From: Ramakrishnan Muthukrishnan <vu3rdd@gmail.com>
Date: Fri, 9 Dec 2011 21:21:22 +0000 (+0530)
Subject: changes in the metacircular eval for primitive procedures
X-Git-Url: https://git.rkrishnan.org/specifications/%5B/%5D%20/%22doc.html/%22file:/nxhtml.html?a=commitdiff_plain;h=91494e6f42e823aa5b7114bdd91e394dd46d5051;p=sicp.git

changes in the metacircular eval for primitive procedures
---

diff --git a/src/sicp/metacircular.rkt b/src/sicp/metacircular.rkt
index bae6128..ac37698 100644
--- 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)
@@ -202,7 +205,7 @@
 
 (define (procedure-parameters p) (cadr p))
 (define (procedure-body p) (caddr p))
-(define (procedure-env p) (cadddr p))
+(define (procedure-environment p) (cadddr p))
 
 ;; operations on environment
 (define (enclosing-environment env) (cdr env))
@@ -267,3 +270,44 @@
     (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))
+
+