]> git.rkrishnan.org Git - sicp.git/blob - src/sicp/ex4_16.rkt
rewrite `quote->cons' using `match'.
[sicp.git] / src / sicp / ex4_16.rkt
1 #lang racket
2
3 ;; a
4 (define (lookup-variable-value var env)
5   (define (env-loop env)
6     (define (scan vars vals)
7       (cond [(null? vars)
8              (env-loop (enclosing-environment env))]
9             [(eq? var (car vars))
10              (let ([value (car vals)])
11                (if (eq? value '*unassigned*)
12                    (error "evaluating a variable which has not been assigned -- LOOKUP-VARIABLE-VALUE:" value)
13                    value))]
14             [else (scan (cdr vars) (cdr vals))]))
15     (if (eq? env the-empty-environment)
16         (error "unbound variable" var)
17         (let ([frame (first-frame env)])
18           (scan (frame-variables frame)
19                 (frame-values frame)))))
20   (env-loop env))
21
22 ;; b
23 (define (tagged-list? expr tag)
24   (and (pair? expr) (eq? (car expr) tag)))
25
26 (define (definition? expr)
27   (tagged-list? expr 'define))
28
29 (define (lambda? expr)
30   (tagged-list? expr 'lambda))
31
32 (define (lambda-parameters expr)
33   (car (cdr expr)))
34
35 (define (make-lambda params body)
36   (cons 'lambda (cons params body)))
37
38 ;;(lambda (x) (..)(..)...(..))
39 (define (lambda-body expr)
40   (cdr (cdr expr)))
41
42 (define (scan-out-defines body)
43   (define (internal-definition-names defs)
44     (cond
45       [(empty? defs) '()]
46       [else (cons (cadr (car defs)) (internal-definition-names (cdr defs)))]))
47   (define (internal-definition-values defs)
48     (cond
49       [(empty? defs) '()]
50       [else (cons (caddr (car defs)) (internal-definition-values (cdr defs)))]))
51   
52   ;; assumes that definitions come first in the body
53   (letrec ([get-body-internal (lambda (b)
54                                 (cond
55                                   [(empty? b) '()]
56                                   [(definition? (car b)) (get-body-internal (cdr b))]
57                                   [else (cons (car b)
58                                               (get-body-internal (cdr b)))]))]
59            [get-definitions (lambda (b)
60                               (cond
61                                 [(empty? b) '()]
62                                 [(definition? (car b)) (cons (car b) (get-definitions (cdr b)))]
63                                 [else '()]))])
64     (let ([internal-definitions (get-definitions body)])
65       (let ([def-names (internal-definition-names internal-definitions)]
66             [def-vals (internal-definition-values internal-definitions)]
67             [internal-body (get-body-internal body)])
68         (letrec ([p (lambda (name-list)
69                       (cond
70                         [(empty? name-list) '()]
71                         [else (cons (list (car name-list) ''*unassigned*)
72                                     (p (cdr name-list)))]))]
73                  [s (lambda (names vals)
74                       (cond
75                         [(empty? names) '()]
76                         [else (cons (list 'set! (car names) (car vals))
77                                     (s (cdr names) (cdr vals)))]))])
78           (cons 'let 
79                 (cons (p def-names)
80                       (append (s def-names def-vals)
81                               internal-body))))))))
82
83 ;; c
84
85 #|
86 It is better to do this change in the procedure-body so that the procedure abstractions
87 are maintained as it is. The change we are introducing is related to Scheme and hence
88 should be done at the lowest level. We should be able to replace procedure-body for another
89 language and still be able to use the same eval function.
90
91 |#
92
93 (define (procedure-body p) (scan-out-defines (caddr p)))