From 360f74044147e04a34548dadc69d490b9e652486 Mon Sep 17 00:00:00 2001
From: Felix Martin <mail@felixm.de>
Date: Wed, 21 Apr 2021 10:02:02 -0400
Subject: [PATCH] Work on 5.39

---
 ex-5_39-xx.scm                            |  88 ++++-
 misc/sicp-compiler-lexical-addressing.scm | 384 ++++++++++++++++++++++
 misc/sicp-eceval-compiler.scm             |  16 +-
 util.scm                                  |   2 +-
 4 files changed, 474 insertions(+), 16 deletions(-)
 create mode 100644 misc/sicp-compiler-lexical-addressing.scm

diff --git a/ex-5_39-xx.scm b/ex-5_39-xx.scm
index e38c699..933987c 100644
--- a/ex-5_39-xx.scm
+++ b/ex-5_39-xx.scm
@@ -1,16 +1,90 @@
 (load "util.scm")
-(load "misc/sicp-compiler.scm")
+(load "misc/sicp-compiler-lexical-addressing.scm")
 
-(display "\nex-5.39\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))
+
+(define test-env '((1 2 3) (4 5 6) (7 8 9)))
+
+(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))
+      ((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)))
+    (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)
+(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))
 
-(let ((x 3) (y 4))
-  (lambda (a b c d e)
-    (let ((y (* a b x))
-          (z (+ c d x)))
-      (* x y z))))
 
 (display "\nex-5.40\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")
 
 ; (display "\nex-5.41\n")
 ; (display "\nex-5.42\n")
diff --git a/misc/sicp-compiler-lexical-addressing.scm b/misc/sicp-compiler-lexical-addressing.scm
new file mode 100644
index 0000000..71d3602
--- /dev/null
+++ b/misc/sicp-compiler-lexical-addressing.scm
@@ -0,0 +1,384 @@
+;;;;COMPILER FROM SECTION 5.5 OF
+;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
+
+;;;;Matches code in ch5.scm
+
+;;;;This file can be loaded into Scheme as a whole.
+;;;;**NOTE**This file loads the metacircular evaluator's syntax procedures
+;;;;  from section 4.1.2
+;;;;  You may need to change the (load ...) expression to work in your
+;;;;  version of Scheme.
+
+;;;;Then you can compile Scheme programs as shown in section 5.5.5
+
+;;**implementation-dependent loading of syntax procedures
+(load "misc/sicp-syntax.scm")			;section 4.1.2 syntax procedures
+
+
+;;;SECTION 5.5.1
+
+(define (compile exp 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))
+        ((assignment? exp)
+         (compile-assignment exp target linkage))
+        ((definition? exp)
+         (compile-definition exp target linkage))
+        ((if? exp) (compile-if exp target linkage))
+        ((lambda? exp) (compile-lambda exp target linkage))
+        ((begin? exp)
+         (compile-sequence (begin-actions exp)
+                           target
+                           linkage))
+        ((cond? exp) (compile (cond->if exp) target linkage))
+        ((primitive-procedure? exp)
+         (compile-primitive exp target linkage))
+        ((application? exp)
+         (compile-application exp target linkage))
+        (else
+         (error "Unknown expression type -- COMPILE" exp))))
+
+
+(define (make-instruction-sequence needs modifies statements)
+  (list needs modifies statements))
+
+(define (empty-instruction-sequence)
+  (make-instruction-sequence '() '() '()))
+
+;; Implemented in 5.38.
+(define (primitive-procedure? exp) #f)
+
+;;;SECTION 5.5.2
+
+;;;linkage code
+
+(define (compile-linkage linkage)
+  (cond ((eq? linkage 'return)
+         (make-instruction-sequence '(continue) '()
+          '((goto (reg continue)))))
+        ((eq? linkage 'next)
+         (empty-instruction-sequence))
+        (else
+         (make-instruction-sequence '() '()
+          `((goto (label ,linkage)))))))
+
+(define (end-with-linkage linkage instruction-sequence)
+  (preserving '(continue)
+   instruction-sequence
+   (compile-linkage linkage)))
+
+
+;;;simple expressions
+
+(define (compile-self-evaluating exp target linkage)
+  (end-with-linkage linkage
+   (make-instruction-sequence '() (list target)
+    `((assign ,target (const ,exp))))))
+
+(define (compile-quoted exp target linkage)
+  (end-with-linkage linkage
+   (make-instruction-sequence '() (list target)
+    `((assign ,target (const ,(text-of-quotation exp)))))))
+
+(define (compile-variable exp target linkage)
+  (end-with-linkage linkage
+   (make-instruction-sequence '(env) (list target)
+    `((assign ,target
+              (op lookup-variable-value)
+              (const ,exp)
+              (reg env))))))
+
+(define (compile-assignment exp 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))))))))
+
+(define (compile-definition exp target linkage)
+  (let ((var (definition-variable exp))
+        (get-value-code
+         (compile (definition-value exp) 'val 'next)))
+    (end-with-linkage linkage
+     (preserving '(env)
+      get-value-code
+      (make-instruction-sequence '(env val) (list target)
+       `((perform (op define-variable!)
+                  (const ,var)
+                  (reg val)
+                  (reg env))
+         (assign ,target (const ok))))))))
+
+
+;;;conditional expressions
+
+;;;labels (from footnote)
+(define label-counter 0)
+
+(define (new-label-number)
+  (set! label-counter (+ 1 label-counter))
+  label-counter)
+
+(define (make-label name)
+  (string->symbol
+    (string-append (symbol->string name)
+                   (number->string (new-label-number)))))
+;; end of footnote
+
+(define (compile-if exp 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))
+            (c-code
+             (compile
+              (if-consequent exp) target consequent-linkage))
+            (a-code
+             (compile (if-alternative exp) target linkage)))
+        (preserving '(env continue)
+         p-code
+         (append-instruction-sequences
+          (make-instruction-sequence '(val) '()
+           `((test (op false?) (reg val))
+             (branch (label ,f-branch))))
+          (parallel-instruction-sequences
+           (append-instruction-sequences t-branch c-code)
+           (append-instruction-sequences f-branch a-code))
+          after-if))))))
+
+;;; sequences
+
+(define (compile-sequence seq target linkage)
+  (if (last-exp? seq)
+      (compile (first-exp seq) target linkage)
+      (preserving '(env continue)
+       (compile (first-exp seq) target 'next)
+       (compile-sequence (rest-exps seq) target linkage))))
+
+;;;lambda expressions
+
+(define (compile-lambda exp target linkage)
+  (let ((proc-entry (make-label 'entry))
+        (after-lambda (make-label 'after-lambda)))
+    (let ((lambda-linkage
+           (if (eq? linkage 'next) after-lambda linkage)))
+      (append-instruction-sequences
+       (tack-on-instruction-sequence
+        (end-with-linkage lambda-linkage
+         (make-instruction-sequence '(env) (list target)
+          `((assign ,target
+                    (op make-compiled-procedure)
+                    (label ,proc-entry)
+                    (reg env)))))
+        (compile-lambda-body exp proc-entry))
+       after-lambda))))
+
+(define (compile-lambda-body exp proc-entry)
+  (let ((formals (lambda-parameters exp)))
+    (append-instruction-sequences
+     (make-instruction-sequence '(env proc argl) '(env)
+      `(,proc-entry
+        (assign env (op compiled-procedure-env) (reg proc))
+        (assign env
+                (op extend-environment)
+                (const ,formals)
+                (reg argl)
+                (reg env))))
+     (compile-sequence (lambda-body exp) 'val 'return))))
+
+
+;;;SECTION 5.5.3
+
+;;;combinations
+
+(define (compile-application exp target linkage)
+  (let ((proc-code (compile (operator exp) 'proc 'next))
+        (operand-codes
+         (map (lambda (operand) (compile operand 'val 'next))
+              (operands exp))))
+    (preserving '(env continue)
+     proc-code
+     (preserving '(proc continue)
+      (construct-arglist operand-codes)
+      (compile-procedure-call target linkage)))))
+
+(define (construct-arglist operand-codes)
+  (let ((operand-codes (reverse operand-codes)))
+    (if (null? operand-codes)
+        (make-instruction-sequence '() '(argl)
+         '((assign argl (const ()))))
+        (let ((code-to-get-last-arg
+               (append-instruction-sequences
+                (car operand-codes)
+                (make-instruction-sequence '(val) '(argl)
+                 '((assign argl (op list) (reg val)))))))
+          (if (null? (cdr operand-codes))
+              code-to-get-last-arg
+              (preserving '(env)
+               code-to-get-last-arg
+               (code-to-get-rest-args
+                (cdr operand-codes))))))))
+
+(define (code-to-get-rest-args operand-codes)
+  (let ((code-for-next-arg
+         (preserving '(argl)
+          (car operand-codes)
+          (make-instruction-sequence '(val argl) '(argl)
+           '((assign argl
+              (op cons) (reg val) (reg argl)))))))
+    (if (null? (cdr operand-codes))
+        code-for-next-arg
+        (preserving '(env)
+         code-for-next-arg
+         (code-to-get-rest-args (cdr operand-codes))))))
+
+;;;applying procedures
+
+(define (compile-procedure-call target linkage)
+  (let ((primitive-branch (make-label 'primitive-branch))
+        (compiled-branch (make-label 'compiled-branch))
+        (after-call (make-label 'after-call)))
+    (let ((compiled-linkage
+           (if (eq? linkage 'next) after-call linkage)))
+      (append-instruction-sequences
+       (make-instruction-sequence '(proc) '()
+        `((test (op primitive-procedure?) (reg proc))
+          (branch (label ,primitive-branch))))
+       (parallel-instruction-sequences
+        (append-instruction-sequences
+         compiled-branch
+         (compile-proc-appl target compiled-linkage))
+        (append-instruction-sequences
+         primitive-branch
+         (end-with-linkage linkage
+          (make-instruction-sequence '(proc argl)
+                                     (list target)
+           `((assign ,target
+                     (op apply-primitive-procedure)
+                     (reg proc)
+                     (reg argl)))))))
+       after-call))))
+
+;;;applying compiled procedures
+
+(define (compile-proc-appl target linkage)
+  (cond ((and (eq? target 'val) (not (eq? linkage 'return)))
+         (make-instruction-sequence '(proc) all-regs
+           `((assign continue (label ,linkage))
+             (assign val (op compiled-procedure-entry)
+                         (reg proc))
+             (goto (reg val)))))
+        ((and (not (eq? target 'val))
+              (not (eq? linkage 'return)))
+         (let ((proc-return (make-label 'proc-return)))
+           (make-instruction-sequence '(proc) all-regs
+            `((assign continue (label ,proc-return))
+              (assign val (op compiled-procedure-entry)
+                          (reg proc))
+              (goto (reg val))
+              ,proc-return
+              (assign ,target (reg val))
+              (goto (label ,linkage))))))
+        ((and (eq? target 'val) (eq? linkage 'return))
+         (make-instruction-sequence '(proc continue) all-regs
+          '((assign val (op compiled-procedure-entry)
+                        (reg proc))
+            (goto (reg val)))))
+        ((and (not (eq? target 'val)) (eq? linkage 'return))
+         (error "return linkage, target not val -- COMPILE"
+                target))))
+
+;; footnote
+(define all-regs '(env proc val argl continue))
+
+
+;;;SECTION 5.5.4
+
+(define (registers-needed s)
+  (if (symbol? s) '() (car s)))
+
+(define (registers-modified s)
+  (if (symbol? s) '() (cadr s)))
+
+(define (statements s)
+  (if (symbol? s) (list s) (caddr s)))
+
+(define (needs-register? seq reg)
+  (memq reg (registers-needed seq)))
+
+(define (modifies-register? seq reg)
+  (memq reg (registers-modified seq)))
+
+
+(define (append-instruction-sequences . seqs)
+  (define (append-2-sequences seq1 seq2)
+    (make-instruction-sequence
+     (list-union (registers-needed seq1)
+                 (list-difference (registers-needed seq2)
+                                  (registers-modified seq1)))
+     (list-union (registers-modified seq1)
+                 (registers-modified seq2))
+     (append (statements seq1) (statements seq2))))
+  (define (append-seq-list seqs)
+    (if (null? seqs)
+        (empty-instruction-sequence)
+        (append-2-sequences (car seqs)
+                            (append-seq-list (cdr seqs)))))
+  (append-seq-list seqs))
+
+(define (list-union s1 s2)
+  (cond ((null? s1) s2)
+        ((memq (car s1) s2) (list-union (cdr s1) s2))
+        (else (cons (car s1) (list-union (cdr s1) s2)))))
+
+(define (list-difference s1 s2)
+  (cond ((null? s1) '())
+        ((memq (car s1) s2) (list-difference (cdr s1) s2))
+        (else (cons (car s1)
+                    (list-difference (cdr s1) s2)))))
+
+(define (preserving regs seq1 seq2)
+  (if (null? regs)
+      (append-instruction-sequences seq1 seq2)
+      (let ((first-reg (car regs)))
+        (if (and (needs-register? seq2 first-reg)
+                 (modifies-register? seq1 first-reg))
+            (preserving (cdr regs)
+             (make-instruction-sequence
+              (list-union (list first-reg)
+                          (registers-needed seq1))
+              (list-difference (registers-modified seq1)
+                               (list first-reg))
+              (append `((save ,first-reg))
+                      (statements seq1)
+                      `((restore ,first-reg))))
+             seq2)
+            (preserving (cdr regs) seq1 seq2)))))
+
+(define (tack-on-instruction-sequence seq body-seq)
+  (make-instruction-sequence
+   (registers-needed seq)
+   (registers-modified seq)
+   (append (statements seq) (statements body-seq))))
+
+(define (parallel-instruction-sequences seq1 seq2)
+  (make-instruction-sequence
+   (list-union (registers-needed seq1)
+               (registers-needed seq2))
+   (list-union (registers-modified seq1)
+               (registers-modified seq2))
+   (append (statements seq1) (statements seq2))))
+
+'(COMPILER LOADED)
diff --git a/misc/sicp-eceval-compiler.scm b/misc/sicp-eceval-compiler.scm
index d97eb2b..03f1340 100644
--- a/misc/sicp-eceval-compiler.scm
+++ b/misc/sicp-eceval-compiler.scm
@@ -64,7 +64,7 @@
 (define eceval-operations
   (list
    ;;primitive Scheme operations
-   (list 'read read)			;used by eceval
+   (list 'read read)      ;used by eceval
 
    ;;used by compiled code
    (list 'list list)
@@ -102,7 +102,7 @@
 
    ;;operations in eceval-support.scm
    (list 'true? true?)
-   (list 'false? false?)		;for compiled code
+   (list 'false? false?)    ;for compiled code
    (list 'make-procedure make-procedure)
    (list 'compound-procedure? compound-procedure?)
    (list 'procedure-parameters procedure-parameters)
@@ -120,7 +120,7 @@
    (list 'empty-arglist empty-arglist)
    (list 'adjoin-arg adjoin-arg)
    (list 'last-operand? last-operand?)
-   (list 'no-more-exps? no-more-exps?)	;for non-tail-recursive machine
+   (list 'no-more-exps? no-more-exps?)  ;for non-tail-recursive machine
    (list 'get-global-environment get-global-environment)
 
    ;;for compiled code (also in eceval-support.scm)
@@ -133,8 +133,8 @@
 (define eceval
   (make-machine
    '(exp env val proc argl continue unev
-	 compapp			;*for compiled to call interpreted
-	 )
+   compapp      ;*for compiled to call interpreted
+   )
    eceval-operations
   '(
 ;;SECTION 5.4.4, as modified in 5.5.7
@@ -259,10 +259,10 @@ ev-appl-accum-last-arg
 apply-dispatch
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-apply))
-  (test (op compound-procedure?) (reg proc))  
+  (test (op compound-procedure?) (reg proc))
   (branch (label compound-apply))
 ;;*next added to call compiled code from evaluator (section 5.5.7)
-  (test (op compiled-procedure?) (reg proc))  
+  (test (op compiled-procedure?) (reg proc))
   (branch (label compiled-apply))
   (goto (label unknown-procedure-type))
 
@@ -367,4 +367,4 @@ ev-definition-1
   (goto (reg continue))
    )))
 
-'(EXPLICIT CONTROL EVALUATOR FOR COMPILER LOADED)
\ No newline at end of file
+'(EXPLICIT CONTROL EVALUATOR FOR COMPILER LOADED)
diff --git a/util.scm b/util.scm
index 62c4c64..3dcce30 100644
--- a/util.scm
+++ b/util.scm
@@ -138,7 +138,7 @@
         (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
+  (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)))