Add racket version of analyzing mceval

analyzing-mceval.rkt

@@ -0,0 +1,133 @@
+#lang sicp
+
+;;;;METACIRCULAR EVALUATOR THAT SEPARATES ANALYSIS FROM EXECUTION
+;;;; FROM SECTION 4.1.7 OF STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
+
+;;;;Matches code in ch4.scm
+
+;;;;This file can be loaded into Scheme as a whole.
+;;;;**NOTE**This file loads the metacircular evaluator of
+;;;;  sections 4.1.1-4.1.4, since it uses the expression representation,
+;;;;  environment representation, etc.
+;;;;  You may need to change the (load ...) expression to work in your
+;;;;  version of Scheme.
+;;;;**WARNING: Don't load mceval twice (or you'll lose the primitives
+;;;;  interface, due to renamings of apply).
+
+;;;;Then you can initialize and start the evaluator by evaluating
+;;;; the two lines at the end of the file ch4-mceval.scm
+;;;; (setting up the global environment and starting the driver loop).
+
+
+;;**implementation-dependent loading of evaluator file
+;;Note: It is loaded first so that the section 4.1.7 definition
+;; of eval overrides the definition from 4.1.1
+
+;; OP: Modified to run in racket.
+
+(#%require "ch4-mceval.rkt")
+(#%require racket/trace)
+
+;;;SECTION 4.1.7
+
+(trace-define (eval exp env)
+  ((analyze exp) env))
+
+(trace-define (analyze exp)
+  (cond ((self-evaluating? exp) 
+         (analyze-self-evaluating exp))
+        ((quoted? exp) (analyze-quoted exp))
+        ((variable? exp) (analyze-variable exp))
+        ((assignment? exp) (analyze-assignment exp))
+        ((definition? exp) (analyze-definition exp))
+        ((if? exp) (analyze-if exp))
+        ((lambda? exp) (analyze-lambda exp))
+        ((begin? exp) (analyze-sequence (begin-actions exp)))
+        ((cond? exp) (analyze (cond->if exp)))
+        ((application? exp) (analyze-application exp))
+        (else
+         (error "Unknown expression type -- ANALYZE" exp))))
+
+(trace-define (analyze-self-evaluating exp)
+  (lambda (env) exp))
+
+(trace-define (analyze-quoted exp)
+  (let ((qval (text-of-quotation exp)))
+    (lambda (env) qval)))
+
+(trace-define (analyze-variable exp)
+  (lambda (env) (lookup-variable-value exp env)))
+
+(trace-define (analyze-assignment exp)
+  (let ((var (assignment-variable exp))
+        (vproc (analyze (assignment-value exp))))
+    (lambda (env)
+      (set-variable-value! var (vproc env) env)
+      'ok)))
+
+(trace-define (analyze-definition exp)
+  (let ((var (definition-variable exp))
+        (vproc (analyze (definition-value exp))))
+    (lambda (env)
+      (define-variable! var (vproc env) env)
+      'ok)))
+
+(trace-define (analyze-if exp)
+  (let ((pproc (analyze (if-predicate exp)))
+        (cproc (analyze (if-consequent exp)))
+        (aproc (analyze (if-alternative exp))))
+    (lambda (env)
+      (if (true? (pproc env))
+          (cproc env)
+          (aproc env)))))
+
+(trace-define (analyze-lambda exp)
+  (let ((vars (lambda-parameters exp))
+        (bproc (analyze-sequence (lambda-body exp))))
+    (lambda (env) (make-procedure vars bproc env))))
+
+(trace-define (analyze-sequence exps)
+  (define (sequentially proc1 proc2)
+    (lambda (env) (proc1 env) (proc2 env)))
+  (define (loop first-proc rest-procs)
+    (if (null? rest-procs)
+        first-proc
+        (loop (sequentially first-proc (car rest-procs))
+              (cdr rest-procs))))
+  (let ((procs (map analyze exps)))
+    (if (null? procs)
+        (error "Empty sequence -- ANALYZE"))
+    (loop (car procs) (cdr procs))))
+
+(trace-define (analyze-application exp)
+  (let ((fproc (analyze (operator exp)))
+        (aprocs (map analyze (operands exp))))
+    (lambda (env)
+      (execute-application (fproc env)
+                           (map (lambda (aproc) (aproc env))
+                                aprocs)))))
+
+(trace-define (execute-application proc args)
+  (cond ((primitive-procedure? proc)
+         (apply-primitive-procedure proc args))
+        ((compound-procedure? proc)
+         ((procedure-body proc)
+          (extend-environment (procedure-parameters proc)
+                              args
+                              (procedure-environment proc))))
+        (else
+         (error
+          "Unknown procedure type -- EXECUTE-APPLICATION"
+          proc))))
+
+;; Redefine here so that this version of eval is in driver-loop's
+;; environment rather than the one in ch4-mceval.
+(define (driver-loop)
+  (prompt-for-input input-prompt)
+  (let ((input (read)))
+    (let ((output (eval input the-global-environment)))
+      (announce-output output-prompt)
+      (user-print output)))
+  (driver-loop))
+
+'ANALYZING-METACIRCULAR-EVALUATOR-LOADED

ch4-mceval.rkt

@@ -22,7 +22,54 @@
 
 ;;;SECTION 4.1.1
 
-(#%provide (all-defined))
+;;(#%provide (all-defined))
+
+(#%provide self-evaluating?
+           quoted?
+           variable?
+           assignment?
+           definition?
+           if?
+           lambda?
+           begin?
+           cond?
+           application?
+           begin-actions
+           cond->if
+           text-of-quotation
+           lookup-variable-value
+           assignment-variable
+           assignment-value
+           set-variable-value!
+           definition-variable
+           definition-value
+           define-variable!
+           if-predicate
+           if-consequent
+           if-alternative
+           true?
+           lambda-parameters
+           lambda-body
+           make-procedure
+           operator
+           operands
+           primitive-procedure?
+           apply-primitive-procedure
+           procedure-body
+           procedure-parameters
+           compound-procedure?
+           extend-environment
+           procedure-environment
+           the-global-environment
+           prompt-for-input
+           input-prompt
+           announce-output
+           output-prompt
+           user-print)
+
+;;(#%require )
+;;(#%require (only racket/base except-out))
+;;(#%provide (all-from-except eval))
 
 (define (eval exp env)
   (cond ((self-evaluating? exp) exp)
@@ -302,6 +349,11 @@
         (list 'cdr cdr)
         (list 'cons cons)
         (list 'null? null?)
+        (list '= =)
+        (list '+ +)
+        (list '- -)
+        (list '* *)
+        (list '/ /)
 ;;      more primitives
         ))