src/sicp/metacircular.rkt

   1 #lang racket
   2
   3 (require "ex4_8.rkt" ;; for let and named let
   4          "ex4_7.rkt")
   5
   6 ;; metacircular evaluator
   7 (define (eval exp env)
   8   (cond ((self-evaluating? exp) exp)
   9         ((variable? exp) (lookup-variable-value exp env))
  10         ((quoted? exp) (text-of-quotation exp))
  11         ((assignment? exp) (eval-assignment exp env))
  12         ((definition? exp) (eval-definition exp env))
  13         ((if? exp) (eval-if exp env))
  14         ((lambda? exp)
  15          (make-procedure (lambda-parameters exp)
  16                          (lambda-body exp)
  17                          env))
  18         ((begin? exp) (eval-sequence (begin-actions exp) env))
  19         ((cond? exp) (eval (cond->if exp) env))
  20         ((let? exp) (eval (let->combination exp) env))  ;; from ex4.8
  21         ((let*? exp) (eval (let*->nested-lets exp) env)) ;; from ex4_7
  22         ((application? exp)
  23          (apply (eval (operator exp) env)
  24                 (list-of-values (operands exp) env)))
  25         (else
  26          (error "unknown expression type -- EVAL" exp))))
  27
  28 (define (apply procedure arguments)
  29   (cond ((primitive-procedure? procedure)
  30          (apply-primitive-procedure procedure arguments))
  31         ((compound-procedure? procedure)
  32          (eval-sequence
  33           (procedure-body procedure)
  34           (extend-environment
  35            (procedure-parameters procedure)
  36            arguments
  37            (procedure-environment procedure))))
  38         (else
  39          (error "unknown procedure type -- APPLY" procedure))))
  40
  41 (define (list-of-values exps env)
  42   (if (no-operands? exps)
  43       '()
  44       (cons (eval (first-operand exps) env)
  45             (list-of-values (rest-operands exps) env))))
  46
  47 (define (eval-if exp env)
  48   (if (true? (eval (if-predicate exp) env))
  49       (eval (if-consequent exp) env)
  50       (eval (if-alternative exp) env)))
  51
  52 (define (eval-sequence exps env)
  53   (cond ((last-exp? exps)
  54          (eval (first-exp exps) env))
  55         (else
  56          (eval (first-exp exps) env)
  57          (eval-sequence (rest-exps exps) env))))
  58
  59 (define (eval-assignment exp env)
  60   (set-variable-value! (assignment-variable exp)
  61                        (eval (assignment-value exp) env)
  62                        env)
  63   'ok)
  64
  65 (define (eval-definition exp env)
  66   (define-variable! (definition-variable exp)
  67                     (eval (definition-value exp) env)
  68                     env)
  69   'ok)
  70
  71 ;; =====
  72 (define (self-evaluating? expr)
  73   (cond [(number? expr) #t]
  74         [(string? expr) #t]
  75         [else #f]))
  76
  77 (define (variable? expr)
  78   (symbol? expr))
  79
  80 ;; quotation
  81 (define (quoted? expr)
  82   (tagged-list? expr 'quote))
  83
  84 (define (tagged-list? expr tag)
  85   (or (pair? expr) (eq? (car expr) tag)))
  86
  87 (define (text-of-quotation expr)
  88   (car (cdr expr)))
  89
  90 ;; assignment
  91 (define (assignment? expr)
  92   (tagged-list? expr 'set!))
  93
  94 (define (assignment-variable expr)
  95   (car (cdr expr)))
  96
  97 (define (assignment-value expr)
  98   (car (cdr (cdr expr))))
  99
 100 ;; define
 101 (define (definition? expr)
 102   (tagged-list? expr 'define))
 103
 104 (define (definition-variable expr)
 105   (if (symbol? (car (cdr expr))) ;; (define foo 42)
 106       (car (cdr expr))
 107       ;; (define (foo x) (....))
 108       (car (car (cdr expr)))))
 109
 110 (define (definition-value expr)
 111   ;; (define foo 42)
 112   (if (symbol? (car (cdr expr)))
 113       (car (cdr (cdr expr)))
 114       ;; (define (foo x) (....))
 115       (make-lambda (cdr (car (cdr expr))) ;; gives (x)
 116                    (cdr (cdr expr)))))    ;; body
 117
 118 ;; lambda
 119 (define (lambda? expr)
 120   (tagged-list? expr 'lambda))
 121
 122 (define (lambda-parameters expr)
 123   (car (cdr expr)))
 124
 125 ;;(lambda (x) (..)(..)...(..))
 126 (define (lambda-body expr)
 127   (cdr (cdr expr)))
 128
 129 (define (make-lambda params body)
 130   (cons 'lambda (cons params body)))
 131
 132 ;; if
 133 (define (if? exp) (tagged-list? exp 'if))
 134 (define (if-predicate expr) (car (cdr expr)))
 135 (define (if-consequent expr) (car (cdr (cdr expr))))
 136 (define (if-alternative expr)
 137   (if (not (null? (cdr (cdr (cdr expr)))))
 138       (car (cdr (cdr (cdr expr))))
 139       'false))
 140
 141 (define (make-if predicate consequent alternative)
 142   (list 'if predicate consequent alternative))
 143
 144 ;; begin
 145 (define (begin? exp) (tagged-list? exp 'begin))
 146 (define (begin-actions exp) (cdr exp))
 147 (define (last-exp? seq) (null? (cdr seq)))
 148 (define (first-exp seq) (car seq))
 149 (define (rest-exp seq) (cdr seq))
 150
 151 (define (sequence->exp seq)
 152   (cond ((null? seq) seq)
 153         ((last-exp? seq) (first-exp seq))
 154         (else (make-begin seq))))
 155 (define (make-begin seq) (cons 'begin seq))
 156
 157 ;; procedure application
 158 (define (application? exp) (pair? exp))
 159 (define (operator exp) (car exp))
 160 (define (operands exp) (cdr exp))
 161 (define (no-operands? ops) (null? ops))
 162 (define (first-operand ops) (car ops))
 163 (define (rest-operands ops) (cdr ops))
 164
 165 ;; expander for `cond' expressions to be transformed into `if' expressions
 166 (define (cond? exp) (tagged-list? exp 'cond))
 167 (define (cond-clauses exp) (cdr exp))
 168 (define (cond-else-clause? clause)
 169   (eq? (cond-predicate clause) 'else))
 170 (define (cond-predicate clause) (car clause))
 171 (define (cond-actions clause) (cdr clause))
 172 (define (cond->if exp)
 173   (expand-clauses (cond-clauses exp)))
 174
 175 (define (expand-clauses clauses)
 176   (if (null? clauses)
 177       'false                          ; no else clause
 178       (let ((first (car clauses))
 179             (rest (cdr clauses)))
 180         (if (cond-else-clause? first)
 181             (if (null? rest)
 182                 (sequence->exp (cond-actions first))
 183                 (error "ELSE clause isn't last -- COND->IF"
 184                        clauses))
 185             (make-if (cond-predicate first)
 186                      (sequence->exp (cond-actions first))
 187                      (expand-clauses rest))))))
 188
 189 ;; true and false
 190 (define (true? x)
 191   (not (eq? x false)))
 192
 193 (define (false? x)
 194   (eq? x false))
 195
 196 ;; procedures
 197 (define (make-procedure parameters body env)
 198   (list 'procedure parameters body env))
 199
 200 (define (compound-procedure? p)
 201   (tagged-list? p 'procedure))
 202
 203 (define (procedure-parameters p) (cadr p))
 204 (define (procedure-body p) (caddr p))
 205 (define (procedure-env p) (cadddr p))
 206
 207 ;; operations on environment
 208 (define (enclosing-environment env) (cdr env))
 209 (define (first-frame env) (car env))
 210 (define the-empty-environment '())
 211
 212 ;; frame operations
 213 (define (make-frame variables values)
 214   (cons variables values))
 215
 216 (define (frame-variables frame) (car frame))
 217 (define (frame-values frame) (cdr frame))
 218 (define (add-bindings-to-frame! var val frame)
 219   (set-car! frame (cons var (frame-variables frame)))
 220   (set-cdr! frame (cons val (frame-values frame))))
 221
 222 (define (extend-environment vars vals base-env)
 223   (if (= (length vars) (length vals))
 224       (cons (make-frame vars vals) base-env)
 225       (if (< (length vars) (length vals))
 226           (error "Too many args supplied" vars vals)
 227           (error "Too many args supplied" vars vals))))
 228
 229 (define (lookup-variable-value var env)
 230   (define (env-loop env)
 231     (define (scan vars vals)
 232       (cond [(null? vars)
 233              (env-loop (enclosing-environment env))]
 234             [(eq? var (car vars))
 235              (car vals)]
 236             [else (scan (cdr vars) (cdr vals))]))
 237     (if (eq? env the-empty-environment)
 238         (error "unbound variable" var)
 239         (let ([frame (first-frame env)])
 240           (scan (frame-variables frame)
 241                 (frame-values frame)))))
 242   (env-loop env))
 243
 244 (define (set-variable-value! var val env)
 245   (define (env-loop env)
 246     (define (scan vars vals)
 247       (cond [(null? vars)
 248              (env-loop (enclosing-environment env))]
 249             [(eq? var (car vars))
 250              (set-car! vals val)]
 251             [else (scan (cdr vars) (cdr vals))]))
 252     (if (eq? env the-empty-environment)
 253         (error "unbound variable" var)
 254         (let ([frame (first-frame env)])
 255           (scan (frame-variables frame)
 256                 (frame-values frame)))))
 257   (env-loop env))
 258
 259 (define (define-variable! var val env)
 260   (let ([frame (first-frame env)])
 261     (define (scan vars vals)
 262       (cond [(null? vars)
 263              (add-bindings-to-frame! var val frame)]
 264             [(eq? var (car vars))
 265              (set-car! vals val)]
 266             [else (scan (cdr vars) (cdr vals))]))
 267     (scan (frame-variables frame)
 268           (frame-values frame))))
 269