From 54bc6725f34f391babadb6680a31694b6e786d76 Mon Sep 17 00:00:00 2001
From: Felix Martin <mail@felixm.de>
Date: Thu, 22 Apr 2021 09:05:18 -0400
Subject: [PATCH] Implement till 5.39

---
 ex-5_31-38.scm                            |  24 +++-
 ex-5_39-xx.scm                            | 151 ++++++++++++----------
 misc/sicp-compiler-lexical-addressing.scm |  61 +++++----
 util.scm                                  |  23 ----
 4 files changed, 141 insertions(+), 118 deletions(-)

diff --git a/ex-5_31-38.scm b/ex-5_31-38.scm
index 7625426..1f09c32 100644
--- a/ex-5_31-38.scm
+++ b/ex-5_31-38.scm
@@ -1,6 +1,28 @@
-(load "util.scm")
 (load "misc/sicp-compiler.scm")
 
+(define (compile-to-file code target linkage file-name)
+  (set! label-counter 0)
+  (define (write-list-to-port xs port)
+    (if (null? xs)
+      '()
+      (begin
+        (display (car xs) port)
+        (display "\n" port)
+        (write-list-to-port (cdr xs) port))))
+  (if #f ; #t means write to file; #f means don't write to file
+    (let* ((compile-result (compile code target linkage))
+           (assembly-insts (statements compile-result))
+           (port (open-output-file file-name)))
+      (write-list-to-port assembly-insts port)
+      (display "[")
+      (display file-name)
+      (display "]\n")
+      (close-output-port port))
+      (begin
+        (display "[")
+        (display file-name)
+        (display "]\n"))))
+
 (display "\nex-5.31 - save-and-restore-for-apply\n")
 
 ; 1. save and restore env around operator
diff --git a/ex-5_39-xx.scm b/ex-5_39-xx.scm
index 933987c..a2a472f 100644
--- a/ex-5_39-xx.scm
+++ b/ex-5_39-xx.scm
@@ -1,91 +1,110 @@
 (load "util.scm")
 (load "misc/sicp-compiler-lexical-addressing.scm")
 
+(define (compile-to-file code target linkage file-name)
+  (set! label-counter 0)
+  (define (write-list-to-port xs port)
+    (if (null? xs)
+      '()
+      (begin
+        (display (car xs) port)
+        (display "\n" port)
+        (write-list-to-port (cdr xs) port))))
+  (if #t ; #t means write to file; #f means don't write to file
+    (let* ((compile-result (compile code (empty-compile-time-env) target linkage))
+           (assembly-insts (statements compile-result))
+           (port (open-output-file file-name)))
+      (write-list-to-port assembly-insts port)
+      (display "[")
+      (display file-name)
+      (display "]\n")
+      (close-output-port port))
+      (begin
+        (display "[")
+        (display file-name)
+        (display "]\n"))))
+
 (display "\nex-5.39 - lexical-addressing\n")
 
-; Exercise 5.39.  Write a procedure lexical-address-lookup that implements the
-; new lookup operation. It should take two arguments -- a lexical address and a
-; run-time environment -- and return the value of the variable stored at the
-; specified lexical address. Lexical-address-lookup should signal an error if
-; the value of the variable is the symbol *unassigned*.46 Also write a
-; procedure lexical-address-set! that implements the operation that changes the
-; value of the variable at a specified lexical address.
-
 (define (make-address frame-number index-number)
-  (list 'address frame-number index-number))
-(define (frame-number address) (cadr address))
-(define (index-number address) (caddr address))
+  (list frame-number index-number))
+(define (frame-number address) (car address))
+(define (index-number address) (cadr address))
 
 (define test-env '((1 2 3) (4 5 6) (7 8 9)))
 
+(define (lexical-address-frame frame-number env)
+  (cond
+    ((null? env)
+     (error "frame does not exist - LEXICAL-ADDRESS-FRAME" adr env))
+    ((= frame-number 0) (car env))
+    (else (lexical-address-frame (- frame-number 1) (cdr env)))))
+
 (define (lexical-address-lookup adr env)
-  (define (iter-env frame-number env)
-    (cond
-      ((null? env)
-       (error "frame does not exist - LEXICAL-ADDRESS-LOOKUP" adr env))
-      ((= frame-number 0) (car env))
-      (else (iter-env (- frame-number 1) (cdr env)))))
   (define (iter-frame index-number frame)
     (cond
-      ((null? frame)
-       (error "index does not exist - LEXICAL-ADDRESS-LOOKUP" adr env))
+      ((null? frame) (error "index does not exist - LEXICAL-ADDRESS-LOOKUP" adr env))
       ((and (= index-number 0) (eq? (car frame) '*unassigned*))
        (error "var not assigned - LEXICAL-ADDRESS-LOOKUP" adr env))
       ((= index-number 0) (car frame))
       (else (iter-frame (- index-number 1) (cdr frame)))))
-  (let ((frame (iter-env (frame-number adr) env)))
+  (let ((frame (lexical-address-frame (frame-number adr) env)))
+    (iter-frame (index-number adr) frame)))
+
+(define (lexical-address-set! adr val env)
+  (define (iter-frame index-number frame)
+    (cond
+      ((null? frame) (error "index does not exist - LEXICAL-ADDRESS-LOOKUP" adr env))
+      ((= index-number 0) (set-car! frame val))
+      (else (iter-frame (- index-number 1) (cdr frame)))))
+  (let ((frame (lexical-address-frame (frame-number adr) env)))
     (iter-frame (index-number adr) frame)))
 
 (assert (lexical-address-lookup (make-address 0 0) test-env) 1)
-(assert (lexical-address-lookup (make-address 0 1) test-env) 2)
-(assert (lexical-address-lookup (make-address 0 2) test-env) 3)
-(assert (lexical-address-lookup (make-address 1 0) test-env) 4)
+(lexical-address-set! (make-address 0 0) 42 test-env)
+(assert (lexical-address-lookup (make-address 0 0) test-env) 42)
 (assert (lexical-address-lookup (make-address 2 2) test-env) 9)
-
-;  (define (env-loop env)
-;    (define (scan vars vals)
-;      (cond ((null? vars)
-;             (env-loop (enclosing-environment env)))
-;            ((eq? var (car vars))
-;             (car vals))
-;            (else (scan (cdr vars) (cdr vals)))))
-;    (if (eq? env the-empty-environment)
-;        'unbound-variable-error
-;        (let ((frame (first-frame env)))
-;          (scan (frame-variables frame)
-;                (frame-values frame)))))
-;  (env-loop env))
-
-;(define (unbound-variable? var)
-;  (eq? var 'unbound-variable-error))
-
-(define (lexical-address-set! adr val env) '())
-
-;  (define (env-loop env)
-;    (define (scan vars vals)
-;      (cond ((null? vars)
-;             (env-loop (enclosing-environment env)))
-;            ((eq? var (car vars))
-;             (set-car! vals val))
-;            (else (scan (cdr vars) (cdr vals)))))
-;    (if (eq? env the-empty-environment)
-;        (error "Unbound variable -- SET!" var)
-;        (let ((frame (first-frame env)))
-;          (scan (frame-variables frame)
-;                (frame-values frame)))))
-;  (env-loop env))
+(lexical-address-set! (make-address 2 2) 43 test-env)
+(assert (lexical-address-lookup (make-address 2 2) test-env) 43)
 
 
-(display "\nex-5.40\n")
+(display "\nex-5.40 - compile-time-env\n")
 
-;(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-lexaddr.scm")
+(define (empty-compile-time-env) '())
 
-; (display "\nex-5.41\n")
-; (display "\nex-5.42\n")
+(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 "\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)
+
+(assert (find-variable 'c '((y z) (a b c d e) (x y)))
+        (make-address 1 2))
+
+(assert (find-variable 'x '((y z) (a b c d e) (x y)))
+        (make-address 2 0))
+
+(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")
 
diff --git a/misc/sicp-compiler-lexical-addressing.scm b/misc/sicp-compiler-lexical-addressing.scm
index 71d3602..07467ce 100644
--- a/misc/sicp-compiler-lexical-addressing.scm
+++ b/misc/sicp-compiler-lexical-addressing.scm
@@ -13,31 +13,35 @@
 
 ;;**implementation-dependent loading of syntax procedures
 (load "misc/sicp-syntax.scm")			;section 4.1.2 syntax procedures
+(load "misc/sicp-eceval-support.scm") ;; for let support
 
 
 ;;;SECTION 5.5.1
 
-(define (compile exp target linkage)
+(define (compile exp ct-env target linkage)
   (cond ((self-evaluating? exp)
          (compile-self-evaluating exp target linkage))
         ((quoted? exp) (compile-quoted exp target linkage))
         ((variable? exp)
-         (compile-variable exp target linkage))
+         (compile-variable exp ct-env target linkage))
         ((assignment? exp)
-         (compile-assignment exp target linkage))
+         (compile-assignment exp ct-env target linkage))
         ((definition? exp)
-         (compile-definition exp target linkage))
-        ((if? exp) (compile-if exp target linkage))
-        ((lambda? exp) (compile-lambda exp target linkage))
+         (compile-definition exp ct-env target linkage))
+        ((if? exp) (compile-if exp ct-env target linkage))
+        ((let? exp)
+          (compile (let->combination exp) ct-env target linkage))
+        ((lambda? exp) (compile-lambda exp ct-env target linkage))
         ((begin? exp)
          (compile-sequence (begin-actions exp)
+                           ct-env
                            target
                            linkage))
-        ((cond? exp) (compile (cond->if exp) target linkage))
+        ((cond? exp) (compile (cond->if exp) ct-env target linkage))
         ((primitive-procedure? exp)
          (compile-primitive exp target linkage))
         ((application? exp)
-         (compile-application exp target linkage))
+         (compile-application exp ct-env target linkage))
         (else
          (error "Unknown expression type -- COMPILE" exp))))
 
@@ -83,7 +87,7 @@
    (make-instruction-sequence '() (list target)
     `((assign ,target (const ,(text-of-quotation exp)))))))
 
-(define (compile-variable exp target linkage)
+(define (compile-variable exp ct-env target linkage)
   (end-with-linkage linkage
    (make-instruction-sequence '(env) (list target)
     `((assign ,target
@@ -91,7 +95,7 @@
               (const ,exp)
               (reg env))))))
 
-(define (compile-assignment exp target linkage)
+(define (compile-assignment exp ct-env target linkage)
   (let ((var (assignment-variable exp))
         (get-value-code
          (compile (assignment-value exp) 'val 'next)))
@@ -105,10 +109,10 @@
                   (reg env))
          (assign ,target (const ok))))))))
 
-(define (compile-definition exp target linkage)
+(define (compile-definition exp ct-env target linkage)
   (let ((var (definition-variable exp))
         (get-value-code
-         (compile (definition-value exp) 'val 'next)))
+         (compile (definition-value exp) ct-env 'val 'next)))
     (end-with-linkage linkage
      (preserving '(env)
       get-value-code
@@ -135,18 +139,18 @@
                    (number->string (new-label-number)))))
 ;; end of footnote
 
-(define (compile-if exp target linkage)
+(define (compile-if exp ct-env target linkage)
   (let ((t-branch (make-label 'true-branch))
         (f-branch (make-label 'false-branch))
         (after-if (make-label 'after-if)))
     (let ((consequent-linkage
            (if (eq? linkage 'next) after-if linkage)))
-      (let ((p-code (compile (if-predicate exp) 'val 'next))
+      (let ((p-code (compile (if-predicate exp) ct-env 'val 'next))
             (c-code
              (compile
-              (if-consequent exp) target consequent-linkage))
+              (if-consequent exp) ct-env target consequent-linkage))
             (a-code
-             (compile (if-alternative exp) target linkage)))
+             (compile (if-alternative exp) ct-env target linkage)))
         (preserving '(env continue)
          p-code
          (append-instruction-sequences
@@ -160,16 +164,16 @@
 
 ;;; sequences
 
-(define (compile-sequence seq target linkage)
+(define (compile-sequence seq ct-env target linkage)
   (if (last-exp? seq)
-      (compile (first-exp seq) target linkage)
+      (compile (first-exp seq) ct-env target linkage)
       (preserving '(env continue)
-       (compile (first-exp seq) target 'next)
-       (compile-sequence (rest-exps seq) target linkage))))
+       (compile (first-exp seq) ct-env target 'next)
+       (compile-sequence (rest-exps seq) ct-env target linkage))))
 
 ;;;lambda expressions
 
-(define (compile-lambda exp target linkage)
+(define (compile-lambda exp ct-env target linkage)
   (let ((proc-entry (make-label 'entry))
         (after-lambda (make-label 'after-lambda)))
     (let ((lambda-linkage
@@ -182,11 +186,12 @@
                     (op make-compiled-procedure)
                     (label ,proc-entry)
                     (reg env)))))
-        (compile-lambda-body exp proc-entry))
+        (compile-lambda-body exp ct-env proc-entry))
        after-lambda))))
 
-(define (compile-lambda-body exp proc-entry)
-  (let ((formals (lambda-parameters exp)))
+(define (compile-lambda-body exp ct-env proc-entry)
+  (let* ((formals (lambda-parameters exp))
+         (ct-env (extend-compile-time-env formals ct-env)))
     (append-instruction-sequences
      (make-instruction-sequence '(env proc argl) '(env)
       `(,proc-entry
@@ -196,17 +201,17 @@
                 (const ,formals)
                 (reg argl)
                 (reg env))))
-     (compile-sequence (lambda-body exp) 'val 'return))))
+     (compile-sequence (lambda-body exp) ct-env 'val 'return))))
 
 
 ;;;SECTION 5.5.3
 
 ;;;combinations
 
-(define (compile-application exp target linkage)
-  (let ((proc-code (compile (operator exp) 'proc 'next))
+(define (compile-application exp ct-env target linkage)
+  (let ((proc-code (compile (operator exp) ct-env 'proc 'next))
         (operand-codes
-         (map (lambda (operand) (compile operand 'val 'next))
+         (map (lambda (operand) (compile operand ct-env 'val 'next))
               (operands exp))))
     (preserving '(env continue)
      proc-code
diff --git a/util.scm b/util.scm
index 3dcce30..fbbd6f1 100644
--- a/util.scm
+++ b/util.scm
@@ -129,27 +129,4 @@
 
 (define integers (cons-stream 1 (add-streams ones integers)))
 
-(define (compile-to-file code target linkage file-name)
-  (set! label-counter 0)
-  (define (write-list-to-port xs port)
-    (if (null? xs)
-      '()
-      (begin
-        (display (car xs) port)
-        (display "\n" port)
-        (write-list-to-port (cdr xs) port))))
-  (if #t ; #t means write to file; #f means don't write to file
-    (let* ((compile-result (compile code target linkage))
-           (assembly-insts (statements compile-result))
-           (port (open-output-file file-name)))
-      (write-list-to-port assembly-insts port)
-      (display "[")
-      (display file-name)
-      (display "]\n")
-      (close-output-port port))
-      (begin
-        (display "[")
-        (display file-name)
-        (display "]\n"))))
-
 'util-loaded