(cs441-load "sets.scm")
(cs441-load "parser.scm")

(define make-empty
  (lambda ()
    (lambda (x) #f)))

(define extend
  (lambda (f d r)
    (lambda (x)
      (if (eq? x d)
          r
          (f x)))))

(define lookup
  (lambda (f x)
    (f x)))

(define extend-list
  (lambda (env doms rans)
    (if (null? doms)
        env
        (extend-list
          (extend env (car doms) (car rans))
          (cdr doms) 
          (cdr rans)))))

(define firsts
  (lambda (lst)
    (map car lst)))

(define seconds
  (lambda (lst)
    (map cadr lst)))

(define last 
  (lambda (lst)
    (cond ((null? lst) '())
          ((null? (cdr lst)) (car lst))
          (else (last (cdr lst))))))

(define-record Boxrep (unbox set-box!))

(define make-box 
  (lambda (v)
    (make-Boxrep
      (lambda () v)
      (lambda (new) (set! v new)))))

(define unbox
  (lambda (b)
    ((Boxrep->unbox b))))

(define set-box!
  (lambda (b v)
    ((Boxrep->set-box! b) v)))    

(define primitives
  (list
    (list 'not     not)
    (list 'symbol? symbol?)
    (list 'number? number?)
    (list 'null?   null?)
    (list 'pair?   pair?)
    (list 'car     car)
    (list 'cdr     cdr)
    (list 'zero?   zero?)
    (list 'eq?     eq?)
    (list 'equal?  equal?)
    (list '=       =)
    (list 'cons    cons)
    (list '+       +)
    (list '*       *)
    (list '-       -)
    (list '/       /)))
    
(define initial-env
  (extend-list (make-empty)
    (firsts primitives)
    (map (lambda (p)
           (make-box (lambda (k . args) (k (apply p args)))))
         (seconds primitives))))

(define initial-cont
  (lambda (x) x))

(define mapLR-cps
  (lambda (f l k)
    (if (null? l) 
        (k '())
        (f (car l)
           (lambda (x)
             (mapLR-cps f (cdr l)
               (lambda (v)
                 (k (cons x v)))))))))

(define interp
  (lambda (e env k)
    (variant-case e
      (Const (value)
        (k value))
      (Var (name)
        (k (unbox (lookup env name))))
      (Lam (formals body) 
	(k (lambda (k2 . args)
             (interp body
               (extend-list env formals (map make-box args))
               k2))))
      (Ap (fun args)
	(interp fun env
          (lambda (vfun)
            (mapLR-cps (lambda (e k2) (interp e env k2)) args
              (lambda (vargs)
                (apply vfun (cons k vargs)))))))
      (Beg (exprs)
        (mapLR-cps (lambda (e k2) (interp e env k2))
          exprs
          (lambda (vexprs)
            (k (last vexprs)))))
      (Set! (name body) 
	(interp body env
	  (lambda (v) (k (set-box! (lookup env name) v)))))
      (If (test then else)
	(interp test env
          (lambda (v)
            (interp (if v then else) env k))))
      (Let (bindings body)
        (interp (make-Ap
                  (make-Lam
                    (firsts bindings)
                    body)
                  (seconds bindings))
          env
          k))
      (Let* (bindings body)
        (if (null? bindings)
            (interp body env k)
            (let ((x (car (car bindings)))
                  (e (cadr (car bindings)))
                  (rest (cdr bindings)))
              (interp (make-Ap
                        (make-Lam (list x)
                          (make-Let* rest body))
                        (list e))
                env
                k))))
      (Letrec (bindings body)
        (let* ((boxes (map make-box (firsts bindings)))
               (newenv (extend-list env (firsts bindings) boxes)))
          (mapLR-cps
            (lambda (e k)
              (interp e newenv k))
            (seconds bindings)
            (lambda (vals)
              (for-each set-box! boxes vals)
              (interp body newenv k)))))
      (Abort (body)
        (interp body env initial-cont))
      (Let/cc (name body)
	(interp body 
	  (extend env name 
	    (make-box (lambda (k2 arg) (k arg))))
          k)))))

(define eval
  (lambda (sexp)
    (interp (parse sexp) initial-env initial-cont)))