1 | ;;;; syntax-case.scm |
---|
2 | ; |
---|
3 | |
---|
4 | |
---|
5 | (declare |
---|
6 | (unit syntax-case) |
---|
7 | (interrupts-disabled) |
---|
8 | (number-type fixnum) |
---|
9 | (standard-bindings) |
---|
10 | (extended-bindings) ) |
---|
11 | |
---|
12 | (cond-expand |
---|
13 | [paranoia] |
---|
14 | [else |
---|
15 | (declare |
---|
16 | (no-bound-checks) ) ] ) |
---|
17 | |
---|
18 | #{syncase |
---|
19 | list* eval-hook expand-install-hook error-hook new-symbol-hook global-definitions put-global-definition-hook |
---|
20 | get-global-definition-hook |
---|
21 | build-application build-conditional build-lexical-reference build-lexical-assignment build-global-reference |
---|
22 | build-global-assignment build-lambda build-improper-lambda build-data build-identifier build-sequence |
---|
23 | build-letrec build-global-definition syntax-dispatch install-global-transformer |
---|
24 | install-macro-package srfi-0-def std-defs install-macro-defs} |
---|
25 | |
---|
26 | (declare |
---|
27 | (hide syncase-dispatch build-lambda build-improper-lambda build-data srfi-0-def list* |
---|
28 | expand-install-hook eval-hook new-symbol-hook std-defs get-global-definition-hook |
---|
29 | put-global-definition-hook build-sequence build-letrec build-global-assignment |
---|
30 | build-lexical-assignment global-definitions error-hook build-application |
---|
31 | build-conditional install-global-transformer build-global-definition build-identifier |
---|
32 | build-lexical-reference build-global-reference) ) |
---|
33 | |
---|
34 | |
---|
35 | ;;; compat.ss |
---|
36 | ;;; Robert Hieb & Kent Dybvig |
---|
37 | ;;; 92/06/18 |
---|
38 | |
---|
39 | ;;; This file contains nonstandard help procedures. |
---|
40 | ;;; They are all present in Chez Scheme, but are easily defined |
---|
41 | ;;; in any standard Scheme system. |
---|
42 | ;;; These versions do no error checking. |
---|
43 | |
---|
44 | |
---|
45 | ;;; hooks.ss |
---|
46 | ;;; Robert Hieb & Kent Dybvig |
---|
47 | ;;; 92/06/18 |
---|
48 | |
---|
49 | (define (list* first . rest) |
---|
50 | (let recur ((x first) (rest rest)) |
---|
51 | (if (pair? rest) |
---|
52 | (cons x (recur (car rest) (cdr rest))) |
---|
53 | x))) |
---|
54 | |
---|
55 | |
---|
56 | ;;; This file contains procedures that are best defined using |
---|
57 | ;;; nonstandard features. |
---|
58 | ;;; The following work in Chez Scheme. |
---|
59 | |
---|
60 | ;;; eval-hook should be a one-argument "eval". It is used to evaluate |
---|
61 | ;;; macro definitions during macro expansion. Since it receives |
---|
62 | ;;; an expression that has already been expanded, there is no need |
---|
63 | ;;; to reexpand. |
---|
64 | |
---|
65 | (define eval-hook |
---|
66 | (let ([old (##sys#eval-handler)]) |
---|
67 | (lambda (x) (old x)) ) ) |
---|
68 | |
---|
69 | ;;; expand-install-hook takes a one-argument "expand" procedure as |
---|
70 | ;;; an argument, and installs it as the system expander to be |
---|
71 | ;;; invoked on all expressions prior to evaluation. In Chez Scheme, |
---|
72 | ;;; we redefine the current evaluator (used by the read-eval-print |
---|
73 | ;;; loop and load) to invoke expand and call eval-hook on the result. |
---|
74 | |
---|
75 | (define expand-install-hook |
---|
76 | (lambda (expand) |
---|
77 | (##sys#eval-handler (lambda (x . env) (eval-hook (expand x)))) |
---|
78 | (set! ##sys#macroexpand-hook (lambda (x me) x)) |
---|
79 | (set! ##sys#macroexpand-1-hook (lambda (x me) x)) |
---|
80 | (set! ##sys#compiler-toplevel-macroexpand-hook expand) ) ) |
---|
81 | |
---|
82 | |
---|
83 | ;;; In Chez Scheme, the following reports: |
---|
84 | ;;; "Error in <who>: <why> <what>." |
---|
85 | ;;; "who" is a symbol, "why" is a string, and "what" is an arbitrary object. |
---|
86 | |
---|
87 | (define error-hook |
---|
88 | (lambda (who why what) (##sys#error why what who))) |
---|
89 | |
---|
90 | ;;; New symbols are used to generate non-capturing bindings. If it is |
---|
91 | ;;; impossible to generate unique symbols, output identifiers during |
---|
92 | ;;; expansion and either feed the result directly into the compiler or |
---|
93 | ;;; make another pass to perform alpha substitution. |
---|
94 | |
---|
95 | (define new-symbol-hook gensym) |
---|
96 | |
---|
97 | ;;; "put-global-definition-hook" should overwrite existing definitions. |
---|
98 | |
---|
99 | (define global-definitions (make-vector 997 '())) |
---|
100 | |
---|
101 | (define put-global-definition-hook |
---|
102 | (lambda (symbol binding) |
---|
103 | (##sys#hash-table-set! global-definitions symbol binding))) |
---|
104 | |
---|
105 | ;;; "get-global-definition-hook" should return "#f" if no binding |
---|
106 | ;;; has been established "put-global-definition-hook" for the symbol. |
---|
107 | |
---|
108 | (define get-global-definition-hook |
---|
109 | (lambda (symbol) |
---|
110 | (##sys#hash-table-ref global-definitions symbol) ) ) |
---|
111 | |
---|
112 | |
---|
113 | ;;; output.ss |
---|
114 | ;;; Robert Hieb & Kent Dybvig |
---|
115 | ;;; 92/06/18 |
---|
116 | |
---|
117 | ; The output routines can be tailored to feed a specific system or compiler. |
---|
118 | ; They are set up here to generate the following subset of standard Scheme: |
---|
119 | |
---|
120 | ; <expression> :== <application> |
---|
121 | ; | <variable> |
---|
122 | ; | (set! <variable> <expression>) |
---|
123 | ; | (define <variable> <expression>) |
---|
124 | ; | (lambda (<variable>*) <expression>) |
---|
125 | ; | (lambda <variable> <expression>) |
---|
126 | ; | (lambda (<variable>+ . <variable>) <expression>) |
---|
127 | ; | (letrec (<binding>+) <expression>) |
---|
128 | ; | (if <expression> <expression> <expression>) |
---|
129 | ; | (begin <expression> <expression>) |
---|
130 | ; | (quote <datum>) |
---|
131 | ; <application> :== (<expression>+) |
---|
132 | ; <binding> :== (<variable> <expression>) |
---|
133 | ; <variable> :== <symbol> |
---|
134 | |
---|
135 | ; Definitions are generated only at top level. |
---|
136 | |
---|
137 | (define build-application |
---|
138 | (lambda (fun-exp arg-exps) |
---|
139 | `(,fun-exp ,@arg-exps))) |
---|
140 | |
---|
141 | (define build-conditional |
---|
142 | (lambda (test-exp then-exp else-exp) |
---|
143 | `(if ,test-exp ,then-exp ,else-exp))) |
---|
144 | |
---|
145 | (define build-lexical-reference (lambda (var) var)) |
---|
146 | |
---|
147 | (define build-lexical-assignment |
---|
148 | (lambda (var exp) |
---|
149 | `(##core#set! ,var ,exp))) |
---|
150 | |
---|
151 | (define build-global-reference (lambda (var) var)) |
---|
152 | |
---|
153 | (define build-global-assignment |
---|
154 | (lambda (var exp) |
---|
155 | `(##core#set! ,var ,exp))) |
---|
156 | |
---|
157 | (define build-lambda |
---|
158 | (lambda (vars exp) |
---|
159 | `(lambda ,vars ,exp))) |
---|
160 | |
---|
161 | (define build-improper-lambda |
---|
162 | (lambda (vars var exp) |
---|
163 | `(lambda (,@vars . ,var) ,exp))) |
---|
164 | |
---|
165 | (define build-data |
---|
166 | (lambda (exp) |
---|
167 | `(quote ,exp))) |
---|
168 | |
---|
169 | (define build-identifier |
---|
170 | (lambda (id) |
---|
171 | `(quote ,id))) |
---|
172 | |
---|
173 | (define build-sequence |
---|
174 | (lambda (exps) |
---|
175 | (if (null? (cdr exps)) |
---|
176 | (car exps) |
---|
177 | `(begin ,(car exps) ,(build-sequence (cdr exps)))))) |
---|
178 | |
---|
179 | (define build-letrec |
---|
180 | (let ((map map)) |
---|
181 | (lambda (vars val-exps body-exp) |
---|
182 | (if (null? vars) |
---|
183 | body-exp |
---|
184 | `(let ,(##sys#map (lambda (var) (list var '(##core#undefined))) vars) |
---|
185 | (begin ,@(map (lambda (var val) `(##core#set! ,var ,val)) vars val-exps) |
---|
186 | ,body-exp) ) ) ) ) ) |
---|
187 | |
---|
188 | (define build-global-definition |
---|
189 | (lambda (var val) |
---|
190 | `(##core#set! ,var ,val))) |
---|
191 | |
---|
192 | |
---|
193 | ;;; init.ss |
---|
194 | ;;; Robert Hieb & Kent Dybvig |
---|
195 | ;;; 92/06/18 |
---|
196 | |
---|
197 | ; These initializations are done here rather than "expand.ss" so that |
---|
198 | ; "expand.ss" can be loaded twice (for bootstrapping purposes). |
---|
199 | |
---|
200 | (define expand-syntax #f) |
---|
201 | (define syntax-dispatch #f) |
---|
202 | (define generate-temporaries #f) |
---|
203 | (define identifier? #f) |
---|
204 | (define syntax-error #f) |
---|
205 | (define syntax-object->datum #f) |
---|
206 | (define bound-identifier=? #f) |
---|
207 | (define free-identifier=? #f) |
---|
208 | (define install-global-transformer #f) |
---|
209 | (define implicit-identifier #f) |
---|
210 | |
---|
211 | |
---|
212 | (begin ((lambda () |
---|
213 | (letrec ((lambda-var-list (lambda (vars) |
---|
214 | ((letrec ((lvl (lambda (vars ls) |
---|
215 | (if (pair? vars) |
---|
216 | (lvl (cdr vars) |
---|
217 | (cons (car vars) |
---|
218 | ls)) |
---|
219 | (if (id? vars) |
---|
220 | (cons vars |
---|
221 | ls) |
---|
222 | (if (null? |
---|
223 | vars) |
---|
224 | ls |
---|
225 | (if (syntax-object? |
---|
226 | vars) |
---|
227 | (lvl (unwrap |
---|
228 | vars) |
---|
229 | ls) |
---|
230 | (cons vars |
---|
231 | ls)))))))) |
---|
232 | lvl) |
---|
233 | vars |
---|
234 | '()))) |
---|
235 | (gen-var (lambda (id) (gen-sym (id-sym-name id)))) |
---|
236 | (gen-sym (lambda (sym) |
---|
237 | (new-symbol-hook sym) ) ) ; (new-symbol-hook (symbol->string sym)))) |
---|
238 | (strip (lambda (x) |
---|
239 | (if (syntax-object? x) |
---|
240 | (strip (syntax-object-expression x)) |
---|
241 | (if (pair? x) |
---|
242 | ((lambda (a d) |
---|
243 | (if (if (eq? a (car x)) |
---|
244 | (eq? d (cdr x)) |
---|
245 | #f) |
---|
246 | x |
---|
247 | (cons a d))) |
---|
248 | (strip (car x)) |
---|
249 | (strip (cdr x))) |
---|
250 | (if (vector? x) |
---|
251 | ((lambda (old) |
---|
252 | ((lambda (new) |
---|
253 | (if (andmap eq? old new) |
---|
254 | x |
---|
255 | (list->vector new))) |
---|
256 | (map strip old))) |
---|
257 | (vector->list x)) |
---|
258 | x))))) |
---|
259 | (regen (lambda (x) |
---|
260 | ((lambda (g000139) |
---|
261 | (if (memv g000139 '(ref)) |
---|
262 | (build-lexical-reference (cadr x)) |
---|
263 | (if (memv g000139 '(primitive)) |
---|
264 | (build-global-reference (cadr x)) |
---|
265 | (if (memv g000139 '(id)) |
---|
266 | (build-identifier (cadr x)) |
---|
267 | (if (memv g000139 '(quote)) |
---|
268 | (build-data (cadr x)) |
---|
269 | (if (memv |
---|
270 | g000139 |
---|
271 | '(lambda)) |
---|
272 | (build-lambda |
---|
273 | (cadr x) |
---|
274 | (regen (caddr x))) |
---|
275 | (begin g000139 |
---|
276 | (build-application |
---|
277 | (build-global-reference |
---|
278 | (car x)) |
---|
279 | (map regen |
---|
280 | (cdr x)))))))))) |
---|
281 | (car x)))) |
---|
282 | (gen-vector (lambda (x) |
---|
283 | (if (eq? (car x) 'list) |
---|
284 | (list* 'vector (cdr x)) |
---|
285 | (if (eq? (car x) 'quote) |
---|
286 | (list |
---|
287 | 'quote |
---|
288 | (list->vector (cadr x))) |
---|
289 | (list 'list->vector x))))) |
---|
290 | (gen-append (lambda (x y) |
---|
291 | (if (equal? y ''()) |
---|
292 | x |
---|
293 | (list 'append x y)))) |
---|
294 | (gen-cons (lambda (x y) |
---|
295 | (if (eq? (car y) 'list) |
---|
296 | (list* 'list x (cdr y)) |
---|
297 | (if (if (eq? (car x) 'quote) |
---|
298 | (eq? (car y) 'quote) |
---|
299 | #f) |
---|
300 | (list |
---|
301 | 'quote |
---|
302 | (cons (cadr x) (cadr y))) |
---|
303 | (if (equal? y ''()) |
---|
304 | (list 'list x) |
---|
305 | (list 'cons x y)))))) |
---|
306 | (gen-map (lambda (e map-env) |
---|
307 | ((lambda (formals actuals) |
---|
308 | (if (eq? (car e) 'ref) |
---|
309 | (car actuals) |
---|
310 | (if (andmap |
---|
311 | (lambda (x) |
---|
312 | (if (eq? (car x) 'ref) |
---|
313 | (memq (cadr x) |
---|
314 | formals) |
---|
315 | #f)) |
---|
316 | (cdr e)) |
---|
317 | (list* |
---|
318 | 'map |
---|
319 | (list 'primitive (car e)) |
---|
320 | (map ((lambda (r) |
---|
321 | (lambda (x) |
---|
322 | (cdr (assq (cadr x) |
---|
323 | r)))) |
---|
324 | (map cons |
---|
325 | formals |
---|
326 | actuals)) |
---|
327 | (cdr e))) |
---|
328 | (list* |
---|
329 | 'map |
---|
330 | (list 'lambda formals e) |
---|
331 | actuals)))) |
---|
332 | (map cdr map-env) |
---|
333 | (map (lambda (x) (list 'ref (car x))) |
---|
334 | map-env)))) |
---|
335 | (gen-ref (lambda (var level maps k) |
---|
336 | (if (= level 0) |
---|
337 | (k var maps) |
---|
338 | (gen-ref |
---|
339 | var |
---|
340 | (- level 1) |
---|
341 | (cdr maps) |
---|
342 | (lambda (outer-var outer-maps) |
---|
343 | ((lambda (b) |
---|
344 | (if b |
---|
345 | (k (cdr b) maps) |
---|
346 | ((lambda (inner-var) |
---|
347 | (k inner-var |
---|
348 | (cons (cons (cons outer-var |
---|
349 | inner-var) |
---|
350 | (car maps)) |
---|
351 | outer-maps))) |
---|
352 | (gen-sym var)))) |
---|
353 | (assq outer-var (car maps)))))))) |
---|
354 | (chi-syntax (lambda (src exp r w) |
---|
355 | ((letrec ((gen (lambda (e maps k) |
---|
356 | (if (id? e) |
---|
357 | ((lambda (n) |
---|
358 | ((lambda (b) |
---|
359 | (if (eq? (binding-type |
---|
360 | b) |
---|
361 | 'syntax) |
---|
362 | ((lambda (level) |
---|
363 | (if (< (length |
---|
364 | maps) |
---|
365 | level) |
---|
366 | (syntax-error |
---|
367 | src |
---|
368 | "missing ellipsis in") |
---|
369 | (gen-ref |
---|
370 | n |
---|
371 | level |
---|
372 | maps |
---|
373 | (lambda (x |
---|
374 | maps) |
---|
375 | (k (list |
---|
376 | 'ref |
---|
377 | x) |
---|
378 | maps))))) |
---|
379 | (binding-value |
---|
380 | b)) |
---|
381 | (if (ellipsis? |
---|
382 | (wrap e |
---|
383 | w)) |
---|
384 | (syntax-error |
---|
385 | src |
---|
386 | "invalid context for ... in") |
---|
387 | (k (list |
---|
388 | 'id |
---|
389 | (wrap e |
---|
390 | w)) |
---|
391 | maps)))) |
---|
392 | (lookup |
---|
393 | n |
---|
394 | e |
---|
395 | r))) |
---|
396 | (id-var-name |
---|
397 | e |
---|
398 | w)) |
---|
399 | ((lambda (g000141) |
---|
400 | ((lambda (g000142) |
---|
401 | ((lambda (g000140) |
---|
402 | (if (not (eq? g000140 |
---|
403 | 'no)) |
---|
404 | ((lambda (_dots1 |
---|
405 | _dots2) |
---|
406 | (if (if (ellipsis? |
---|
407 | (wrap _dots1 |
---|
408 | w)) |
---|
409 | (ellipsis? |
---|
410 | (wrap _dots2 |
---|
411 | w)) |
---|
412 | #f) |
---|
413 | (k (list |
---|
414 | 'id |
---|
415 | (wrap _dots1 |
---|
416 | w)) |
---|
417 | maps) |
---|
418 | (g000142))) |
---|
419 | (car g000140) |
---|
420 | (cadr g000140)) |
---|
421 | (g000142))) |
---|
422 | (syntax-dispatch |
---|
423 | g000141 |
---|
424 | '(pair (any) |
---|
425 | pair |
---|
426 | (any) |
---|
427 | atom) |
---|
428 | (vector)))) |
---|
429 | (lambda () |
---|
430 | ((lambda (g000144) |
---|
431 | ((lambda (g000145) |
---|
432 | ((lambda (g000143) |
---|
433 | (if (not (eq? g000143 |
---|
434 | 'no)) |
---|
435 | ((lambda (_x |
---|
436 | _dots |
---|
437 | _y) |
---|
438 | (if (ellipsis? |
---|
439 | (wrap _dots |
---|
440 | w)) |
---|
441 | (gen _y |
---|
442 | maps |
---|
443 | (lambda (y |
---|
444 | maps) |
---|
445 | (gen _x |
---|
446 | (cons '() |
---|
447 | maps) |
---|
448 | (lambda (x |
---|
449 | maps) |
---|
450 | (if (null? |
---|
451 | (car maps)) |
---|
452 | (syntax-error |
---|
453 | src |
---|
454 | "extra ellipsis in") |
---|
455 | (k (gen-append |
---|
456 | (gen-map |
---|
457 | x |
---|
458 | (car maps)) |
---|
459 | y) |
---|
460 | (cdr maps))))))) |
---|
461 | (g000145))) |
---|
462 | (car g000143) |
---|
463 | (cadr g000143) |
---|
464 | (caddr |
---|
465 | g000143)) |
---|
466 | (g000145))) |
---|
467 | (syntax-dispatch |
---|
468 | g000144 |
---|
469 | '(pair (any) |
---|
470 | pair |
---|
471 | (any) |
---|
472 | any) |
---|
473 | (vector)))) |
---|
474 | (lambda () |
---|
475 | ((lambda (g000147) |
---|
476 | ((lambda (g000146) |
---|
477 | (if (not (eq? g000146 |
---|
478 | 'no)) |
---|
479 | ((lambda (_x |
---|
480 | _y) |
---|
481 | (gen _x |
---|
482 | maps |
---|
483 | (lambda (x |
---|
484 | maps) |
---|
485 | (gen _y |
---|
486 | maps |
---|
487 | (lambda (y |
---|
488 | maps) |
---|
489 | (k (gen-cons |
---|
490 | x |
---|
491 | y) |
---|
492 | maps)))))) |
---|
493 | (car g000146) |
---|
494 | (cadr g000146)) |
---|
495 | ((lambda (g000149) |
---|
496 | ((lambda (g000148) |
---|
497 | (if (not (eq? g000148 |
---|
498 | 'no)) |
---|
499 | ((lambda (_e1 |
---|
500 | _e2) |
---|
501 | (gen (cons _e1 |
---|
502 | _e2) |
---|
503 | maps |
---|
504 | (lambda (e |
---|
505 | maps) |
---|
506 | (k (gen-vector |
---|
507 | e) |
---|
508 | maps)))) |
---|
509 | (car g000148) |
---|
510 | (cadr g000148)) |
---|
511 | ((lambda (g000151) |
---|
512 | ((lambda (g000150) |
---|
513 | (if (not (eq? g000150 |
---|
514 | 'no)) |
---|
515 | ((lambda (__) |
---|
516 | (k (list |
---|
517 | 'quote |
---|
518 | (wrap e |
---|
519 | w)) |
---|
520 | maps)) |
---|
521 | (car g000150)) |
---|
522 | (syntax-error |
---|
523 | g000151))) |
---|
524 | (syntax-dispatch |
---|
525 | g000151 |
---|
526 | '(any) |
---|
527 | (vector)))) |
---|
528 | g000149))) |
---|
529 | (syntax-dispatch |
---|
530 | g000149 |
---|
531 | '(vector |
---|
532 | pair |
---|
533 | (any) |
---|
534 | each |
---|
535 | any) |
---|
536 | (vector)))) |
---|
537 | g000147))) |
---|
538 | (syntax-dispatch |
---|
539 | g000147 |
---|
540 | '(pair (any) |
---|
541 | any) |
---|
542 | (vector)))) |
---|
543 | g000144)))) |
---|
544 | g000141)))) |
---|
545 | e))))) |
---|
546 | gen) |
---|
547 | exp |
---|
548 | '() |
---|
549 | (lambda (e maps) (regen e))))) |
---|
550 | (ellipsis? (lambda (x) |
---|
551 | (if (identifier? x) |
---|
552 | (free-id=? x '...) |
---|
553 | #f))) |
---|
554 | (chi-syntax-definition (lambda (e w) |
---|
555 | ((lambda (g000153) |
---|
556 | ((lambda (g000154) |
---|
557 | ((lambda (g000152) |
---|
558 | (if (not (eq? g000152 |
---|
559 | 'no)) |
---|
560 | ((lambda (__ |
---|
561 | _name |
---|
562 | _val) |
---|
563 | (if (id? _name) |
---|
564 | (list _name |
---|
565 | _val) |
---|
566 | (g000154))) |
---|
567 | (car g000152) |
---|
568 | (cadr g000152) |
---|
569 | (caddr |
---|
570 | g000152)) |
---|
571 | (g000154))) |
---|
572 | (syntax-dispatch |
---|
573 | g000153 |
---|
574 | '(pair (any) |
---|
575 | pair |
---|
576 | (any) |
---|
577 | pair |
---|
578 | (any) |
---|
579 | atom) |
---|
580 | (vector)))) |
---|
581 | (lambda () |
---|
582 | (syntax-error |
---|
583 | g000153)))) |
---|
584 | (wrap e w)))) |
---|
585 | (chi-definition (lambda (e w) |
---|
586 | ((lambda (g000156) |
---|
587 | ((lambda (g000157) |
---|
588 | ((lambda (g000155) |
---|
589 | (if (not (eq? g000155 |
---|
590 | 'no)) |
---|
591 | (apply |
---|
592 | (lambda (__ |
---|
593 | _name |
---|
594 | _args |
---|
595 | _e1 |
---|
596 | _e2) |
---|
597 | (if (if (id? _name) |
---|
598 | (valid-bound-ids? |
---|
599 | (lambda-var-list |
---|
600 | _args)) |
---|
601 | #f) |
---|
602 | (list _name |
---|
603 | (cons '#(syntax-object |
---|
604 | lambda |
---|
605 | (top)) |
---|
606 | (cons _args |
---|
607 | (cons _e1 |
---|
608 | _e2)))) |
---|
609 | (g000157))) |
---|
610 | g000155) |
---|
611 | (g000157))) |
---|
612 | (syntax-dispatch |
---|
613 | g000156 |
---|
614 | '(pair (any) |
---|
615 | pair |
---|
616 | (pair (any) any) |
---|
617 | pair |
---|
618 | (any) |
---|
619 | each |
---|
620 | any) |
---|
621 | (vector)))) |
---|
622 | (lambda () |
---|
623 | ((lambda (g000159) |
---|
624 | ((lambda (g000158) |
---|
625 | (if (not (eq? g000158 |
---|
626 | 'no)) |
---|
627 | ((lambda (__ |
---|
628 | _name |
---|
629 | _val) |
---|
630 | (list _name |
---|
631 | _val)) |
---|
632 | (car g000158) |
---|
633 | (cadr g000158) |
---|
634 | (caddr |
---|
635 | g000158)) |
---|
636 | ((lambda (g000161) |
---|
637 | ((lambda (g000162) |
---|
638 | ((lambda (g000160) |
---|
639 | (if (not (eq? g000160 |
---|
640 | 'no)) |
---|
641 | ((lambda (__ |
---|
642 | _name) |
---|
643 | (if (id? _name) |
---|
644 | (list _name |
---|
645 | (list '#(syntax-object |
---|
646 | ##core#undefined |
---|
647 | (top)))) |
---|
648 | (g000162))) |
---|
649 | (car g000160) |
---|
650 | (cadr g000160)) |
---|
651 | (g000162))) |
---|
652 | (syntax-dispatch |
---|
653 | g000161 |
---|
654 | '(pair (any) |
---|
655 | pair |
---|
656 | (any) |
---|
657 | atom) |
---|
658 | (vector)))) |
---|
659 | (lambda () |
---|
660 | (syntax-error |
---|
661 | g000161)))) |
---|
662 | g000159))) |
---|
663 | (syntax-dispatch |
---|
664 | g000159 |
---|
665 | '(pair (any) |
---|
666 | pair |
---|
667 | (any) |
---|
668 | pair |
---|
669 | (any) |
---|
670 | atom) |
---|
671 | (vector)))) |
---|
672 | g000156)))) |
---|
673 | (wrap e w)))) |
---|
674 | (chi-sequence (lambda (e w) |
---|
675 | ((lambda (g000164) |
---|
676 | ((lambda (g000163) |
---|
677 | (if (not (eq? g000163 'no)) |
---|
678 | ((lambda (__ _e) _e) |
---|
679 | (car g000163) |
---|
680 | (cadr g000163)) |
---|
681 | (syntax-error g000164))) |
---|
682 | (syntax-dispatch |
---|
683 | g000164 |
---|
684 | '(pair (any) each any) |
---|
685 | (vector)))) |
---|
686 | (wrap e w)))) |
---|
687 | (chi-macro-def (lambda (def r w) |
---|
688 | (eval-hook (chi def null-env w)))) |
---|
689 | (chi-local-syntax (lambda (e r w) |
---|
690 | ((lambda (g000166) |
---|
691 | ((lambda (g000167) |
---|
692 | ((lambda (g000165) |
---|
693 | (if (not (eq? g000165 |
---|
694 | 'no)) |
---|
695 | (apply |
---|
696 | (lambda (_who |
---|
697 | _var |
---|
698 | _val |
---|
699 | _e1 |
---|
700 | _e2) |
---|
701 | (if (valid-bound-ids? |
---|
702 | _var) |
---|
703 | ((lambda (new-vars) |
---|
704 | ((lambda (new-w) |
---|
705 | (chi-body |
---|
706 | (cons _e1 |
---|
707 | _e2) |
---|
708 | e |
---|
709 | (extend-macro-env |
---|
710 | new-vars |
---|
711 | ((lambda (w) |
---|
712 | (map (lambda (x) |
---|
713 | (chi-macro-def |
---|
714 | x |
---|
715 | r |
---|
716 | w)) |
---|
717 | _val)) |
---|
718 | (if (free-id=? |
---|
719 | _who |
---|
720 | '#(syntax-object |
---|
721 | letrec-syntax |
---|
722 | (top))) |
---|
723 | new-w |
---|
724 | w)) |
---|
725 | r) |
---|
726 | new-w)) |
---|
727 | (make-binding-wrap |
---|
728 | _var |
---|
729 | new-vars |
---|
730 | w))) |
---|
731 | (map gen-var |
---|
732 | _var)) |
---|
733 | (g000167))) |
---|
734 | g000165) |
---|
735 | (g000167))) |
---|
736 | (syntax-dispatch |
---|
737 | g000166 |
---|
738 | '(pair (any) |
---|
739 | pair |
---|
740 | (each pair |
---|
741 | (any) |
---|
742 | pair |
---|
743 | (any) |
---|
744 | atom) |
---|
745 | pair |
---|
746 | (any) |
---|
747 | each |
---|
748 | any) |
---|
749 | (vector)))) |
---|
750 | (lambda () |
---|
751 | ((lambda (g000169) |
---|
752 | ((lambda (g000168) |
---|
753 | (if (not (eq? g000168 |
---|
754 | 'no)) |
---|
755 | ((lambda (__) |
---|
756 | (syntax-error |
---|
757 | (wrap e |
---|
758 | w))) |
---|
759 | (car g000168)) |
---|
760 | (syntax-error |
---|
761 | g000169))) |
---|
762 | (syntax-dispatch |
---|
763 | g000169 |
---|
764 | '(any) |
---|
765 | (vector)))) |
---|
766 | g000166)))) |
---|
767 | e))) |
---|
768 | (chi-body (lambda (body source r w) |
---|
769 | (if (null? (cdr body)) |
---|
770 | (chi (car body) r w) |
---|
771 | ((letrec ((parse1 (lambda (body |
---|
772 | var-ids |
---|
773 | var-vals |
---|
774 | macro-ids |
---|
775 | macro-vals) |
---|
776 | (if (null? body) |
---|
777 | (syntax-error |
---|
778 | (wrap source |
---|
779 | w) |
---|
780 | "no expressions in body") |
---|
781 | ((letrec ((parse2 (lambda (e) |
---|
782 | ((lambda (b) |
---|
783 | ((lambda (g000170) |
---|
784 | (if (memv |
---|
785 | g000170 |
---|
786 | '(macro)) |
---|
787 | (parse2 |
---|
788 | (chi-macro |
---|
789 | (binding-value |
---|
790 | b) |
---|
791 | e |
---|
792 | r |
---|
793 | empty-wrap |
---|
794 | (lambda (e |
---|
795 | r |
---|
796 | w) |
---|
797 | (wrap e |
---|
798 | w)))) |
---|
799 | (if (memv |
---|
800 | g000170 |
---|
801 | '(definition)) |
---|
802 | (parse1 |
---|
803 | (cdr body) |
---|
804 | (cons (cadr b) |
---|
805 | var-ids) |
---|
806 | (cons (caddr |
---|
807 | b) |
---|
808 | var-vals) |
---|
809 | macro-ids |
---|
810 | macro-vals) |
---|
811 | (if (memv |
---|
812 | g000170 |
---|
813 | '(syntax-definition)) |
---|
814 | (parse1 |
---|
815 | (cdr body) |
---|
816 | var-ids |
---|
817 | var-vals |
---|
818 | (cons (cadr b) |
---|
819 | macro-ids) |
---|
820 | (cons (caddr |
---|
821 | b) |
---|
822 | macro-vals)) |
---|
823 | (if (memv |
---|
824 | g000170 |
---|
825 | '(sequence)) |
---|
826 | (parse1 |
---|
827 | (append |
---|
828 | (cdr b) |
---|
829 | (cdr body)) |
---|
830 | var-ids |
---|
831 | var-vals |
---|
832 | macro-ids |
---|
833 | macro-vals) |
---|
834 | (begin g000170 |
---|
835 | (if (valid-bound-ids? |
---|
836 | (append |
---|
837 | var-ids |
---|
838 | macro-ids)) |
---|
839 | ((lambda (new-var-names |
---|
840 | new-macro-names) |
---|
841 | ((lambda (w) |
---|
842 | ((lambda (r) |
---|
843 | (build-letrec |
---|
844 | new-var-names |
---|
845 | (map (lambda (x) |
---|
846 | (chi x |
---|
847 | r |
---|
848 | w)) |
---|
849 | var-vals) |
---|
850 | (build-sequence |
---|
851 | (map (lambda (x) |
---|
852 | (chi x |
---|
853 | r |
---|
854 | w)) |
---|
855 | body)))) |
---|
856 | (extend-macro-env |
---|
857 | new-macro-names |
---|
858 | (map (lambda (x) |
---|
859 | (chi-macro-def |
---|
860 | x |
---|
861 | r |
---|
862 | w)) |
---|
863 | macro-vals) |
---|
864 | (extend-var-env |
---|
865 | new-var-names |
---|
866 | r)))) |
---|
867 | (make-binding-wrap |
---|
868 | (append |
---|
869 | macro-ids |
---|
870 | var-ids) |
---|
871 | (append |
---|
872 | new-macro-names |
---|
873 | new-var-names) |
---|
874 | empty-wrap))) |
---|
875 | (map gen-var |
---|
876 | var-ids) |
---|
877 | (map gen-var |
---|
878 | macro-ids)) |
---|
879 | (syntax-error |
---|
880 | (wrap source |
---|
881 | w) |
---|
882 | "invalid identifier")))))))) |
---|
883 | (car b))) |
---|
884 | (syntax-type |
---|
885 | e |
---|
886 | r |
---|
887 | empty-wrap))))) |
---|
888 | parse2) |
---|
889 | (car body)))))) |
---|
890 | parse1) |
---|
891 | (map (lambda (x) (wrap x w)) body) |
---|
892 | '() |
---|
893 | '() |
---|
894 | '() |
---|
895 | '())))) |
---|
896 | (syntax-type (lambda (e r w) |
---|
897 | (if (syntax-object? e) |
---|
898 | (syntax-type |
---|
899 | (syntax-object-expression e) |
---|
900 | r |
---|
901 | (join-wraps |
---|
902 | (syntax-object-wrap e) |
---|
903 | w)) |
---|
904 | (if (if (pair? e) |
---|
905 | (identifier? (car e)) |
---|
906 | #f) |
---|
907 | ((lambda (n) |
---|
908 | ((lambda (b) |
---|
909 | ((lambda (g000171) |
---|
910 | (if (memv |
---|
911 | g000171 |
---|
912 | '(special)) |
---|
913 | (if (memv |
---|
914 | n |
---|
915 | '(define)) |
---|
916 | (cons 'definition |
---|
917 | (chi-definition |
---|
918 | e |
---|
919 | w)) |
---|
920 | (if (memv |
---|
921 | n |
---|
922 | '(define-syntax)) |
---|
923 | (cons 'syntax-definition |
---|
924 | (chi-syntax-definition |
---|
925 | e |
---|
926 | w)) |
---|
927 | (if (memv |
---|
928 | n |
---|
929 | '(begin)) |
---|
930 | (cons 'sequence |
---|
931 | (chi-sequence |
---|
932 | e |
---|
933 | w)) |
---|
934 | (begin n |
---|
935 | (##core#undefined))))) |
---|
936 | (begin g000171 |
---|
937 | b))) |
---|
938 | (binding-type b))) |
---|
939 | (lookup n (car e) r))) |
---|
940 | (id-var-name (car e) w)) |
---|
941 | '(other))))) |
---|
942 | (chi-args (lambda (args r w source source-w) |
---|
943 | (if (pair? args) |
---|
944 | (cons (chi (car args) r w) |
---|
945 | (chi-args |
---|
946 | (cdr args) |
---|
947 | r |
---|
948 | w |
---|
949 | source |
---|
950 | source-w)) |
---|
951 | (if (null? args) |
---|
952 | '() |
---|
953 | (if (syntax-object? args) |
---|
954 | (chi-args |
---|
955 | (syntax-object-expression |
---|
956 | args) |
---|
957 | r |
---|
958 | (join-wraps |
---|
959 | w |
---|
960 | (syntax-object-wrap |
---|
961 | args)) |
---|
962 | source |
---|
963 | source-w) |
---|
964 | (syntax-error |
---|
965 | (wrap source source-w))))))) |
---|
966 | (chi-ref (lambda (e name binding w) |
---|
967 | ((lambda (g000172) |
---|
968 | (if (memv g000172 '(lexical)) |
---|
969 | (build-lexical-reference name) |
---|
970 | (if (memv |
---|
971 | g000172 |
---|
972 | '(global global-unbound)) |
---|
973 | (build-global-reference name) |
---|
974 | (begin g000172 |
---|
975 | (id-error |
---|
976 | (wrap e w)))))) |
---|
977 | (binding-type binding)))) |
---|
978 | (chi-macro (letrec ((check-macro-output (lambda (x) |
---|
979 | (if (pair? |
---|
980 | x) |
---|
981 | (begin (check-macro-output |
---|
982 | (car x)) |
---|
983 | (check-macro-output |
---|
984 | (cdr x))) |
---|
985 | ((lambda (g000173) |
---|
986 | (if g000173 |
---|
987 | g000173 |
---|
988 | (if (vector? |
---|
989 | x) |
---|
990 | ((lambda (n) |
---|
991 | ((letrec ((g000174 (lambda (i) |
---|
992 | (if (= i |
---|
993 | n) |
---|
994 | (##core#undefined) |
---|
995 | (begin (check-macro-output |
---|
996 | (vector-ref |
---|
997 | x |
---|
998 | i)) |
---|
999 | (g000174 |
---|
1000 | (+ i |
---|
1001 | 1))))))) |
---|
1002 | g000174) |
---|
1003 | 0)) |
---|
1004 | (vector-length |
---|
1005 | x)) |
---|
1006 | (if (symbol? |
---|
1007 | x) |
---|
1008 | (syntax-error |
---|
1009 | x |
---|
1010 | "encountered raw symbol") |
---|
1011 | (##core#undefined))))) |
---|
1012 | (syntax-object? |
---|
1013 | x)))))) |
---|
1014 | (lambda (p e r w k) |
---|
1015 | ((lambda (mw) |
---|
1016 | ((lambda (x) |
---|
1017 | (check-macro-output x) |
---|
1018 | (k x r mw)) |
---|
1019 | (p (wrap e (join-wraps mw w))))) |
---|
1020 | (new-mark-wrap))))) |
---|
1021 | (chi-pair (lambda (e r w k) |
---|
1022 | ((lambda (first rest) |
---|
1023 | (if (id? first) |
---|
1024 | ((lambda (n) |
---|
1025 | ((lambda (b) |
---|
1026 | ((lambda (g000175) |
---|
1027 | (if (memv |
---|
1028 | g000175 |
---|
1029 | '(core)) |
---|
1030 | ((binding-value b) |
---|
1031 | e |
---|
1032 | r |
---|
1033 | w) |
---|
1034 | (if (memv |
---|
1035 | g000175 |
---|
1036 | '(macro)) |
---|
1037 | (chi-macro |
---|
1038 | (binding-value |
---|
1039 | b) |
---|
1040 | e |
---|
1041 | r |
---|
1042 | w |
---|
1043 | k) |
---|
1044 | (if (memv |
---|
1045 | g000175 |
---|
1046 | '(special)) |
---|
1047 | ((binding-value |
---|
1048 | b) |
---|
1049 | e |
---|
1050 | r |
---|
1051 | w |
---|
1052 | k) |
---|
1053 | (begin g000175 |
---|
1054 | (build-application |
---|
1055 | (chi-ref |
---|
1056 | first |
---|
1057 | n |
---|
1058 | b |
---|
1059 | w) |
---|
1060 | (chi-args |
---|
1061 | rest |
---|
1062 | r |
---|
1063 | w |
---|
1064 | e |
---|
1065 | w))))))) |
---|
1066 | (binding-type b))) |
---|
1067 | (lookup n first r))) |
---|
1068 | (id-var-name first w)) |
---|
1069 | (build-application |
---|
1070 | (chi first r w) |
---|
1071 | (chi-args rest r w e w)))) |
---|
1072 | (car e) |
---|
1073 | (cdr e)))) |
---|
1074 | (chi (lambda (e r w) |
---|
1075 | (if (symbol? e) |
---|
1076 | ((lambda (n) |
---|
1077 | (chi-ref e n (lookup n e r) w)) |
---|
1078 | (id-var-name e w)) |
---|
1079 | (if (pair? e) |
---|
1080 | (chi-pair e r w chi) |
---|
1081 | (if (syntax-object? e) |
---|
1082 | (chi (syntax-object-expression e) |
---|
1083 | r |
---|
1084 | (join-wraps |
---|
1085 | w |
---|
1086 | (syntax-object-wrap e))) |
---|
1087 | (if ((lambda (g000176) |
---|
1088 | (if g000176 |
---|
1089 | g000176 |
---|
1090 | ((lambda (g000177) |
---|
1091 | (if g000177 |
---|
1092 | g000177 |
---|
1093 | ((lambda (g000178) |
---|
1094 | (if g000178 |
---|
1095 | g000178 |
---|
1096 | (char? |
---|
1097 | e))) |
---|
1098 | (string? e)))) |
---|
1099 | (number? e)))) |
---|
1100 | (boolean? e)) |
---|
1101 | (build-data e) |
---|
1102 | (syntax-error (wrap e w)))))))) |
---|
1103 | (chi-top (lambda (e r w) |
---|
1104 | (if (pair? e) |
---|
1105 | (chi-pair e r w chi-top) |
---|
1106 | (if (syntax-object? e) |
---|
1107 | (chi-top |
---|
1108 | (syntax-object-expression e) |
---|
1109 | r |
---|
1110 | (join-wraps |
---|
1111 | w |
---|
1112 | (syntax-object-wrap e))) |
---|
1113 | (chi e r w))))) |
---|
1114 | (wrap (lambda (x w) |
---|
1115 | (if (null? w) |
---|
1116 | x |
---|
1117 | (if (syntax-object? x) |
---|
1118 | (make-syntax-object |
---|
1119 | (syntax-object-expression x) |
---|
1120 | (join-wraps |
---|
1121 | w |
---|
1122 | (syntax-object-wrap x))) |
---|
1123 | (if (null? x) |
---|
1124 | x |
---|
1125 | (make-syntax-object x w)))))) |
---|
1126 | (unwrap (lambda (x) |
---|
1127 | (if (syntax-object? x) |
---|
1128 | ((lambda (e w) |
---|
1129 | (if (pair? e) |
---|
1130 | (cons (wrap (car e) w) |
---|
1131 | (wrap (cdr e) w)) |
---|
1132 | (if (vector? e) |
---|
1133 | (list->vector |
---|
1134 | (map (lambda (x) |
---|
1135 | (wrap x w)) |
---|
1136 | (vector->list e))) |
---|
1137 | e))) |
---|
1138 | (syntax-object-expression x) |
---|
1139 | (syntax-object-wrap x)) |
---|
1140 | x))) |
---|
1141 | (bound-id-member? (lambda (x list) |
---|
1142 | (if (not (null? list)) |
---|
1143 | ((lambda (g000179) |
---|
1144 | (if g000179 |
---|
1145 | g000179 |
---|
1146 | (bound-id-member? |
---|
1147 | x |
---|
1148 | (cdr list)))) |
---|
1149 | (bound-id=? x (car list))) |
---|
1150 | #f))) |
---|
1151 | (valid-bound-ids? (lambda (ids) |
---|
1152 | (if ((letrec ((all-ids? (lambda (ids) |
---|
1153 | ((lambda (g000181) |
---|
1154 | (if g000181 |
---|
1155 | g000181 |
---|
1156 | (if (id? (car ids)) |
---|
1157 | (all-ids? |
---|
1158 | (cdr ids)) |
---|
1159 | #f))) |
---|
1160 | (null? |
---|
1161 | ids))))) |
---|
1162 | all-ids?) |
---|
1163 | ids) |
---|
1164 | ((letrec ((unique? (lambda (ids) |
---|
1165 | ((lambda (g000180) |
---|
1166 | (if g000180 |
---|
1167 | g000180 |
---|
1168 | (if (not (bound-id-member? |
---|
1169 | (car ids) |
---|
1170 | (cdr ids))) |
---|
1171 | (unique? |
---|
1172 | (cdr ids)) |
---|
1173 | #f))) |
---|
1174 | (null? |
---|
1175 | ids))))) |
---|
1176 | unique?) |
---|
1177 | ids) |
---|
1178 | #f))) |
---|
1179 | (bound-id=? (lambda (i j) |
---|
1180 | (if (eq? (id-sym-name i) |
---|
1181 | (id-sym-name j)) |
---|
1182 | ((lambda (i j) |
---|
1183 | (if (eq? (car i) (car j)) |
---|
1184 | (same-marks? |
---|
1185 | (cdr i) |
---|
1186 | (cdr j)) |
---|
1187 | #f)) |
---|
1188 | (id-var-name&marks i empty-wrap) |
---|
1189 | (id-var-name&marks j empty-wrap)) |
---|
1190 | #f))) |
---|
1191 | (free-id=? (lambda (i j) |
---|
1192 | (if (eq? (id-sym-name i) (id-sym-name j)) |
---|
1193 | (eq? (id-var-name i empty-wrap) |
---|
1194 | (id-var-name j empty-wrap)) |
---|
1195 | #f))) |
---|
1196 | (id-var-name&marks (lambda (id w) |
---|
1197 | (if (null? w) |
---|
1198 | (if (symbol? id) |
---|
1199 | (list id) |
---|
1200 | (id-var-name&marks |
---|
1201 | (syntax-object-expression |
---|
1202 | id) |
---|
1203 | (syntax-object-wrap |
---|
1204 | id))) |
---|
1205 | ((lambda (n&m first) |
---|
1206 | (if (pair? first) |
---|
1207 | ((lambda (n) |
---|
1208 | ((letrec ((search (lambda (rib) |
---|
1209 | (if (null? |
---|
1210 | rib) |
---|
1211 | n&m |
---|
1212 | (if (if (eq? (caar rib) |
---|
1213 | n) |
---|
1214 | (same-marks? |
---|
1215 | (cdr n&m) |
---|
1216 | (cddar |
---|
1217 | rib)) |
---|
1218 | #f) |
---|
1219 | (cdar rib) |
---|
1220 | (search |
---|
1221 | (cdr rib))))))) |
---|
1222 | search) |
---|
1223 | first)) |
---|
1224 | (car n&m)) |
---|
1225 | (cons (car n&m) |
---|
1226 | (if ((lambda (g000182) |
---|
1227 | (if g000182 |
---|
1228 | g000182 |
---|
1229 | (not (eqv? first |
---|
1230 | (cadr n&m))))) |
---|
1231 | (null? |
---|
1232 | (cdr n&m))) |
---|
1233 | (cons first |
---|
1234 | (cdr n&m)) |
---|
1235 | (cddr n&m))))) |
---|
1236 | (id-var-name&marks |
---|
1237 | id |
---|
1238 | (cdr w)) |
---|
1239 | (car w))))) |
---|
1240 | (id-var-name (lambda (id w) |
---|
1241 | (if (null? w) |
---|
1242 | (if (symbol? id) |
---|
1243 | id |
---|
1244 | (id-var-name |
---|
1245 | (syntax-object-expression |
---|
1246 | id) |
---|
1247 | (syntax-object-wrap id))) |
---|
1248 | (if (pair? (car w)) |
---|
1249 | (car (id-var-name&marks id w)) |
---|
1250 | (id-var-name id (cdr w)))))) |
---|
1251 | (same-marks? (lambda (x y) |
---|
1252 | (if (null? x) |
---|
1253 | (null? y) |
---|
1254 | (if (not (null? y)) |
---|
1255 | (if (eqv? (car x) (car y)) |
---|
1256 | (same-marks? |
---|
1257 | (cdr x) |
---|
1258 | (cdr y)) |
---|
1259 | #f) |
---|
1260 | #f)))) |
---|
1261 | (join-wraps2 (lambda (w1 w2) |
---|
1262 | ((lambda (x w1) |
---|
1263 | (if (null? w1) |
---|
1264 | (if (if (not (pair? x)) |
---|
1265 | (eqv? x (car w2)) |
---|
1266 | #f) |
---|
1267 | (cdr w2) |
---|
1268 | (cons x w2)) |
---|
1269 | (cons x (join-wraps2 w1 w2)))) |
---|
1270 | (car w1) |
---|
1271 | (cdr w1)))) |
---|
1272 | (join-wraps1 (lambda (w1 w2) |
---|
1273 | (if (null? w1) |
---|
1274 | w2 |
---|
1275 | (cons (car w1) |
---|
1276 | (join-wraps1 (cdr w1) w2))))) |
---|
1277 | (join-wraps (lambda (w1 w2) |
---|
1278 | (if (null? w2) |
---|
1279 | w1 |
---|
1280 | (if (null? w1) |
---|
1281 | w2 |
---|
1282 | (if (pair? (car w2)) |
---|
1283 | (join-wraps1 w1 w2) |
---|
1284 | (join-wraps2 w1 w2)))))) |
---|
1285 | (make-wrap-rib (lambda (ids new-names w) |
---|
1286 | (if (null? ids) |
---|
1287 | '() |
---|
1288 | (cons ((lambda (n&m) |
---|
1289 | (cons (car n&m) |
---|
1290 | (cons (car new-names) |
---|
1291 | (cdr n&m)))) |
---|
1292 | (id-var-name&marks |
---|
1293 | (car ids) |
---|
1294 | w)) |
---|
1295 | (make-wrap-rib |
---|
1296 | (cdr ids) |
---|
1297 | (cdr new-names) |
---|
1298 | w))))) |
---|
1299 | (make-binding-wrap (lambda (ids new-names w) |
---|
1300 | (if (null? ids) |
---|
1301 | w |
---|
1302 | (cons (make-wrap-rib |
---|
1303 | ids |
---|
1304 | new-names |
---|
1305 | w) |
---|
1306 | w)))) |
---|
1307 | (new-mark-wrap (lambda () |
---|
1308 | (set! current-mark |
---|
1309 | (+ current-mark 1)) |
---|
1310 | (list current-mark))) |
---|
1311 | (current-mark 0) |
---|
1312 | (top-wrap '(top)) |
---|
1313 | (empty-wrap '()) |
---|
1314 | (id-sym-name (lambda (x) |
---|
1315 | (if (symbol? x) |
---|
1316 | x |
---|
1317 | (syntax-object-expression x)))) |
---|
1318 | (id? (lambda (x) |
---|
1319 | ((lambda (g000183) |
---|
1320 | (if g000183 |
---|
1321 | g000183 |
---|
1322 | (if (syntax-object? x) |
---|
1323 | (symbol? |
---|
1324 | (syntax-object-expression x)) |
---|
1325 | #f))) |
---|
1326 | (symbol? x)))) |
---|
1327 | (global-extend (lambda (type sym val) |
---|
1328 | (extend-global-env |
---|
1329 | sym |
---|
1330 | (cons type val)))) |
---|
1331 | (lookup (lambda (name id r) |
---|
1332 | (if (eq? name (id-sym-name id)) |
---|
1333 | (global-lookup name) |
---|
1334 | ((letrec ((search (lambda (r name) |
---|
1335 | (if (null? r) |
---|
1336 | '(displaced-lexical) |
---|
1337 | (if (pair? |
---|
1338 | (car r)) |
---|
1339 | (if (eq? (caar r) |
---|
1340 | name) |
---|
1341 | (cdar r) |
---|
1342 | (search |
---|
1343 | (cdr r) |
---|
1344 | name)) |
---|
1345 | (if (eq? (car r) |
---|
1346 | name) |
---|
1347 | '(lexical) |
---|
1348 | (search |
---|
1349 | (cdr r) |
---|
1350 | name))))))) |
---|
1351 | search) |
---|
1352 | r |
---|
1353 | name)))) |
---|
1354 | (extend-syntax-env (lambda (vars vals r) |
---|
1355 | (if (null? vars) |
---|
1356 | r |
---|
1357 | (cons (cons (car vars) |
---|
1358 | (cons 'syntax |
---|
1359 | (car vals))) |
---|
1360 | (extend-syntax-env |
---|
1361 | (cdr vars) |
---|
1362 | (cdr vals) |
---|
1363 | r))))) |
---|
1364 | (extend-var-env append) |
---|
1365 | (extend-macro-env (lambda (vars vals r) |
---|
1366 | (if (null? vars) |
---|
1367 | r |
---|
1368 | (cons (cons (car vars) |
---|
1369 | (cons 'macro |
---|
1370 | (car vals))) |
---|
1371 | (extend-macro-env |
---|
1372 | (cdr vars) |
---|
1373 | (cdr vals) |
---|
1374 | r))))) |
---|
1375 | (null-env '()) |
---|
1376 | (global-lookup (lambda (sym) |
---|
1377 | ((lambda (g000184) |
---|
1378 | (if g000184 |
---|
1379 | g000184 |
---|
1380 | '(global-unbound))) |
---|
1381 | (get-global-definition-hook sym)))) |
---|
1382 | (extend-global-env (lambda (sym binding) |
---|
1383 | (put-global-definition-hook |
---|
1384 | sym |
---|
1385 | binding))) |
---|
1386 | (binding-value cdr) |
---|
1387 | (binding-type car) |
---|
1388 | (arg-check (lambda (pred? x who) |
---|
1389 | (if (not (pred? x)) |
---|
1390 | (error-hook who "invalid argument" x) |
---|
1391 | (##core#undefined)))) |
---|
1392 | (id-error (lambda (x) |
---|
1393 | (syntax-error |
---|
1394 | x |
---|
1395 | "invalid context for identifier"))) |
---|
1396 | (scope-error (lambda (id) |
---|
1397 | (syntax-error |
---|
1398 | id |
---|
1399 | "invalid context for bound identifier"))) |
---|
1400 | (syntax-object-wrap (lambda (x) (vector-ref x 2))) |
---|
1401 | (syntax-object-expression (lambda (x) (vector-ref x 1))) |
---|
1402 | (make-syntax-object (lambda (expression wrap) |
---|
1403 | (vector |
---|
1404 | 'syntax-object |
---|
1405 | expression |
---|
1406 | wrap))) |
---|
1407 | (syntax-object? (lambda (x) |
---|
1408 | (if (vector? x) |
---|
1409 | (if (= (vector-length x) 3) |
---|
1410 | (eq? (vector-ref x 0) |
---|
1411 | 'syntax-object) |
---|
1412 | #f) |
---|
1413 | #f)))) |
---|
1414 | (global-extend 'core 'letrec-syntax chi-local-syntax) |
---|
1415 | (global-extend 'core 'let-syntax chi-local-syntax) |
---|
1416 | (global-extend |
---|
1417 | 'core |
---|
1418 | 'quote |
---|
1419 | (lambda (e r w) |
---|
1420 | ((lambda (g000136) |
---|
1421 | ((lambda (g000135) |
---|
1422 | (if (not (eq? g000135 'no)) |
---|
1423 | ((lambda (__ _e) (build-data (strip _e))) |
---|
1424 | (car g000135) |
---|
1425 | (cadr g000135)) |
---|
1426 | ((lambda (g000138) |
---|
1427 | ((lambda (g000137) |
---|
1428 | (if (not (eq? g000137 'no)) |
---|
1429 | ((lambda (__) |
---|
1430 | (syntax-error (wrap e w))) |
---|
1431 | (car g000137)) |
---|
1432 | (syntax-error g000138))) |
---|
1433 | (syntax-dispatch |
---|
1434 | g000138 |
---|
1435 | '(any) |
---|
1436 | (vector)))) |
---|
1437 | g000136))) |
---|
1438 | (syntax-dispatch |
---|
1439 | g000136 |
---|
1440 | '(pair (any) pair (any) atom) |
---|
1441 | (vector)))) |
---|
1442 | e))) |
---|
1443 | (global-extend |
---|
1444 | 'core |
---|
1445 | 'syntax |
---|
1446 | (lambda (e r w) |
---|
1447 | ((lambda (g000132) |
---|
1448 | ((lambda (g000131) |
---|
1449 | (if (not (eq? g000131 'no)) |
---|
1450 | ((lambda (__ _x) (chi-syntax e _x r w)) |
---|
1451 | (car g000131) |
---|
1452 | (cadr g000131)) |
---|
1453 | ((lambda (g000134) |
---|
1454 | ((lambda (g000133) |
---|
1455 | (if (not (eq? g000133 'no)) |
---|
1456 | ((lambda (__) |
---|
1457 | (syntax-error (wrap e w))) |
---|
1458 | (car g000133)) |
---|
1459 | (syntax-error g000134))) |
---|
1460 | (syntax-dispatch |
---|
1461 | g000134 |
---|
1462 | '(any) |
---|
1463 | (vector)))) |
---|
1464 | g000132))) |
---|
1465 | (syntax-dispatch |
---|
1466 | g000132 |
---|
1467 | '(pair (any) pair (any) atom) |
---|
1468 | (vector)))) |
---|
1469 | e))) |
---|
1470 | (global-extend |
---|
1471 | 'core |
---|
1472 | 'syntax-lambda |
---|
1473 | (lambda (e r w) |
---|
1474 | ((lambda (g000127) |
---|
1475 | ((lambda (g000128) |
---|
1476 | ((lambda (g000126) |
---|
1477 | (if (not (eq? g000126 'no)) |
---|
1478 | ((lambda (__ _id _level _exp) |
---|
1479 | (if (if (valid-bound-ids? _id) |
---|
1480 | (map (lambda (x) |
---|
1481 | (if (integer? x) |
---|
1482 | (if (exact? x) |
---|
1483 | (not (negative? |
---|
1484 | x)) |
---|
1485 | #f) |
---|
1486 | #f)) |
---|
1487 | (map unwrap _level)) |
---|
1488 | #f) |
---|
1489 | ((lambda (new-vars) |
---|
1490 | (build-lambda |
---|
1491 | new-vars |
---|
1492 | (chi _exp |
---|
1493 | (extend-syntax-env |
---|
1494 | new-vars |
---|
1495 | (map unwrap |
---|
1496 | _level) |
---|
1497 | r) |
---|
1498 | (make-binding-wrap |
---|
1499 | _id |
---|
1500 | new-vars |
---|
1501 | w)))) |
---|
1502 | (map gen-var _id)) |
---|
1503 | (g000128))) |
---|
1504 | (car g000126) |
---|
1505 | (cadr g000126) |
---|
1506 | (caddr g000126) |
---|
1507 | (cadddr g000126)) |
---|
1508 | (g000128))) |
---|
1509 | (syntax-dispatch |
---|
1510 | g000127 |
---|
1511 | '(pair (any) |
---|
1512 | pair |
---|
1513 | (each pair (any) pair (any) atom) |
---|
1514 | pair |
---|
1515 | (any) |
---|
1516 | atom) |
---|
1517 | (vector)))) |
---|
1518 | (lambda () |
---|
1519 | ((lambda (g000130) |
---|
1520 | ((lambda (g000129) |
---|
1521 | (if (not (eq? g000129 'no)) |
---|
1522 | ((lambda (__) |
---|
1523 | (syntax-error (wrap e w))) |
---|
1524 | (car g000129)) |
---|
1525 | (syntax-error g000130))) |
---|
1526 | (syntax-dispatch |
---|
1527 | g000130 |
---|
1528 | '(any) |
---|
1529 | (vector)))) |
---|
1530 | g000127)))) |
---|
1531 | e))) |
---|
1532 | (global-extend |
---|
1533 | 'core |
---|
1534 | 'lambda |
---|
1535 | (lambda (e r w) |
---|
1536 | ((lambda (g000121) |
---|
1537 | ((lambda (g000120) |
---|
1538 | (if (not (eq? g000120 'no)) |
---|
1539 | ((lambda (__ _id _e1 _e2) |
---|
1540 | (if (not (valid-bound-ids? _id)) |
---|
1541 | (syntax-error |
---|
1542 | (wrap e w) |
---|
1543 | "invalid parameter list") |
---|
1544 | ((lambda (new-vars) |
---|
1545 | (build-lambda |
---|
1546 | new-vars |
---|
1547 | (chi-body |
---|
1548 | (cons _e1 _e2) |
---|
1549 | e |
---|
1550 | (extend-var-env |
---|
1551 | new-vars |
---|
1552 | r) |
---|
1553 | (make-binding-wrap |
---|
1554 | _id |
---|
1555 | new-vars |
---|
1556 | w)))) |
---|
1557 | (map gen-var _id)))) |
---|
1558 | (car g000120) |
---|
1559 | (cadr g000120) |
---|
1560 | (caddr g000120) |
---|
1561 | (cadddr g000120)) |
---|
1562 | ((lambda (g000123) |
---|
1563 | ((lambda (g000122) |
---|
1564 | (if (not (eq? g000122 'no)) |
---|
1565 | ((lambda (__ _ids _e1 _e2) |
---|
1566 | ((lambda (old-ids) |
---|
1567 | (if (not (valid-bound-ids? |
---|
1568 | (lambda-var-list |
---|
1569 | _ids))) |
---|
1570 | (syntax-error |
---|
1571 | (wrap e w) |
---|
1572 | "invalid parameter list") |
---|
1573 | ((lambda (new-vars) |
---|
1574 | (build-improper-lambda |
---|
1575 | (reverse |
---|
1576 | (cdr new-vars)) |
---|
1577 | (car new-vars) |
---|
1578 | (chi-body |
---|
1579 | (cons _e1 |
---|
1580 | _e2) |
---|
1581 | e |
---|
1582 | (extend-var-env |
---|
1583 | new-vars |
---|
1584 | r) |
---|
1585 | (make-binding-wrap |
---|
1586 | old-ids |
---|
1587 | new-vars |
---|
1588 | w)))) |
---|
1589 | (map gen-var |
---|
1590 | old-ids)))) |
---|
1591 | (lambda-var-list _ids))) |
---|
1592 | (car g000122) |
---|
1593 | (cadr g000122) |
---|
1594 | (caddr g000122) |
---|
1595 | (cadddr g000122)) |
---|
1596 | ((lambda (g000125) |
---|
1597 | ((lambda (g000124) |
---|
1598 | (if (not (eq? g000124 |
---|
1599 | 'no)) |
---|
1600 | ((lambda (__) |
---|
1601 | (syntax-error |
---|
1602 | (wrap e w))) |
---|
1603 | (car g000124)) |
---|
1604 | (syntax-error |
---|
1605 | g000125))) |
---|
1606 | (syntax-dispatch |
---|
1607 | g000125 |
---|
1608 | '(any) |
---|
1609 | (vector)))) |
---|
1610 | g000123))) |
---|
1611 | (syntax-dispatch |
---|
1612 | g000123 |
---|
1613 | '(pair (any) |
---|
1614 | pair |
---|
1615 | (any) |
---|
1616 | pair |
---|
1617 | (any) |
---|
1618 | each |
---|
1619 | any) |
---|
1620 | (vector)))) |
---|
1621 | g000121))) |
---|
1622 | (syntax-dispatch |
---|
1623 | g000121 |
---|
1624 | '(pair (any) |
---|
1625 | pair |
---|
1626 | (each any) |
---|
1627 | pair |
---|
1628 | (any) |
---|
1629 | each |
---|
1630 | any) |
---|
1631 | (vector)))) |
---|
1632 | e))) |
---|
1633 | (global-extend |
---|
1634 | 'core |
---|
1635 | 'letrec |
---|
1636 | (lambda (e r w) |
---|
1637 | ((lambda (g000116) |
---|
1638 | ((lambda (g000117) |
---|
1639 | ((lambda (g000115) |
---|
1640 | (if (not (eq? g000115 'no)) |
---|
1641 | (apply |
---|
1642 | (lambda (__ _id _val _e1 _e2) |
---|
1643 | (if (valid-bound-ids? _id) |
---|
1644 | ((lambda (new-vars) |
---|
1645 | ((lambda (w r) |
---|
1646 | (build-letrec |
---|
1647 | new-vars |
---|
1648 | (map (lambda (x) |
---|
1649 | (chi x |
---|
1650 | r |
---|
1651 | w)) |
---|
1652 | _val) |
---|
1653 | (chi-body |
---|
1654 | (cons _e1 _e2) |
---|
1655 | e |
---|
1656 | r |
---|
1657 | w))) |
---|
1658 | (make-binding-wrap |
---|
1659 | _id |
---|
1660 | new-vars |
---|
1661 | w) |
---|
1662 | (extend-var-env |
---|
1663 | new-vars |
---|
1664 | r))) |
---|
1665 | (map gen-var _id)) |
---|
1666 | (g000117))) |
---|
1667 | g000115) |
---|
1668 | (g000117))) |
---|
1669 | (syntax-dispatch |
---|
1670 | g000116 |
---|
1671 | '(pair (any) |
---|
1672 | pair |
---|
1673 | (each pair (any) pair (any) atom) |
---|
1674 | pair |
---|
1675 | (any) |
---|
1676 | each |
---|
1677 | any) |
---|
1678 | (vector)))) |
---|
1679 | (lambda () |
---|
1680 | ((lambda (g000119) |
---|
1681 | ((lambda (g000118) |
---|
1682 | (if (not (eq? g000118 'no)) |
---|
1683 | ((lambda (__) |
---|
1684 | (syntax-error (wrap e w))) |
---|
1685 | (car g000118)) |
---|
1686 | (syntax-error g000119))) |
---|
1687 | (syntax-dispatch |
---|
1688 | g000119 |
---|
1689 | '(any) |
---|
1690 | (vector)))) |
---|
1691 | g000116)))) |
---|
1692 | e))) |
---|
1693 | (global-extend |
---|
1694 | 'core |
---|
1695 | 'if |
---|
1696 | (lambda (e r w) |
---|
1697 | ((lambda (g000110) |
---|
1698 | ((lambda (g000109) |
---|
1699 | (if (not (eq? g000109 'no)) |
---|
1700 | ((lambda (__ _test _then) |
---|
1701 | (build-conditional |
---|
1702 | (chi _test r w) |
---|
1703 | (chi _then r w) |
---|
1704 | (chi (list '#(syntax-object |
---|
1705 | ##core#undefined |
---|
1706 | (top))) |
---|
1707 | r |
---|
1708 | empty-wrap))) |
---|
1709 | (car g000109) |
---|
1710 | (cadr g000109) |
---|
1711 | (caddr g000109)) |
---|
1712 | ((lambda (g000112) |
---|
1713 | ((lambda (g000111) |
---|
1714 | (if (not (eq? g000111 'no)) |
---|
1715 | ((lambda (__ _test _then _else) |
---|
1716 | (build-conditional |
---|
1717 | (chi _test r w) |
---|
1718 | (chi _then r w) |
---|
1719 | (chi _else r w))) |
---|
1720 | (car g000111) |
---|
1721 | (cadr g000111) |
---|
1722 | (caddr g000111) |
---|
1723 | (cadddr g000111)) |
---|
1724 | ((lambda (g000114) |
---|
1725 | ((lambda (g000113) |
---|
1726 | (if (not (eq? g000113 |
---|
1727 | 'no)) |
---|
1728 | ((lambda (__) |
---|
1729 | (syntax-error |
---|
1730 | (wrap e w))) |
---|
1731 | (car g000113)) |
---|
1732 | (syntax-error |
---|
1733 | g000114))) |
---|
1734 | (syntax-dispatch |
---|
1735 | g000114 |
---|
1736 | '(any) |
---|
1737 | (vector)))) |
---|
1738 | g000112))) |
---|
1739 | (syntax-dispatch |
---|
1740 | g000112 |
---|
1741 | '(pair (any) |
---|
1742 | pair |
---|
1743 | (any) |
---|
1744 | pair |
---|
1745 | (any) |
---|
1746 | pair |
---|
1747 | (any) |
---|
1748 | atom) |
---|
1749 | (vector)))) |
---|
1750 | g000110))) |
---|
1751 | (syntax-dispatch |
---|
1752 | g000110 |
---|
1753 | '(pair (any) pair (any) pair (any) atom) |
---|
1754 | (vector)))) |
---|
1755 | e))) |
---|
1756 | (global-extend |
---|
1757 | 'core |
---|
1758 | 'set! |
---|
1759 | (lambda (e r w) |
---|
1760 | ((lambda (g000104) |
---|
1761 | ((lambda (g000105) |
---|
1762 | ((lambda (g000103) |
---|
1763 | (if (not (eq? g000103 'no)) |
---|
1764 | ((lambda (__ _id _val) |
---|
1765 | (if (id? _id) |
---|
1766 | ((lambda (val n) |
---|
1767 | ((lambda (g000108) |
---|
1768 | (if (memv |
---|
1769 | g000108 |
---|
1770 | '(lexical)) |
---|
1771 | (build-lexical-assignment |
---|
1772 | n |
---|
1773 | val) |
---|
1774 | (if (memv |
---|
1775 | g000108 |
---|
1776 | '(global |
---|
1777 | global-unbound)) |
---|
1778 | (build-global-assignment |
---|
1779 | n |
---|
1780 | val) |
---|
1781 | (begin g000108 |
---|
1782 | (id-error |
---|
1783 | (wrap _id |
---|
1784 | w)))))) |
---|
1785 | (binding-type |
---|
1786 | (lookup n _id r)))) |
---|
1787 | (chi _val r w) |
---|
1788 | (id-var-name _id w)) |
---|
1789 | (g000105))) |
---|
1790 | (car g000103) |
---|
1791 | (cadr g000103) |
---|
1792 | (caddr g000103)) |
---|
1793 | (g000105))) |
---|
1794 | (syntax-dispatch |
---|
1795 | g000104 |
---|
1796 | '(pair (any) pair (any) pair (any) atom) |
---|
1797 | (vector)))) |
---|
1798 | (lambda () |
---|
1799 | ((lambda (g000107) |
---|
1800 | ((lambda (g000106) |
---|
1801 | (if (not (eq? g000106 'no)) |
---|
1802 | ((lambda (__) |
---|
1803 | (syntax-error (wrap e w))) |
---|
1804 | (car g000106)) |
---|
1805 | (syntax-error g000107))) |
---|
1806 | (syntax-dispatch |
---|
1807 | g000107 |
---|
1808 | '(any) |
---|
1809 | (vector)))) |
---|
1810 | g000104)))) |
---|
1811 | e))) |
---|
1812 | (global-extend |
---|
1813 | 'special |
---|
1814 | 'begin |
---|
1815 | (lambda (e r w k) |
---|
1816 | ((lambda (body) |
---|
1817 | (if (null? body) |
---|
1818 | (if (eqv? k chi-top) |
---|
1819 | (chi (list '#(syntax-object ##core#undefined (top))) |
---|
1820 | r |
---|
1821 | empty-wrap) |
---|
1822 | (syntax-error |
---|
1823 | (wrap e w) |
---|
1824 | "no expressions in body of")) |
---|
1825 | (build-sequence |
---|
1826 | ((letrec ((dobody (lambda (body) |
---|
1827 | (if (null? body) |
---|
1828 | '() |
---|
1829 | ((lambda (first) |
---|
1830 | (cons first |
---|
1831 | (dobody |
---|
1832 | (cdr body)))) |
---|
1833 | (k (car body) |
---|
1834 | r |
---|
1835 | empty-wrap)))))) |
---|
1836 | dobody) |
---|
1837 | body)))) |
---|
1838 | (chi-sequence e w)))) |
---|
1839 | (global-extend |
---|
1840 | 'special |
---|
1841 | 'define |
---|
1842 | (lambda (e r w k) |
---|
1843 | (if (eqv? k chi-top) |
---|
1844 | ((lambda (n&v) |
---|
1845 | ((lambda (n) |
---|
1846 | (global-extend 'global n '()) |
---|
1847 | (build-global-definition |
---|
1848 | n |
---|
1849 | (chi (cadr n&v) r empty-wrap))) |
---|
1850 | (id-var-name (car n&v) empty-wrap))) |
---|
1851 | (chi-definition e w)) |
---|
1852 | (syntax-error |
---|
1853 | (wrap e w) |
---|
1854 | "invalid context for definition")))) |
---|
1855 | (global-extend |
---|
1856 | 'special |
---|
1857 | 'define-syntax |
---|
1858 | (lambda (e r w k) |
---|
1859 | (if (eqv? k chi-top) |
---|
1860 | ((lambda (n&v) |
---|
1861 | (global-extend |
---|
1862 | 'macro |
---|
1863 | (id-var-name (car n&v) empty-wrap) |
---|
1864 | (chi-macro-def (cadr n&v) r empty-wrap)) |
---|
1865 | (chi (list '#(syntax-object ##core#undefined (top))) |
---|
1866 | r |
---|
1867 | empty-wrap)) |
---|
1868 | (chi-syntax-definition e w)) |
---|
1869 | (syntax-error |
---|
1870 | (wrap e w) |
---|
1871 | "invalid context for definition")))) |
---|
1872 | (set! expand-syntax |
---|
1873 | (lambda (x) (chi-top x null-env top-wrap))) |
---|
1874 | (set! implicit-identifier |
---|
1875 | (lambda (id sym) |
---|
1876 | (arg-check id? id 'implicit-identifier) |
---|
1877 | (arg-check symbol? sym 'implicit-identifier) |
---|
1878 | (if (syntax-object? id) |
---|
1879 | (wrap sym (syntax-object-wrap id)) |
---|
1880 | sym))) |
---|
1881 | (set! syntax-object->datum (lambda (x) (strip x))) |
---|
1882 | (set! generate-temporaries |
---|
1883 | (lambda (ls) |
---|
1884 | (arg-check list? ls 'generate-temporaries) |
---|
1885 | (map (lambda (x) (wrap (gensym) top-wrap)) ls))) |
---|
1886 | (set! free-identifier=? |
---|
1887 | (lambda (x y) |
---|
1888 | (arg-check id? x 'free-identifier=?) |
---|
1889 | (arg-check id? y 'free-identifier=?) |
---|
1890 | (free-id=? x y))) |
---|
1891 | (set! bound-identifier=? |
---|
1892 | (lambda (x y) |
---|
1893 | (arg-check id? x 'bound-identifier=?) |
---|
1894 | (arg-check id? y 'bound-identifier=?) |
---|
1895 | (bound-id=? x y))) |
---|
1896 | (set! identifier? (lambda (x) (id? x))) |
---|
1897 | (set! syntax-error |
---|
1898 | (lambda (object . messages) |
---|
1899 | (for-each |
---|
1900 | (lambda (x) (arg-check string? x 'syntax-error)) |
---|
1901 | messages) |
---|
1902 | ((lambda (message) |
---|
1903 | (error-hook 'expand-syntax message (strip object))) |
---|
1904 | (if (null? messages) |
---|
1905 | "invalid syntax" |
---|
1906 | (apply string-append messages))))) |
---|
1907 | (set! install-global-transformer |
---|
1908 | (lambda (sym p) (global-extend 'macro sym p))) |
---|
1909 | ((lambda () |
---|
1910 | (letrec ((matchx (lambda (e p k w r) |
---|
1911 | (if (eq? r 'no) |
---|
1912 | r |
---|
1913 | ((lambda (g000100) |
---|
1914 | (if (memv g000100 '(any)) |
---|
1915 | (cons (wrap e w) r) |
---|
1916 | (if (memv |
---|
1917 | g000100 |
---|
1918 | '(free-id)) |
---|
1919 | (if (if (identifier? |
---|
1920 | e) |
---|
1921 | (free-id=? |
---|
1922 | (wrap e w) |
---|
1923 | (vector-ref |
---|
1924 | k |
---|
1925 | (cdr p))) |
---|
1926 | #f) |
---|
1927 | r |
---|
1928 | 'no) |
---|
1929 | (begin g000100 |
---|
1930 | (if (syntax-object? |
---|
1931 | e) |
---|
1932 | (match* |
---|
1933 | (syntax-object-expression |
---|
1934 | e) |
---|
1935 | p |
---|
1936 | k |
---|
1937 | (join-wraps |
---|
1938 | w |
---|
1939 | (syntax-object-wrap |
---|
1940 | e)) |
---|
1941 | r) |
---|
1942 | (match* |
---|
1943 | e |
---|
1944 | p |
---|
1945 | k |
---|
1946 | w |
---|
1947 | r)))))) |
---|
1948 | (car p))))) |
---|
1949 | (match* (lambda (e p k w r) |
---|
1950 | ((lambda (g000101) |
---|
1951 | (if (memv g000101 '(pair)) |
---|
1952 | (if (pair? e) |
---|
1953 | (matchx |
---|
1954 | (car e) |
---|
1955 | (cadr p) |
---|
1956 | k |
---|
1957 | w |
---|
1958 | (matchx |
---|
1959 | (cdr e) |
---|
1960 | (cddr p) |
---|
1961 | k |
---|
1962 | w |
---|
1963 | r)) |
---|
1964 | 'no) |
---|
1965 | (if (memv g000101 '(each)) |
---|
1966 | (if (eq? (cadr p) 'any) |
---|
1967 | ((lambda (l) |
---|
1968 | (if (eq? l 'no) |
---|
1969 | l |
---|
1970 | (cons l r))) |
---|
1971 | (match-each-any |
---|
1972 | e |
---|
1973 | w)) |
---|
1974 | (if (null? e) |
---|
1975 | (match-empty |
---|
1976 | (cdr p) |
---|
1977 | r) |
---|
1978 | ((lambda (l) |
---|
1979 | (if (eq? l |
---|
1980 | 'no) |
---|
1981 | l |
---|
1982 | ((letrec ((collect (lambda (l) |
---|
1983 | (if (null? |
---|
1984 | (car l)) |
---|
1985 | r |
---|
1986 | (cons (map car |
---|
1987 | l) |
---|
1988 | (collect |
---|
1989 | (map cdr |
---|
1990 | l))))))) |
---|
1991 | collect) |
---|
1992 | l))) |
---|
1993 | (match-each |
---|
1994 | e |
---|
1995 | (cdr p) |
---|
1996 | k |
---|
1997 | w)))) |
---|
1998 | (if (memv |
---|
1999 | g000101 |
---|
2000 | '(atom)) |
---|
2001 | (if (equal? |
---|
2002 | (cdr p) |
---|
2003 | e) |
---|
2004 | r |
---|
2005 | 'no) |
---|
2006 | (if (memv |
---|
2007 | g000101 |
---|
2008 | '(vector)) |
---|
2009 | (if (vector? e) |
---|
2010 | (matchx |
---|
2011 | (vector->list |
---|
2012 | e) |
---|
2013 | (cdr p) |
---|
2014 | k |
---|
2015 | w |
---|
2016 | r) |
---|
2017 | 'no) |
---|
2018 | (begin g000101 |
---|
2019 | (##core#undefined))))))) |
---|
2020 | (car p)))) |
---|
2021 | (match-empty (lambda (p r) |
---|
2022 | ((lambda (g000102) |
---|
2023 | (if (memv g000102 '(any)) |
---|
2024 | (cons '() r) |
---|
2025 | (if (memv |
---|
2026 | g000102 |
---|
2027 | '(each)) |
---|
2028 | (match-empty |
---|
2029 | (cdr p) |
---|
2030 | r) |
---|
2031 | (if (memv |
---|
2032 | g000102 |
---|
2033 | '(pair)) |
---|
2034 | (match-empty |
---|
2035 | (cadr p) |
---|
2036 | (match-empty |
---|
2037 | (cddr p) |
---|
2038 | r)) |
---|
2039 | (if (memv |
---|
2040 | g000102 |
---|
2041 | '(free-id |
---|
2042 | atom)) |
---|
2043 | r |
---|
2044 | (if (memv |
---|
2045 | g000102 |
---|
2046 | '(vector)) |
---|
2047 | (match-empty |
---|
2048 | (cdr p) |
---|
2049 | r) |
---|
2050 | (begin g000102 |
---|
2051 | (##core#undefined)))))))) |
---|
2052 | (car p)))) |
---|
2053 | (match-each-any (lambda (e w) |
---|
2054 | (if (pair? e) |
---|
2055 | ((lambda (l) |
---|
2056 | (if (eq? l 'no) |
---|
2057 | l |
---|
2058 | (cons (wrap (car e) |
---|
2059 | w) |
---|
2060 | l))) |
---|
2061 | (match-each-any |
---|
2062 | (cdr e) |
---|
2063 | w)) |
---|
2064 | (if (null? e) |
---|
2065 | '() |
---|
2066 | (if (syntax-object? |
---|
2067 | e) |
---|
2068 | (match-each-any |
---|
2069 | (syntax-object-expression |
---|
2070 | e) |
---|
2071 | (join-wraps |
---|
2072 | w |
---|
2073 | (syntax-object-wrap |
---|
2074 | e))) |
---|
2075 | 'no))))) |
---|
2076 | (match-each (lambda (e p k w) |
---|
2077 | (if (pair? e) |
---|
2078 | ((lambda (first) |
---|
2079 | (if (eq? first 'no) |
---|
2080 | first |
---|
2081 | ((lambda (rest) |
---|
2082 | (if (eq? rest |
---|
2083 | 'no) |
---|
2084 | rest |
---|
2085 | (cons first |
---|
2086 | rest))) |
---|
2087 | (match-each |
---|
2088 | (cdr e) |
---|
2089 | p |
---|
2090 | k |
---|
2091 | w)))) |
---|
2092 | (matchx (car e) p k w '())) |
---|
2093 | (if (null? e) |
---|
2094 | '() |
---|
2095 | (if (syntax-object? e) |
---|
2096 | (match-each |
---|
2097 | (syntax-object-expression |
---|
2098 | e) |
---|
2099 | p |
---|
2100 | k |
---|
2101 | (join-wraps |
---|
2102 | w |
---|
2103 | (syntax-object-wrap |
---|
2104 | e))) |
---|
2105 | 'no)))))) |
---|
2106 | (set! syntax-dispatch |
---|
2107 | (lambda (expression pattern keys) |
---|
2108 | (matchx |
---|
2109 | expression |
---|
2110 | pattern |
---|
2111 | keys |
---|
2112 | empty-wrap |
---|
2113 | '()))))))))) |
---|
2114 | (install-global-transformer |
---|
2115 | 'let |
---|
2116 | (lambda (x) |
---|
2117 | ((lambda (g00095) |
---|
2118 | ((lambda (g00096) |
---|
2119 | ((lambda (g00094) |
---|
2120 | (if (not (eq? g00094 'no)) |
---|
2121 | (apply |
---|
2122 | (lambda (__ _x _v _e1 _e2) |
---|
2123 | (if (andmap identifier? _x) |
---|
2124 | (cons (cons '#(syntax-object |
---|
2125 | lambda |
---|
2126 | (top)) |
---|
2127 | (cons _x |
---|
2128 | (cons _e1 _e2))) |
---|
2129 | _v) |
---|
2130 | (g00096))) |
---|
2131 | g00094) |
---|
2132 | (g00096))) |
---|
2133 | (syntax-dispatch |
---|
2134 | g00095 |
---|
2135 | '(pair (any) |
---|
2136 | pair |
---|
2137 | (each pair (any) pair (any) atom) |
---|
2138 | pair |
---|
2139 | (any) |
---|
2140 | each |
---|
2141 | any) |
---|
2142 | (vector)))) |
---|
2143 | (lambda () |
---|
2144 | ((lambda (g00098) |
---|
2145 | ((lambda (g00099) |
---|
2146 | ((lambda (g00097) |
---|
2147 | (if (not (eq? g00097 'no)) |
---|
2148 | (apply |
---|
2149 | (lambda (__ _f _x _v _e1 _e2) |
---|
2150 | (if (andmap |
---|
2151 | identifier? |
---|
2152 | (cons _f _x)) |
---|
2153 | (cons (list '#(syntax-object |
---|
2154 | letrec |
---|
2155 | (top)) |
---|
2156 | (list (list _f |
---|
2157 | (cons '#(syntax-object |
---|
2158 | lambda |
---|
2159 | (top)) |
---|
2160 | (cons _x |
---|
2161 | (cons _e1 |
---|
2162 | _e2))))) |
---|
2163 | _f) |
---|
2164 | _v) |
---|
2165 | (g00099))) |
---|
2166 | g00097) |
---|
2167 | (g00099))) |
---|
2168 | (syntax-dispatch |
---|
2169 | g00098 |
---|
2170 | '(pair (any) |
---|
2171 | pair |
---|
2172 | (any) |
---|
2173 | pair |
---|
2174 | (each pair (any) pair (any) atom) |
---|
2175 | pair |
---|
2176 | (any) |
---|
2177 | each |
---|
2178 | any) |
---|
2179 | (vector)))) |
---|
2180 | (lambda () (syntax-error g00098)))) |
---|
2181 | g00095)))) |
---|
2182 | x))) |
---|
2183 | (install-global-transformer |
---|
2184 | 'syntax-case |
---|
2185 | ((lambda () |
---|
2186 | (letrec ((build-dispatch-call (lambda (args body val) |
---|
2187 | ((lambda (g00046) |
---|
2188 | ((lambda (g00045) |
---|
2189 | (if (not (eq? g00045 |
---|
2190 | 'no)) |
---|
2191 | body |
---|
2192 | ((lambda (g00048) |
---|
2193 | ((lambda (g00047) |
---|
2194 | (if (not (eq? g00047 |
---|
2195 | 'no)) |
---|
2196 | ((lambda (_arg1) |
---|
2197 | ((lambda (g00066) |
---|
2198 | ((lambda (g00065) |
---|
2199 | (if (not (eq? g00065 |
---|
2200 | 'no)) |
---|
2201 | ((lambda (_body |
---|
2202 | _val) |
---|
2203 | (list (list '#(syntax-object |
---|
2204 | syntax-lambda |
---|
2205 | (top)) |
---|
2206 | (list _arg1) |
---|
2207 | _body) |
---|
2208 | (list '#(syntax-object |
---|
2209 | car |
---|
2210 | (top)) |
---|
2211 | _val))) |
---|
2212 | (car g00065) |
---|
2213 | (cadr g00065)) |
---|
2214 | (syntax-error |
---|
2215 | g00066))) |
---|
2216 | (syntax-dispatch |
---|
2217 | g00066 |
---|
2218 | '(pair (any) |
---|
2219 | pair |
---|
2220 | (any) |
---|
2221 | atom) |
---|
2222 | (vector)))) |
---|
2223 | (list body |
---|
2224 | val))) |
---|
2225 | (car g00047)) |
---|
2226 | ((lambda (g00050) |
---|
2227 | ((lambda (g00049) |
---|
2228 | (if (not (eq? g00049 |
---|
2229 | 'no)) |
---|
2230 | ((lambda (_arg1 |
---|
2231 | _arg2) |
---|
2232 | ((lambda (g00064) |
---|
2233 | ((lambda (g00063) |
---|
2234 | (if (not (eq? g00063 |
---|
2235 | 'no)) |
---|
2236 | ((lambda (_body |
---|
2237 | _val) |
---|
2238 | (list (list '#(syntax-object |
---|
2239 | syntax-lambda |
---|
2240 | (top)) |
---|
2241 | (list _arg1 |
---|
2242 | _arg2) |
---|
2243 | _body) |
---|
2244 | (list '#(syntax-object |
---|
2245 | car |
---|
2246 | (top)) |
---|
2247 | _val) |
---|
2248 | (list '#(syntax-object |
---|
2249 | cadr |
---|
2250 | (top)) |
---|
2251 | _val))) |
---|
2252 | (car g00063) |
---|
2253 | (cadr g00063)) |
---|
2254 | (syntax-error |
---|
2255 | g00064))) |
---|
2256 | (syntax-dispatch |
---|
2257 | g00064 |
---|
2258 | '(pair (any) |
---|
2259 | pair |
---|
2260 | (any) |
---|
2261 | atom) |
---|
2262 | (vector)))) |
---|
2263 | (list body |
---|
2264 | val))) |
---|
2265 | (car g00049) |
---|
2266 | (cadr g00049)) |
---|
2267 | ((lambda (g00052) |
---|
2268 | ((lambda (g00051) |
---|
2269 | (if (not (eq? g00051 |
---|
2270 | 'no)) |
---|
2271 | ((lambda (_arg1 |
---|
2272 | _arg2 |
---|
2273 | _arg3) |
---|
2274 | ((lambda (g00062) |
---|
2275 | ((lambda (g00061) |
---|
2276 | (if (not (eq? g00061 |
---|
2277 | 'no)) |
---|
2278 | ((lambda (_body |
---|
2279 | _val) |
---|
2280 | (list (list '#(syntax-object |
---|
2281 | syntax-lambda |
---|
2282 | (top)) |
---|
2283 | (list _arg1 |
---|
2284 | _arg2 |
---|
2285 | _arg3) |
---|
2286 | _body) |
---|
2287 | (list '#(syntax-object |
---|
2288 | car |
---|
2289 | (top)) |
---|
2290 | _val) |
---|
2291 | (list '#(syntax-object |
---|
2292 | cadr |
---|
2293 | (top)) |
---|
2294 | _val) |
---|
2295 | (list '#(syntax-object |
---|
2296 | caddr |
---|
2297 | (top)) |
---|
2298 | _val))) |
---|
2299 | (car g00061) |
---|
2300 | (cadr g00061)) |
---|
2301 | (syntax-error |
---|
2302 | g00062))) |
---|
2303 | (syntax-dispatch |
---|
2304 | g00062 |
---|
2305 | '(pair (any) |
---|
2306 | pair |
---|
2307 | (any) |
---|
2308 | atom) |
---|
2309 | (vector)))) |
---|
2310 | (list body |
---|
2311 | val))) |
---|
2312 | (car g00051) |
---|
2313 | (cadr g00051) |
---|
2314 | (caddr |
---|
2315 | g00051)) |
---|
2316 | ((lambda (g00054) |
---|
2317 | ((lambda (g00053) |
---|
2318 | (if (not (eq? g00053 |
---|
2319 | 'no)) |
---|
2320 | ((lambda (_arg1 |
---|
2321 | _arg2 |
---|
2322 | _arg3 |
---|
2323 | _arg4) |
---|
2324 | ((lambda (g00060) |
---|
2325 | ((lambda (g00059) |
---|
2326 | (if (not (eq? g00059 |
---|
2327 | 'no)) |
---|
2328 | ((lambda (_body |
---|
2329 | _val) |
---|
2330 | (list (list '#(syntax-object |
---|
2331 | syntax-lambda |
---|
2332 | (top)) |
---|
2333 | (list _arg1 |
---|
2334 | _arg2 |
---|
2335 | _arg3 |
---|
2336 | _arg4) |
---|
2337 | _body) |
---|
2338 | (list '#(syntax-object |
---|
2339 | car |
---|
2340 | (top)) |
---|
2341 | _val) |
---|
2342 | (list '#(syntax-object |
---|
2343 | cadr |
---|
2344 | (top)) |
---|
2345 | _val) |
---|
2346 | (list '#(syntax-object |
---|
2347 | caddr |
---|
2348 | (top)) |
---|
2349 | _val) |
---|
2350 | (list '#(syntax-object |
---|
2351 | cadddr |
---|
2352 | (top)) |
---|
2353 | _val))) |
---|
2354 | (car g00059) |
---|
2355 | (cadr g00059)) |
---|
2356 | (syntax-error |
---|
2357 | g00060))) |
---|
2358 | (syntax-dispatch |
---|
2359 | g00060 |
---|
2360 | '(pair (any) |
---|
2361 | pair |
---|
2362 | (any) |
---|
2363 | atom) |
---|
2364 | (vector)))) |
---|
2365 | (list body |
---|
2366 | val))) |
---|
2367 | (car g00053) |
---|
2368 | (cadr g00053) |
---|
2369 | (caddr |
---|
2370 | g00053) |
---|
2371 | (cadddr |
---|
2372 | g00053)) |
---|
2373 | ((lambda (g00056) |
---|
2374 | ((lambda (g00055) |
---|
2375 | (if (not (eq? g00055 |
---|
2376 | 'no)) |
---|
2377 | ((lambda (_arg) |
---|
2378 | ((lambda (g00058) |
---|
2379 | ((lambda (g00057) |
---|
2380 | (if (not (eq? g00057 |
---|
2381 | 'no)) |
---|
2382 | ((lambda (_body |
---|
2383 | _val) |
---|
2384 | (list '#(syntax-object |
---|
2385 | apply |
---|
2386 | (top)) |
---|
2387 | (list '#(syntax-object |
---|
2388 | syntax-lambda |
---|
2389 | (top)) |
---|
2390 | _arg |
---|
2391 | _body) |
---|
2392 | _val)) |
---|
2393 | (car g00057) |
---|
2394 | (cadr g00057)) |
---|
2395 | (syntax-error |
---|
2396 | g00058))) |
---|
2397 | (syntax-dispatch |
---|
2398 | g00058 |
---|
2399 | '(pair (any) |
---|
2400 | pair |
---|
2401 | (any) |
---|
2402 | atom) |
---|
2403 | (vector)))) |
---|
2404 | (list body |
---|
2405 | val))) |
---|
2406 | (car g00055)) |
---|
2407 | (syntax-error |
---|
2408 | g00056))) |
---|
2409 | (syntax-dispatch |
---|
2410 | g00056 |
---|
2411 | '(each any) |
---|
2412 | (vector)))) |
---|
2413 | g00054))) |
---|
2414 | (syntax-dispatch |
---|
2415 | g00054 |
---|
2416 | '(pair (any) |
---|
2417 | pair |
---|
2418 | (any) |
---|
2419 | pair |
---|
2420 | (any) |
---|
2421 | pair |
---|
2422 | (any) |
---|
2423 | atom) |
---|
2424 | (vector)))) |
---|
2425 | g00052))) |
---|
2426 | (syntax-dispatch |
---|
2427 | g00052 |
---|
2428 | '(pair (any) |
---|
2429 | pair |
---|
2430 | (any) |
---|
2431 | pair |
---|
2432 | (any) |
---|
2433 | atom) |
---|
2434 | (vector)))) |
---|
2435 | g00050))) |
---|
2436 | (syntax-dispatch |
---|
2437 | g00050 |
---|
2438 | '(pair (any) |
---|
2439 | pair |
---|
2440 | (any) |
---|
2441 | atom) |
---|
2442 | (vector)))) |
---|
2443 | g00048))) |
---|
2444 | (syntax-dispatch |
---|
2445 | g00048 |
---|
2446 | '(pair (any) |
---|
2447 | atom) |
---|
2448 | (vector)))) |
---|
2449 | g00046))) |
---|
2450 | (syntax-dispatch |
---|
2451 | g00046 |
---|
2452 | '(atom) |
---|
2453 | (vector)))) |
---|
2454 | args))) |
---|
2455 | (extract-bound-syntax-ids (lambda (pattern keys) |
---|
2456 | ((letrec ((gen (lambda (p |
---|
2457 | n |
---|
2458 | ids) |
---|
2459 | (if (identifier? |
---|
2460 | p) |
---|
2461 | (if (key? p |
---|
2462 | keys) |
---|
2463 | ids |
---|
2464 | (cons (list p |
---|
2465 | n) |
---|
2466 | ids)) |
---|
2467 | ((lambda (g00068) |
---|
2468 | ((lambda (g00069) |
---|
2469 | ((lambda (g00067) |
---|
2470 | (if (not (eq? g00067 |
---|
2471 | 'no)) |
---|
2472 | ((lambda (_x |
---|
2473 | _dots) |
---|
2474 | (if (ellipsis? |
---|
2475 | _dots) |
---|
2476 | (gen _x |
---|
2477 | (+ n |
---|
2478 | 1) |
---|
2479 | ids) |
---|
2480 | (g00069))) |
---|
2481 | (car g00067) |
---|
2482 | (cadr g00067)) |
---|
2483 | (g00069))) |
---|
2484 | (syntax-dispatch |
---|
2485 | g00068 |
---|
2486 | '(pair (any) |
---|
2487 | pair |
---|
2488 | (any) |
---|
2489 | atom) |
---|
2490 | (vector)))) |
---|
2491 | (lambda () |
---|
2492 | ((lambda (g00071) |
---|
2493 | ((lambda (g00070) |
---|
2494 | (if (not (eq? g00070 |
---|
2495 | 'no)) |
---|
2496 | ((lambda (_x |
---|
2497 | _y) |
---|
2498 | (gen _x |
---|
2499 | n |
---|
2500 | (gen _y |
---|
2501 | n |
---|
2502 | ids))) |
---|
2503 | (car g00070) |
---|
2504 | (cadr g00070)) |
---|
2505 | ((lambda (g00073) |
---|
2506 | ((lambda (g00072) |
---|
2507 | (if (not (eq? g00072 |
---|
2508 | 'no)) |
---|
2509 | ((lambda (_x) |
---|
2510 | (gen _x |
---|
2511 | n |
---|
2512 | ids)) |
---|
2513 | (car g00072)) |
---|
2514 | ((lambda (g00075) |
---|
2515 | ((lambda (g00074) |
---|
2516 | (if (not (eq? g00074 |
---|
2517 | 'no)) |
---|
2518 | ((lambda (_x) |
---|
2519 | ids) |
---|
2520 | (car g00074)) |
---|
2521 | (syntax-error |
---|
2522 | g00075))) |
---|
2523 | (syntax-dispatch |
---|
2524 | g00075 |
---|
2525 | '(any) |
---|
2526 | (vector)))) |
---|
2527 | g00073))) |
---|
2528 | (syntax-dispatch |
---|
2529 | g00073 |
---|
2530 | '(vector |
---|
2531 | each |
---|
2532 | any) |
---|
2533 | (vector)))) |
---|
2534 | g00071))) |
---|
2535 | (syntax-dispatch |
---|
2536 | g00071 |
---|
2537 | '(pair (any) |
---|
2538 | any) |
---|
2539 | (vector)))) |
---|
2540 | g00068)))) |
---|
2541 | p))))) |
---|
2542 | gen) |
---|
2543 | pattern |
---|
2544 | 0 |
---|
2545 | '()))) |
---|
2546 | (valid-syntax-pattern? (lambda (pattern keys) |
---|
2547 | (letrec ((check? (lambda (p |
---|
2548 | ids) |
---|
2549 | (if (identifier? |
---|
2550 | p) |
---|
2551 | (if (eq? ids |
---|
2552 | 'no) |
---|
2553 | ids |
---|
2554 | (if (key? p |
---|
2555 | keys) |
---|
2556 | ids |
---|
2557 | (if (if (not (ellipsis? |
---|
2558 | p)) |
---|
2559 | (not (memid |
---|
2560 | p |
---|
2561 | ids)) |
---|
2562 | #f) |
---|
2563 | (cons p |
---|
2564 | ids) |
---|
2565 | 'no))) |
---|
2566 | ((lambda (g00077) |
---|
2567 | ((lambda (g00078) |
---|
2568 | ((lambda (g00076) |
---|
2569 | (if (not (eq? g00076 |
---|
2570 | 'no)) |
---|
2571 | ((lambda (_x |
---|
2572 | _dots) |
---|
2573 | (if (ellipsis? |
---|
2574 | _dots) |
---|
2575 | (check? |
---|
2576 | _x |
---|
2577 | ids) |
---|
2578 | (g00078))) |
---|
2579 | (car g00076) |
---|
2580 | (cadr g00076)) |
---|
2581 | (g00078))) |
---|
2582 | (syntax-dispatch |
---|
2583 | g00077 |
---|
2584 | '(pair (any) |
---|
2585 | pair |
---|
2586 | (any) |
---|
2587 | atom) |
---|
2588 | (vector)))) |
---|
2589 | (lambda () |
---|
2590 | ((lambda (g00080) |
---|
2591 | ((lambda (g00079) |
---|
2592 | (if (not (eq? g00079 |
---|
2593 | 'no)) |
---|
2594 | ((lambda (_x |
---|
2595 | _y) |
---|
2596 | (check? |
---|
2597 | _x |
---|
2598 | (check? |
---|
2599 | _y |
---|
2600 | ids))) |
---|
2601 | (car g00079) |
---|
2602 | (cadr g00079)) |
---|
2603 | ((lambda (g00082) |
---|
2604 | ((lambda (g00081) |
---|
2605 | (if (not (eq? g00081 |
---|
2606 | 'no)) |
---|
2607 | ((lambda (_x) |
---|
2608 | (check? |
---|
2609 | _x |
---|
2610 | ids)) |
---|
2611 | (car g00081)) |
---|
2612 | ((lambda (g00084) |
---|
2613 | ((lambda (g00083) |
---|
2614 | (if (not (eq? g00083 |
---|
2615 | 'no)) |
---|
2616 | ((lambda (_x) |
---|
2617 | ids) |
---|
2618 | (car g00083)) |
---|
2619 | (syntax-error |
---|
2620 | g00084))) |
---|
2621 | (syntax-dispatch |
---|
2622 | g00084 |
---|
2623 | '(any) |
---|
2624 | (vector)))) |
---|
2625 | g00082))) |
---|
2626 | (syntax-dispatch |
---|
2627 | g00082 |
---|
2628 | '(vector |
---|
2629 | each |
---|
2630 | any) |
---|
2631 | (vector)))) |
---|
2632 | g00080))) |
---|
2633 | (syntax-dispatch |
---|
2634 | g00080 |
---|
2635 | '(pair (any) |
---|
2636 | any) |
---|
2637 | (vector)))) |
---|
2638 | g00077)))) |
---|
2639 | p))))) |
---|
2640 | (not (eq? (check? |
---|
2641 | pattern |
---|
2642 | '()) |
---|
2643 | 'no))))) |
---|
2644 | (valid-keyword? (lambda (k) |
---|
2645 | (if (identifier? k) |
---|
2646 | (not (free-identifier=? |
---|
2647 | k |
---|
2648 | '...)) |
---|
2649 | #f))) |
---|
2650 | (convert-syntax-dispatch-pattern (lambda (pattern |
---|
2651 | keys) |
---|
2652 | ((letrec ((gen (lambda (p) |
---|
2653 | (if (identifier? |
---|
2654 | p) |
---|
2655 | (if (key? p |
---|
2656 | keys) |
---|
2657 | (cons '#(syntax-object |
---|
2658 | free-id |
---|
2659 | (top)) |
---|
2660 | (key-index |
---|
2661 | p |
---|
2662 | keys)) |
---|
2663 | (list '#(syntax-object |
---|
2664 | any |
---|
2665 | (top)))) |
---|
2666 | ((lambda (g00086) |
---|
2667 | ((lambda (g00087) |
---|
2668 | ((lambda (g00085) |
---|
2669 | (if (not (eq? g00085 |
---|
2670 | 'no)) |
---|
2671 | ((lambda (_x |
---|
2672 | _dots) |
---|
2673 | (if (ellipsis? |
---|
2674 | _dots) |
---|
2675 | (cons '#(syntax-object |
---|
2676 | each |
---|
2677 | (top)) |
---|
2678 | (gen _x)) |
---|
2679 | (g00087))) |
---|
2680 | (car g00085) |
---|
2681 | (cadr g00085)) |
---|
2682 | (g00087))) |
---|
2683 | (syntax-dispatch |
---|
2684 | g00086 |
---|
2685 | '(pair (any) |
---|
2686 | pair |
---|
2687 | (any) |
---|
2688 | atom) |
---|
2689 | (vector)))) |
---|
2690 | (lambda () |
---|
2691 | ((lambda (g00089) |
---|
2692 | ((lambda (g00088) |
---|
2693 | (if (not (eq? g00088 |
---|
2694 | 'no)) |
---|
2695 | ((lambda (_x |
---|
2696 | _y) |
---|
2697 | (cons '#(syntax-object |
---|
2698 | pair |
---|
2699 | (top)) |
---|
2700 | (cons (gen _x) |
---|
2701 | (gen _y)))) |
---|
2702 | (car g00088) |
---|
2703 | (cadr g00088)) |
---|
2704 | ((lambda (g00091) |
---|
2705 | ((lambda (g00090) |
---|
2706 | (if (not (eq? g00090 |
---|
2707 | 'no)) |
---|
2708 | ((lambda (_x) |
---|
2709 | (cons '#(syntax-object |
---|
2710 | vector |
---|
2711 | (top)) |
---|
2712 | (gen _x))) |
---|
2713 | (car g00090)) |
---|
2714 | ((lambda (g00093) |
---|
2715 | ((lambda (g00092) |
---|
2716 | (if (not (eq? g00092 |
---|
2717 | 'no)) |
---|
2718 | ((lambda (_x) |
---|
2719 | (cons '#(syntax-object |
---|
2720 | atom |
---|
2721 | (top)) |
---|
2722 | p)) |
---|
2723 | (car g00092)) |
---|
2724 | (syntax-error |
---|
2725 | g00093))) |
---|
2726 | (syntax-dispatch |
---|
2727 | g00093 |
---|
2728 | '(any) |
---|
2729 | (vector)))) |
---|
2730 | g00091))) |
---|
2731 | (syntax-dispatch |
---|
2732 | g00091 |
---|
2733 | '(vector |
---|
2734 | each |
---|
2735 | any) |
---|
2736 | (vector)))) |
---|
2737 | g00089))) |
---|
2738 | (syntax-dispatch |
---|
2739 | g00089 |
---|
2740 | '(pair (any) |
---|
2741 | any) |
---|
2742 | (vector)))) |
---|
2743 | g00086)))) |
---|
2744 | p))))) |
---|
2745 | gen) |
---|
2746 | pattern))) |
---|
2747 | (key-index (lambda (p keys) |
---|
2748 | (- (length keys) |
---|
2749 | (length (memid p keys))))) |
---|
2750 | (key? (lambda (p keys) |
---|
2751 | (if (identifier? p) (memid p keys) #f))) |
---|
2752 | (memid (lambda (i ids) |
---|
2753 | (if (not (null? ids)) |
---|
2754 | (if (bound-identifier=? i (car ids)) |
---|
2755 | ids |
---|
2756 | (memid i (cdr ids))) |
---|
2757 | #f))) |
---|
2758 | (ellipsis? (lambda (x) |
---|
2759 | (if (identifier? x) |
---|
2760 | (free-identifier=? x '...) |
---|
2761 | #f)))) |
---|
2762 | (lambda (x) |
---|
2763 | ((lambda (g00030) |
---|
2764 | ((lambda (g00031) |
---|
2765 | ((lambda (g00029) |
---|
2766 | (if (not (eq? g00029 'no)) |
---|
2767 | ((lambda (__ _val _key) |
---|
2768 | (if (andmap valid-keyword? _key) |
---|
2769 | (list '#(syntax-object |
---|
2770 | syntax-error |
---|
2771 | (top)) |
---|
2772 | _val) |
---|
2773 | (g00031))) |
---|
2774 | (car g00029) |
---|
2775 | (cadr g00029) |
---|
2776 | (caddr g00029)) |
---|
2777 | (g00031))) |
---|
2778 | (syntax-dispatch |
---|
2779 | g00030 |
---|
2780 | '(pair (any) |
---|
2781 | pair |
---|
2782 | (any) |
---|
2783 | pair |
---|
2784 | (each any) |
---|
2785 | atom) |
---|
2786 | (vector)))) |
---|
2787 | (lambda () |
---|
2788 | ((lambda (g00033) |
---|
2789 | ((lambda (g00034) |
---|
2790 | ((lambda (g00032) |
---|
2791 | (if (not (eq? g00032 'no)) |
---|
2792 | (apply |
---|
2793 | (lambda (__ |
---|
2794 | _val |
---|
2795 | _key |
---|
2796 | _pat |
---|
2797 | _exp) |
---|
2798 | (if (if (identifier? |
---|
2799 | _pat) |
---|
2800 | (if (andmap |
---|
2801 | valid-keyword? |
---|
2802 | _key) |
---|
2803 | (andmap |
---|
2804 | (lambda (x) |
---|
2805 | (not (free-identifier=? |
---|
2806 | _pat |
---|
2807 | x))) |
---|
2808 | (cons '... |
---|
2809 | _key)) |
---|
2810 | #f) |
---|
2811 | #f) |
---|
2812 | (list (list '#(syntax-object |
---|
2813 | syntax-lambda |
---|
2814 | (top)) |
---|
2815 | (list (list _pat |
---|
2816 | 0)) |
---|
2817 | _exp) |
---|
2818 | _val) |
---|
2819 | (g00034))) |
---|
2820 | g00032) |
---|
2821 | (g00034))) |
---|
2822 | (syntax-dispatch |
---|
2823 | g00033 |
---|
2824 | '(pair (any) |
---|
2825 | pair |
---|
2826 | (any) |
---|
2827 | pair |
---|
2828 | (each any) |
---|
2829 | pair |
---|
2830 | (pair (any) pair (any) atom) |
---|
2831 | atom) |
---|
2832 | (vector)))) |
---|
2833 | (lambda () |
---|
2834 | ((lambda (g00036) |
---|
2835 | ((lambda (g00037) |
---|
2836 | ((lambda (g00035) |
---|
2837 | (if (not (eq? g00035 'no)) |
---|
2838 | (apply |
---|
2839 | (lambda (__ |
---|
2840 | _val |
---|
2841 | _key |
---|
2842 | _pat |
---|
2843 | _exp |
---|
2844 | _e1 |
---|
2845 | _e2 |
---|
2846 | _e3) |
---|
2847 | (if (if (andmap |
---|
2848 | valid-keyword? |
---|
2849 | _key) |
---|
2850 | (valid-syntax-pattern? |
---|
2851 | _pat |
---|
2852 | _key) |
---|
2853 | #f) |
---|
2854 | ((lambda (g00044) |
---|
2855 | ((lambda (g00043) |
---|
2856 | (if (not (eq? g00043 |
---|
2857 | 'no)) |
---|
2858 | ((lambda (_pattern |
---|
2859 | _y |
---|
2860 | _call) |
---|
2861 | (list '#(syntax-object |
---|
2862 | let |
---|
2863 | (top)) |
---|
2864 | (list (list '#(syntax-object |
---|
2865 | x |
---|
2866 | (top)) |
---|
2867 | _val)) |
---|
2868 | (list '#(syntax-object |
---|
2869 | let |
---|
2870 | (top)) |
---|
2871 | (list (list _y |
---|
2872 | (list '#(syntax-object |
---|
2873 | syntax-dispatch |
---|
2874 | (top)) |
---|
2875 | '#(syntax-object |
---|
2876 | x |
---|
2877 | (top)) |
---|
2878 | (list '#(syntax-object |
---|
2879 | quote |
---|
2880 | (top)) |
---|
2881 | _pattern) |
---|
2882 | (list '#(syntax-object |
---|
2883 | syntax |
---|
2884 | (top)) |
---|
2885 | (list->vector |
---|
2886 | _key))))) |
---|
2887 | (list '#(syntax-object |
---|
2888 | if |
---|
2889 | (top)) |
---|
2890 | (list '#(syntax-object |
---|
2891 | not |
---|
2892 | (top)) |
---|
2893 | (list '#(syntax-object |
---|
2894 | eq? |
---|
2895 | (top)) |
---|
2896 | _y |
---|
2897 | (list '#(syntax-object |
---|
2898 | quote |
---|
2899 | (top)) |
---|
2900 | '#(syntax-object |
---|
2901 | no |
---|
2902 | (top))))) |
---|
2903 | _call |
---|
2904 | (cons '#(syntax-object |
---|
2905 | syntax-case |
---|
2906 | (top)) |
---|
2907 | (cons '#(syntax-object |
---|
2908 | x |
---|
2909 | (top)) |
---|
2910 | (cons _key |
---|
2911 | (map (lambda (__e1 |
---|
2912 | __e2 |
---|
2913 | __e3) |
---|
2914 | (cons __e1 |
---|
2915 | (cons __e2 |
---|
2916 | __e3))) |
---|
2917 | _e1 |
---|
2918 | _e2 |
---|
2919 | _e3)))))))) |
---|
2920 | (car g00043) |
---|
2921 | (cadr g00043) |
---|
2922 | (caddr |
---|
2923 | g00043)) |
---|
2924 | (syntax-error |
---|
2925 | g00044))) |
---|
2926 | (syntax-dispatch |
---|
2927 | g00044 |
---|
2928 | '(pair (any) |
---|
2929 | pair |
---|
2930 | (any) |
---|
2931 | pair |
---|
2932 | (any) |
---|
2933 | atom) |
---|
2934 | (vector)))) |
---|
2935 | (list (convert-syntax-dispatch-pattern |
---|
2936 | _pat |
---|
2937 | _key) |
---|
2938 | '#(syntax-object |
---|
2939 | y |
---|
2940 | (top)) |
---|
2941 | (build-dispatch-call |
---|
2942 | (extract-bound-syntax-ids |
---|
2943 | _pat |
---|
2944 | _key) |
---|
2945 | _exp |
---|
2946 | '#(syntax-object |
---|
2947 | y |
---|
2948 | (top))))) |
---|
2949 | (g00037))) |
---|
2950 | g00035) |
---|
2951 | (g00037))) |
---|
2952 | (syntax-dispatch |
---|
2953 | g00036 |
---|
2954 | '(pair (any) |
---|
2955 | pair |
---|
2956 | (any) |
---|
2957 | pair |
---|
2958 | (each any) |
---|
2959 | pair |
---|
2960 | (pair (any) |
---|
2961 | pair |
---|
2962 | (any) |
---|
2963 | atom) |
---|
2964 | each |
---|
2965 | pair |
---|
2966 | (any) |
---|
2967 | pair |
---|
2968 | (any) |
---|
2969 | each |
---|
2970 | any) |
---|
2971 | (vector)))) |
---|
2972 | (lambda () |
---|
2973 | ((lambda (g00039) |
---|
2974 | ((lambda (g00040) |
---|
2975 | ((lambda (g00038) |
---|
2976 | (if (not (eq? g00038 |
---|
2977 | 'no)) |
---|
2978 | (apply |
---|
2979 | (lambda (__ |
---|
2980 | _val |
---|
2981 | _key |
---|
2982 | _pat |
---|
2983 | _fender |
---|
2984 | _exp |
---|
2985 | _e1 |
---|
2986 | _e2 |
---|
2987 | _e3) |
---|
2988 | (if (if (andmap |
---|
2989 | valid-keyword? |
---|
2990 | _key) |
---|
2991 | (valid-syntax-pattern? |
---|
2992 | _pat |
---|
2993 | _key) |
---|
2994 | #f) |
---|
2995 | ((lambda (g00042) |
---|
2996 | ((lambda (g00041) |
---|
2997 | (if (not (eq? g00041 |
---|
2998 | 'no)) |
---|
2999 | ((lambda (_pattern |
---|
3000 | _y |
---|
3001 | _dorest |
---|
3002 | _call) |
---|
3003 | (list '#(syntax-object |
---|
3004 | let |
---|
3005 | (top)) |
---|
3006 | (list (list '#(syntax-object |
---|
3007 | x |
---|
3008 | (top)) |
---|
3009 | _val)) |
---|
3010 | (list '#(syntax-object |
---|
3011 | let |
---|
3012 | (top)) |
---|
3013 | (list (list _dorest |
---|
3014 | (list '#(syntax-object |
---|
3015 | lambda |
---|
3016 | (top)) |
---|
3017 | '() |
---|
3018 | (cons '#(syntax-object |
---|
3019 | syntax-case |
---|
3020 | (top)) |
---|
3021 | (cons '#(syntax-object |
---|
3022 | x |
---|
3023 | (top)) |
---|
3024 | (cons _key |
---|
3025 | (map (lambda (__e1 |
---|
3026 | __e2 |
---|
3027 | __e3) |
---|
3028 | (cons __e1 |
---|
3029 | (cons __e2 |
---|
3030 | __e3))) |
---|
3031 | _e1 |
---|
3032 | _e2 |
---|
3033 | _e3))))))) |
---|
3034 | (list '#(syntax-object |
---|
3035 | let |
---|
3036 | (top)) |
---|
3037 | (list (list _y |
---|
3038 | (list '#(syntax-object |
---|
3039 | syntax-dispatch |
---|
3040 | (top)) |
---|
3041 | '#(syntax-object |
---|
3042 | x |
---|
3043 | (top)) |
---|
3044 | (list '#(syntax-object |
---|
3045 | quote |
---|
3046 | (top)) |
---|
3047 | _pattern) |
---|
3048 | (list '#(syntax-object |
---|
3049 | syntax |
---|
3050 | (top)) |
---|
3051 | (list->vector |
---|
3052 | _key))))) |
---|
3053 | (list '#(syntax-object |
---|
3054 | if |
---|
3055 | (top)) |
---|
3056 | (list '#(syntax-object |
---|
3057 | not |
---|
3058 | (top)) |
---|
3059 | (list '#(syntax-object |
---|
3060 | eq? |
---|
3061 | (top)) |
---|
3062 | _y |
---|
3063 | (list '#(syntax-object |
---|
3064 | quote |
---|
3065 | (top)) |
---|
3066 | '#(syntax-object |
---|
3067 | no |
---|
3068 | (top))))) |
---|
3069 | _call |
---|
3070 | (list _dorest)))))) |
---|
3071 | (car g00041) |
---|
3072 | (cadr g00041) |
---|
3073 | (caddr |
---|
3074 | g00041) |
---|
3075 | (cadddr |
---|
3076 | g00041)) |
---|
3077 | (syntax-error |
---|
3078 | g00042))) |
---|
3079 | (syntax-dispatch |
---|
3080 | g00042 |
---|
3081 | '(pair (any) |
---|
3082 | pair |
---|
3083 | (any) |
---|
3084 | pair |
---|
3085 | (any) |
---|
3086 | pair |
---|
3087 | (any) |
---|
3088 | atom) |
---|
3089 | (vector)))) |
---|
3090 | (list (convert-syntax-dispatch-pattern |
---|
3091 | _pat |
---|
3092 | _key) |
---|
3093 | '#(syntax-object |
---|
3094 | y |
---|
3095 | (top)) |
---|
3096 | '#(syntax-object |
---|
3097 | dorest |
---|
3098 | (top)) |
---|
3099 | (build-dispatch-call |
---|
3100 | (extract-bound-syntax-ids |
---|
3101 | _pat |
---|
3102 | _key) |
---|
3103 | (list '#(syntax-object |
---|
3104 | if |
---|
3105 | (top)) |
---|
3106 | _fender |
---|
3107 | _exp |
---|
3108 | (list '#(syntax-object |
---|
3109 | dorest |
---|
3110 | (top)))) |
---|
3111 | '#(syntax-object |
---|
3112 | y |
---|
3113 | (top))))) |
---|
3114 | (g00040))) |
---|
3115 | g00038) |
---|
3116 | (g00040))) |
---|
3117 | (syntax-dispatch |
---|
3118 | g00039 |
---|
3119 | '(pair (any) |
---|
3120 | pair |
---|
3121 | (any) |
---|
3122 | pair |
---|
3123 | (each any) |
---|
3124 | pair |
---|
3125 | (pair (any) |
---|
3126 | pair |
---|
3127 | (any) |
---|
3128 | pair |
---|
3129 | (any) |
---|
3130 | atom) |
---|
3131 | each |
---|
3132 | pair |
---|
3133 | (any) |
---|
3134 | pair |
---|
3135 | (any) |
---|
3136 | each |
---|
3137 | any) |
---|
3138 | (vector)))) |
---|
3139 | (lambda () |
---|
3140 | (syntax-error |
---|
3141 | g00039)))) |
---|
3142 | g00036)))) |
---|
3143 | g00033)))) |
---|
3144 | g00030)))) |
---|
3145 | x))))))) |
---|
3146 | |
---|
3147 | |
---|
3148 | ;;; Install: |
---|
3149 | |
---|
3150 | |
---|
3151 | ;;; CHICKEN specific macros: |
---|
3152 | |
---|
3153 | (define srfi-0-def #<<EOF |
---|
3154 | (define-syntax cond-expand |
---|
3155 | (lambda (x) |
---|
3156 | (syntax-case x (else not or and) |
---|
3157 | [(_) |
---|
3158 | (##sys#error |
---|
3159 | (##core#immutable '"no matching clause in `cond-expand' form") ) ] |
---|
3160 | [(_ (else body ...)) |
---|
3161 | (syntax (begin body ...)) ] |
---|
3162 | [(_ ((and) body ...) more ...) |
---|
3163 | (syntax (begin body ...)) ] |
---|
3164 | [(_ ((and req1 req2 ...) body ...) more ...) |
---|
3165 | (syntax (cond-expand |
---|
3166 | (req1 |
---|
3167 | (cond-expand |
---|
3168 | ((and req2 ...) body ...) |
---|
3169 | more ...)) |
---|
3170 | more ...) ) ] |
---|
3171 | [(_ ((or) body ...) more ...) |
---|
3172 | (syntax (cond-expand more ...)) ] |
---|
3173 | [(_ ((or req1 req2 ...) body ...) more ...) |
---|
3174 | (syntax (cond-expand |
---|
3175 | (req1 (begin body ...)) |
---|
3176 | (else (cond-expand |
---|
3177 | ((or req2 ...) body ...) |
---|
3178 | more ...) ) ) ) ] |
---|
3179 | [(_ ((not req) body ...) more ...) |
---|
3180 | (syntax (cond-expand |
---|
3181 | (req (cond-expand more ...)) |
---|
3182 | (else body ...) ) ) ] |
---|
3183 | [(_ (req body ...) more ...) |
---|
3184 | (if (##sys#test-feature (syntax-object->datum (syntax req))) |
---|
3185 | (syntax (begin body ...)) |
---|
3186 | (syntax (cond-expand more ...)) ) ] ) ) ) |
---|
3187 | EOF |
---|
3188 | ) |
---|
3189 | |
---|
3190 | ;;; macro-defs.ss |
---|
3191 | ;;; Robert Hieb & Kent Dybvig |
---|
3192 | ;;; 92/06/18 |
---|
3193 | |
---|
3194 | (define std-defs #<<EOF |
---|
3195 | (begin |
---|
3196 | |
---|
3197 | (define-syntax with-syntax |
---|
3198 | (lambda (x) |
---|
3199 | (syntax-case x () |
---|
3200 | ((_ () e1 e2 ...) |
---|
3201 | (syntax (begin e1 e2 ...))) |
---|
3202 | ((_ ((out in)) e1 e2 ...) |
---|
3203 | (syntax (syntax-case in () (out (begin e1 e2 ...))))) |
---|
3204 | ((_ ((out in) ...) e1 e2 ...) |
---|
3205 | (syntax (syntax-case (list in ...) () |
---|
3206 | ((out ...) (begin e1 e2 ...)))))))) |
---|
3207 | |
---|
3208 | (define-syntax syntax-rules |
---|
3209 | (lambda (x) |
---|
3210 | (syntax-case x () |
---|
3211 | ((_ (k ...) ((keyword . pattern) template) ...) |
---|
3212 | (with-syntax (((dummy ...) |
---|
3213 | (generate-temporaries (syntax (keyword ...))))) |
---|
3214 | (syntax (lambda (x) |
---|
3215 | (syntax-case x (k ...) |
---|
3216 | ((dummy . pattern) (syntax template)) |
---|
3217 | ...)))))))) |
---|
3218 | |
---|
3219 | (define-syntax or |
---|
3220 | (lambda (x) |
---|
3221 | (syntax-case x () |
---|
3222 | ((_) (syntax #f)) |
---|
3223 | ((_ e) (syntax e)) |
---|
3224 | ((_ e1 e2 e3 ...) |
---|
3225 | (syntax (let ((t e1)) (if t t (or e2 e3 ...)))))))) |
---|
3226 | |
---|
3227 | (define-syntax and |
---|
3228 | (lambda (x) |
---|
3229 | (syntax-case x () |
---|
3230 | ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f))) |
---|
3231 | ((_ e) (syntax e)) |
---|
3232 | ((_) (syntax #t))))) |
---|
3233 | |
---|
3234 | (define-syntax cond |
---|
3235 | (lambda (x) |
---|
3236 | (syntax-case x (else =>) |
---|
3237 | ((_ (else e1 e2 ...)) |
---|
3238 | (syntax (begin e1 e2 ...))) |
---|
3239 | ((_ (e0)) |
---|
3240 | (syntax (let ((t e0)) (if t t)))) |
---|
3241 | ((_ (e0) c1 c2 ...) |
---|
3242 | (syntax (let ((t e0)) (if t t (cond c1 c2 ...))))) |
---|
3243 | ((_ (e0 => e1)) (syntax (let ((t e0)) (if t (e1 t))))) |
---|
3244 | ((_ (e0 => e1) c1 c2 ...) |
---|
3245 | (syntax (let ((t e0)) (if t (e1 t) (cond c1 c2 ...))))) |
---|
3246 | ((_ (e0 e1 e2 ...)) (syntax (if e0 (begin e1 e2 ...)))) |
---|
3247 | ((_ (e0 e1 e2 ...) c1 c2 ...) |
---|
3248 | (syntax (if e0 (begin e1 e2 ...) (cond c1 c2 ...))))))) |
---|
3249 | |
---|
3250 | (define-syntax let* |
---|
3251 | (lambda (x) |
---|
3252 | (syntax-case x () |
---|
3253 | ((let* () e1 e2 ...) |
---|
3254 | (syntax (let () e1 e2 ...))) |
---|
3255 | ((let* ((x1 v1) (x2 v2) ...) e1 e2 ...) |
---|
3256 | (andmap identifier? (syntax (x1 x2 ...))) |
---|
3257 | (syntax (let ((x1 v1)) (let* ((x2 v2) ...) e1 e2 ...))))))) |
---|
3258 | |
---|
3259 | (define-syntax case |
---|
3260 | (lambda (x) |
---|
3261 | (syntax-case x (else) |
---|
3262 | ((_ v (else e1 e2 ...)) |
---|
3263 | (syntax (begin e1 e2 ...))) |
---|
3264 | ((_ v ((k1 ...) e1 e2 ...)) |
---|
3265 | (syntax (let ((x v)) |
---|
3266 | (if (or (eqv? x 'k1) ...) (begin e1 e2 ...)) ) ) ) |
---|
3267 | ((_ v ((k1 ...) e1 e2 ...) c1 c2 ...) |
---|
3268 | (syntax (let ((x v)) |
---|
3269 | (if (or (eqv? x 'k1) ...) |
---|
3270 | (begin e1 e2 ...) |
---|
3271 | (case x c1 c2 ...))))))) ) |
---|
3272 | |
---|
3273 | (define-syntax do |
---|
3274 | (lambda (orig-x) |
---|
3275 | (syntax-case orig-x () |
---|
3276 | ((_ ((var init . step) ...) (e0 e1 ...) c ...) |
---|
3277 | (with-syntax (((step ...) |
---|
3278 | (map (lambda (v s) |
---|
3279 | (syntax-case s () |
---|
3280 | (() v) |
---|
3281 | ((e) (syntax e)) |
---|
3282 | (_ (syntax-error orig-x)))) |
---|
3283 | (syntax (var ...)) |
---|
3284 | (syntax (step ...))))) |
---|
3285 | (syntax-case (syntax (e1 ...)) () |
---|
3286 | (() (syntax (let doloop ((var init) ...) |
---|
3287 | (if (not e0) |
---|
3288 | (begin c ... (doloop step ...)))))) |
---|
3289 | ((e1 e2 ...) |
---|
3290 | (syntax (let doloop ((var init) ...) |
---|
3291 | (if e0 |
---|
3292 | (begin e1 e2 ...) |
---|
3293 | (begin c ... (doloop step ...)))))))))))) |
---|
3294 | |
---|
3295 | (define-syntax quasiquote |
---|
3296 | (letrec |
---|
3297 | ((gen-cons |
---|
3298 | (lambda (x y) |
---|
3299 | (syntax-case x (quote) |
---|
3300 | ((quote x) |
---|
3301 | (syntax-case y (quote ##sys#list) |
---|
3302 | ((quote y) (syntax (quote (x . y)))) |
---|
3303 | ((##sys#list y ...) (syntax (##sys#list (quote x) y ...))) |
---|
3304 | (y (syntax (##sys#cons (quote x) y))))) |
---|
3305 | (x (syntax-case y (quote ##sys#list) |
---|
3306 | ((quote ()) (syntax (##sys#list x))) |
---|
3307 | ((##sys#list y ...) (syntax (##sys#list x y ...))) |
---|
3308 | (y (syntax (##sys#cons x y)))))))) |
---|
3309 | |
---|
3310 | (gen-append |
---|
3311 | (lambda (x y) |
---|
3312 | (syntax-case x (quote ##sys#list ##sys#cons) |
---|
3313 | ((quote (x1 x2 ...)) |
---|
3314 | (syntax-case y (quote) |
---|
3315 | ((quote y) (syntax (quote (x1 x2 ... . y)))) |
---|
3316 | (y (syntax (##sys#append (quote (x1 x2 ...) y)))))) |
---|
3317 | ((quote ()) y) |
---|
3318 | ((##sys#list x1 x2 ...) |
---|
3319 | (gen-cons (syntax x1) (gen-append (syntax (##sys#list x2 ...)) y))) |
---|
3320 | (x (syntax-case y (quote ##sys#list) |
---|
3321 | ((quote ()) (syntax x)) |
---|
3322 | (y (syntax (##sys#append x y)))))))) |
---|
3323 | |
---|
3324 | (gen-vector |
---|
3325 | (lambda (x) |
---|
3326 | (syntax-case x (quote ##sys#list) |
---|
3327 | ((quote (x ...)) (syntax (quote #(x ...)))) |
---|
3328 | ((##sys#list x ...) (syntax (##sys#vector x ...))) |
---|
3329 | (x (syntax (##sys#list->vector x)))))) |
---|
3330 | |
---|
3331 | (gen |
---|
3332 | (lambda (p lev) |
---|
3333 | (syntax-case p (unquote unquote-splicing quasiquote) |
---|
3334 | ((unquote p) |
---|
3335 | (if (fx= lev 0) |
---|
3336 | (syntax p) |
---|
3337 | (gen-cons (syntax (quote unquote)) |
---|
3338 | (gen (syntax (p)) (fx- lev 1))))) |
---|
3339 | (((unquote-splicing p) . q) |
---|
3340 | (if (fx= lev 0) |
---|
3341 | (gen-append (syntax p) (gen (syntax q) lev)) |
---|
3342 | (gen-cons (gen-cons (syntax (quote unquote-splicing)) |
---|
3343 | (gen (syntax p) (fx- lev 1))) |
---|
3344 | (gen (syntax q) lev)))) |
---|
3345 | ((quasiquote p) |
---|
3346 | (gen-cons (syntax (quote quasiquote)) |
---|
3347 | (gen (syntax (p)) (fx+ lev 1)))) |
---|
3348 | ((p . q) |
---|
3349 | (gen-cons (gen (syntax p) lev) (gen (syntax q) lev))) |
---|
3350 | (#(x ...) (gen-vector (gen (syntax (x ...)) lev))) |
---|
3351 | (p (syntax (quote p))))))) |
---|
3352 | |
---|
3353 | (lambda (x) |
---|
3354 | (syntax-case x () |
---|
3355 | ((- e) (gen (syntax e) 0)))))) |
---|
3356 | |
---|
3357 | (define-syntax delay |
---|
3358 | (lambda (x) |
---|
3359 | (syntax-case x () |
---|
3360 | ((delay exp) |
---|
3361 | (syntax (##sys#make-promise (lambda () exp))))))) |
---|
3362 | ) |
---|
3363 | EOF |
---|
3364 | ) |
---|
3365 | |
---|
3366 | (define install-macro-defs |
---|
3367 | (let ([open-input-string open-input-string] |
---|
3368 | [read read] |
---|
3369 | [expand-syntax expand-syntax] ) |
---|
3370 | (lambda (defstr) |
---|
3371 | (let ([in (open-input-string defstr)]) |
---|
3372 | (expand-syntax (read in)) ) ) ) ) |
---|
3373 | |
---|
3374 | (define install-macro-package |
---|
3375 | (let ([installed #f]) |
---|
3376 | (lambda args |
---|
3377 | (unless installed |
---|
3378 | (let-optionals* args ([std #f] [srfi0 #f]) |
---|
3379 | (set! installed #t) |
---|
3380 | (expand-install-hook expand-syntax) |
---|
3381 | (set! macro? |
---|
3382 | (lambda (name) |
---|
3383 | (##sys#check-symbol name) |
---|
3384 | (let ((x (get-global-definition-hook name))) |
---|
3385 | (and x (eq? (car x) 'macro)) ) ) ) |
---|
3386 | (set! macroexpand (lambda (exp . me) (expand-syntax exp))) |
---|
3387 | (set! undefine-macro! (lambda names (##sys#error "can not undefine high-level macros" names))) |
---|
3388 | (register-feature! #:hygienic-macros) |
---|
3389 | (install-macro-defs std-defs) |
---|
3390 | (when srfi0 (install-macro-defs srfi-0-def)) |
---|
3391 | (unless std (load (##sys#resolve-include-filename "highlevel-macros"))) ) ) ) ) ) |
---|