;;; Ugly, concrete-syntax evaluator for an
;;; Elementary Dynamically-Scoped Language 
;;; such as MACLISP or Emacs Lisp.

(define eval
  (lambda (exp env)
    ;; Dispatch on expression type
    (cond ((number? exp) exp)
	  ((symbol? exp) (lookup exp env))
	  ((eq? (car exp) 'QUOTE) (cadr exp)) 
          ((eq? (car exp) 'COND)
	   (eval-clauses (cdr exp) env))
	  ((eq? (car exp) 'LAMBDA)
	   ;; Rule for making a procedure obj.
	   (list 'PROCEDURE	   ;tag
		 (cadr exp)	   ;bvars
		 (caddr exp)))	   ;body
	  ;; ... add more here
	  ;; ... DEFINE, SET!, BEGIN, IF
	  (else
	   (apply (eval (car exp) env)
		  (values (cdr exp) env)
		  env)))))	       ;env of call

(define apply
  (lambda (proc args env)
    ;; Dispatch on procedure type
    (cond ((primitive? proc)
	   (papply proc args))
	  ((eq? (car proc) 'PROCEDURE)
	   ;; Rule for making an environment 
	   ;;  (PROCEDURE <bvars> <e> <env>)
	   (eval (caddr proc)	       ;body
		 (extend env	       ;env of call
			 (cadr proc)   ;bvars
			 args)))       ;args
	  (else
	   (error "Unknown proc -- APPLY"
		  proc)))))

(define values
  (lambda (exps env)
    (cond ((null? exps) '())
	  (else
	   (cons (eval (car exps) env)
		 (values (cdr exps) env))))))

(define eval-clauses
  (lambda (clauses env)
    (cond ((eq? (caar clauses) 'ELSE)
	   (eval (cadar clauses) env))
	  ((not (eq? (eval (caar clauses) env)
		     #f))
	   (eval (cadar clauses) env))
	  (else
	   (eval-clauses (cdr clauses) env)))))

(define extend
  (lambda (base-env vars vals)
    (cons (make-frame vars vals) base-env)))

(define make-frame
  (lambda (vars vals)
    (cond ((null? vars)
	   (cond ((null? vals) '())
		 (else
		  (error "Too many arguments"))))
	  ((null? vals)
	   (error "Too few arguments"))
	  (else
	   (cons (cons (car vars) (car vals))
		 (make-frame (cdr vars)
			     (cdr vals)))))))

(define lookup
  (lambda (var env)
    (cond ((null? env)
	   (error "Unbound variable" var))
	  (else
	   (let ((binding (assq var (car env))))
	     (cond (binding (cdr binding))
		   (else
		    (lookup var (cdr env)))))))))

(define assq
  (lambda (var bindings)
    (cond ((null? bindings) #f)
	  ((eq? var (caar bindings))
	   (car bindings))
	  (else (assq var (cdr bindings))))))

(define primitive?
  (lambda (proc)
    (memq proc
	  (list car cdr pair? cons eq? ...))))

(define papply
  (lambda (proc args)
    (cond ((eq? proc car) (car (car args)))
	  ((eq? proc cdr) (cdr (car args)))
	  ((eq? proc pair?) (pair? (car args)))
	  ((eq? proc cons)
	   (cons (car args) (cadr args)))
	  ((eq? proc eq?)
	   (eq? (car args) (cadr args)))
	  ;; ...
	  )))

;;; For testing... 

(define primitive?
  (lambda (proc) (procedure? proc)))

(define papply
  (lambda (proc args)
    ((access apply system-global-environment)
     proc args)))

(define lookup
  (lambda (var env)
    (cond ((null? env)
	   (environment-lookup system-global-environment
			       var))
	  (else
	   (let ((binding (assq var (car env))))
	     (cond (binding (cdr binding))
		   (else
		    (lookup var (cdr env)))))))))

(define (repl)
  (newline)
  (let ((val (eval (read) '())))
    (display ";==> ")
    (write-line val))
  (repl))