3 (require (rename-in racket/base
4 (apply apply-in-underlying-scheme)
5 (eval eval-in-underlying-scheme)))
7 (provide (all-defined-out))
9 (define (self-evaluating? expr)
16 (define (variable? expr) (symbol? expr))
19 (define (eval-sequence exps env)
21 [(last-exp? exps) (eval (first-exp exps) env)]
22 [else (eval (first-exp exps) env)
23 (eval-sequence (rest-exps exps) env)]))
26 (define (last-exp? seq) (null? (cdr seq)))
27 (define (first-exp seq) (car seq))
28 (define (rest-exps seq) (cdr seq))
31 (define (make-lambda parameters body)
32 (cons 'lambda (cons parameters body)))
34 ;; environment data structures
35 (define (enclosing-environment env) (cdr env))
36 (define (first-frame env) (car env))
37 (define the-empty-environment '())
39 (define (make-frame variables values)
40 (let ([ht (make-hash)])
41 (for-each (lambda (var val)
42 (hash-set! ht var val))
47 (define (frame-variables frame)
50 (define (frame-values frame)
53 (define (add-binding-to-frame! var val frame)
54 (hash-set! frame var val))
56 ;; environment is a list of frames, most recent being the last
57 ;; one consed into the list
58 (define (extend-environment vars vals base-env)
59 (let ([frame (make-frame vars vals)])
60 (cons frame base-env)))
62 (define (lookup-variable-value var env)
63 (if (eq? env the-empty-environment)
64 (error "unbound variable: " var)
65 (let ([frame (first-frame env)])
66 (let ([value (hash-ref frame var (lambda () (lookup-variable-value var (enclosing-environment env))))])
67 (if (eq? value '*unassigned*)
68 (error "evaluating a variable that is not assigned a value -- " var)
71 (define (set-variable-value! var val env)
72 (if (eq? env the-empty-environment)
73 (error "unbound variable: " var)
74 (let ([frame (first-frame env)])
75 (if (hash-has-key? frame var)
76 (hash-set! frame var val)
77 (set-variable-value! var val (enclosing-environment env))))))
79 (define (define-variable! var val env)
80 (let ([frame (first-frame env)])
81 (if (hash-has-key? frame var)
82 (hash-set! frame var val)
83 (add-binding-to-frame! var val frame))))
85 ;; primitive procedure
86 (define (primitive-implementation proc) (cadr proc))
88 (define primitive-procedures
102 (define (primitive-procedure-names)
103 (map car primitive-procedures))
105 (define (primitive-procedure-objects)
106 (map (lambda (proc) (list 'primitive (cadr proc)))
107 primitive-procedures))
109 (define (apply-primitive-procedure proc args)
110 (apply-in-underlying-scheme
111 (primitive-implementation proc) args))
114 (define (make-environment)
116 (extend-environment (primitive-procedure-names)
117 (primitive-procedure-objects)
118 the-empty-environment)))
119 (define-variable! 'true true initial-env)
120 (define-variable! 'false false initial-env)
123 (define the-global-environment (make-environment))
126 (define (list-of-values exps env)
127 (if (no-operands? exps)
129 (cons (eval (first-operand exps) env)
130 (list-of-values (rest-operands exps) env))))
132 (define (no-operands? ops) (null? ops))
133 (define (first-operand ops) (car ops))
134 (define (rest-operands ops) (cdr ops))
136 ;; compound procedure
137 (define (make-procedure params body env)
138 (list 'procedure params (scan-out-definitions body) env))
140 (define (procedure-parameters p) (cadr p))
141 (define (procedure-body p) (scan-out-definitions (caddr p)))
142 (define (procedure-environment p) (cadddr p))
144 (define (apply procedure arguments env)
146 [`(primitive ,f ...) (apply-primitive-procedure procedure (list-of-arg-values arguments env))]
147 [`(procedure ,f ...) (eval-sequence
148 (procedure-body procedure)
150 (procedure-parameters procedure)
151 (list-of-delayed-args arguments env)
152 (procedure-environment procedure)))]
153 [_ (error "Unknown procedure type -- APPLY" procedure)]))
155 (define (list-of-arg-values exps env)
156 (if (no-operands? exps)
158 (cons (actual-value (first-operand exps) env)
159 (list-of-arg-values (rest-operands exps) env))))
161 (define (list-of-delayed-args exps env)
162 (if (no-operands? exps)
164 (cons (delay-it (first-operand exps) env)
165 (list-of-delayed-args (rest-operands exps) env))))
175 (define (cond->if clauses)
176 (define (seq->exp actions)
177 (if (empty? (cdr actions))
182 (let ([clause (car clauses)])
184 [`(else ,action ...) (seq->exp action)]
185 [`(,pred ,action ...) `(if ,pred
187 ,(cond->if (cdr clauses)))]))))
190 (define (let->combination lexpr)
191 (match-let* ([`(let ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) lexpr]
192 [`((,var ,val) ...) bindings])
193 `((lambda ,var ,@body) ,@val)))
196 (define (named-let->combination lexpr)
197 (match-let* ([`(let ,(? symbol? name) ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) lexpr]
198 [`((,var ,val) ...) bindings])
199 `(begin (define ,name (lambda ,var ,@body))
203 (define (let*->nested-lets lexpr)
205 [`(let* (,first-binding ,rest-bindings ...) ,body ..1)
206 `(let (,first-binding) ,(let*->nested-lets `(let* ,rest-bindings ,@body)))]
207 [`(let* () ,body ..1) `(let () ,@body)]))
209 ;; internal definitions
210 (define (scan-out-definitions body)
212 [`((define ,var ,e) ..1 ,rest)
213 `((let ,(map (lambda (v) (list (car v) ''*unassigned*)) var)
214 ,@(map (lambda (v e) `(set! ,(car v) (lambda ,(cdr v) ,e))) var e)
219 (define (letrec->combination lexpr)
221 [`(letrec (,bindings ...) ,body ..1)
222 `(let ,(map (lambda (v) (list (car v) ''*unassigned*)) bindings)
223 ,@(map (lambda (binding)
224 (let ([name (car binding)]
225 [value (cadr binding)])
226 `(set! ,name ,value)))
231 (define (actual-value exp env)
232 (force-it (eval exp env)))
234 (define (force-it obj)
236 [`(thunk ,exp ,env) (actual-value exp env)]
239 (define (delay-it exp env)
240 (list 'thunk exp env))
243 (define (eval exp env)
244 ;; use this display statement to visualize the recursive evaluation process
245 ;;(display (format "~s~%" exp))
247 [(? self-evaluating? exp) exp]
248 [(? variable? exp) (lookup-variable-value exp env)]
250 [`(set! ,var ,val) (set-variable-value! var (eval val env) env)]
251 [`(define ,(? (lambda (x) (not (pair? x))) var) ,b) (define-variable! var (eval b env) env)]
252 [`(define ,(? pair? var) ,b ..1) (define-variable! (car var) (eval (make-lambda (cdr var) b) env) env)]
253 [`(if ,pred ,consequent ,alternative) (if (true? (actual-value pred env)) (eval consequent env) (eval alternative env))]
254 [`(unless ,condition ,consequent ,alternative) (if (true? (eval condition env)) (eval alternative env) (eval consequent env))]
255 [`(lambda ,parameters ,body ..1) (make-procedure parameters body env)]
256 [`(begin ,exp ...) (eval-sequence exp env)]
257 [`(cond ,clauses ...) (eval (cond->if clauses) env)]
258 [`(let ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) (eval (let->combination exp) env)]
259 [`(let ,(? symbol? name) ,bindings ,body ..1) (eval (named-let->combination exp) env)]
260 [`(let* ,bindings ,body ..1) (eval (let*->nested-lets exp) env)]
261 [`(letrec ,bindings ,body ..1) (eval (letrec->combination exp) env)]
262 [`(,f ,x ...) (apply (actual-value f env)
265 [_ (error "unable to evaluate expression -- EVAL " exp)]))
269 (let loop ([input (read)]
270 [env the-global-environment])
271 (let ([output (actual-value input env)])
276 (let ([t1 (current-inexact-milliseconds)])
277 (eval expr the-global-environment)
278 (displayln (- (current-inexact-milliseconds) t1))))