137 lines
4.6 KiB
Scheme
137 lines
4.6 KiB
Scheme
(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")
|
|
|