Implement 4.12 and fix some prior issues

ex-4_01-xx.scm

@@ -273,13 +273,17 @@
 (assert (lookup-variable-value 'b env-2) 2)
 (set-variable-value! 'b 42 env-2)
 (assert (lookup-variable-value 'b env-2) 42)
+(define-variable! 'e 5 env-2)
+(assert (lookup-variable-value 'e env-2) 5)
 
 (define (make-frame variables values)
   (map cons variables values))
 (define (frame-variables frame) (map car frame))
 (define (frame-values frame) (map cdr frame))
 (define (add-binding-to-frame! var val frame)
-  (set-car! frame (cons (cons var val) frame)))
+  (if (null? (cdr frame))
+    (set-cdr! frame (cons (cons var val) '()))
+    (add-binding-to-frame! var val (cdr frame))))
 
 (define frame-var car)
 (define frame-val cdr)
@@ -315,14 +319,13 @@
 
 (define (define-variable! var val env)
   (let ((frame (first-frame env)))
-    (define (scan vars vals)
+    (define (scan frame)
-      (cond ((null? vars)
+      (cond ((null? frame)
-             (add-binding-to-frame! var val frame))
+             (add-binding-to-frame! var val (first-frame env)))
-            ((eq? var (car vars))
+            ((eq? var (frame-var (car frame)))
-             (set-car! vals val))
+             (set-cdr! (car frame) val))
-            (else (scan (cdr vars) (cdr vals)))))
+            (else (scan (cdr frame)))))
-    (scan (frame-variables frame)
+    (scan frame)))
-          (frame-values frame))))
 
 (define env-0 the-empty-environment)
 (define env-1 (extend-environment '(a b) '(1 2) env-0))
@@ -331,32 +334,70 @@
 (assert (lookup-variable-value 'b env-2) 2)
 (set-variable-value! 'b 42 env-2)
 (assert (lookup-variable-value 'b env-2) 42)
+(define-variable! 'e 5 env-2)
+(assert (lookup-variable-value 'e env-2) 5)
 
 (display "\nex-4.12 - abstract-traversal\n")
 
-(define (find-pair-frame frame var)
+(define (find-pair-frame var frame)
-  ; (display "FIND-PAIR-FRAME ") (display frame) (newline)
+  (assoc var frame))
-  (define (frame-loop frame)
-    (cond
-      ((null? frame) 'pair-not-found)
-      ((eq? var (frame-var (car frame))) (car frame))
-      (else (frame-loop (cdr frame)))))
-  (frame-loop frame))
 
-(define (find-pair-env env var)
+(define (find-pair-env var env)
   (define (env-loop env)
     (if (eq? env the-empty-environment)
-      'pair-not-found
+      #f
-      (let ((pair (find-pair-frame (first-frame env) var)))
+      (let ((pair (assoc var (first-frame env))))
-        (if (eq? pair 'pair-not-found)
+        (if (pair? pair)
-          (env-loop (enclosing-environment env))
+          pair
-          pair))))
+          (env-loop (enclosing-environment env))))))
   (env-loop env))
 
-(display (find-pair-env env-2 'd))
+(define (lookup-variable-value var env)
-(newline)
+  (let ((pair (find-pair-env var env)))
+    (if (eq? pair #f)
+      (error "Unbound variable" var)
+      (frame-val pair))))
 
-(display "\nex-4.13\n")
+(define (set-variable-value! var val env)
+  (let ((pair (find-pair-env var env)))
+    (if (pair? pair)
+      (set-cdr! pair val)
+      '())))
 
-; (display "\nex-4.14\n")
+(define (define-variable! var val env)
+  (let ((frame (first-frame env)))
+    (let ((pair (assoc var frame)))
+      (if (pair? pair)
+        (set-cdr! pair val)
+        (add-binding-to-frame! var val frame)))))
+
+(define env-0 the-empty-environment)
+(define env-1 (extend-environment '(a b) '(1 2) env-0))
+(define env-2 (extend-environment '(c d) '(3 4) env-1))
+
+(assert (find-pair-env 'd env-2) (cons 'd 4))
+(assert (lookup-variable-value 'b env-2) 2)
+(set-variable-value! 'b 42 env-2)
+(assert (lookup-variable-value 'b env-2) 42)
+(define-variable! 'e 5 env-2)
+(assert (lookup-variable-value 'e env-2) 5)
+
+(display "\nex-4.13 - make-unbound!\n")
+
+; XXX: work in progress
+
+(define (make-unbound-frame! var frame)
+  (if (null? frame)
+    #f
+    (if (eq? var (frame-var (car frame)))
+      (begin
+        (set-car! frame (cadr frame))
+        (set-cdr! frame (cddr frame)))
+      (make-unbound-frame! var (cdr frame)))))
+
+(display (first-frame env-2)) (newline)
+(make-unbound-frame! 'e (first-frame env-2))
+(display (first-frame env-2)) (newline)
+
+(display "\nex-4.14\n")