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)))