source: project/chicken/branches/release/match.scm @ 7276

Last change on this file since 7276 was 7276, checked in by felix winkelmann, 12 years ago

merged trunk

File size: 151.0 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;; match:error-control controls what code is generated for failed matches.
102;; Possible values:
103;;  'unspecified - do nothing, ie., evaluate (cond [#f #f])
104;;  'fail - call match:error, or die at car or cdr
105;;  'error - call match:error with the unmatched value
106;;  'match - call match:error with the unmatched value _and_
107;;             the quoted match expression
108;; match:error-control is set by calling match:set-error-control with
109;; the new value.
110;;
111;; match:error is called for a failed match.
112;; match:error is set by calling match:set-error with the new value.
113;;
114;; End of user visible/modifiable stuff.
115;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
116
117; 10/07/00 - felix:
118;
119
120
121(declare
122 (unit match)
123 (run-time-macros)
124 (disable-interrupts)
125 (usual-integrations) 
126 (hide every))
127
128(cond-expand 
129 [paranoia]
130 [else
131  (declare
132    (no-procedure-checks-for-usual-bindings)
133    (no-bound-checks) ) ] )
134
135
136(define (every fn lst)
137  (or (null? lst)
138      (and (fn (car lst)) (every fn (cdr lst)))))
139
140
141;;; Macros
142
143(define-macro
144  (match . args)
145  (cond
146    ((and (list? args)
147          (<= 1 (length args))
148          (every
149            (lambda (y) (and (list? y) (<= 2 (length y))))
150            (cdr args))) (let* ((exp (car args))
151                                (clauses (cdr args))
152                                (e (if (symbol? exp) exp (gensym))))
153                           (if (symbol? exp)
154                               ((car ##match#expanders)
155                                e
156                                clauses
157                                `(match ,@args))
158                               `(let ((,e ,exp))
159                                  ,((car ##match#expanders)
160                                    e
161                                    clauses
162                                    `(match ,@args))))))
163    (else (##match#syntax-err `(match ,@args) "syntax error in"))))
164(define-macro
165  (match-lambda . args)
166  (if (and (list? args)
167           (every
168             (lambda (g126)
169               (if (and (pair? g126) (list? (cdr g126)))
170                   (pair? (cdr g126))
171                   #f))
172             args))
173      ((lambda ()
174         (let ((e (gensym))) `(lambda (,e) (match ,e ,@args)))))
175      ((lambda ()
176         (##match#syntax-err
177           `(match-lambda ,@args)
178           "syntax error in")))))
179(define-macro
180  (match-lambda* . args)
181  (if (and (list? args)
182           (every
183             (lambda (g134)
184               (if (and (pair? g134) (list? (cdr g134)))
185                   (pair? (cdr g134))
186                   #f))
187             args))
188      ((lambda ()
189         (let ((e (gensym))) `(lambda ,e (match ,e ,@args)))))
190      ((lambda ()
191         (##match#syntax-err
192           `(match-lambda* ,@args)
193           "syntax error in")))))
194(define-macro
195  (match-let . args)
196  (let ((g158 (lambda (pat exp body)
197                `(match ,exp (,pat ,@body))))
198        (g154 (lambda (pat exp body)
199                (let ((g (map (lambda (x) (gensym)) pat))
200                      (vpattern (list->vector pat)))
201                  `(let ,(map list g exp)
202                     (match (vector ,@g) (,vpattern ,@body))))))
203        (g146 (lambda ()
204                (##match#syntax-err `(match-let ,@args) "syntax error in")))
205        (g145 (lambda (p1 e1 p2 e2 body)
206                (let ((g1 (gensym)) (g2 (gensym)))
207                  `(let ((,g1 ,e1) (,g2 ,e2))
208                     (match (cons ,g1 ,g2) ((,p1 . ,p2) ,@body))))))
209        (g136 (cadddr ##match#expanders)))
210    (if (pair? args)
211        (if (symbol? (car args))
212            (if (and (pair? (cdr args)) (list? (cadr args)))
213                (let g161 ((g162 (cadr args)) (g160 '()) (g159 '()))
214                  (if (null? g162)
215                      (if (and (list? (cddr args)) (pair? (cddr args)))
216                          ((lambda (name pat exp body)
217                             (if (every
218                                   (cadddr ##match#expanders)
219                                   pat)
220                                 `(let ,@args)
221                                 `(letrec ((,name (match-lambda*
222                                                    (,pat ,@body))))
223                                    (,name ,@exp))))
224                           (car args)
225                           (reverse g159)
226                           (reverse g160)
227                           (cddr args))
228                          (g146))
229                      (if (and (pair? (car g162))
230                               (pair? (cdar g162))
231                               (null? (cddar g162)))
232                          (g161 (cdr g162)
233                                (cons (cadar g162) g160)
234                                (cons (caar g162) g159))
235                          (g146))))
236                (g146))
237            (if (list? (car args))
238                (if (every
239                      (lambda (g167)
240                        (if (and (pair? g167)
241                                 (g136 (car g167))
242                                 (pair? (cdr g167)))
243                            (null? (cddr g167))
244                            #f))
245                      (car args))
246                    (if (and (list? (cdr args)) (pair? (cdr args)))
247                        ((lambda () `(let ,@args)))
248                        (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
249                          (if (null? g150)
250                              (g146)
251                              (if (and (pair? (car g150))
252                                       (pair? (cdar g150))
253                                       (null? (cddar g150)))
254                                  (g149 (cdr g150)
255                                        (cons (cadar g150) g148)
256                                        (cons (caar g150) g147))
257                                  (g146)))))
258                    (if (and (pair? (car args))
259                             (pair? (caar args))
260                             (pair? (cdaar args))
261                             (null? (cddaar args)))
262                        (if (null? (cdar args))
263                            (if (and (list? (cdr args)) (pair? (cdr args)))
264                                (g158 (caaar args)
265                                      (cadaar args)
266                                      (cdr args))
267                                (let g149 ((g150 (car args))
268                                           (g148 '())
269                                           (g147 '()))
270                                  (if (null? g150)
271                                      (g146)
272                                      (if (and (pair? (car g150))
273                                               (pair? (cdar g150))
274                                               (null? (cddar g150)))
275                                          (g149 (cdr g150)
276                                                (cons (cadar g150) g148)
277                                                (cons (caar g150) g147))
278                                          (g146)))))
279                            (if (and (pair? (cdar args))
280                                     (pair? (cadar args))
281                                     (pair? (cdadar args))
282                                     (null? (cdr (cdadar args)))
283                                     (null? (cddar args)))
284                                (if (and (list? (cdr args))
285                                         (pair? (cdr args)))
286                                    (g145 (caaar args)
287                                          (cadaar args)
288                                          (caadar args)
289                                          (car (cdadar args))
290                                          (cdr args))
291                                    (let g149 ((g150 (car args))
292                                               (g148 '())
293                                               (g147 '()))
294                                      (if (null? g150)
295                                          (g146)
296                                          (if (and (pair? (car g150))
297                                                   (pair? (cdar g150))
298                                                   (null? (cddar g150)))
299                                              (g149 (cdr g150)
300                                                    (cons (cadar g150)
301                                                          g148)
302                                                    (cons (caar g150)
303                                                          g147))
304                                              (g146)))))
305                                (let g149 ((g150 (car args))
306                                           (g148 '())
307                                           (g147 '()))
308                                  (if (null? g150)
309                                      (if (and (list? (cdr args))
310                                               (pair? (cdr args)))
311                                          (g154 (reverse g147)
312                                                (reverse g148)
313                                                (cdr args))
314                                          (g146))
315                                      (if (and (pair? (car g150))
316                                               (pair? (cdar g150))
317                                               (null? (cddar g150)))
318                                          (g149 (cdr g150)
319                                                (cons (cadar g150) g148)
320                                                (cons (caar g150) g147))
321                                          (g146))))))
322                        (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
323                          (if (null? g150)
324                              (if (and (list? (cdr args))
325                                       (pair? (cdr args)))
326                                  (g154 (reverse g147)
327                                        (reverse g148)
328                                        (cdr args))
329                                  (g146))
330                              (if (and (pair? (car g150))
331                                       (pair? (cdar g150))
332                                       (null? (cddar g150)))
333                                  (g149 (cdr g150)
334                                        (cons (cadar g150) g148)
335                                        (cons (caar g150) g147))
336                                  (g146))))))
337                (if (pair? (car args))
338                    (if (and (pair? (caar args))
339                             (pair? (cdaar args))
340                             (null? (cddaar args)))
341                        (if (null? (cdar args))
342                            (if (and (list? (cdr args)) (pair? (cdr args)))
343                                (g158 (caaar args)
344                                      (cadaar args)
345                                      (cdr args))
346                                (let g149 ((g150 (car args))
347                                           (g148 '())
348                                           (g147 '()))
349                                  (if (null? g150)
350                                      (g146)
351                                      (if (and (pair? (car g150))
352                                               (pair? (cdar g150))
353                                               (null? (cddar g150)))
354                                          (g149 (cdr g150)
355                                                (cons (cadar g150) g148)
356                                                (cons (caar g150) g147))
357                                          (g146)))))
358                            (if (and (pair? (cdar args))
359                                     (pair? (cadar args))
360                                     (pair? (cdadar args))
361                                     (null? (cdr (cdadar args)))
362                                     (null? (cddar args)))
363                                (if (and (list? (cdr args))
364                                         (pair? (cdr args)))
365                                    (g145 (caaar args)
366                                          (cadaar args)
367                                          (caadar args)
368                                          (car (cdadar args))
369                                          (cdr args))
370                                    (let g149 ((g150 (car args))
371                                               (g148 '())
372                                               (g147 '()))
373                                      (if (null? g150)
374                                          (g146)
375                                          (if (and (pair? (car g150))
376                                                   (pair? (cdar g150))
377                                                   (null? (cddar g150)))
378                                              (g149 (cdr g150)
379                                                    (cons (cadar g150)
380                                                          g148)
381                                                    (cons (caar g150)
382                                                          g147))
383                                              (g146)))))
384                                (let g149 ((g150 (car args))
385                                           (g148 '())
386                                           (g147 '()))
387                                  (if (null? g150)
388                                      (if (and (list? (cdr args))
389                                               (pair? (cdr args)))
390                                          (g154 (reverse g147)
391                                                (reverse g148)
392                                                (cdr args))
393                                          (g146))
394                                      (if (and (pair? (car g150))
395                                               (pair? (cdar g150))
396                                               (null? (cddar g150)))
397                                          (g149 (cdr g150)
398                                                (cons (cadar g150) g148)
399                                                (cons (caar g150) g147))
400                                          (g146))))))
401                        (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
402                          (if (null? g150)
403                              (if (and (list? (cdr args))
404                                       (pair? (cdr args)))
405                                  (g154 (reverse g147)
406                                        (reverse g148)
407                                        (cdr args))
408                                  (g146))
409                              (if (and (pair? (car g150))
410                                       (pair? (cdar g150))
411                                       (null? (cddar g150)))
412                                  (g149 (cdr g150)
413                                        (cons (cadar g150) g148)
414                                        (cons (caar g150) g147))
415                                  (g146)))))
416                    (g146))))
417        (g146))))
418(define-macro
419  (match-let* . args)
420  (let ((g176 (lambda ()
421                (##match#syntax-err `(match-let* ,@args) "syntax error in"))))
422    (if (pair? args)
423        (if (null? (car args))
424            (if (and (list? (cdr args)) (pair? (cdr args)))
425                ((lambda (body) `(let* ,@args)) (cdr args))
426                (g176))
427            (if (and (pair? (car args))
428                     (pair? (caar args))
429                     (pair? (cdaar args))
430                     (null? (cddaar args))
431                     (list? (cdar args))
432                     (list? (cdr args))
433                     (pair? (cdr args)))
434                ((lambda (pat exp rest body)
435                   (if ((cadddr ##match#expanders) pat)
436                       `(let ((,pat ,exp)) (match-let* ,rest ,@body))
437                       `(match ,exp (,pat (match-let* ,rest ,@body)))))
438                 (caaar args)
439                 (cadaar args)
440                 (cdar args)
441                 (cdr args))
442                (g176)))
443        (g176))))
444(define-macro
445  (match-letrec . args)
446  (let ((g200 (cadddr ##match#expanders))
447        (g199 (lambda (p1 e1 p2 e2 body)
448                `(match-letrec (((,p1 . ,p2) (cons ,e1 ,e2))) ,@body)))
449        (g195 (lambda ()
450                (##match#syntax-err
451                  `(match-letrec ,@args)
452                  "syntax error in")))
453        (g194 (lambda (pat exp body)
454                `(match-letrec
455                   ((,(list->vector pat) (vector ,@exp)))
456                   ,@body)))
457        (g186 (lambda (pat exp body)
458                ((cadr ##match#expanders)
459                 pat
460                 exp
461                 body
462                 `(match-letrec ((,pat ,exp)) ,@body)))))
463    (if (pair? args)
464        (if (list? (car args))
465            (if (every
466                  (lambda (g206)
467                    (if (and (pair? g206)
468                             (g200 (car g206))
469                             (pair? (cdr g206)))
470                        (null? (cddr g206))
471                        #f))
472                  (car args))
473                (if (and (list? (cdr args)) (pair? (cdr args)))
474                    ((lambda () `(letrec ,@args)))
475                    (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
476                      (if (null? g190)
477                          (g195)
478                          (if (and (pair? (car g190))
479                                   (pair? (cdar g190))
480                                   (null? (cddar g190)))
481                              (g189 (cdr g190)
482                                    (cons (cadar g190) g188)
483                                    (cons (caar g190) g187))
484                              (g195)))))
485                (if (and (pair? (car args))
486                         (pair? (caar args))
487                         (pair? (cdaar args))
488                         (null? (cddaar args)))
489                    (if (null? (cdar args))
490                        (if (and (list? (cdr args)) (pair? (cdr args)))
491                            (g186 (caaar args) (cadaar args) (cdr args))
492                            (let g189 ((g190 (car args))
493                                       (g188 '())
494                                       (g187 '()))
495                              (if (null? g190)
496                                  (g195)
497                                  (if (and (pair? (car g190))
498                                           (pair? (cdar g190))
499                                           (null? (cddar g190)))
500                                      (g189 (cdr g190)
501                                            (cons (cadar g190) g188)
502                                            (cons (caar g190) g187))
503                                      (g195)))))
504                        (if (and (pair? (cdar args))
505                                 (pair? (cadar args))
506                                 (pair? (cdadar args))
507                                 (null? (cdr (cdadar args)))
508                                 (null? (cddar args)))
509                            (if (and (list? (cdr args)) (pair? (cdr args)))
510                                (g199 (caaar args)
511                                      (cadaar args)
512                                      (caadar args)
513                                      (car (cdadar args))
514                                      (cdr args))
515                                (let g189 ((g190 (car args))
516                                           (g188 '())
517                                           (g187 '()))
518                                  (if (null? g190)
519                                      (g195)
520                                      (if (and (pair? (car g190))
521                                               (pair? (cdar g190))
522                                               (null? (cddar g190)))
523                                          (g189 (cdr g190)
524                                                (cons (cadar g190) g188)
525                                                (cons (caar g190) g187))
526                                          (g195)))))
527                            (let g189 ((g190 (car args))
528                                       (g188 '())
529                                       (g187 '()))
530                              (if (null? g190)
531                                  (if (and (list? (cdr args))
532                                           (pair? (cdr args)))
533                                      (g194 (reverse g187)
534                                            (reverse g188)
535                                            (cdr args))
536                                      (g195))
537                                  (if (and (pair? (car g190))
538                                           (pair? (cdar g190))
539                                           (null? (cddar g190)))
540                                      (g189 (cdr g190)
541                                            (cons (cadar g190) g188)
542                                            (cons (caar g190) g187))
543                                      (g195))))))
544                    (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
545                      (if (null? g190)
546                          (if (and (list? (cdr args)) (pair? (cdr args)))
547                              (g194 (reverse g187)
548                                    (reverse g188)
549                                    (cdr args))
550                              (g195))
551                          (if (and (pair? (car g190))
552                                   (pair? (cdar g190))
553                                   (null? (cddar g190)))
554                              (g189 (cdr g190)
555                                    (cons (cadar g190) g188)
556                                    (cons (caar g190) g187))
557                              (g195))))))
558            (if (pair? (car args))
559                (if (and (pair? (caar args))
560                         (pair? (cdaar args))
561                         (null? (cddaar args)))
562                    (if (null? (cdar args))
563                        (if (and (list? (cdr args)) (pair? (cdr args)))
564                            (g186 (caaar args) (cadaar args) (cdr args))
565                            (let g189 ((g190 (car args))
566                                       (g188 '())
567                                       (g187 '()))
568                              (if (null? g190)
569                                  (g195)
570                                  (if (and (pair? (car g190))
571                                           (pair? (cdar g190))
572                                           (null? (cddar g190)))
573                                      (g189 (cdr g190)
574                                            (cons (cadar g190) g188)
575                                            (cons (caar g190) g187))
576                                      (g195)))))
577                        (if (and (pair? (cdar args))
578                                 (pair? (cadar args))
579                                 (pair? (cdadar args))
580                                 (null? (cdr (cdadar args)))
581                                 (null? (cddar args)))
582                            (if (and (list? (cdr args)) (pair? (cdr args)))
583                                (g199 (caaar args)
584                                      (cadaar args)
585                                      (caadar args)
586                                      (car (cdadar args))
587                                      (cdr args))
588                                (let g189 ((g190 (car args))
589                                           (g188 '())
590                                           (g187 '()))
591                                  (if (null? g190)
592                                      (g195)
593                                      (if (and (pair? (car g190))
594                                               (pair? (cdar g190))
595                                               (null? (cddar g190)))
596                                          (g189 (cdr g190)
597                                                (cons (cadar g190) g188)
598                                                (cons (caar g190) g187))
599                                          (g195)))))
600                            (let g189 ((g190 (car args))
601                                       (g188 '())
602                                       (g187 '()))
603                              (if (null? g190)
604                                  (if (and (list? (cdr args))
605                                           (pair? (cdr args)))
606                                      (g194 (reverse g187)
607                                            (reverse g188)
608                                            (cdr args))
609                                      (g195))
610                                  (if (and (pair? (car g190))
611                                           (pair? (cdar g190))
612                                           (null? (cddar g190)))
613                                      (g189 (cdr g190)
614                                            (cons (cadar g190) g188)
615                                            (cons (caar g190) g187))
616                                      (g195))))))
617                    (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
618                      (if (null? g190)
619                          (if (and (list? (cdr args)) (pair? (cdr args)))
620                              (g194 (reverse g187)
621                                    (reverse g188)
622                                    (cdr args))
623                              (g195))
624                          (if (and (pair? (car g190))
625                                   (pair? (cdar g190))
626                                   (null? (cddar g190)))
627                              (g189 (cdr g190)
628                                    (cons (cadar g190) g188)
629                                    (cons (caar g190) g187))
630                              (g195)))))
631                (g195)))
632        (g195))))
633(define-macro
634  (match-define . args)
635  (let ((g210 (cadddr ##match#expanders))
636        (g209 (lambda ()
637                (##match#syntax-err
638                  `(match-define ,@args)
639                  "syntax error in"))))
640    (if (pair? args)
641        (if (g210 (car args))
642            (if (and (pair? (cdr args)) (null? (cddr args)))
643                ((lambda () `(begin (define ,@args))))
644                (g209))
645            (if (and (pair? (cdr args)) (null? (cddr args)))
646                ((lambda (pat exp)
647                   ((caddr ##match#expanders)
648                    pat
649                    exp
650                    `(match-define ,@args)))
651                 (car args)
652                 (cadr args))
653                (g209)))
654        (g209))))
655
656
657;;; Support code
658
659(define ##match#syntax-err
660  (lambda (obj msg) (##sys#signal-hook #:syntax-error msg obj)))
661(define ##match#set-error (lambda (v) (set! ##sys#match-error v)))
662(define ##match#error-control #:error)
663(define ##match#set-error-control
664  (lambda (v) (set! ##match#error-control v)))
665(define ##match#disjoint-predicates
666  (cons 'null
667        '(pair?
668           symbol?
669           boolean?
670           number?
671           string?
672           char?
673           procedure?
674           vector?)))
675(define ##match#expanders
676  (letrec ((genmatch (lambda (x clauses match-expr)
677                       (let* ((length>= (gensym))
678                              (eb-errf (error-maker match-expr))
679                              (blist (car eb-errf))
680                              (plist (map (lambda (c)
681                                            (let* ((x (bound
682                                                        (validate-pattern
683                                                          (car c))))
684                                                   (p (car x))
685                                                   (bv (cadr x))
686                                                   (bindings (caddr x))
687                                                   (code (gensym))
688                                                   (fail (and (pair?
689                                                                (cdr c))
690                                                              (pair?
691                                                                (cadr c))
692                                                              (eq? (caadr
693                                                                     c)
694                                                                   '=>)
695                                                              (symbol?
696                                                                (cadadr c))
697                                                              (pair?
698                                                                (cdadr c))
699                                                              (null?
700                                                                (cddadr c))
701                                                              (pair?
702                                                                (cddr c))
703                                                              (cadadr c)))
704                                                   (bv2 (if fail
705                                                            (cons fail bv)
706                                                            bv))
707                                                   (body (if fail
708                                                             (cddr c)
709                                                             (cdr c))))
710                                              (set! blist
711                                                (cons `(,code
712                                                         (lambda ,bv2
713                                                           ,@body))
714                                                      (append
715                                                        bindings
716                                                        blist)))
717                                              (list p
718                                                    code
719                                                    bv
720                                                    (and fail (gensym))
721                                                    #f)))
722                                          clauses))
723                              (code (gen x
724                                         '()
725                                         plist
726                                         (cdr eb-errf)
727                                         length>=
728                                         (gensym))))
729                         (unreachable plist match-expr)
730                         (inline-let
731                           `(let ((,length>= (lambda (n)
732                                               (lambda (l)
733                                                 (>= (length l) n))))
734                                  ,@blist)
735                              ,code)))))
736           (genletrec (lambda (pat exp body match-expr)
737                        (let* ((length>= (gensym))
738                               (eb-errf (error-maker match-expr))
739                               (x (bound (validate-pattern pat)))
740                               (p (car x))
741                               (bv (cadr x))
742                               (bindings (caddr x))
743                               (code (gensym))
744                               (plist (list (list p code bv #f #f)))
745                               (x (gensym))
746                               (m (gen x
747                                       '()
748                                       plist
749                                       (cdr eb-errf)
750                                       length>=
751                                       (gensym)))
752                               (gs (map (lambda (_) (gensym)) bv)))
753                          (unreachable plist match-expr)
754                          `(letrec ((,length>= (lambda (n)
755                                                 (lambda (l)
756                                                   (>= (length l) n))))
757                                    ,@(map (lambda (v) `(,v #f)) bv)
758                                    (,x ,exp)
759                                    (,code (lambda ,gs
760                                             ,@(map (lambda (v g)
761                                                      `(set! ,v ,g))
762                                                    bv
763                                                    gs)
764                                             ,@body))
765                                    ,@bindings
766                                    ,@(car eb-errf))
767                             ,m))))
768           (gendefine (lambda (pat exp match-expr)
769                        (let* ((length>= (gensym))
770                               (eb-errf (error-maker match-expr))
771                               (x (bound (validate-pattern pat)))
772                               (p (car x))
773                               (bv (cadr x))
774                               (bindings (caddr x))
775                               (code (gensym))
776                               (plist (list (list p code bv #f #f)))
777                               (x (gensym))
778                               (m (gen x
779                                       '()
780                                       plist
781                                       (cdr eb-errf)
782                                       length>=
783                                       (gensym)))
784                               (gs (map (lambda (_) (gensym)) bv)))
785                          (unreachable plist match-expr)
786                          `(begin ,@(map (lambda (v) `(define ,v #f)) bv)
787                                  ,(inline-let
788                                     `(let ((,length>= (lambda (n)
789                                                         (lambda (l)
790                                                           (>= (length l)
791                                                               n))))
792                                            (,x ,exp)
793                                            (,code (lambda ,gs
794                                                     ,@(map (lambda (v g)
795                                                              `(set! ,v
796                                                                 ,g))
797                                                            bv
798                                                            gs)
799                                                     (##sys#void)))
800                                            ,@bindings
801                                            ,@(car eb-errf))
802                                        ,m))))))
803           (pattern-var? (lambda (x)
804                           (and (symbol? x)
805                                (not (dot-dot-k? x))
806                                (not (memq x
807                                           '(quasiquote
808                                              quote
809                                              unquote
810                                              unquote-splicing
811                                              ?
812                                              _
813                                              $
814                                              =
815                                              and
816                                              or
817                                              not
818                                              set!
819                                              get!
820                                              ...
821                                              ___))))))
822           (dot-dot-k? (lambda (s)
823                         (and (symbol? s)
824                              (if (memq s '(... ___))
825                                  0
826                                  (let* ((s (symbol->string s))
827                                         (n (string-length s)))
828                                    (and (<= 3 n)
829                                         (memq (string-ref s 0) '(#\. #\_))
830                                         (memq (string-ref s 1) '(#\. #\_))
831                                         (every
832                                           char-numeric?
833                                           (string->list
834                                             (substring s 2 n)))
835                                         (string->number
836                                           (substring s 2 n))))))))
837           (error-maker (lambda (match-expr)
838                          (cond
839                            ((eq? ##match#error-control '#:unspecified) (cons '()
840                                                                          (lambda (x) '(##sys#void))))
841                            ((memq ##match#error-control '(#:error #:fail)) (cons '()
842                                                                            (lambda (x)
843                                                                              `(##sys#match-error
844                                                                                 ,x))))
845                            ((eq? ##match#error-control '#:match) (let ((errf (gensym))
846                                                                    (arg (gensym)))
847                                                                (cons `((,errf
848                                                                          (lambda (,arg)
849                                                                            (##sys#match-error
850                                                                              ,arg
851                                                                              ',match-expr))))
852                                                                      (lambda (x)
853                                                                        `(,errf
854                                                                           ,x)))))
855                            (else (##match#syntax-err
856                                    '(unspecified error fail match)
857                                    "invalid value for ##match#error-control, legal values are")))))
858           (unreachable (lambda (plist match-expr)
859                          (for-each
860                            (lambda (x)
861                              (if (not (car (cddddr x)))
862                                  (##sys#warn "Warning: unreachable pattern " (car x) 'in match-expr) ) )
863                            plist)))
864           (validate-pattern (lambda (pattern)
865                               (letrec ((simple? (lambda (x)
866                                                   (or (string? x)
867                                                       (boolean? x)
868                                                       (char? x)
869                                                       (number? x)
870                                                       (null? x))))
871                                        (ordinary (lambda (p)
872                                                    (let ((g88 (lambda (x
873                                                                        y)
874                                                                 (cons (ordinary
875                                                                         x)
876                                                                       (ordinary
877                                                                         y)))))
878                                                      (if (simple? p)
879                                                          ((lambda (p) p)
880                                                           p)
881                                                          (if (equal? p '_)
882                                                              ((lambda ()
883                                                                 '_))
884                                                              (if (pattern-var?
885                                                                    p)
886                                                                  ((lambda (p)
887                                                                     p)
888                                                                   p)
889                                                                  (if (pair?
890                                                                        p)
891                                                                      (if (equal?
892                                                                            (car p)
893                                                                            'quasiquote)
894                                                                          (if (and (pair?
895                                                                                     (cdr p))
896                                                                                   (null?
897                                                                                     (cddr p)))
898                                                                              ((lambda (p)
899                                                                                 (quasi
900                                                                                   p))
901                                                                               (cadr p))
902                                                                              (g88 (car p)
903                                                                                   (cdr p)))
904                                                                          (if (equal?
905                                                                                (car p)
906                                                                                'quote)
907                                                                              (if (and (pair?
908                                                                                         (cdr p))
909                                                                                       (null?
910                                                                                         (cddr p)))
911                                                                                  ((lambda (p)
912                                                                                     p)
913                                                                                   p)
914                                                                                  (g88 (car p)
915                                                                                       (cdr p)))
916                                                                              (if (equal?
917                                                                                    (car p)
918                                                                                    '?)
919                                                                                  (if (and (pair?
920                                                                                             (cdr p))
921                                                                                           (list?
922                                                                                             (cddr p)))
923                                                                                      ((lambda (pred
924                                                                                                ps)
925                                                                                         `(? ,pred
926                                                                                             ,@(map ordinary
927                                                                                                    ps)))
928                                                                                       (cadr p)
929                                                                                       (cddr p))
930                                                                                      (g88 (car p)
931                                                                                           (cdr p)))
932                                                                                  (if (equal?
933                                                                                        (car p)
934                                                                                        '=)
935                                                                                      (if (and (pair?
936                                                                                                 (cdr p))
937                                                                                               (pair?
938                                                                                                 (cddr p))
939                                                                                               (null?
940                                                                                                 (cdddr
941                                                                                                   p)))
942                                                                                          ((lambda (sel
943                                                                                                    p)
944                                                                                             `(= ,sel
945                                                                                                 ,(ordinary
946                                                                                                    p)))
947                                                                                           (cadr p)
948                                                                                           (caddr
949                                                                                             p))
950                                                                                          (g88 (car p)
951                                                                                               (cdr p)))
952                                                                                      (if (equal?
953                                                                                            (car p)
954                                                                                            'and)
955                                                                                          (if (and (list?
956                                                                                                     (cdr p))
957                                                                                                   (pair?
958                                                                                                     (cdr p)))
959                                                                                              ((lambda (ps)
960                                                                                                 `(and ,@(map ordinary
961                                                                                                              ps)))
962                                                                                               (cdr p))
963                                                                                              (g88 (car p)
964                                                                                                   (cdr p)))
965                                                                                          (if (equal?
966                                                                                                (car p)
967                                                                                                'or)
968                                                                                              (if (and (list?
969                                                                                                         (cdr p))
970                                                                                                       (pair?
971                                                                                                         (cdr p)))
972                                                                                                  ((lambda (ps)
973                                                                                                     `(or ,@(map ordinary
974                                                                                                                 ps)))
975                                                                                                   (cdr p))
976                                                                                                  (g88 (car p)
977                                                                                                       (cdr p)))
978                                                                                              (if (equal?
979                                                                                                    (car p)
980                                                                                                    'not)
981                                                                                                  (if (and (list?
982                                                                                                             (cdr p))
983                                                                                                           (pair?
984                                                                                                             (cdr p)))
985                                                                                                      ((lambda (ps)
986                                                                                                         `(not ,@(map ordinary
987                                                                                                                      ps)))
988                                                                                                       (cdr p))
989                                                                                                      (g88 (car p)
990                                                                                                           (cdr p)))
991                                                                                                  (if (equal?
992                                                                                                        (car p)
993                                                                                                        '$)
994                                                                                                      (if (and (pair?
995                                                                                                                 (cdr p))
996                                                                                                               (symbol?
997                                                                                                                 (cadr p))
998                                                                                                               (list?
999                                                                                                                 (cddr p)))
1000                                                                                                          ((lambda (r
1001                                                                                                                    ps)
1002                                                                                                             `($ ,r
1003                                                                                                                 ,@(map ordinary
1004                                                                                                                        ps)))
1005                                                                                                           (cadr p)
1006                                                                                                           (cddr p))
1007                                                                                                          (g88 (car p)
1008                                                                                                               (cdr p)))
1009                                                                                                      (if (equal?
1010                                                                                                            (car p)
1011                                                                                                            'set!)
1012                                                                                                          (if (and (pair?
1013                                                                                                                     (cdr p))
1014                                                                                                                   (pattern-var?
1015                                                                                                                     (cadr p))
1016                                                                                                                   (null?
1017                                                                                                                     (cddr p)))
1018                                                                                                              ((lambda (p)
1019                                                                                                                 p)
1020                                                                                                               p)
1021                                                                                                              (g88 (car p)
1022                                                                                                                   (cdr p)))
1023                                                                                                          (if (equal?
1024                                                                                                                (car p)
1025                                                                                                                'get!)
1026                                                                                                              (if (and (pair?
1027                                                                                                                         (cdr p))
1028                                                                                                                       (pattern-var?
1029                                                                                                                         (cadr p))
1030                                                                                                                       (null?
1031                                                                                                                         (cddr p)))
1032                                                                                                                  ((lambda (p)
1033                                                                                                                     p)
1034                                                                                                                   p)
1035                                                                                                                  (g88 (car p)
1036                                                                                                                       (cdr p)))
1037                                                                                                              (if (equal?
1038                                                                                                                    (car p)
1039                                                                                                                    'unquote)
1040                                                                                                                  (g88 (car p)
1041                                                                                                                       (cdr p))
1042                                                                                                                  (if (equal?
1043                                                                                                                        (car p)
1044                                                                                                                        'unquote-splicing)
1045                                                                                                                      (g88 (car p)
1046                                                                                                                           (cdr p))
1047                                                                                                                      (if (and (pair?
1048                                                                                                                                 (cdr p))
1049                                                                                                                               (dot-dot-k?
1050                                                                                                                                 (cadr p))
1051                                                                                                                               (null?
1052                                                                                                                                 (cddr p)))
1053                                                                                                                          ((lambda (p
1054                                                                                                                                    ddk)
1055                                                                                                                             `(,(ordinary
1056                                                                                                                                  p)
1057                                                                                                                                ,ddk))
1058                                                                                                                           (car p)
1059                                                                                                                           (cadr p))
1060                                                                                                                          (g88 (car p)
1061                                                                                                                               (cdr p)))))))))))))))
1062                                                                      (if (vector?
1063                                                                            p)
1064                                                                          ((lambda (p)
1065                                                                             (let* ((pl (vector->list
1066                                                                                          p))
1067                                                                                    (rpl (reverse
1068                                                                                           pl)))
1069                                                                               (apply
1070                                                                                 vector
1071                                                                                 (if (and (not (null?
1072                                                                                                 rpl))
1073                                                                                          (dot-dot-k?
1074                                                                                            (car rpl)))
1075                                                                                     (reverse
1076                                                                                       (cons (car rpl)
1077                                                                                             (map ordinary
1078                                                                                                  (cdr rpl))))
1079                                                                                     (map ordinary
1080                                                                                          pl)))))
1081                                                                           p)
1082                                                                          ((lambda ()
1083                                                                             (##match#syntax-err
1084                                                                               pattern
1085                                                                               "syntax error in pattern")))))))))))
1086                                        (quasi (lambda (p)
1087                                                 (let ((g109 (lambda (x y)
1088                                                               (cons (quasi
1089                                                                       x)
1090                                                                     (quasi
1091                                                                       y)))))
1092                                                   (if (simple? p)
1093                                                       ((lambda (p) p) p)
1094                                                       (if (symbol? p)
1095                                                           ((lambda (p)
1096                                                              `',p)
1097                                                            p)
1098                                                           (if (pair? p)
1099                                                               (if (equal?
1100                                                                     (car p)
1101                                                                     'unquote)
1102                                                                   (if (and (pair?
1103                                                                              (cdr p))
1104                                                                            (null?
1105                                                                              (cddr p)))
1106                                                                       ((lambda (p)
1107                                                                          (ordinary
1108                                                                            p))
1109                                                                        (cadr p))
1110                                                                       (g109 (car p)
1111                                                                             (cdr p)))
1112                                                                   (if (and (pair?
1113                                                                              (car p))
1114                                                                            (equal?
1115                                                                              (caar p)
1116                                                                              'unquote-splicing)
1117                                                                            (pair?
1118                                                                              (cdar p))
1119                                                                            (null?
1120                                                                              (cddar
1121                                                                                p)))
1122                                                                       (if (null?
1123                                                                             (cdr p))
1124                                                                           ((lambda (p)
1125                                                                              (ordinary
1126                                                                                p))
1127                                                                            (cadar
1128                                                                              p))
1129                                                                           ((lambda (p
1130                                                                                     y)
1131                                                                              (append
1132                                                                                (ordlist
1133                                                                                  p)
1134                                                                                (quasi
1135                                                                                  y)))
1136                                                                            (cadar
1137                                                                              p)
1138                                                                            (cdr p)))
1139                                                                       (if (and (pair?
1140                                                                                  (cdr p))
1141                                                                                (dot-dot-k?
1142                                                                                  (cadr p))
1143                                                                                (null?
1144                                                                                  (cddr p)))
1145                                                                           ((lambda (p
1146                                                                                     ddk)
1147                                                                              `(,(quasi
1148                                                                                   p)
1149                                                                                 ,ddk))
1150                                                                            (car p)
1151                                                                            (cadr p))
1152                                                                           (g109 (car p)
1153                                                                                 (cdr p)))))
1154                                                               (if (vector?
1155                                                                     p)
1156                                                                   ((lambda (p)
1157                                                                      (let* ((pl (vector->list
1158                                                                                   p))
1159                                                                             (rpl (reverse
1160                                                                                    pl)))
1161                                                                        (apply
1162                                                                          vector
1163                                                                          (if (dot-dot-k?
1164                                                                                (car rpl))
1165                                                                              (reverse
1166                                                                                (cons (car rpl)
1167                                                                                      (map quasi
1168                                                                                           (cdr rpl))))
1169                                                                              (map ordinary
1170                                                                                   pl)))))
1171                                                                    p)
1172                                                                   ((lambda ()
1173                                                                      (##match#syntax-err
1174                                                                        pattern
1175                                                                        "syntax error in pattern"))))))))))
1176                                        (ordlist (lambda (p)
1177                                                   (cond
1178                                                     ((null? p) '())
1179                                                     ((pair? p) (cons (ordinary
1180                                                                        (car p))
1181                                                                      (ordlist
1182                                                                        (cdr p))))
1183                                                     (else (##match#syntax-err
1184                                                             pattern
1185                                                             "invalid use of unquote-splicing in pattern"))))))
1186                                 (ordinary pattern))))
1187           (bound (lambda (pattern)
1188                    (letrec ((pred-bodies '())
1189                             (bound (lambda (p a k)
1190                                      (cond
1191                                        ((eq? '_ p) (k p a))
1192                                        ((symbol? p) (if (memq p a)
1193                                                         (##match#syntax-err
1194                                                           pattern
1195                                                           "duplicate variable in pattern"))
1196                                         (k p (cons p a)))
1197                                        ((and (pair? p)
1198                                              (eq? 'quote (car p))) (k p a))
1199                                        ((and (pair? p) (eq? '? (car p))) (cond
1200                                                                            ((not (null?
1201                                                                                    (cddr p))) (bound
1202                                                                                                 `(and (? ,(cadr p))
1203                                                                                                       ,@(cddr p))
1204                                                                                                 a
1205                                                                                                 k))
1206                                                                            ((or (not (symbol?
1207                                                                                        (cadr p)))
1208                                                                                 (memq (cadr p)
1209                                                                                       a)) (let ((g (gensym)))
1210                                                                                             (set! pred-bodies
1211                                                                                               (cons `(,g ,(cadr p))
1212                                                                                                     pred-bodies))
1213                                                                                             (k `(? ,g)
1214                                                                                                a)))
1215                                                                            (else (k p
1216                                                                                     a))))
1217                                        ((and (pair? p) (eq? '= (car p))) (cond
1218                                                                            ((or (not (symbol?
1219                                                                                        (cadr p)))
1220                                                                                 (memq (cadr p)
1221                                                                                       a)) (let ((g (gensym)))
1222                                                                                             (set! pred-bodies
1223                                                                                               (cons `(,g ,(cadr p))
1224                                                                                                     pred-bodies))
1225                                                                                             (bound
1226                                                                                               `(= ,g
1227                                                                                                   ,(caddr
1228                                                                                                      p))
1229                                                                                               a
1230                                                                                               k)))
1231                                                                            (else (bound
1232                                                                                    (caddr
1233                                                                                      p)
1234                                                                                    a
1235                                                                                    (lambda (p2
1236                                                                                             a)
1237                                                                                      (k `(= ,(cadr p)
1238                                                                                             ,p2)
1239                                                                                         a))))))
1240                                        ((and (pair? p) (eq? 'and (car p))) (bound*
1241                                                                              (cdr p)
1242                                                                              a
1243                                                                              (lambda (p
1244                                                                                       a)
1245                                                                                (k `(and ,@p)
1246                                                                                   a))))
1247                                        ((and (pair? p) (eq? 'or (car p))) (bound
1248                                                                             (cadr p)
1249                                                                             a
1250                                                                             (lambda (first-p
1251                                                                                      first-a)
1252                                                                               (let or* ((plist (cddr p))
1253                                                                                         (k (lambda (plist)
1254                                                                                              (k `(or ,first-p
1255                                                                                                      ,@plist)
1256                                                                                                 first-a))))
1257                                                                                 (if (null?
1258                                                                                       plist)
1259                                                                                     (k plist)
1260                                                                                     (bound
1261                                                                                       (car plist)
1262                                                                                       a
1263                                                                                       (lambda (car-p
1264                                                                                                car-a)
1265                                                                                         (if (not (permutation
1266                                                                                                    car-a
1267                                                                                                    first-a))
1268                                                                                             (##match#syntax-err
1269                                                                                               pattern
1270                                                                                               "variables of or-pattern differ in"))
1271                                                                                         (or* (cdr plist)
1272                                                                                              (lambda (cdr-p)
1273                                                                                                (k (cons car-p
1274                                                                                                         cdr-p)))))))))))
1275                                        ((and (pair? p) (eq? 'not (car p))) (cond
1276                                                                              ((not (null?
1277                                                                                      (cddr p))) (bound
1278                                                                                                   `(not (or ,@(cdr p)))
1279                                                                                                   a
1280                                                                                                   k))
1281                                                                              (else (bound
1282                                                                                      (cadr p)
1283                                                                                      a
1284                                                                                      (lambda (p2
1285                                                                                               a2)
1286                                                                                        (if (not (permutation
1287                                                                                                   a
1288                                                                                                   a2))
1289                                                                                            (##match#syntax-err
1290                                                                                              p
1291                                                                                              "no variables allowed in"))
1292                                                                                        (k `(not ,p2)
1293                                                                                           a))))))
1294                                        ((and (pair? p)
1295                                              (pair? (cdr p))
1296                                              (dot-dot-k? (cadr p))) (bound
1297                                                                       (car p)
1298                                                                       a
1299                                                                       (lambda (q
1300                                                                                b)
1301                                                                         (let ((bvars (find-prefix
1302                                                                                        b
1303                                                                                        a)))
1304                                                                           (k `(,q ,(cadr p)
1305                                                                                   ,bvars
1306                                                                                   ,(gensym)
1307                                                                                   ,(gensym)
1308                                                                                   ,(map (lambda (_)
1309                                                                                           (gensym))
1310                                                                                         bvars))
1311                                                                              b)))))
1312                                        ((and (pair? p) (eq? '$ (car p))) (bound*
1313                                                                            (cddr p)
1314                                                                            a
1315                                                                            (lambda (p1
1316                                                                                     a)
1317                                                                              (k `($ ,(cadr p)
1318                                                                                     ,@p1)
1319                                                                                 a))))
1320                                        ((and (pair? p)
1321                                              (eq? 'set! (car p))) (if (memq (cadr p)
1322                                                                             a)
1323                                                                       (k p
1324                                                                          a)
1325                                                                       (k p
1326                                                                          (cons (cadr p)
1327                                                                                a))))
1328                                        ((and (pair? p)
1329                                              (eq? 'get! (car p))) (if (memq (cadr p)
1330                                                                             a)
1331                                                                       (k p
1332                                                                          a)
1333                                                                       (k p
1334                                                                          (cons (cadr p)
1335                                                                                a))))
1336                                        ((pair? p) (bound
1337                                                     (car p)
1338                                                     a
1339                                                     (lambda (car-p a)
1340                                                       (bound
1341                                                         (cdr p)
1342                                                         a
1343                                                         (lambda (cdr-p a)
1344                                                           (k (cons car-p
1345                                                                    cdr-p)
1346                                                              a))))))
1347                                        ((vector? p) (boundv
1348                                                       (vector->list p)
1349                                                       a
1350                                                       (lambda (pl a)
1351                                                         (k (list->vector
1352                                                              pl)
1353                                                            a))))
1354                                        (else (k p a)))))
1355                             (boundv (lambda (plist a k)
1356                                       (let ((g115 (lambda () (k plist a))))
1357                                         (if (pair? plist)
1358                                             (if (and (pair? (cdr plist))
1359                                                      (dot-dot-k?
1360                                                        (cadr plist))
1361                                                      (null? (cddr plist)))
1362                                                 ((lambda ()
1363                                                    (bound plist a k)))
1364                                                 (if (null? plist)
1365                                                     (g115)
1366                                                     ((lambda (x y)
1367                                                        (bound
1368                                                          x
1369                                                          a
1370                                                          (lambda (car-p a)
1371                                                            (boundv
1372                                                              y
1373                                                              a
1374                                                              (lambda (cdr-p
1375                                                                       a)
1376                                                                (k (cons car-p
1377                                                                         cdr-p)
1378                                                                   a))))))
1379                                                      (car plist)
1380                                                      (cdr plist))))
1381                                             (if (null? plist)
1382                                                 (g115)
1383                                                 (##sys#match-error plist))))))
1384                             (bound* (lambda (plist a k)
1385                                       (if (null? plist)
1386                                           (k plist a)
1387                                           (bound
1388                                             (car plist)
1389                                             a
1390                                             (lambda (car-p a)
1391                                               (bound*
1392                                                 (cdr plist)
1393                                                 a
1394                                                 (lambda (cdr-p a)
1395                                                   (k (cons car-p cdr-p)
1396                                                      a))))))))
1397                             (find-prefix (lambda (b a)
1398                                            (if (eq? b a)
1399                                                '()
1400                                                (cons (car b)
1401                                                      (find-prefix
1402                                                        (cdr b)
1403                                                        a)))))
1404                             (permutation (lambda (p1 p2)
1405                                            (and (= (length p1)
1406                                                    (length p2))
1407                                                 (every
1408                                                   (lambda (x1)
1409                                                     (memq x1 p2))
1410                                                   p1)))))
1411                      (bound
1412                        pattern
1413                        '()
1414                        (lambda (p a) (list p (reverse a) pred-bodies))))))
1415           (inline-let (lambda (let-exp)
1416                         (letrec ((occ (lambda (x e)
1417                                         (let loop ((e e))
1418                                           (cond
1419                                             ((pair? e) (+ (loop (car e))
1420                                                           (loop (cdr e))))
1421                                             ((eq? x e) 1)
1422                                             (else 0)))))
1423                                  (subst (lambda (e old new)
1424                                           (let loop ((e e))
1425                                             (cond
1426                                               ((pair? e) (cons (loop (car e))
1427                                                                (loop (cdr e))))
1428                                               ((eq? old e) new)
1429                                               (else e)))))
1430                                  (const? (lambda (sexp)
1431                                            (or (symbol? sexp)
1432                                                (boolean? sexp)
1433                                                (string? sexp)
1434                                                (char? sexp)
1435                                                (number? sexp)
1436                                                (null? sexp)
1437                                                (and (pair? sexp)
1438                                                     (eq? (car sexp)
1439                                                          'quote)
1440                                                     (pair? (cdr sexp))
1441                                                     (symbol? (cadr sexp))
1442                                                     (null? (cddr sexp))))))
1443                                  (isval? (lambda (sexp)
1444                                            (or (const? sexp)
1445                                                (and (pair? sexp)
1446                                                     (memq (car sexp)
1447                                                           '(lambda quote
1448                                                              match-lambda
1449                                                              match-lambda*))))))
1450                                  (small? (lambda (sexp)
1451                                            (or (const? sexp)
1452                                                (and (pair? sexp)
1453                                                     (eq? (car sexp)
1454                                                          'lambda)
1455                                                     (pair? (cdr sexp))
1456                                                     (pair? (cddr sexp))
1457                                                     (const? (caddr sexp))
1458                                                     (null?
1459                                                       (cdddr sexp)))))))
1460                           (let loop ((b (cadr let-exp))
1461                                      (new-b '())
1462                                      (e (caddr let-exp)))
1463                             (cond
1464                               ((null? b) (if (null? new-b)
1465                                              e
1466                                              `(let ,(reverse new-b) ,e)))
1467                               ((isval? (cadr (car b))) (let* ((x (caar b))
1468                                                               (n (occ x e)))
1469                                                          (cond
1470                                                            ((= 0 n) (loop (cdr b)
1471                                                                           new-b
1472                                                                           e))
1473                                                            ((or (= 1 n)
1474                                                                 (small?
1475                                                                   (cadr (car b)))) (loop (cdr b)
1476                                                                                          new-b
1477                                                                                          (subst
1478                                                                                            e
1479                                                                                            x
1480                                                                                            (cadr (car b)))))
1481                                                            (else (loop (cdr b)
1482                                                                        (cons (car b)
1483                                                                              new-b)
1484                                                                        e)))))
1485                               (else (loop (cdr b) (cons (car b) new-b) e)))))))
1486           (gen (lambda (x sf plist erract length>= eta)
1487                  (if (null? plist)
1488                      (erract x)
1489                      (let* ((v '())
1490                             (val (lambda (x) (cdr (assq x v))))
1491                             (fail (lambda (sf)
1492                                     (gen x
1493                                          sf
1494                                          (cdr plist)
1495                                          erract
1496                                          length>=
1497                                          eta)))
1498                             (success (lambda (sf)
1499                                        (set-car! (cddddr (car plist)) #t)
1500                                        (let* ((code (cadr (car plist)))
1501                                               (bv (caddr (car plist)))
1502                                               (fail-sym (cadddr
1503                                                           (car plist))))
1504                                          (if fail-sym
1505                                              (let ((ap `(,code
1506                                                           ,fail-sym
1507                                                           ,@(map val bv))))
1508                                                `(call-with-current-continuation
1509                                                   (lambda (,fail-sym)
1510                                                     (let ((,fail-sym (lambda ()
1511                                                                        (,fail-sym
1512                                                                          ,(fail sf)))))
1513                                                       ,ap))))
1514                                              `(,code ,@(map val bv)))))))
1515                        (let next ((p (caar plist))
1516                                   (e x)
1517                                   (sf sf)
1518                                   (kf fail)
1519                                   (ks success))
1520                          (cond
1521                            ((eq? '_ p) (ks sf))
1522                            ((symbol? p) (set! v (cons (cons p e) v))
1523                             (ks sf))
1524                            ((null? p) (emit `(null? ,e) sf kf ks))
1525                            ((equal? p ''()) (emit `(null? ,e) sf kf ks))
1526                            ((string? p) (emit `(equal? ,e ,p) sf kf ks))
1527                            ((boolean? p) (emit `(equal? ,e ,p) sf kf ks))
1528                            ((char? p) (emit `(equal? ,e ,p) sf kf ks))
1529                            ((number? p) (emit `(equal? ,e ,p) sf kf ks))
1530                            ((and (pair? p) (eq? 'quote (car p))) (emit `(equal?
1531                                                                           ,e
1532                                                                           ,p)
1533                                                                        sf
1534                                                                        kf
1535                                                                        ks))
1536                            ((and (pair? p) (eq? '? (car p))) (let ((tst `(,(cadr p)
1537                                                                            ,e)))
1538                                                                (emit tst
1539                                                                      sf
1540                                                                      kf
1541                                                                      ks)))
1542                            ((and (pair? p) (eq? '= (car p))) (next (caddr
1543                                                                      p)
1544                                                                    `(,(cadr p)
1545                                                                       ,e)
1546                                                                    sf
1547                                                                    kf
1548                                                                    ks))
1549                            ((and (pair? p) (eq? 'and (car p))) (let loop ((p (cdr p))
1550                                                                           (sf sf))
1551                                                                  (if (null?
1552                                                                        p)
1553                                                                      (ks sf)
1554                                                                      (next (car p)
1555                                                                            e
1556                                                                            sf
1557                                                                            kf
1558                                                                            (lambda (sf)
1559                                                                              (loop (cdr p)
1560                                                                                    sf))))))
1561                            ((and (pair? p) (eq? 'or (car p))) (let ((or-v v))
1562                                                                 (let loop ((p (cdr p))
1563                                                                            (sf sf))
1564                                                                   (if (null?
1565                                                                         p)
1566                                                                       (kf sf)
1567                                                                       (begin (set! v
1568                                                                                or-v)
1569                                                                              (next (car p)
1570                                                                                    e
1571                                                                                    sf
1572                                                                                    (lambda (sf)
1573                                                                                      (loop (cdr p)
1574                                                                                            sf))
1575                                                                                    ks))))))
1576                            ((and (pair? p) (eq? 'not (car p))) (next (cadr p)
1577                                                                      e
1578                                                                      sf
1579                                                                      ks
1580                                                                      kf))
1581                            ((and (pair? p) (eq? '$ (car p))) (let* ((tag (cadr p))
1582                                                                     (fields (cdr p))
1583                                                                     (rlen (length
1584                                                                             fields))
1585                                                                     (tst `(,(symbol-append
1586                                                                               tag
1587                                                                               '?)
1588                                                                             ,e)))
1589                                                                (emit tst
1590                                                                      sf
1591                                                                      kf
1592                                                                      (let rloop ((n 1))
1593                                                                        (lambda (sf)
1594                                                                          (if (= n
1595                                                                                 rlen)
1596                                                                              (ks sf)
1597                                                                              (next (list-ref
1598                                                                                      fields
1599                                                                                      n)
1600                                                                                    `(##sys#block-ref ,e ,n)
1601                                                                                    sf
1602                                                                                    kf
1603                                                                                    (rloop
1604                                                                                      (+ 1
1605                                                                                         n)))))))))
1606                            ((and (pair? p) (eq? 'set! (car p))) (set! v
1607                                                                   (cons (cons (cadr p)
1608                                                                               (setter
1609                                                                                 e
1610                                                                                 p))
1611                                                                         v))
1612                             (ks sf))
1613                            ((and (pair? p) (eq? 'get! (car p))) (set! v
1614                                                                   (cons (cons (cadr p)
1615                                                                               (getter
1616                                                                                 e
1617                                                                                 p))
1618                                                                         v))
1619                             (ks sf))
1620                            ((and (pair? p)
1621                                  (pair? (cdr p))
1622                                  (dot-dot-k? (cadr p))) (emit `(list? ,e)
1623                                                               sf
1624                                                               kf
1625                                                               (lambda (sf)
1626                                                                 (let* ((k (dot-dot-k?
1627                                                                             (cadr p)))
1628                                                                        (ks (lambda (sf)
1629                                                                              (let ((bound (list-ref
1630                                                                                             p
1631                                                                                             2)))
1632                                                                                (cond
1633                                                                                  ((eq? (car p)
1634                                                                                        '_) (ks sf))
1635                                                                                  ((null?
1636                                                                                     bound) (let* ((ptst (next (car p)
1637                                                                                                               eta
1638                                                                                                               sf
1639                                                                                                               (lambda (sf)
1640                                                                                                                 #f)
1641                                                                                                               (lambda (sf)
1642                                                                                                                 #t)))
1643                                                                                                   (tst (if (and (pair?
1644                                                                                                                   ptst)
1645                                                                                                                 (symbol?
1646                                                                                                                   (car ptst))
1647                                                                                                                 (pair?
1648                                                                                                                   (cdr ptst))
1649                                                                                                                 (eq? eta
1650                                                                                                                      (cadr ptst))
1651                                                                                                                 (null?
1652                                                                                                                   (cddr ptst)))
1653                                                                                                            (car ptst)
1654                                                                                                            `(lambda (,eta)
1655                                                                                                               ,ptst))))
1656                                                                                              (assm `(every
1657                                                                                                       ,tst
1658                                                                                                       ,e)
1659                                                                                                    (kf sf)
1660                                                                                                    (ks sf))))
1661                                                                                  ((and (symbol?
1662                                                                                          (car p))
1663                                                                                        (equal?
1664                                                                                          (list (car p))
1665                                                                                          bound)) (next (car p)
1666                                                                                                        e
1667                                                                                                        sf
1668                                                                                                        kf
1669                                                                                                        ks))
1670                                                                                  (else (let* ((gloop (list-ref
1671                                                                                                        p
1672                                                                                                        3))
1673                                                                                               (ge (list-ref
1674                                                                                                     p
1675                                                                                                     4))
1676                                                                                               (fresh (list-ref
1677                                                                                                        p
1678                                                                                                        5))
1679                                                                                               (p1 (next (car p)
1680                                                                                                         `(car ,ge)
1681                                                                                                         sf
1682                                                                                                         kf
1683                                                                                                         (lambda (sf)
1684                                                                                                           `(,gloop
1685                                                                                                              (cdr ,ge)
1686                                                                                                              ,@(map (lambda (b
1687                                                                                                                              f)
1688                                                                                                                       `(cons ,(val b)
1689                                                                                                                              ,f))
1690                                                                                                                     bound
1691                                                                                                                     fresh))))))
1692                                                                                          (set! v
1693                                                                                            (append
1694                                                                                              (map cons
1695                                                                                                   bound
1696                                                                                                   (map (lambda (x)
1697                                                                                                          `(reverse
1698                                                                                                             ,x))
1699                                                                                                        fresh))
1700                                                                                              v))
1701                                                                                          `(let ,gloop
1702                                                                                             ((,ge ,e)
1703                                                                                              ,@(map (lambda (x)
1704                                                                                                       `(,x '()))
1705                                                                                                     fresh))
1706                                                                                             (if (null?
1707                                                                                                   ,ge)
1708                                                                                                 ,(ks sf)
1709                                                                                                 ,p1)))))))))
1710                                                                   (case k
1711                                                                     ((0) (ks sf))
1712                                                                     ((1) (emit `(pair?
1713                                                                                   ,e)
1714                                                                                sf
1715                                                                                kf
1716                                                                                ks))
1717                                                                     (else (emit `((,length>=
1718                                                                                     ,k)
1719                                                                                   ,e)
1720                                                                                 sf
1721                                                                                 kf
1722                                                                                 ks)))))))
1723                            ((pair? p) (emit `(pair? ,e)
1724                                             sf
1725                                             kf
1726                                             (lambda (sf)
1727                                               (next (car p)
1728                                                     (add-a e)
1729                                                     sf
1730                                                     kf
1731                                                     (lambda (sf)
1732                                                       (next (cdr p)
1733                                                             (add-d e)
1734                                                             sf
1735                                                             kf
1736                                                             ks))))))
1737                            ((and (vector? p)
1738                                  (>= (vector-length p) 6)
1739                                  (dot-dot-k?
1740                                    (vector-ref
1741                                      p
1742                                      (- (vector-length p) 5)))) (let* ((vlen (- (vector-length
1743                                                                                   p)
1744                                                                                 6))
1745                                                                        (k (dot-dot-k?
1746                                                                             (vector-ref
1747                                                                               p
1748                                                                               (+ vlen
1749                                                                                  1))))
1750                                                                        (minlen (+ vlen
1751                                                                                   k))
1752                                                                        (bound (vector-ref
1753                                                                                 p
1754                                                                                 (+ vlen
1755                                                                                    2))))
1756                                                                   (emit `(vector?
1757                                                                            ,e)
1758                                                                         sf
1759                                                                         kf
1760                                                                         (lambda (sf)
1761                                                                           (assm `(>= (vector-length
1762                                                                                        ,e)
1763                                                                                      ,minlen)
1764                                                                                 (kf sf)
1765                                                                                 ((let vloop ((n 0))
1766                                                                                    (lambda (sf)
1767                                                                                      (cond
1768                                                                                        ((not (= n
1769                                                                                                 vlen)) (next (vector-ref
1770                                                                                                                p
1771                                                                                                                n)
1772                                                                                                              `(vector-ref
1773                                                                                                                 ,e
1774                                                                                                                 ,n)
1775                                                                                                              sf
1776                                                                                                              kf
1777                                                                                                              (vloop
1778                                                                                                                (+ 1
1779                                                                                                                   n))))
1780                                                                                        ((eq? (vector-ref
1781                                                                                                p
1782                                                                                                vlen)
1783                                                                                              '_) (ks sf))
1784                                                                                        (else (let* ((gloop (vector-ref
1785                                                                                                              p
1786                                                                                                              (+ vlen
1787                                                                                                                 3)))
1788                                                                                                     (ind (vector-ref
1789                                                                                                            p
1790                                                                                                            (+ vlen
1791                                                                                                               4)))
1792                                                                                                     (fresh (vector-ref
1793                                                                                                              p
1794                                                                                                              (+ vlen
1795                                                                                                                 5)))
1796                                                                                                     (p1 (next (vector-ref
1797                                                                                                                 p
1798                                                                                                                 vlen)
1799                                                                                                               `(vector-ref
1800                                                                                                                  ,e
1801                                                                                                                  ,ind)
1802                                                                                                               sf
1803                                                                                                               kf
1804                                                                                                               (lambda (sf)
1805                                                                                                                 `(,gloop
1806                                                                                                                    (- ,ind
1807                                                                                                                       1)
1808                                                                                                                    ,@(map (lambda (b
1809                                                                                                                                    f)
1810                                                                                                                             `(cons ,(val b)
1811                                                                                                                                    ,f))
1812                                                                                                                           bound
1813                                                                                                                           fresh))))))
1814                                                                                                (set! v
1815                                                                                                  (append
1816                                                                                                    (map cons
1817                                                                                                         bound
1818                                                                                                         fresh)
1819                                                                                                    v))
1820                                                                                                `(let ,gloop
1821                                                                                                   ((,ind (- (vector-length
1822                                                                                                               ,e)
1823                                                                                                             1))
1824                                                                                                    ,@(map (lambda (x)
1825                                                                                                             `(,x '()))
1826                                                                                                           fresh))
1827                                                                                                   (if (> ,minlen
1828                                                                                                          ,ind)
1829                                                                                                       ,(ks sf)
1830                                                                                                       ,p1)))))))
1831                                                                                  sf))))))
1832                            ((vector? p) (let ((vlen (vector-length p)))
1833                                           (emit `(vector? ,e)
1834                                                 sf
1835                                                 kf
1836                                                 (lambda (sf)
1837                                                   (emit `(equal?
1838                                                            (vector-length
1839                                                              ,e)
1840                                                            ,vlen)
1841                                                         sf
1842                                                         kf
1843                                                         (let vloop ((n 0))
1844                                                           (lambda (sf)
1845                                                             (if (= n vlen)
1846                                                                 (ks sf)
1847                                                                 (next (vector-ref
1848                                                                         p
1849                                                                         n)
1850                                                                       `(vector-ref
1851                                                                          ,e
1852                                                                          ,n)
1853                                                                       sf
1854                                                                       kf
1855                                                                       (vloop
1856                                                                         (+ 1
1857                                                                            n)))))))))))
1858                            (else (display
1859                                    "FATAL ERROR IN PATTERN MATCHER")
1860                             (newline)
1861                             (##sys#error #f "THIS NEVER HAPPENS"))))))))
1862           (emit (lambda (tst sf kf ks)
1863                   (cond
1864                     ((in tst sf) (ks sf))
1865                     ((in `(not ,tst) sf) (kf sf))
1866                     (else (let* ((e (cadr tst))
1867                                  (implied (cond
1868                                             ((eq? (car tst) 'equal?) (let ((p (caddr
1869                                                                                 tst)))
1870                                                                        (cond
1871                                                                          ((string?
1872                                                                             p) `((string?
1873                                                                                    ,e)))
1874                                                                          ((boolean?
1875                                                                             p) `((boolean?
1876                                                                                    ,e)))
1877                                                                          ((char?
1878                                                                             p) `((char?
1879                                                                                    ,e)))
1880                                                                          ((number?
1881                                                                             p) `((number?
1882                                                                                    ,e)))
1883                                                                          ((and (pair?
1884                                                                                  p)
1885                                                                                (eq? 'quote
1886                                                                                     (car p))) `((symbol?
1887                                                                                                   ,e)))
1888                                                                          (else '()))))
1889                                             ((eq? (car tst) 'null?) `((list?
1890                                                                         ,e)))
1891                                             (else '())))
1892                                  (not-imp (case (car tst)
1893                                             ((list?) `((not (null? ,e))))
1894                                             (else '())))
1895                                  (s (ks (cons tst (append implied sf))))
1896                                  (k (kf (cons `(not ,tst)
1897                                               (append not-imp sf)))))
1898                             (assm tst k s))))))
1899           (assm (lambda (tst f s)
1900                   (cond
1901                     ((equal? s f) s)
1902                     ((and (eq? s #t) (eq? f #f)) tst)
1903                     ((and (eq? (car tst) 'pair?)
1904                           (memq ##match#error-control '(#:unspecified #:fail))
1905                           (memq (car f) '(cond ##sys#match-error))
1906                           (guarantees s (cadr tst))) s)
1907                     ((and (pair? s)
1908                           (eq? (car s) 'if)
1909                           (equal? (cadddr s) f)) (if (eq? (car (cadr s))
1910                                                           'and)
1911                                                      `(if (and ,tst
1912                                                                ,@(cdr (cadr s)))
1913                                                           ,(caddr s)
1914                                                           ,f)
1915                                                      `(if (and ,tst
1916                                                                ,(cadr s))
1917                                                           ,(caddr s)
1918                                                           ,f)))
1919                     ((and (pair? s)
1920                           (equal? (car s) 'call-with-current-continuation)
1921                           (pair? (cdr s))
1922                           (pair? (cadr s))
1923                           (equal? (caadr s) 'lambda)
1924                           (pair? (cdadr s))
1925                           (pair? (cadadr s))
1926                           (null? (cdr (cadadr s)))
1927                           (pair? (cddadr s))
1928                           (pair? (car (cddadr s)))
1929                           (equal? (caar (cddadr s)) 'let)
1930                           (pair? (cdar (cddadr s)))
1931                           (pair? (cadar (cddadr s)))
1932                           (pair? (caadar (cddadr s)))
1933                           (pair? (cdr (caadar (cddadr s))))
1934                           (pair? (cadr (caadar (cddadr s))))
1935                           (equal? (caadr (caadar (cddadr s))) 'lambda)
1936                           (pair? (cdadr (caadar (cddadr s))))
1937                           (null? (cadadr (caadar (cddadr s))))
1938                           (pair? (cddadr (caadar (cddadr s))))
1939                           (pair? (car (cddadr (caadar (cddadr s)))))
1940                           (pair? (cdar (cddadr (caadar (cddadr s)))))
1941                           (null? (cddar (cddadr (caadar (cddadr s)))))
1942                           (null? (cdr (cddadr (caadar (cddadr s)))))
1943                           (null? (cddr (caadar (cddadr s))))
1944                           (null? (cdadar (cddadr s)))
1945                           (pair? (cddar (cddadr s)))
1946                           (null? (cdddar (cddadr s)))
1947                           (null? (cdr (cddadr s)))
1948                           (null? (cddr s))
1949                           (equal? f (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr
1950                                                                                            s)))
1951                                                                                  (fail (car (caadar
1952                                                                                               (cddadr
1953                                                                                                 s))))
1954                                                                                  (s2 (caddar
1955                                                                                        (cddadr
1956                                                                                          s))))
1957                                                                              `(call-with-current-continuation
1958                                                                                 (lambda (,k)
1959                                                                                   (let ((,fail (lambda ()
1960                                                                                                  (,k ,f))))
1961                                                                                     ,(assm tst
1962                                                                                            `(,fail)
1963                                                                                            s2))))))
1964                     ((and #f
1965                           (pair? s)
1966                           (equal? (car s) 'let)
1967                           (pair? (cdr s))
1968                           (pair? (cadr s))
1969                           (pair? (caadr s))
1970                           (pair? (cdaadr s))
1971                           (pair? (car (cdaadr s)))
1972                           (equal? (caar (cdaadr s)) 'lambda)
1973                           (pair? (cdar (cdaadr s)))
1974                           (null? (cadar (cdaadr s)))
1975                           (pair? (cddar (cdaadr s)))
1976                           (null? (cdddar (cdaadr s)))
1977                           (null? (cdr (cdaadr s)))
1978                           (null? (cdadr s))
1979                           (pair? (cddr s))
1980                           (null? (cdddr s))
1981                           (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr
1982                                                                         s))
1983                                                                 (s2 (caddr
1984                                                                       s)))
1985                                                             `(let ((,fail (lambda ()
1986                                                                             ,f)))
1987                                                                ,(assm tst
1988                                                                       `(,fail)
1989                                                                       s2))))
1990                     (else `(if ,tst ,s ,f)))))
1991           (guarantees (lambda (code x)
1992                         (let ((a (add-a x)) (d (add-d x)))
1993                           (let loop ((code code))
1994                             (cond
1995                               ((not (pair? code)) #f)
1996                               ((memq (car code) '(cond ##sys#match-error)) #t)
1997                               ((or (equal? code a) (equal? code d)) #t)
1998                               ((eq? (car code) 'if) (or (loop (cadr code))
1999                                                         (and (loop (caddr
2000                                                                      code))
2001                                                              (loop (cadddr
2002                                                                      code)))))
2003                               ((eq? (car code) 'lambda) #f)
2004                               ((and (eq? (car code) 'let)
2005                                     (symbol? (cadr code))) #f)
2006                               (else (or (loop (car code))
2007                                         (loop (cdr code)))))))))
2008           (in (lambda (e l)
2009                 (or (member e l)
2010                     (and (eq? (car e) 'list?)
2011                          (or (member `(null? ,(cadr e)) l)
2012                              (member `(pair? ,(cadr e)) l)))
2013                     (and (eq? (car e) 'not)
2014                          (let* ((srch (cadr e))
2015                                 (const-class (equal-test? srch)))
2016                            (cond
2017                              (const-class (let mem ((l l))
2018                                             (if (null? l)
2019                                                 #f
2020                                                 (let ((x (car l)))
2021                                                   (or (and (equal?
2022                                                              (cadr x)
2023                                                              (cadr srch))
2024                                                            (disjoint? x)
2025                                                            (not (equal?
2026                                                                   const-class
2027                                                                   (car x))))
2028                                                       (equal?
2029                                                         x
2030                                                         `(not (,const-class
2031                                                                 ,(cadr srch))))
2032                                                       (and (equal?
2033                                                              (cadr x)
2034                                                              (cadr srch))
2035                                                            (equal-test? x)
2036                                                            (not (equal?
2037                                                                   (caddr
2038                                                                     srch)
2039                                                                   (caddr
2040                                                                     x))))
2041                                                       (mem (cdr l)))))))
2042                              ((disjoint? srch) (let mem ((l l))
2043                                                  (if (null? l)
2044                                                      #f
2045                                                      (let ((x (car l)))
2046                                                        (or (and (equal?
2047                                                                   (cadr x)
2048                                                                   (cadr srch))
2049                                                                 (disjoint?
2050                                                                   x)
2051                                                                 (not (equal?
2052                                                                        (car x)
2053                                                                        (car srch))))
2054                                                            (mem (cdr l)))))))
2055                              ((eq? (car srch) 'list?) (let mem ((l l))
2056                                                         (if (null? l)
2057                                                             #f
2058                                                             (let ((x (car l)))
2059                                                               (or (and (equal?
2060                                                                          (cadr x)
2061                                                                          (cadr srch))
2062                                                                        (disjoint?
2063                                                                          x)
2064                                                                        (not (memq (car x)
2065                                                                                   '(list?
2066                                                                                      pair?
2067                                                                                      null?))))
2068                                                                   (mem (cdr l)))))))
2069                              (else #f)))))))
2070           (equal-test? (lambda (tst)
2071                          (and (eq? (car tst) 'equal?)
2072                               (let ((p (caddr tst)))
2073                                 (cond
2074                                   ((string? p) 'string?)
2075                                   ((boolean? p) 'boolean?)
2076                                   ((char? p) 'char?)
2077                                   ((number? p) 'number?)
2078                                   ((and (pair? p)
2079                                         (pair? (cdr p))
2080                                         (null? (cddr p))
2081                                         (eq? 'quote (car p))
2082                                         (symbol? (cadr p))) 'symbol?)
2083                                   (else #f))))))
2084           (disjoint? (lambda (tst)
2085                        (memq (car tst) ##match#disjoint-predicates)))
2086           (add-a (lambda (a)
2087                    (let ((new (and (pair? a) (assq (car a) c---rs))))
2088                      (if new (cons (cadr new) (cdr a)) `(car ,a)))))
2089           (add-d (lambda (a)
2090                    (let ((new (and (pair? a) (assq (car a) c---rs))))
2091                      (if new (cons (cddr new) (cdr a)) `(cdr ,a)))))
2092           (c---rs '((car caar . cdar)
2093                     (cdr cadr . cddr)
2094                     (caar caaar . cdaar)
2095                     (cadr caadr . cdadr)
2096                     (cdar cadar . cddar)
2097                     (cddr caddr . cdddr)
2098                     (caaar caaaar . cdaaar)
2099                     (caadr caaadr . cdaadr)
2100                     (cadar caadar . cdadar)
2101                     (caddr caaddr . cdaddr)
2102                     (cdaar cadaar . cddaar)
2103                     (cdadr cadadr . cddadr)
2104                     (cddar caddar . cdddar)
2105                     (cdddr cadddr . cddddr)))
2106           (setter (lambda (e p)
2107                     (let ((mk-setter (lambda (s)
2108                                        (symbol-append 'set- s '!))))
2109                       (cond
2110                         ((not (pair? e)) (##match#syntax-err
2111                                            p
2112                                            "unnested set! pattern"))
2113                         ((eq? (car e) 'vector-ref) `(let ((x ,(cadr e)))
2114                                                       (lambda (y)
2115                                                         (vector-set!
2116                                                           x
2117                                                           ,(caddr e)
2118                                                           y))))
2119                         ((eq? (car e) 'unbox) `(let ((x ,(cadr e)))
2120                                                  (lambda (y)
2121                                                    (set-box! x y))))
2122                         ((eq? (car e) 'car) `(let ((x ,(cadr e)))
2123                                                (lambda (y)
2124                                                  (set-car! x y))))
2125                         ((eq? (car e) 'cdr) `(let ((x ,(cadr e)))
2126                                                (lambda (y)
2127                                                  (set-cdr! x y))))
2128                         ((eq? (car e) '##sys#block-ref)
2129                          `(let ((x ,(cadr e)))
2130                             (lambda (y) 
2131                               (##sys#block-set! x ,(caddr e) y) ) ) )
2132                         ((let ((a (assq (car e) get-c---rs)))
2133                            (and a
2134                                 `(let ((x (,(cadr a) ,(cadr e))))
2135                                    (lambda (y)
2136                                      (,(mk-setter (cddr a)) x y))))))
2137                         (else `(let ((x ,(cadr e)))
2138                                  (lambda (y) (,(mk-setter (car e)) x y))))))))
2139           (getter (lambda (e p)
2140                     (cond
2141                       ((not (pair? e)) (##match#syntax-err
2142                                          p
2143                                          "unnested get! pattern"))
2144                       ((eq? (car e) 'vector-ref) `(let ((x ,(cadr e)))
2145                                                     (lambda ()
2146                                                       (vector-ref
2147                                                         x
2148                                                         ,(caddr e)))))
2149                       ((eq? (car e) 'unbox) `(let ((x ,(cadr e)))
2150                                                (lambda () (unbox x))))
2151                       ((eq? (car e) 'car) `(let ((x ,(cadr e)))
2152                                              (lambda () (car x))))
2153                       ((eq? (car e) 'cdr) `(let ((x ,(cadr e)))
2154                                              (lambda () (cdr x))))
2155                       ((eq? (car e) '##sys#block-ref)
2156                        `(let ((x ,(cadr e)))
2157                           (lambda () (##sys#block-ref x ,(caddr e))) ) )
2158                       ((let ((a (assq (car e) get-c---rs)))
2159                          (and a
2160                               `(let ((x (,(cadr a) ,(cadr e))))
2161                                  (lambda () (,(cddr a) x))))))
2162                       (else `(let ((x ,(cadr e)))
2163                                (lambda () (,(car e) x)))))))
2164           (get-c---rs '((caar car . car)
2165                         (cadr cdr . car)
2166                         (cdar car . cdr)
2167                         (cddr cdr . cdr)
2168                         (caaar caar . car)
2169                         (caadr cadr . car)
2170                         (cadar cdar . car)
2171                         (caddr cddr . car)
2172                         (cdaar caar . cdr)
2173                         (cdadr cadr . cdr)
2174                         (cddar cdar . cdr)
2175                         (cdddr cddr . cdr)
2176                         (caaaar caaar . car)
2177                         (caaadr caadr . car)
2178                         (caadar cadar . car)
2179                         (caaddr caddr . car)
2180                         (cadaar cdaar . car)
2181                         (cadadr cdadr . car)
2182                         (caddar cddar . car)
2183                         (cadddr cdddr . car)
2184                         (cdaaar caaar . cdr)
2185                         (cdaadr caadr . cdr)
2186                         (cdadar cadar . cdr)
2187                         (cdaddr caddr . cdr)
2188                         (cddaar cdaar . cdr)
2189                         (cddadr cdadr . cdr)
2190                         (cdddar cddar . cdr)
2191                         (cddddr cdddr . cdr)))
2192           (symbol-append (lambda l
2193                            (string->symbol
2194                              (apply
2195                                string-append
2196                                (map (lambda (x)
2197                                       (cond
2198                                         ((symbol? x) (symbol->string x))
2199                                         ((number? x) (number->string x))
2200                                         (else x)))
2201                                     l)))))
2202           (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l)))))
2203           (rdc (lambda (l)
2204                  (if (null? (cdr l)) '() (cons (car l) (rdc (cdr l)))))))
2205    (list genmatch genletrec gendefine pattern-var?)))
2206
2207(define (match-error-control . arg)
2208  (if (pair? arg)
2209      (##match#set-error-control (car arg))
2210      ##match#error-control) )
2211
2212(define (match-error-procedure . proc)
2213  (if (pair? proc)
2214    (##match#set-error (car proc))
2215    ##sys#match-error) )
2216
2217(register-feature! 'match)
Note: See TracBrowser for help on using the repository browser.