src/sicp/metacircular.rkt

   1 #lang planet neil/sicp
   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 ;; capture the underlying apply before redefining it
  29 (define apply-in-underlying-scheme apply)
  30
  31 (define (apply procedure arguments)
  32   (cond ((primitive-procedure? procedure)
  33          (apply-primitive-procedure procedure arguments))
  34         ((compound-procedure? procedure)
  35          (eval-sequence
  36           (procedure-body procedure)
  37           (extend-environment
  38            (procedure-parameters procedure)
  39            arguments
  40            (procedure-environment procedure))))
  41         (else
  42          (error "unknown procedure type -- APPLY" procedure))))
  43
  44 (define (list-of-values exps env)
  45   (if (no-operands? exps)
  46       '()
  47       (cons (eval (first-operand exps) env)
  48             (list-of-values (rest-operands exps) env))))
  49
  50 (define (eval-if exp env)
  51   (if (true? (eval (if-predicate exp) env))
  52       (eval (if-consequent exp) env)
  53       (eval (if-alternative exp) env)))
  54
  55 (define (eval-sequence exps env)
  56   (cond ((last-exp? exps)
  57          (eval (first-exp exps) env))
  58         (else
  59          (eval (first-exp exps) env)
  60          (eval-sequence (rest-exps exps) env))))
  61
  62 (define (eval-assignment exp env)
  63   (set-variable-value! (assignment-variable exp)
  64                        (eval (assignment-value exp) env)
  65                        env)
  66   'ok)
  67
  68 (define (eval-definition exp env)
  69   (define-variable! (definition-variable exp)
  70                     (eval (definition-value exp) env)
  71                     env)
  72   'ok)
  73
  74 ;; =====
  75 (define (self-evaluating? expr)
  76   (cond [(number? expr) #t]
  77         [(string? expr) #t]
  78         [else #f]))
  79
  80 (define (variable? expr)
  81   (symbol? expr))
  82
  83 ;; quotation
  84 (define (quoted? expr)
  85   (tagged-list? expr 'quote))
  86
  87 (define (tagged-list? expr tag)
  88   (or (pair? expr) (eq? (car expr) tag)))
  89
  90 (define (text-of-quotation expr)
  91   (car (cdr expr)))
  92
  93 ;; assignment
  94 (define (assignment? expr)
  95   (tagged-list? expr 'set!))
  96
  97 (define (assignment-variable expr)
  98   (car (cdr expr)))
  99
 100 (define (assignment-value expr)
 101   (car (cdr (cdr expr))))
 102
 103 ;; define
 104 (define (definition? expr)
 105   (tagged-list? expr 'define))
 106
 107 (define (definition-variable expr)
 108   (if (symbol? (car (cdr expr))) ;; (define foo 42)
 109       (car (cdr expr))
 110       ;; (define (foo x) (....))
 111       (car (car (cdr expr)))))
 112
 113 (define (definition-value expr)
 114   ;; (define foo 42)
 115   (if (symbol? (car (cdr expr)))
 116       (car (cdr (cdr expr)))
 117       ;; (define (foo x) (....))
 118       (make-lambda (cdr (car (cdr expr))) ;; gives (x)
 119                    (cdr (cdr expr)))))    ;; body
 120
 121 ;; lambda
 122 (define (lambda? expr)
 123   (tagged-list? expr 'lambda))
 124
 125 (define (lambda-parameters expr)
 126   (car (cdr expr)))
 127
 128 ;;(lambda (x) (..)(..)...(..))
 129 (define (lambda-body expr)
 130   (cdr (cdr expr)))
 131
 132 (define (make-lambda params body)
 133   (cons 'lambda (cons params body)))
 134
 135 ;; if
 136 (define (if? exp) (tagged-list? exp 'if))
 137 (define (if-predicate expr) (car (cdr expr)))
 138 (define (if-consequent expr) (car (cdr (cdr expr))))
 139 (define (if-alternative expr)
 140   (if (not (null? (cdr (cdr (cdr expr)))))
 141       (car (cdr (cdr (cdr expr))))
 142       'false))
 143
 144 (define (make-if predicate consequent alternative)
 145   (list 'if predicate consequent alternative))
 146
 147 ;; begin
 148 (define (begin? exp) (tagged-list? exp 'begin))
 149 (define (begin-actions exp) (cdr exp))
 150 (define (last-exp? seq) (null? (cdr seq)))
 151 (define (first-exp seq) (car seq))
 152 (define (rest-exps seq) (cdr seq))
 153
 154 (define (sequence->exp seq)
 155   (cond ((null? seq) seq)
 156         ((last-exp? seq) (first-exp seq))
 157         (else (make-begin seq))))
 158 (define (make-begin seq) (cons 'begin seq))
 159
 160 ;; procedure application
 161 (define (application? exp) (pair? exp))
 162 (define (operator exp) (car exp))
 163 (define (operands exp) (cdr exp))
 164 (define (no-operands? ops) (null? ops))
 165 (define (first-operand ops) (car ops))
 166 (define (rest-operands ops) (cdr ops))
 167
 168 ;; expander for `cond' expressions to be transformed into `if' expressions
 169 (define (cond? exp) (tagged-list? exp 'cond))
 170 (define (cond-clauses exp) (cdr exp))
 171 (define (cond-else-clause? clause)
 172   (eq? (cond-predicate clause) 'else))
 173 (define (cond-predicate clause) (car clause))
 174 (define (cond-actions clause) (cdr clause))
 175 (define (cond->if exp)
 176   (expand-clauses (cond-clauses exp)))
 177
 178 (define (expand-clauses clauses)
 179   (if (null? clauses)
 180       'false                          ; no else clause
 181       (let ((first (car clauses))
 182             (rest (cdr clauses)))
 183         (if (cond-else-clause? first)
 184             (if (null? rest)
 185                 (sequence->exp (cond-actions first))
 186                 (error "ELSE clause isn't last -- COND->IF"
 187                        clauses))
 188             (make-if (cond-predicate first)
 189                      (sequence->exp (cond-actions first))
 190                      (expand-clauses rest))))))
 191
 192 ;; true and false
 193 (define (true? x)
 194   (not (eq? x false)))
 195
 196 (define (false? x)
 197   (eq? x false))
 198
 199 ;; procedures
 200 (define (make-procedure parameters body env)
 201   (list 'procedure parameters body env))
 202
 203 (define (compound-procedure? p)
 204   (tagged-list? p 'procedure))
 205
 206 (define (procedure-parameters p) (cadr p))
 207 (define (procedure-body p) (caddr p))
 208 (define (procedure-environment p) (cadddr p))
 209
 210 ;; operations on environment
 211 (define (enclosing-environment env) (cdr env))
 212 (define (first-frame env) (car env))
 213 (define the-empty-environment '())
 214
 215 ;; frame operations
 216 (define (make-frame variables values)
 217   (cons variables values))
 218
 219 (define (frame-variables frame) (car frame))
 220 (define (frame-values frame) (cdr frame))
 221 (define (add-bindings-to-frame! var val frame)
 222   (set-car! frame (cons var (frame-variables frame)))
 223   (set-cdr! frame (cons val (frame-values frame))))
 224
 225 (define (extend-environment vars vals base-env)
 226   (if (= (length vars) (length vals))
 227       (cons (make-frame vars vals) base-env)
 228       (if (< (length vars) (length vals))
 229           (error "Too many args supplied" vars vals)
 230           (error "Too many args supplied" vars vals))))
 231
 232 (define (lookup-variable-value var env)
 233   (define (env-loop env)
 234     (define (scan vars vals)
 235       (cond [(null? vars)
 236              (env-loop (enclosing-environment env))]
 237             [(eq? var (car vars))
 238              (car vals)]
 239             [else (scan (cdr vars) (cdr vals))]))
 240     (if (eq? env the-empty-environment)
 241         (error "unbound variable" var)
 242         (let ([frame (first-frame env)])
 243           (scan (frame-variables frame)
 244                 (frame-values frame)))))
 245   (env-loop env))
 246
 247 (define (set-variable-value! var val env)
 248   (define (env-loop env)
 249     (define (scan vars vals)
 250       (cond [(null? vars)
 251              (env-loop (enclosing-environment env))]
 252             [(eq? var (car vars))
 253              (set-car! vals val)]
 254             [else (scan (cdr vars) (cdr vals))]))
 255     (if (eq? env the-empty-environment)
 256         (error "unbound variable" var)
 257         (let ([frame (first-frame env)])
 258           (scan (frame-variables frame)
 259                 (frame-values frame)))))
 260   (env-loop env))
 261
 262 (define (define-variable! var val env)
 263   (let ([frame (first-frame env)])
 264     (define (scan vars vals)
 265       (cond [(null? vars)
 266              (add-bindings-to-frame! var val frame)]
 267             [(eq? var (car vars))
 268              (set-car! vals val)]
 269             [else (scan (cdr vars) (cdr vals))]))
 270     (scan (frame-variables frame)
 271           (frame-values frame))))
 272
 273
 274 ;; primitive procedures
 275 (define (primitive-procedure? proc)
 276   (tagged-list? proc 'primitive))
 277
 278 (define (primitive-implementation proc) (cadr proc))
 279
 280 (define primitive-procedures
 281   (list (list 'car car)
 282         (list 'cdr cdr)
 283         (list 'cons cons)
 284         (list 'null? null?)
 285         (list '+ +)
 286         (list '- -)
 287         (list '= =)))
 288
 289 (define (primitive-procedure-names)
 290   (map car primitive-procedures))
 291
 292 (define (primitive-procedure-objects)
 293   (map (lambda (proc) (list 'primitive (cadr proc)))
 294        primitive-procedures))
 295
 296 ;; apply from implementation language
 297 (define (apply-primitive-procedure proc args)
 298   (apply-in-underlying-scheme
 299    (primitive-implementation proc) args))
 300
 301 ;; setting up the environment
 302 (define (setup-environment)
 303   (let ((initial-env
 304          (extend-environment (primitive-procedure-names)
 305                              (primitive-procedure-objects)
 306                              the-empty-environment)))
 307     (define-variable! 'true #t initial-env)
 308     (define-variable! 'false #f initial-env)
 309     initial-env))
 310
 311 (define the-global-environment (setup-environment))
 312
 313