add named let and simultaneous define semantics

3 files changed, 54 insertions, 6 deletions

diff --git a/environment.scm b/environment.scm
index 4917a40..37f9fa4 100644
--- a/environment.scm
+++ b/environment.scm
@@ -29,6 +29,7 @@
       (error "Too few or too many arguments supplied" vars vals)))
 
 ;;; variable lookup
+(define (is-unassigned? u) (eq? u '*unassigned*))
 (define (lookup-variable-value var env)
   (cond
     [(empty-env? env) (error "Unbound variable" var)]
@@ -76,5 +77,6 @@
                        the-empty-env)])
     (define-variable! 'true #t initial-env)
     (define-variable! 'false #f initial-env)
+    (define-variable! '*unassigned* #f initial-env)
     initial-env))
 
diff --git a/main.scm b/main.scm
index dd60662..1781255 100644
--- a/main.scm
+++ b/main.scm
@@ -76,7 +76,9 @@
 (define (lambda-form? expr) (tagged? expr 'lambda))
 (define (lambda-params expr) (cadr expr))
 (define (lambda-body expr) (cddr expr))
-(define (make-lambda params body) (cons 'lambda (cons params body)))
+(define (make-lambda params body) 
+  (cons 'lambda
+        (cons params (scan-out-defines body))))
 
 ;;; begin
 (define (begin-form? expr) (tagged? expr 'begin))
@@ -92,6 +94,11 @@
 ;;; let
 (define (let-form? expr) (tagged? expr 'let))
 (define (let*-form? expr) (tagged? expr 'let*))
+(define (named-let-variable expr) (cadr expr))
+(define (named-let-form? expr) (and (tagged? expr 'let)
+                                    (variable? (named-let-variable expr))))
+(define (named-let-bindings expr) (caddr expr))
+(define (named-let-body expr) (cdddr expr))
 (define (let-bindings expr) (cadr expr))
 (define (last-binding? bindings) (null? (cdr bindings)))
 (define (let-body expr) (cddr expr))
@@ -110,22 +117,50 @@
       [(last-binding? bindings) (make-let bindings body)]
       [else (make-let (list (car bindings))
                       (let*->let (make-let* (cdr bindings) body)))])))
+(define (named-let->let expr)
+  (let ([name (named-let-variable expr)]
+        [body (sequence->expr (named-let-body expr))]
+        [bindings (named-let-bindings expr)])
+    (let ([new-binding (make-lambda (let-binding-variables bindings)
+                                     body)])
+      (make-let (cons (list name new-binding)
+                      bindings)
+                body))))
+
+;;; handle internal definitions
+(define (define->set statements)
+  (map (lambda (d)
+         (cons 'set! (cdr d)))
+       statements))
+(define (make-unassigned-bindings internal-defines)
+  (map (lambda (d)
+         (list (definition-name d) '*unassigned*)) internal-defines))
+(define (scan-out-defines body)
+  (let ([internal-defines (filter definition? body)]
+        [rest (filter (lambda (n) (not (definition? n))) body)])
+    (cond 
+      [(null? internal-defines) body]
+      [else 
+        (let ([variables (make-unassigned-bindings internal-defines)])
+          (let ([new-bindings (define->set internal-defines)])
+            (list (cons 'let (cons variables (append new-bindings rest))))))])))
 
 
 (define (eval-expr expr env)
   (cond
     [(self-evaluating? expr) expr]
     [(variable? expr) (lookup-variable-value expr env)]
+    [(assignment? expr) (eval-assignment expr env)]
+    [(definition? expr) (eval-definition expr env)]
+    [(quote-form? expr) (quotation-text expr)]
     [(if-else? expr) (eval-if expr env)]
     [(begin-form? expr) (eval-sequence (begin-actions expr) env)]
     [(lambda-form? expr) (make-lambda (lambda-params expr)
                                       (lambda-body expr))]
+    [(named-let-form? expr) 'false]
     [(let-form? expr) (eval-let expr env)]
     [(let*-form? expr) (eval-let* expr env)]
-    [(assignment? expr) (eval-assignment expr env)]
-    [(definition? expr) (eval-definition expr env)]
     [(cond-form? expr) (eval-cond expr env)]
-    [(quote-form? expr) (quotation-text expr)]
     [(function-application? expr) (eval-function-application expr env)]))
 
 (define (eval-if expr env)
@@ -143,6 +178,9 @@
             (eval-expr (car exprs) env)
             (eval-sequence (cdr exprs) env))]))
 
+(define (eval-named-let expr env)
+  (eval-let (named-let->let expr) env))
+
 (define (eval-let expr env)
   (eval-function-application 
     (cons (let->lambda expr)
@@ -153,7 +191,7 @@
   (eval-expr (let*->let expr) env))
 
 (define (eval-assignment expr env)
-  (set-variable-value! 
+  (set-variable-value!
     (assignment-name expr)
     (eval-expr (assignment-value expr) env)
     env))
diff --git a/prelude/primitives.scm b/prelude/primitives.scm
index cd7f1bf..ad1584d 100644
--- a/prelude/primitives.scm
+++ b/prelude/primitives.scm
@@ -45,12 +45,20 @@
     (> . ,(lift-bool >))
     (<= . ,(lift-bool <=))
     (>= . ,(lift-bool >=))
+    (= . ,(lift-bool =))
     (eq? . ,(lift-bool eq?))
     (&& . ,and-special)
     (|| . ,or-special)
     (/= . ,not-fn)
     (first . ,car)
-    (rest . ,cdr)))
+    (second . ,cadr)
+    (third . ,caddr)
+    (fourth . ,cadddr)
+    (rest . ,cdr)
+    (cons . ,cons)
+    (list . ,list)
+    (map . ,map)
+    (null? . ,(lift-bool null?))))
 
 (define (primitive-names) (map car primitives))
 (define (primitive-objs) (map cdr primitives))