src/sicp/metacircular2.rkt

   1 #lang racket
   2
   3 (require (rename-in racket/base
   4                     (apply apply-in-underlying-scheme)
   5                     (eval eval-in-underlying-scheme)))
   6
   7 (define (self-evaluating? expr)
   8   (match expr
   9     [(? number? expr) #t]
  10     [(? char? expr) #t]
  11     [(? string? expr) #t]
  12     [_ #f]))
  13
  14 (define (variable? expr) (symbol? expr))
  15
  16
  17 ;; sequence
  18 (define (eval-sequence exps env)
  19   (cond ((last-exp? exps) (eval (first-exp exps) env))
  20         (else (eval (first-exp exps) env)
  21               (eval-sequence (rest-exps exps) env))))
  22
  23 ;; begin
  24 (define (last-exp? seq) (null? (cdr seq)))
  25 (define (first-exp seq) (car seq))
  26 (define (rest-exps seq) (cdr seq))
  27
  28 ;; lambda
  29 (define (make-lambda parameters body)
  30   (cons 'lambda (cons parameters body)))
  31
  32 ;; environment data structures
  33 (define (enclosing-environment env) (cdr env))
  34 (define (first-frame env) (car env))
  35 (define the-empty-environment '())
  36
  37 (define (make-frame variables values)
  38   (let ([ht (make-hash)])
  39     (for-each (lambda (var val)
  40                 (hash-set! ht var val))
  41               variables
  42               values)
  43     ht))
  44
  45 (define (frame-variables frame)
  46   (hash-keys frame))
  47
  48 (define (frame-values frame)
  49   (hash-values frame))
  50
  51 (define (add-binding-to-frame! var val frame)
  52   (hash-set! frame var val))
  53
  54 ;; environment is a list of frames, most recent being the last
  55 ;; one consed into the list
  56 (define (extend-environment vars vals base-env)
  57   (let ([frame (make-frame vars vals)])
  58     (cons frame base-env)))
  59
  60 (define (lookup-variable-value var env)
  61   (if (eq? env the-empty-environment)
  62       (error "unbound variable:" var)
  63       (let ([frame (first-frame env)])
  64         (hash-ref frame var (lambda () (lookup-variable-value var (enclosing-environment env)))))))
  65
  66 (define (set-variable-value! var val env)
  67   (if (eq? env the-empty-environment)
  68       (error "unbound variable")
  69       (let ([frame (first-frame env)])
  70         (if (hash-has-key? frame var)
  71             (hash-set! frame var val)
  72             (set-variable-value! var val (enclosing-environment env))))))
  73
  74 (define (define-variable! var val env)
  75   (let ([frame (first-frame env)])
  76     (if (hash-has-key? frame var)
  77         (hash-set! frame var val)
  78         (add-binding-to-frame! var val frame))))
  79
  80 ;; primitive procedure
  81 (define (primitive-implementation proc) (cadr proc))
  82
  83 (define primitive-procedures
  84   (list (list 'car car)
  85         (list 'cdr cdr)
  86         (list 'cons cons)
  87         (list 'null? null?)
  88         (list 'list list)
  89         (list '+ +)
  90         (list '- -)
  91         (list '* *)
  92         (list '/ /)
  93         (list '= =)))
  94
  95 (define (primitive-procedure-names)
  96   (map car primitive-procedures))
  97
  98 (define (primitive-procedure-objects)
  99   (map (lambda (proc) (list 'primitive (cadr proc)))
 100        primitive-procedures))
 101
 102 (define (apply-primitive-procedure proc args)
 103   (apply-in-underlying-scheme
 104    (primitive-implementation proc) args))
 105
 106 ;; global env
 107 (define (setup-environment)
 108   (let ((initial-env
 109          (extend-environment (primitive-procedure-names)
 110                              (primitive-procedure-objects)
 111                              the-empty-environment)))
 112     (define-variable! 'true true initial-env)
 113     (define-variable! 'false false initial-env)
 114     initial-env))
 115
 116 (define the-global-environment (setup-environment))
 117
 118 ;; application
 119 (define (list-of-values exps env)
 120   (if (no-operands? exps)
 121       '()
 122       (cons (eval (first-operand exps) env)
 123             (list-of-values (rest-operands exps) env))))
 124
 125 (define (no-operands? ops) (null? ops))
 126 (define (first-operand ops) (car ops))
 127 (define (rest-operands ops) (cdr ops))
 128
 129 ;; compound procedure
 130 (define (make-procedure params body env)
 131   (list 'procedure params (scan-out-definitions body) env))
 132
 133 (define (procedure-parameters p) (cadr p))
 134 (define (procedure-body p) (scan-out-definitions (caddr p)))
 135 (define (procedure-environment p) (cadddr p))
 136
 137 (define (apply procedure arguments)
 138   (match procedure
 139     [`(primitive ,f ...)  (apply-primitive-procedure procedure arguments)]
 140     [`(procedure ,f ...)  (eval-sequence
 141                        (procedure-body procedure)
 142                        (extend-environment
 143                         (procedure-parameters procedure)
 144                         arguments
 145                         (procedure-environment procedure)))]
 146     [_                (error "Unknown procedure type -- APPLY" procedure)]))
 147
 148 ;; truth
 149 (define (true? x)
 150   (not (eq? x false)))
 151
 152 (define (false? x)
 153   (eq? x false))
 154
 155 ;; cond
 156 (define (cond->if clauses)
 157   (define (seq->exp actions)
 158     (if (empty? (cdr actions))
 159         (car actions)
 160         `(begin ,@actions)))
 161   (if (empty? clauses)
 162       'false
 163       (let ([clause (car clauses)])
 164         (match clause
 165           [`(else ,action ...) (seq->exp action)]
 166           [`(,pred ,action ...) `(if ,pred
 167                                      ,(seq->exp action)
 168                                      ,(cond->if (cdr clauses)))]))))
 169
 170 ;; let
 171 (define (let->combination lexpr)
 172   (match-let* ([`(let ,bindings ,body ..1) lexpr]
 173                [`((,var ,val) ...) bindings])
 174     `((lambda ,var ,@body) ,@val)))
 175
 176 ;; let*
 177 (define (let*->nested-lets lexpr)
 178   (match lexpr
 179     [`(let* (,first-binding ,rest-bindings ...) ,body ..1)
 180      `(let (,first-binding) ,(let*->nested-lets `(let* ,rest-bindings ,@body)))]
 181      [`(let* () ,body ..1) `(let () ,@body)]))
 182
 183 ;; internal definitions
 184 (define (scan-out-definitions body)
 185   (match body
 186     [`((define ,var ,e) ..1 ,rest)
 187      `((let ,(map (lambda (v) (list (car v) ''*unassigned*)) var)
 188         ,@(map (lambda (v e) `(set! ,(car v) (lambda ,(cdr v) ,e))) var e)
 189         ,rest))]
 190     [_  body]))
 191
 192 ;; eval
 193 (define (eval exp env)
 194   (display (format "~s~%" exp))
 195   (match exp
 196     [(? self-evaluating? exp) exp]
 197     [(? variable? exp) (lookup-variable-value exp env)]
 198     [`(quote ,x) x]
 199     [`(set! ,var ,val) (set-variable-value! var (eval val env) env)]
 200     [`(define ,(? (lambda (x) (not (pair? x))) var) ,b) (define-variable! var (eval b env) env)]
 201     [`(define ,(? pair? var) ,b ..1) (define-variable! (car var) (eval (make-lambda (cdr var) b) env) env)]
 202     [`(if ,pred ,consequent ,alternative) (if (true? (eval pred env)) (eval consequent env) (eval alternative env))]
 203     [`(lambda ,parameters ,body ..1) (make-procedure parameters body env)]
 204     [`(begin ,exp ...) (eval-sequence exp env)]
 205     [`(cond ,clauses ...) (eval (cond->if clauses) env)]
 206     [`(let ,bindings ,body ..1) (eval (let->combination exp) env)]
 207     [`(let* ,bindings ,body ..1) (eval (let*->nested-lets exp) env)]
 208     [(list f x ...) (apply (eval f env) (list-of-values x env))]
 209     [_ (error "unable to evaluate expression -- EVAL " exp)]))
 210
 211
 212 (define (interpret)
 213   (let loop ([input (read)]
 214              [env the-global-environment])
 215     (let ([output (eval input env)])
 216       (display output)
 217       (loop (read) env))))
 218
 219 (define (t expr)
 220   (let ([t1 (current-inexact-milliseconds)])
 221     (eval expr the-global-environment)
 222     (displayln (- (current-inexact-milliseconds) t1))))