;; The following is a self-interpreting loop.  In other words, we
;; write a (fairly minimal) Scheme evaluator in Scheme, and we run the
;; Scheme evaluator on itself.  So the evaluator evaluates a Scheme
;; evaluator evaluating a Scheme evaluator... and so on.

;; See exercice 4 of section 1.4.3.2 of D. E. Knuth's ``Art of
;; Computer Programming''.

(

;;; --- Evaluator begins here ---

;; The terminal-eval function (defined below in this let*) is the
;; evaluator's main function.  It takes the symbolic representation of
;; a Scheme expression (for example '(cons 42 1729)) and returns it
;; evaluated.  Expressions are represented as lists in the usual way.
;; Environments are represented as association tables.  The result of
;; an evaluation is essentially the Scheme object itself (that is, we
;; do not distinguish metas for evaluated objects) with one important
;; difference: the evaluator represents functions as functions of
;; *one* variable (which is a list of all the arguments).  This is
;; because we do not wish to use functions of a variable number of
;; variables.  Indeed, our evaluator does not support them, and our
;; evaluator must be written in the very same subset of Scheme that it
;; supports.

;; The subset in question has the lambda special form as well as quote
;; (but not quasiquote), begin, if (only in the form (if expr then
;; else), that is, with exactly three arguments), or (only with
;; exactly two arguments), case and let*.  Absolutely no error
;; checking is done: for example, all hell will break loose in a case
;; expression if nothing matches.  The (lambda varargs body)
;; construction is not supported, only (lambda (args) body).

;; Note that we do not implement letrec, so also we do not use it.  We
;; use the classical Y-combinator way of rewriting letrec's: the eval
;; function, which needs to call on eval, is rewritten as $eval, which
;; calls on $eval, but takes $eval as a parameter.  This is the reason
;; why the following is so obscure.

(let*
    ((lookup
      ;; Lookup a variable in an environment.
      (lambda (var env)
	(cdr (assq var env))))
     ($eval
      ;; The main evaluation function: evaluates an expression in a
      ;; given environment.
      (lambda (exp env $eval $evals $eval-case $eval-let* $make-fun)
	;; Print some tracing information.
	(display "==>Evaluating expression:") (newline)
	(write exp) (display "<==") (newline)
	;; Now consider the type of the expression.
	(if (pair? exp)
	    (case (car exp)
	      ((lambda) ;; lambda abstraction
	       ($make-fun (cadr exp) (cddr exp) env
			  $eval $evals $eval-case $eval-let* $make-fun))
	      ((quote) (cadr exp))
	      ((begin) ;; begin special form
	       ($evals (cdr exp) env
		       $eval $evals $eval-case $eval-let* $make-fun))
	      ((if) ;; if special form (of three arguments)
	       (if ($eval (cadr exp) env
			  $eval $evals $eval-case $eval-let* $make-fun)
		   ($eval (caddr exp) env
			  $eval $evals $eval-case $eval-let* $make-fun)
		   ($eval (cadddr exp) env
			  $eval $evals $eval-case $eval-let* $make-fun)))
	      ((or) ;; or special form (of two arguments)
	       (or ($eval (cadr exp) env
			  $eval $evals $eval-case $eval-let* $make-fun)
		   ($eval (caddr exp) env
			  $eval $evals $eval-case $eval-let* $make-fun)))
	      ((case) ;; case special form
	       ($eval-case ($eval (cadr exp) env
				  $eval $evals $eval-case $eval-let* $make-fun)
			   (cddr exp) env
			   $eval $evals $eval-case $eval-let* $make-fun))
	      ((let*) ;; let* special form
	       ($eval-let* (cadr exp) (cddr exp) env
			   $eval $evals $eval-case $eval-let* $make-fun))
	      (else ;; application
	       (($eval (car exp) env
		       $eval $evals $eval-case $eval-let* $make-fun)
		(map (lambda (x)
		       ($eval x env
			      $eval $evals $eval-case $eval-let* $make-fun))
				(cdr exp)))))
	    (if (symbol? exp)
		(lookup exp env) ;; variable lookup
		exp)))) ;; self-evaluating
     ($evals
      ;; Evaluate a list of expressions.
      (lambda (exps env $eval $evals $eval-case $eval-let* $make-fun)
	(if (null? (cdr exps))
	    ($eval (car exps) env
		   $eval $evals $eval-case $eval-let* $make-fun)
	    (begin
	      ($eval (car exps) env
		     $eval $evals $eval-case $eval-let* $make-fun)
	      ($evals (cdr exps) env
		      $eval $evals $eval-case $eval-let* $make-fun)))))
     ($eval-case
      ;; Evaluate the case special form.
      (lambda (val lines env $eval $evals $eval-case $eval-let* $make-fun)
	(if (or (eqv? (car (car lines)) 'else)
		(memq val (car (car lines))))
	    ($evals (cdr (car lines)) env
		    $eval $evals $eval-case $eval-let* $make-fun)
	    ($eval-case val (cdr lines) env
			$eval $evals $eval-case $eval-let* $make-fun))))
     ($eval-let*
      ;; Evaluate the let* special form.
      (lambda (defns body env $eval $evals $eval-case $eval-let* $make-fun)
	(if (null? defns)
	    ($evals body env
		    $eval $evals $eval-case $eval-let* $make-fun)
	    ($eval-let* (cdr defns)
			body
			(cons (cons (car (car defns))
				    ($evals (cdr (car defns)) env
					    $eval $evals $eval-case $eval-let* $make-fun))
					 env)
			$eval $evals $eval-case $eval-let*
			$make-fun))))
     ;; Make a function (evaluate the lambda special form).  This also
     ;; implicitly contains the internal apply function.
     ($make-fun
      (lambda (formals body denv $eval $evals $eval-case $eval-let* $make-fun)
	(lambda (values)
	  ($evals body (append (map cons formals values)
			       denv)
		  $eval $evals $eval-case $eval-let* $make-fun))))
     ;; The initial environment, i.e. the functions which the
     ;; evaluator knows about.  Essentially, we just take those of the
     ;; underlying Scheme; however, since functions should be of one
     ;; variable, some modifications are of order.
     (initial-env (list (cons 'car (lambda (values) (apply car values)))
			(cons 'cdr (lambda (values) (apply cdr values)))
			(cons 'cadr (lambda (values) (apply cadr values)))
			(cons 'cddr (lambda (values) (apply cddr values)))
			(cons 'caddr (lambda (values) (apply caddr values)))
			(cons 'cdddr (lambda (values) (apply cdddr values)))
			(cons 'cadddr (lambda (values) (apply cadddr values)))
			(cons 'cons (lambda (values) (apply cons values)))
			;; list is trivial because of the way we pass
			;; arguments.
			(cons 'list (lambda (values) values))
			(cons 'append (lambda (values) (apply append values)))
			(cons 'apply (lambda (values)
				       ((car values) (cadr values))))
			;; The following is a bit tricky.
			(cons 'map (lambda (values)
				     (map (car values)
					  (apply map
						 (cons list
						       (cdr values))))))
			(cons 'eqv? (lambda (values) (apply eqv? values)))
			(cons 'memq (lambda (values) (apply memq values)))
			(cons 'assq (lambda (values) (apply assq values)))
			(cons 'pair? (lambda (values) (apply pair? values)))
			(cons 'symbol? (lambda (values) (apply symbol? values)))
			(cons 'null? (lambda (values) (apply null? values)))
			;; We trap display, write and newline so as to
			;; distinguish things printed by the program
			;; being interpreted from those written by the
			;; interpreter itself.
			(cons 'display (lambda (values)
					 (display "[[[")
					 (apply display values)
					 (display "]]]") (newline)))
			(cons 'write (lambda (values)
				       (display "[[[")
				       (apply write values)
				       (display "]]]") (newline)))
			(cons 'newline (lambda (values)
					 (display "[[[")
					 (apply newline values)
					 (display "]]]") (newline)))
			))
     (terminal-eval
      ;; The entry point to the interpreter.
      (lambda (exp)
	($eval exp initial-env
	       $eval $evals $eval-case $eval-let* $make-fun))))
  (display "Now starting evaluation...") (newline)
  ;; We will take a function (i.e. the expression representing a
  ;; function) and run the evaluator on `(,fun ',fun) (i.e. fun
  ;; applied to fun's representation).  Since we don't have
  ;; quasiquote, we write this as:
  (lambda (fun) (terminal-eval (list fun (list 'quote fun))))
  ;; Uncomment this (and comment the above) if you just want to try
  ;; out the interpreter (and replace the second part by whatever you
  ;; want it to interpret).
; terminal-eval
  )

;;; --- Evaluator ends here ---

' ;; The program to be evaluated is quoted

;;; --- Program to be evaluated begins here ---

;; Well, it's the evaluator again.

(let*
    ((lookup
      (lambda (var env)
	(cdr (assq var env))))
     ($eval
      (lambda (exp env $eval $evals $eval-case $eval-let* $make-fun)
	(display "==>Evaluating expression:") (newline)
	(write exp) (display "<==") (newline)
	(if (pair? exp)
	    (case (car exp)
	      ((lambda)
	       ($make-fun (cadr exp) (cddr exp) env
			  $eval $evals $eval-case $eval-let* $make-fun))
	      ((quote) (cadr exp))
	      ((begin)
	       ($evals (cdr exp) env
		       $eval $evals $eval-case $eval-let* $make-fun))
	      ((if)
	       (if ($eval (cadr exp) env
			  $eval $evals $eval-case $eval-let* $make-fun)
		   ($eval (caddr exp) env
			  $eval $evals $eval-case $eval-let* $make-fun)
		   ($eval (cadddr exp) env
			  $eval $evals $eval-case $eval-let* $make-fun)))
	      ((or)
	       (or ($eval (cadr exp) env
			  $eval $evals $eval-case $eval-let* $make-fun)
		   ($eval (caddr exp) env
			  $eval $evals $eval-case $eval-let* $make-fun)))
	      ((case)
	       ($eval-case ($eval (cadr exp) env
				  $eval $evals $eval-case $eval-let* $make-fun)
			   (cddr exp) env
			   $eval $evals $eval-case $eval-let* $make-fun))
	      ((let*)
	       ($eval-let* (cadr exp) (cddr exp) env
			   $eval $evals $eval-case $eval-let* $make-fun))
	      (else
	       (($eval (car exp) env
		       $eval $evals $eval-case $eval-let* $make-fun)
		(map (lambda (x)
		       ($eval x env
			      $eval $evals $eval-case $eval-let* $make-fun))
				(cdr exp)))))
	    (if (symbol? exp)
		(lookup exp env)
		exp))))
     ($evals
      (lambda (exps env $eval $evals $eval-case $eval-let* $make-fun)
	(if (null? (cdr exps))
	    ($eval (car exps) env
		   $eval $evals $eval-case $eval-let* $make-fun)
	    (begin
	      ($eval (car exps) env
		     $eval $evals $eval-case $eval-let* $make-fun)
	      ($evals (cdr exps) env
		      $eval $evals $eval-case $eval-let* $make-fun)))))
     ($eval-case
      (lambda (val lines env $eval $evals $eval-case $eval-let* $make-fun)
	(if (or (eqv? (car (car lines)) 'else)
		(memq val (car (car lines))))
	    ($evals (cdr (car lines)) env
		    $eval $evals $eval-case $eval-let* $make-fun)
	    ($eval-case val (cdr lines) env
			$eval $evals $eval-case $eval-let* $make-fun))))
     ($eval-let*
      (lambda (defns body env $eval $evals $eval-case $eval-let* $make-fun)
	(if (null? defns)
	    ($evals body env
		    $eval $evals $eval-case $eval-let* $make-fun)
	    ($eval-let* (cdr defns)
			body
			(cons (cons (car (car defns))
				    ($evals (cdr (car defns)) env
					    $eval $evals $eval-case $eval-let* $make-fun))
					 env)
			$eval $evals $eval-case $eval-let*
			$make-fun))))
     ($make-fun
      (lambda (formals body denv $eval $evals $eval-case $eval-let* $make-fun)
	(lambda (values)
	  ($evals body (append (map cons formals values)
			       denv)
		  $eval $evals $eval-case $eval-let* $make-fun))))
     (initial-env (list (cons 'car (lambda (values) (apply car values)))
			(cons 'cdr (lambda (values) (apply cdr values)))
			(cons 'cadr (lambda (values) (apply cadr values)))
			(cons 'cddr (lambda (values) (apply cddr values)))
			(cons 'caddr (lambda (values) (apply caddr values)))
			(cons 'cdddr (lambda (values) (apply cdddr values)))
			(cons 'cadddr (lambda (values) (apply cadddr values)))
			(cons 'cons (lambda (values) (apply cons values)))
			(cons 'list (lambda (values) values))
			(cons 'append (lambda (values) (apply append values)))
			(cons 'apply (lambda (values)
				       ((car values) (cadr values))))
			(cons 'map (lambda (values)
				     (map (car values)
					  (apply map
						 (cons list
						       (cdr values))))))
			(cons 'eqv? (lambda (values) (apply eqv? values)))
			(cons 'memq (lambda (values) (apply memq values)))
			(cons 'assq (lambda (values) (apply assq values)))
			(cons 'pair? (lambda (values) (apply pair? values)))
			(cons 'symbol? (lambda (values) (apply symbol? values)))
			(cons 'null? (lambda (values) (apply null? values)))
			(cons 'display (lambda (values)
					 (display "[[[")
					 (apply display values)
					 (display "]]]") (newline)))
			(cons 'write (lambda (values)
				       (display "[[[")
				       (apply write values)
				       (display "]]]") (newline)))
			(cons 'newline (lambda (values)
					 (display "[[[")
					 (apply newline values)
					 (display "]]]") (newline)))
			))
     (terminal-eval
      (lambda (exp)
	($eval exp initial-env
	       $eval $evals $eval-case $eval-let* $make-fun))))
  (display "Now starting evaluation...") (newline)
  (lambda (fun) (terminal-eval (list fun (list 'quote fun))))
  )

;;; --- Program to be evaluated ends here ---

)