Chapter 5, Computing with Register Machines
Exercise 5.43
- Used the code
scan-out-defines
from ex-4.16. - Because
scan-out-defines
convert the code into alet
expression, we need our compiler to parse let expresstions. This can be done just by converting the code oflet
intolambda
which we have already done in ex-4.6. - There’s a subtle point about the return value of
scan-out-defines
. It should be returning a sequence because we send its output tocompile-sequence
. It turns out that it is already doing so as per the old implementation! So, nothing needs to be done.
Well, that’s it!
Here are the changes:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
;;Change in compile procedure
((let? exp) (compile (let->combination exp) target linkage cenv))
(define (compile-lambda-body exp proc-entry cenv)
(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)) ;;;
'val
'return
(extend-cenv formals cenv)))))
;;this procedure copied from ex-4.16 for ex-5.43
(define (scan-out-defines proc-body)
(let ((result
(fold-right
(lambda(new rem)
(if (definition? new)
(let ((var-def (list (definition-variable new) ''*unassigned*))
(var-set (list 'set! (definition-variable new) (definition-value new))))
(list (cons var-def (car rem))
(cons var-set (cadr rem))))
(list (car rem)
(cons new (cadr rem)))))
(list '() '())
proc-body)))
(if (eq? '() (car result))
proc-body ;;return original else infinite loop!
;;note that this procedure was copied from ex-4.16
;;and there we put the result in a list
;;and it turns out we need to get the result
;;in a list here too bec this result is passed to
;;compiler sequence and it expects a sequence
;;which means a list!
(list (make-let (car result)
(cadr result))))))
Also, there are few changes in ch5-syntax.scm - to add support for let?
:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
;; var-defs and body should be list
(define (make-let var-defs body)
(cons 'let (cons var-defs body)))
(define (let? exp) (tagged-list? exp 'let))
(define (let-varexps exp) (cadr exp))
(define (let-body exp) (cddr exp))
(define (let->combination exp)
(let ((res (fold-right
(lambda (new rem)
(cons (cons (car new) (car rem))
(cons (cadr new) (cdr rem))))
(cons '() '())
(let-varexps exp))))
(let ((vars (car res))
(vexps (cdr res)))
(cons (make-lambda vars (let-body exp)) vexps)
)))
Example/Code
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
1 ]=>
(compile '(define (dummy) (define a 10) a (define b 20) (+ a b)) 'val 'next the-empty-cenv)
;;Output:
((env)
(val)
(
(assign val (op make-compiled-procedure) (label entry2) (reg env))
(goto (label after-lambda1))
entry2
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const ()) (reg argl) (reg env))
(assign proc (op make-compiled-procedure) (label entry4) (reg env))
(goto (label after-lambda3))
entry4
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (a b)) (reg argl) (reg env))
(assign val (const 10))
(perform (op lexical-address-set!) (const (0 0)) (reg val) (reg env))
(assign val (const ok))
(assign val (op lexical-address-lookup) (const (0 0)) (reg env))
(assign val (const 20))
(perform (op lexical-address-set!) (const (0 1)) (reg val) (reg env))
(assign val (const ok))
(assign proc (op lookup-variable-value) (const +) (reg env))
(assign val (op lexical-address-lookup) (const (0 1)) (reg env))
(assign argl (op list) (reg val))
(assign val (op lexical-address-lookup) (const (0 0)) (reg env))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-branch7))
compiled-branch6
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-branch7
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
(goto (reg continue))
after-call5
after-lambda3
(assign val (const *unassigned*))
(assign argl (op list) (reg val))
(assign val (const *unassigned*))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-branch10))
compiled-branch9
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-branch10
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
(goto (reg continue))
after-call8
after-lambda1
(perform (op define-variable!) (const dummy) (reg val) (reg env))
(assign val (const ok))
))