(load "record.ss")

;;; For loop

(define for
  (lambda (start end proc)
    (unless (>= start end)
      (proc start)
      (for (+ start 1) end proc))))


;;; Expression records

(define-record num (val))
(define-record varref (var))
(define-record lambda (formals body))
(define-record app (operator operands))
(define-record if (test then else))
(define-record letrecproc (var formals exp body))
(define-record let (vars exps body))


;;; Recordifier (aka Parser)

(define recordify
  (lambda (exp)
    (cond
      ((number? exp) (make-num exp))
      ((symbol? exp) (make-varref exp))
      ((atom? exp) (error 'recordify "illegal expression ~s" exp))
      (else
	(case (car exp)
	  ((lambda)
	   (make-lambda (cadr exp) (recordify (caddr exp))))
	  ((if)
	   (make-if (recordify (cadr exp)) (recordify (caddr exp))
	     (recordify (cadddr exp))))
	  ((let)
	   (let ((vars (map car (cadr exp))) (exps (map cadr (cadr exp))))
	     (let ((exps (map recordify exps)))
	       (make-let vars exps (recordify (caddr exp))))))
	  ((letrecproc)
	   (let ((decl (cadr exp)))
	     (make-letrecproc
	       (car decl)
	       (cadr decl)
	       (recordify (caddr decl))
	       (recordify (caddr exp)))))
	  (else
	    (make-app (recordify (car exp)) (map recordify (cdr exp)))))))))


;;; Environment ADT

(define create-empty-env (lambda () '()))

(define extend-env
  (lambda (vars vals env)
    (append (map cons vars vals) env)))

(define apply-env
  (lambda (env var)
    (cond
      ((assq var env) => cdr)
      (else (error 'apply-env "variable ~s is undefined" var)))))


;;; Heap ADT

(define-record mcell (mark ptr))
(define HEAP-SIZE 120)
(define the-store (make-vector HEAP-SIZE 'free))

(define mark-cell
  (lambda (adr boolean)
    (let ((cell (vector-ref the-store adr)))
      (vector-set! the-store adr (make-mcell boolean (mcell->ptr cell))))))

(define marked?
  (lambda (adr)
    (let ((cell (vector-ref the-store adr)))
      (and (mcell? cell) (mcell->mark cell)))))

(define free-cell
  (lambda (adr)
    (vector-set! the-store adr 'free)))

(define free?
  (lambda (adr)
    (eq? (vector-ref the-store adr) 'free)))

(define apply-store 
  (lambda (adr)
    (mcell->ptr (vector-ref the-store adr))))

(define update-store 
  (lambda (adr ptr)
    (vector-set! the-store adr (make-mcell #f ptr))))

(define allocate
  (lambda (ptrs sk fk)
    (let loop ((i 0) (ptrs ptrs) (adrs '()))
      (cond
	((null? ptrs) (sk (reverse adrs)))
	((= i HEAP-SIZE) (for-each free-cell adrs) (fk))
	((free? i)
	 (update-store i (car ptrs))
	 (loop (+ i 1) (cdr ptrs) (cons i adrs)))
	(else (loop (+ i 1) ptrs adrs))))))


;;; Pointer ADT

(define-record ppair (address))
(define-record pnum (val))
(define-record pnull ())
(define-record pclosure (address))
(define-record pprim (proc))
(define-record penv-cell (env-cell))

(define decode-ptr
  (lambda (ptr)
    (variant-case ptr
      (pnum (val) val)
      (pnull () '())
      (pclosure (address) '<procedure>)
      (pprim (proc) '<primitive-procedure>)
      (ppair (address)
	(cons (decode-ptr (apply-store address))
	  (decode-ptr (apply-store (+ address 1)))))
      (else (error 'decode-ptr "invalid pointer ~s" ptr)))))

(define decode-closure-at-address
  (lambda (address k)
    (let ((size (apply-store address)))
      (k
	(apply-store (+ address 1))
	(apply-store (+ address 2))
	(let loop ((adr (+ address 3)) (i 0))
	  (cond
	    ((= i size) '())
	    (else
	      (cons (penv-cell->env-cell (apply-store adr))
		(loop (+ adr 1) (+ i 1))))))))))


;;; Memory allocation procedures

(define make-closure
  (lambda (formals body env)
    (let ((ptrs `(,(length env) ,formals ,body ,@(map make-penv-cell env))))
      (allocate ptrs
	(lambda (adrs) (make-pclosure (car adrs)))
	(lambda ()
	  (gc env)
	  (allocate ptrs
	    (lambda (adrs) (make-pclosure (car adrs)))
	    (lambda () (error 'make-closure "not enough memory"))))))))

(define make-pair
  (lambda (env ptr1 ptr2)
    (let ((ptrs (list ptr1 ptr2)))
      (allocate ptrs
	(lambda (adrs) (make-ppair (car adrs)))
	(lambda ()
	  (gc env)
	  (allocate ptrs
	    (lambda (adrs) (make-ppair (car adrs)))
	    (lambda () (error 'make-pair "not enough memory"))))))))


;;; List and number manipulation procedures

(define tt (make-pnum 1))
(define ff (make-pnum 0))

(define true-value?
  (lambda (ptr)
    (variant-case ptr
      (pnum (val) (not (zero? val)))
      (else #t))))

(define zero
  (lambda (env ptr)
    (variant-case ptr
      (pnum (val) (if (zero? val) tt ff))
      (else (error 'zero "~s is not a number" (decode-ptr ptr))))))

(define equal
  (lambda (env ptr1 ptr2)
    (cond
      ((and (pnum? ptr1) (pnum? ptr2))
       (if (= (pnum->val ptr1) (pnum->val ptr2)) tt ff))
      ((pnum? ptr1) (error 'equal "~s is not a number" (decode-ptr ptr2)))
      (else (error 'equal "~s is not a number" (decode-ptr ptr1))))))

(define less
  (lambda (env ptr1 ptr2)
    (cond
      ((and (pnum? ptr1) (pnum? ptr2))
       (if (< (pnum->val ptr1) (pnum->val ptr2)) tt ff))
      ((pnum? ptr1) (error 'equal "~s is not a number" (decode-ptr ptr2)))
      (else (error 'less "~s is not a number" (decode-ptr ptr1))))))

(define greater
  (lambda (env ptr1 ptr2)
    (cond
      ((and (pnum? ptr1) (pnum? ptr2))
       (if (> (pnum->val ptr1) (pnum->val ptr2)) tt ff))
      ((pnum? ptr1) (error 'equal "~s is not a number" (decode-ptr ptr2)))
      (else (error 'greater "~s is not a number" (decode-ptr ptr1))))))

(define addone
  (lambda (env ptr)
    (variant-case ptr
      (pnum (val) (make-pnum (add1 val)))
      (else (error 'add1 "~s is not a number" (decode-ptr ptr))))))

(define subone
  (lambda (env ptr)
    (variant-case ptr
      (pnum (val) (make-pnum (sub1 val)))
      (else (error 'sub1 "~s is not a number" (decode-ptr ptr))))))

(define plus
  (lambda (env ptr1 ptr2)
    (cond
      ((and (pnum? ptr1) (pnum? ptr2))
       (make-pnum (+ (pnum->val ptr1) (pnum->val ptr2))))
      ((pnum? ptr1) (error 'equal "~s is not a number" (decode-ptr ptr2)))
      (else (error '+ "~s is not a number" (decode-ptr ptr1))))))

(define minus
  (lambda (env ptr1 ptr2)
    (cond
      ((and (pnum? ptr1) (pnum? ptr2))
       (make-pnum (- (pnum->val ptr1) (pnum->val ptr2))))
      ((pnum? ptr1) (error 'equal "~s is not a number" (decode-ptr ptr2)))
      (else (error '- "~s is not a number" (decode-ptr ptr1))))))

(define times
  (lambda (env ptr1 ptr2)
    (cond
      ((and (pnum? ptr1) (pnum? ptr2))
       (make-pnum (* (pnum->val ptr1) (pnum->val ptr2))))
      ((pnum? ptr1) (error 'equal "~s is not a number" (decode-ptr ptr2)))
      (else (error '* "~s is not a number" (decode-ptr ptr1))))))

(define fst
  (lambda (env ptr)
    (variant-case ptr
      (ppair (address) (apply-store address))
      (else (error 'car "~s is not a pair" (decode-ptr ptr))))))

(define snd
  (lambda (env ptr)
    (variant-case ptr
      (ppair (address) (apply-store (+ address 1)))
      (else (error 'cdr "~s is not a pair" (decode-ptr ptr))))))

(define setcar
  (lambda (env ptr1 ptr2)
    (variant-case ptr1
      (ppair (address) (update-store address ptr2))
      (else (error 'set-car! "~s is not a pair" (decode-ptr ptr))))))

(define setcdr
  (lambda (env ptr1 ptr2)
    (variant-case ptr1
      (ppair (address) (update-store (+ address 1) ptr2))
      (else (error 'set-cdr! "~s is not a pair" (decode-ptr ptr))))))

(define null
  (lambda (env ptr)
    (if (pnull? ptr) tt ff)))


;;; Initial environment

(define init-env
  (extend-env
    '(+ - * add1 sub1 cons set-car!)
    (map make-pprim (list plus minus times addone subone make-pair setcar))
    (extend-env
      '(zero less greater car cdr null equal set-cdr!)
      (map make-pprim (list zero less greater fst snd null equal setcdr))
      (extend-env '(emptylist) (list (make-pnull)) (create-empty-env)))))


;;; Garbage collector

(define mark
  (lambda (ptr)
    (variant-case ptr
      (pnum (val) (void))
      (pnull () (void))
      (pprim (proc) (void))
      (pclosure (address)
	(unless (marked? address)
	  (mark-cell address #t)
	  (mark-cell (+ address 1) #t)
	  (mark-cell (+ address 2) #t)
	  (for (+ address 3) (+ address 3 (apply-store address))
	    (lambda (i)
	      (mark-cell i #t)
	      (let ((x (apply-store i)))
		(variant-case x
		  (penv-cell (env-cell) (mark (cdr env-cell)))
		  (else (error 'gc "environment cell expected ~s" x))))))))
      (ppair (address)
	(unless (marked? address)
	  (mark-cell address #t)
	  (mark-cell (+ address 1) #t)
	  (mark (apply-store address))
	  (mark (apply-store (+ address 1)))))
      (else (error 'gc "invalid pointer ~s" ptr)))))

(define sweep
  (lambda ()
    (for 0 HEAP-SIZE
      (lambda (i)
	(if (marked? i)
	    (mark-cell i #f)
	    (begin
	      (printf "freeing cell ~s: ~s~n" i (vector-ref the-store i))
	      (free-cell i)))))))

(define gc
  (lambda (env)
    (for-each (lambda (x) (mark (cdr x))) env)
    (sweep)))


;;; Interpreter

(define apply-proc
  (lambda (proc args env)
    (variant-case proc
      (pclosure (address)
	(decode-closure-at-address address
	  (lambda (formals body env)
	    (eval-exp body (extend-env formals args env)))))
      (pprim (proc) (apply proc env args))
      (else (error "~s is not a procedure" (decode-ptr proc))))))

(define eval-rands
  (lambda (vars exps env k)
    (cond
      ((null? exps) (k '() env))
      (else
	(let ((x (eval-exp (car exps) env)))
	  (eval-rands (cdr vars) (cdr exps)
	    (extend-env (list (car vars)) (list x) env)
	    (lambda (exps env) (k (cons x exps) env))))))))

(define eval-exp
  (lambda (exp env)
    (variant-case exp
      (num (val) (make-pnum val))
      (varref (var) (apply-env env var))
      (lambda (formals body) (make-closure formals body env))
      (let (vars exps body)
	(eval-rands vars exps env (lambda (_ env) (eval-exp body env))))
      (if (test then else)
	  (if (true-value? (eval-exp test env))
	      (eval-exp then env)
	      (eval-exp else env)))
      (letrecproc (var formals exp body)
	(let ((tmpenv (extend-env (list var) (list ff) env)))
	  (let ((closure (make-closure formals exp tmpenv)))
	    (update-store (+ (pclosure->address closure) 3)
	      (make-penv-cell (cons var closure)))
	    (eval-exp body (extend-env (list var) (list closure) env)))))
      (app (operator operands)
	(let ((exps (cons operator operands)))
	  (eval-rands (map (lambda (_) (gensym)) exps) exps env
	    (lambda (exps env)
	      (apply-proc (car exps) (cdr exps) env))))))))

(define repl
  (lambda ()
    (printf "--> ")
    (let ((x (read)))
      (printf "~s~n" (decode-ptr (eval-exp (recordify x) init-env)))
      (repl))))