<< Previous exercise (5.43) | Index | Next exercise (5.45) >>
Just to expand on the comment in the question that "The code will work correctly as long as the program does not define or set! these names."
This approach will work with:
((lambda (+ a b)
(+ a b))
- 10 3)
which means it will also work with internal definitions:
(define (seven)
(define + -)
(+ 10 3))
But it won't work with a top level define:
(define + -) (+ 10 3)
because this definition is stored in the global environment which isn't available at compile time. Nor will it work with:
(define (seven)
(set! + -)
(+ 10 3))
set! will fail because there is no + defined in the environment.
A compilation of solutions from Ex 5.39 to Ex 5.44.
(load "ch5-compiler.scm") ;;; syntax support (define the-open-code-procedures '(+ - * / =)) (define (open-code-application? exp) (memq (car exp) the-open-code-procedures)) (define (second-operand operands) (cadr operands)) ;;; Exercise 5.39-5.42 implement an "real" definition version of lexical addressing compiler, ;;; in which internal definitions for block structure are considered "real" ;;; defines. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; NOTE: YOU CAN COMMENT OUT EXERCISE 5.43 IF YOU WANT TO RUN THIS VERSION. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Exercise 5.39 ;;; operations used by run-time environment for lexical-addressing (define (frame-number address) (car address)) (define (displacement-number address) (cadr address)) ;; return a frame with a given index (define (env-ref runtime-env n) (if (= n 0) (first-frame runtime-env) (env-ref (enclosing-environment runtime-env) (- n 1)))) (define (frame-values-ref frame-values n) (list-ref frame-values n)) (define (frame-values-set! frame-values n val) (if (zero? n) (set-car! frame-values val) (frame-values-set! (cdr frame-values) (- n 1) val))) (define (lexical-address-lookup address runtime-env) (let* ([f-num (frame-number address)] [d-num (displacement-number address)] [val (frame-values-ref (frame-values (env-ref runtime-env f-num)) d-num)]) (if (eq? val '*unassigned*) (error "use unassigned variable" (car vars)) val))) (define (lexical-address-set! address val runtime-env) (let ([f-num (frame-number address)] [d-num (displacement-number address)]) (frame-values-set! (frame-values (env-ref runtime-env f-num)) d-num val))) ;;; Exercise 5.40 ;; a blacklist contains a list of modified open-code-procedures ;; which are no longer considered as open-code-procedures, ;; we won't compile modified open-code-procedures "in line", ;; instead, those will be taken as general application. (define (compile exp compile-time-env blacklist target linkage) (cond ((self-evaluating? exp) (compile-self-evaluating exp target linkage)) ((quoted? exp) (compile-quoted exp target linkage)) ((variable? exp) (compile-variable exp compile-time-env target linkage)) ((assignment? exp) (compile-assignment exp compile-time-env blacklist target linkage)) ((definition? exp) (compile-definition exp compile-time-env blacklist target linkage)) ((if? exp) (compile-if exp compile-time-env blacklist target linkage)) ((lambda? exp) (compile-lambda exp compile-time-env blacklist target linkage)) ((begin? exp) (compile-sequence (begin-actions exp) compile-time-env blacklist target linkage)) ((cond? exp) (compile (cond->if exp) compile-time-env blacklist target linkage)) ;; LET clause for the scaning out version ((let? exp) (compile (let->combination exp) compile-time-env blacklist target linkage)) ((and (open-code-application? exp) ; we compile exp "in line" if and only if ; exp is open-code-application [1] ; ; and operator is open-code-procedure ; (which means operator is not in ; blacklist) [2] ; ; and variable will be found in top-level-environment ; if we are in the current compile-time environment [3] ; (open-code-procedure? (operator exp) blacklist) (variable-in-top-level? (operator exp) compile-time-env)) (compile-open-code exp compile-time-env blacklist target linkage)) ((application? exp) (compile-application exp compile-time-env blacklist target linkage)) (else (error "Unknown expression type -- COMPILE" exp)))) (define (compile-sequence seq compile-time-env blacklist target linkage) ;; for internal definitions without scanning out, we need ;; impose an evaluation order on sequence evaluation so that ;; subsequent expressions can refer to preceding definitions. ;; Here's why: I found the order of evaluation of operands is ;; dependent on the implementation of Scheme. In Chez Scheme, ;; the interpreter does not follow ours intuition that ;; operands are evaluated from left to right. Running the ;; compiled instructions by original version will raise ;; an exception, if we don't impose an order of evaluation. (let ([first-code (if (last-exp? seq) (compile (first-exp seq) compile-time-env blacklist target linkage) (compile (first-exp seq) compile-time-env blacklist target 'next))]) (if (last-exp? seq) first-code (preserving '(env continue) first-code (compile-sequence (rest-exps seq) compile-time-env blacklist target linkage))))) (define (compile-lambda exp compile-time-env blacklist 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 (extend-compile-time-environment (lambda-parameters exp) compile-time-env) blacklist proc-entry)) after-lambda)))) (define (extend-compile-time-environment vars base-env) (cons vars base-env)) (define (compile-lambda-body exp compile-time-env blacklist 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) compile-time-env blacklist 'val 'return)))) (define (compile-application exp compile-time-env blacklist target linkage) (let ((proc-code (compile (operator exp) compile-time-env blacklist 'proc 'next)) (operand-codes (map (lambda (operand) (compile operand compile-time-env blacklist 'val 'next)) (operands exp)))) (preserving '(env continue) proc-code (preserving '(proc continue) (construct-arglist operand-codes) (compile-procedure-call target linkage))))) (define (compile-if exp compile-time-env blacklist 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) compile-time-env blacklist 'val 'next)) (c-code (compile (if-consequent exp) compile-time-env blacklist target consequent-linkage)) (a-code (compile (if-alternative exp) compile-time-env blacklist 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)))))) ;;; Exercise 5.41 (define (index-of lst val) (define (iter n lst) (cond [(null? lst) -1] [(eq? (car lst) val) n] [else (iter (+ n 1) (cdr lst))])) (iter 0 lst)) (define (found? address) (not (eq? address 'not-found))) (define (find-variable var compile-time-env) (define (iter f-num compile-time-env) (if (null? compile-time-env) 'not-found (let ([d-num (index-of (first-frame compile-time-env) var)]) (if (= d-num -1) (iter (+ f-num 1) (enclosing-environment compile-time-env)) (list f-num d-num))))) (iter 0 compile-time-env)) ;;; Exercise 5.42 (define (top-level-environment? compile-time-env) (= (length compile-time-env) 1)) (define (open-code-procedure? proc blacklist) (and (memq proc the-open-code-procedures) (not (memq proc blacklist)))) (define (add-proc-to-blacklist var blacklist) (set-cdr! blacklist (cons var (cdr blacklist)))) ;;; define a variable in the current compile-time-env ;;; add a procedure to blacklist if it meets the conditions ;;; (1. the current compile-time-env is top-level-environment ;;; 2. it is open-code-procedure) (define (define-compile-time-variable! var compile-time-env blacklist) (if (and (top-level-environment? compile-time-env) (open-code-procedure? var blacklist)) (add-proc-to-blacklist var blacklist)) (if (not (memq var (car compile-time-env))) (set-car! compile-time-env (cons var (car compile-time-env))))) (define (variable-in-top-level? var compile-time-env) (eq? (frame-number (find-variable var compile-time-env)) (- (length compile-time-env) 1))) (define (compile-variable exp compile-time-env target linkage) (let ([address (find-variable exp compile-time-env)]) (end-with-linkage linkage (make-instruction-sequence '(env) (list target) `((assign ,target (op lexical-address-lookup) (const ,address) (reg env))))))) (define (compile-assignment exp compile-time-env blacklist target linkage) (let* ([var (assignment-variable exp)] [get-value-code (compile (assignment-value exp) compile-time-env blacklist 'val 'next)] [address (find-variable var compile-time-env)]) (if (and (variable-in-top-level? var compile-time-env) (open-code-procedure? var blacklist)) (add-proc-to-blacklist var blacklist)) (end-with-linkage linkage (preserving '(env) get-value-code (make-instruction-sequence '(env val) (list target) `((perform (op lexical-address-set!) (const ,address) (reg val) (reg env)) (assign ,target (const ok)))))))) (define (compile-definition exp compile-time-env blacklist target linkage) (let ((var (definition-variable exp))) (define-compile-time-variable! var compile-time-env blacklist) (let ((get-value-code (compile (definition-value exp) compile-time-env blacklist '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))))))))) ;;; setting up a compile time environment which is perfectly ;;; parallel to the runtime environment, which means we do not ;;; deal with the global environment specially (all variables ;;; in the global environment have a correspoding lexical address. (define (setup-compile-environment) (list (frame-variables (first-frame (setup-environment))))) ;;; Exercise 5.43 ;;; **NB** we redefine some function in order to support an version with scanning out. ;;; we don't define a variable in the current compile-time-env, ;;; just add a procedure to blacklist if it meets the conditions ;;; (1. the current compile-time-env is top-level-environment ;;; 2. it is open-code-procedure) (define (define-compile-time-variable! var compile-time-env blacklist) (if (and (top-level-environment? compile-time-env) (open-code-procedure? var blacklist)) (add-proc-to-blacklist var blacklist))) ;;; setting up a compile time environment, ;;; the top level environment of a compile time environment ;;; is empty, which means all variables ;;; in the global environment don't have a lexical address, ;;; so we need compile those expressions with lookup-variable-value. (define (setup-compile-environment) '(())) ;;; we modified this, since the top level environment is empty. (define (variable-in-top-level? var compile-time-env) (not (found? (find-variable var compile-time-env)))) ;;; NOTE: the special handling of the global variables (define (compile-variable exp compile-time-env target linkage) (let* ([address (find-variable exp compile-time-env)] [lookup (if (found? address) 'lexical-address-lookup 'lookup-variable-value)] [object (if (found? address) address exp)] [needed (if (found? address) '(env) '())] [modified (if (found? address) (list target) (list target 'env))] [maybe-change-env (if (found? address) '() '((assign env (op get-global-environment))))]) (end-with-linkage linkage (make-instruction-sequence needed modified (append maybe-change-env `((assign ,target (op ,lookup) (const ,object) (reg env)))))))) (define (compile-assignment exp compile-time-env blacklist target linkage) (let* ([var (assignment-variable exp)] [get-value-code (compile (assignment-value exp) compile-time-env blacklist 'val 'next)] [address (find-variable var compile-time-env)] [setter (if (found? address) 'lexical-address-set! 'set-variable-value!)] [object (if (found? address) address var)] [needed (if (found? address) '(env val) '(val))] [modified (if (found? address) (list target) (list target 'env))] [maybe-change-env (if (found? address) '() '((assign env (op get-global-environment))))]) (if (and (variable-in-top-level? var compile-time-env) (open-code-procedure? var blacklist)) (add-proc-to-blacklist var blacklist)) (end-with-linkage linkage (preserving '(env) get-value-code (make-instruction-sequence needed modified (append maybe-change-env `((perform (op ,setter) (const ,object) (reg val) (reg env)) (assign ,target (const ok))))))))) ;;; NOTE: we scan out internal definitions in lambda body here. (define (compile-lambda-body exp compile-time-env blacklist 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 (scan-out-defines ;** (lambda-body exp)) ;** compile-time-env blacklist 'val 'return)))) ;;; Exercise 5.44 (define (spread-arguments operands compile-time-env blacklist) (let ([arg1-code (compile (first-operand operands) compile-time-env blacklist 'arg1 'next)] (rest-codes (map (lambda (op) (compile op compile-time-env blacklist 'arg2 'next)) (rest-operands operands)))) (if (>= (length operands) 2) (cons arg1-code rest-codes) (error "Unsupported arity!" operands)))) (define (compile-open-code exp compile-time-env blacklist target linkage) (define (compile-open-code-rest operand-codes) (if (null? (cdr operand-codes)) (preserving '(arg1) (car operand-codes) (make-instruction-sequence '(arg1 arg2) ;in fact, arg2 can be omitted. (list target) `((assign ,target (op ,(operator exp)) (reg arg1) (reg arg2))))) (preserving '(arg1 env) (car operand-codes) (append-instruction-sequences (make-instruction-sequence '(arg1 arg2) ;in fact, arg2 can be omitted. '(arg1) `((assign arg1 (op ,(operator exp)) (reg arg1) (reg arg2)))) (compile-open-code-rest (cdr operand-codes)) )))) ;; we evaluate the first operand and the second operand, ;; then assign the values to the corresponding registers sequentially. ;; By accumulating arg2 into arg1, we have the accumulation of the first ;; two operands. After that, we evaluate the third and put its value into ;; arg2. As above, we accumulate arg2 into arg1 so that we have the ;; accumulation of the first three operands. And so on, until we reach ;; the last operand of the operands, this time, we put the accumulation ;; of arg1 and arg2 into the target register. (let ([operand-codes (spread-arguments (operands exp) compile-time-env blacklist)]) (end-with-linkage linkage (preserving '(env) (car operand-codes) (compile-open-code-rest (cdr operand-codes)))))) ;;; Verification Support (load "ch5-regsim.scm") (define (lookup-prim symbol operations) (let ((val (assoc symbol operations))) (if val (cadr val) (eval symbol)))) ;;; some expressions and its corresponding anwsers (define exps (list '(begin (define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n))) (factorial 5)) ;; => 120 '(begin (define + (lambda (x) (- 1 1))) + (+ 1)) ;; => 0 '(((lambda (x y) (lambda (a b c d e) ((lambda (y z) (* x y z)) (* a b x) (+ c d x)))) 3 4) 1 7 3 4 5 ) ;; => 630 '(let ((x 3) (y 4)) ((lambda (a b c d e) (let ((y (* a b x)) (z (+ c d x))) (* x y z))) 1 7 3 4 5 )) ;; => 630 '(begin (define (square x) (* x x)) (define x 4) (+ (square 2) x x) ) ;; => 12 '((lambda (+ * a b x y) (+ (* a x) (* b y))) + * 1 2 3 4) ;; => 11 '((lambda (+ * a b x y) (+ (* a x) (* b y))) * + 1 2 3 4) ;; => 24 '(begin ((lambda (+ * a b x y) (+ (* a x) (* b y))) * + 1 2 3 4) (+ 1 3 4 5)) ;; => 13 '(begin (set! + 1) +) ;; => 1 '(begin (define y 2) (define - y) (define + -) (define (f x) (set! x +) (set! + *) (+ x 3)) (f 2)) ;; => 6 '(begin (define (f x) (define + -) 1) (f 2) (+ 1 1)) ;; => 2 '(begin (define (f x) (set! + -) 1) (f 2) (+ 1 1)) ;; => 0 '(begin (define + -) (+ 1 1)) ;; => 0 '(begin (define (factorial n) (define (iter product counter) (if (> counter n) product (iter (* counter product) (+ counter 1)))) (iter 1 1)) (factorial 5)) ;; => 120 '(begin (set! + (begin (set! + -) (+ 1 1))) +) ;; => 0 '(begin (set! + (begin (+ 1 1))) +) ;; => 2 )) (define (make-blacklist) (list '*HEAD*)) (define (compile-and-print exp) (define the-global-environment (setup-environment)) (define (get-global-environment) the-global-environment) (define demo-machine (make-machine all-regs (list (list 'get-global-environment get-global-environment)) (statements (compile exp (setup-compile-environment) (make-blacklist) 'val 'next)))) ;; Extra settings for Chez Scheme (define new-env (copy-environment (scheme-environment))) (eval '(define + '()) new-env) (eval '(define + (eval '+ (scheme-environment))) new-env) (eval '(define - '()) new-env) (eval '(define - (eval '- (scheme-environment))) new-env) (eval '(define * '()) new-env) (eval '(define * (eval '* (scheme-environment))) new-env) (eval '(define / '()) new-env) (eval '(define / (eval '/ (scheme-environment))) new-env) (eval '(define = '()) new-env) (eval '(define = (eval '= (scheme-environment))) new-env) (set-register-contents! demo-machine 'env (get-global-environment)) (start demo-machine) (pretty-print exp) (display ";; => ") (pretty-print (get-register-contents demo-machine 'val)) (if (eq? (eval exp new-env) (get-register-contents demo-machine 'val)) (display "pass") (begin (display "fail") (newline) (display (eval exp new-env)))) (newline) (newline) ) (for-each compile-and-print exps) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;OUTPUT;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (begin (define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n))) (factorial 5)) ;; => 120 pass (begin (define + (lambda (x) (- 1 1))) + (+ 1)) ;; => 0 pass (((lambda (x y) (lambda (a b c d e) ((lambda (y z) (* x y z)) (* a b x) (+ c d x)))) 3 4) 1 7 3 4 5) ;; => 630 pass (let ([x 3] [y 4]) ((lambda (a b c d e) (let ([y (* a b x)] [z (+ c d x)]) (* x y z))) 1 7 3 4 5)) ;; => 630 pass (begin (define (square x) (* x x)) (define x 4) (+ (square 2) x x)) ;; => 12 pass ((lambda (+ * a b x y) (+ (* a x) (* b y))) + * 1 2 3 4) ;; => 11 pass ((lambda (+ * a b x y) (+ (* a x) (* b y))) * + 1 2 3 4) ;; => 24 pass (begin ((lambda (+ * a b x y) (+ (* a x) (* b y))) * + 1 2 3 4) (+ 1 3 4 5)) ;; => 13 pass (begin (set! + 1) +) ;; => 1 pass (begin (define y 2) (define - y) (define + -) (define (f x) (set! x +) (set! + *) (+ x 3)) (f 2)) ;; => 6 pass (begin (define (f x) (define + -) 1) (f 2) (+ 1 1)) ;; => 2 pass (begin (define (f x) (set! + -) 1) (f 2) (+ 1 1)) ;; => 0 pass (begin (define + -) (+ 1 1)) ;; => 0 pass (begin (define (factorial n) (define (iter product counter) (if (> counter n) product (iter (* counter product) (+ counter 1)))) (iter 1 1)) (factorial 5)) ;; => 120 pass (begin (set! + (begin (set! + -) (+ 1 1))) +) ;; => 0 pass (begin (set! + (begin (+ 1 1))) +) ;; => 2 pass ;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; a special test case: ;;; raises an exception in version 1 ;;; works in version 2 ;;; You can test it yourself! '(begin (define (f) (define (g) h) (define (h) g) ((h))) (f)) ;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;
meteorgan