428 lines
15 KiB
Racket
428 lines
15 KiB
Racket
#lang sicp
|
|
|
|
(#%require racket/trace)
|
|
(#%require (only racket/base when))
|
|
|
|
(#%require "dispatch-table.rkt")
|
|
(#%require "syntax.rkt")
|
|
(#%require "environment.rkt")
|
|
(#%require "common.rkt")
|
|
|
|
;; This is a lightly modified version of ch4-mceval.scm to work in racket.
|
|
|
|
;;;;METACIRCULAR EVALUATOR FROM CHAPTER 4 (SECTIONS 4.1.1-4.1.4) of
|
|
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
|
|
|
|
;;;;Matches code in ch4.scm
|
|
|
|
;;;;This file can be loaded into Scheme as a whole.
|
|
;;;;Then you can initialize and start the evaluator by evaluating
|
|
;;;; the two commented-out lines at the end of the file (setting up the
|
|
;;;; global environment and starting the driver loop).
|
|
|
|
;;;;**WARNING: Don't load this file twice (or you'll lose the primitives
|
|
;;;; interface, due to renamings of apply).
|
|
|
|
;;;from section 4.1.4 -- must precede def of metacircular apply
|
|
;; Racket doesn't seem to like this. Instead rename the apply here to
|
|
;; mce-apply.
|
|
;;(define apply-in-underlying-scheme apply)
|
|
|
|
;;;SECTION 4.1.1
|
|
|
|
|
|
(define type-tag car)
|
|
(define dispatch-table (make-dispatch-table))
|
|
|
|
;; Data directed eval. Consult the eval dispatch table that uses the
|
|
;; car of the expression to get the type-tag. Only if nothing matches from
|
|
;; the dispatch table, attempt to evaluate as an application. This is very similar
|
|
;; to the data-directed dispatch for symbolic differentiation in exercise
|
|
;; 3.73. The main difference is that we have another case to consider
|
|
;; if the lookup fails (ie application).
|
|
(define (mce-eval exp env)
|
|
(cond ((self-evaluating? exp) exp)
|
|
((variable? exp) (lookup-variable-value exp env))
|
|
((get dispatch-table (type-tag exp))
|
|
=> (lambda (proc) (proc exp env)))
|
|
((application? exp)
|
|
(mce-apply (mce-eval (operator exp) env)
|
|
(list-of-values (operands exp) env)))
|
|
(else
|
|
(error "Unknown expression type -- EVAL" exp))))
|
|
|
|
(define (mce-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 -- MCE-APPLY" procedure))))
|
|
|
|
(define (true? x)
|
|
(not (eq? x false)))
|
|
|
|
(define (false? x)
|
|
(eq? x false))
|
|
|
|
;; Evaluation rules
|
|
(define (list-of-values exps env)
|
|
(if (no-operands? exps)
|
|
'()
|
|
(cons (mce-eval (first-operand exps) env)
|
|
(list-of-values (rest-operands exps) env))))
|
|
|
|
;; Exercise 4.16: Scan out the defines when accessing the body, so we
|
|
;; only incur the overhead if it is needed. There may be procedure
|
|
;; bodies that are never evaluated, so it makes sense to process them
|
|
;; lazily.
|
|
(define (procedure-body p) (scan-out-defines (caddr p)))
|
|
(define (procedure-environment p) (cadddr p))
|
|
|
|
;; Exercise 4.16: transform the body to scan out internal
|
|
;; definitions. Variables will be created unassigned by a let and
|
|
;; then initialised by a set! inside the let body. Perhaps it is
|
|
;; possible to do this in one pass while still keeping the clean
|
|
;; recursive structure (ie not resorting to append or set! at each
|
|
;; iteration), but this is probably good enough, given that the size
|
|
;; of the body is likely to be quite small.
|
|
(define (scan-out-defines body)
|
|
;; Get a list of defined variables in the body
|
|
(define (scan-vars body)
|
|
(if (null? body)
|
|
'()
|
|
(let ((exp (first-exp body)))
|
|
(if (definition? exp)
|
|
(cons (definition-variable exp)
|
|
(scan-vars (rest-exps body)))
|
|
(scan-vars (rest-exps body))))))
|
|
;; Convert all definitions to assignments
|
|
(define (definition->assignment body)
|
|
(if (null? body)
|
|
'()
|
|
(let ((exp (first-exp body)))
|
|
(cons
|
|
(if (definition? exp)
|
|
(make-assignment (definition-variable exp)
|
|
(definition-value exp))
|
|
exp)
|
|
(definition->assignment (rest-exps body))))))
|
|
(define (make-unassigned-let vars body)
|
|
(make-let
|
|
(map (lambda (var)
|
|
(list var '*unassigned*))
|
|
vars)
|
|
body))
|
|
(let ((vars (scan-vars body)))
|
|
(if (null? vars)
|
|
body
|
|
(make-body
|
|
(make-unassigned-let vars
|
|
(definition->assignment body))))))
|
|
|
|
|
|
|
|
(define (eval-if exp env)
|
|
(if (true? (mce-eval (if-predicate exp) env))
|
|
(mce-eval (if-consequent exp) env)
|
|
(mce-eval (if-alternative exp) env)))
|
|
|
|
(define (eval-sequence exps env)
|
|
(cond ((last-exp? exps) (mce-eval (first-exp exps) env))
|
|
(else (mce-eval (first-exp exps) env)
|
|
(eval-sequence (rest-exps exps) env))))
|
|
|
|
(define (eval-assignment exp env)
|
|
(set-variable-value! (assignment-variable exp)
|
|
(mce-eval (assignment-value exp) env)
|
|
env)
|
|
'ok)
|
|
|
|
(define (eval-definition exp env)
|
|
(define-variable! (definition-variable exp)
|
|
(mce-eval (definition-value exp) env)
|
|
env)
|
|
'ok)
|
|
|
|
(define (eval-unbind exp env)
|
|
(make-unbound-variable! (unbound-variable exp) env))
|
|
|
|
(define (eval-and conjuncts env)
|
|
(cond ((null? conjuncts)
|
|
'true)
|
|
((last-conjunct? conjuncts)
|
|
(mce-eval (first-conjunct conjuncts) env))
|
|
((false? (mce-eval (first-conjunct conjuncts) env))
|
|
'false)
|
|
(else
|
|
(eval-and (make-and (rest-conjuncts conjuncts)) env))))
|
|
|
|
(define (eval-or disjuncts env)
|
|
(if (null? disjuncts)
|
|
'false
|
|
(let ((val (mce-eval (first-disjunct disjuncts) env)))
|
|
(if val
|
|
val
|
|
(eval-or (make-or (rest-disjuncts disjuncts)) env)))))
|
|
|
|
;; As derived forms. Not complete; would need negation, which we don't
|
|
;; seem to have yet.
|
|
;;
|
|
;; (and a b) -> (if (eq? a #f) #f (if (eq? b #f) #f b))
|
|
;; (or a b) -> (if a a (if b b #f))
|
|
|
|
;; (define (and->if predicates)
|
|
;; (expand-and-to-if predicates))
|
|
|
|
;; (define (expand-and-to-if predicates)
|
|
;; (if (null? predicates)
|
|
;; 'true
|
|
;; (let ((first (first-predicate predicates))
|
|
;; (rest (rest-predicates predicates)))
|
|
;; (if (last-predicate? predicates)
|
|
;; first
|
|
;; (make-if (false? first) ; Need an expression not a value
|
|
;; 'false
|
|
;; (expand-and-to-if rest))))))
|
|
|
|
;; Exercise 4.6
|
|
|
|
;; Reduce (let ((var1 exp1) ... (varn expn)) body) to
|
|
;; ((lambda (var1 ... varn) (body)) (exp1 ... expn))
|
|
|
|
;;;SECTION 4.1.3
|
|
|
|
|
|
(define input-prompt ";;; M-Eval input:")
|
|
(define output-prompt ";;; M-Eval value:")
|
|
|
|
(define (repl)
|
|
(define the-global-environment (setup-environment))
|
|
(define (driver-loop)
|
|
(prompt-for-input input-prompt)
|
|
(let ((input (read)))
|
|
(let ((output (mce-eval input the-global-environment)))
|
|
(announce-output output-prompt)
|
|
(mce-user-print output))
|
|
(driver-loop)))
|
|
(driver-loop))
|
|
|
|
(define (prompt-for-input string)
|
|
(newline) (newline) (display string) (newline))
|
|
|
|
(define (announce-output string)
|
|
(newline) (display string) (newline))
|
|
|
|
(define (mce-user-print object)
|
|
(if (compound-procedure? object)
|
|
(display (list 'compound-procedure
|
|
(procedure-parameters object)
|
|
(procedure-body object)
|
|
'<procedure-env>))
|
|
(display object)))
|
|
|
|
;; Data directed version
|
|
|
|
;; Each procedure takes the expression and environment as arguments
|
|
(define mce-dispatch-alist
|
|
`((if ,eval-if)
|
|
(begin
|
|
,(lambda (exp env)
|
|
(eval-sequence (begin-actions exp) env)))
|
|
(set! ,eval-assignment)
|
|
(define ,eval-definition)
|
|
(make-unbound! ,eval-unbind)
|
|
(quote
|
|
,(lambda (exp env)
|
|
(text-of-quotation exp)))
|
|
(lambda
|
|
,(lambda (exp env)
|
|
(make-procedure (lambda-parameters exp)
|
|
(lambda-body exp)
|
|
env)))
|
|
(cond
|
|
,(lambda (exp env)
|
|
(mce-eval (cond->if exp) env)))
|
|
(and ,eval-and)
|
|
(or ,eval-or)
|
|
(let ,(lambda (exp env)
|
|
(mce-eval (let->combination exp) env)))
|
|
(let* ,(lambda (exp env)
|
|
(mce-eval (let*->nested-let exp) env)))
|
|
(letrec ,(lambda (exp env)
|
|
(mce-eval (letrec->let exp) env)))
|
|
(for ,(lambda (exp env)
|
|
(mce-eval (for->named-let exp) env)))
|
|
(unless ,(lambda (exp env)
|
|
(mce-eval (unless->if exp) env)))))
|
|
|
|
;; (define (eval-dispatch-lookup type)
|
|
;; ((dispatch-table 'lookup) type))
|
|
|
|
|
|
'METACIRCULAR-EVALUATOR-LOADED
|
|
|
|
(#%require (only racket/base module+))
|
|
|
|
(module+ main
|
|
(define the-global-environment (setup-environment))
|
|
;; (driver-loop)
|
|
)
|
|
|
|
(module+ test
|
|
|
|
(define (fib n)
|
|
(let fib-iter ((a 1)
|
|
(b 0)
|
|
(count n))
|
|
(if (= count 0)
|
|
b
|
|
(fib-iter (+ a b) a (- count 1)))))
|
|
|
|
;; (map fib '(1 2 3 4 5 6 7 8 9 10)) -> (1 1 2 3 5 8 13 21 34 55)
|
|
)
|
|
|
|
;; Exercise 4.15: Suppose for any p and a (halts? p a) returns #t if p
|
|
;; halts on a or #f otherwise.
|
|
|
|
;; Define:
|
|
;; (define (run-forever) (run-forever))
|
|
;; (define (try p)
|
|
;; (if (halts? p p) (run-forever) 'halts))
|
|
|
|
;; If (try try) halts then (halts? p p) -> #t, which implies (try p p)
|
|
;; -> (run-forever). If (try try) doesn't halt, then (halts? p p) -> #f,
|
|
;; which implies (try try) -> 'halts. This is a contradiction, so
|
|
;; halts? cannot exist.
|
|
|
|
|
|
|
|
;; Exercise 4.17: For the case of sequential definitions: (lambda
|
|
;; <vars> (define u <e1>) (define v <e2>) <e3>), e3 will be evaluated
|
|
;; in an environment E1 that binds <vars> to <vals>, u to <e1> and v
|
|
;; to <e2>. E1's parent environment will be E0, the environment
|
|
;; in which the procedure was defined.
|
|
;;
|
|
;; For the scanned-out case: (lambda <vars> ((lambda (u v) (set! u
|
|
;; <e1>) (set! v <e2>) <e3>) '*unassigned* '*unassigned*)), <e3> will
|
|
;; be evaluated in the environment E2, which binds u and v to
|
|
;; '*unassigned*. E2 inherits from E1, which binds <vars> to <vals>.
|
|
;; E1 inherits from E0, which is as above.
|
|
;;
|
|
;; A correct program will ensure that the definitions in procedure
|
|
;; body precede any expressions and that other simultaneously defined
|
|
;; variables do not need to be evaluated in order to be defined. In
|
|
;; this case, that means that u and v are defined before evaluating
|
|
;; <e3> and that the definition of u doesn't require the evaluation of
|
|
;; v and vice versa. In the scanned-out case, the assignment modifies
|
|
;; the bindings for u and v in the first environment frame it reaches
|
|
;; and does this before any variables in the body are evaluated. It
|
|
;; doesn't matter how many frames there are in the environment, as
|
|
;; long as the variables have been assigned before they are evaluated.
|
|
;;
|
|
;; One way to eliminate this extra frame (which is introduced by the
|
|
;; syntax transformation of let to a procedure application) might be
|
|
;; to modify procedure application to assign or define the bound
|
|
;; variable in the current frame instead of introducing a new one.
|
|
;; Outside of the procedure body, the binding could be removed (with
|
|
;; make-unbound!) or reinstated (with set!). This would require the
|
|
;; interpreter to store the current value bound to the variable and to
|
|
;; restore it after evaluating the procedure body.
|
|
|
|
;; Exercise 4.18: The scanning out algorithm presented in the exercise
|
|
;; enforces that each internal definition does not depend on the
|
|
;; evaluation of any of the others by setting them to *unassigned*.
|
|
;; For the case of solve, this means that the procedure will not work,
|
|
;; as the definition of dy requires the evaluation of y, which will be
|
|
;; unassigned at the point that dy is defined. This is in contrast to
|
|
;; the previous scanning-out algorithm, where y is defined first.
|
|
;; This succeeds because there is no dependency on the evaluation of
|
|
;; dy (delay ensures this). Then the definition of dy is OK, because
|
|
;; y is already defined (and is assigned by the preceeding set!). The
|
|
;; key difference between the two algorithms is that the first allows
|
|
;; us to get away with defining variables in terms of those that were
|
|
;; defined before it, whereas the second method enforces independence
|
|
;; of the variables.
|
|
|
|
;; Exercise 4.19: Alyssa's view seems to be the most reasonable: Ben's
|
|
;; version seems to be counter to how define should work: it seems to
|
|
;; be more like the behaviour expected from set! To implement Eva's
|
|
;; version, we could reorder the internal definitions such that if a
|
|
;; definition depends on the value of another variable, the dependent
|
|
;; definition would be moved after the one it depended on. This could
|
|
;; be done in a similar way to lsort(1): build a list of pairs of
|
|
;; dependencies and then use something like tsort(1) to get a total
|
|
;; ordering compatible with the dependency constraints.
|
|
|
|
;; Exercise 4.20b: If we use let instead of letrec:
|
|
;; (define (f x)
|
|
;; (let ((even? (lambda (n) (if (= n 0) #t (odd? (- n 1)))))
|
|
;; (odd? (lambda (n) (if (= n 0) #f (even? (- n 1))))))
|
|
;; (even? x)))
|
|
;; then the let is transformed into a procedure application whose body
|
|
;; is evaluated in the environment carried by augmented by a binding
|
|
;; of even? to its lambda expression (and vice versa for odd?). This
|
|
;; lambda expression is evaluated in the same environment as f
|
|
;; (i.e. one in which even? and odd? are not defined). So when either
|
|
;; is evaluated, it should fail at the point where odd? or even? are
|
|
;; called. However, this seems to work in racket. Not sure why.
|
|
|
|
;; Exercise 4.21
|
|
;; 10th fibonacci number without using let or define (using Y
|
|
;; combinator). For each recursive call, we pass in the procedure
|
|
;; definition for it to be passed down to the next call.
|
|
(module+ 4-21
|
|
((lambda (n)
|
|
((lambda (fib) (fib fib n)) ; Pass in the procedure to
|
|
; itself to enable recursion.
|
|
(lambda (ft k)
|
|
(cond ((= k 0) 0)
|
|
((= k 1) 1)
|
|
(else (+ (ft ft (- k 1))
|
|
(ft ft (- k 2))))))))
|
|
10)
|
|
|
|
;; Procedure with internal definitions
|
|
(define (f x)
|
|
(define (even? n)
|
|
(if (= n 0)
|
|
true
|
|
(odd? (- n 1))))
|
|
(define (odd? n)
|
|
(if (= n 0)
|
|
false
|
|
(even? (- n 1))))
|
|
(even? x))
|
|
|
|
;; Same procedure using no internal definitions or letrec
|
|
(define (g x)
|
|
((lambda (even? odd?) (even? even? odd? x))
|
|
(lambda (ev? od? n)
|
|
(if (= n 0) true (od? ev? od? (- n 1)))) ; even
|
|
(lambda (ev? od? n)
|
|
(if (= n 0) false (ev? ev? od? (- n 1)))))) ; odd
|
|
)
|
|
|
|
;; Exercise 4.25: If unless is defined in an applicative order
|
|
;; evaluator, then the version of factorial using unless will never
|
|
;; terminate, as all procedure parameters will be evaluated at every
|
|
;; iteration, including (fact (- n 1)). The normal recursive version
|
|
;; of factorial relies on if only evaluating either the subsequent or
|
|
;; consequent, so in the degenerate case, it evaluates 1 instead of
|
|
;; (fact (- n 1)). If unless is defined in a normal-order evaluator,
|
|
;; then this version of factorial will function the same as the
|
|
;; if-based version, because only one of the consequent and
|
|
;; alternative is evaluated.
|
|
|
|
;; Exercise 4.26: See above for an implementation of unless as a
|
|
;; special form in the interpreter. It may be useful to have unless
|
|
;; as a procedure, if we wish to map it onto input lists, or use it in
|
|
;; a functional style in general. However, I can't see how it's much
|
|
;; better than wrapping a call to a special form in a procedure.
|