Library functioning using new quasiquote.
[scheme.forth.jl.git] / examples / metacirc.scm
1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;; Mandatory SICP Metacircular Evaluator ;;
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4
5 ;; To use, simply (load "metacirc.scm") and run the (driver-loop) command.
6
7 (define apply-in-underlying-scheme apply)
8 (define true #t)
9 (define false #f)
10
11 ;; Verbatim code from SICP
12
13 (define (eval exp env)
14   (cond ((self-evaluating? exp) 
15          exp)
16         ((variable? exp) 
17          (lookup-variable-value exp env))
18         ((quoted? exp) 
19          (text-of-quotation exp))
20         ((assignment? exp) 
21          (eval-assignment exp env))
22         ((definition? exp) 
23          (eval-definition exp env))
24         ((if? exp) 
25          (eval-if exp env))
26         ((lambda? exp)
27          (make-procedure 
28            (lambda-parameters exp)
29            (lambda-body exp)
30            env))
31         ((begin? exp)
32          (eval-sequence 
33            (begin-actions exp) 
34            env))
35         ((cond? exp) 
36          (eval (cond->if exp) env))
37         ((application? exp)
38          (apply (eval (operator exp) env)
39                 (list-of-values 
40                   (operands exp) 
41                   env)))
42         (else
43           (error "Unknown expression type: EVAL" exp))))
44
45 (define (apply procedure arguments)
46   (cond ((primitive-procedure? procedure)
47          (apply-primitive-procedure 
48            procedure 
49            arguments))
50         ((compound-procedure? procedure)
51          (eval-sequence
52            (procedure-body procedure)
53            (extend-environment
54              (procedure-parameters 
55                procedure)
56              arguments
57              (procedure-environment 
58                procedure))))
59         (else
60           (error "Unknown procedure type: APPLY" 
61                  procedure))))
62
63 (define (list-of-values exps env)
64   (if (no-operands? exps)
65     '()
66     (cons (eval (first-operand exps) env)
67           (list-of-values 
68             (rest-operands exps) 
69             env))))
70
71 (define (eval-if exp env)
72   (if (true? (eval (if-predicate exp) env))
73     (eval (if-consequent exp) env)
74     (eval (if-alternative exp) env)))
75
76 (define (eval-sequence exps env)
77   (cond ((last-exp? exps) 
78          (eval (first-exp exps) env))
79         (else 
80           (eval (first-exp exps) env)
81           (eval-sequence (rest-exps exps) 
82                          env))))
83
84 (define (eval-assignment exp env)
85   (set-variable-value! 
86     (assignment-variable exp)
87     (eval (assignment-value exp) env)
88     env)
89   'ok)
90
91 (define (eval-definition exp env)
92   (define-variable! 
93     (definition-variable exp)
94     (eval (definition-value exp) env)
95     env)
96   'ok)
97
98 (define (self-evaluating? exp)
99   (cond ((number? exp) true)
100         ((string? exp) true)
101         (else false)))
102
103 (define (variable? exp) (symbol? exp))
104
105 (define (quoted? exp)
106   (tagged-list? exp 'quote))
107
108 (define (text-of-quotation exp)
109   (cadr exp))
110
111 (define (tagged-list? exp tag)
112   (if (pair? exp)
113     (eq? (car exp) tag)
114     false))
115
116 (define (assignment? exp)
117   (tagged-list? exp 'set!))
118
119 (define (assignment-variable exp) 
120   (cadr exp))
121
122 (define (assignment-value exp) (caddr exp))
123
124 (define (definition? exp)
125   (tagged-list? exp 'define))
126
127 (define (definition-variable exp)
128   (if (symbol? (cadr exp))
129     (cadr exp)
130     (caadr exp)))
131
132 (define (definition-value exp)
133   (if (symbol? (cadr exp))
134     (caddr exp)
135     (make-lambda 
136       (cdadr exp)   ; formal parameters
137       (cddr exp)))) ; body
138
139
140 (define (lambda? exp) 
141   (tagged-list? exp 'lambda))
142 (define (lambda-parameters exp) (cadr exp))
143 (define (lambda-body exp) (cddr exp))
144
145 (define (make-lambda parameters body)
146     (cons 'lambda (cons parameters body)))
147
148 (define (if? exp) (tagged-list? exp 'if))
149 (define (if-predicate exp) (cadr exp))
150 (define (if-consequent exp) (caddr exp))
151 (define (if-alternative exp)
152   (if (not (null? (cdddr exp)))
153     (cadddr exp)
154     'false))
155
156 (define (make-if predicate 
157                  consequent 
158                  alternative)
159   (list 'if 
160         predicate 
161         consequent 
162         alternative))
163
164 (define (begin? exp) 
165   (tagged-list? exp 'begin))
166 (define (begin-actions exp) (cdr exp))
167 (define (last-exp? seq) (null? (cdr seq)))
168 (define (first-exp seq) (car seq))
169 (define (rest-exps seq) (cdr seq))
170
171 (define (sequence->exp seq)
172   (cond ((null? seq) seq)
173         ((last-exp? seq) (first-exp seq))
174         (else (make-begin seq))))
175
176 (define (make-begin seq) (cons 'begin seq))
177
178 (define (application? exp) (pair? exp))
179 (define (operator exp) (car exp))
180 (define (operands exp) (cdr exp))
181 (define (no-operands? ops) (null? ops))
182 (define (first-operand ops) (car ops))
183 (define (rest-operands ops) (cdr ops))
184
185
186 (define (cond? exp) 
187   (tagged-list? exp 'cond))
188 (define (cond-clauses exp) (cdr exp))
189 (define (cond-else-clause? clause)
190   (eq? (cond-predicate clause) 'else))
191 (define (cond-predicate clause) 
192   (car clause))
193 (define (cond-actions clause) 
194   (cdr clause))
195 (define (cond->if exp)
196   (expand-clauses (cond-clauses exp)))
197 (define (expand-clauses clauses)
198   (if (null? clauses)
199     'false     ; no else clause
200     (let ((first (car clauses))
201           (rest (cdr clauses)))
202       (if (cond-else-clause? first)
203         (if (null? rest)
204           (sequence->exp 
205             (cond-actions first))
206           (error "ELSE clause isn't last: COND->IF"
207           clauses))
208       (make-if (cond-predicate first)
209                (sequence->exp 
210                  (cond-actions first))
211                (expand-clauses 
212                  rest))))))
213
214
215 (define (true? x)
216   (not (eq? x false)))
217
218 (define (false? x)
219   (eq? x false))
220
221
222 (define (make-procedure parameters body env)
223   (list 'procedure parameters body env))
224 (define (compound-procedure? p)
225   (tagged-list? p 'procedure))
226 (define (procedure-parameters p) (cadr p))
227 (define (procedure-body p) (caddr p))
228 (define (procedure-environment p) (cadddr p))
229
230 (define (enclosing-environment env) (cdr env))
231 (define (first-frame env) (car env))
232 (define the-empty-environment '())
233
234
235 (define (make-frame variables values)
236   (cons variables values))
237 (define (frame-variables frame) (car frame))
238 (define (frame-values frame) (cdr frame))
239 (define (add-binding-to-frame! var val frame)
240   (set-car! frame (cons var (car frame)))
241   (set-cdr! frame (cons val (cdr frame))))
242
243 (define (extend-environment vars vals base-env)
244   (if (= (length vars) (length vals))
245     (cons (make-frame vars vals) base-env)
246     (if (< (length vars) (length vals))
247       (error "Too many arguments supplied" 
248              vars 
249              vals)
250       (error "Too few arguments supplied" 
251              vars 
252              vals))))
253
254 (define (lookup-variable-value var env)
255   (define (env-loop env)
256     (define (scan vars vals)
257       (cond ((null? vars)
258              (env-loop 
259                (enclosing-environment env)))
260             ((eq? var (car vars))
261              (car vals))
262             (else (scan (cdr vars) 
263                         (cdr vals)))))
264     (if (eq? env the-empty-environment)
265       (error "Unbound variable" var)
266       (let ((frame (first-frame env)))
267         (scan (frame-variables frame)
268               (frame-values frame)))))
269   (env-loop env))
270
271 (define (set-variable-value! var val env)
272   (define (env-loop env)
273     (define (scan vars vals)
274       (cond ((null? vars)
275              (env-loop 
276                (enclosing-environment env)))
277             ((eq? var (car vars))
278              (set-car! vals val))
279             (else (scan (cdr vars) 
280                         (cdr vals)))))
281     (if (eq? env the-empty-environment)
282       (error "Unbound variable: SET!" var)
283       (let ((frame (first-frame env)))
284         (scan (frame-variables frame)
285               (frame-values frame)))))
286   (env-loop env))
287
288 (define (define-variable! var val env)
289   (let ((frame (first-frame env)))
290     (define (scan vars vals)
291       (cond ((null? vars)
292              (add-binding-to-frame! 
293                var val frame))
294             ((eq? var (car vars))
295              (set-car! vals val))
296             (else
297                 (scan (cdr vars) 
298                         (cdr vals)))))
299     (scan (frame-variables frame)
300           (frame-values frame))))
301
302 (define (setup-environment)
303   (let ((initial-env
304           (extend-environment 
305             (primitive-procedure-names)
306             (primitive-procedure-objects)
307             the-empty-environment)))
308     (define-variable! 'true true initial-env)
309     (define-variable! 'false false initial-env)
310     initial-env))
311
312
313 (define (primitive-procedure? proc)
314   (tagged-list? proc 'primitive))
315
316 (define (primitive-implementation proc) 
317   (cadr proc))
318
319 (define primitive-procedures
320   (list (list 'car car)
321         (list 'cdr cdr)
322         (list 'cons cons)
323         (list 'null? null?)
324         (list '+ +)
325         (list '- -)
326         (list '* *)))
327
328 (define (primitive-procedure-names)
329   (map car primitive-procedures))
330
331 (define (primitive-procedure-objects)
332   (map (lambda (proc) 
333          (list 'primitive (cadr proc)))
334        primitive-procedures))
335
336 (define (apply-primitive-procedure proc args)
337     (apply-in-underlying-scheme
338          (primitive-implementation proc) args))
339
340 (define input-prompt  ";;; M-Eval input:")
341 (define output-prompt ";;; M-Eval value:")
342
343
344 (define (driver-loop)
345   (prompt-for-input input-prompt)
346   (let ((input (read)))
347     (let ((output 
348             (eval input 
349                   the-global-environment)))
350       (announce-output output-prompt)
351       (user-print output)))
352   (driver-loop))
353
354 (define (prompt-for-input string)
355   (newline) (newline) 
356   (display string) (newline))
357
358 (define (announce-output string)
359   (newline) (display string) (newline))
360
361 (define (user-print object)
362   (if (compound-procedure? object)
363     (display 
364       (list 'compound-procedure
365             (procedure-parameters object)
366             (procedure-body object)
367             '<procedure-env>))
368     (display object)))
369
370
371 (define the-global-environment (setup-environment))