; Copyright (c) 1993-2008 by Richard Kelsey.  See file COPYING.

; Evaluator for nodes.

; Cloned from ps-compiler/prescheme/eval.scm.

; (NAME-NODE-BINDING name-node) is used as an EQ? key in local environments,
; and passed as-is to the global-environment arguments.

; Exports:
; (EVALUATE-NODE node global-ref global-set! eval-primitive)
; EVAL-CLOSURE? (EVAL-CLOSURE-NODE closure) (EVAL-CLOSURE-ENV closure)
; (UNSPECIFIC? thing)

(define (evaluate-node node global-ref global-set! coerce-closure eval-primitive)
  (evaluate node (make-env '()
			   (make-eval-data global-ref
					   global-set!
					   coerce-closure
					   eval-primitive))))

(define-record-type eval-data :eval-data
  (make-eval-data global-ref global-set! coerce-closure eval-primitive)
  eval-data?
  (global-ref     eval-data-global-ref)
  (global-set!    eval-data-global-set!)
  (coerce-closure eval-data-coerce-closure)
  (eval-primitive eval-data-eval-primitive))

; Environments

(define-record-type env :env
  (make-env alist eval-data)
  env?
  (alist env-alist)
  (eval-data env-eval-data))

(define (env-ref env name-node)
  (let ((cell (assq name-node (env-alist env))))
    (if cell
	(cdr cell)
	((eval-data-global-ref (env-eval-data env)) name-node))))

(define (env-set! env name-node value)
  (let ((cell (assq name-node (env-alist env))))
    (if cell
	(set-cdr! cell value)
	((eval-data-global-set! (env-eval-data env))
	 name-node
	 value))))

(define (extend-env env ids vals)
  (make-env (append (map cons ids vals)
		    (env-alist env))
	    (env-eval-data env)))

(define (eval-primitive primitive args env)
  ((eval-data-eval-primitive (env-eval-data env)) primitive args))

; Closures

; Avoid name clash with the native closures.

(define-record-type eval-closure :eval-closure
  (make-eval-closure node env)
  eval-closure?
  (node eval-closure-node)
  (env real-eval-closure-env)
  (temp eval-closure-temp set-eval-closure-temp!))

(define (eval-closure-env closure)                   ; exported
  (env-alist (real-eval-closure-env closure)))

(define (make-top-level-eval-closure exp)
  (make-eval-closure exp the-empty-env))

(define the-empty-env (make-env '() #f))

; Main dispatch

(define (evaluate node env)
  ((operator-table-ref evaluators (node-operator-id node))
   node
   env))

; Particular operators

(define evaluators
  (make-operator-table
   (lambda (node env)
     (error "no evaluator for node ~S" node))))

(define (define-evaluator name proc)
  (operator-define! evaluators name #f proc))

(define (eval-list nodes env)
  (map (lambda (node)
	 (evaluate node env))
       nodes))

(define-evaluator 'literal
  (lambda (node env)
    (node-form node)))

(define-evaluator 'unspecific
  (lambda (node env)
    (unspecific)))

(define-evaluator 'unassigned
  (lambda (node env)
    (unspecific)))

(define-evaluator 'quote
  (lambda (node env)
    (cadr (node-form node))))

(define-evaluator 'lambda
  (lambda (node env)
    ((eval-data-coerce-closure (env-eval-data env))
     (make-eval-closure node env))))

(define (apply-eval-closure closure args)
  (let ((node (eval-closure-node closure))
	(env (real-eval-closure-env closure)))
    (call-with-values
	(lambda () (parse-arguments (cadr (node-form node)) args))
      (lambda (ids vals)
	(evaluate (caddr (node-form node))
		  (extend-env env ids vals))))))

; returns ids, values
(define (parse-arguments the-formals the-args)
  (let recur ((formals the-formals) (args the-args))
    (cond
     ((pair? formals)
      (if (null? args)
	  (assertion-violation 'parse-arguments "argument count mismatch" the-formals the-args))
      (call-with-values
	  (lambda () (recur (cdr formals) (cdr args)))
	(lambda (ids vals)
	  (values (cons (car formals) ids)
		  (cons (car args) vals)))))
     (else
      (values (list formals)
	      (list args))))))

(define-evaluator 'name
  (lambda (node env)
    (env-ref env node)))

(define-evaluator 'set!
  (lambda (node env)
    (let ((exp (node-form node)))
      (env-set! env (cadr exp) (evaluate (caddr exp) env))
      (unspecific))))

(define-evaluator 'call
  (lambda (node env)
    (eval-call (car (node-form node))
	       (cdr (node-form node))
	       env)))

(define-evaluator 'goto
  (lambda (node env)
    (eval-call (cadr (node-form node))
	       (cddr (node-form node))
	       env)))

(define (eval-call proc args env)
  (let ((proc (evaluate proc env))
	(args (eval-list args env)))
    (if (eval-closure? proc)
	(apply-eval-closure proc args)
	(eval-primitive proc args env))))

(define-evaluator 'begin
  (lambda (node env)
    (let ((exps (cdr (node-form node)))) 
      (if (null? exps)
	  (unspecific)
	  (let loop ((exps exps))
	    (cond ((null? (cdr exps))
		   (evaluate (car exps) env))
		  (else
		   (evaluate (car exps) env)
		   (loop (cdr exps)))))))))

(define-evaluator 'if 
  (lambda (node env)
    (let* ((form (node-form node))
	   (test (cadr form))
	   (arms (cddr form)))
      (cond ((evaluate test env)
	     (evaluate (car arms) env))
	    ((null? (cdr arms))
	     (unspecific))
	    (else
	     (evaluate (cadr arms) env))))))

(define-evaluator 'loophole
  (lambda (node env)
    (evaluate (caddr (node-form node)) env)))

(define-evaluator 'letrec
  (lambda (node env)
    (let ((form (node-form node)))
      (let ((vars (map car (cadr form)))
	    (vals (map cadr (cadr form)))
	    (body (caddr form)))
	(let ((env (extend-env env
			       vars
			       (map (lambda (ignore)
				      (unspecific))
				    vars))))
	  (for-each (lambda (var val)
		      (env-set! env var (evaluate val env)))
		    vars
		    vals)
	  (evaluate body env))))))

(define (unspecific? x)
  (eq? x (unspecific)))

