;;; call-by.ss

(load "record.ss")

;;; Semantic domains:
;;;   procedure = closure + prim-proc
;;;   expressed-value = number + procedure
;;;   L-value = cell(expressed-value)
;;;   denoted-value = L-value , for call-by-value and call-by-reference
;;;   denoted-value = L-value + thunk , for class-by-name
;;;   thunk = () -> L-value
;;;   closure = (denoted-value*) -> expressed-value
;;;   prim-proc = (denoted-value*) -> expressed-value


;;; Syntax

;;; expression -> variable | prim-op | number
;;;   | (IF expression expression expresssion)
;;;   | (LAMBDA (variable*) expression+)
;;;   | (LET ({(variable expression)}*) expression+)
;;;   | (LOCAL ({(variable expression)}*) expression+)
;;;   | (BEGIN expression+)
;;;   | (SET! variable expression)
;;;   | (expression+)

(define-record varref (var))
(define-record primref (prim-op))
(define-record lit (datum))
(define-record app (rator rands))
(define-record if (test conseq alt))
(define-record proc (formals body))
(define-record varassign (var exp))
(define-record begin (exp1 exp2))
(define-record decl (var exp))
(define-record local (decls body))

;; procedure records
(define-record prim-proc (prim-op))
(define-record closure (formals body env))

;; thunk record
(define-record thunk (exp env))

(define parse
  (lambda (exp)
    (cond
      ((symbol? exp)
       (if (memq exp prim-ops) (make-primref exp) (make-varref exp)))
      ((number? exp) (make-lit exp))
      ((and (pair? exp) (eq? (car exp) 'if) (= 4 (length exp)))
       (make-if
	 (parse (cadr exp))
	 (parse (caddr exp))
	 (parse (cadddr exp))))
      ((and (pair? exp) (eq? (car exp) 'lambda))
       (make-proc (cadr exp) (parse (cons 'begin (cddr exp)))))
      ((and (pair? exp) (eq? (car exp) 'let))
       (make-app
	 (make-proc (map car (cadr exp)) (parse (cons 'begin (cddr exp))))
	 (map parse (map cadr (cadr exp)))))
      ((and (pair? exp) (eq? (car exp) 'local))
       (make-local (map (lambda (decl-ls)
			  (make-decl (car decl-ls) (parse (cadr decl-ls))))
		     (cadr exp))
	 (parse (cons 'begin (cddr exp)))))
      ((and (pair? exp) (eq? (car exp) 'begin))
       (if (= (length (cdr exp)) 1)
	   (parse (cadr exp))
	   (make-begin (parse (cadr exp)) (parse (cons 'begin (cddr exp))))))
      ((and (pair? exp) (eq? (car exp) 'set!))
       (make-varassign (cadr exp) (parse (caddr exp))))
      (else
	(make-app
	  (parse (car exp))
	  (map parse (cdr exp)))))))


;;; Environments

(define empty-env '())

(define extend-env
  (lambda (vars vals env)
    (cons (cons vars (list->vector vals)) env)))

(define apply-env
  (lambda (env v)
    (if (null? env)
	(apply-init-env v)
	(let ((names (caar env))
	      (vals (cdar env)))
	  (let ((find-result (member v names)))
	    (if find-result
		(vector-ref vals (- (length names) (length find-result)))
		(apply-env (cdr env) v)))))))


;;; Primitives

(define prim-ops '(equal zero less greater + - * add1 sub1 minus))

(define apply-prim-op
  (lambda (prim-op args)
    (case prim-op
      ((equal) (if (and (number? (car args))
			(number? (cadr args))
			(= (car args) (cadr args)))
		   1
		   0))
      ((zero) (if (zero? (car args)) 1 0))
      ((less) (if (and (number? (car args))
		       (number? (cadr args))
		       (< (car args) (cadr args)))
		  1
		  0))
      ((greater) (if (and (number? (car args))
			  (number? (cadr args))
			  (> (car args) (cadr args)))
		     1
		     0))
      ((+) (+ (car args) (cadr args)))
      ((-) (- (car args) (cadr args)))
      ((*) (* (car args) (cadr args)))
      ((add1) (+ (car args) 1))
      ((sub1) (- (car args) 1))
      ((minus) (* -1 (car args))))))

(define prim-env ; denoted value = expressed value in prim-env
  (extend-env prim-ops (map make-prim-proc prim-ops) empty-env))


;;; Truth

(define true-value?
  (lambda (x)
    (if (number? x)
      (not (zero? x))
      #t)))


;;; Cells

(define cell-ref unbox)
(define cell-set! set-box!)
(define make-cell box)


;;; Domain conversions
 
(define L-value->expressed cell-ref)

(define denoted->L-value 'ignored) ; assigned by the call-by- procedures

(define denoted->expressed
  (lambda (denval)
    (L-value->expressed (denoted->L-value denval))))

(define expressed->L-value make-cell)

(define L-value->denoted (lambda (lval) lval))

(define expressed->denoted
  (lambda (val)
    (L-value->denoted (expressed->L-value val))))


;;; Procedures

(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 env))))))


;;; Expression evaluation

(define eval-exp
  (lambda (exp env)
    (variant-case exp
      (varref (var) (denoted->expressed (apply-env env var)))
      (primref (prim-op) (apply-env prim-env prim-op))
      (app (rator rands)
	(apply-proc (eval-exp rator env) (eval-rands rands env)))
      (varassign (var exp)
	(cell-set!
	  (denoted->L-value (apply-env env var))
	  (eval-exp exp env)))
      (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))))
      (lit (datum) datum)
      (if (test conseq alt)
	(if (true-value? (eval-exp test env))
	  (eval-exp conseq env)
	  (eval-exp alt env)))
      (proc (formals body)
	(make-closure formals body env))
      (begin (exp1 exp2)
	(let ((ignored (eval-exp exp1 env)))
	  (eval-exp exp2 env))))))

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

(define eval-rand 'ignored) ; assigned by the call-by- procedures


;;; Call-by variations

(define call-by-value
  (lambda ()
    (set! denoted->L-value (lambda (denval) denval))
    (set! eval-rand
      (lambda (rand env)
	(expressed->denoted (eval-exp rand env))))))

(define call-by-reference
  (lambda ()
    (set! denoted->L-value (lambda (denval) denval))
    (set! eval-rand
      (lambda (rand env)
	(variant-case rand
	  (varref (var) (apply-env env var))
	  (else (expressed->denoted (eval-exp rand env))))))))

(define call-by-name
  (lambda ()
    (set! denoted->L-value
      (lambda (denval)
	(if (thunk? denval)
	  (thaw-thunk denval)
	  denval)))
    (set! eval-rand
      (lambda (rand env)
	(make-thunk rand env)))))

(define thaw-thunk
  (lambda (thunk)
    (let ((exp (thunk->exp thunk))
	  (env (thunk->env thunk)))
      (variant-case exp
	(varref (var) (denoted->L-value (apply-env env var)))
	(else (expressed->L-value (eval-exp exp env)))))))


;;; Testing

(define run
  (lambda (exp)
    (eval-exp (parse exp) empty-env)))

(define test
  (lambda (exp)
    (call-by-value)
    (printf "By-value: ~s~n" (run exp))
    (call-by-reference)
    (printf "By-reference: ~s~n" (run exp))
    (call-by-name)
    (printf "By-name: ~s~n" (run exp))))

(define test1
  '(local ((a 1))
     (let ((x a)
	   (y (+ a 1)))
       (set! x (+ a 1))
       (set! x y)
       a)))