(define (withdraw! amt)
   (if (<= amt account)
       (set! account (- account amt))
       (writeln "sorry, insufficient funds"))
   'done)

(define (deposit! amt)
   (set! account (+ account amt))
   'done)

; account is a formal parameter
(define (deposit! account amt)
   (set! account (+ account amt))
  &nbspdone)

; selector:
(define (balance pswrd account)
   (if (eq? pswrd (car account))
       (cdr account)
       (writeln "access denied")))

(define (set-password! new-password
                      old-password
                      account)
   (if (eq? old-password (car account))
       (set-car! account new-password)
       (writeln "access denied"))
   'done)

(define (withdraw! pswrd amt account)
   (cond
      ((not (eq? pswrd (car acct)))
         (writeln "access denied"))
      ((>= (balance account) amt)
          (set-cdr! account (- (balance account) amt))
       (else (writeln "sorry, insufficient funds")))
   'done)

(define (deposit! pswrd amt account)
   (if (eq? pswrd (car account))
       (set-cdr! account (- (balance account) amt))
       (writeln "access denied"))
   'done)

LOCATION ::= (loc . NATURAL)

REFERENCE ::=
  &nbspLOCATION | (LOCATION . LOCATION) | #(LOCATION ...)

(define (loc n)
   (if (natural? n)
      (cons 'loc n)
      (error "bad input" loc n)))

(define (location? val)
   (and (pair? val) (eqv? (car val) 'loc)))

(define index cdr) ; extracts int from loc

(define (reference? val)
   (or (location? val)
       (and (pair? val)
            (reference? (car val))
            (reference? (cdr val)))
       (and (vector? val)
            (all? reference? (vector->list val)))))

Stores

STORE ::= #(STORABLE ...)

(define (make-store capacity)
   (if (natural? capacity)
      (make-vector capacity free)
      (error "bad input" make-store capacity)))

(define capacity vector-length)

(define free 'free)
(define alloc 'alloc)

(define store? vector?)

(define (storable? val)
   (or (null? val)
       (number? val)
       (char? val)
       (boolean? val)
    (symbol? val)
       (procedure? val)
       (reference? val)))

(define (free? store loc)
(eqv? free (vector-ref store (cdr loc))))

(define (accessible? store loc)
   (and (store? store)
       (location? loc)
       (<= (index loc) (capacity store))
       (not (free? store loc))))

Reading, Writing, and Allocating Locations

(define (read-loc store loc)
   (if (accessible? store loc)
       (vector-ref store (cdr loc))
       (error "bad location" read-loc loc)))

(define (write-loc! store loc val)
   (if (and (accessible? store loc) (storable? val))
       (vector-set! store (cdr loc) val)
       (error "bad input(s)" write-loc! loc val)))

; = a location-store pair
(define (alloc-loc! store env)
   (define (search next store)...)
   (define i (search 0 store))
   (vector-set! store i alloc)
   (cons (loc i) store))

(define (search next store)
   (define cap (capacity store))
   (cond
      ((>= next cap) (search 0 (gc store env)))
      ((free? store (loc next)) next)
      (else (search (+ next 1) store))))

Reading and Writing References

(define (read-ref store ref)
   (cond
      ((location? ref)
         (read-ref store (read-loc store ref)))
      ((and (reference? ref) (pair? ref))
         (read-pair store ref))
      ((and (reference? ref) (vector? ref))
         (read-vector store ref))
      (else ref)))

(define (read-pair store ref)
   (cons (read-ref store (car ref))
         (read-ref store (cdr ref))))

(define (read-vector store ref)
   (define (read-list refs vals) ...)
   (list->vector (read-list (vector->list ref) '())))

(define (read-list refs vals)
   (if (null? refs)
     &nbspvals
      (let ((val (read-ref store (car refs))))
         (read-list (cdr refs)
                   (cons-last val vals)))))

(define (write-ref! store ref val)
   (cond
      ((location? ref) (write-loc! store ref val))
      ((and (pair? ref) (pair? val))
         (write-pair! store ref val))
      ((and (vector? ref) (vector? val))
         (write-vector! store ref val))
      (else
         (error "bad input(s)" write-ref! ref val))))

(define (write-pair! store ref pair)
   (define new-store
      (write-ref! store (car ref) (car pair)))
   (write-ref! new-store (cdr ref) (cdr pair)))

(define (write-vector! store ref vec)
   (define (write-list! store refs vals) ...)
   (write-list!
     &nbspstore (vector->list ref) (vector->list vec)))

(define (write-list! store refs vals)
   (if (null? vals)
     &nbspstore
      (let
         ((new-store
            (write-ref! store (car refs) (car vals))))
         (write-list!
           &nbspnew-store (cdr refs) (cdr vals)))))

Allocating References

(define (alloc-ref! store env val)
   (cond ((pair? val) (alloc-pair! val store env))
         ((vector? val) (alloc-vector! val store env))
         (else (alloc-loc! store env))))

(define (alloc-pair! pair store env)
   (define loc1.store1
      (alloc-ref! store (car pair) env))
   (define loc1 (car loc1.store1))
   (define store1 (cdr loc1.store1))
   (define loc2.store2
      (alloc-ref! store1 (cdr pair) env))
   (define loc2 (car loc2.store2))
   (define store2 (cdr loc2.store2))
   (cons (cons loc1 loc2) store2))

(define (alloc-vector! vec store env)
   (define (iter-alloc i locs store) ...)
   (iter-alloc 0 '() store))

(define (iter-alloc i locs store)
   (define len (vector-length vec))
   (if (>= i len)
      (cons (list->vector locs) store)
      (let*
          ((loc1.store1
            (alloc-ref! store env (vector-ref vec i)))
          (loc1 (car loc1.store1))
          (store1 (cdr loc1.store1)))
         (iter-alloc (+ i 1)
                     (cons-last loc1 locs) store1))))

Garbage Collection

(define (gc store env)
   (define locs
      (get-locs
         (filter not-ref?
            (map cdr (apply append env))))
   (writeln "garbage collection commencing ...")
   (writeln tab "mark phase commencing ...")
   (mark! store locs)
   (writeln tab "sweep phase commencing ...")
   (sweep! store))

(define (not-ref? val) (not (reference? val)))

(define (get-locs refs)
   (apply append (map ref->locs refs)))

(define (ref->locs ref)
   (cond
      ((location? ref) (list loc))
      ((pair? ref) (list (car ref) (cdr ref)))
      ((vector? ref) (vector->list ref))))

(define (mark! store locs)
   (if (null? locs)
     &nbspstore
      (let* ((i (cdar locs))
            (val (vector-ref store i)))
         (vector-set! store i (mark val))
         (if (reference? val)
            (mark! store
               (append (cdr locs)
                      (reference->locs val)))
            (mark! store (cdr locs))))))

(define (mark val)
   (if (marked? val)
     &nbspval
       (cons 'marked val)))

(define (sweep! store)
   (define cap (capacity store))
   (define (iter-sweep i store success)...)
   (iter-sweep 0 store #f))

(define (iter-sweep i store success)
   (if (<= cap i)
      (if success store (error "out of memory" gc))
      (let* ((val (vector-ref store i))
             (new-val
               (if (marked? val) (unmark val) free))
             (suc (or success (eqv? new-val free)))
         (vector-set! store i new-val)
         (iter-sweep (+ i 1) store suc)))))

(define (marked? val)
   (and (pair? val) (eqv? (car val) 'marked)))

(define (unmark val)
   (if (marked? val)
      (cdr val)
     &nbspval))

(define (make-sstore storables)
   (cons '() storables))

(define (end? sstore)
   (null? (cdr sstore)))

(define (init-sstore! sstore)
   (define seen (car sstore))
   (define unseen (cdr sstore))
   (set-cdr! sstore (append seen unseen))
   (set-car! sstore '())
   'done)

(define (read-next! sstore)
   (define seen (car sstore))
   (define unseen (cdr sstore))
   (define val (car unseen))
   (set-cdr! sstore (cdr unseen))
   (set-car! sstore (append seen (list val)))
  &nbspval)

(define (write-next! sstore storable)
   (set-car! sstore
      (append (car sstore) (list storable)))
   'done)

(() . (#\4 #\2 #\space #\1 #\9 eof))

Creating Ports

((#\4 #\2) . (#\space #\1 #\9 eof))

((#\4 #\2 #\space #\1 #\9) . (eof))

((#\4 #\2 #\space #\1 #\9 eof) . ())

Example: Files to Lists

(define (file->list file)
   (define port (open-input-file file))
   (do ((next (safe-read port) (safe-read port))
       (vals '() (cons next vals)))
       ((eof-object? next)
            (close-input-port port)
            (reverse vals))))

(define (file->sstore file)
   (make-sstore (file->list file)))

(define (port->stream port)
   (cons-stream (safe-read port) (port->stream port)))

Example: Changing Case

(define (file-upcase source-file dest-file)
   (define sport (open-input-file source-file))
   (define dport (open-output-file dest-file))
   (do ((next (read-char sport) (read-char sport)))
       ((eof-object? next)
             (close-input-port sport)
            (close-output-port dport)
            'done))
       (write-char (char-upcase next) dport)))