source: project/chicken/tags/0.1071/syntax-case.scm @ 17995

Last change on this file since 17995 was 17995, checked in by felix winkelmann, 9 years ago

imported historic version of chicken (0.1071)

File size: 246.4 KB
Line 
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 ...)) ) ] ) ) )
3187EOF
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)
3363EOF
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"))) ) ) ) ) )
Note: See TracBrowser for help on using the repository browser.