;;; Substitute Evaluator
;;; by : Cedric Lee
;;; date: May 1992
;;;JL this version does not have an APPLICATION rule, but has a COMPOUND rule
(define nl (gensym))
(define subst-prompt "subst-eval> ")
(define top-level #f) ; Top level continuation (for error handling).
(define error-flag #f) ; #t if an error occurred.
(define stop-flag (gensym)) ; Returned by stop procedure.
(define *single-step* #f) ; Do we pause between reductions?
;;; Syntax procedures
;;; First a utility procedure which returns the nth item of a list, or
;;; signals an error if it doesn't exist.
(define (careful-nth form n type message)
(cond
((null? form) (*eval-error type message))
((= n 0) (car form))
(else (careful-nth (cdr form) (- n 1) type message))))
(define (is-application? x)
(and (pair? x) (not (is-primitive? x))))
;;; Here's a list of special forms, for error checking during variable
;;; lookup.
(define special-forms '(define lambda if quote))
;;; Definitions have the form (DEFINE name value).
(define (is-definition? form)
(and (pair? form) (eq? (car form) 'define)))
(define (definition-name form)
(careful-nth form 1 'define "no name was given"))
(define (definition-value form)
(careful-nth form 2 'define "no value was given"))
;;; Lambda expressions have the form (LAMBDA args body), in which args
;;; is a proper list (no `rest' arguments), and body is a single form
;;; (no sequences).
(define (is-lambda? form)
(and (pair? form) (eq? (car form) 'lambda)))
(define (lambda-args form)
(careful-nth form 1 'lambda "no argument list was given"))
(define (lambda-body form)
(careful-nth form 2 'lambda "no body was given"))
;;; The only conditional supported is (if ). Because
;;; all forms are evaluated strictly for value, both the and
;;; parts must be present.
(define (is-conditional? form)
(and (pair? form) (eq? (car form) 'if)))
(define (conditional-condition form)
(careful-nth form 1 'if "no condition was given"))
(define (conditional-then form)
(careful-nth form 2 'if "no then-part was given"))
(define (conditional-else form)
(careful-nth form 3 'if "no else-part was given"))
;;; Quotations are of the form (QUOTE x).
(define (is-quotation? form)
(and (pair? form) (eq? (car form) 'quote)))
(define (quotation-value form)
(careful-nth form 1 'quote "no quoted value was given"))
;;; Primitive procedure type.
(define primflag (gensym))
(define (make-primitive primname proc)
`(,primflag ,primname ,proc))
(define (is-primitive? x)
(and (pair? x) (eq? (car x) primflag)))
(define (print-primitive x)
(display "{")
(display (cadr x))
(display "}"))
(define primitive-procedure caddr)
;;; Finally, the evaluator.
(define (subst-eval)
(*print 0 subst-prompt)
(set! error-flag #f)
(let ((form (read))
(result '()))
(if (eq? form 'single-step)
(set! *single-step* (not *single-step*))
(begin
(call/cc
(lambda (x)
(set! top-level x)
(set! result (subst-eval-form 1 form))))
(if error-flag
(*print 0
"Evaluation was terminated prematurely because of an error."
nl)
(*print 0 "Result: " result nl))))
(if (not (eq? result stop-flag))
(subst-eval))))
(define (*eval-error offender reason)
(*print 0 "I don't know how to evaluate " offender nl
" -- because " reason "." nl)
(set! error-flag #t)
(top-level error-flag))
(define subst-eval-form
(lambda (level f)
(if (is-primitive? f)
f
(let
((result #f)
(why #f))
(cond
((number? f)
(set! result f)
(set! why "NUMBER"))
((boolean? f)
(set! result f)
(set! why "BOOLEAN"))
((symbol? f)
(set! result (lookup-environ f))
(set! why "NAME"))
((is-lambda? f)
(set! result f)
(set! why "LAMBDA"))
((is-definition? f)
(let ((n (definition-name f))
(v (definition-value f)))
(insert-environ n (subst-eval-form (1+ level) v))
(*print level "Installing definition for " n " with value " v nl)
(set! result "Definitions have no result!!!")
(set! why "DEFINITION")))
((is-conditional? f)
(let ((c (conditional-condition f))
(t (conditional-then f))
(e (conditional-else f)))
(*print level "Preparing to use the IF rule." nl)
(cond ((subst-eval-form (1+ level) c)
(*print level
"if condition evaluates to #t; evaluating " t "." nl)
(set! result
(subst-eval-form (1+ level) t)))
(else
(*print level
"if condition evaluates to #f; evaluating " f "." nl)
(set! result
(subst-eval-form (1+ level) e))))
(set! why "IF")))
((is-application? f)
(*print level "Evaluating " f ", using the APPLICATION rule." nl)
(let*
((elements
(let ((result '()))
(for-each
(lambda (x)
(set! result (append result (list (subst-eval-form (1+ level) x)))))
f)
result))
(op (car elements))
(args (cdr elements)))
(cond
((is-lambda? op)
(if (not (= (length (lambda-args op)) (length args)))
(*eval-error f "you gave the wrong number of arguments."))
(let ((newform
(substitute (lambda-body op)
(map cons (lambda-args op) args))))
(*print (1+ level) "Substituting "
newform " for " f ", by the PROCEDURE rule." nl)
(set! result (subst-eval-form (1+ level) newform))
(set! why "PROCEDURE")))
((is-primitive? op)
(set! result (apply (primitive-procedure op) args))
(set! why "PRIMITIVE"))
(else
(*eval-error f "I don't know about that kind of form")))))
(else
(*eval-error f "I don't know about that kind of form")))
(*print level f " => " result ", by the " why " rule." nl)
result
)))
)
(define substitute
(lambda (form alist)
(if (pair? form)
(cons (substitute (car form) alist) (substitute (cdr form) alist))
(let ((z (assq form alist)))
(if (not z)
form
(cdr z))))))
;;; Environment management.
(define environment '())
(define lookup-environ
(lambda (x)
(let ((y (assq x environment)))
(if (not y)
(*eval-error x "it was not defined in the environment")
(cdr y)))))
(define insert-environ
(lambda (x y)
(let ((z (assq x environment)))
(if (not z)
(set! environment (cons (cons x y) environment))
(begin
(*print 0 "Redefining " x nl)
(set-cdr! z y)
)))))
;;; This is just a version of display which has a few frills:
;;; (1) it knows about primitives, and prints them readably.
;;; (2) it takes any number of objects, and prints them consecutively.
;;; (3) if any of the objects is the value nl, then it does a newline.
(define (*print level . objects)
(define (*print1 x)
(cond
((is-primitive? x) (print-primitive x))
(else (display "(") (*print 0 (car x)) (*print2 (cdr x)) (display ")"))))
(define (*print2 x)
(cond
((null? x))
((atom? x) (display " . ") (display x))
(else (display " ") (*print 0 (car x)) (*print2 (cdr x)))))
(define indent
(lambda (n)
(if (> n 0) (begin (display " ") (indent (- n 1))))))
(indent level)
(for-each
(lambda (x)
(if (eq? x nl)
(newline)
(cond
((pair? x) (*print1 x))
(else (display x)))))
objects))
;; Primitives.
(define number-dyadic
(lambda (f)
(lambda (x y)
(if (number? x)
(if (number? y)
(f x y)
(*eval-error y "I expected a number"))
(*eval-error x "I expected a number")))))
(define number-monadic
(lambda (f)
(lambda (x)
(if (number? x)
(f x)
(*eval-error x "I expected a number")))))
(begin
(insert-environ '+ (make-primitive 'plus (number-dyadic +)))
(insert-environ '- (make-primitive 'minus (number-dyadic -)))
(insert-environ '* (make-primitive 'times (number-dyadic *)))
(insert-environ '/ (make-primitive 'divide (number-dyadic /)))
(insert-environ '< (make-primitive 'less (number-dyadic <)))
(insert-environ '> (make-primitive 'greater (number-dyadic >)))
(insert-environ '= (make-primitive 'equal (number-dyadic =)))
(insert-environ 'max
(make-primitive 'maximum
(number-dyadic
(lambda (x y) (if (> x y) x y)))))
(insert-environ 'min
(make-primitive 'minimmum
(number-dyadic
(lambda (x y) (if (< x y) x y)))))
(insert-environ 'sqrt (make-primitive 'square-root (number-monadic sqrt)))
(insert-environ 'stop (make-primitive 'stop (lambda () stop-flag)))
(insert-environ 'pi 3.1415926)
"Ready to go!"
)