From: Ramakrishnan Muthukrishnan <vu3rdd@gmail.com>
Date: Sat, 31 Dec 2011 14:21:35 +0000 (+0530)
Subject: support for internal definitions
X-Git-Url: https://git.rkrishnan.org/listings/$rel_link?a=commitdiff_plain;h=0a5ee86a54bbe2f6bbf733a870112813168938d9;p=sicp.git

support for internal definitions
---

diff --git a/src/sicp/metacircular2.rkt b/src/sicp/metacircular2.rkt
index 7bc5f02..f08b5a1 100644
--- a/src/sicp/metacircular2.rkt
+++ b/src/sicp/metacircular2.rkt
@@ -27,7 +27,7 @@
 
 ;; lambda
 (define (make-lambda parameters body)
-  (cons 'lambda (cons parameters (list body))))
+  (cons 'lambda (cons parameters body)))
 
 ;; environment data structures
 (define (enclosing-environment env) (cdr env))
@@ -89,7 +89,8 @@
         (list '+ +)
         (list '- -)
         (list '* *)
-        (list '/ /)))
+        (list '/ /)
+        (list '= =)))
 
 (define (primitive-procedure-names)
   (map car primitive-procedures))
@@ -127,10 +128,10 @@
 
 ;; compound procedure
 (define (make-procedure params body env)
-  (list 'procedure params body env))
+  (list 'procedure params (scan-out-definitions body) env))
 
 (define (procedure-parameters p) (cadr p))
-(define (procedure-body p) (caddr p))
+(define (procedure-body p) (scan-out-definitions (caddr p)))
 (define (procedure-environment p) (cadddr p))
 
 (define (apply procedure arguments)
@@ -168,9 +169,9 @@
 
 ;; let
 (define (let->combination lexpr)
-  (match-let* ([`(let ,bindings ,body) lexpr]
+  (match-let* ([`(let ,bindings ,body ..1) lexpr]
                [`((,var ,val) ...) bindings])
-    `((lambda ,var ,body) ,@val)))
+    `((lambda ,var ,@body) ,@val)))
 
 ;; let*
 (define (let*->nested-lets lexpr)
@@ -179,20 +180,30 @@
      `(let (,first-binding) ,(let*->nested-lets `(let* ,rest-bindings ,body)))]
      [`(let* () ,body) body]))
 
+;; internal definitions
+(define (scan-out-definitions body)
+  (match body
+    [`((define ,var ,e) ..1 ,rest)
+     `((let ,(map (lambda (v) (list (car v) ''*unassigned*)) var)
+        ,@(map (lambda (v e) `(set! ,(car v) (lambda ,(cdr v) ,e))) var e)
+        ,rest))]
+    [_  body]))
+
 ;; eval
 (define (eval exp env)
+  ;; (display (format "~s~%" exp))
   (match exp
     [(? self-evaluating? exp) exp]
     [(? variable? exp) (lookup-variable-value exp env)]
     [`(quote ,x) x]
     [`(set! ,var ,val) (set-variable-value! var (eval val env) env)]
     [`(define ,(? (lambda (x) (not (pair? x))) var) ,b) (define-variable! var (eval b env) env)]
-    [`(define ,(? pair? var) ,b) (define-variable! (car var) (eval (make-lambda (cdr var) b) env) env)]
+    [`(define ,(? pair? var) ,b ..1) (define-variable! (car var) (eval (make-lambda (cdr var) b) env) env)]
     [`(if ,pred ,consequent ,alternative) (if (true? (eval pred env)) (eval consequent env) (eval alternative env))]
-    [`(lambda ,parameters ,body ...) (make-procedure parameters body env)]
+    [`(lambda ,parameters ,body ..1) (make-procedure parameters body env)]
     [`(begin ,exp ...) (eval-sequence exp env)]
     [`(cond ,clauses ...) (eval (cond->if clauses) env)]
-    [`(let ,bindings ,body) (eval (let->combination exp) env)]
+    [`(let ,bindings ,body ..1) (eval (let->combination exp) env)]
     [`(let* ,bindings ,body) (eval (let*->nested-lets exp) env)]
     [(list f x ...) (apply (eval f env) (list-of-values x env))]
     [_ (error "unable to evaluate expression -- EVAL " exp)]))