src/sicp/metacircular.rkt

   1 #lang racket
   2
   3 ;; metacircular evaluator
   4 (define (eval exp env)
   5   (cond ((self-evaluating? exp) exp)
   6         ((variable? exp) (lookup-variable-value exp env))
   7         ((quoted? exp) (text-of-quotation exp))
   8         ((assignment? exp) (eval-assignment exp env))
   9         ((definition? exp) (eval-definition exp env))
  10         ((if? exp) (eval-if exp env))
  11         ((lambda? exp)
  12          (make-procedure (lambda-parameters exp)
  13                          (lambda-body exp)
  14                          env))
  15         ((begin? exp) (eval-sequence (begin-actions exp) env))
  16         ((cond? exp) (eval (cond->if exp) env))
  17         ((application? exp)
  18          (apply (eval (operator exp) env)
  19                 (list-of-values (operands exp) env)))
  20         (else
  21          (error "unknown expression type -- EVAL" exp))))
  22
  23 (define (apply procedure arguments)
  24   (cond ((primitive-procedure? procedure)
  25          (apply-primitive-procedure procedure arguments))
  26         ((compound-procedure? procedure)
  27          (eval-sequence
  28           (procedure-body procedure)
  29           (extend-environment
  30            (procedure-parameters procedure)
  31            arguments
  32            (procedure-environment procedure))))
  33         (else
  34          (error "unknown procedure type -- APPLY" procedure))))
  35
  36 (define (list-of-values exps env)
  37   (if (no-operands? exps)
  38       '()
  39       (cons (eval (first-operand exps) env)
  40             (list-of-values (rest-operands exps) env))))
  41
  42 (define (eval-if exp env)
  43   (if (true? (eval (if-predicate exp) env))
  44       (eval (if-consequent exp) env)
  45       (eval (if-alternative exp) env)))
  46
  47 (define (eval-sequence exps env)
  48   (cond ((last-exp? exps)
  49          (eval (first-exp exps) env))
  50         (else
  51          (eval (first-exp exps) env)
  52          (eval-sequence (rest-exps exps) env))))
  53
  54 (define (eval-assignment exp env)
  55   (set-variable-value! (assignment-variable exp)
  56                        (eval (assignment-value exp) env)
  57                        env)
  58   'ok)
  59
  60 (define (eval-definition exp env)
  61   (define-variable! (definition-variable exp)
  62                     (eval (definition-value exp) env)
  63                     env)
  64   'ok)
  65
  66 ;; =====
  67 (define (self-evaluating? expr)
  68   (cond [(number? expr) #t]
  69         [(string? expr) #t]
  70         [else #f]))
  71
  72 (define (variable? expr)
  73   (symbol? expr))
  74
  75 ;; quotation
  76 (define (quoted? expr)
  77   (tagged-list? expr 'quote))
  78
  79 (define (tagged-list? expr tag)
  80   (or (pair? expr) (eq? (car expr) tag)))
  81
  82 (define (text-of-quotation expr)
  83   (car (cdr expr)))
  84
  85 ;; assignment
  86 (define (assignment? expr)
  87   (tagged-list? expr 'set!))
  88
  89 (define (assignment-variable expr)
  90   (car (cdr expr)))
  91
  92 (define (assignment-value expr)
  93   (car (cdr (cdr expr))))
  94
  95 ;; define
  96 (define (definition? expr)
  97   (tagged-list? expr 'define))
  98
  99 (define (definition-variable expr)
 100   (if (symbol? (car (cdr expr))) ;; (define foo 42)
 101       (car (cdr expr))
 102       ;; (define (foo x) (....))
 103       (car (car (cdr expr)))))
 104
 105 (define (definition-value expr)
 106   ;; (define foo 42)
 107   (if (symbol? (car (cdr expr)))
 108       (car (cdr (cdr expr)))
 109       ;; (define (foo x) (....))
 110       (make-lambda (cdr (car (cdr expr))) ;; gives (x)
 111                    (cdr (cdr expr)))))    ;; body
 112
 113 ;; lambda
 114 (define (lambda? expr)
 115   (tagged-list? expr 'lambda))
 116
 117 (define (lambda-parameters expr)
 118   (car (cdr expr)))
 119
 120 ;;(lambda (x) (..)(..)...(..))
 121 (define (lambda-body expr)
 122   (cdr (cdr expr)))
 123
 124 (define (make-lambda params body)
 125   (cons 'lambda (cons params body)))
 126
 127 ;; if
 128 (define (if? exp) (tagged-list? exp 'if))
 129 (define (if-predicate expr) (car (cdr expr)))
 130 (define (if-consequent expr) (car (cdr (cdr expr))))
 131 (define (if-alternative expr)
 132   (if (not (null? (cdr (cdr (cdr expr)))))
 133       (car (cdr (cdr (cdr expr))))
 134       'false))
 135
 136 (define (make-if predicate consequent alternative)
 137   (list 'if predicate consequent alternative))
 138
 139 ;; begin
 140 (define (begin? exp) (tagged-list? exp 'begin))
 141 (define (begin-actions exp) (cdr exp))
 142 (define (last-exp? seq) (null? (cdr seq)))
 143 (define (first-exp seq) (car seq))
 144 (define (rest-exp seq) (cdr seq))
 145
 146 (define (sequence->exp seq)
 147   (cond ((null? seq) seq)
 148         ((last-exp? seq) (first-exp seq))
 149         (else (make-begin seq))))
 150 (define (make-begin seq) (cons 'begin seq))
 151
 152 ;; procedure application
 153 (define (application? exp) (pair? exp))
 154 (define (operator exp) (car exp))
 155 (define (operands exp) (cdr exp))
 156 (define (no-operands? ops) (null? ops))
 157 (define (first-operand ops) (car ops))
 158 (define (rest-operands ops) (cdr ops))
 159
 160 ;; expander for `cond' expressions to be transformed into `if' expressions
 161 (define (cond? exp) (tagged-list? exp 'cond))
 162 (define (cond-clauses exp) (cdr exp))
 163 (define (cond-else-clause? clause)
 164   (eq? (cond-predicate clause) 'else))
 165 (define (cond-predicate clause) (car clause))
 166 (define (cond-actions clause) (cdr clause))
 167 (define (cond->if exp)
 168   (expand-clauses (cond-clauses exp)))
 169
 170 (define (expand-clauses clauses)
 171   (if (null? clauses)
 172       'false                          ; no else clause
 173       (let ((first (car clauses))
 174             (rest (cdr clauses)))
 175         (if (cond-else-clause? first)
 176             (if (null? rest)
 177                 (sequence->exp (cond-actions first))
 178                 (error "ELSE clause isn't last -- COND->IF"
 179                        clauses))
 180             (make-if (cond-predicate first)
 181                      (sequence->exp (cond-actions first))
 182                      (expand-clauses rest))))))