Better explanation of the unless procesure if it is not defined

[sicp.git] / src / sicp / metacircular.rkt

diff --git a/src/sicp/metacircular.rkt b/src/sicp/metacircular.rkt
index 24ef7e051db77922aec082f064776aded1a42adf..ac376986b87949998cdddf4c677a70ef5dda89a4 100644 (file)
--- a/src/sicp/metacircular.rkt
+++ b/src/sicp/metacircular.rkt
@@ -1,6 +1,6 @@
-#lang racket
+#lang planet neil/sicp
 
-(require "ex4_8.rkt" ;; for let and named let
+(#%require "ex4_8.rkt" ;; for let and named let
          "ex4_7.rkt")
 
 ;; metacircular evaluator
@@ -25,6 +25,9 @@
         (else
          (error "unknown expression type -- EVAL" exp))))
 
+;; capture the underlying apply before redefining it
+(define apply-in-underlying-scheme apply)
+
 (define (apply procedure arguments)
   (cond ((primitive-procedure? procedure)
          (apply-primitive-procedure procedure arguments))
@@ -146,7 +149,7 @@
 (define (begin-actions exp) (cdr exp))
 (define (last-exp? seq) (null? (cdr seq)))
 (define (first-exp seq) (car seq))
-(define (rest-exp seq) (cdr seq))
+(define (rest-exps seq) (cdr seq))
 
 (define (sequence->exp seq)
   (cond ((null? seq) seq)
@@ -184,4 +187,127 @@
                        clauses))
             (make-if (cond-predicate first)
                      (sequence->exp (cond-actions first))
-                     (expand-clauses rest))))))
\ No newline at end of file
+                     (expand-clauses rest))))))
+
+;; true and false
+(define (true? x)
+  (not (eq? x false)))
+
+(define (false? x)
+  (eq? x false))
+
+;; procedures
+(define (make-procedure parameters body env)
+  (list 'procedure parameters body env))
+
+(define (compound-procedure? p)
+  (tagged-list? p 'procedure))
+
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; operations on environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+
+;; frame operations
+(define (make-frame variables values)
+  (cons variables values))
+
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-bindings-to-frame! var val frame)
+  (set-car! frame (cons var (frame-variables frame)))
+  (set-cdr! frame (cons val (frame-values frame))))
+
+(define (extend-environment vars vals base-env)
+  (if (= (length vars) (length vals))
+      (cons (make-frame vars vals) base-env)
+      (if (< (length vars) (length vals))
+          (error "Too many args supplied" vars vals)
+          (error "Too many args supplied" vars vals))))
+
+(define (lookup-variable-value var env)
+  (define (env-loop env)
+    (define (scan vars vals)
+      (cond [(null? vars)
+             (env-loop (enclosing-environment env))]
+            [(eq? var (car vars))
+             (car vals)]
+            [else (scan (cdr vars) (cdr vals))]))
+    (if (eq? env the-empty-environment)
+        (error "unbound variable" var)
+        (let ([frame (first-frame env)])
+          (scan (frame-variables frame)
+                (frame-values frame)))))
+  (env-loop env))
+
+(define (set-variable-value! var val env)
+  (define (env-loop env)
+    (define (scan vars vals)
+      (cond [(null? vars)
+             (env-loop (enclosing-environment env))]
+            [(eq? var (car vars))
+             (set-car! vals val)]
+            [else (scan (cdr vars) (cdr vals))]))
+    (if (eq? env the-empty-environment)
+        (error "unbound variable" var)
+        (let ([frame (first-frame env)])
+          (scan (frame-variables frame)
+                (frame-values frame)))))
+  (env-loop env))
+
+(define (define-variable! var val env)
+  (let ([frame (first-frame env)])
+    (define (scan vars vals)
+      (cond [(null? vars)
+             (add-bindings-to-frame! var val frame)]
+            [(eq? var (car vars))
+             (set-car! vals val)]
+            [else (scan (cdr vars) (cdr vals))]))
+    (scan (frame-variables frame)
+          (frame-values frame))))
+
+
+;; primitive procedures
+(define (primitive-procedure? proc)
+  (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+
+(define primitive-procedures
+  (list (list 'car car)
+        (list 'cdr cdr)
+        (list 'cons cons)
+        (list 'null? null?)
+        (list '+ +)
+        (list '- -)
+        (list '= =)))
+
+(define (primitive-procedure-names)
+  (map car primitive-procedures))
+
+(define (primitive-procedure-objects)
+  (map (lambda (proc) (list 'primitive (cadr proc)))
+       primitive-procedures))
+
+;; apply from implementation language
+(define (apply-primitive-procedure proc args)
+  (apply-in-underlying-scheme
+   (primitive-implementation proc) args))
+
+;; setting up the environment
+(define (setup-environment)
+  (let ((initial-env
+         (extend-environment (primitive-procedure-names)
+                             (primitive-procedure-objects)
+                             the-empty-environment)))
+    (define-variable! 'true #t initial-env)
+    (define-variable! 'false #f initial-env)
+    initial-env))
+
+(define the-global-environment (setup-environment))
+
+