;;; Ugly, concrete-syntax evaluator for an
;;; Elementary Lexically-Scoped Language with continuations

(define eval
  (lambda (exp env)
    (eval-k exp env (lambda (x) x))))

(define eval-k
  (lambda (exp env k)
    (cond ((number? exp) (k exp))
	  ((symbol? exp) (k (lookup exp env)))
	  ((eq? (car exp) 'QUOTE) (k (cadr exp))) 
          ((eq? (car exp) 'COND)
	   (eval-clauses-k (cdr exp) env k))
	  ((eq? (car exp) 'LAMBDA)
	   (k (list 'PROCEDURE		;tag
		    (cadr exp)		;bvars
		    (caddr exp)		;body
		    env)))		;env of definition
	  (else
	   (eval-k (car exp) env
	     (lambda (proc)
	       (values-k (cdr exp) env
		 (lambda (args)
		   (apply-k proc args k)))))))))

(define apply
  (lambda (proc args)
    (apply-k proc args (lambda (x) x))))

(define apply-k
  (lambda (proc args k)
    (cond ((eq? proc call/cc)
	   (call/cc (car args) k k))
	  ((primitive? proc)
	   (k (papply proc args)))
	  ((eq? (car proc) 'PROCEDURE)
	   (eval-k (caddr proc)          ;body
		   (extend (cadddr proc) ;env of definition
			   (cadr proc)   ;bvars
			   args)	 ;args
		   k))
	  (else
	   (error "Unknown proc -- APPLY"
		  proc)))))

(define call/cc
  (lambda (proc continue k)
    (apply-k proc (list continue) k)))

(define values-k
  (lambda (exps env k)
    (cond ((null? exps) (k '()))
	  (else
	   (eval-k (car exps) env
	     (lambda (arg)
	       (values-k (cdr exps) env
		 (lambda (args)
		   (k (cons arg args))))))))))

(define eval-clauses-k
  (lambda (clauses env k)
    (cond ((eq? (caar clauses) 'ELSE)
	   (eval-k (cadar clauses) env k))
	  (else
	   (eval-k (caar clauses) env
	     (lambda (p)
	       (cond ((not (eq? p #f))
		      (eval-k (cadar clauses)
			      env k))
		     (else
		      (eval-clauses-k (cdr clauses)
				      env k)))))))))

(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
	    user-initial-environment
	    var))
	  (else
	   (let ((binding (assq var (car env))))
	     (cond (binding (cdr binding))
		   (else
		    (lookup var (cdr env)))))))))

(define (repl)
  (newline)
  (eval-k (read) '()
	  (lambda (val)
	    (display ";==> ")
	    (write-line val)
	    (repl))))