SICP/ex-5_39-xx.scm

(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")

(define (make-address frame-number index-number)
  (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-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 (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)
(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)
(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 - compile-time-env\n")

(define (empty-compile-time-env) '())

(define (extend-compile-time-env parameters base-env)
  (cons parameters base-env))

(display "[done]\n")

(display "\nex-5.41 - find-variable\n")

(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))

(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 - 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")