source: project/chicken/tags/0.1071/match.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: 174.4 KB
Line 
1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2;; Pattern Matching Syntactic Extensions for Scheme
3;;
4(define ##match#version "Version 1.18, July 17, 1995 (Chicken port)")
5;;
6;; Report bugs to wright@research.nj.nec.com.  The most recent version of
7;; this software can be obtained by anonymous FTP from ftp.nj.nec.com
8;; in file pub/wright/match.tar.Z.  Be sure to set "type binary" when
9;; transferring this file.
10;;
11;; Written by Andrew K. Wright, 1993 (wright@research.nj.nec.com).
12;; Adapted from code originally written by Bruce F. Duba, 1991.
13;; This package also includes a modified version of Kent Dybvig's
14;; define-structure (see Dybvig, R.K., The Scheme Programming Language,
15;; Prentice-Hall, NJ, 1987).
16;;
17;; This software is in the public domain.  Feel free to copy,
18;; distribute, and modify this software as desired.  No warranties
19;; nor guarantees of any kind apply.  Please return any improvements
20;; or bug fixes to wright@research.nj.nec.com so that they may be included
21;; in future releases.
22;;
23;; This macro package extends Scheme with several new expression forms.
24;; Following is a brief summary of the new forms.  See the associated
25;; LaTeX documentation for a full description of their functionality.
26;;
27;;
28;;         match expressions:
29;;
30;; exp ::= ...
31;;       | (match exp clause ...)
32;;       | (match-lambda clause ...)
33;;       | (match-lambda* clause ...)
34;;       | (match-let ((pat exp) ...) body)
35;;       | (match-let* ((pat exp) ...) body)
36;;       | (match-letrec ((pat exp) ...) body)
37;;       | (match-define pat exp)
38;;
39;; clause ::= (pat body) | (pat => exp)
40;;
41;;         patterns:                       matches:
42;;
43;; pat ::= identifier                      anything, and binds identifier
44;;       | _                               anything
45;;       | ()                              the empty list
46;;       | #t                              #t
47;;       | #f                              #f
48;;       | string                          a string
49;;       | number                          a number
50;;       | character                       a character
51;;       | 'sexp                           an s-expression
52;;       | 'symbol                         a symbol (special case of s-expr)
53;;       | (pat_1 ... pat_n)               list of n elements
54;;       | (pat_1 ... pat_n . pat_{n+1})   list of n or more
55;;       | (pat_1 ... pat_n pat_n+1 ooo)   list of n or more, each element
56;;                                           of remainder must match pat_n+1
57;;       | #(pat_1 ... pat_n)              vector of n elements
58;;       | #(pat_1 ... pat_n pat_n+1 ooo)  vector of n or more, each element
59;;                                           of remainder must match pat_n+1
60;;       | #&pat                           box
61;;       | ($ struct-name pat_1 ... pat_n) a structure
62;;       | (= field pat)                   a field of a structure
63;;       | (and pat_1 ... pat_n)           if all of pat_1 thru pat_n match
64;;       | (or pat_1 ... pat_n)            if any of pat_1 thru pat_n match
65;;       | (not pat_1 ... pat_n)           if all pat_1 thru pat_n don't match
66;;       | (? predicate pat_1 ... pat_n)   if predicate true and all of
67;;                                           pat_1 thru pat_n match
68;;       | (set! identifier)               anything, and binds setter
69;;       | (get! identifier)               anything, and binds getter
70;;       | `qp                             a quasi-pattern
71;;
72;; ooo ::= ...                             zero or more
73;;       | ___                             zero or more
74;;       | ..k                             k or more
75;;       | __k                             k or more
76;;
77;;         quasi-patterns:                 matches:
78;;
79;; qp  ::= ()                              the empty list
80;;       | #t                              #t
81;;       | #f                              #f
82;;       | string                          a string
83;;       | number                          a number
84;;       | character                       a character
85;;       | identifier                      a symbol
86;;       | (qp_1 ... qp_n)                 list of n elements
87;;       | (qp_1 ... qp_n . qp_{n+1})      list of n or more
88;;       | (qp_1 ... qp_n qp_n+1 ooo)      list of n or more, each element
89;;                                           of remainder must match qp_n+1
90;;       | #(qp_1 ... qp_n)                vector of n elements
91;;       | #(qp_1 ... qp_n qp_n+1 ooo)     vector of n or more, each element
92;;                                           of remainder must match qp_n+1
93;;       | #&qp                            box
94;;       | ,pat                            a pattern
95;;       | ,@pat                           a pattern
96;;
97;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
98;; and, or, not, set!, get!, ..., ___) cannot be used as pattern variables.
99;;
100;;
101;;         structure expressions:
102;;
103;; exp ::= ...
104;;       | (define-structure (id_0 id_1 ... id_n))
105;;       | (define-structure (id_0 id_1 ... id_n)
106;;                           ((id_{n+1} exp_1) ... (id_{n+m} exp_m)))
107;;       | (define-const-structure (id_0 arg_1 ... arg_n))
108;;       | (define-const-structure (id_0 arg_1 ... arg_n)
109;;                                 ((arg_{n+1} exp_1) ... (arg_{n+m} exp_m)))
110;;
111;; arg ::= id | (! id) | (@ id)
112;;
113;;
114;; match:error-control controls what code is generated for failed matches.
115;; Possible values:
116;;  'unspecified - do nothing, ie., evaluate (cond [#f #f])
117;;  'fail - call match:error, or die at car or cdr
118;;  'error - call match:error with the unmatched value
119;;  'match - call match:error with the unmatched value _and_
120;;             the quoted match expression
121;; match:error-control is set by calling match:set-error-control with
122;; the new value.
123;;
124;; match:error is called for a failed match.
125;; match:error is set by calling match:set-error with the new value.
126;;
127;; match:structure-control controls the uniqueness of structures
128;; (does not exist for Scheme 48 version).
129;; Possible values:
130;;  'vector - (default) structures are vectors with a symbol in position 0
131;;  'disjoint - structures are fully disjoint from all other values
132;; match:structure-control is set by calling match:set-structure-control
133;; with the new value.
134;;
135;; match:runtime-structures controls whether local structure declarations
136;; generate new structures each time they are reached
137;; (does not exist for Scheme 48 version).
138;; Possible values:
139;;  #t - (default) each runtime occurrence generates a new structure
140;;  #f - each lexical occurrence generates a new structure
141;;
142;; End of user visible/modifiable stuff.
143;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
144
145; 10/07/00 - felix:
146;
147
148
149(declare
150 (unit match)
151 (interrupts-disabled)
152 (usual-integrations) )
153
154(cond-expand 
155 [paranoia]
156 [else
157  (declare
158    (no-bound-checks) ) ] )
159
160(register-feature! 'match)
161
162
163;
164;  - Adapted (roughly) to CHICKEN
165
166(define ##match#syntax-err
167  (lambda (obj msg) (##sys#error msg obj)))
168(define ##match#disjoint-structure-tags '())
169(define ##match#structure?
170  (lambda (tag) (memq tag ##match#disjoint-structure-tags)))
171(define ##match#structure-control 'vector)
172(define ##match#set-structure-control
173  (lambda (v) (set! ##match#structure-control v)))
174(define ##match#set-error (lambda (v) (set! ##sys#match-error v)))
175(define ##match#error-control #:error)
176(define ##match#set-error-control
177  (lambda (v) (set! ##match#error-control v)))
178(define ##match#disjoint-predicates
179  (cons 'null
180        '(pair?
181           symbol?
182           boolean?
183           number?
184           string?
185           char?
186           procedure?
187           vector?)))
188(define ##match#vector-structures '())
189(define ##match#expanders
190  (letrec ((genmatch (lambda (x clauses match-expr)
191                       (let* ((length>= (gensym))
192                              (eb-errf (error-maker match-expr))
193                              (blist (car eb-errf))
194                              (plist (map (lambda (c)
195                                            (let* ((x (bound
196                                                        (validate-pattern
197                                                          (car c))))
198                                                   (p (car x))
199                                                   (bv (cadr x))
200                                                   (bindings (caddr x))
201                                                   (code (gensym))
202                                                   (fail (and (pair?
203                                                                (cdr c))
204                                                              (pair?
205                                                                (cadr c))
206                                                              (eq? (caadr
207                                                                     c)
208                                                                   '=>)
209                                                              (symbol?
210                                                                (cadadr c))
211                                                              (pair?
212                                                                (cdadr c))
213                                                              (null?
214                                                                (cddadr c))
215                                                              (pair?
216                                                                (cddr c))
217                                                              (cadadr c)))
218                                                   (bv2 (if fail
219                                                            (cons fail bv)
220                                                            bv))
221                                                   (body (if fail
222                                                             (cddr c)
223                                                             (cdr c))))
224                                              (set! blist
225                                                (cons `(,code
226                                                         (lambda ,bv2
227                                                           ,@body))
228                                                      (append
229                                                        bindings
230                                                        blist)))
231                                              (list p
232                                                    code
233                                                    bv
234                                                    (and fail (gensym))
235                                                    #f)))
236                                          clauses))
237                              (code (gen x
238                                         '()
239                                         plist
240                                         (cdr eb-errf)
241                                         length>=
242                                         (gensym))))
243                         (unreachable plist match-expr)
244                         (inline-let
245                           `(let ((,length>= (lambda (n)
246                                               (lambda (l)
247                                                 (>= (length l) n))))
248                                  ,@blist)
249                              ,code)))))
250           (genletrec (lambda (pat exp body match-expr)
251                        (let* ((length>= (gensym))
252                               (eb-errf (error-maker match-expr))
253                               (x (bound (validate-pattern pat)))
254                               (p (car x))
255                               (bv (cadr x))
256                               (bindings (caddr x))
257                               (code (gensym))
258                               (plist (list (list p code bv #f #f)))
259                               (x (gensym))
260                               (m (gen x
261                                       '()
262                                       plist
263                                       (cdr eb-errf)
264                                       length>=
265                                       (gensym)))
266                               (gs (map (lambda (_) (gensym)) bv)))
267                          (unreachable plist match-expr)
268                          `(letrec ((,length>= (lambda (n)
269                                                 (lambda (l)
270                                                   (>= (length l) n))))
271                                    ,@(map (lambda (v) `(,v #f)) bv)
272                                    (,x ,exp)
273                                    (,code (lambda ,gs
274                                             ,@(map (lambda (v g)
275                                                      `(set! ,v ,g))
276                                                    bv
277                                                    gs)
278                                             ,@body))
279                                    ,@bindings
280                                    ,@(car eb-errf))
281                             ,m))))
282           (gendefine (lambda (pat exp match-expr)
283                        (let* ((length>= (gensym))
284                               (eb-errf (error-maker match-expr))
285                               (x (bound (validate-pattern pat)))
286                               (p (car x))
287                               (bv (cadr x))
288                               (bindings (caddr x))
289                               (code (gensym))
290                               (plist (list (list p code bv #f #f)))
291                               (x (gensym))
292                               (m (gen x
293                                       '()
294                                       plist
295                                       (cdr eb-errf)
296                                       length>=
297                                       (gensym)))
298                               (gs (map (lambda (_) (gensym)) bv)))
299                          (unreachable plist match-expr)
300                          `(begin ,@(map (lambda (v) `(define ,v #f)) bv)
301                                  ,(inline-let
302                                     `(let ((,length>= (lambda (n)
303                                                         (lambda (l)
304                                                           (>= (length l)
305                                                               n))))
306                                            (,x ,exp)
307                                            (,code (lambda ,gs
308                                                     ,@(map (lambda (v g)
309                                                              `(set! ,v
310                                                                 ,g))
311                                                            bv
312                                                            gs)
313                                                     (cond (#f #f))))
314                                            ,@bindings
315                                            ,@(car eb-errf))
316                                        ,m))))))
317           (pattern-var? (lambda (x)
318                           (and (symbol? x)
319                                (not (dot-dot-k? x))
320                                (not (memq x
321                                           '(quasiquote
322                                              quote
323                                              unquote
324                                              unquote-splicing
325                                              ?
326                                              _
327                                              $
328                                              =
329                                              and
330                                              or
331                                              not
332                                              set!
333                                              get!
334                                              ...
335                                              ___))))))
336           (dot-dot-k? (lambda (s)
337                         (and (symbol? s)
338                              (if (memq s '(... ___))
339                                  0
340                                  (let* ((s (symbol->string s))
341                                         (n (string-length s)))
342                                    (and (<= 3 n)
343                                         (memq (string-ref s 0) '(#\. #\_))
344                                         (memq (string-ref s 1) '(#\. #\_))
345                                         (andmap
346                                           char-numeric?
347                                           (string->list
348                                             (substring s 2 n)))
349                                         (string->number
350                                           (substring s 2 n))))))))
351           (error-maker (lambda (match-expr)
352                          (cond
353                            ((eq? ##match#error-control '#:unspecified) (cons '()
354                                                                          (lambda (x)
355                                                                            `(cond
356                                                                               (#f #f)))))
357                            ((memq ##match#error-control '(#:error #:fail)) (cons '()
358                                                                            (lambda (x)
359                                                                              `(##sys#match-error
360                                                                                 ,x))))
361                            ((eq? ##match#error-control '#:match) (let ((errf (gensym))
362                                                                    (arg (gensym)))
363                                                                (cons `((,errf
364                                                                          (lambda (,arg)
365                                                                            (##sys#match-error
366                                                                              ,arg
367                                                                              ',match-expr))))
368                                                                      (lambda (x)
369                                                                        `(,errf
370                                                                           ,x)))))
371                            (else (##match#syntax-err
372                                    '(unspecified error fail match)
373                                    "invalid value for ##match#error-control, legal values are")))))
374           (unreachable (lambda (plist match-expr)
375                          (for-each
376                            (lambda (x)
377                              (if (not (car (cddddr x)))
378                                  (##sys#warn "Warning: unreachable pattern " (car x) 'in match-expr) ) )
379                            plist)))
380           (validate-pattern (lambda (pattern)
381                               (letrec ((simple? (lambda (x)
382                                                   (or (string? x)
383                                                       (boolean? x)
384                                                       (char? x)
385                                                       (number? x)
386                                                       (null? x))))
387                                        (ordinary (lambda (p)
388                                                    (let ((g88 (lambda (x
389                                                                        y)
390                                                                 (cons (ordinary
391                                                                         x)
392                                                                       (ordinary
393                                                                         y)))))
394                                                      (if (simple? p)
395                                                          ((lambda (p) p)
396                                                           p)
397                                                          (if (equal? p '_)
398                                                              ((lambda ()
399                                                                 '_))
400                                                              (if (pattern-var?
401                                                                    p)
402                                                                  ((lambda (p)
403                                                                     p)
404                                                                   p)
405                                                                  (if (pair?
406                                                                        p)
407                                                                      (if (equal?
408                                                                            (car p)
409                                                                            'quasiquote)
410                                                                          (if (and (pair?
411                                                                                     (cdr p))
412                                                                                   (null?
413                                                                                     (cddr p)))
414                                                                              ((lambda (p)
415                                                                                 (quasi
416                                                                                   p))
417                                                                               (cadr p))
418                                                                              (g88 (car p)
419                                                                                   (cdr p)))
420                                                                          (if (equal?
421                                                                                (car p)
422                                                                                'quote)
423                                                                              (if (and (pair?
424                                                                                         (cdr p))
425                                                                                       (null?
426                                                                                         (cddr p)))
427                                                                                  ((lambda (p)
428                                                                                     p)
429                                                                                   p)
430                                                                                  (g88 (car p)
431                                                                                       (cdr p)))
432                                                                              (if (equal?
433                                                                                    (car p)
434                                                                                    '?)
435                                                                                  (if (and (pair?
436                                                                                             (cdr p))
437                                                                                           (list?
438                                                                                             (cddr p)))
439                                                                                      ((lambda (pred
440                                                                                                ps)
441                                                                                         `(? ,pred
442                                                                                             ,@(map ordinary
443                                                                                                    ps)))
444                                                                                       (cadr p)
445                                                                                       (cddr p))
446                                                                                      (g88 (car p)
447                                                                                           (cdr p)))
448                                                                                  (if (equal?
449                                                                                        (car p)
450                                                                                        '=)
451                                                                                      (if (and (pair?
452                                                                                                 (cdr p))
453                                                                                               (pair?
454                                                                                                 (cddr p))
455                                                                                               (null?
456                                                                                                 (cdddr
457                                                                                                   p)))
458                                                                                          ((lambda (sel
459                                                                                                    p)
460                                                                                             `(= ,sel
461                                                                                                 ,(ordinary
462                                                                                                    p)))
463                                                                                           (cadr p)
464                                                                                           (caddr
465                                                                                             p))
466                                                                                          (g88 (car p)
467                                                                                               (cdr p)))
468                                                                                      (if (equal?
469                                                                                            (car p)
470                                                                                            'and)
471                                                                                          (if (and (list?
472                                                                                                     (cdr p))
473                                                                                                   (pair?
474                                                                                                     (cdr p)))
475                                                                                              ((lambda (ps)
476                                                                                                 `(and ,@(map ordinary
477                                                                                                              ps)))
478                                                                                               (cdr p))
479                                                                                              (g88 (car p)
480                                                                                                   (cdr p)))
481                                                                                          (if (equal?
482                                                                                                (car p)
483                                                                                                'or)
484                                                                                              (if (and (list?
485                                                                                                         (cdr p))
486                                                                                                       (pair?
487                                                                                                         (cdr p)))
488                                                                                                  ((lambda (ps)
489                                                                                                     `(or ,@(map ordinary
490                                                                                                                 ps)))
491                                                                                                   (cdr p))
492                                                                                                  (g88 (car p)
493                                                                                                       (cdr p)))
494                                                                                              (if (equal?
495                                                                                                    (car p)
496                                                                                                    'not)
497                                                                                                  (if (and (list?
498                                                                                                             (cdr p))
499                                                                                                           (pair?
500                                                                                                             (cdr p)))
501                                                                                                      ((lambda (ps)
502                                                                                                         `(not ,@(map ordinary
503                                                                                                                      ps)))
504                                                                                                       (cdr p))
505                                                                                                      (g88 (car p)
506                                                                                                           (cdr p)))
507                                                                                                  (if (equal?
508                                                                                                        (car p)
509                                                                                                        '$)
510                                                                                                      (if (and (pair?
511                                                                                                                 (cdr p))
512                                                                                                               (symbol?
513                                                                                                                 (cadr p))
514                                                                                                               (list?
515                                                                                                                 (cddr p)))
516                                                                                                          ((lambda (r
517                                                                                                                    ps)
518                                                                                                             `($ ,r
519                                                                                                                 ,@(map ordinary
520                                                                                                                        ps)))
521                                                                                                           (cadr p)
522                                                                                                           (cddr p))
523                                                                                                          (g88 (car p)
524                                                                                                               (cdr p)))
525                                                                                                      (if (equal?
526                                                                                                            (car p)
527                                                                                                            'set!)
528                                                                                                          (if (and (pair?
529                                                                                                                     (cdr p))
530                                                                                                                   (pattern-var?
531                                                                                                                     (cadr p))
532                                                                                                                   (null?
533                                                                                                                     (cddr p)))
534                                                                                                              ((lambda (p)
535                                                                                                                 p)
536                                                                                                               p)
537                                                                                                              (g88 (car p)
538                                                                                                                   (cdr p)))
539                                                                                                          (if (equal?
540                                                                                                                (car p)
541                                                                                                                'get!)
542                                                                                                              (if (and (pair?
543                                                                                                                         (cdr p))
544                                                                                                                       (pattern-var?
545                                                                                                                         (cadr p))
546                                                                                                                       (null?
547                                                                                                                         (cddr p)))
548                                                                                                                  ((lambda (p)
549                                                                                                                     p)
550                                                                                                                   p)
551                                                                                                                  (g88 (car p)
552                                                                                                                       (cdr p)))
553                                                                                                              (if (equal?
554                                                                                                                    (car p)
555                                                                                                                    'unquote)
556                                                                                                                  (g88 (car p)
557                                                                                                                       (cdr p))
558                                                                                                                  (if (equal?
559                                                                                                                        (car p)
560                                                                                                                        'unquote-splicing)
561                                                                                                                      (g88 (car p)
562                                                                                                                           (cdr p))
563                                                                                                                      (if (and (pair?
564                                                                                                                                 (cdr p))
565                                                                                                                               (dot-dot-k?
566                                                                                                                                 (cadr p))
567                                                                                                                               (null?
568                                                                                                                                 (cddr p)))
569                                                                                                                          ((lambda (p
570                                                                                                                                    ddk)
571                                                                                                                             `(,(ordinary
572                                                                                                                                  p)
573                                                                                                                                ,ddk))
574                                                                                                                           (car p)
575                                                                                                                           (cadr p))
576                                                                                                                          (g88 (car p)
577                                                                                                                               (cdr p)))))))))))))))
578                                                                      (if (vector?
579                                                                            p)
580                                                                          ((lambda (p)
581                                                                             (let* ((pl (vector->list
582                                                                                          p))
583                                                                                    (rpl (reverse
584                                                                                           pl)))
585                                                                               (apply
586                                                                                 vector
587                                                                                 (if (and (not (null?
588                                                                                                 rpl))
589                                                                                          (dot-dot-k?
590                                                                                            (car rpl)))
591                                                                                     (reverse
592                                                                                       (cons (car rpl)
593                                                                                             (map ordinary
594                                                                                                  (cdr rpl))))
595                                                                                     (map ordinary
596                                                                                          pl)))))
597                                                                           p)
598                                                                          ((lambda ()
599                                                                             (##match#syntax-err
600                                                                               pattern
601                                                                               "syntax error in pattern")))))))))))
602                                        (quasi (lambda (p)
603                                                 (let ((g109 (lambda (x y)
604                                                               (cons (quasi
605                                                                       x)
606                                                                     (quasi
607                                                                       y)))))
608                                                   (if (simple? p)
609                                                       ((lambda (p) p) p)
610                                                       (if (symbol? p)
611                                                           ((lambda (p)
612                                                              `',p)
613                                                            p)
614                                                           (if (pair? p)
615                                                               (if (equal?
616                                                                     (car p)
617                                                                     'unquote)
618                                                                   (if (and (pair?
619                                                                              (cdr p))
620                                                                            (null?
621                                                                              (cddr p)))
622                                                                       ((lambda (p)
623                                                                          (ordinary
624                                                                            p))
625                                                                        (cadr p))
626                                                                       (g109 (car p)
627                                                                             (cdr p)))
628                                                                   (if (and (pair?
629                                                                              (car p))
630                                                                            (equal?
631                                                                              (caar p)
632                                                                              'unquote-splicing)
633                                                                            (pair?
634                                                                              (cdar p))
635                                                                            (null?
636                                                                              (cddar
637                                                                                p)))
638                                                                       (if (null?
639                                                                             (cdr p))
640                                                                           ((lambda (p)
641                                                                              (ordinary
642                                                                                p))
643                                                                            (cadar
644                                                                              p))
645                                                                           ((lambda (p
646                                                                                     y)
647                                                                              (append
648                                                                                (ordlist
649                                                                                  p)
650                                                                                (quasi
651                                                                                  y)))
652                                                                            (cadar
653                                                                              p)
654                                                                            (cdr p)))
655                                                                       (if (and (pair?
656                                                                                  (cdr p))
657                                                                                (dot-dot-k?
658                                                                                  (cadr p))
659                                                                                (null?
660                                                                                  (cddr p)))
661                                                                           ((lambda (p
662                                                                                     ddk)
663                                                                              `(,(quasi
664                                                                                   p)
665                                                                                 ,ddk))
666                                                                            (car p)
667                                                                            (cadr p))
668                                                                           (g109 (car p)
669                                                                                 (cdr p)))))
670                                                               (if (vector?
671                                                                     p)
672                                                                   ((lambda (p)
673                                                                      (let* ((pl (vector->list
674                                                                                   p))
675                                                                             (rpl (reverse
676                                                                                    pl)))
677                                                                        (apply
678                                                                          vector
679                                                                          (if (dot-dot-k?
680                                                                                (car rpl))
681                                                                              (reverse
682                                                                                (cons (car rpl)
683                                                                                      (map quasi
684                                                                                           (cdr rpl))))
685                                                                              (map ordinary
686                                                                                   pl)))))
687                                                                    p)
688                                                                   ((lambda ()
689                                                                      (##match#syntax-err
690                                                                        pattern
691                                                                        "syntax error in pattern"))))))))))
692                                        (ordlist (lambda (p)
693                                                   (cond
694                                                     ((null? p) '())
695                                                     ((pair? p) (cons (ordinary
696                                                                        (car p))
697                                                                      (ordlist
698                                                                        (cdr p))))
699                                                     (else (##match#syntax-err
700                                                             pattern
701                                                             "invalid use of unquote-splicing in pattern"))))))
702                                 (ordinary pattern))))
703           (bound (lambda (pattern)
704                    (letrec ((pred-bodies '())
705                             (bound (lambda (p a k)
706                                      (cond
707                                        ((eq? '_ p) (k p a))
708                                        ((symbol? p) (if (memq p a)
709                                                         (##match#syntax-err
710                                                           pattern
711                                                           "duplicate variable in pattern"))
712                                         (k p (cons p a)))
713                                        ((and (pair? p)
714                                              (eq? 'quote (car p))) (k p a))
715                                        ((and (pair? p) (eq? '? (car p))) (cond
716                                                                            ((not (null?
717                                                                                    (cddr p))) (bound
718                                                                                                 `(and (? ,(cadr p))
719                                                                                                       ,@(cddr p))
720                                                                                                 a
721                                                                                                 k))
722                                                                            ((or (not (symbol?
723                                                                                        (cadr p)))
724                                                                                 (memq (cadr p)
725                                                                                       a)) (let ((g (gensym)))
726                                                                                             (set! pred-bodies
727                                                                                               (cons `(,g ,(cadr p))
728                                                                                                     pred-bodies))
729                                                                                             (k `(? ,g)
730                                                                                                a)))
731                                                                            (else (k p
732                                                                                     a))))
733                                        ((and (pair? p) (eq? '= (car p))) (cond
734                                                                            ((or (not (symbol?
735                                                                                        (cadr p)))
736                                                                                 (memq (cadr p)
737                                                                                       a)) (let ((g (gensym)))
738                                                                                             (set! pred-bodies
739                                                                                               (cons `(,g ,(cadr p))
740                                                                                                     pred-bodies))
741                                                                                             (bound
742                                                                                               `(= ,g
743                                                                                                   ,(caddr
744                                                                                                      p))
745                                                                                               a
746                                                                                               k)))
747                                                                            (else (bound
748                                                                                    (caddr
749                                                                                      p)
750                                                                                    a
751                                                                                    (lambda (p2
752                                                                                             a)
753                                                                                      (k `(= ,(cadr p)
754                                                                                             ,p2)
755                                                                                         a))))))
756                                        ((and (pair? p) (eq? 'and (car p))) (bound*
757                                                                              (cdr p)
758                                                                              a
759                                                                              (lambda (p
760                                                                                       a)
761                                                                                (k `(and ,@p)
762                                                                                   a))))
763                                        ((and (pair? p) (eq? 'or (car p))) (bound
764                                                                             (cadr p)
765                                                                             a
766                                                                             (lambda (first-p
767                                                                                      first-a)
768                                                                               (let or* ((plist (cddr p))
769                                                                                         (k (lambda (plist)
770                                                                                              (k `(or ,first-p
771                                                                                                      ,@plist)
772                                                                                                 first-a))))
773                                                                                 (if (null?
774                                                                                       plist)
775                                                                                     (k plist)
776                                                                                     (bound
777                                                                                       (car plist)
778                                                                                       a
779                                                                                       (lambda (car-p
780                                                                                                car-a)
781                                                                                         (if (not (permutation
782                                                                                                    car-a
783                                                                                                    first-a))
784                                                                                             (##match#syntax-err
785                                                                                               pattern
786                                                                                               "variables of or-pattern differ in"))
787                                                                                         (or* (cdr plist)
788                                                                                              (lambda (cdr-p)
789                                                                                                (k (cons car-p
790                                                                                                         cdr-p)))))))))))
791                                        ((and (pair? p) (eq? 'not (car p))) (cond
792                                                                              ((not (null?
793                                                                                      (cddr p))) (bound
794                                                                                                   `(not (or ,@(cdr p)))
795                                                                                                   a
796                                                                                                   k))
797                                                                              (else (bound
798                                                                                      (cadr p)
799                                                                                      a
800                                                                                      (lambda (p2
801                                                                                               a2)
802                                                                                        (if (not (permutation
803                                                                                                   a
804                                                                                                   a2))
805                                                                                            (##match#syntax-err
806                                                                                              p
807                                                                                              "no variables allowed in"))
808                                                                                        (k `(not ,p2)
809                                                                                           a))))))
810                                        ((and (pair? p)
811                                              (pair? (cdr p))
812                                              (dot-dot-k? (cadr p))) (bound
813                                                                       (car p)
814                                                                       a
815                                                                       (lambda (q
816                                                                                b)
817                                                                         (let ((bvars (find-prefix
818                                                                                        b
819                                                                                        a)))
820                                                                           (k `(,q ,(cadr p)
821                                                                                   ,bvars
822                                                                                   ,(gensym)
823                                                                                   ,(gensym)
824                                                                                   ,(map (lambda (_)
825                                                                                           (gensym))
826                                                                                         bvars))
827                                                                              b)))))
828                                        ((and (pair? p) (eq? '$ (car p))) (bound*
829                                                                            (cddr p)
830                                                                            a
831                                                                            (lambda (p1
832                                                                                     a)
833                                                                              (k `($ ,(cadr p)
834                                                                                     ,@p1)
835                                                                                 a))))
836                                        ((and (pair? p)
837                                              (eq? 'set! (car p))) (if (memq (cadr p)
838                                                                             a)
839                                                                       (k p
840                                                                          a)
841                                                                       (k p
842                                                                          (cons (cadr p)
843                                                                                a))))
844                                        ((and (pair? p)
845                                              (eq? 'get! (car p))) (if (memq (cadr p)
846                                                                             a)
847                                                                       (k p
848                                                                          a)
849                                                                       (k p
850                                                                          (cons (cadr p)
851                                                                                a))))
852                                        ((pair? p) (bound
853                                                     (car p)
854                                                     a
855                                                     (lambda (car-p a)
856                                                       (bound
857                                                         (cdr p)
858                                                         a
859                                                         (lambda (cdr-p a)
860                                                           (k (cons car-p
861                                                                    cdr-p)
862                                                              a))))))
863                                        ((vector? p) (boundv
864                                                       (vector->list p)
865                                                       a
866                                                       (lambda (pl a)
867                                                         (k (list->vector
868                                                              pl)
869                                                            a))))
870                                        (else (k p a)))))
871                             (boundv (lambda (plist a k)
872                                       (let ((g115 (lambda () (k plist a))))
873                                         (if (pair? plist)
874                                             (if (and (pair? (cdr plist))
875                                                      (dot-dot-k?
876                                                        (cadr plist))
877                                                      (null? (cddr plist)))
878                                                 ((lambda ()
879                                                    (bound plist a k)))
880                                                 (if (null? plist)
881                                                     (g115)
882                                                     ((lambda (x y)
883                                                        (bound
884                                                          x
885                                                          a
886                                                          (lambda (car-p a)
887                                                            (boundv
888                                                              y
889                                                              a
890                                                              (lambda (cdr-p
891                                                                       a)
892                                                                (k (cons car-p
893                                                                         cdr-p)
894                                                                   a))))))
895                                                      (car plist)
896                                                      (cdr plist))))
897                                             (if (null? plist)
898                                                 (g115)
899                                                 (##sys#match-error plist))))))
900                             (bound* (lambda (plist a k)
901                                       (if (null? plist)
902                                           (k plist a)
903                                           (bound
904                                             (car plist)
905                                             a
906                                             (lambda (car-p a)
907                                               (bound*
908                                                 (cdr plist)
909                                                 a
910                                                 (lambda (cdr-p a)
911                                                   (k (cons car-p cdr-p)
912                                                      a))))))))
913                             (find-prefix (lambda (b a)
914                                            (if (eq? b a)
915                                                '()
916                                                (cons (car b)
917                                                      (find-prefix
918                                                        (cdr b)
919                                                        a)))))
920                             (permutation (lambda (p1 p2)
921                                            (and (= (length p1)
922                                                    (length p2))
923                                                 (andmap
924                                                   (lambda (x1)
925                                                     (memq x1 p2))
926                                                   p1)))))
927                      (bound
928                        pattern
929                        '()
930                        (lambda (p a) (list p (reverse a) pred-bodies))))))
931           (inline-let (lambda (let-exp)
932                         (letrec ((occ (lambda (x e)
933                                         (let loop ((e e))
934                                           (cond
935                                             ((pair? e) (+ (loop (car e))
936                                                           (loop (cdr e))))
937                                             ((eq? x e) 1)
938                                             (else 0)))))
939                                  (subst (lambda (e old new)
940                                           (let loop ((e e))
941                                             (cond
942                                               ((pair? e) (cons (loop (car e))
943                                                                (loop (cdr e))))
944                                               ((eq? old e) new)
945                                               (else e)))))
946                                  (const? (lambda (sexp)
947                                            (or (symbol? sexp)
948                                                (boolean? sexp)
949                                                (string? sexp)
950                                                (char? sexp)
951                                                (number? sexp)
952                                                (null? sexp)
953                                                (and (pair? sexp)
954                                                     (eq? (car sexp)
955                                                          'quote)
956                                                     (pair? (cdr sexp))
957                                                     (symbol? (cadr sexp))
958                                                     (null? (cddr sexp))))))
959                                  (isval? (lambda (sexp)
960                                            (or (const? sexp)
961                                                (and (pair? sexp)
962                                                     (memq (car sexp)
963                                                           '(lambda quote
964                                                              match-lambda
965                                                              match-lambda*))))))
966                                  (small? (lambda (sexp)
967                                            (or (const? sexp)
968                                                (and (pair? sexp)
969                                                     (eq? (car sexp)
970                                                          'lambda)
971                                                     (pair? (cdr sexp))
972                                                     (pair? (cddr sexp))
973                                                     (const? (caddr sexp))
974                                                     (null?
975                                                       (cdddr sexp)))))))
976                           (let loop ((b (cadr let-exp))
977                                      (new-b '())
978                                      (e (caddr let-exp)))
979                             (cond
980                               ((null? b) (if (null? new-b)
981                                              e
982                                              `(let ,(reverse new-b) ,e)))
983                               ((isval? (cadr (car b))) (let* ((x (caar b))
984                                                               (n (occ x e)))
985                                                          (cond
986                                                            ((= 0 n) (loop (cdr b)
987                                                                           new-b
988                                                                           e))
989                                                            ((or (= 1 n)
990                                                                 (small?
991                                                                   (cadr (car b)))) (loop (cdr b)
992                                                                                          new-b
993                                                                                          (subst
994                                                                                            e
995                                                                                            x
996                                                                                            (cadr (car b)))))
997                                                            (else (loop (cdr b)
998                                                                        (cons (car b)
999                                                                              new-b)
1000                                                                        e)))))
1001                               (else (loop (cdr b) (cons (car b) new-b) e)))))))
1002           (gen (lambda (x sf plist erract length>= eta)
1003                  (if (null? plist)
1004                      (erract x)
1005                      (let* ((v '())
1006                             (val (lambda (x) (cdr (assq x v))))
1007                             (fail (lambda (sf)
1008                                     (gen x
1009                                          sf
1010                                          (cdr plist)
1011                                          erract
1012                                          length>=
1013                                          eta)))
1014                             (success (lambda (sf)
1015                                        (set-car! (cddddr (car plist)) #t)
1016                                        (let* ((code (cadr (car plist)))
1017                                               (bv (caddr (car plist)))
1018                                               (fail-sym (cadddr
1019                                                           (car plist))))
1020                                          (if fail-sym
1021                                              (let ((ap `(,code
1022                                                           ,fail-sym
1023                                                           ,@(map val bv))))
1024                                                `(call-with-current-continuation
1025                                                   (lambda (,fail-sym)
1026                                                     (let ((,fail-sym (lambda ()
1027                                                                        (,fail-sym
1028                                                                          ,(fail sf)))))
1029                                                       ,ap))))
1030                                              `(,code ,@(map val bv)))))))
1031                        (let next ((p (caar plist))
1032                                   (e x)
1033                                   (sf sf)
1034                                   (kf fail)
1035                                   (ks success))
1036                          (cond
1037                            ((eq? '_ p) (ks sf))
1038                            ((symbol? p) (set! v (cons (cons p e) v))
1039                             (ks sf))
1040                            ((null? p) (emit `(null? ,e) sf kf ks))
1041                            ((equal? p ''()) (emit `(null? ,e) sf kf ks))
1042                            ((string? p) (emit `(equal? ,e ,p) sf kf ks))
1043                            ((boolean? p) (emit `(equal? ,e ,p) sf kf ks))
1044                            ((char? p) (emit `(equal? ,e ,p) sf kf ks))
1045                            ((number? p) (emit `(equal? ,e ,p) sf kf ks))
1046                            ((and (pair? p) (eq? 'quote (car p))) (emit `(equal?
1047                                                                           ,e
1048                                                                           ,p)
1049                                                                        sf
1050                                                                        kf
1051                                                                        ks))
1052                            ((and (pair? p) (eq? '? (car p))) (let ((tst `(,(cadr p)
1053                                                                            ,e)))
1054                                                                (emit tst
1055                                                                      sf
1056                                                                      kf
1057                                                                      ks)))
1058                            ((and (pair? p) (eq? '= (car p))) (next (caddr
1059                                                                      p)
1060                                                                    `(,(cadr p)
1061                                                                       ,e)
1062                                                                    sf
1063                                                                    kf
1064                                                                    ks))
1065                            ((and (pair? p) (eq? 'and (car p))) (let loop ((p (cdr p))
1066                                                                           (sf sf))
1067                                                                  (if (null?
1068                                                                        p)
1069                                                                      (ks sf)
1070                                                                      (next (car p)
1071                                                                            e
1072                                                                            sf
1073                                                                            kf
1074                                                                            (lambda (sf)
1075                                                                              (loop (cdr p)
1076                                                                                    sf))))))
1077                            ((and (pair? p) (eq? 'or (car p))) (let ((or-v v))
1078                                                                 (let loop ((p (cdr p))
1079                                                                            (sf sf))
1080                                                                   (if (null?
1081                                                                         p)
1082                                                                       (kf sf)
1083                                                                       (begin (set! v
1084                                                                                or-v)
1085                                                                              (next (car p)
1086                                                                                    e
1087                                                                                    sf
1088                                                                                    (lambda (sf)
1089                                                                                      (loop (cdr p)
1090                                                                                            sf))
1091                                                                                    ks))))))
1092                            ((and (pair? p) (eq? 'not (car p))) (next (cadr p)
1093                                                                      e
1094                                                                      sf
1095                                                                      ks
1096                                                                      kf))
1097                            ((and (pair? p) (eq? '$ (car p))) (let* ((tag (cadr p))
1098                                                                     (fields (cdr p))
1099                                                                     (rlen (length
1100                                                                             fields))
1101                                                                     (tst `(,(symbol-append
1102                                                                               tag
1103                                                                               '?)
1104                                                                             ,e)))
1105                                                                (emit tst
1106                                                                      sf
1107                                                                      kf
1108                                                                      (let rloop ((n 1))
1109                                                                        (lambda (sf)
1110                                                                          (if (= n
1111                                                                                 rlen)
1112                                                                              (ks sf)
1113                                                                              (next (list-ref
1114                                                                                      fields
1115                                                                                      n)
1116                                                                                    `(,(symbol-append
1117                                                                                         tag
1118                                                                                         '-
1119                                                                                         n)
1120                                                                                       ,e)
1121                                                                                    sf
1122                                                                                    kf
1123                                                                                    (rloop
1124                                                                                      (+ 1
1125                                                                                         n)))))))))
1126                            ((and (pair? p) (eq? 'set! (car p))) (set! v
1127                                                                   (cons (cons (cadr p)
1128                                                                               (setter
1129                                                                                 e
1130                                                                                 p))
1131                                                                         v))
1132                             (ks sf))
1133                            ((and (pair? p) (eq? 'get! (car p))) (set! v
1134                                                                   (cons (cons (cadr p)
1135                                                                               (getter
1136                                                                                 e
1137                                                                                 p))
1138                                                                         v))
1139                             (ks sf))
1140                            ((and (pair? p)
1141                                  (pair? (cdr p))
1142                                  (dot-dot-k? (cadr p))) (emit `(list? ,e)
1143                                                               sf
1144                                                               kf
1145                                                               (lambda (sf)
1146                                                                 (let* ((k (dot-dot-k?
1147                                                                             (cadr p)))
1148                                                                        (ks (lambda (sf)
1149                                                                              (let ((bound (list-ref
1150                                                                                             p
1151                                                                                             2)))
1152                                                                                (cond
1153                                                                                  ((eq? (car p)
1154                                                                                        '_) (ks sf))
1155                                                                                  ((null?
1156                                                                                     bound) (let* ((ptst (next (car p)
1157                                                                                                               eta
1158                                                                                                               sf
1159                                                                                                               (lambda (sf)
1160                                                                                                                 #f)
1161                                                                                                               (lambda (sf)
1162                                                                                                                 #t)))
1163                                                                                                   (tst (if (and (pair?
1164                                                                                                                   ptst)
1165                                                                                                                 (symbol?
1166                                                                                                                   (car ptst))
1167                                                                                                                 (pair?
1168                                                                                                                   (cdr ptst))
1169                                                                                                                 (eq? eta
1170                                                                                                                      (cadr ptst))
1171                                                                                                                 (null?
1172                                                                                                                   (cddr ptst)))
1173                                                                                                            (car ptst)
1174                                                                                                            `(lambda (,eta)
1175                                                                                                               ,ptst))))
1176                                                                                              (assm `(andmap
1177                                                                                                       ,tst
1178                                                                                                       ,e)
1179                                                                                                    (kf sf)
1180                                                                                                    (ks sf))))
1181                                                                                  ((and (symbol?
1182                                                                                          (car p))
1183                                                                                        (equal?
1184                                                                                          (list (car p))
1185                                                                                          bound)) (next (car p)
1186                                                                                                        e
1187                                                                                                        sf
1188                                                                                                        kf
1189                                                                                                        ks))
1190                                                                                  (else (let* ((gloop (list-ref
1191                                                                                                        p
1192                                                                                                        3))
1193                                                                                               (ge (list-ref
1194                                                                                                     p
1195                                                                                                     4))
1196                                                                                               (fresh (list-ref
1197                                                                                                        p
1198                                                                                                        5))
1199                                                                                               (p1 (next (car p)
1200                                                                                                         `(car ,ge)
1201                                                                                                         sf
1202                                                                                                         kf
1203                                                                                                         (lambda (sf)
1204                                                                                                           `(,gloop
1205                                                                                                              (cdr ,ge)
1206                                                                                                              ,@(map (lambda (b
1207                                                                                                                              f)
1208                                                                                                                       `(cons ,(val b)
1209                                                                                                                              ,f))
1210                                                                                                                     bound
1211                                                                                                                     fresh))))))
1212                                                                                          (set! v
1213                                                                                            (append
1214                                                                                              (map cons
1215                                                                                                   bound
1216                                                                                                   (map (lambda (x)
1217                                                                                                          `(reverse
1218                                                                                                             ,x))
1219                                                                                                        fresh))
1220                                                                                              v))
1221                                                                                          `(let ,gloop
1222                                                                                             ((,ge ,e)
1223                                                                                              ,@(map (lambda (x)
1224                                                                                                       `(,x '()))
1225                                                                                                     fresh))
1226                                                                                             (if (null?
1227                                                                                                   ,ge)
1228                                                                                                 ,(ks sf)
1229                                                                                                 ,p1)))))))))
1230                                                                   (case k
1231                                                                     ((0) (ks sf))
1232                                                                     ((1) (emit `(pair?
1233                                                                                   ,e)
1234                                                                                sf
1235                                                                                kf
1236                                                                                ks))
1237                                                                     (else (emit `((,length>=
1238                                                                                     ,k)
1239                                                                                   ,e)
1240                                                                                 sf
1241                                                                                 kf
1242                                                                                 ks)))))))
1243                            ((pair? p) (emit `(pair? ,e)
1244                                             sf
1245                                             kf
1246                                             (lambda (sf)
1247                                               (next (car p)
1248                                                     (add-a e)
1249                                                     sf
1250                                                     kf
1251                                                     (lambda (sf)
1252                                                       (next (cdr p)
1253                                                             (add-d e)
1254                                                             sf
1255                                                             kf
1256                                                             ks))))))
1257                            ((and (vector? p)
1258                                  (>= (vector-length p) 6)
1259                                  (dot-dot-k?
1260                                    (vector-ref
1261                                      p
1262                                      (- (vector-length p) 5)))) (let* ((vlen (- (vector-length
1263                                                                                   p)
1264                                                                                 6))
1265                                                                        (k (dot-dot-k?
1266                                                                             (vector-ref
1267                                                                               p
1268                                                                               (+ vlen
1269                                                                                  1))))
1270                                                                        (minlen (+ vlen
1271                                                                                   k))
1272                                                                        (bound (vector-ref
1273                                                                                 p
1274                                                                                 (+ vlen
1275                                                                                    2))))
1276                                                                   (emit `(vector?
1277                                                                            ,e)
1278                                                                         sf
1279                                                                         kf
1280                                                                         (lambda (sf)
1281                                                                           (assm `(>= (vector-length
1282                                                                                        ,e)
1283                                                                                      ,minlen)
1284                                                                                 (kf sf)
1285                                                                                 ((let vloop ((n 0))
1286                                                                                    (lambda (sf)
1287                                                                                      (cond
1288                                                                                        ((not (= n
1289                                                                                                 vlen)) (next (vector-ref
1290                                                                                                                p
1291                                                                                                                n)
1292                                                                                                              `(vector-ref
1293                                                                                                                 ,e
1294                                                                                                                 ,n)
1295                                                                                                              sf
1296                                                                                                              kf
1297                                                                                                              (vloop
1298                                                                                                                (+ 1
1299                                                                                                                   n))))
1300                                                                                        ((eq? (vector-ref
1301                                                                                                p
1302                                                                                                vlen)
1303                                                                                              '_) (ks sf))
1304                                                                                        (else (let* ((gloop (vector-ref
1305                                                                                                              p
1306                                                                                                              (+ vlen
1307                                                                                                                 3)))
1308                                                                                                     (ind (vector-ref
1309                                                                                                            p
1310                                                                                                            (+ vlen
1311                                                                                                               4)))
1312                                                                                                     (fresh (vector-ref
1313                                                                                                              p
1314                                                                                                              (+ vlen
1315                                                                                                                 5)))
1316                                                                                                     (p1 (next (vector-ref
1317                                                                                                                 p
1318                                                                                                                 vlen)
1319                                                                                                               `(vector-ref
1320                                                                                                                  ,e
1321                                                                                                                  ,ind)
1322                                                                                                               sf
1323                                                                                                               kf
1324                                                                                                               (lambda (sf)
1325                                                                                                                 `(,gloop
1326                                                                                                                    (- ,ind
1327                                                                                                                       1)
1328                                                                                                                    ,@(map (lambda (b
1329                                                                                                                                    f)
1330                                                                                                                             `(cons ,(val b)
1331                                                                                                                                    ,f))
1332                                                                                                                           bound
1333                                                                                                                           fresh))))))
1334                                                                                                (set! v
1335                                                                                                  (append
1336                                                                                                    (map cons
1337                                                                                                         bound
1338                                                                                                         fresh)
1339                                                                                                    v))
1340                                                                                                `(let ,gloop
1341                                                                                                   ((,ind (- (vector-length
1342                                                                                                               ,e)
1343                                                                                                             1))
1344                                                                                                    ,@(map (lambda (x)
1345                                                                                                             `(,x '()))
1346                                                                                                           fresh))
1347                                                                                                   (if (> ,minlen
1348                                                                                                          ,ind)
1349                                                                                                       ,(ks sf)
1350                                                                                                       ,p1)))))))
1351                                                                                  sf))))))
1352                            ((vector? p) (let ((vlen (vector-length p)))
1353                                           (emit `(vector? ,e)
1354                                                 sf
1355                                                 kf
1356                                                 (lambda (sf)
1357                                                   (emit `(equal?
1358                                                            (vector-length
1359                                                              ,e)
1360                                                            ,vlen)
1361                                                         sf
1362                                                         kf
1363                                                         (let vloop ((n 0))
1364                                                           (lambda (sf)
1365                                                             (if (= n vlen)
1366                                                                 (ks sf)
1367                                                                 (next (vector-ref
1368                                                                         p
1369                                                                         n)
1370                                                                       `(vector-ref
1371                                                                          ,e
1372                                                                          ,n)
1373                                                                       sf
1374                                                                       kf
1375                                                                       (vloop
1376                                                                         (+ 1
1377                                                                            n)))))))))))
1378                            (else (display
1379                                    "FATAL ERROR IN PATTERN MATCHER")
1380                             (newline)
1381                             (##sys#error #f "THIS NEVER HAPPENS"))))))))
1382           (emit (lambda (tst sf kf ks)
1383                   (cond
1384                     ((in tst sf) (ks sf))
1385                     ((in `(not ,tst) sf) (kf sf))
1386                     (else (let* ((e (cadr tst))
1387                                  (implied (cond
1388                                             ((eq? (car tst) 'equal?) (let ((p (caddr
1389                                                                                 tst)))
1390                                                                        (cond
1391                                                                          ((string?
1392                                                                             p) `((string?
1393                                                                                    ,e)))
1394                                                                          ((boolean?
1395                                                                             p) `((boolean?
1396                                                                                    ,e)))
1397                                                                          ((char?
1398                                                                             p) `((char?
1399                                                                                    ,e)))
1400                                                                          ((number?
1401                                                                             p) `((number?
1402                                                                                    ,e)))
1403                                                                          ((and (pair?
1404                                                                                  p)
1405                                                                                (eq? 'quote
1406                                                                                     (car p))) `((symbol?
1407                                                                                                   ,e)))
1408                                                                          (else '()))))
1409                                             ((eq? (car tst) 'null?) `((list?
1410                                                                         ,e)))
1411                                             ((vec-structure? tst) `((vector?
1412                                                                       ,e)))
1413                                             (else '())))
1414                                  (not-imp (case (car tst)
1415                                             ((list?) `((not (null? ,e))))
1416                                             (else '())))
1417                                  (s (ks (cons tst (append implied sf))))
1418                                  (k (kf (cons `(not ,tst)
1419                                               (append not-imp sf)))))
1420                             (assm tst k s))))))
1421           (assm (lambda (tst f s)
1422                   (cond
1423                     ((equal? s f) s)
1424                     ((and (eq? s #t) (eq? f #f)) tst)
1425                     ((and (eq? (car tst) 'pair?)
1426                           (memq ##match#error-control '(#:unspecified #:fail))
1427                           (memq (car f) '(cond ##sys#match-error))
1428                           (guarantees s (cadr tst))) s)
1429                     ((and (pair? s)
1430                           (eq? (car s) 'if)
1431                           (equal? (cadddr s) f)) (if (eq? (car (cadr s))
1432                                                           'and)
1433                                                      `(if (and ,tst
1434                                                                ,@(cdr (cadr s)))
1435                                                           ,(caddr s)
1436                                                           ,f)
1437                                                      `(if (and ,tst
1438                                                                ,(cadr s))
1439                                                           ,(caddr s)
1440                                                           ,f)))
1441                     ((and (pair? s)
1442                           (equal? (car s) 'call-with-current-continuation)
1443                           (pair? (cdr s))
1444                           (pair? (cadr s))
1445                           (equal? (caadr s) 'lambda)
1446                           (pair? (cdadr s))
1447                           (pair? (cadadr s))
1448                           (null? (cdr (cadadr s)))
1449                           (pair? (cddadr s))
1450                           (pair? (car (cddadr s)))
1451                           (equal? (caar (cddadr s)) 'let)
1452                           (pair? (cdar (cddadr s)))
1453                           (pair? (cadar (cddadr s)))
1454                           (pair? (caadar (cddadr s)))
1455                           (pair? (cdr (caadar (cddadr s))))
1456                           (pair? (cadr (caadar (cddadr s))))
1457                           (equal? (caadr (caadar (cddadr s))) 'lambda)
1458                           (pair? (cdadr (caadar (cddadr s))))
1459                           (null? (cadadr (caadar (cddadr s))))
1460                           (pair? (cddadr (caadar (cddadr s))))
1461                           (pair? (car (cddadr (caadar (cddadr s)))))
1462                           (pair? (cdar (cddadr (caadar (cddadr s)))))
1463                           (null? (cddar (cddadr (caadar (cddadr s)))))
1464                           (null? (cdr (cddadr (caadar (cddadr s)))))
1465                           (null? (cddr (caadar (cddadr s))))
1466                           (null? (cdadar (cddadr s)))
1467                           (pair? (cddar (cddadr s)))
1468                           (null? (cdddar (cddadr s)))
1469                           (null? (cdr (cddadr s)))
1470                           (null? (cddr s))
1471                           (equal? f (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr
1472                                                                                            s)))
1473                                                                                  (fail (car (caadar
1474                                                                                               (cddadr
1475                                                                                                 s))))
1476                                                                                  (s2 (caddar
1477                                                                                        (cddadr
1478                                                                                          s))))
1479                                                                              `(call-with-current-continuation
1480                                                                                 (lambda (,k)
1481                                                                                   (let ((,fail (lambda ()
1482                                                                                                  (,k ,f))))
1483                                                                                     ,(assm tst
1484                                                                                            `(,fail)
1485                                                                                            s2))))))
1486                     ((and #f
1487                           (pair? s)
1488                           (equal? (car s) 'let)
1489                           (pair? (cdr s))
1490                           (pair? (cadr s))
1491                           (pair? (caadr s))
1492                           (pair? (cdaadr s))
1493                           (pair? (car (cdaadr s)))
1494                           (equal? (caar (cdaadr s)) 'lambda)
1495                           (pair? (cdar (cdaadr s)))
1496                           (null? (cadar (cdaadr s)))
1497                           (pair? (cddar (cdaadr s)))
1498                           (null? (cdddar (cdaadr s)))
1499                           (null? (cdr (cdaadr s)))
1500                           (null? (cdadr s))
1501                           (pair? (cddr s))
1502                           (null? (cdddr s))
1503                           (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr
1504                                                                         s))
1505                                                                 (s2 (caddr
1506                                                                       s)))
1507                                                             `(let ((,fail (lambda ()
1508                                                                             ,f)))
1509                                                                ,(assm tst
1510                                                                       `(,fail)
1511                                                                       s2))))
1512                     (else `(if ,tst ,s ,f)))))
1513           (guarantees (lambda (code x)
1514                         (let ((a (add-a x)) (d (add-d x)))
1515                           (let loop ((code code))
1516                             (cond
1517                               ((not (pair? code)) #f)
1518                               ((memq (car code) '(cond ##sys#match-error)) #t)
1519                               ((or (equal? code a) (equal? code d)) #t)
1520                               ((eq? (car code) 'if) (or (loop (cadr code))
1521                                                         (and (loop (caddr
1522                                                                      code))
1523                                                              (loop (cadddr
1524                                                                      code)))))
1525                               ((eq? (car code) 'lambda) #f)
1526                               ((and (eq? (car code) 'let)
1527                                     (symbol? (cadr code))) #f)
1528                               (else (or (loop (car code))
1529                                         (loop (cdr code)))))))))
1530           (in (lambda (e l)
1531                 (or (member e l)
1532                     (and (eq? (car e) 'list?)
1533                          (or (member `(null? ,(cadr e)) l)
1534                              (member `(pair? ,(cadr e)) l)))
1535                     (and (eq? (car e) 'not)
1536                          (let* ((srch (cadr e))
1537                                 (const-class (equal-test? srch)))
1538                            (cond
1539                              (const-class (let mem ((l l))
1540                                             (if (null? l)
1541                                                 #f
1542                                                 (let ((x (car l)))
1543                                                   (or (and (equal?
1544                                                              (cadr x)
1545                                                              (cadr srch))
1546                                                            (disjoint? x)
1547                                                            (not (equal?
1548                                                                   const-class
1549                                                                   (car x))))
1550                                                       (equal?
1551                                                         x
1552                                                         `(not (,const-class
1553                                                                 ,(cadr srch))))
1554                                                       (and (equal?
1555                                                              (cadr x)
1556                                                              (cadr srch))
1557                                                            (equal-test? x)
1558                                                            (not (equal?
1559                                                                   (caddr
1560                                                                     srch)
1561                                                                   (caddr
1562                                                                     x))))
1563                                                       (mem (cdr l)))))))
1564                              ((disjoint? srch) (let mem ((l l))
1565                                                  (if (null? l)
1566                                                      #f
1567                                                      (let ((x (car l)))
1568                                                        (or (and (equal?
1569                                                                   (cadr x)
1570                                                                   (cadr srch))
1571                                                                 (disjoint?
1572                                                                   x)
1573                                                                 (not (equal?
1574                                                                        (car x)
1575                                                                        (car srch))))
1576                                                            (mem (cdr l)))))))
1577                              ((eq? (car srch) 'list?) (let mem ((l l))
1578                                                         (if (null? l)
1579                                                             #f
1580                                                             (let ((x (car l)))
1581                                                               (or (and (equal?
1582                                                                          (cadr x)
1583                                                                          (cadr srch))
1584                                                                        (disjoint?
1585                                                                          x)
1586                                                                        (not (memq (car x)
1587                                                                                   '(list?
1588                                                                                      pair?
1589                                                                                      null?))))
1590                                                                   (mem (cdr l)))))))
1591                              ((vec-structure? srch) (let mem ((l l))
1592                                                       (if (null? l)
1593                                                           #f
1594                                                           (let ((x (car l)))
1595                                                             (or (and (equal?
1596                                                                        (cadr x)
1597                                                                        (cadr srch))
1598                                                                      (or (disjoint?
1599                                                                            x)
1600                                                                          (vec-structure?
1601                                                                            x))
1602                                                                      (not (equal?
1603                                                                             (car x)
1604                                                                             'vector?))
1605                                                                      (not (equal?
1606                                                                             (car x)
1607                                                                             (car srch))))
1608                                                                 (equal?
1609                                                                   x
1610                                                                   `(not (vector?
1611                                                                           ,(cadr srch))))
1612                                                                 (mem (cdr l)))))))
1613                              (else #f)))))))
1614           (equal-test? (lambda (tst)
1615                          (and (eq? (car tst) 'equal?)
1616                               (let ((p (caddr tst)))
1617                                 (cond
1618                                   ((string? p) 'string?)
1619                                   ((boolean? p) 'boolean?)
1620                                   ((char? p) 'char?)
1621                                   ((number? p) 'number?)
1622                                   ((and (pair? p)
1623                                         (pair? (cdr p))
1624                                         (null? (cddr p))
1625                                         (eq? 'quote (car p))
1626                                         (symbol? (cadr p))) 'symbol?)
1627                                   (else #f))))))
1628           (disjoint? (lambda (tst)
1629                        (memq (car tst) ##match#disjoint-predicates)))
1630           (vec-structure? (lambda (tst)
1631                             (memq (car tst) ##match#vector-structures)))
1632           (add-a (lambda (a)
1633                    (let ((new (and (pair? a) (assq (car a) c---rs))))
1634                      (if new (cons (cadr new) (cdr a)) `(car ,a)))))
1635           (add-d (lambda (a)
1636                    (let ((new (and (pair? a) (assq (car a) c---rs))))
1637                      (if new (cons (cddr new) (cdr a)) `(cdr ,a)))))
1638           (c---rs '((car caar . cdar)
1639                     (cdr cadr . cddr)
1640                     (caar caaar . cdaar)
1641                     (cadr caadr . cdadr)
1642                     (cdar cadar . cddar)
1643                     (cddr caddr . cdddr)
1644                     (caaar caaaar . cdaaar)
1645                     (caadr caaadr . cdaadr)
1646                     (cadar caadar . cdadar)
1647                     (caddr caaddr . cdaddr)
1648                     (cdaar cadaar . cddaar)
1649                     (cdadr cadadr . cddadr)
1650                     (cddar caddar . cdddar)
1651                     (cdddr cadddr . cddddr)))
1652           (setter (lambda (e p)
1653                     (let ((mk-setter (lambda (s)
1654                                        (symbol-append 'set- s '!))))
1655                       (cond
1656                         ((not (pair? e)) (##match#syntax-err
1657                                            p
1658                                            "unnested set! pattern"))
1659                         ((eq? (car e) 'vector-ref) `(let ((x ,(cadr e)))
1660                                                       (lambda (y)
1661                                                         (vector-set!
1662                                                           x
1663                                                           ,(caddr e)
1664                                                           y))))
1665                         ((eq? (car e) 'unbox) `(let ((x ,(cadr e)))
1666                                                  (lambda (y)
1667                                                    (set-box! x y))))
1668                         ((eq? (car e) 'car) `(let ((x ,(cadr e)))
1669                                                (lambda (y)
1670                                                  (set-car! x y))))
1671                         ((eq? (car e) 'cdr) `(let ((x ,(cadr e)))
1672                                                (lambda (y)
1673                                                  (set-cdr! x y))))
1674                         ((let ((a (assq (car e) get-c---rs)))
1675                            (and a
1676                                 `(let ((x (,(cadr a) ,(cadr e))))
1677                                    (lambda (y)
1678                                      (,(mk-setter (cddr a)) x y))))))
1679                         (else `(let ((x ,(cadr e)))
1680                                  (lambda (y) (,(mk-setter (car e)) x y))))))))
1681           (getter (lambda (e p)
1682                     (cond
1683                       ((not (pair? e)) (##match#syntax-err
1684                                          p
1685                                          "unnested get! pattern"))
1686                       ((eq? (car e) 'vector-ref) `(let ((x ,(cadr e)))
1687                                                     (lambda ()
1688                                                       (vector-ref
1689                                                         x
1690                                                         ,(caddr e)))))
1691                       ((eq? (car e) 'unbox) `(let ((x ,(cadr e)))
1692                                                (lambda () (unbox x))))
1693                       ((eq? (car e) 'car) `(let ((x ,(cadr e)))
1694                                              (lambda () (car x))))
1695                       ((eq? (car e) 'cdr) `(let ((x ,(cadr e)))
1696                                              (lambda () (cdr x))))
1697                       ((let ((a (assq (car e) get-c---rs)))
1698                          (and a
1699                               `(let ((x (,(cadr a) ,(cadr e))))
1700                                  (lambda () (,(cddr a) x))))))
1701                       (else `(let ((x ,(cadr e)))
1702                                (lambda () (,(car e) x)))))))
1703           (get-c---rs '((caar car . car)
1704                         (cadr cdr . car)
1705                         (cdar car . cdr)
1706                         (cddr cdr . cdr)
1707                         (caaar caar . car)
1708                         (caadr cadr . car)
1709                         (cadar cdar . car)
1710                         (caddr cddr . car)
1711                         (cdaar caar . cdr)
1712                         (cdadr cadr . cdr)
1713                         (cddar cdar . cdr)
1714                         (cdddr cddr . cdr)
1715                         (caaaar caaar . car)
1716                         (caaadr caadr . car)
1717                         (caadar cadar . car)
1718                         (caaddr caddr . car)
1719                         (cadaar cdaar . car)
1720                         (cadadr cdadr . car)
1721                         (caddar cddar . car)
1722                         (cadddr cdddr . car)
1723                         (cdaaar caaar . cdr)
1724                         (cdaadr caadr . cdr)
1725                         (cdadar cadar . cdr)
1726                         (cdaddr caddr . cdr)
1727                         (cddaar cdaar . cdr)
1728                         (cddadr cdadr . cdr)
1729                         (cdddar cddar . cdr)
1730                         (cddddr cdddr . cdr)))
1731           (symbol-append (lambda l
1732                            (string->symbol
1733                              (apply
1734                                string-append
1735                                (map (lambda (x)
1736                                       (cond
1737                                         ((symbol? x) (symbol->string x))
1738                                         ((number? x) (number->string x))
1739                                         (else x)))
1740                                     l)))))
1741           (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l)))))
1742           (rdc (lambda (l)
1743                  (if (null? (cdr l)) '() (cons (car l) (rdc (cdr l)))))))
1744    (list genmatch genletrec gendefine pattern-var?)))
1745(define-macro
1746  (match . args)
1747  (cond
1748    ((and (list? args)
1749          (<= 1 (length args))
1750          (andmap
1751            (lambda (y) (and (list? y) (<= 2 (length y))))
1752            (cdr args))) (let* ((exp (car args))
1753                                (clauses (cdr args))
1754                                (e (if (symbol? exp) exp (gensym))))
1755                           (if (symbol? exp)
1756                               ((car ##match#expanders)
1757                                e
1758                                clauses
1759                                `(match ,@args))
1760                               `(let ((,e ,exp))
1761                                  ,((car ##match#expanders)
1762                                    e
1763                                    clauses
1764                                    `(match ,@args))))))
1765    (else (##match#syntax-err `(match ,@args) "syntax error in"))))
1766(define-macro
1767  (match-lambda . args)
1768  (if (and (list? args)
1769           (andmap
1770             (lambda (g126)
1771               (if (and (pair? g126) (list? (cdr g126)))
1772                   (pair? (cdr g126))
1773                   #f))
1774             args))
1775      ((lambda ()
1776         (let ((e (gensym))) `(lambda (,e) (match ,e ,@args)))))
1777      ((lambda ()
1778         (##match#syntax-err
1779           `(match-lambda ,@args)
1780           "syntax error in")))))
1781(define-macro
1782  (match-lambda* . args)
1783  (if (and (list? args)
1784           (andmap
1785             (lambda (g134)
1786               (if (and (pair? g134) (list? (cdr g134)))
1787                   (pair? (cdr g134))
1788                   #f))
1789             args))
1790      ((lambda ()
1791         (let ((e (gensym))) `(lambda ,e (match ,e ,@args)))))
1792      ((lambda ()
1793         (##match#syntax-err
1794           `(match-lambda* ,@args)
1795           "syntax error in")))))
1796(define-macro
1797  (match-let . args)
1798  (let ((g158 (lambda (pat exp body)
1799                `(match ,exp (,pat ,@body))))
1800        (g154 (lambda (pat exp body)
1801                (let ((g (map (lambda (x) (gensym)) pat))
1802                      (vpattern (list->vector pat)))
1803                  `(let ,(map list g exp)
1804                     (match (vector ,@g) (,vpattern ,@body))))))
1805        (g146 (lambda ()
1806                (##match#syntax-err `(match-let ,@args) "syntax error in")))
1807        (g145 (lambda (p1 e1 p2 e2 body)
1808                (let ((g1 (gensym)) (g2 (gensym)))
1809                  `(let ((,g1 ,e1) (,g2 ,e2))
1810                     (match (cons ,g1 ,g2) ((,p1 . ,p2) ,@body))))))
1811        (g136 (cadddr ##match#expanders)))
1812    (if (pair? args)
1813        (if (symbol? (car args))
1814            (if (and (pair? (cdr args)) (list? (cadr args)))
1815                (let g161 ((g162 (cadr args)) (g160 '()) (g159 '()))
1816                  (if (null? g162)
1817                      (if (and (list? (cddr args)) (pair? (cddr args)))
1818                          ((lambda (name pat exp body)
1819                             (if (andmap
1820                                   (cadddr ##match#expanders)
1821                                   pat)
1822                                 `(let ,@args)
1823                                 `(letrec ((,name (match-lambda*
1824                                                    (,pat ,@body))))
1825                                    (,name ,@exp))))
1826                           (car args)
1827                           (reverse g159)
1828                           (reverse g160)
1829                           (cddr args))
1830                          (g146))
1831                      (if (and (pair? (car g162))
1832                               (pair? (cdar g162))
1833                               (null? (cddar g162)))
1834                          (g161 (cdr g162)
1835                                (cons (cadar g162) g160)
1836                                (cons (caar g162) g159))
1837                          (g146))))
1838                (g146))
1839            (if (list? (car args))
1840                (if (andmap
1841                      (lambda (g167)
1842                        (if (and (pair? g167)
1843                                 (g136 (car g167))
1844                                 (pair? (cdr g167)))
1845                            (null? (cddr g167))
1846                            #f))
1847                      (car args))
1848                    (if (and (list? (cdr args)) (pair? (cdr args)))
1849                        ((lambda () `(let ,@args)))
1850                        (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
1851                          (if (null? g150)
1852                              (g146)
1853                              (if (and (pair? (car g150))
1854                                       (pair? (cdar g150))
1855                                       (null? (cddar g150)))
1856                                  (g149 (cdr g150)
1857                                        (cons (cadar g150) g148)
1858                                        (cons (caar g150) g147))
1859                                  (g146)))))
1860                    (if (and (pair? (car args))
1861                             (pair? (caar args))
1862                             (pair? (cdaar args))
1863                             (null? (cddaar args)))
1864                        (if (null? (cdar args))
1865                            (if (and (list? (cdr args)) (pair? (cdr args)))
1866                                (g158 (caaar args)
1867                                      (cadaar args)
1868                                      (cdr args))
1869                                (let g149 ((g150 (car args))
1870                                           (g148 '())
1871                                           (g147 '()))
1872                                  (if (null? g150)
1873                                      (g146)
1874                                      (if (and (pair? (car g150))
1875                                               (pair? (cdar g150))
1876                                               (null? (cddar g150)))
1877                                          (g149 (cdr g150)
1878                                                (cons (cadar g150) g148)
1879                                                (cons (caar g150) g147))
1880                                          (g146)))))
1881                            (if (and (pair? (cdar args))
1882                                     (pair? (cadar args))
1883                                     (pair? (cdadar args))
1884                                     (null? (cdr (cdadar args)))
1885                                     (null? (cddar args)))
1886                                (if (and (list? (cdr args))
1887                                         (pair? (cdr args)))
1888                                    (g145 (caaar args)
1889                                          (cadaar args)
1890                                          (caadar args)
1891                                          (car (cdadar args))
1892                                          (cdr args))
1893                                    (let g149 ((g150 (car args))
1894                                               (g148 '())
1895                                               (g147 '()))
1896                                      (if (null? g150)
1897                                          (g146)
1898                                          (if (and (pair? (car g150))
1899                                                   (pair? (cdar g150))
1900                                                   (null? (cddar g150)))
1901                                              (g149 (cdr g150)
1902                                                    (cons (cadar g150)
1903                                                          g148)
1904                                                    (cons (caar g150)
1905                                                          g147))
1906                                              (g146)))))
1907                                (let g149 ((g150 (car args))
1908                                           (g148 '())
1909                                           (g147 '()))
1910                                  (if (null? g150)
1911                                      (if (and (list? (cdr args))
1912                                               (pair? (cdr args)))
1913                                          (g154 (reverse g147)
1914                                                (reverse g148)
1915                                                (cdr args))
1916                                          (g146))
1917                                      (if (and (pair? (car g150))
1918                                               (pair? (cdar g150))
1919                                               (null? (cddar g150)))
1920                                          (g149 (cdr g150)
1921                                                (cons (cadar g150) g148)
1922                                                (cons (caar g150) g147))
1923                                          (g146))))))
1924                        (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
1925                          (if (null? g150)
1926                              (if (and (list? (cdr args))
1927                                       (pair? (cdr args)))
1928                                  (g154 (reverse g147)
1929                                        (reverse g148)
1930                                        (cdr args))
1931                                  (g146))
1932                              (if (and (pair? (car g150))
1933                                       (pair? (cdar g150))
1934                                       (null? (cddar g150)))
1935                                  (g149 (cdr g150)
1936                                        (cons (cadar g150) g148)
1937                                        (cons (caar g150) g147))
1938                                  (g146))))))
1939                (if (pair? (car args))
1940                    (if (and (pair? (caar args))
1941                             (pair? (cdaar args))
1942                             (null? (cddaar args)))
1943                        (if (null? (cdar args))
1944                            (if (and (list? (cdr args)) (pair? (cdr args)))
1945                                (g158 (caaar args)
1946                                      (cadaar args)
1947                                      (cdr args))
1948                                (let g149 ((g150 (car args))
1949                                           (g148 '())
1950                                           (g147 '()))
1951                                  (if (null? g150)
1952                                      (g146)
1953                                      (if (and (pair? (car g150))
1954                                               (pair? (cdar g150))
1955                                               (null? (cddar g150)))
1956                                          (g149 (cdr g150)
1957                                                (cons (cadar g150) g148)
1958                                                (cons (caar g150) g147))
1959                                          (g146)))))
1960                            (if (and (pair? (cdar args))
1961                                     (pair? (cadar args))
1962                                     (pair? (cdadar args))
1963                                     (null? (cdr (cdadar args)))
1964                                     (null? (cddar args)))
1965                                (if (and (list? (cdr args))
1966                                         (pair? (cdr args)))
1967                                    (g145 (caaar args)
1968                                          (cadaar args)
1969                                          (caadar args)
1970                                          (car (cdadar args))
1971                                          (cdr args))
1972                                    (let g149 ((g150 (car args))
1973                                               (g148 '())
1974                                               (g147 '()))
1975                                      (if (null? g150)
1976                                          (g146)
1977                                          (if (and (pair? (car g150))
1978                                                   (pair? (cdar g150))
1979                                                   (null? (cddar g150)))
1980                                              (g149 (cdr g150)
1981                                                    (cons (cadar g150)
1982                                                          g148)
1983                                                    (cons (caar g150)
1984                                                          g147))
1985                                              (g146)))))
1986                                (let g149 ((g150 (car args))
1987                                           (g148 '())
1988                                           (g147 '()))
1989                                  (if (null? g150)
1990                                      (if (and (list? (cdr args))
1991                                               (pair? (cdr args)))
1992                                          (g154 (reverse g147)
1993                                                (reverse g148)
1994                                                (cdr args))
1995                                          (g146))
1996                                      (if (and (pair? (car g150))
1997                                               (pair? (cdar g150))
1998                                               (null? (cddar g150)))
1999                                          (g149 (cdr g150)
2000                                                (cons (cadar g150) g148)
2001                                                (cons (caar g150) g147))
2002                                          (g146))))))
2003                        (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
2004                          (if (null? g150)
2005                              (if (and (list? (cdr args))
2006                                       (pair? (cdr args)))
2007                                  (g154 (reverse g147)
2008                                        (reverse g148)
2009                                        (cdr args))
2010                                  (g146))
2011                              (if (and (pair? (car g150))
2012                                       (pair? (cdar g150))
2013                                       (null? (cddar g150)))
2014                                  (g149 (cdr g150)
2015                                        (cons (cadar g150) g148)
2016                                        (cons (caar g150) g147))
2017                                  (g146)))))
2018                    (g146))))
2019        (g146))))
2020(define-macro
2021  (match-let* . args)
2022  (let ((g176 (lambda ()
2023                (##match#syntax-err `(match-let* ,@args) "syntax error in"))))
2024    (if (pair? args)
2025        (if (null? (car args))
2026            (if (and (list? (cdr args)) (pair? (cdr args)))
2027                ((lambda (body) `(let* ,@args)) (cdr args))
2028                (g176))
2029            (if (and (pair? (car args))
2030                     (pair? (caar args))
2031                     (pair? (cdaar args))
2032                     (null? (cddaar args))
2033                     (list? (cdar args))
2034                     (list? (cdr args))
2035                     (pair? (cdr args)))
2036                ((lambda (pat exp rest body)
2037                   (if ((cadddr ##match#expanders) pat)
2038                       `(let ((,pat ,exp)) (match-let* ,rest ,@body))
2039                       `(match ,exp (,pat (match-let* ,rest ,@body)))))
2040                 (caaar args)
2041                 (cadaar args)
2042                 (cdar args)
2043                 (cdr args))
2044                (g176)))
2045        (g176))))
2046(define-macro
2047  (match-letrec . args)
2048  (let ((g200 (cadddr ##match#expanders))
2049        (g199 (lambda (p1 e1 p2 e2 body)
2050                `(match-letrec (((,p1 . ,p2) (cons ,e1 ,e2))) ,@body)))
2051        (g195 (lambda ()
2052                (##match#syntax-err
2053                  `(match-letrec ,@args)
2054                  "syntax error in")))
2055        (g194 (lambda (pat exp body)
2056                `(match-letrec
2057                   ((,(list->vector pat) (vector ,@exp)))
2058                   ,@body)))
2059        (g186 (lambda (pat exp body)
2060                ((cadr ##match#expanders)
2061                 pat
2062                 exp
2063                 body
2064                 `(match-letrec ((,pat ,exp)) ,@body)))))
2065    (if (pair? args)
2066        (if (list? (car args))
2067            (if (andmap
2068                  (lambda (g206)
2069                    (if (and (pair? g206)
2070                             (g200 (car g206))
2071                             (pair? (cdr g206)))
2072                        (null? (cddr g206))
2073                        #f))
2074                  (car args))
2075                (if (and (list? (cdr args)) (pair? (cdr args)))
2076                    ((lambda () `(letrec ,@args)))
2077                    (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
2078                      (if (null? g190)
2079                          (g195)
2080                          (if (and (pair? (car g190))
2081                                   (pair? (cdar g190))
2082                                   (null? (cddar g190)))
2083                              (g189 (cdr g190)
2084                                    (cons (cadar g190) g188)
2085                                    (cons (caar g190) g187))
2086                              (g195)))))
2087                (if (and (pair? (car args))
2088                         (pair? (caar args))
2089                         (pair? (cdaar args))
2090                         (null? (cddaar args)))
2091                    (if (null? (cdar args))
2092                        (if (and (list? (cdr args)) (pair? (cdr args)))
2093                            (g186 (caaar args) (cadaar args) (cdr args))
2094                            (let g189 ((g190 (car args))
2095                                       (g188 '())
2096                                       (g187 '()))
2097                              (if (null? g190)
2098                                  (g195)
2099                                  (if (and (pair? (car g190))
2100                                           (pair? (cdar g190))
2101                                           (null? (cddar g190)))
2102                                      (g189 (cdr g190)
2103                                            (cons (cadar g190) g188)
2104                                            (cons (caar g190) g187))
2105                                      (g195)))))
2106                        (if (and (pair? (cdar args))
2107                                 (pair? (cadar args))
2108                                 (pair? (cdadar args))
2109                                 (null? (cdr (cdadar args)))
2110                                 (null? (cddar args)))
2111                            (if (and (list? (cdr args)) (pair? (cdr args)))
2112                                (g199 (caaar args)
2113                                      (cadaar args)
2114                                      (caadar args)
2115                                      (car (cdadar args))
2116                                      (cdr args))
2117                                (let g189 ((g190 (car args))
2118                                           (g188 '())
2119                                           (g187 '()))
2120                                  (if (null? g190)
2121                                      (g195)
2122                                      (if (and (pair? (car g190))
2123                                               (pair? (cdar g190))
2124                                               (null? (cddar g190)))
2125                                          (g189 (cdr g190)
2126                                                (cons (cadar g190) g188)
2127                                                (cons (caar g190) g187))
2128                                          (g195)))))
2129                            (let g189 ((g190 (car args))
2130                                       (g188 '())
2131                                       (g187 '()))
2132                              (if (null? g190)
2133                                  (if (and (list? (cdr args))
2134                                           (pair? (cdr args)))
2135                                      (g194 (reverse g187)
2136                                            (reverse g188)
2137                                            (cdr args))
2138                                      (g195))
2139                                  (if (and (pair? (car g190))
2140                                           (pair? (cdar g190))
2141                                           (null? (cddar g190)))
2142                                      (g189 (cdr g190)
2143                                            (cons (cadar g190) g188)
2144                                            (cons (caar g190) g187))
2145                                      (g195))))))
2146                    (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
2147                      (if (null? g190)
2148                          (if (and (list? (cdr args)) (pair? (cdr args)))
2149                              (g194 (reverse g187)
2150                                    (reverse g188)
2151                                    (cdr args))
2152                              (g195))
2153                          (if (and (pair? (car g190))
2154                                   (pair? (cdar g190))
2155                                   (null? (cddar g190)))
2156                              (g189 (cdr g190)
2157                                    (cons (cadar g190) g188)
2158                                    (cons (caar g190) g187))
2159                              (g195))))))
2160            (if (pair? (car args))
2161                (if (and (pair? (caar args))
2162                         (pair? (cdaar args))
2163                         (null? (cddaar args)))
2164                    (if (null? (cdar args))
2165                        (if (and (list? (cdr args)) (pair? (cdr args)))
2166                            (g186 (caaar args) (cadaar args) (cdr args))
2167                            (let g189 ((g190 (car args))
2168                                       (g188 '())
2169                                       (g187 '()))
2170                              (if (null? g190)
2171                                  (g195)
2172                                  (if (and (pair? (car g190))
2173                                           (pair? (cdar g190))
2174                                           (null? (cddar g190)))
2175                                      (g189 (cdr g190)
2176                                            (cons (cadar g190) g188)
2177                                            (cons (caar g190) g187))
2178                                      (g195)))))
2179                        (if (and (pair? (cdar args))
2180                                 (pair? (cadar args))
2181                                 (pair? (cdadar args))
2182                                 (null? (cdr (cdadar args)))
2183                                 (null? (cddar args)))
2184                            (if (and (list? (cdr args)) (pair? (cdr args)))
2185                                (g199 (caaar args)
2186                                      (cadaar args)
2187                                      (caadar args)
2188                                      (car (cdadar args))
2189                                      (cdr args))
2190                                (let g189 ((g190 (car args))
2191                                           (g188 '())
2192                                           (g187 '()))
2193                                  (if (null? g190)
2194                                      (g195)
2195                                      (if (and (pair? (car g190))
2196                                               (pair? (cdar g190))
2197                                               (null? (cddar g190)))
2198                                          (g189 (cdr g190)
2199                                                (cons (cadar g190) g188)
2200                                                (cons (caar g190) g187))
2201                                          (g195)))))
2202                            (let g189 ((g190 (car args))
2203                                       (g188 '())
2204                                       (g187 '()))
2205                              (if (null? g190)
2206                                  (if (and (list? (cdr args))
2207                                           (pair? (cdr args)))
2208                                      (g194 (reverse g187)
2209                                            (reverse g188)
2210                                            (cdr args))
2211                                      (g195))
2212                                  (if (and (pair? (car g190))
2213                                           (pair? (cdar g190))
2214                                           (null? (cddar g190)))
2215                                      (g189 (cdr g190)
2216                                            (cons (cadar g190) g188)
2217                                            (cons (caar g190) g187))
2218                                      (g195))))))
2219                    (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
2220                      (if (null? g190)
2221                          (if (and (list? (cdr args)) (pair? (cdr args)))
2222                              (g194 (reverse g187)
2223                                    (reverse g188)
2224                                    (cdr args))
2225                              (g195))
2226                          (if (and (pair? (car g190))
2227                                   (pair? (cdar g190))
2228                                   (null? (cddar g190)))
2229                              (g189 (cdr g190)
2230                                    (cons (cadar g190) g188)
2231                                    (cons (caar g190) g187))
2232                              (g195)))))
2233                (g195)))
2234        (g195))))
2235(define-macro
2236  (match-define . args)
2237  (let ((g210 (cadddr ##match#expanders))
2238        (g209 (lambda ()
2239                (##match#syntax-err
2240                  `(match-define ,@args)
2241                  "syntax error in"))))
2242    (if (pair? args)
2243        (if (g210 (car args))
2244            (if (and (pair? (cdr args)) (null? (cddr args)))
2245                ((lambda () `(begin (define ,@args))))
2246                (g209))
2247            (if (and (pair? (cdr args)) (null? (cddr args)))
2248                ((lambda (pat exp)
2249                   ((caddr ##match#expanders)
2250                    pat
2251                    exp
2252                    `(match-define ,@args)))
2253                 (car args)
2254                 (cadr args))
2255                (g209)))
2256        (g209))))
2257(define ##match#runtime-structures #f)
2258(define ##match#primitive-vector? vector?)
2259(define-macro
2260  (defstruct . args)
2261  (let ((field? (lambda (x)
2262                  (if (symbol? x)
2263                      ((lambda () #t))
2264                      (if (and (pair? x)
2265                               (symbol? (car x))
2266                               (pair? (cdr x))
2267                               (symbol? (cadr x))
2268                               (null? (cddr x)))
2269                          ((lambda () #t))
2270                          ((lambda () #f))))))
2271        (selector-name (lambda (x)
2272                         (if (symbol? x)
2273                             ((lambda () x))
2274                             (if (and (pair? x)
2275                                      (symbol? (car x))
2276                                      (pair? (cdr x))
2277                                      (null? (cddr x)))
2278                                 ((lambda (s) s) (car x))
2279                                 (##sys#match-error x)))))
2280        (mutator-name (lambda (x)
2281                        (if (symbol? x)
2282                            ((lambda () #f))
2283                            (if (and (pair? x)
2284                                     (pair? (cdr x))
2285                                     (symbol? (cadr x))
2286                                     (null? (cddr x)))
2287                                ((lambda (s) s) (cadr x))
2288                                (##sys#match-error x)))))
2289        (filter-map-with-index (lambda (f l)
2290                                 (letrec ((mapi (lambda (l i)
2291                                                  (cond
2292                                                    ((null? l) '())
2293                                                    ((f (car l) i) =>
2294                                                     (lambda (x)
2295                                                       (cons x
2296                                                             (mapi (cdr l)
2297                                                                   (+ 1
2298                                                                      i)))))
2299                                                    (else (mapi (cdr l)
2300                                                                (+ 1 i)))))))
2301                                   (mapi l 1)))))
2302    (let ((g227 (lambda ()
2303                  (##match#syntax-err `(defstruct ,@args) "syntax error in"))))
2304      (if (and (pair? args)
2305               (symbol? (car args))
2306               (pair? (cdr args))
2307               (symbol? (cadr args))
2308               (pair? (cddr args))
2309               (symbol? (caddr args))
2310               (list? (cdddr args)))
2311          (let g229 ((g230 (cdddr args)) (g228 '()))
2312            (if (null? g230)
2313                ((lambda (name constructor predicate fields)
2314                   (let* ((selectors (map selector-name fields))
2315                          (mutators (map mutator-name fields))
2316                          (tag (if ##match#runtime-structures
2317                                   (gensym)
2318                                   `',name))
2319                          (vectorP (cond
2320                                     ((eq? ##match#structure-control
2321                                           'disjoint) '##match#primitive-vector?)
2322                                     ((eq? ##match#structure-control 'vector) 'vector?))))
2323                     (cond
2324                       ((eq? ##match#structure-control 'disjoint) (if (eq? vector?
2325                                                                         ##match#primitive-vector?)
2326                                                                    (set! vector?
2327                                                                      (lambda (v)
2328                                                                        (and (##match#primitive-vector?
2329                                                                               v)
2330                                                                             (or (zero?
2331                                                                                   (vector-length
2332                                                                                     v))
2333                                                                                 (not (symbol?
2334                                                                                        (vector-ref
2335                                                                                          v
2336                                                                                          0)))
2337                                                                                 (not (##match#structure?
2338                                                                                        (vector-ref
2339                                                                                          v
2340                                                                                          0))))))))
2341                        (if (not (memq predicate
2342                                       ##match#disjoint-predicates))
2343                            (set! ##match#disjoint-predicates
2344                              (cons predicate ##match#disjoint-predicates))))
2345                       ((eq? ##match#structure-control 'vector) (if (not (memq predicate
2346                                                                             ##match#vector-structures))
2347                                                                  (set! ##match#vector-structures
2348                                                                    (cons predicate
2349                                                                          ##match#vector-structures))))
2350                       (else (##match#syntax-err
2351                               '(vector disjoint)
2352                               "invalid value for ##match#structure-control, legal values are")))
2353                     `(begin ,@(if ##match#runtime-structures
2354                                   `((define ,tag
2355                                       ',name))
2356                                   '())
2357                             (define ,constructor
2358                               (lambda ,selectors
2359                                 (vector ,tag ,@selectors)))
2360                             (define ,predicate
2361                               (lambda (obj)
2362                                 (and (,vectorP obj)
2363                                      (= (vector-length obj)
2364                                         ,(+ 1 (length selectors)))
2365                                      (eq? (vector-ref obj 0) ,tag))))
2366                             ,@(filter-map-with-index
2367                                 (lambda (n i)
2368                                   `(define ,n
2369                                      (lambda (obj) (vector-ref obj ,i))))
2370                                 selectors)
2371                             ,@(filter-map-with-index
2372                                 (lambda (n i)
2373                                   (and n
2374                                        `(define ,n
2375                                           (lambda (obj newval)
2376                                             (vector-set!
2377                                               obj
2378                                               ,i
2379                                               newval)))))
2380                                 mutators))))
2381                 (car args)
2382                 (cadr args)
2383                 (caddr args)
2384                 (reverse g228))
2385                (if (field? (car g230))
2386                    (g229 (cdr g230) (cons (car g230) g228))
2387                    (g227))))
2388          (g227)))))
2389(define-macro
2390  (define-structure . args)
2391  (let ((g242 (lambda ()
2392                (##match#syntax-err
2393                  `(define-structure ,@args)
2394                  "syntax error in"))))
2395    (if (and (pair? args)
2396             (pair? (car args))
2397             (list? (cdar args)))
2398        (if (null? (cdr args))
2399            ((lambda (name id1) `(define-structure (,name ,@id1) ()))
2400             (caar args)
2401             (cdar args))
2402            (if (and (pair? (cdr args)) (list? (cadr args)))
2403                (let g239 ((g240 (cadr args)) (g238 '()) (g237 '()))
2404                  (if (null? g240)
2405                      (if (null? (cddr args))
2406                          ((lambda (name id1 id2 val)
2407                             (let ((mk-id (lambda (id)
2408                                            (if (and (pair? id)
2409                                                     (equal? (car id) '@)
2410                                                     (pair? (cdr id))
2411                                                     (symbol? (cadr id))
2412                                                     (null? (cddr id)))
2413                                                ((lambda (x) x) (cadr id))
2414                                                ((lambda () `(! ,id)))))))
2415                               `(define-const-structure
2416                                  (,name ,@(map mk-id id1))
2417                                  ,(map (lambda (id v) `(,(mk-id id) ,v))
2418                                        id2
2419                                        val))))
2420                           (caar args)
2421                           (cdar args)
2422                           (reverse g237)
2423                           (reverse g238))
2424                          (g242))
2425                      (if (and (pair? (car g240))
2426                               (pair? (cdar g240))
2427                               (null? (cddar g240)))
2428                          (g239 (cdr g240)
2429                                (cons (cadar g240) g238)
2430                                (cons (caar g240) g237))
2431                          (g242))))
2432                (g242)))
2433        (g242))))
2434(define-macro
2435  (define-const-structure . args)
2436  (let ((field? (lambda (id)
2437                  (if (symbol? id)
2438                      ((lambda () #t))
2439                      (if (and (pair? id)
2440                               (equal? (car id) '!)
2441                               (pair? (cdr id))
2442                               (symbol? (cadr id))
2443                               (null? (cddr id)))
2444                          ((lambda () #t))
2445                          ((lambda () #f))))))
2446        (field-name (lambda (x) (if (symbol? x) x (cadr x))))
2447        (has-mutator? (lambda (x) (not (symbol? x))))
2448        (filter-map-with-index (lambda (f l)
2449                                 (letrec ((mapi (lambda (l i)
2450                                                  (cond
2451                                                    ((null? l) '())
2452                                                    ((f (car l) i) =>
2453                                                     (lambda (x)
2454                                                       (cons x
2455                                                             (mapi (cdr l)
2456                                                                   (+ 1
2457                                                                      i)))))
2458                                                    (else (mapi (cdr l)
2459                                                                (+ 1 i)))))))
2460                                   (mapi l 1))))
2461        (symbol-append (lambda l
2462                         (string->symbol
2463                           (apply
2464                             string-append
2465                             (map (lambda (x)
2466                                    (cond
2467                                      ((symbol? x) (symbol->string x))
2468                                      ((number? x) (number->string x))
2469                                      (else x)))
2470                                  l))))))
2471    (let ((g266 (lambda ()
2472                  (##match#syntax-err
2473                    `(define-const-structure ,@args)
2474                    "syntax error in"))))
2475      (if (and (pair? args)
2476               (pair? (car args))
2477               (list? (cdar args)))
2478          (if (null? (cdr args))
2479              ((lambda (name id1)
2480                 `(define-const-structure (,name ,@id1) ()))
2481               (caar args)
2482               (cdar args))
2483              (if (symbol? (caar args))
2484                  (let g259 ((g260 (cdar args)) (g258 '()))
2485                    (if (null? g260)
2486                        (if (and (pair? (cdr args)) (list? (cadr args)))
2487                            (let g263 ((g264 (cadr args))
2488                                       (g262 '())
2489                                       (g261 '()))
2490                              (if (null? g264)
2491                                  (if (null? (cddr args))
2492                                      ((lambda (name id1 id2 val)
2493                                         (let* ((id1id2 (append id1 id2))
2494                                                (raw-constructor (symbol-append
2495                                                                   'make-raw-
2496                                                                   name))
2497                                                (constructor (symbol-append
2498                                                               'make-
2499                                                               name))
2500                                                (predicate (symbol-append
2501                                                             name
2502                                                             '?)))
2503                                           `(begin (defstruct
2504                                                     ,name
2505                                                     ,raw-constructor
2506                                                     ,predicate
2507                                                     ,@(filter-map-with-index
2508                                                         (lambda (arg i)
2509                                                           (if (has-mutator?
2510                                                                 arg)
2511                                                               `(,(symbol-append
2512                                                                    name
2513                                                                    '-
2514                                                                    i)
2515                                                                  ,(symbol-append
2516                                                                     'set-
2517                                                                     name
2518                                                                     '-
2519                                                                     i
2520                                                                     '!))
2521                                                               (symbol-append
2522                                                                 name
2523                                                                 '-
2524                                                                 i)))
2525                                                         id1id2))
2526                                                   ,(let* ((make-fresh (lambda (x)
2527                                                                         (if (eq? '_
2528                                                                                  x)
2529                                                                             (gensym)
2530                                                                             x)))
2531                                                           (names1 (map make-fresh
2532                                                                        (map field-name
2533                                                                             id1)))
2534                                                           (names2 (map make-fresh
2535                                                                        (map field-name
2536                                                                             id2))))
2537                                                      `(define ,constructor
2538                                                         (lambda ,names1
2539                                                           (let* ,(map list
2540                                                                       names2
2541                                                                       val)
2542                                                             (,raw-constructor
2543                                                               ,@names1
2544                                                               ,@names2)))))
2545                                                   ,@(filter-map-with-index
2546                                                       (lambda (field i)
2547                                                         (if (eq? (field-name
2548                                                                    field)
2549                                                                  '_)
2550                                                             #f
2551                                                             `(define ,(symbol-append
2552                                                                         name
2553                                                                         '-
2554                                                                         (field-name
2555                                                                           field))
2556                                                                ,(symbol-append
2557                                                                   name
2558                                                                   '-
2559                                                                   i))))
2560                                                       id1id2)
2561                                                   ,@(filter-map-with-index
2562                                                       (lambda (field i)
2563                                                         (if (or (eq? (field-name
2564                                                                        field)
2565                                                                      '_)
2566                                                                 (not (has-mutator?
2567                                                                        field)))
2568                                                             #f
2569                                                             `(define ,(symbol-append
2570                                                                         'set-
2571                                                                         name
2572                                                                         '-
2573                                                                         (field-name
2574                                                                           field)
2575                                                                         '!)
2576                                                                ,(symbol-append
2577                                                                   'set-
2578                                                                   name
2579                                                                   '-
2580                                                                   i
2581                                                                   '!))))
2582                                                       id1id2))))
2583                                       (caar args)
2584                                       (reverse g258)
2585                                       (reverse g261)
2586                                       (reverse g262))
2587                                      (g266))
2588                                  (if (and (pair? (car g264))
2589                                           (field? (caar g264))
2590                                           (pair? (cdar g264))
2591                                           (null? (cddar g264)))
2592                                      (g263 (cdr g264)
2593                                            (cons (cadar g264) g262)
2594                                            (cons (caar g264) g261))
2595                                      (g266))))
2596                            (g266))
2597                        (if (field? (car g260))
2598                            (g259 (cdr g260) (cons (car g260) g258))
2599                            (g266))))
2600                  (g266)))
2601          (g266)))))
2602
2603
2604(define (match-error-control . arg)
2605  (if (pair? arg)
2606      (##match#set-error-control (car arg))
2607      ##match#error-control) )
Note: See TracBrowser for help on using the repository browser.