X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=examples%2Fmetacirc.scm;h=fe4c965d723b015703c0cd475efc2c481b4e705f;hb=f1bd626bdb02170b189891d8f8f3f3cc6b592209;hp=94787dd0b13dc0147d2a77ae38bcbeb9f2bd16ac;hpb=0dadd5f58d2c204c7f621ccd3c42f75a3fd790a8;p=scheme.forth.jl.git

diff --git a/examples/metacirc.scm b/examples/metacirc.scm
index 94787dd..fe4c965 100644
--- a/examples/metacirc.scm
+++ b/examples/metacirc.scm
@@ -2,14 +2,14 @@
 ;; Mandatory SICP Metacircular Evaluator ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+;; To use, simply (load "metacirc.scm") and run the (driver-loop) command.
+
 (define apply-in-underlying-scheme apply)
 (define true #t)
 (define false #f)
 
 ;; Verbatim code from SICP
 
-(display "eval and apply\n")
-
 (define (eval exp env)
   (cond ((self-evaluating? exp) 
          exp)
@@ -88,6 +88,13 @@
     env)
   'ok)
 
+(define (eval-definition exp env)
+  (define-variable! 
+    (definition-variable exp)
+    (eval (definition-value exp) env)
+    env)
+  'ok)
+
 (define (self-evaluating? exp)
   (cond ((number? exp) true)
         ((string? exp) true)
@@ -130,8 +137,6 @@
       (cddr exp)))) ; body
 
 
-(display "lambda... \n")
-
 (define (lambda? exp) 
   (tagged-list? exp 'lambda))
 (define (lambda-parameters exp) (cadr exp))
@@ -178,8 +183,6 @@
 (define (rest-operands ops) (cdr ops))
 
 
-(display "cond... \n")
-
 (define (cond? exp) 
   (tagged-list? exp 'cond))
 (define (cond-clauses exp) (cdr exp))
@@ -216,9 +219,6 @@
   (eq? x false))
 
 
-(display "make-procedure...\n")
-
-
 (define (make-procedure parameters body env)
   (list 'procedure parameters body env))
 (define (compound-procedure? p)
@@ -232,19 +232,14 @@
 (define the-empty-environment '())
 
 
-(display "make-frame\n")
-
 (define (make-frame variables values)
   (cons variables values))
 (define (frame-variables frame) (car frame))
 (define (frame-values frame) (cdr frame))
 (define (add-binding-to-frame! var val frame)
-  (display "Adding binding to frame... ")
   (set-car! frame (cons var (car frame)))
   (set-cdr! frame (cons val (cdr frame))))
 
-(display "extend-environment\n")
-
 (define (extend-environment vars vals base-env)
   (if (= (length vars) (length vals))
     (cons (make-frame vars vals) base-env)
@@ -256,8 +251,6 @@
              vars 
              vals))))
 
-(display "lookup-variable\n")
-
 (define (lookup-variable-value var env)
   (define (env-loop env)
     (define (scan vars vals)
@@ -275,8 +268,6 @@
               (frame-values frame)))))
   (env-loop env))
 
-(display "set-variable\n")
-
 (define (set-variable-value! var val env)
   (define (env-loop env)
     (define (scan vars vals)
@@ -294,41 +285,31 @@
               (frame-values frame)))))
   (env-loop env))
 
-(display "define-variable\n")
-
 (define (define-variable! var val env)
-  (display "Defining a variable...\n")
   (let ((frame (first-frame env)))
     (define (scan vars vals)
-      (display "Scanning for ") (display var) (display " in ") (display vars) (display "...\n")
       (cond ((null? vars)
-             (begin (display "adding binding\n")
              (add-binding-to-frame! 
-               var val frame)))
+               var val frame))
             ((eq? var (car vars))
-             (begin (display "replacing binding\n")
-             (set-car! vals val)))
+             (set-car! vals val))
             (else
-              (begin
-                (display "iterating\n")
                 (scan (cdr vars) 
-                        (cdr vals))))))
+                        (cdr vals)))))
     (scan (frame-variables frame)
           (frame-values frame))))
 
-(display "setup-environment...\n")
-
 (define (setup-environment)
   (let ((initial-env
           (extend-environment 
             (primitive-procedure-names)
             (primitive-procedure-objects)
             the-empty-environment)))
-    (display "Setting up the environment..\n")
     (define-variable! 'true true initial-env)
     (define-variable! 'false false initial-env)
     initial-env))
 
+
 (define (primitive-procedure? proc)
   (tagged-list? proc 'primitive))
 
@@ -352,8 +333,6 @@
          (list 'primitive (cadr proc)))
        primitive-procedures))
 
-
-
 (define (apply-primitive-procedure proc args)
     (apply-in-underlying-scheme
          (primitive-implementation proc) args))
@@ -362,8 +341,6 @@
 (define output-prompt ";;; M-Eval value:")
 
 
-(display "driver-loop...\n") 
-
 (define (driver-loop)
   (prompt-for-input input-prompt)
   (let ((input (read)))
@@ -390,5 +367,5 @@
             '<procedure-env>))
     (display object)))
 
-(define the-global-environment 
-  (setup-environment))
+
+(define the-global-environment (setup-environment))