;; C311 Assignment 9.  Call by value/Call by reference
;;
;;

(load "grammar.ss")

;;;
;;; primitive procedures
;;;

(define *prim-op-names* '(+ - add1 sub1))

(define apply-prim-op
  (lambda (prim-op args)
    (case prim-op
      ((+) (+ (car args) (cadr args)))
      ((-) (- (car args) (cadr args)))
      ((add1) (+ (car args) 1))
      ((sub1) (- (car args) 1))
      (else (error 'apply-prim-op "Invalid prim-op name: ~s" prim-op)))))

(define make-prim-proc
  (lambda (prim-op-name)
    (list 'prim-proc prim-op-name)))


;;;
;;; environment procedures
;;;

(define apply-env
  (lambda (env symbol)
    (record-case env
      (empty-env ()
	(error 'empty-env "no association for symbol: ~s" symbol))
      (extended-env (sym-list val-vector env)
	(let ((x (memq symbol sym-list)))
	  (if x
	    (vector-ref val-vector (- (length sym-list) (length x)))
	    (apply-env env symbol))))
      (else (error 'apply-env "Invalid finite function: ~s" env)))))

(define the-empty-env
  (list 'empty-env))

(define extend-env
  (lambda (sym-list val-list env)
    (list 'extended-env sym-list (list->vector val-list) env)))

(define prim-env 
  (extend-env
    *prim-op-names*
    (map make-prim-proc *prim-op-names*)
    the-empty-env))

(define init-env the-empty-env)


;;;
;;; eval procedures
;;;

(define apply-proc
  (lambda (proc args)
    (if (pair? proc)
      (record-case proc
	(prim-proc (prim-op)
	  (apply-prim-op prim-op (map denoted->expressed args)))
	(closure (formals body env)
	  (eval-body body (extend-env formals args env)))
	(else (error 'apply-proc "Invalid procedure: ~s" proc)))
      (error 'apply-proc "Invalid procedure: ~s" proc))))

(define eval-body
  (lambda (body env)
    (if (null? (cdr body))
       (eval-exp (car body) env)
       (begin
	  (eval-exp (car body) env)
	  (eval-body (cdr body) env)))))

(define eval-exp
  (lambda (exp env)
    (if (variable? exp)
      (if (memq exp *prim-op-names*)
	(apply-env prim-env exp)
	(denoted->expressed (apply-env env exp)))
      (record-case exp
	(quote (datum) datum)
	(* (exp) (denoted->expressed (eval-exp exp env)))
	(& (var) (apply-env env var))
	(lambda (formals . body) (make-closure formals body env))
	(set! (var exp)
	  (let ([exp-value (eval-exp exp env)])
	    (if (var-indirect? var)
	      (cell-set! (eval-exp (addr->var var) env) exp-value)
	      (cell-set! (denoted->L-value (apply-env env var)) exp-value))))
	(local (decls body)
	  (let ((vars (map decl->var decls))
		(exps (map decl->exp decls)))
	    (eval-exp body
	      (extend-env vars
		(map (lambda (exp) (expressed->denoted (eval-exp exp env)))
		  exps)
		env))))	    
	(else
	  (let ((proc (eval-exp (app->rator exp) env))
		(args (eval-rands (app->rands exp) env)))
	    (apply-proc proc args)))))))

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

(define eval-rand
  (lambda (rand env)
    (expressed->denoted (eval-exp rand env))))


;;;
;;; repl procedures
;;;

(define repl
  (lambda ()
    (new-cafe run)))

(define run
  (lambda (exp)
    (if (exp? exp) (eval-exp (expand exp) init-env))))

(define exp?
  (grammar expression
    (variable
      (predicate
	(lambda (x)
	  (and (symbol? x)
	       (not (memq x '(* & quote local lambda let set!)))))))
    (varaddress  (lst '& variable))
    (varindirect (lst '* expression))
    (literal (predicate number?))
    (datum (predicate (lambda (x) #t)))
    (declaration (lst variable expression))
    (procedure-call
      (predicate	;;; this could have been (lst (plus expression))
	(lambda (x)	;;; but then a spurious bad keyword is reported
	  (and (pair? x)	    
	       (not (and (symbol? (car x)) (not (variable x))))
	       ((seq (plus expression))
		x)))))
    (expression
      (report-if-bad 'expression
	(alt variable varaddress varindirect literal procedure-call
	  (lst 'quote datum)
	  (lst 'lambda (lst (star variable)) (plus expression))
	  (lst 'let (lst (star declaration)) (plus expression))
	  (lst 'local (lst (star declaration)) (plus expression))
	  (lst 'set!
	    (alt variable varindirect)
	    expression))))))

(define expand
  (lambda (exp)
    (cond
      ((literal? exp) (list 'quote exp))
      ((variable? exp) exp)
      (else 
	(record-case exp
	  (quote (datum) exp)
	  (& (var) exp)
	  (* (var) exp)
	  (set! (var exp) (list 'set! var (expand exp)))
	  (let (decls . body)
	    (let ((vars (map decl->var decls))
		  (exps (map decl->exp decls)))
	      (expand (cons (cons 'lambda (cons vars body))
			exps))))
	  (local (decls . body)
	    (let ((vars (map decl->var decls))
		  (exps (map decl->exp decls)))
	      (list 'local (map (lambda (decl)
				  (list (decl->var decl)
				    (expand (decl->exp decl))))
			     decls)
		(expand (cons 'let (cons '() body))))))
	  (lambda (formals . body)
	    (cons 'lambda (cons formals (map expand body))))
	  (else (map expand exp)))))))


;;;
;;; cell ADT
;;;

(define cell-ref  cdr)
(define cell-set! set-cdr!)
(define make-cell
  (lambda (x)
    (cons 'cell x)))


;;;
;;; utility/accessor procedures
;;;

(define identity
  (lambda (x) x))

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

(define variable? 	symbol?)
(define var-address?   (lambda (v) (and (pair? v) (eq? (car v) '&))))
(define var-indirect?  (lambda (v) (and (pair? v) (eq? (car v) '*))))
(define literal?	number?)
(define app->rator	car)
(define app->rands	cdr)
(define decl->var	car)
(define decl->exp	cadr)
(define addr->var	cadr)

(define L-value->expressed  cell-ref)
(define denoted->L-value    identity)
(define denoted->expressed (compose L-value->expressed denoted->L-value))
(define expressed->L-value  make-cell)
(define L-value->denoted    identity)
(define expressed->denoted (compose L-value->denoted expressed->L-value))

(define make-closure
  (lambda (formals body env)
    (list 'closure formals body env)))