1 ;; (define apply-in-underlying-scheme apply)
2 
3 (define (eval exp env)
4   ((analyze exp) env))
5 (define (analyze exp)
6   (cond ((self-evaluating? exp) 
7          (analyze-self-evaluating exp))
8         ((quoted? exp) (analyze-quoted exp))
9         ((variable? exp) (analyze-variable exp))
10         ((assignment? exp) (analyze-assignment exp))
11         ((definition? exp) (analyze-definition exp))
12         ((if? exp) (analyze-if exp))
13         ((lambda? exp) (analyze-lambda exp))
14         ((begin? exp) (analyze-sequence (begin-actions exp)))
15         ((cond? exp) (analyze (cond->if exp)))
16         ((application? exp) (analyze-application exp))
17         (else
18          (error "Unknown expression type -- ANALYZE" exp))))
19 (define (analyze-self-evaluating exp)
20   (lambda (env) exp))
21 (define (analyze-quoted exp)
22   (let ((qval (text-of-quotation exp)))
23     (lambda (env) qval)))
24 (define (analyze-variable exp)
25   (lambda (env) (lookup-variable-value exp env)))
26 (define (analyze-assignment exp)
27   (let ((var (assignment-variable exp))
28         (vproc (analyze (assignment-value exp))))
29     (lambda (env)
30       (set-variable-value! var (vproc env) env)
31       'ok)))
32 (define (analyze-definition exp)
33   (let ((var (definition-variable exp))
34         (vproc (analyze (definition-value exp))))
35     (lambda (env)
36       (define-variable! var (vproc env) env)
37       'ok)))    
38 (define (analyze-if exp)
39   (let ((pproc (analyze (if-predicate exp)))
40         (cproc (analyze (if-consequent exp)))
41         (aproc (analyze (if-alternative exp))))
42     (lambda (env)
43       (if (true? (pproc env))
44           (cproc env)
45           (aproc env)))))
46 (define (analyze-lambda exp)
47   (let ((vars (lambda-parameters exp))
48         (bproc (analyze-sequence (lambda-body exp))))
49     (lambda (env) (make-procedure vars bproc env))))
50 (define (analyze-sequence exps)
51   (define (sequentially proc1 proc2)
52     (lambda (env) (proc1 env) (proc2 env)))
53   (define (loop first-proc rest-procs)
54     (if (null? rest-procs)
55         first-proc
56         (loop (sequentially first-proc (car rest-procs))
57               (cdr rest-procs))))
58   (let ((procs (map analyze exps)))
59     (if (null? procs)
60         (error "Empty sequence -- ANALYZE"))
61     (loop (car procs) (cdr procs))))
62 (define (analyze-application exp)
63   (let ((fproc (analyze (operator exp)))
64         (aprocs (map analyze (operands exp))))
65     (lambda (env)
66       (execute-application (fproc env)
67                            (map (lambda (aproc) (aproc env))
68                                 aprocs)))))
69 (define (execute-application proc args)
70   (cond ((primitive-procedure? proc)
71          (apply-primitive-procedure proc args))
72         ((compound-procedure? proc)
73          ((procedure-body proc)
74           (extend-environment (procedure-parameters proc)
75                               args
76                               (procedure-environment proc))))
77         (else
78          (error
79           "Unknown procedure type -- EXECUTE-APPLICATION"
80           proc))))
81 
82 
83 ;; (define (eval exp env)
84 ;;   (cond ((self-evaluating? exp) exp)
85 ;;         ((variable? exp) (lookup-variable-value exp env))
86 ;;         ((quoted? exp) (text-of-quotation exp))
87 ;;         ((assignment? exp) (eval-assignment exp env))
88 ;;         ((definition? exp) (eval-definition exp env))
89 ;; ;;	((unbound? exp) (eval-unbound exp env))
90 ;;         ((if? exp) (eval-if exp env))
91 ;; 	((and? exp) (eval-and exp env))
92 ;; 	((or? exp) (eval-or exp env))
93 ;;         ((lambda? exp)
94 ;;          (make-procedure (lambda-parameters exp)
95 ;;                          (lambda-body exp)
96 ;;                          env))
97 ;;         ((begin? exp) 
98 ;;          (eval-sequence (begin-actions exp) env))
99 ;;         ((cond? exp) (eval (cond->if exp) env))
100 ;; 	((let? exp) (eval (let->combination exp) env))
101 ;; 	((let*? exp) (eval (let*->nested-lets exp) env))
102 ;; 	((named-let? exp) (eval (named-let->combination exp) env))
103 ;; 	((letrec? exp) (eval (letrec->let exp) env))
104 ;; 	((do? exp) (eval (do->combination exp) env))
105 ;;         ((application? exp)
106 ;;          (apply (eval (operator exp) env)
107 ;;                 (list-of-values (operands exp) env)))
108 ;;         (else
109 ;;          (error "Unknown expression type -- EVAL" exp))))
110 ;; (define (apply procedure arguments)
111 ;;   (cond ((primitive-procedure? procedure)
112 ;;          (apply-primitive-procedure procedure arguments))
113 ;;         ((compound-procedure? procedure)
114 ;;          (eval-sequence
115 ;;            (procedure-body procedure)
116 ;;            (extend-environment
117 ;;              (procedure-parameters procedure)
118 ;;              arguments
119 ;;              (procedure-environment procedure))))
120 ;;         (else
121 ;;          (error
122 ;;           "Unknown procedure type -- APPLY" procedure))))
123 
124 ;; (define (list-of-values exps env)
125 ;;   (if (no-operands? exps)
126 ;;       '()
127 ;;       (cons (eval (first-operand exps) env)
128 ;;             (list-of-values (rest-operands exps) env))))
129 
130 (define (tagged-list? exp tag)
131   (if (pair? exp)
132       (eq? (car exp) tag)
133       false))
134 
135 ;; self-evaluating/variable/quoted
136 (define (self-evaluating? exp)
137   (cond ((number? exp) true)
138         ((string? exp) true)
139         (else false)))
140 (define (variable? exp) (symbol? exp))
141 (define (quoted? exp)
142   (tagged-list? exp 'quote))
143 (define (text-of-quotation exp) (cadr exp))
144 
145 ;; assignment/definition
146 (define (assignment? exp)
147   (tagged-list? exp 'set!))
148 (define (assignment-variable exp) (cadr exp))
149 (define (assignment-value exp) (caddr exp))
150 (define (make-assignment var val)
151   (list 'set! var val))
152 (define (definition? exp)
153   (tagged-list? exp 'define))
154 (define (definition-variable exp)
155   (if (symbol? (cadr exp))
156       (cadr exp)
157       (caadr exp)))
158 (define (definition-value exp)
159   (if (symbol? (cadr exp))
160       (caddr exp)
161       (make-lambda (cdadr exp)   ; formal parameters
162                    (cddr exp)))) ; body
163 (define (eval-assignment exp env)
164   (set-variable-value! (assignment-variable exp)
165                        (eval (assignment-value exp) env)
166                        env)
167   'ok)
168 (define (eval-definition exp env)
169   (define-variable! (definition-variable exp)
170                     (eval (definition-value exp) env)
171                     env)
172   'ok)
173 (define (make-definition var val)
174   `(define ,var ,val))
175 
176 ;; make-unbound!
177 
178 ;; (define (unbound? exp)
179 ;;   (tagged-list? exp 'make-unbound!))
180 ;; (define (unbound-var exp)
181 ;;   (cadr exp))
182 ;; (define (eval-unbound exp env)
183 ;;   (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
184 
185 
186 
187 ;; if/and/or
188 (define (if? exp) (tagged-list? exp 'if))
189 (define (if-predicate exp) (cadr exp))
190 (define (if-consequent exp) (caddr exp))
191 (define (if-alternative exp)
192   (if (not (null? (cdddr exp)))
193       (cadddr exp)
194       'false))
195 (define (make-if predicate consequent alternative)
196   (list 'if predicate consequent alternative))
197 (define (eval-if exp env)
198   (if (true? (eval (if-predicate exp) env))
199       (eval (if-consequent exp) env)
200       (eval (if-alternative exp) env)))
201 
202 (define (and? exp)
203   (tagged-list? exp 'and))
204 (define (and-clauses exp)
205   (cdr exp))
206 (define (or? exp)
207   (tagged-list? exp 'or))
208 (define (or-clauses exp)
209   (cdr exp))
210 (define (eval-and exp env)
211   (define (eval-clauses clauses)
212     (cond ((null? clauses) true)
213 	  ((null? (cdr clauses)) (eval (car clauses) env))
214 	  (else (and (eval (car clauses) env)
215 		     (eval-clauses (cdr clauses))))))
216   (eval-clauses (and-clauses exp)))
217 (define (eval-or exp env)
218   (define (eval-clauses clauses)
219     (if (null? clauses)
220 	false
221 	(or (eval (car clauses) env)
222 	    (eval-clauses (cdr clauses)))))
223   (eval-clauses (or-clauses exp)))
224 
225 
226 ;; lambda/let/let*/letrec
227 (define (lambda? exp) (tagged-list? exp 'lambda))
228 (define (lambda-parameters exp) (cadr exp))
229 (define (lambda-body exp) (cddr exp))
230 (define (make-lambda parameters body)
231   (cons 'lambda (cons parameters body)))
232 
233 (define (make-let vars vals body)
234   (cons 'let
235 	(cons (map list vars vals)
236 	      body)))
237 (define (let? exp)
238   (and (tagged-list? exp 'let)
239        (not (symbol? (cadr exp)))))
240 (define (let-vars exp)
241   (map car (cadr exp)))
242 (define (let-vals exp)
243   (map cadr (cadr exp)))
244 (define (let-body exp)
245   (cddr exp))
246 (define (let->combination exp)
247   (make-application (make-lambda (let-vars exp) (let-body exp))
248 		    (let-vals exp)))
249 (define (named-let? exp)
250   (and (tagged-list? exp 'let)
251        (symbol? (cadr exp))))
252 (define (named-let-name exp)
253   (cadr exp))
254 (define (named-let-vars exp)
255   (map car (caddr exp)))
256 (define (named-let-vals exp)
257   (map cadr (caddr exp)))
258 (define (named-let-body exp)
259   (cdddr exp))
260 (define (named-let->combination exp)
261   (sequence->exp
262    (list (make-definition (named-let-name exp)
263 			  (make-lambda (named-let-vars exp)
264 				       (named-let-body exp)))
265 	 (make-application (named-let-name exp)
266 			   (named-let-vals exp)))))
267 (define (make-named-let name vars vals body)
268   (cons 'let 
269 	(cons name
270 	      (cons (map list vars vals)
271 		    body))))
272 
273 (define (letrec? exp)
274   (tagged-list? exp 'letrec))
275 
276 (define (letrec-vars exp)
277   (map car (cadr exp)))
278 (define (letrec-vals exp)
279   (map cadr (cadr exp)))
280 (define (letrec-body exp)
281   (cddr exp))
282 (define (letrec->let exp)
283   (let* ((vars (letrec-vars exp))
284 	 (unassigneds (map (lambda (var) ''*unassigned*)
285 			   vars))
286 	 (vals (letrec-vals exp))
287 	 (assignments (map (lambda (var val)
288 			     (make-assignment var val))
289 			   vars
290 			   vals))
291 	 (body (letrec-body exp)))
292   (make-let vars 
293 	    unassigneds
294 	    (append assignments body))))
295 
296 
297 
298 
299 (define (make-application op args)
300   (cons op args))
301 
302 (define (let*? exp)
303   (tagged-list? exp 'let*))
304 (define let*-vars let-vars)
305 (define let*-vals let-vals)
306 (define let*-body let-body)
307 (define (let*->nested-lets exp)
308   (define (expand-lets vars vals)
309     (if (null? (cdr vars))
310 	(make-let (list (car vars)) 
311 		  (list (car vals))
312 		  (let*-body exp))
313 	(make-let (list (car vars))
314 		  (list (car vals))
315 		  (list (expand-lets (cdr vars) (cdr vals))))))
316   (let ((vars (let*-vars exp))
317 	(vals (let*-vals exp)))
318     (if (null? vars)
319 	(sequence->exp (let*-body exp))
320 	(expand-lets vars vals))))
321 
322 ;; do loop
323 (define (do? exp)
324   (tagged-list? exp 'do))
325 (define (do-vars exp)
326   (map car (cadr exp)))
327 (define (do-inits exp)
328   (map cadr (cadr exp)))
329 (define (do-steps exp)
330   (map (lambda (var-init-step)
331 	 (if (null? (cddr var-init-step))
332 	     (car var-init-step)
333 	     (caddr var-init-step)))
334        (cadr exp)))
335 (define (do-test exp)
336   (caaddr exp))
337 (define (do-expressions exp)
338   (if (null? (cdaddr exp))
339       (caddr exp)
340       (cdaddr exp)))
341 (define (do-commands exp)
342   (cdddr exp))
343 (define (do->combination exp)
344   (make-named-let
345    'do-iter
346    (do-vars exp)
347    (do-inits exp)
348    (list
349     (make-if
350      (do-test exp)
351      (sequence->exp (do-expressions exp))
352      (sequence->exp
353       (append (do-commands exp)
354 	      (list (make-application
355 		     'do-iter
356 		     (do-steps exp)))))))))
357 
358 
359 ;; begin/sequence
360 (define (begin? exp) (tagged-list? exp 'begin))
361 (define (begin-actions exp) (cdr exp))
362 (define (last-exp? seq) (null? (cdr seq)))
363 (define (first-exp seq) (car seq))
364 (define (rest-exps seq) (cdr seq))
365 (define (sequence->exp seq)
366   (cond ((null? seq) seq)
367         ((last-exp? seq) (first-exp seq))
368         (else (make-begin seq))))
369 (define (make-begin seq) (cons 'begin seq))
370 (define (eval-sequence exps env)
371   (cond ((last-exp? exps) (eval (first-exp exps) env))
372         (else (eval (first-exp exps) env)
373               (eval-sequence (rest-exps exps) env))))
374 
375 ;; application
376 (define (application? exp) (pair? exp))
377 (define (operator exp) (car exp))
378 (define (operands exp) (cdr exp))
379 (define (no-operands? ops) (null? ops))
380 (define (first-operand ops) (car ops))
381 (define (rest-operands ops) (cdr ops))
382 
383 ;; cond
384 (define (cond? exp) (tagged-list? exp 'cond))
385 (define (cond-clauses exp) (cdr exp))
386 (define (cond-else-clause? clause)
387   (eq? (cond-predicate clause) 'else))
388 (define (cond-predicate clause) (car clause))
389 (define (cond-actions clause) (cdr clause))
390 (define (cond-extended-clause? clause)
391   (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
392 (define (cond-extended-proc clause)
393   (caddr clause))
394 (define (cond->if exp)
395   (expand-clauses (cond-clauses exp)))
396 (define (expand-clauses clauses)
397   (if (null? clauses)
398       'false                          ; no else clause
399       (let ((first (car clauses))
400             (rest (cdr clauses)))
401         (if (cond-else-clause? first)
402             (if (null? rest)
403                 (sequence->exp (cond-actions first))
404                 (error "ELSE clause isn't last -- COND->IF"
405                        clauses))
406 	    (if (cond-extended-clause? first)
407 		(make-if (cond-predicate first)
408 			 (make-application
409 			  (cond-extended-proc first)
410 			  (list (cond-predicate first)))
411 			 (expand-clauses rest))
412 		(make-if (cond-predicate first)
413 			 (sequence->exp (cond-actions first))
414 			 (expand-clauses rest)))))))
415 (define (true? x)
416   (not (eq? x false)))
417 (define (false? x)
418   (eq? x false))
419 
420 ;; procedure
421 (define (make-procedure parameters body env)
422   (list 'procedure parameters (scan-out-defines body) env))
423 (define (scan-out-defines body)
424   (let* ((definitions (filter definition? body))
425 	 (vars (map definition-variable definitions))
426 	 (unassigneds (map (lambda (var) ''*unassigned*) 
427 			   vars))
428 	 (vals (map definition-value definitions))
429 	 (assignments 
430 	  (map (lambda (var val)
431 		 (make-assignment var val))
432 	       vars vals))
433 	 (exps (remove definition? body)))
434     (if (null? definitions)
435 	body
436 	(list
437 	 (make-let vars
438 		   unassigneds
439 		   (append assignments exps))))))
440 (define (compound-procedure? p)
441   (tagged-list? p 'procedure))
442 (define (procedure-parameters p) (cadr p))
443 (define (procedure-body p) (caddr p))
444 (define (procedure-environment p) (cadddr p))
445 
446 ;; environment
447 (define (enclosing-environment env) (cdr env))
448 (define (first-frame env) (car env))
449 (define the-empty-environment '())
450 (define (make-frame variables values)
451   (cons variables values))
452 (define (frame-variables frame) (car frame))
453 (define (frame-values frame) (cdr frame))
454 (define (add-binding-to-frame! var val frame)
455   (set-car! frame (cons var (car frame)))
456   (set-cdr! frame (cons val (cdr frame))))
457 (define (extend-environment vars vals base-env)
458   (if (= (length vars) (length vals))
459       (cons (make-frame vars vals) base-env)
460       (if (< (length vars) (length vals))
461           (error "Too many arguments supplied" vars vals)
462           (error "Too few arguments supplied" vars vals))))
463 (define (lookup-variable-value var env)
464   (define (env-loop env)
465     (define (scan vars vals)
466       (cond ((null? vars)
467              (env-loop (enclosing-environment env)))
468             ((eq? var (car vars))
469 	     (let ((val (car vals)))
470 	       (if (eq? val '*unassigned*)
471 		   (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
472 		   val)))
473             (else (scan (cdr vars) (cdr vals)))))
474     (if (eq? env the-empty-environment)
475         (error "Unbound variable" var)
476         (let ((frame (first-frame env)))
477           (scan (frame-variables frame)
478                 (frame-values frame)))))
479   (env-loop env))
480 (define (set-variable-value! var val env)
481   (define (env-loop env)
482     (define (scan vars vals)
483       (cond ((null? vars)
484              (env-loop (enclosing-environment env)))
485             ((eq? var (car vars))
486              (set-car! vals val))
487             (else (scan (cdr vars) (cdr vals)))))
488     (if (eq? env the-empty-environment)
489         (error "Unbound variable -- SET!" var)
490         (let ((frame (first-frame env)))
491           (scan (frame-variables frame)
492                 (frame-values frame)))))
493   (env-loop env))
494 (define (define-variable! var val env)
495   (let ((frame (first-frame env)))
496     (define (scan vars vals)
497       (cond ((null? vars)
498              (add-binding-to-frame! var val frame))
499             ((eq? var (car vars))
500              (set-car! vals val))
501             (else (scan (cdr vars) (cdr vals)))))
502     (scan (frame-variables frame)
503           (frame-values frame))))
504 
505 (define (remove-binding-from-frame! var frame)
506   (define (scan vars vals)
507     (cond ((null? (cdr vars))
508 	   (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
509 	  ((eq? var (cadr vars))
510 	   (set-cdr! vars (cddr vars))
511 	   (set-cdr! vals (cddr vals)))
512 	  (else (scan (cdr vars) (cdr vals)))))
513   (let ((vars (frame-variables frame))
514 	(vals (frame-values frame)))
515     (if (eq? var (car vars))
516 	(begin (set-car! frame (cdr vars))
517 	       (set-cdr! frame (cdr vals)))
518 	(scan vars vals))))
519 
520 ;; primitives
521 (define (primitive-procedure? proc)
522   (tagged-list? proc 'primitive))
523 (define (primitive-implementation proc) (cadr proc))
524 (define primitive-procedures
525   (list (list 'car car)
526         (list 'cdr cdr)
527 	(list 'caar caar)
528 	(list 'cadr cadr)
529 	(list 'cddr cddr)
530         (list 'cons cons)
531         (list 'null? null?)
532 	(list '* *)
533 	(list '/ /)
534 	(list '+ +)
535 	(list '- -)
536 	(list '= =)
537 	(list '< <)
538 	(list '> >)
539 	(list '<= <=)
540 	(list '>= >=)
541 	(list 'remainder remainder)
542 	(list 'eq? eq?)
543 	(list 'equal? equal?)
544 	(list 'display display)))
545 (define (primitive-procedure-names)
546   (map car
547        primitive-procedures))
548 (define (primitive-procedure-objects)
549   (map (lambda (proc) (list 'primitive (cadr proc)))
550        primitive-procedures))
551 (define (apply-primitive-procedure proc args)
552   (apply-in-underlying-scheme
553    (primitive-implementation proc) args))
554 
555 ;; driver-loop
556 (define input-prompt ";;; M-Eval input:")
557 (define output-prompt ";;; M-Eval value:")
558 (define (driver-loop)
559   (prompt-for-input input-prompt)
560   (let ((input (read)))
561     (let ((output (eval input the-global-environment)))
562       (announce-output output-prompt)
563       (user-print output)))
564   (driver-loop))
565 (define (prompt-for-input string)
566   (newline) (newline) (display string) (newline))
567 
568 (define (announce-output string)
569   (newline) (display string) (newline))
570 (define (user-print object)
571   (if (compound-procedure? object)
572       (display (list 'compound-procedure
573                      (procedure-parameters object)
574                      (procedure-body object)
575                      '<procedure-env>))
576       (display object)))
577 (define (setup-environment)
578   (let ((initial-env
579          (extend-environment (primitive-procedure-names)
580                              (primitive-procedure-objects)
581                              the-empty-environment)))
582     (define-variable! 'true true initial-env)
583     (define-variable! 'false false initial-env)
584     initial-env))
585 (define the-global-environment (setup-environment))
586 
587 ;; auxiliary
588 (define (test-case actual expected)
589   (newline)
590   (display "Actual:   ")
591   (display actual)
592   (newline)
593   (display "Expected: ")
594   (display expected)
595   (newline))
596 (define (geval exp) ;; eval globally
597   (eval exp the-global-environment))
598 (define (test-eval exp expected)
599   (test-case (geval exp) expected))
600 
601 
602 
603 ;; test-suite
604 
605 ;; procedure definitions
606 
607 (geval 
608  '(define (assoc key records)
609     (cond ((null? records) false)
610 	  ((equal? key (caar records)) (car records))
611 	  (else (assoc key (cdr records))))))
612 
613 (geval
614  '(define (map proc list)
615     (if (null? list)
616 	'()
617 	(cons (proc (car list))
618 	      (map proc (cdr list))))))
619 
620 (geval 
621  '(define (accumulate op initial sequence)
622     (if (null? sequence)
623 	initial
624 	(op (car sequence)
625 	    (accumulate op initial (cdr sequence))))))
626 
627 ;; all special forms
628 (test-eval '(begin 5 6) 6)
629 (test-eval '10 10)
630 (geval '(define x 3))
631 (test-eval 'x 3)
632 (test-eval '(set! x -25) 'ok)
633 (test-eval 'x -25)
634 (geval '(define z (lambda (x y) (+ x (* x y)))))
635 (test-eval '(z 3 4) 15)
636 (test-eval '(cond ((= x -2) 'x=-2)
637 		  ((= x -25) 'x=-25)
638 		  (else 'failed))
639 	   'x=-25)
640 (test-eval '(if true false true) false)
641 (test-eval 
642  '(let ((x 4) (y 7))
643     (+ x y (* x y)))
644  (+ 4 7 (* 4 7)))
645 
646 
647 ;; and/or
648 (geval '(define x (+ 3 8)))
649 (test-eval '(and 0 true x) 11)
650 (test-eval '(and 0 true x false) false)
651 (test-eval '(and 0 true x (set! x -2) false) false)
652 (test-eval 'x -2)
653 (test-eval '(and 0 true x false (set! x -5)) false)
654 (test-eval 'x -2)
655 (test-eval '(or false (set! x 25)) 'ok)
656 (test-eval 'x 25)
657 (test-eval '(or (set! x 2) (set! x 4)) 'ok)
658 (test-eval 'x 2)
659 (test-eval '(or false (set! x 25) true false) 'ok)
660 (test-eval 'x 25)
661 (test-eval '(or ((lambda (x) x) 5)) 5)
662 (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
663 
664 
665 ;; cond
666 
667 (test-eval 
668  '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
669 	(else false))
670  2)
671 
672 (test-eval
673  '(cond ((= 3 4) 'not-true)
674 	((= (* 2 4) 3) 'also-false)
675 	((map (lambda (x)
676 		(* x (+ x 1)))
677 	      '(2 4 1 9))
678 	 =>
679 	 (lambda (x)
680 	   (accumulate + 0 x)))
681 	(else 'never-reach))
682  118)
683 ;; '(6 20 2 90)
684 
685 
686 ;; procedure definition and application
687 (geval
688  '(define (factorial n)
689     (if (= n 0)
690 	1
691 	(* n (factorial (- n 1))))))
692 (test-eval '(factorial 5) 120)
693 
694 ;; map
695 
696 (test-eval
697  '(map (lambda (x)
698 	 (* x (+ x 1)))
699        '(2 1 4 2 8 3))
700  '(6 2 20 6 72 12))
701 ;; accumulate
702 
703 (test-eval
704  '(accumulate + 0 '(1 2 3 4 5))
705  15)
706 
707 ;; make-let
708 (test-eval 
709  (make-let '(x y) '(3 5) '((+ x y)))
710  8)
711 (test-eval 
712  '(let ()
713     5)
714  5)
715 (test-eval
716  '(let ((x 3))
717     x)
718  3)
719 (test-eval
720  '(let ((x 3)
721 	(y 5))
722     (+ x y))
723  8)
724 (test-eval 
725  '(let ((x 3)
726 	(y 2))
727     (+ (let ((x (+ y 2))
728 	     (y x))
729 	 (* x y))
730        x y))
731  (+ (* 4 3) 3 2))
732 (test-eval
733  '(let ((x 6)
734 	(y (let ((x 2))
735 	     (+ x 3)))
736 	(z (let ((a (* 3 2)))
737 	     (+ a 3))))
738     (+ x y z))
739  (+ 6 5 9))
740     
741 
742 ;; let*
743 
744 (test-eval
745  '(let* ((x 3)
746 	 (y (+ x 2))
747 	 (z (+ x y 5)))
748     (* x z))
749  39)
750 
751 (test-eval
752  '(let* ()
753     5)
754  5)
755 (test-eval
756  '(let* ((x 3))
757     (let* ((y 5))
758       (+ x y)))
759  8)
760 
761 (test-eval 
762  '(let* ((x 3)
763 	 (y (+ x 1)))
764     (+ (let* ((x (+ y 2))
765 	      (y x))
766 	 (* x y))
767        x y))
768  (+ (* 6 6) 3 4))
769 (test-eval
770  '(let* ((x 6)
771 	 (y (let* ((x 2)
772 		   (a (let* ((x (* 3 x)))
773 			(+ x 2))))       
774 	      (+ x a)))                  
775 	 (z (+ x y)))                    
776     (+ x y z))
777  32)
778 
779 ;; named-let
780 
781 (test-eval
782  '(let eight ()
783     5
784     7
785     8)
786  8)
787 (test-eval
788  '(let loop ((count 0))
789     (if (= 100 count)
790 	count
791 	(loop (+ count 1))))
792  100)
793 (geval
794  '(define (prime? x)
795     (let prime-iter ((i 2))
796       (cond ((> (* i i) x) true)
797 	    ((= (remainder x i) 0) false)
798 	    (else (prime-iter (+ i 1)))))))
799 (test-eval
800  '(let primes ((x 2)
801 	       (n 20))
802     (cond ((= n 0) '())
803 	  ((prime? x) 
804 	   (cons x
805 		 (primes (+ x 1) (- n 1))))
806 	  (else (primes (+ x 1) n))))
807  '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
808 
809 (geval
810  '(define (fib n)
811     (let fib-iter ((a 1)
812 		   (b 0)
813 		   (count n))
814       (if (= count 0)
815 	  b
816 	  (fib-iter (+ a b) a (- count 1))))))
817 (test-eval '(fib 19) 4181)
818 
819 ;; do-loop	  
820 (test-eval
821  '(let ((y 0))
822     (do ((x 0 (+ x 1)))
823 	((= x 5) y)
824       (set! y (+ y 1))))
825  5)
826 (test-eval
827  '(do ()
828       (true))
829  true)
830 (test-eval
831  '(do ()
832       (true 5))
833  5)
834 (test-eval
835  '(let ((y 0))
836     (do ()
837 	((= y 5) y)
838       (set! y (+ y 1))))
839  5)
840 
841 (test-eval
842  '(do ((y '(1 2 3 4)))
843       ((null? y))
844     (set! y (cdr y)))
845  true)
846 (test-eval
847  '(let ((y 0))
848     (do ((x 0 (+ x 1)))
849 	((= x 5) y)
850       (set! y (+ y 1))))
851  5)
852 (test-eval
853  '(let ((x '(1 3 5 7 9)))
854     (do ((x x (cdr x))
855 	 (sum 0 (+ sum (car x))))
856 	((null? x) sum)))
857  25)
858 (test-eval 
859  '(let ((z '()))
860     (do ((x '(1 2 3 4) (cdr x))
861 	 (y '(1 2 3 4 5 6 7 8) (cddr y)))
862 	((null? x) y x z)
863       (set! z (cons (car x) z))))
864  '(4 3 2 1))
865 
866 
867 
868 ;; make-unbound!
869 ;; broken now due to scan-out-defines
870 
871 ;; (test-eval
872 ;;  '(let ((x 3))
873 ;;     (let ((x 5))
874 ;;       (make-unbound! x)
875 ;;       (* x x)))
876 ;;  9)
877 
878 ;; (test-eval
879 ;;  '(let ((x 3))
880 ;;     (let ((x 5))
881 ;;       (define y x)
882 ;;       (make-unbound! x)
883 ;;       (* y x)))
884 ;;  15)
885 
886 ;; (test-eval
887 ;;  '(let ((y -1) (x 3))
888 ;;     (let ((y 0.5) (x 5))
889 ;;       (define a x)
890 ;;       (define b y)
891 ;;       (make-unbound! x)
892 ;;       (make-unbound! y)
893 ;;       (* a b x y)))
894 ;;  (* 5 3 -1 0.5))
895 
896 ;; (test-eval
897 ;;  '(let ((x 3) (y 4))
898 ;;     (let ((x 5))
899 ;;       (make-unbound! x)
900 ;;       (+ x 4)))
901 ;;  7)
902 
903 ;; (test-eval 
904 ;;  '(let ((a 1) (b 2) (c 3) (d 4))
905 ;;     (make-unbound! b)
906 ;;     (+ a c d))
907 ;;  (+ 1 3 4))
908 
909 ;; (test-eval
910 ;;  '(let ((x 4) (y 5))
911 ;;     (let ((a 1) (b 2) (c 3))
912 ;;       (let ((x (+ a b)) (y (+ c a)))
913 ;; 	(make-unbound! x)
914 ;; 	(let ((a x) (b (+ x y)))
915 ;; 	  (define z b)
916 ;; 	  (make-unbound! b)
917 ;; 	  (* (+ a z)
918 ;; 	     (+ a b y))))))
919 ;;  (* (+ 4 8)
920 ;;     (+ 4 2 4)))
921  
922 ;; x 3 -- y 4
923 ;; x 4 -- y 4
924 ;; a 4 -- b 4
925 ;; a 4 -- b 2
926 
927 ;; scan-out-defines
928 
929 (geval
930  '(define (f x)
931     (define (even? n)
932       (if (= n 0)
933 	  true
934 	  (odd? (- n 1))))
935     (define (odd? n)
936       (if (= n 0)
937 	  false
938 	  (even? (- n 1))))
939     (even? x)))
940 (test-eval '(f 5) false)
941 (test-eval '(f 10) true)
942 
943 ;; (geval
944 ;;  '(let ((x 5))
945 ;;     (define y x)
946 ;;     (define x 3)
947 ;;     (+ x y)))
948 ;; signal an error because x is undefined if variables are scanned out
949 
950 ;; letrec
951 
952 (geval
953  '(define (f x)
954     (letrec ((even?
955 	      (lambda (n)
956 		(if (= n 0)
957 		    true
958 		    (odd? (- n 1)))))
959 	     (odd?
960 	      (lambda (n)
961 		(if (= n 0)
962 		    false
963 		    (even? (- n 1))))))
964       (even? x))))
965 (test-eval '(f 11) false)
966 (test-eval '(f 16) true)
967 
968 (test-eval 
969  '(letrec ((fact
970 	    (lambda (n)
971 	      (if (= n 1)
972 		  1
973 		  (* n (fact (- n 1)))))))
974     (fact 10))
975  3628800)