;;;; 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
;;; ( (ARGUMENTS) BODY ENV),
;;; where 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: ( (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.