1;;; SCHEME -- A Scheme interpreter evaluating a sort, written by Marc Feeley.
2
3; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4
5(define (scheme-eval expr)
6  (let ((code (scheme-comp expr scheme-global-environment)))
7    (code #f)))
8
9(define scheme-global-environment
10  (cons '()   ; environment chain
11        '())) ; macros
12
13(define (scheme-add-macro name proc)
14  (set-cdr! scheme-global-environment
15    (cons (cons name proc) (cdr scheme-global-environment)))
16  name)
17
18(define (scheme-error msg . args)
19  (fatal-error msg args))
20
21; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
22
23(define (lst->vector l)
24  (let* ((n (length l))
25         (v (make-vector n)))
26    (let loop ((l l) (i 0))
27      (if (pair? l)
28        (begin
29          (vector-set! v i (car l))
30          (loop (cdr l) (+ i 1)))
31        v))))
32
33(define (vector->lst v)
34  (let loop ((l '()) (i (- (vector-length v) 1)))
35    (if (< i 0)
36      l
37      (loop (cons (vector-ref v i) l) (- i 1)))))
38
39; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
40
41(define scheme-syntactic-keywords
42  '(quote quasiquote unquote unquote-splicing
43    lambda if set! cond => else and or
44    case let let* letrec begin do define
45    define-macro))
46
47; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
48
49(define (push-frame frame env)
50  (if (null? frame)
51    env
52    (cons (cons (car env) frame) (cdr env))))
53
54(define (lookup-var name env)
55  (let loop1 ((chain (car env)) (up 0))
56    (if (null? chain)
57      name
58      (let loop2 ((chain chain)
59                  (up up)
60                  (frame (cdr chain))
61                  (over 1))
62        (cond ((null? frame)
63               (loop1 (car chain) (+ up 1)))
64              ((eq? (car frame) name)
65               (cons up over))
66              (else
67               (loop2 chain up (cdr frame) (+ over 1))))))))
68
69(define (macro? name env)
70  (assq name (cdr env)))
71
72(define (push-macro name proc env)
73  (cons (car env) (cons (cons name proc) (cdr env))))
74
75(define (lookup-macro name env)
76  (cdr (assq name (cdr env))))
77
78; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
79
80(define (variable x)
81  (if (not (symbol? x))
82    (scheme-error "Identifier expected" x))
83  (if (memq x scheme-syntactic-keywords)
84    (scheme-error "Variable name can not be a syntactic keyword" x)))
85
86(define (shape form n)
87  (let loop ((form form) (n n) (l form))
88    (cond ((<= n 0))
89          ((pair? l)
90           (loop form (- n 1) (cdr l)))
91          (else
92           (scheme-error "Ill-constructed form" form)))))
93
94; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
95
96(define (macro-expand expr env)
97  (apply (lookup-macro (car expr) env) (cdr expr)))
98
99; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
100
101(define (comp-var expr env)
102  (variable expr)
103  (gen-var-ref (lookup-var expr env)))
104
105; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
106
107(define (comp-self-eval expr env)
108  (gen-cst expr))
109
110; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
111
112(define (comp-quote expr env)
113  (shape expr 2)
114  (gen-cst (cadr expr)))
115
116; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
117
118(define (comp-quasiquote expr env)
119  (comp-quasiquotation (cadr expr) 1 env))
120
121(define (comp-quasiquotation form level env)
122  (cond ((= level 0)
123         (scheme-comp form env))
124        ((pair? form)
125         (cond
126           ((eq? (car form) 'quasiquote)
127            (comp-quasiquotation-list form (+ level 1) env))
128           ((eq? (car form) 'unquote)
129            (if (= level 1)
130              (scheme-comp (cadr form) env)
131              (comp-quasiquotation-list form (- level 1) env)))
132           ((eq? (car form) 'unquote-splicing)
133            (if (= level 1)
134              (scheme-error "Ill-placed 'unquote-splicing'" form))
135            (comp-quasiquotation-list form (- level 1) env))
136           (else
137            (comp-quasiquotation-list form level env))))
138        ((vector? form)
139         (gen-vector-form
140           (comp-quasiquotation-list (vector->lst form) level env)))
141        (else
142         (gen-cst form))))
143
144(define (comp-quasiquotation-list l level env)
145  (if (pair? l)
146    (let ((first (car l)))
147      (if (= level 1)
148        (if (unquote-splicing? first)
149          (begin
150            (shape first 2)
151            (gen-append-form (scheme-comp (cadr first) env)
152                             (comp-quasiquotation (cdr l) 1 env)))
153          (gen-cons-form (comp-quasiquotation first level env)
154                         (comp-quasiquotation (cdr l) level env)))
155        (gen-cons-form (comp-quasiquotation first level env)
156                       (comp-quasiquotation (cdr l) level env))))
157    (comp-quasiquotation l level env)))
158
159(define (unquote-splicing? x)
160  (if (pair? x)
161    (if (eq? (car x) 'unquote-splicing) #t #f)
162    #f))
163
164; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
165
166(define (comp-unquote expr env)
167  (scheme-error "Ill-placed 'unquote'" expr))
168
169; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
170
171(define (comp-unquote-splicing expr env)
172  (scheme-error "Ill-placed 'unquote-splicing'" expr))
173
174; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
175
176(define (comp-set! expr env)
177  (shape expr 3)
178  (variable (cadr expr))
179  (gen-var-set (lookup-var (cadr expr) env) (scheme-comp (caddr expr) env)))
180
181; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
182
183(define (comp-lambda expr env)
184  (shape expr 3)
185  (let ((parms (cadr expr)))
186    (let ((frame (parms->frame parms)))
187      (let ((nb-vars (length frame))
188            (code (comp-body (cddr expr) (push-frame frame env))))
189        (if (rest-param? parms)
190          (gen-lambda-rest nb-vars code)
191          (gen-lambda nb-vars code))))))
192
193(define (parms->frame parms)
194  (cond ((null? parms)
195         '())
196        ((pair? parms)
197         (let ((x (car parms)))
198           (variable x)
199           (cons x (parms->frame (cdr parms)))))
200        (else
201         (variable parms)
202         (list parms))))
203
204(define (rest-param? parms)
205  (cond ((pair? parms)
206         (rest-param? (cdr parms)))
207        ((null? parms)
208         #f)
209        (else
210         #t)))
211
212(define (comp-body body env)
213
214  (define (letrec-defines vars vals body env)
215    (if (pair? body)
216
217      (let ((expr (car body)))
218        (cond ((not (pair? expr))
219               (letrec-defines* vars vals body env))
220              ((macro? (car expr) env)
221               (letrec-defines vars
222                               vals
223                               (cons (macro-expand expr env) (cdr body))
224                               env))
225              (else
226               (cond
227                 ((eq? (car expr) 'begin)
228                  (letrec-defines vars
229                                  vals
230                                  (append (cdr expr) (cdr body))
231                                  env))
232                 ((eq? (car expr) 'define)
233                  (let ((x (definition-name expr)))
234                    (variable x)
235                    (letrec-defines (cons x vars)
236                                    (cons (definition-value expr) vals)
237                                    (cdr body)
238                                    env)))
239                 ((eq? (car expr) 'define-macro)
240                  (let ((x (definition-name expr)))
241                    (letrec-defines vars
242                                    vals
243                                    (cdr body)
244                                    (push-macro
245                                      x
246                                      (scheme-eval (definition-value expr))
247                                      env))))
248                 (else
249                  (letrec-defines* vars vals body env))))))
250
251      (scheme-error "Body must contain at least one evaluable expression")))
252
253  (define (letrec-defines* vars vals body env)
254    (if (null? vars)
255      (comp-sequence body env)
256      (comp-letrec-aux vars vals body env)))
257
258  (letrec-defines '() '() body env))
259
260(define (definition-name expr)
261  (shape expr 3)
262  (let ((pattern (cadr expr)))
263    (let ((name (if (pair? pattern) (car pattern) pattern)))
264      (if (not (symbol? name))
265        (scheme-error "Identifier expected" name))
266      name)))
267
268(define (definition-value expr)
269  (let ((pattern (cadr expr)))
270    (if (pair? pattern)
271      (cons 'lambda (cons (cdr pattern) (cddr expr)))
272      (caddr expr))))
273
274; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
275
276(define (comp-if expr env)
277  (shape expr 3)
278  (let ((code1 (scheme-comp (cadr expr) env))
279        (code2 (scheme-comp (caddr expr) env)))
280    (if (pair? (cdddr expr))
281      (gen-if code1 code2 (scheme-comp (cadddr expr) env))
282      (gen-when code1 code2))))
283
284; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
285
286(define (comp-cond expr env)
287  (comp-cond-aux (cdr expr) env))
288
289(define (comp-cond-aux clauses env)
290  (if (pair? clauses)
291    (let ((clause (car clauses)))
292      (shape clause 1)
293      (cond ((eq? (car clause) 'else)
294             (shape clause 2)
295             (comp-sequence (cdr clause) env))
296            ((not (pair? (cdr clause)))
297             (gen-or (scheme-comp (car clause) env)
298                     (comp-cond-aux (cdr clauses) env)))
299            ((eq? (cadr clause) '=>)
300             (shape clause 3)
301             (gen-cond-send (scheme-comp (car clause) env)
302                            (scheme-comp (caddr clause) env)
303                            (comp-cond-aux (cdr clauses) env)))
304            (else
305             (gen-if (scheme-comp (car clause) env)
306                     (comp-sequence (cdr clause) env)
307                     (comp-cond-aux (cdr clauses) env)))))
308    (gen-cst '())))
309
310; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
311
312(define (comp-and expr env)
313  (let ((rest (cdr expr)))
314    (if (pair? rest) (comp-and-aux rest env) (gen-cst #t))))
315
316(define (comp-and-aux l env)
317  (let ((code (scheme-comp (car l) env))
318        (rest (cdr l)))
319    (if (pair? rest) (gen-and code (comp-and-aux rest env)) code)))
320
321; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
322
323(define (comp-or expr env)
324  (let ((rest (cdr expr)))
325    (if (pair? rest) (comp-or-aux rest env) (gen-cst #f))))
326
327(define (comp-or-aux l env)
328  (let ((code (scheme-comp (car l) env))
329        (rest (cdr l)))
330    (if (pair? rest) (gen-or code (comp-or-aux rest env)) code)))
331
332; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
333
334(define (comp-case expr env)
335  (shape expr 3)
336  (gen-case (scheme-comp (cadr expr) env)
337            (comp-case-aux (cddr expr) env)))
338
339(define (comp-case-aux clauses env)
340  (if (pair? clauses)
341    (let ((clause (car clauses)))
342      (shape clause 2)
343      (if (eq? (car clause) 'else)
344        (gen-case-else (comp-sequence (cdr clause) env))
345        (gen-case-clause (car clause)
346                         (comp-sequence (cdr clause) env)
347                         (comp-case-aux (cdr clauses) env))))
348    (gen-case-else (gen-cst '()))))
349
350; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
351
352(define (comp-let expr env)
353  (shape expr 3)
354  (let ((x (cadr expr)))
355    (cond ((symbol? x)
356           (shape expr 4)
357           (let ((y (caddr expr)))
358             (let ((proc (cons 'lambda (cons (bindings->vars y) (cdddr expr)))))
359               (scheme-comp (cons (list 'letrec (list (list x proc)) x)
360                                  (bindings->vals y))
361                            env))))
362          ((pair? x)
363           (scheme-comp (cons (cons 'lambda (cons (bindings->vars x) (cddr expr)))
364                              (bindings->vals x))
365                        env))
366          (else
367           (comp-body (cddr expr) env)))))
368
369(define (bindings->vars bindings)
370  (if (pair? bindings)
371    (let ((binding (car bindings)))
372      (shape binding 2)
373      (let ((x (car binding)))
374        (variable x)
375        (cons x (bindings->vars (cdr bindings)))))
376    '()))
377
378(define (bindings->vals bindings)
379  (if (pair? bindings)
380    (let ((binding (car bindings)))
381      (cons (cadr binding) (bindings->vals (cdr bindings))))
382    '()))
383
384; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
385
386(define (comp-let* expr env)
387  (shape expr 3)
388  (let ((bindings (cadr expr)))
389    (if (pair? bindings)
390      (scheme-comp (list 'let
391                         (list (car bindings))
392                         (cons 'let* (cons (cdr bindings) (cddr expr))))
393                   env)
394      (comp-body (cddr expr) env))))
395
396; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
397
398(define (comp-letrec expr env)
399  (shape expr 3)
400  (let ((bindings (cadr expr)))
401    (comp-letrec-aux (bindings->vars bindings)
402                     (bindings->vals bindings)
403                     (cddr expr)
404                     env)))
405
406(define (comp-letrec-aux vars vals body env)
407  (if (pair? vars)
408    (let ((new-env (push-frame vars env)))
409      (gen-letrec (comp-vals vals new-env)
410                  (comp-body body new-env)))
411    (comp-body body env)))
412
413(define (comp-vals l env)
414  (if (pair? l)
415    (cons (scheme-comp (car l) env) (comp-vals (cdr l) env))
416    '()))
417
418; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
419
420(define (comp-begin expr env)
421  (shape expr 2)
422  (comp-sequence (cdr expr) env))
423
424(define (comp-sequence exprs env)
425  (if (pair? exprs)
426    (comp-sequence-aux exprs env)
427    (gen-cst '())))
428
429(define (comp-sequence-aux exprs env)
430  (let ((code (scheme-comp (car exprs) env))
431        (rest (cdr exprs)))
432    (if (pair? rest) (gen-sequence code (comp-sequence-aux rest env)) code)))
433
434; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
435
436(define (comp-do expr env)
437  (shape expr 3)
438  (let ((bindings (cadr expr))
439        (exit (caddr expr)))
440    (shape exit 1)
441    (let* ((vars (bindings->vars bindings))
442           (new-env1 (push-frame '(#f) env))
443           (new-env2 (push-frame vars new-env1)))
444      (gen-letrec
445        (list
446          (gen-lambda
447            (length vars)
448            (gen-if
449              (scheme-comp (car exit) new-env2)
450              (comp-sequence (cdr exit) new-env2)
451              (gen-sequence
452                (comp-sequence (cdddr expr) new-env2)
453                (gen-combination
454                  (gen-var-ref '(1 . 1))
455                  (comp-vals (bindings->steps bindings) new-env2))))))
456        (gen-combination
457          (gen-var-ref '(0 . 1))
458          (comp-vals (bindings->vals bindings) new-env1))))))
459
460(define (bindings->steps bindings)
461  (if (pair? bindings)
462    (let ((binding (car bindings)))
463      (cons (if (pair? (cddr binding)) (caddr binding) (car binding))
464            (bindings->steps (cdr bindings))))
465    '()))
466
467; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
468
469(define (comp-define expr env)
470  (shape expr 3)
471  (let ((pattern (cadr expr)))
472    (let ((x (if (pair? pattern) (car pattern) pattern)))
473      (variable x)
474      (gen-sequence
475        (gen-var-set (lookup-var x env)
476                     (scheme-comp (if (pair? pattern)
477                                    (cons 'lambda (cons (cdr pattern) (cddr expr)))
478                                    (caddr expr))
479                                  env))
480        (gen-cst x)))))
481
482; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
483
484(define (comp-define-macro expr env)
485  (let ((x (definition-name expr)))
486    (gen-macro x (scheme-eval (definition-value expr)))))
487
488; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
489
490(define (comp-combination expr env)
491  (gen-combination (scheme-comp (car expr) env) (comp-vals (cdr expr) env)))
492
493;------------------------------------------------------------------------------
494
495(define (gen-var-ref var)
496  (if (pair? var)
497    (gen-rte-ref (car var) (cdr var))
498    (gen-glo-ref (scheme-global-var var))))
499
500(define (gen-rte-ref up over)
501  (case up
502    ((0)  (gen-slot-ref-0 over))
503    ((1)  (gen-slot-ref-1 over))
504    (else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over)))))
505
506(define (gen-slot-ref-0 i)
507  (case i
508    ((0)  (lambda (rte) (vector-ref rte 0)))
509    ((1)  (lambda (rte) (vector-ref rte 1)))
510    ((2)  (lambda (rte) (vector-ref rte 2)))
511    ((3)  (lambda (rte) (vector-ref rte 3)))
512    (else (lambda (rte) (vector-ref rte i)))))
513
514(define (gen-slot-ref-1 i)
515  (case i
516    ((0)  (lambda (rte) (vector-ref (vector-ref rte 0) 0)))
517    ((1)  (lambda (rte) (vector-ref (vector-ref rte 0) 1)))
518    ((2)  (lambda (rte) (vector-ref (vector-ref rte 0) 2)))
519    ((3)  (lambda (rte) (vector-ref (vector-ref rte 0) 3)))
520    (else (lambda (rte) (vector-ref (vector-ref rte 0) i)))))
521
522(define (gen-slot-ref-up-2 code)
523  (lambda (rte) (code (vector-ref (vector-ref rte 0) 0))))
524
525(define (gen-glo-ref i)
526  (lambda (rte) (scheme-global-var-ref i)))
527
528; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
529
530(define (gen-cst val)
531  (case val
532    ((()) (lambda (rte) '()))
533    ((#f) (lambda (rte) #f))
534    ((#t) (lambda (rte) #t))
535    ((-2) (lambda (rte) -2))
536    ((-1) (lambda (rte) -1))
537    ((0)  (lambda (rte) 0))
538    ((1)  (lambda (rte) 1))
539    ((2)  (lambda (rte) 2))
540    (else (lambda (rte) val))))
541
542; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
543
544(define (gen-append-form code1 code2)
545  (lambda (rte) (append (code1 rte) (code2 rte))))
546
547(define (gen-cons-form code1 code2)
548  (lambda (rte) (cons (code1 rte) (code2 rte))))
549
550(define (gen-vector-form code)
551  (lambda (rte) (lst->vector (code rte))))
552
553; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
554
555(define (gen-var-set var code)
556  (if (pair? var)
557    (gen-rte-set (car var) (cdr var) code)
558    (gen-glo-set (scheme-global-var var) code)))
559
560(define (gen-rte-set up over code)
561  (case up
562    ((0)  (gen-slot-set-0 over code))
563    ((1)  (gen-slot-set-1 over code))
564    (else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code))))
565
566(define (gen-slot-set-0 i code)
567  (case i
568    ((0)  (lambda (rte) (vector-set! rte 0 (code rte))))
569    ((1)  (lambda (rte) (vector-set! rte 1 (code rte))))
570    ((2)  (lambda (rte) (vector-set! rte 2 (code rte))))
571    ((3)  (lambda (rte) (vector-set! rte 3 (code rte))))
572    (else (lambda (rte) (vector-set! rte i (code rte))))))
573
574(define (gen-slot-set-1 i code)
575  (case i
576    ((0)  (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte))))
577    ((1)  (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte))))
578    ((2)  (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte))))
579    ((3)  (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte))))
580    (else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte))))))
581
582(define (gen-slot-set-n up i code)
583  (case i
584    ((0)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte))))
585    ((1)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte))))
586    ((2)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte))))
587    ((3)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte))))
588    (else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte))))))
589
590(define (gen-glo-set i code)
591  (lambda (rte) (scheme-global-var-set! i (code rte))))
592
593; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
594
595(define (gen-lambda-rest nb-vars body)
596  (case nb-vars
597    ((1)  (gen-lambda-1-rest body))
598    ((2)  (gen-lambda-2-rest body))
599    ((3)  (gen-lambda-3-rest body))
600    (else (gen-lambda-n-rest nb-vars body))))
601
602(define (gen-lambda-1-rest body)
603  (lambda (rte)
604    (lambda a
605      (body (vector rte a)))))
606
607(define (gen-lambda-2-rest body)
608  (lambda (rte)
609    (lambda (a . b)
610      (body (vector rte a b)))))
611
612(define (gen-lambda-3-rest body)
613  (lambda (rte)
614    (lambda (a b . c)
615      (body (vector rte a b c)))))
616
617(define (gen-lambda-n-rest nb-vars body)
618  (lambda (rte)
619    (lambda (a b c . d)
620      (let ((x (make-vector (+ nb-vars 1))))
621        (vector-set! x 0 rte)
622        (vector-set! x 1 a)
623        (vector-set! x 2 b)
624        (vector-set! x 3 c)
625        (let loop ((n nb-vars) (x x) (i 4) (l d))
626          (if (< i n)
627            (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l)))
628            (vector-set! x i l)))
629        (body x)))))
630
631(define (gen-lambda nb-vars body)
632  (case nb-vars
633    ((0)  (gen-lambda-0 body))
634    ((1)  (gen-lambda-1 body))
635    ((2)  (gen-lambda-2 body))
636    ((3)  (gen-lambda-3 body))
637    (else (gen-lambda-n nb-vars body))))
638
639(define (gen-lambda-0 body)
640  (lambda (rte)
641    (lambda ()
642      (body rte))))
643
644(define (gen-lambda-1 body)
645  (lambda (rte)
646    (lambda (a)
647      (body (vector rte a)))))
648
649(define (gen-lambda-2 body)
650  (lambda (rte)
651    (lambda (a b)
652      (body (vector rte a b)))))
653
654(define (gen-lambda-3 body)
655  (lambda (rte)
656    (lambda (a b c)
657      (body (vector rte a b c)))))
658
659(define (gen-lambda-n nb-vars body)
660  (lambda (rte)
661    (lambda (a b c . d)
662      (let ((x (make-vector (+ nb-vars 1))))
663        (vector-set! x 0 rte)
664        (vector-set! x 1 a)
665        (vector-set! x 2 b)
666        (vector-set! x 3 c)
667        (let loop ((n nb-vars) (x x) (i 4) (l d))
668          (if (<= i n)
669            (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l)))))
670        (body x)))))
671
672; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
673
674(define (gen-sequence code1 code2)
675  (lambda (rte) (code1 rte) (code2 rte)))
676
677; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
678
679(define (gen-when code1 code2)
680  (lambda (rte)
681    (if (code1 rte)
682      (code2 rte)
683      '())))
684
685(define (gen-if code1 code2 code3)
686  (lambda (rte)
687    (if (code1 rte)
688      (code2 rte)
689      (code3 rte))))
690
691; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
692
693(define (gen-cond-send code1 code2 code3)
694  (lambda (rte)
695    (let ((temp (code1 rte)))
696      (if temp
697        ((code2 rte) temp)
698        (code3 rte)))))
699
700; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
701
702(define (gen-and code1 code2)
703  (lambda (rte)
704    (let ((temp (code1 rte)))
705      (if temp
706        (code2 rte)
707        temp))))
708
709; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
710
711(define (gen-or code1 code2)
712  (lambda (rte)
713    (let ((temp (code1 rte)))
714      (if temp
715        temp
716        (code2 rte)))))
717
718; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
719
720(define (gen-case code1 code2)
721  (lambda (rte) (code2 rte (code1 rte))))
722
723(define (gen-case-clause datums code1 code2)
724  (lambda (rte key) (if (memv key datums) (code1 rte) (code2 rte key))))
725
726(define (gen-case-else code)
727  (lambda (rte key) (code rte)))
728
729; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
730
731(define (gen-letrec vals body)
732  (let ((nb-vals (length vals)))
733    (case nb-vals
734      ((1)  (gen-letrec-1 (car vals) body))
735      ((2)  (gen-letrec-2 (car vals) (cadr vals) body))
736      ((3)  (gen-letrec-3 (car vals) (cadr vals) (caddr vals) body))
737      (else (gen-letrec-n nb-vals vals body)))))
738
739(define (gen-letrec-1 val1 body)
740  (lambda (rte)
741    (let ((x (vector rte #f)))
742      (vector-set! x 1 (val1 x))
743      (body x))))
744
745(define (gen-letrec-2 val1 val2 body)
746  (lambda (rte)
747    (let ((x (vector rte #f #f)))
748      (vector-set! x 1 (val1 x))
749      (vector-set! x 2 (val2 x))
750      (body x))))
751
752(define (gen-letrec-3 val1 val2 val3 body)
753  (lambda (rte)
754    (let ((x (vector rte #f #f #f)))
755      (vector-set! x 1 (val1 x))
756      (vector-set! x 2 (val2 x))
757      (vector-set! x 3 (val3 x))
758      (body x))))
759
760(define (gen-letrec-n nb-vals vals body)
761  (lambda (rte)
762    (let ((x (make-vector (+ nb-vals 1))))
763      (vector-set! x 0 rte)
764      (let loop ((x x) (i 1) (l vals))
765        (if (pair? l)
766          (begin (vector-set! x i ((car l) x)) (loop x (+ i 1) (cdr l)))))
767      (body x))))
768
769; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
770
771(define (gen-macro name proc)
772  (lambda (rte) (scheme-add-macro name proc)))
773
774; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
775
776(define (gen-combination oper args)
777  (case (length args)
778    ((0)  (gen-combination-0 oper))
779    ((1)  (gen-combination-1 oper (car args)))
780    ((2)  (gen-combination-2 oper (car args) (cadr args)))
781    ((3)  (gen-combination-3 oper (car args) (cadr args) (caddr args)))
782    (else (gen-combination-n oper args))))
783
784(define (gen-combination-0 oper)
785  (lambda (rte) ((oper rte))))
786
787(define (gen-combination-1 oper arg1)
788  (lambda (rte) ((oper rte) (arg1 rte))))
789
790(define (gen-combination-2 oper arg1 arg2)
791  (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte))))
792
793(define (gen-combination-3 oper arg1 arg2 arg3)
794  (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte) (arg3 rte))))
795
796(define (gen-combination-n oper args)
797  (lambda (rte)
798    (define (evaluate l rte)
799      (if (pair? l)
800        (cons ((car l) rte) (evaluate (cdr l) rte))
801        '()))
802    (apply (oper rte) (evaluate args rte))))
803
804; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
805
806(define (scheme-comp expr env)
807  (cond ((symbol? expr)
808         (comp-var expr env))
809        ((not (pair? expr))
810         (comp-self-eval expr env))
811        ((macro? (car expr) env)
812         (scheme-comp (macro-expand expr env) env))
813        (else
814         (cond
815           ((eq? (car expr) 'quote)            (comp-quote expr env))
816           ((eq? (car expr) 'quasiquote)       (comp-quasiquote expr env))
817           ((eq? (car expr) 'unquote)          (comp-unquote expr env))
818           ((eq? (car expr) 'unquote-splicing) (comp-unquote-splicing expr env))
819           ((eq? (car expr) 'set!)             (comp-set! expr env))
820           ((eq? (car expr) 'lambda)           (comp-lambda expr env))
821           ((eq? (car expr) 'if)               (comp-if expr env))
822           ((eq? (car expr) 'cond)             (comp-cond expr env))
823           ((eq? (car expr) 'and)              (comp-and expr env))
824           ((eq? (car expr) 'or)               (comp-or expr env))
825           ((eq? (car expr) 'case)             (comp-case expr env))
826           ((eq? (car expr) 'let)              (comp-let expr env))
827           ((eq? (car expr) 'let*)             (comp-let* expr env))
828           ((eq? (car expr) 'letrec)           (comp-letrec expr env))
829           ((eq? (car expr) 'begin)            (comp-begin expr env))
830           ((eq? (car expr) 'do)               (comp-do expr env))
831           ((eq? (car expr) 'define)           (comp-define expr env))
832           ((eq? (car expr) 'define-macro)     (comp-define-macro expr env))
833           (else                               (comp-combination expr env))))))
834
835; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
836
837(define (scheme-global-var name)
838  (let ((x (assq name scheme-global-variables)))
839    (if x
840      x
841      (let ((y (cons name '())))
842        (set! scheme-global-variables (cons y scheme-global-variables))
843        y))))
844
845(define (scheme-global-var-ref i)
846  (cdr i))
847
848(define (scheme-global-var-set! i val)
849  (set-cdr! i val)
850  '())
851
852(define scheme-global-variables '())
853
854(define (def-proc name value)
855  (scheme-global-var-set!
856    (scheme-global-var name)
857    value))
858
859(def-proc 'not                            (lambda (x) (not x)))
860(def-proc 'boolean?                       boolean?)
861(def-proc 'eqv?                           eqv?)
862(def-proc 'eq?                            eq?)
863(def-proc 'equal?                         equal?)
864(def-proc 'pair?                          (lambda (obj) (pair? obj)))
865(def-proc 'cons                           (lambda (x y) (cons x y)))
866(def-proc 'car                            (lambda (x) (car x)))
867(def-proc 'cdr                            (lambda (x) (cdr x)))
868(def-proc 'set-car!                       set-car!)
869(def-proc 'set-cdr!                       set-cdr!)
870(def-proc 'caar                           caar)
871(def-proc 'cadr                           cadr)
872(def-proc 'cdar                           cdar)
873(def-proc 'cddr                           cddr)
874(def-proc 'caaar                          caaar)
875(def-proc 'caadr                          caadr)
876(def-proc 'cadar                          cadar)
877(def-proc 'caddr                          caddr)
878(def-proc 'cdaar                          cdaar)
879(def-proc 'cdadr                          cdadr)
880(def-proc 'cddar                          cddar)
881(def-proc 'cdddr                          cdddr)
882(def-proc 'caaaar                         caaaar)
883(def-proc 'caaadr                         caaadr)
884(def-proc 'caadar                         caadar)
885(def-proc 'caaddr                         caaddr)
886(def-proc 'cadaar                         cadaar)
887(def-proc 'cadadr                         cadadr)
888(def-proc 'caddar                         caddar)
889(def-proc 'cadddr                         cadddr)
890(def-proc 'cdaaar                         cdaaar)
891(def-proc 'cdaadr                         cdaadr)
892(def-proc 'cdadar                         cdadar)
893(def-proc 'cdaddr                         cdaddr)
894(def-proc 'cddaar                         cddaar)
895(def-proc 'cddadr                         cddadr)
896(def-proc 'cdddar                         cdddar)
897(def-proc 'cddddr                         cddddr)
898(def-proc 'null?                          (lambda (x) (null? x)))
899(def-proc 'list?                          list?)
900(def-proc 'list                           list)
901(def-proc 'length                         length)
902(def-proc 'append                         append)
903(def-proc 'reverse                        reverse)
904(def-proc 'list-ref                       list-ref)
905(def-proc 'memq                           memq)
906(def-proc 'memv                           memv)
907(def-proc 'member                         member)
908(def-proc 'assq                           assq)
909(def-proc 'assv                           assv)
910(def-proc 'assoc                          assoc)
911(def-proc 'symbol?                        symbol?)
912(def-proc 'symbol->string                 symbol->string)
913(def-proc 'string->symbol                 string->symbol)
914(def-proc 'number?                        number?)
915(def-proc 'complex?                       complex?)
916(def-proc 'real?                          real?)
917(def-proc 'rational?                      rational?)
918(def-proc 'integer?                       integer?)
919(def-proc 'exact?                         exact?)
920(def-proc 'inexact?                       inexact?)
921;(def-proc '=                              =)
922;(def-proc '<                              <)
923;(def-proc '>                              >)
924;(def-proc '<=                             <=)
925;(def-proc '>=                             >=)
926;(def-proc 'zero?                          zero?)
927;(def-proc 'positive?                      positive?)
928;(def-proc 'negative?                      negative?)
929;(def-proc 'odd?                           odd?)
930;(def-proc 'even?                          even?)
931(def-proc 'max                            max)
932(def-proc 'min                            min)
933;(def-proc '+                              +)
934;(def-proc '*                              *)
935;(def-proc '-                              -)
936(def-proc '/                              /)
937(def-proc 'abs                            abs)
938;(def-proc 'quotient                       quotient)
939;(def-proc 'remainder                      remainder)
940;(def-proc 'modulo                         modulo)
941(def-proc 'gcd                            gcd)
942(def-proc 'lcm                            lcm)
943;(def-proc 'numerator                      numerator)
944;(def-proc 'denominator                    denominator)
945(def-proc 'floor                          floor)
946(def-proc 'ceiling                        ceiling)
947(def-proc 'truncate                       truncate)
948(def-proc 'round                          round)
949;(def-proc 'rationalize                    rationalize)
950(def-proc 'exp                            exp)
951(def-proc 'log                            log)
952(def-proc 'sin                            sin)
953(def-proc 'cos                            cos)
954(def-proc 'tan                            tan)
955(def-proc 'asin                           asin)
956(def-proc 'acos                           acos)
957(def-proc 'atan                           atan)
958(def-proc 'sqrt                           sqrt)
959(def-proc 'expt                           expt)
960;(def-proc 'make-rectangular               make-rectangular)
961;(def-proc 'make-polar                     make-polar)
962;(def-proc 'real-part                      real-part)
963;(def-proc 'imag-part                      imag-part)
964;(def-proc 'magnitude                      magnitude)
965;(def-proc 'angle                          angle)
966(def-proc 'exact->inexact                 exact->inexact)
967(def-proc 'inexact->exact                 inexact->exact)
968(def-proc 'number->string                 number->string)
969(def-proc 'string->number                 string->number)
970(def-proc 'char?                          char?)
971(def-proc 'char=?                         char=?)
972(def-proc 'char<?                         char<?)
973(def-proc 'char>?                         char>?)
974(def-proc 'char<=?                        char<=?)
975(def-proc 'char>=?                        char>=?)
976(def-proc 'char-ci=?                      char-ci=?)
977(def-proc 'char-ci<?                      char-ci<?)
978(def-proc 'char-ci>?                      char-ci>?)
979(def-proc 'char-ci<=?                     char-ci<=?)
980(def-proc 'char-ci>=?                     char-ci>=?)
981(def-proc 'char-alphabetic?               char-alphabetic?)
982(def-proc 'char-numeric?                  char-numeric?)
983(def-proc 'char-whitespace?               char-whitespace?)
984(def-proc 'char-lower-case?               char-lower-case?)
985(def-proc 'char->integer                  char->integer)
986(def-proc 'integer->char                  integer->char)
987(def-proc 'char-upcase                    char-upcase)
988(def-proc 'char-downcase                  char-downcase)
989(def-proc 'string?                        string?)
990(def-proc 'make-string                    make-string)
991(def-proc 'string                         string)
992(def-proc 'string-length                  string-length)
993(def-proc 'string-ref                     string-ref)
994(def-proc 'string-set!                    string-set!)
995(def-proc 'string=?                       string=?)
996(def-proc 'string<?                       string<?)
997(def-proc 'string>?                       string>?)
998(def-proc 'string<=?                      string<=?)
999(def-proc 'string>=?                      string>=?)
1000(def-proc 'string-ci=?                    string-ci=?)
1001(def-proc 'string-ci<?                    string-ci<?)
1002(def-proc 'string-ci>?                    string-ci>?)
1003(def-proc 'string-ci<=?                   string-ci<=?)
1004(def-proc 'string-ci>=?                   string-ci>=?)
1005(def-proc 'substring                      substring)
1006(def-proc 'string-append                  string-append)
1007(def-proc 'vector?                        vector?)
1008(def-proc 'make-vector                    make-vector)
1009(def-proc 'vector                         vector)
1010(def-proc 'vector-length                  vector-length)
1011(def-proc 'vector-ref                     vector-ref)
1012(def-proc 'vector-set!                    vector-set!)
1013(def-proc 'procedure?                     procedure?)
1014(def-proc 'apply                          apply)
1015(def-proc 'map                            map)
1016(def-proc 'for-each                       for-each)
1017;(def-proc 'call-with-current-continuation call-with-current-continuation)
1018(def-proc 'call-with-input-file           call-with-input-file)
1019(def-proc 'call-with-output-file          call-with-output-file)
1020(def-proc 'input-port?                    input-port?)
1021(def-proc 'output-port?                   output-port?)
1022(def-proc 'current-input-port             current-input-port)
1023(def-proc 'current-output-port            current-output-port)
1024(def-proc 'open-input-file                open-input-file)
1025(def-proc 'open-output-file               open-output-file)
1026(def-proc 'close-input-port               close-input-port)
1027(def-proc 'close-output-port              close-output-port)
1028(def-proc 'eof-object?                    eof-object?)
1029(def-proc 'read                           read)
1030(def-proc 'read-char                      read-char)
1031(def-proc 'peek-char                      peek-char)
1032(def-proc 'write                          write)
1033(def-proc 'display                        display)
1034(def-proc 'newline                        newline)
1035(def-proc 'write-char                     write-char)
1036
1037; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1038
1039(define (main . args)
1040  (run-benchmark
1041    "scheme"
1042    scheme-iters
1043    (lambda (result)
1044      (equal? result
1045              '("eight" "eleven" "five" "four" "nine" "one"
1046                "seven" "six" "ten" "three" "twelve" "two")))
1047    (lambda (expr) (lambda () (scheme-eval expr)))
1048    '(let ()
1049
1050       (define (sort-list obj pred)
1051
1052         (define (loop l)
1053           (if (and (pair? l) (pair? (cdr l)))
1054               (split l '() '())
1055               l))
1056
1057         (define (split l one two)
1058           (if (pair? l)
1059               (split (cdr l) two (cons (car l) one))
1060               (merge (loop one) (loop two))))
1061
1062         (define (merge one two)
1063           (cond ((null? one) two)
1064                 ((pred (car two) (car one))
1065                  (cons (car two)
1066                        (merge (cdr two) one)))
1067                 (else
1068                  (cons (car one)
1069                        (merge (cdr one) two)))))
1070
1071         (loop obj))
1072
1073       (sort-list '("one" "two" "three" "four" "five" "six"
1074                    "seven" "eight" "nine" "ten" "eleven" "twelve")
1075                  string<?))))
1076