Implement till 5.39
parent
360f740441
commit
54bc6725f3
|
|
@ -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
|
||||
|
|
|
|||
151
ex-5_39-xx.scm
151
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")
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
23
util.scm
23
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue