From ff4fa9e844ac70bdfac6bf8f95d9b5a1de9d942f Mon Sep 17 00:00:00 2001
From: Felix Martin <mail@felixm.de>
Date: Fri, 23 Apr 2021 21:29:05 -0400
Subject: [PATCH] Implement 5.42

---
 ex-5_39-xx.scm                            | 64 ++++++++++++++++-------
 misc/sicp-compiler-lexical-addressing.scm | 47 ++++++++++-------
 2 files changed, 74 insertions(+), 37 deletions(-)

diff --git a/ex-5_39-xx.scm b/ex-5_39-xx.scm
index a2a472f..47ad64d 100644
--- a/ex-5_39-xx.scm
+++ b/ex-5_39-xx.scm
@@ -73,28 +73,30 @@
 (define (empty-compile-time-env) '())
 
 (define (extend-compile-time-env parameters base-env)
-  (display base-env) (newline)
-  (display parameters) (newline)
   (cons parameters base-env))
 
-(compile-to-file
-  '(let ((x 3) (y 4))
-    (lambda (a b c d e)
-      (let ((y (* a b x))
-            (z (+ c d x)))
-        (* x y z))))
-  'val 'next "f-lex-adr.scm")
+(display "[done]\n")
 
 (display "\nex-5.41 - find-variable\n")
 
-; Exercise 5.41.  Write a procedure find-variable that takes as arguments a
-; variable and a compile-time environment and returns the lexical address of
-; the variable with respect to that environment. For example, in the program
-; fragment that is shown above, the compile-time environment during the
-; compilation of expression <e1> is ((y z) (a b c d e) (x y)). Find-variable
-; should produce
-
-(define (find-variable var env) '9)
+(define (find-variable var env)
+  (define (get-index frame current-index)
+    (cond
+      ((null? frame) (error "var not found -- FIND-VARIABLE"))
+      ((eq? (car frame) var) current-index)
+      (else (get-index (cdr frame) (+ current-index 1)))))
+  (define (find-env i frames)
+    (cond
+      ((null? frames) 'not-found)
+      ((memq var (car frames)) (cons i (car frames)))
+      (else (find-env (+ i 1) (cdr frames)))))
+  (let ((find-env-result (find-env 0 env)))
+    (if (eq? find-env-result 'not-found)
+      'not-found
+      (let* ((frame-number (car find-env-result))
+             (frame (cdr find-env-result))
+             (index-number (get-index frame 0)))
+        (make-address frame-number index-number)))))
 
 (assert (find-variable 'c '((y z) (a b c d e) (x y)))
         (make-address 1 2))
@@ -105,6 +107,30 @@
 (assert (find-variable 'w '((y z) (a b c d e) (x y)))
         'not-found)
 
-(display "\nex-5.42\n")
-; (display "\nex-5.43\n")
+(display "\nex-5.42 - compile-lexical-addressing\n")
+
+(compile-to-file
+  '(let ((x 3) (y 4))
+    (lambda (a b c d e)
+      (let ((y (* a b x))
+            (z (+ c d x)))
+        (set! y 3)
+        (* x y z))))
+  'val 'next "f-lex-adr.scm")
+
+(display "[done]\n")
+
+
+(display "\nex-5.43 - scan-out-defines\n")
+
+; Exercise 5.43.  We argued in section 4.1.6 that internal definitions for
+; block structure should not be considered ``real'' defines. Rather, a
+; procedure body should be interpreted as if the internal variables being
+; defined were installed as ordinary lambda variables initialized to their
+; correct values using set!. Section 4.1.6 and exercise 4.16 showed how to
+; modify the metacircular interpreter to accomplish this by scanning out
+; internal definitions. Modify the compiler to perform the same transformation
+; before it compiles a procedure body.
+
+(display "\nex-5.44\n")
 
diff --git a/misc/sicp-compiler-lexical-addressing.scm b/misc/sicp-compiler-lexical-addressing.scm
index 07467ce..0cf494e 100644
--- a/misc/sicp-compiler-lexical-addressing.scm
+++ b/misc/sicp-compiler-lexical-addressing.scm
@@ -88,26 +88,37 @@
     `((assign ,target (const ,(text-of-quotation exp)))))))
 
 (define (compile-variable exp ct-env target linkage)
-  (end-with-linkage linkage
-   (make-instruction-sequence '(env) (list target)
-    `((assign ,target
-              (op lookup-variable-value)
-              (const ,exp)
-              (reg env))))))
+  (let ((adr (find-variable exp ct-env)))
+    (if (eq? adr 'not-found)
+      (end-with-linkage linkage
+       (make-instruction-sequence '(env) (list target 'env)
+        `((assign env (op get-global-environment) (reg env))
+          (assign ,target
+                  (op lookup-variable-value)
+                  (const ,exp)
+                  (reg env)))))
+      (end-with-linkage linkage
+       (make-instruction-sequence '(env) (list target)
+        `((assign ,target
+                  (op lexical-address-lookup)
+                  (const ,adr)
+                  (reg env))))))))
 
 (define (compile-assignment exp ct-env target linkage)
-  (let ((var (assignment-variable exp))
-        (get-value-code
-         (compile (assignment-value exp) 'val 'next)))
-    (end-with-linkage linkage
-     (preserving '(env)
-      get-value-code
-      (make-instruction-sequence '(env val) (list target)
-       `((perform (op set-variable-value!)
-                  (const ,var)
-                  (reg val)
-                  (reg env))
-         (assign ,target (const ok))))))))
+  (let* ((var (assignment-variable exp))
+         (get-value-code (compile (assignment-value exp) ct-env 'val 'next))
+         (adr (find-variable var ct-env)))
+    (if (eq? adr 'not-found)
+      (error "var not found -- compile-assignment" var)
+      (end-with-linkage linkage
+       (preserving '(env)
+        get-value-code
+        (make-instruction-sequence '(env val) (list target)
+         `((perform (op lexical-address-set!)
+                    (const ,adr) ;; (const ,var) before
+                    (reg val)
+                    (reg env))
+           (assign ,target (const ok)))))))))
 
 (define (compile-definition exp ct-env target linkage)
   (let ((var (definition-variable exp))