(let ((time-stamp "Time-stamp: <2001-08-03 13:00:35 dfried>"))
  (eopl:printf "3-8need.scm - interp with call by need ~a~%"
    (substring time-stamp 13 29)))

;;;;;;;;;;;;;;;; top level and tests ;;;;;;;;;;;;;;;;

(define run
  (lambda (string)
    (eval-program (scan&parse string))))

(define run-all
  (lambda ()
    (run-experiment run use-execution-outcome
      '(lang3-1 lang3-5 lang3-6 lang3-7 lang3-8need) all-tests)))

(define run-one
  (lambda (test-name)
    (run-test run test-name)))

;; needed for testing
(define equal-external-reps? equal?)

;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;

(define the-lexical-spec
  '((whitespace (whitespace) skip)
    (comment ("%" (arbno (not #\newline))) skip)
    (identifier
      (letter (arbno (or letter digit "_" "-" "?")))
      symbol)
    (number (digit (arbno digit)) number)))

(define the-grammar
  '((program (expression) a-program)
    (expression (number) lit-exp)
    (expression (identifier) var-exp)   
    (expression
      (primitive "(" (separated-list expression ",") ")")
      primapp-exp)
    (expression
      ("if" expression "then" expression "else" expression)
      if-exp)
   (expression
      ("let" (arbno  identifier "=" expression) "in" expression)
      let-exp)
    (expression
      ("proc" "(" (separated-list identifier ",") ")" expression)
      proc-exp)
    (expression
      ("(" expression (arbno expression) ")")
      app-exp)
    (expression ("set" identifier "=" expression) varassign-exp)
    (expression
      ("begin" expression (arbno ";" expression) "end")
      begin-exp)
    (expression                         
      ("letrec"
        (arbno identifier "(" (separated-list identifier ",") ")"
          "=" expression)
        "in" expression)
      letrec-exp)

    (primitive ("+")     add-prim)
    (primitive ("-")     subtract-prim)
    (primitive ("*")     mult-prim)
    (primitive ("add1")  incr-prim)
    (primitive ("sub1")  decr-prim)
    (primitive ("zero?") zero-test-prim)

    ))

(sllgen:make-define-datatypes the-lexical-spec the-grammar)

(define show-the-datatypes
  (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))

(define scan&parse
  (sllgen:make-string-parser the-lexical-spec the-grammar))

(define just-scan
  (sllgen:make-string-scanner the-lexical-spec the-grammar))

;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;

(define eval-program 
  (lambda (pgm)
    (cases program pgm
      (a-program (body)
        (eval-expression body (init-env))))))

(define eval-expression                 ; exp x env -> expval
  (lambda (exp env)
    (cases expression exp
      (lit-exp (datum) datum)
      (var-exp (id) (apply-env env id))
      (varassign-exp (id rhs-exp)
        (begin
          (setref! 
            (apply-env-ref env id)
            (eval-expression rhs-exp env))
          1))
      (primapp-exp (prim rands)
        (let ((args (eval-primapp-exp-rands rands env)))
          (apply-primitive prim args)))
      (if-exp (test-exp true-exp false-exp)
        (if (true-value? (eval-expression test-exp env))
          (eval-expression true-exp env)
          (eval-expression false-exp env)))
      (proc-exp (ids body) (closure ids body env))
      (begin-exp (exp1 exps)
        (let loop ((acc (eval-expression exp1 env))
                   (exps exps))
          (if (null? exps) acc
            (loop (eval-expression (car exps) env) (cdr exps)))))
      (let-exp (ids rands body)
        (let ((args (eval-let-exp-rands rands env)))
          (eval-expression body (extend-env ids args env))))
      (app-exp (rator rands)
        (let ((proc (eval-expression rator env))
              (args (eval-rands rands env)))
          (if (procval? proc)
            (apply-procval proc args)
            (eopl:error 'eval-expression
              "Attempt to apply non-procedure ~s" proc))))
      (letrec-exp (proc-names idss bodies letrec-body)
        (eval-expression letrec-body
          (extend-env-recursively proc-names idss bodies env)))     
      )))

(define eval-primapp-exp-rands
  (lambda (rands env)
    (map (lambda (x) (eval-expression x env)) rands)))

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

(define eval-let-exp-rand
  (lambda (rand env)
    (direct-target (eval-expression rand env))))

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

(define eval-rand
  (lambda (rand env)
    (cases expression rand
      (var-exp (id) 
        (let ((ref (apply-env-ref env id)))
          (indirect-target
            (cases target (primitive-deref ref)
              (direct-target (expval) ref)
              (indirect-target (ref1) ref1)
              (thunk-target (exp env) ref)))))   ;\new5
      (lit-exp (datum) (direct-target datum))      
      (proc-exp (ids body)                       
        (direct-target (closure ids body env)))
      (else (thunk-target rand env)))))          

; version wrapped for debugging
; (define eval-rand
;   (lambda (rand env)
; ;    (eopl:printf "eval-rand: rand = ~s ~%" rand)
; ;    (eopl:pretty-print (printable-env env))
;     (let ((ans (cases expression rand
;                  (lit-exp (datum) (direct-target datum))
;                  (var-exp (id) 
;                    (let ((ref (apply-env-ref env id)))
;                      (cases target (primitive-deref ref)
;                        (direct-target (expval)
;                          (indirect-target ref))
;                        (indirect-target (ref1)
;                          (indirect-target ref1))
;                        (thunk-target (exp env)
;                          (indirect-target ref)))))
;                  (proc-exp (ids body)
;                    (direct-target (closure ids body env)))
;                  (else (thunk-target rand env)))))
; ;      (eopl:printf "eval-rand succeeded ~%")
;       ans)))


(define apply-primitive
  (lambda (prim args)
    (cases primitive prim
      (add-prim  () (+ (car args) (cadr args)))
      (subtract-prim () (- (car args) (cadr args)))
      (mult-prim  () (* (car args) (cadr args)))
      (incr-prim  () (+ (car args) 1))
      (decr-prim  () (- (car args) 1))
      (zero-test-prim () (if (zero? (car args)) 1 0))
      )))

(define init-env 
  (lambda ()
    (extend-env
      '(i v x)
      (map direct-target '(1 5 10))
      (empty-env))))

;;;;;;;;;;;;;;;; booleans ;;;;;;;;;;;;;;;;

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

;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;

(define-datatype procval procval?
  (closure 
    (ids (list-of symbol?)) 
    (body expression?)
    (env environment?)))

(define apply-procval
  (lambda (proc args)
    (cases procval proc
      (closure (ids body env)
        (eval-expression body (extend-env ids args env))))))
               
;;;;;;;;;;;;;;;; references ;;;;;;;;;;;;;;;;

;; a reference is a pointer to a vector containing targets.

;; the order of fields is funny, but leads to easier debugging.

(define-datatype reference reference?
  (a-ref                                
    (position integer?)
    (vec (vector-of target?))))

(define-datatype target target?
  (direct-target
    (expval expval?))
  (indirect-target
    (ref ref-to-direct-target?))
  (thunk-target   ;\new3   
    (exp expression?)
    (env environment?))) 
    
(define expval?
  (lambda (x)
    (or (number? x) (procval? x))))

(define vector-of                       ; ignores argument
  (lambda (pred) vector?))

(define ref-to-direct-target?
  (lambda (x)
    (and
      (reference? x) 
      (cases reference x
        (a-ref (pos vec)
          (cases target (vector-ref vec pos)
            (direct-target (v) #t)
            (indirect-target (p) #f)
            (thunk-target (exp env) #t))))))) ;\new1

(define primitive-deref
  (lambda (ref)
    (cases reference ref
      (a-ref (pos vec) (vector-ref vec pos)))))

(define primitive-setref!
  (lambda (ref val)
    (cases reference ref
      (a-ref (pos vec) (vector-set! vec pos val)))))

(define deref 
  (lambda (ref)
    (cases target (primitive-deref ref)
      (direct-target (expval) expval)
      (indirect-target (ref1)
        (cases target (primitive-deref ref1)
          (direct-target (expval) expval)
          (indirect-target (p)
            (eopl:error 'deref
              "Illegal reference: ~s" ref1))
          (thunk-target (exp env) (eval-thunk ref1))))  ;\new2
      (thunk-target (exp env) (eval-thunk ref)))))

(define eval-thunk                      
  (lambda (ref)
    (cases target (primitive-deref ref)
      (thunk-target (exp env)
        (let ((val (eval-expression exp env)))
          (primitive-setref! ref (direct-target val))
          val))
      (else
        (eopl:error 'eval-thunk "Impossible!")))))

(define setref!
  (lambda (ref expval)
    (let ((ref (cases target (primitive-deref ref)
                 (direct-target (expval1) ref)
                 (indirect-target (ref1) ref1)
                 (thunk-target (exp env) ref)))) ;\new1
      (primitive-setref! ref (direct-target expval)))))
        

;;;;;;;;;;;;;;;; environments ;;;;;;;;;;;;;;;;

(define-datatype environment environment?
  (empty-env-record)
  (extended-env-record
    (syms (list-of symbol?))
    (vec vector?)              ; can use this for anything.
    (env environment?))
  )

(define empty-env
  (lambda ()
    (empty-env-record)))

(define extend-env
  (lambda (syms vals env)
    (if ((list-of target?) vals)
        (extended-env-record syms (list->vector vals) env)
        (begin
          (eopl:printf "extend-env: bad values ~%")
          (eopl:pretty-print vals)
          (eopl:error 'extend-env "")))))
  

(define apply-env-ref
  (lambda (env sym)
    (cases environment env
      (empty-env-record ()
        (eopl:error 'apply-env-ref "No binding for ~s" sym))
      (extended-env-record (syms vals env)
        (let ((pos (rib-find-position sym syms)))
          (if (number? pos)
              (a-ref pos vals)
              (apply-env-ref env sym)))))))

(define apply-env
  (lambda (env sym)
    (deref (apply-env-ref env sym))))

(define extend-env-recursively
  (lambda (proc-names idss bodies old-env)
    (let ((len (length proc-names)))
      (let ((vec (make-vector len)))
        (let ((env (extended-env-record proc-names vec old-env)))
          (for-each
            (lambda (pos ids body)
              (vector-set! vec pos
                (direct-target          ; change for by-ref
                  (closure ids body env))))
            (iota len) idss bodies)
          env)))))

(define rib-find-position 
  (lambda (sym los)
    (list-find-position sym los)))

(define list-find-position
  (lambda (sym los)
    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))

(define list-index
  (lambda (pred ls)
    (cond
      ((null? ls) #f)
      ((pred (car ls)) 0)
      (else (let ((list-index-r (list-index pred (cdr ls))))
              (if (number? list-index-r)
                (+ list-index-r 1)
                #f))))))

(define iota
  (lambda (end)
    (let loop ((next 0))
      (if (>= next end) '()
        (cons next (loop (+ 1 next)))))))

(define difference
  (lambda (set1 set2)
    (cond
      ((null? set1) '())
      ((memv (car set1) set2)
       (difference (cdr set1) set2))
      (else (cons (car set1) (difference (cdr set1) set2))))))

;; for debugging:

(define printable-env
  (lambda (env)
    (cases environment env
      (empty-env-record () '())
      (extended-env-record (syms vals env)
        (cons
          (map
            (lambda (sym)
              (let ((pos (rib-find-position sym syms)))
                (if (number? pos)
                    (let ((t1 (vector-ref vals pos)))
                      (cases target t1
                        (direct-target (val1)
                          (list sym (list 'my-direct-target 
                                          (printable-expval val1))))
                        (indirect-target (ref1)
                          (list sym (list 'my-indirect-target 
                                          (printable-expval (deref
                                                              ref1)))))
                        (thunk-target (exp env)
                          (list sym (list 'my-thunk-target
                                          exp
                                          (printable-env env))))))
                    
                    (eopl:error 'printable))))
            syms)
          (printable-env env))))))

(define printable-expval
  (lambda (v)
    (if (procval? v)
        (cases procval v
          (closure (ids body env)
            (list 'my-closure ids body (printable-env env))))
        v)))