;; PJ Waskiewicz
;; interpreter.scm
;; A really weird interpreter

(load "ff.scm")
(load "parser.scm")

(define cell-tag "cell")

(define make-cell
  (lambda (x)
    (vector cell-tag x)))

(define cell?
  (lambda (x)
    (and (vector? x)
         (= (vector-length x) 2)
         (eq? (vector-ref x 0) cell-tag))))

(define cell-ref
  (lambda (x)
    (if (cell? x)
        (vector-ref x 1)
        (error "Invalid argument to cell-ref:" x))))

(define cell-set!
  (lambda (x value)
    (if (cell? x) 
        (vector-set! x 1 value)
        (error "Invalid argument to cell-set!:" x))))

(define eval-rator
  (lambda (rator env)
    (eval-exp rator env)))

(define eval-rands
  (lambda (rands env)
    (map (lambda (rand) (eval-exp rand env)) rands)))

(define cell-swap!
  (lambda (cell-1 cell-2)
    (let ((temp (cell-ref cell-1)))
      (cell-set! cell-1 (cell-ref cell-2))
      (cell-set! cell-2 temp))))

(define make-array
  (lambda (dimension)
    (let ((array (make-cell (make-vector (+ dimension 1)))))
      (vector-set! (cell-ref array) 0 '*array*)
      array)))

(define array?
  (lambda (x)
    (and (cell? x) (eq? (vector-ref (cell-ref x) 0) '*array*))))

(define array-ref
  (lambda (array index)
    (vector-ref (cell-ref array) (+ index 1))))

(define array-set!
  (lambda (array index value)
    (vector-set! (cell-ref array) (+ index 1) value)))

(define array-whole-set!
  (lambda (dest-array source-array)
    (let ((source-len (vector-length (cell-ref source-array))))
      (letrec 
        ((loop (lambda (n)
                 (if (< n source-len)
                     (begin
                       (vector-set! (cell-ref dest-array) n (vector-ref
                                     (cell-ref source-array n)))
                       (loop (+ n 1)))))))
        (loop 1)))))

(define array-copy
  (lambda (array)
    (let ((new-array (make-array (- (vector-length (cell-ref array)) 1))))
      (array-whole-set! new-array array)
      (make-cell new-array))))

(define compose
  (lambda (f g)
    (lambda (x)
      (f (g x)))))

(define the-empty-env (make-cell (create-empty-ff)))
(define denoted->expressed cell-ref)
(define denoted-value-assign! cell-set!)

(define do-letarray (compose make-cell make-array))

(define expressed->denoted make-cell)
(define extend-env
  (lambda (vals vars env)
    (make-cell (extend-ff* vals vars (cell-ref env)))))
(define apply-env
  (lambda (env var)
    (apply-ff (cell-ref env) var)))
(define prim-op-names '(+ - * add1 sub1 minus cons car cdr list
                          equal zero greater less null eq))
(define-record prim-proc (prim-op))

(define eval-exp
  (lambda (exp env)
    (variant-case exp
      (lit (datum) datum)
      (varref (var) (denoted->expressed (apply-env env var)))
      (app (rator rands)
        (let ((proc (eval-exp rator env))
              (args (map make-cell (eval-rands rands env))))
          (apply-proc proc args)))
      (if (test-exp then-exp else-exp)
        (if (true-value? (eval-exp test-exp env))
            (eval-exp then-exp env)
            (eval-exp else-exp env)))
      (let (decls body)
        (let ((vars (map decl->var decls))
              (exps (map decl->exp decls)))
          (let ((new-env (extend-env vars (map make-cell (eval-rands exps env)) env)))
            (eval-exp body new-env))))
      (proc (formals body)
        (make-closure formals body (make-cell env)))
      (varassign (var exp)
        (denoted-value-assign! (apply-env env var) (eval-exp exp env)))
      (begin (exp1 exp2)
        (begin (eval-exp exp1 env) (eval-exp exp2 env)))
      (letarray (arraydecls body)
        (eval-exp body 
          (extend-env (map decl->var arraydecls)
            (map (lambda (decl)
                   (do-letarray (eval-exp (decl->exp decl) env)))
                 arraydecls)
            env)))
      (arrayref (array index) 
        (array-ref (eval-array-exp array env)
          (eval-exp index env)))
      (arrayassign (array index exp)
        (array-set! (eval-array-exp array env)
          (eval-exp index env) 
          (eval-exp exp env)))
      (else (error "Invalid abstract syntax:" exp)))))

(define eval-array-exp eval-exp)

(define apply-proc
  (lambda (proc args)
    (variant-case proc
          (prim-proc (prim-op)
             (apply-prim-op prim-op
               (map denoted->expressed args)))
          (closure (formals body env)
                   (eval-exp body
             (extend-env formals args (cell-ref env))))
          (else (error "Invalid procedure:" proc)))))

(define apply-prim-op
  (lambda (prim-op args)
    (case prim-op
      ((+) (+ (car args) (cadr args)))
      ((-) (- (car args) (cadr args)))
      ((*) (* (car args) (cadr args)))
      ((add1) (+ (car args) 1))
      ((sub1) (- (car args) 1))
      ((minus) (* (car args) -1))
      ((list) args)
      ((cons) (cons (cell-ref (car args)) (cell-ref (cadr args))))
      ((car) (cell-ref (caar args)))
      ((cdr) (cell-ref (cdar args)))
      ((equal) (if(=? (cell-ref (car args)) (cell-ref (cadr args))) 1 0))
      ((zero) (if(zero? (car args)) 1 0))
      ((greater) (if(>? (cell-ref (car args)) (cell-ref (cadr args))) 1 0))
      ((less) (if(<? (cell-ref (car args)) (cell-ref (cadr args))) 1 0))
      ((null) (if(null? (cell-ref (car args))) 1 0))
      ((eq) (if(eq? (cell-ref (car args)) (cell-ref (cadr args))) 1 0))
      (else (error "Invalid prim-op name:" prim-op)))))

(define true-value?
  (lambda (x)
    (not (zero? x))))

(define init-env 
  (extend-env
    (list 'emptylist)
    (list '())
    (extend-env
     prim-op-names
     (map make-cell (map make-prim-proc prim-op-names))
     the-empty-env)))

(define eval-print
  (lambda (tree)
    (variant-case tree
          (define (var exp)
            (let ((result (eval-exp exp init-env))
                  (foo (apply-env init-env var)))
              (if (eq? foo '*fail*)
                  (variant-case exp
                        (proc (formals body)
                              (cell-set! init-env (cell-ref (extend-env
                               (list var) (list (make-cell '*dummy*))
                                init-env)))
                              (cell-set! (apply-env init-env var)
                                         (eval-exp exp init-env)))
                        (else
                         (cell-set! init-env (cell-ref (extend-env (list var)
                                (list (make-cell result)) init-env))))))))
          (else
           (let ((result (eval-exp tree init-env)))
             (write result))))))