(load "record.ss")

;;; 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 let (vars exps body))
(define-record letrecproc (vars formalss exps body))
(define-record begin (exps))
(define-record set! (var exp))
(define-record call/cc (exp))

;;; 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 ((decls (cadr exp)))
	     (make-letrecproc (map car decls)
	       (map cadr decls)
	       (map (lambda (decl) (recordify (caddr decl))) decls)
	       (recordify (caddr exp)))))
	  ((begin) (make-begin (map recordify (cdr exp))))
	  ((set!) (make-set! (cadr exp) (recordify (caddr exp))))
	  ((call/cc) (make-call/cc (recordify (cadr exp))))
	  (else
	    (make-app (recordify (car exp)) (map recordify (cdr exp)))))))))

;;; Value records

(define-record closure (formals body env))
(define-record cont (k))

;;; Environment ADT

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

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

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

;;; Cell ADT

(define make-cell (lambda (x) (vector x)))
(define cell-ref (lambda (c) (vector-ref c 0)))
(define cell-set! (lambda (c v) (vector-set! c 0 v)))

;;; Initial environment

(define null (lambda (x) (if (null? x) 1 0)))
(define zero (lambda (x) (if (zero? x) 1 0)))
(define equal (lambda (x y) (if (= x y) 1 0)))
(define less (lambda (x y) (if (< x y) 1 0)))
(define greater (lambda (x y) (if (> x y) 1 0)))
  
(define init-env
  (extend-env
    '(equal zero less greater emptylist)
    (list equal zero less greater '())
    (extend-env
      '(+ - * add1 sub1 cons car cdr list null)
      (list + - * add1 sub1 cons car cdr list null)
      (create-empty-env))))

;;; Interpreter

(define apply-proc
  (lambda (rator rands k)
    (variant-case rator
      (closure (formals body env)
	(eval-exp body (extend-env formals rands env) k))
      (cont (k) (k (car rands)))
      (else (k (apply rator rands))))))

(define eval-rands
  (lambda (exps env k)
    (cond
      ((null? exps) (k '()))
      (else
	(eval-exp (car exps) env
	  (lambda (exp)
	    (eval-rands (cdr exps) env
	      (lambda (exps)
		(k (cons exp exps))))))))))

(define eval-exp
  (lambda (exp env k)
    (variant-case exp
      (num (val) (k val))
      (varref (var) (k (cell-ref (apply-env env var))))
      (lambda (formals body) (k (make-closure formals body env)))
      (let (vars exps body)
	(eval-rands exps env
	  (lambda (rands)
	    (eval-exp body
	      (extend-env vars rands env)
	      k))))
      (app (operator operands)
	(eval-exp operator env
	  (lambda (proc)
	    (eval-rands operands env
	      (lambda (args) (apply-proc proc args k))))))
      (if (test then else)
	(eval-exp test env
	  (lambda (test)
	    (if (= test 0)
		(eval-exp else env k)
		(eval-exp then env k)))))
      (begin (exps)
	(eval-rands exps env
	  (lambda (vals) (k (car (reverse vals))))))
      (letrecproc (vars formalss exps body)
	(eval-exp
	  (make-let vars (map (lambda (_) (make-num 0)) vars)
	    (make-begin
	      `(,@(map
		    (lambda (var fs exp) (make-set! var (make-lambda fs exp)))
		    vars
		    formalss
		    exps)
		,body)))
	  env
	  k))
      (set! (var exp)
	(eval-exp exp env
	  (lambda (v)
	    (k (cell-set! (apply-env env var) v)))))
      (call/cc (exp)
	(eval-exp exp env
	  (lambda (proc)
	    (apply-proc proc (list (make-cont k)) k))))
      (else (error 'eval-exp "invalid syntax tree: ~s" exp)))))

(define et1
  (lambda (exp)
    (pretty-print exp)
    (printf "~n==>~n~n~s~n~n" (eval-exp (recordify exp) init-env (lambda (v) v)))))
			 
(define test
  (lambda (file eval-test)
    (let ((ip (open-input-file file)))
      (let loop ((x (read ip)))
	(unless (eof-object? x)
	  (eval-test x)
	  (loop (read ip))))
      (close-input-port ip))))