;; Add "set" to the language  

;; A expval is
;;   * number, or
;;   * boolean, or
;;   * proc

;; A denval is a reference                 <<<<<<<

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

(define the-lexical-spec
  '((whitespace (whitespace) 
                skip)
    (id (letter (arbno (or letter digit "?")))
        make-symbol)
    (number ((or "" "-" "+") digit (arbno digit))
            make-number)))

(define the-grammar
  '((program (expression) a-program)

    (expression (number) lit-exp)
    (expression (id) var-exp)
    (expression
      (primitive "(" (separated-list expression ",") ")")
      primapp-exp)
    (expression ("true") true-exp)
    (expression ("false") false-exp)
    (expression ("let"
                 (arbno id "=" expression)
                 "in"
                 expression)
                let-exp)
    (expression ("proc"
                 "(" (separated-list id ",") ")"
                 expression)
                proc-exp)
    (expression ("(" expression (arbno expression) ")")
                app-exp)
    (expression ("if" expression
                 "then" expression
                 "else" expression)
                if-exp)
    (expression ("letrec"
                 (arbno
                  id "=" 
                  "proc" "(" (separated-list id ",") ")"
                  expression)
                 "in" expression)
                letrec-exp)
    (expression ("set" id "=" expression) set-exp)       ; <<<<<<
    
    (primitive ("+")     add-prim)
    (primitive ("-")     subtract-prim)
    (primitive ("*")     mult-prim)
    (primitive ("add1")  incr-prim)
    (primitive ("sub1")  decr-prim)
    (primitive ("or")    or-prim)))

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

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

; The reference datatype implements a "box" by          <<<<<<
;  pointing to a particular element of an
;  environment extension's vector:
(define-datatype
 reference reference?
 (a-ref (pos integer?)
        (vec vector?)))

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

; eval-program : program -> expval
(define eval-program 
  (lambda (pgm)
    (cases program pgm
      (a-program (body)
        (eval-expression body (init-env))))))

; eval-expression : expression env -> expval
(define eval-expression 
  (lambda (exp env)
    (cases expression exp
      (lit-exp (datum) datum)
      (var-exp (id) (apply-env env id))
      (primapp-exp (prim rands)
        (let ((args (eval-rands rands env)))
          (apply-primitive prim args)))
      (true-exp () #t)
      (false-exp () #f)
      (proc-exp (ids body-exp)
                (closure ids body-exp env))
      (app-exp (rator rands)
               (let ([func (eval-expression rator env)]
                     [args (eval-rands rands env)])
                 (apply-proc func args)))
      (if-exp (test then else)
              (if (zero? (eval-expression test env))
                  (eval-expression else env)
                  (eval-expression then env)))
      (let-exp (ids exps body-exp) 
               (eval-expression
                body-exp ;; expression
                (extend-env
                 ids ;; list-of-sym
                 (eval-rands exps env)
                 env)))
      (letrec-exp (func-ids arg-idss func-exps body-exp)
                  (eval-expression
                   body-exp
                   (recursively-extend-env
                    func-ids
                    arg-idss
                    func-exps
                    env)))
      ; To evaluate a set:                             <<<<<<<<
      ;    1. Eval RHS
      ;    2. Get a reference for the LHS
      ;    3. Install the value from  #1 into #2's reference
      ;    4. Return 1, always
      (set-exp (id exp) 
               (let ([new-val (eval-expression
                               exp
                               env)]
                     [var-ref (apply-env-ref
                               env
                               id)])
                 (setref! var-ref new-val)
                 1))
      )))

; setref! : reference expval -> [nothing]
; 
;  Modifies the given environment reference by installing
;  the given value.
;
(define (setref! ref val)
  (cases reference ref
         [a-ref (pos vec) 
                (vector-set! vec pos val)]))

; apply-proc : proc list-of-expval -> expval
(define (apply-proc func args)
  (cases proc func
         (closure (ids body-exp env)
                  (eval-expression
                   body-exp
                   (extend-env
                    ids
                    args
                    env)))))

; eval-rands : list-of-expression env -> list-of-expval
(define eval-rands
  (lambda (rands env)
    (map (lambda (x) (eval-rand x env)) rands)))

; eval-rand : expression env -> expval
(define eval-rand
  (lambda (rand env)
    (eval-expression rand env)))

; apply-primitive : primitive list-of-expval -> expval
;  (apply-prim (add-prim) '(0 3)) = 3
;  (apply-prim (sub-prim) '(1 2)) = -1
(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))
      (or-prim () (or (car args) (cadr args))))))

; init-env :  -> env
(define init-env
  (lambda () (empty-env)))

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

;; Abstract envrionment datatype implemenation.

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

; empty-env : -> env
(define empty-env
  (lambda ()
    (empty-env-record)))

; extend-env : list-of-sym list-of-expval env -> env 
(define extend-env
  (lambda (syms vals env)
    (extended-env-record syms (list->vector vals) env)))

; recursively-extend-env : list-of-sym list-of-list-of-sym list-of-exp -> env
(define recursively-extend-env
  (lambda (func-ids arg-idss func-exps old-env)
    (let ([vec (make-vector (length func-ids) #f)])
      (let ([result (extended-env-record
                     func-ids vec old-env)])
        (letrec ([install-closures!
                  (lambda (pos arg-idss func-exps)
                    (cond
                      [(null? args-idss) 'done]
                      [else (vector-set! 
                             vec pos
                             (closure (car arg-idss)
                                      (car func-exps)
                                      result))
                            (install-closures!
                             (+ pos 1)
                             (cdr arg-idss)
                             (cdr func-exps))]))])
          (install-closures! 0 arg-idss func-exps)
          result)))))
                              
    
; apply-env : env sym -> expval
(define apply-env
  (lambda (env sym)
    (cases environment env
      (empty-env-record ()
        (eopl:error 'apply-env "No binding for ~s" sym))
      (extended-env-record (syms vals env)
        (let ((position (env-find-position sym syms)))
          (if (number? position)
              (vector-ref vals position)
              (apply-env env sym)))))))

; apply-env-ref : env sym -> reference
;
; Gets a reference for a vriable, instead of it's
; current value.
;
(define (apply-env-ref env sym)
  (cases environment env
   (empty-env-record () 
     (eopl:error 'apply-env-ref "No binding for ~s" sym)]
   (extended-env-record (syms vals-vec old-env)
      (let ([position (env-find-position sym syms)])
	(if (number? position)
	    (a-ref position vals-vec)
	    (apply-env-ref old-env sym))))))

;; Environment helper functions

; env-find-position : sym list-of-symbols -> num-or-#f
(define env-find-position 
  (lambda (sym los)
    (list-find-position sym los)))

; list-find-position : sym list-of-symbols -> num-or-#f
(define list-find-position
  (lambda (sym los)
    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))

; list-index : pred list-of-symbols -> num-or-#f
(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))))))

;;;;;;;;;;;;;;;; top level ;;;;;;;;;;;;;;;;

; read-eval-print : -> [loops forever]
(define read-eval-print
  (lambda ()
    ((sllgen:make-rep-loop "-->"
			   eval-program
                           (sllgen:make-stream-parser
                            the-lexical-spec
                            the-grammar)))))

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

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