;;; A metacircular evaluator for Scheme.
;;;
;;; This program is a simple Scheme evaluator, written in Scheme.
;;;
;;; Copyright (C) Vincent Manis, 1991.
;;;
;;; Cosmetic changes by Carl Alphonce, June 1992.
;;;
;;; Code added by Johnny Kam and polished by Carl Alphonce, June 1992.
;;;
;;; assq->assv by Jim Little, March 1993.
;;; find-binding a semi-predicate now Jim Little, March 1993.
;;;
;;; Cosmetic changes, moduleized, macros changed, and user interface revised,
;;; Vincent Manis, 1993 November.
;;;
;;; Harmonized with text (cosmetically). J. Little 1995 June
;;; The following constants are used by various parts of the evaluator. Any
;;; values could be used, except that the values must not appear in any
;;; Scheme code to be evaluated.
(define unbound '**unbound**)
;;; This module defines the format of a procedure. A procedure contains the
;;; code for a procedure, along with the environment which was current
;;; when the procedure was built.
(module self-eval-procedure
(export make-procedure is-procedure? procedure-params procedure-body
procedure-env)
;; The representation used here is not particularly efficient: a procedure
;; is represented by a 4-element list:
;;
;; (**procedure** args body env)
;;
;; where `args' is the argument list of the procedure, `body' is the
;; procedure's body, and env is the environment which was active at the
;; time the procedure was created.
(define procedure-flag '**procedure**)
(define make-procedure
(lambda (args body env)
(list procedure-flag args body env)))
(define is-procedure?
(lambda (proc)
(and (pair? proc) (eqv? (car proc) procedure-flag))))
(define procedure-params
(lambda (proc)
(if (is-procedure? proc)
(list-ref proc 1)
(evaluator-error "Procedure expected" proc))))
(define procedure-body
(lambda (proc)
(if (is-procedure? proc)
(list-ref proc 2)
(evaluator-error "Procedure expected" proc))))
(define procedure-env
(lambda (proc)
(if (is-procedure? proc)
(list-ref proc 3)
(evaluator-error "Procedure expected" proc))))
)
;;; This module defines an environment type. An environment is a list of
;;; `frames', each containing the bindings for a particular procedure
;;; application.
(module self-eval-frames
(export extend-environment get-binding set-binding def-binding)
;; extend-environment -- add a frame to an existing environment
;;
;; Arguments:
;; names -- the list of names to be bound.
;; values -- a list of values, of the same length as names.
;; env -- the parent environment.
;; Return value:
;; a new environment, with the specified bindings, whose parent is
;; env.
(define extend-environment
(lambda (names values env)
(letrec
((new-frame
(lambda (n v)
(if (and (null? n) (null? v))
'()
(if (null? n)
(evaluator-error
"Too many arguments" (cons names values))
(if (null? v)
(evaluator-error
"Too few arguments" (cons names values))
(if (and (pair? n) (symbol? (car n)))
(cons
(cons (car n) (car v))
(new-frame (cdr n) (cdr v)))
(evaluator-error
"Invalid argument list" names))))))))
(cons (new-frame names values) env))))
;; find-binding -- look up a symbol in an environment.
;;
;; Arguments:
;; symb -- the name to be searched for.
;; env -- the environment.
;; Return value:
;; a) a pair (the binding) if it exists.
;; b) #f if no binding can be found.
;;
;; This is a utility routine used by the get/put binding procedures.
(define find-binding
(lambda (symb env)
(if (null? env)
#f
(let ((x (assv symb (car env))))
(if (not x)
(find-binding symb (cdr env))
x)))))
;; get-binding -- search for a variable in an environment.
;;
;; Arguments:
;; symb -- the symbol to be searched for.
;; env -- the environment to be used.
;; Return value:
;; the value of the symbol. An error is generated if the symbol is
;; not bound.
(define get-binding
(lambda (symb env)
(let ((x (find-binding symb env)))
(if (not x)
(evaluator-error "Unbound variable (get)" symb)
(cdr x)))))
;; set-binding -- assign a new value to an already-bound variable.
;;
;; Arguments:
;; symb -- the variable name.
;; val -- the new value to be given.
;; env -- the environment.
;; Return value:
;; none.
;;
;; If the symbol is bound *anywhere* in the environment, its value will
;; be mutated. If it is unbound, an error is generated.
(define set-binding
(lambda (symb val env)
(let ((x (find-binding symb env)))
(if (not x)
(evaluator-error "Unbound variable (set)" symb)
(set-cdr! x val)))))
;; def-binding -- create a *new* variable binding.
;;
;; Arguments:
;; symb -- the symbol to be bound.
;; val -- the new value to be assigned.
;; env -- the environment to be used.
;; Return value:
;; none.
;;
;; If the symbol is bound in the top frame of the environment, then
;; the binding is mutated (a la put-binding). If the symbol is unbound
;; in the top frame, EVEN IF IT IS BOUND IN A LOWER LAYER, a new
;; binding for it is created in the top frame.
(define def-binding
(lambda (symb val env)
(let ((x (assv symb (car env))))
(if (not x)
(set-car! env (cons (cons symb val) (car env)))
(set-cdr! x val)))))
) ;;; end of module self-eval-frames
;;; This module contains the evaluator proper, along with procedures for
;;; handling special forms.
(module self-eval-evaluator
(export define-special-forms self-eval)
;;; get-arg -- get the n-th element of a list.
;;;
;;; Arguments:
;;; exp -- the list.
;;; n -- the number of elements to skip (counting from 0).
;;;
;;; Return value:
;;; if n < (length exp), the n-th element. Otherwise, it generates an
;;; error.
(define get-arg
(lambda (exp n)
(car (get-rest exp n))))
;;; get-rest -- get the n-th tail of a list.
;;;
;;; Arguments:
;;; exp -- the list.
;;; n -- the number of elements to skip (counting from 0).
;;;
;;; Return value:
;;; if n < (length exp), the sublist obtained by taking n cdrs of exp.
;;; Otherwise, it generates an error.
(define get-rest
(lambda (exp n)
(letrec
((find
(lambda (x n)
(if (pair? x)
(if (= n 0)
x
(find (cdr x) (- n 1)))
(evaluator-error "Invalid expression" exp)))))
(find exp n))))
;;; self-sequence -- evaluate a sequence.
;;;
;;; Arguments:
;;; exp -- a list containing a sequence of forms.
;;; env -- the environment to be used.
;;; Return value:
;;; the value of the last form.
(define self-sequence
(lambda (exp env)
(letrec
((seq
(lambda (val exp env)
(if (null? exp)
val
(seq (self-eval (car exp) env) (cdr exp) env)))))
(seq unbound exp env))))
;;; The list of special forms.
(define special-forms '())
(define define-special
(lambda (symb proc)
(let ((x (assv symb special-forms)))
(if x
(set-cdr! x proc)
(set! special-forms
(cons (cons symb proc) special-forms))))))
(define define-special-forms
(lambda ()
(define-special 'quote
(lambda (exp env)
(get-arg exp 1)))
(define-special 'lambda
(lambda (exp env)
(make-procedure
(get-arg exp 1)
(get-rest exp 2)
env)))
(define-special 'set!
(lambda (exp env)
(set-binding
(get-arg exp 1)
(self-eval (get-arg exp 2) env) env)
(void)))
(define-special 'if
(lambda (exp env)
(if (self-eval (get-arg exp 1) env)
(self-eval (get-arg exp 2) env)
(self-eval (get-arg exp 3) env))))
(define-special 'begin
(lambda (exp env)
(self-sequence (get-rest exp 1) env)))
(define-special 'define
(lambda (exp env)
(def-binding
(get-arg exp 1)
(self-eval (get-arg exp 2) env) env)
(void)))
(define-special 'define-macro
(lambda (exp env)
(def-macro
(get-arg exp 1)
(self-eval (get-arg exp 2) env))
(void)))
))
(define def-macro
(lambda (mac-name expander)
(define-special mac-name
(lambda (exp env)
(self-eval
(self-sequence
(procedure-body expander)
(extend-environment (procedure-params expander)
(list exp)
(procedure-env expander)))
env)))))
(define self-eval
(lambda (exp env)
(simple-form exp env)))
(define constant?
(lambda (exp)
(or (number? exp) (boolean? exp) (string? exp))))
(define simple-form
(lambda (exp env)
(cond
((constant? exp)
exp)
((symbol? exp)
(get-binding exp env))
((pair? exp)
(let ((b (assv (car exp) special-forms)))
((if b (cdr b) self-application) exp env)))
(else (evaluator-error "Incorrect expression" exp)))))
(define self-application
(lambda (exp env)
(let*
((eval-arg (lambda (arg) (self-eval arg env)))
(evaluated-args (map eval-arg exp))
(operator (car evaluated-args))
(operands (cdr evaluated-args)))
(cond
((is-primitive? operator)
((primitive-procedure operator) operands))
((is-procedure? operator)
(self-sequence
(procedure-body operator)
(extend-environment
(procedure-params operator)
operands
(procedure-env operator))))
(else
(evaluator-error "Procedure required" exp))))))
)
(module self-eval-primitives
(export is-primitive? primitive-procedure make-primitive-environment)
;;; Purpose: define all of the primitives.
;;;
;;; Here we actually build the primitive environment. Naturally, you
;;; can insert whatever names you like, with whatever procedures or other
;;; values you choose. This module is intentionally kept small here, with
;;; just enough primitives to show that things work.
(define is-primitive? procedure?)
;;; particularly simple since we just use procedures
(define primitive-procedure (lambda (x) x))
(define make-primitive-environment
(lambda ()
(let ((pf (extend-environment '() '() '())))
(let
((def
(lambda (name proc)
(def-binding name proc pf))))
;; Arithmetic procedures.
(def '+ (lambda (x) (+ (car x) (car (cdr x)))))
(def '- (lambda (x) (- (car x) (car (cdr x)))))
(def '* (lambda (x) (* (car x) (car (cdr x)))))
(def '/ (lambda (x) (/ (car x) (car (cdr x)))))
;; Comparisons.
(def '< (lambda (x) (< (car x) (car (cdr x)))))
(def '= (lambda (x) (= (car x) (car (cdr x)))))
(def '> (lambda (x) (> (car x) (car (cdr x)))))
;; What's defined in the primitive environment need not be
;; procedures.
(def 'pi 3.1415926)
;; Hey, you can work with pairs!
(def 'car (lambda (x) (car (car x))))
(def 'cdr (lambda (x) (cdr (car x))))
(def 'cons (lambda (x) (cons (car x) (car (cdr x)))))
(def 'null? (lambda (x) (null? (car x))))
(def 'eqv? (lambda (x) (eqv? (car x) (car (cdr x)))))
(def 'not (lambda (x) (not (car x))))
;; Input/output.
(def 'display (lambda (x) (show (car x)))) ; thanks RJW
(def 'newline (lambda (x) (newline)))
pf))))
) ;;; end of module self-eval-primitives
;;; This module contains a ``top-level'' procedure, which displays a
;;; prompt, reads a form, and then evaluates it. This user interface
;;; can be extended in many ways, including remembering previous
;;; results, or even working with a window system.
(module self-eval-user
(export top-level evaluator-error)
;; top-level -- interact with a user.
;;
;; This procedure reads an expression from the user, evaluates it,
;; and displays the result.
;;
;; Arguments:
;; none.
;; Return value:
;; none.
;;
(define prompt "se> ")
(define answer-prefix " => ")
(define terminator '(stop))
(define top-level
(lambda ()
(define-special-forms)
(let
((env (make-primitive-environment)))
(letrec
((read-eval-print-loop
(lambda ()
(display prompt)
(let
((form (read)))
(if (equal? form terminator)
(begin
(format #t "...and a pleasant day to you!~%")
(void))
(let ((answer (self-eval form env)))
(if (not (eqv? (void) answer))
(begin
(display answer-prefix)
(show answer)
(newline)))
(read-eval-print-loop)))))))
(read-eval-print-loop)))))
;; evaluator-error -- handle an error in a user form.
;;
;; Arguments:
;; what: an error code, indicating what sort of error was detected.
;; irritant: the data which caused the problem, e.g., name of an unbound
;; variable. If `(void)' is used, the irritant isn't printed.
;; env: the environment at the time of the error.
;; Return value:
;; none.
;;
;; This procedure ought to do all sorts of things. It ought to cancel the
;; evaluation of the current form. It ought to give the user a chance to
;; look through things to see what's wrong. It ought to allow the user to
;; get on-line help about what might have gone wrong. But in the interests
;; of simplicity...
(define evaluator-error
(lambda (what irritant)
(format #t "~%Error in self-eval: ~a: " what)
(if (not (eqv? (void) irritant))
(display irritant))
;; Don't do anything with the environment.
(format #t "~%...resetting to top level.~%")
(top-level)))
)
;;; This module contains a procedure, show, which acts like display.
;;; The difference between show and display is that show will
;;; print a list representing a procedure as '{procedure}'. This
;;; is essential because a procedure contains an environment within
;;; it. If the procedure is the value of a binding, then the
;;; environment will contain a definition for that name. Hence
;;; we get a circular structure, which will take a very long time
;;; to print.
(module self-eval-show
(export show)
;; Let's make our show routine very easily customizable. Suppose we
;; wanted to use square brackets...
(define left-list-bracket "(")
(define right-list-bracket ")")
(define improper-list-separator " . ")
(define procedure-marker "{procedure}")
;; show -- display a list structure in a similar manner to what Scheme
;; does, but print procedures as '{procedure}'.
;;
;; Arguments:
;; x -- a Scheme value to be displayed.
;;
;; Return value:
;; none.
;;
(define show
(lambda (x)
(letrec
(
(show1
;; show1 is given a list as an argument, and displays the first
;; element, calling show2 to do the rest.
(lambda (x)
(display left-list-bracket)
(show (car x))
(show2 (cdr x))))
(show2
;; show2 is given a ``list tail'' as an argument, and displays
;; the first element. show2 worries about procedures.
(lambda (x)
(if (null? x)
(display right-list-bracket)
(if (pair? x)
(begin
(display " ")
(if (is-procedure? x)
(begin
(display procedure-marker)
(display right-list-bracket))
(begin
(show (car x))
(show2 (cdr x)))))
(begin
(display improper-list-separator)
(display x)
(display right-list-bracket))
)))))
;; The main part of the procedure.
(if (pair? x)
(if (is-procedure? x)
(display procedure-marker)
(show1 x))
(display x)))))
)