;;;; METACIRCULAR EVALUATOR

;;;; Revised version of the evaluator presented in CHAPTER 4
;;;; (SECTIONS 4.1.1-4.1.4) of STRUCTURE AND INTERPRETATION OF
;;;; COMPUTER PROGRAMS

;;;; This file can be loaded into Scheme as a whole.
;;;; Then you can initialize and start the evaluator by evaluating
;;;; the expression (mce).

;;; SICP Metacircular Evaluator Scheme:
;;;   * Only numbers, strings, #t, and #f are valid self-evaluating
;;;     (literal) forms.
;;;   * Only the following special forms are defined:
;;;         if, cond, lambda, quote, define, begin, set!
;;;   * The following primitive procedures are defined:
;;;         car cdr cons null + - * / = > < >= <= list append equal?
;;;         number? symbol? procedure?
;;;
;;; See the NOTES at the end for implementation details, especially about
;;; our handling of environments.


;; The value of Scheme expression EXP in the environment ENV.  When
;; EXP is a define, destructively updates ENV to reflect the definition.
(define (mc-eval exp env)
  (let ((kind (expression-class exp)))
    (case kind
      ((self-evaluating)  exp)
      ((symbol)   (lookup-variable-value exp env))
      ((quote)    (operand 1 exp))
      ((set!)     (eval-assignment (operand 1 exp)
				   (operand 2 exp)
				   env))
      ((define)   (eval-definition (operand 1 exp)
				   (operand-list 2 exp)
				   env))
      ((if)       (eval-if (operand 1 exp) (operand 2 exp)
			   (optional-operand 3 exp)
			   env))
      ((lambda)   (make-procedure (operand 1 exp)
				  (operand-list 2 exp)
				  env))
      ((begin)    (eval-sequence (operand-list 1 exp) env))
      ((cond)     (mc-eval (cond->if exp) env))
      ((pair)     (mc-apply
		   (mc-eval (operand 0 exp) env)
		   (map (lambda (e) (mc-eval e env))
			(operand-list 1 exp))))
      (else       (error "Unknown expression type -- EVAL: " exp)))))

;; Apply PROCEDURE, which must be a MC-Scheme procedure value (either
;; primitive or compound) to the argument values ARGUMENTS
(define (mc-apply procedure arguments)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure procedure arguments))
        ((compound-procedure? procedure)
         (eval-sequence
           (procedure-body procedure)
           (extend-environment
             (procedure-parameters procedure)
             arguments
             (procedure-environment procedure))))
        (else
         (error
          "Unknown procedure type -- APPLY" procedure))))

;; The value of (if TEST THEN-PART ELSE-PART) in the environment ENV.
(define (eval-if test then-part else-part env)
  (if (true? (mc-eval test env))
      (mc-eval then-part env)
      (mc-eval else-part env)))

;; Assuming that EXPS is a list of MC-Scheme expressions, the result of
;; evaluating them in sequence in environment ENV, yielding the value of
;; the last one.
(define (eval-sequence exps env)
  (if (null? (cdr exps))
      (mc-eval (car exps) env)
      (begin
	(mc-eval (car exps) env)
	(eval-sequence (cdr exps) env))))

;; The result of evaluating (set! VARIABLE EXP) in environment ENV.
(define (eval-assignment variable exp env)
  (set-variable-value! variable
                       (mc-eval exp env)
                       env)
  'ok)

;; The result of evaluating (define HEADER . BODY) in environment ENV.
(define (eval-definition header body env)
  (cond ((symbol? header)
	 (define-variable! header (mc-eval (car body) env) env))
	((and (pair? header) (symbol? (operand 0 header)))
	 (eval-definition (operand 0 header)
			  (list (make-lambda (operand-list 1 header) body))
			  env))
	(else (error "Bad definition header: " header)))
  'ok)

;;; PART 2.  Support for parsing expressions

(define special-form-symbols '(cond if lambda quote define set! begin))

;; A symbol indicating what kind of Scheme-1 expression EXP is:
;;    symbol           For a symbol (identifier)
;;    self-evaluating  For strings, numbers, and booleans
;;    other            For other atoms (nil, vectors, etc.)
;;    cond, if, lambda, quote, define, begin, set!
;;                     For expressions whose car is one of these symbols
;;    pair             For other pairs.
(define (expression-class exp)
  (cond ((or (number? exp) (string? exp) (boolean? exp))
	 'self-evaluating)
	((symbol? exp) 'symbol)
	((atom? exp) 'other)
	((memq (car exp) special-form-symbols) (car exp))
	(else 'pair)))

;; Operand (subexpression) number N in the expression EXP, which must
;; be a combination or special form with at least N+1 items.
;; Operands are numbered from 0.
(define (operand n exp)
  (list-ref exp n))

;; Operand number N (>= 0) in the expression EXP, which must be a combination
;; or special form.  Returns #f (false) if EXP has fewer than N+1 operands.
(define (optional-operand n exp)
  (cond ((null? exp) #f)
	((eqv? n 0) (car exp))
	(else (optional-operand (- n 1) (cdr exp)))))

;; The list of operands (subexpressions) in expression EXP, beginning with
;; operand number N (numbering from 0).  EXP must be combination or special
;; form with at least N items.  Operands are numbered from 0.
(define (operand-list n exp)
  (list-tail exp n))

;; The expression (lambda PARAMETERS . BODY).  (That is, BODY is a *list* of
;; expressions).
(define (make-lambda parameters body)
  (cons 'lambda (cons parameters body)))

;; The expression (if PREDICATE CONSEQUENT ALTERNATIVE)
(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))

;; The expression (begin EXPRESSIONS) 
(define (make-begin expressions)
  (cons 'begin expressions))

;; A MC-Scheme 'if' expression that is equivalent to EXP, which must be
;; a valid Scheme-1 'cond' expression.
(define (cond->if exp)
  (expand-clauses (operand-list 1 exp)))

;; A MC-Scheme 'if' expression that is equivalent to the sequence of 
;; clauses CLAUSES, which must be from a valid Scheme-1 'cond' expression.
(define (expand-clauses clauses)
  (if (null? clauses)
      #f
      (let ((first (car clauses))
            (rest (cdr clauses)))
	(cond ((not (pair? first))
	       (error "Badly formed cond clause -- COND->IF" first))
	      ((not (eq? (operand 0 first) 'else))
	       (make-if (operand 0 first)
			(make-begin (operand-list 1 first))
			(expand-clauses rest)))
	      ((null? rest) (operand 1 first))
	      (else (error "ELSE clause isn't last -- COND->IF" clauses))))))

;;;SECTION 4.1.3

(define (true? x)
  (not (eq? x #f)))

;; A unique value that marks closure values.
(define closure-mark (list 'closure))

;; A compound procedure with formal parameters PARAMETERS (a list of
;; symbols), environment ENV, and BODY (a list of 0 or more definitions
;; followed by an expression) as the body.
(define (make-procedure parameters body env)
  (list closure-mark parameters body env))

;; True iff PROC is a value produced by make-procedure.
(define (compound-procedure? proc)
  (and (pair? proc) (eq? (car proc) closure-mark)))

(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))

(define environment-frame-marker '(#f #f))
(define (the-empty-environment) (list environment-frame-marker))

(define (extend-environment vars vals base-env)
  (cond ((= (length vars) (length vals))
	 (cons environment-frame-marker 
	       (append (map cons vars vals) base-env)))
	((< (length vars) (length vals))
          (error "Too many arguments supplied" vars vals))
	(else
          (error "Too few arguments supplied" vars vals))))

(define (lookup-variable-value var env)
  (let ((match (assq var env)))
    (if match (cdr match)
	(error "Undefined variable: " var))))

(define (set-variable-value! var val env)
  (let ((match (assq var env)))
    (if match (set-cdr! match val)
	(error "Undefined variable: " var))))

(define (define-variable! var val env)
  (define (scan items)
    (cond ((or (null? items) (eq? (car items) environment-frame-marker))
	   (set-cdr! env (cons (cons var val) (cdr env))))
	  ((eq? (caar items) var) (set-cdr! (car items) val))
	  (else (scan (cdr items)))))
  (scan (cdr env)))

;;;SECTION 4.1.4

(define the-global-environment (the-empty-environment))

;; The initial value for the global environment.
(define (setup-environment)
  (let ((initial-env
         (extend-environment (primitive-procedure-names)
                             (primitive-procedure-objects)
                             (the-empty-environment))))
    (define-variable! 'true #t initial-env)
    (define-variable! 'false #f initial-env)
    initial-env))

(define (primitive-procedure? proc)
  (procedure? proc))

(define apply-primitive-procedure apply)

(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'null? null?)
	(list '+ +)
	(list '- -)
	(list '* *)
	(list '/ /)
	(list '= =)
	(list '< <)
	(list '> >)
	(list '>= >=)
	(list '<= <=)
	(list 'list list)
	(list 'append append)
	(list 'equal? equal?)
	(list 'number? number?)
	(list 'symbol? symbol?)
	(list 'pair? pair?)
	(list 'procedure?
	      (lambda (x) (or (primitive-procedure? x)
			      (compound-procedure? x))))
	(list 'display (lambda (x) (display x)))
;;      more primitives
        ))

(define (primitive-procedure-names)
  (map car primitive-procedures))

(define (primitive-procedure-objects)
  (map cadr primitive-procedures))

(define standard-input-prompt "MC-Eval> ")
(define standard-output-prompt "")

;; Prompt for, read, evaluate, and print Scheme-1 expressions until
;; or end-of-file is read, using OUTER-ENV as the global environment.
;; INPUT-PROMPT and OUTPUT-PROMPT are issued before each input and output,
;; respectively.
(define (driver-loop input-prompt output-prompt)
  (define (loop)
     (prompt-for-input input-prompt)
     (let ((input (read)))
       (if (not (eof-object? input))
	   (let ((output (mc-eval input the-global-environment)))
	     (announce-output output-prompt)
	     (user-print output)
	     (loop)))))
  (run-restartably loop))

(define (prompt-for-input string)
  (display string)
  (flush))

(define (announce-output string)
  (display string))

(define (user-print object)
  (if (compound-procedure? object)
      (display (list 'compound-procedure
                     (procedure-parameters object)
                     (procedure-body object)))
      (display object))
  (newline))

;; Read, evaluate, and print Scheme definitions and expressions from
;; the standard input, starting with the standard predefined Scheme
;; environment.
(define (read-eval-print)
  (display "Scheme Interpreter") (newline)
  (set! the-global-environment (setup-environment))
  (driver-loop standard-input-prompt standard-output-prompt))

;; Read, evaluate, and print Scheme definitions and expressions from
;; the file named FILE-NAME, starting with the standard predefined
;; Scheme environment.
(define (read-eval-print-file file-name)
  (set! the-global-environment (setup-environment))
  (with-input-from-file file-name
    (lambda () (driver-loop "" ""))))

;;; Testing

;; Given that TESTS is a list of lists, each of the form (INPUT OUTPUT),
;; check that in each case, the evaluation of (PROC INPUT) yields OUTPUT
;; (using equal? to check). 
(define (test-proc proc tests)
  (if (not (null? tests))
      (let* ((input (caar tests))
	     (output (cadar tests))
	     (result (proc input)))
	(if (not (equal? result output))
	    (format (current-output-port) 
		    "Error: input ~a yields ~a instead of ~a~%" 
		    input result output))
	(test-proc proc (cdr tests)))))

;;; Arcane Special Effects

;; Repeatedly execute THUNK (a "thunk" is a parameterless function) until
;; it exits normally (i.e., other than as a result of an error). See NOTES
;; for details, if curious.
(define (run-restartably thunk)
  (let ((want-to-leave? #f))
    (call/cc 
     (lambda (continue)
       (dynamic-wind
	   (lambda () #f)
	   (lambda () (thunk) (set! want-to-leave? #t))
	   (lambda () (continue)))))
    (if (not want-to-leave?) (run-restartably thunk))))

;; Arrange for Scheme to cause an error when sent an interrupt from the 
;; keyboard.
(set-signal-handler! |SIGINT| (lambda (sig) (error "Interrupt")))

;;; NOTES.
;;; Representing Scheme Values
;;;   It's convenient (actually, kind of obvious) to represent most Scheme
;;;   values "as themselves".  Thus, the Scheme values used in the evaluator
;;;   to represent all Scheme's values other than closures (i.e., the
;;;   results of evaluating lambda expressions) will be those values
;;;   themselves: evaluating 3 in Scheme yields 3, (cons 1 2),
;;;   yields (1 . 2), and so forth.
;;;
;;;   For lambda, we have a little problem.  You might think we could
;;;   simply represent result of evaluating (lambda (x) x) as the list
;;;   (lambda (x) x), but then how do we tell the value of
;;;      (lambda (x) x)
;;;   from the value of
;;;      (list 'lambda (list 'x) 'x)
;;;   or of
;;;      '(lambda (x) x)  ?
;;;   So in Scheme, we're going to "mark" closures with a special value,
;;;   closure-mark, defined below.  This value will have the property that
;;;   no value a user can produce with a Scheme program can be eq? to it.
;;;   We will represent a Scheme closure value, then, with a Scheme list
;;;   of the form
;;;       (<closure> (ARGUMENTS) BODY ENV),
;;;   where <closure> here stands for the value of closure-mark.  ENV is
;;;   the inner environment at the time the lambda is evaluated (that is,
;;;   enclosing parameter definitions, but not the outer environment, which
;;;   contains predefined names and the results of 'defines').
;;;
;;; Environments
;;;   In this version, we use mutation (set-cdr!) to modify
;;;   environments.  This allows us both to implement set! in an obvious
;;;   fashion, and to get recursive and mutually recursive function
;;;   definitions in the usual way using define.  An environment is an
;;;   "association list" and looks like this:
;;;
;;;       ((#f #f) (symbol0 . value0) (symbol1 . value1) ...
;;;        (#f #f) (symboln valuen) ...)
;;;
;;;   An environment frame consists of the symbols and values after an
;;;   instance of the frame marker (#f #f) and before the end of the
;;;   list or the next frame marker.  There's a little trick here: #f
;;;   is not eq? to any symbol, and so we can safely use it as a
;;;   "sentinel" to head up each frame without interfering with
;;;   searches.  The reason for the using these frame markers has to
;;;   do with the need to expand a frame while still maintaining its
;;;   identity.  Suppose we want to make the following two mutually
;;;   recursive definitions:
;;;
;;;     (define (f L) (if (null? L) '() (cons (g (car L)) (f (cdr L))))
;;;     (define (g L) (if (pair? L) (f L) 42))
;;;
;;;   These are equivalent to
;;;
;;;     (define f (lambda (L)
;;;         (if (null? L) '() (cons (g (car L)) (f (cdr L))))))
;;;     (define g (lambda (L) (if (pair? L) (f L) 42)))
;;;
;;;   What do we use as the values of the lambda expressions?  Well, we need
;;;   two compound procedures, BOTH of which have the same
;;;   procedure-environment component, and this environment component must
;;;   contain both the definition of f and g---it's a circular data structure.
;;;   But at the time we evaluate the definition of f, g is not in the
;;;   environment (neither is f, for that matter) and at the time we
;;;   evaluate the definition of g, the lambda expression for f has already
;;;   been evaluated.  In effect, we want to be able to retroactively
;;;   change the environment parts of both f and g to contain both their
;;;   definitions WITHOUT going back and changing each of the two
;;;   compound procedures we created when we made these definitions.
;;;
;;;   To accomplish this neat little trick, we start with an environment
;;;   (let's call it E0) that looks like this:
;;;
;;;       E0: [ * | *-]--->[ * | *-] ---> ...
;;;             |            |
;;;             v            v
;;;          (#f #f)      (s0 v0)
;;;
;;;   We first compute the value of f: (<closure> (L) BODY-OF-F E0)
;;;   Now we use set-cdr! to insert a new entry to f just after the
;;;   existing cell for E0.  Likewise for g.  We end up with this:
;;;       
;;;       E0: [ * | *-]--->[ * | *-] ---> [ * | *-] ---> [ * | *-] ---> ...
;;;        ^    |            |              |              |
;;;        |    v            v              v              v
;;;        | (#f #f)      (f (... *))     (g (... *))     (s0 v0)
;;;        |			  |		  |
;;;	   +----------------------+---------------+
;;;
;;;   which gives us exactly what we want!
;;;
;;; Recovering From Errors
;;;   You need not understand the run-restartably function, except for its
;;;   purpose: to allow the interpreter to continue even after a user program 
;;;   has caused a Lisp error (say by taking the car of '()).  For the 
;;;   ambitiously curious, however, here's an explanation.
;;;
;;;   (dynamic-wind thunk1 thunk2 thunk2) normally just executes
;;;      (thunk1) (thunk2) (thunk3)
;;;   That is, it calls its three function arguments (all parameterless 
;;;   functions) in turn.  If (thunk2) exits as a result of an error or
;;;   calling a continuation (see below), which would normally cause
;;;   evaluation of (thunk3) to be skipped, dynamic-wind instead arranges 
;;;   to call (thunk3) first, before the exit occurs.
;;;
;;;   (call/cc func) is probably the most bizarre function in all of Scheme.
;;;   It basically just calls (FUNC cont), where cont is a special kind of
;;;   parameterless function known as a "continuation" (call/cc itself is
;;;   short for call-with-current-continuation).  Suppose the program looks
;;;   like this:
;;;     (call/cc func)
;;;     (do-something-else)
;;;   If FUNC or something it calls ever calls cont (with (cont)), the effect
;;;   is to exit from FUNC (and any functions it may have called) and 
;;;   continue executing the program at (do-something-else).  This gives the
;;;   functionality of "exceptions" in Java or C++, and considerably more as
;;;   as well.  (Things get particularly interesting when a function 
;;;   RETURNS a continuation which the program later calls---that causes the
;;;   function to "unreturn" and resume execution.  We DON'T use that 
;;;   power here!).
;;;
;;;   (set-signal-handler! SIGNAL HANDLER) is an STk function that
;;;   causes Scheme to respond to the UNIX signal SIGNAL by calling 
;;;   HANDLER (a one-argument function).  |SIGINT| is the name of the
;;;   signal that is sent to your program by Control-C (at least in our
;;;   setup).  This call allows you to interrupt the current evaluation
;;;   and do something useful.