source: project/chicken/match.scm @ 1213

Last change on this file since 1213 was 1213, checked in by felix winkelmann, 13 years ago

removed old mailbox egg

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