turn off fastcall feature, add budy to unify.h
[gule-log:guile-log.git] / ice-9 / match-phd-lookup.scm
1 ;; 2010/05/20 - record matching for guile (Stefan Israelsson Tampe)
2 ;; Modifying upstream version (match.upstream.scm) by Alex Shinn
3 ;; 2010/08/29 - match abstractions and unquote added
4
5 (define-module (ice-9 match-phd-lookup)
6   #:use-module (srfi srfi-9)
7   #:use-module (srfi srfi-11)
8   #:export     (match-define match-let* match-let match-letrec match-lambda*
9                              match-lambda match make-phd-matcher))
10
11 (define (id x . l) x)
12
13
14 (define-syntax match
15   (syntax-rules (-abs -phd)
16     ((match s)
17      (match-syntax-error "missing match expression"))
18     ((match s atom)
19      (match-syntax-error "no match clauses"))
20
21     ((match s -abs abs -phd p . l)
22      (match* s (abs p) . l))
23     ((match s phd p -abs abs . l)
24      (match* s (abs p) . l))
25
26     ((match s -abs abs . l)
27      (match* s (abs ((car cdr pair? null? equal? id) ())) . l))
28
29     ((match s -phd p . l)
30      (match* s (() p) . l))
31
32     ((match s x . l)
33      (match* s (() ((car cdr pair? null? equal? id) ())) x . l))))
34
35 (define-syntax match*
36   (lambda (x)
37     (syntax-case x ()
38       ((q s . l) 
39        ;(pk `(match* ,(syntax->datum (syntax l))))
40        (syntax (match** s . l))))))
41
42 (define-syntax match+
43   (lambda (x)
44     (syntax-case x ()
45       ((_ s abs (arg ...) . l)
46        (with-syntax (((v ...) 
47                       (map (lambda (x) (datum->syntax x (gensym "v")))
48                            #'(arg ...))))         
49
50          #'(let ((v arg) ...)
51              (match-next abs s (v ...) (#f #f) . l)))))))
52
53 (define-syntax match**
54   (syntax-rules ()
55     ((match* s abs (#:args arg ...) . l) 
56      (match+ s abs (arg ...)  . l))
57
58
59     ((match* s abs (app ...) (pat . body) ...)
60      (let ((v (app ...)))
61        (match-next abs s v ((app ...) (set! (app ...))) (pat . body) ...)))
62     ((match* s abs #(vec ...) (pat . body) ...)
63      (let ((v #(vec ...)))
64        (match-next abs s v (v (set! v)) (pat . body) ...)))
65     ((match* s abs atom (pat . body) ...)
66      (let ((v atom))
67        (match-next abs s v (atom (set! atom)) (pat . body) ...)))
68     ))
69
70 (define-syntax match-next
71   (syntax-rules (=> ->)
72     ;; no more clauses, the match failed
73     ((match-next abs s v g+s)
74      (error 'match "no matching pattern"))
75
76     ;; named failure continuation
77     ((match-next abs s v g+s (pat (=> failure) . body) . rest)
78      (let ((failure (lambda () (match-next abs s v g+s . rest))))
79        ;; match-one analyzes the pattern for us
80        (match-one abs s v pat g+s (match-drop-ids (begin . body)) 
81                   (match-drop-ids (failure)) ())))
82
83     ((match-next abs s v g+s (pat (-> failure (f a ...)) . body) . rest)
84      (let ((failure (f a ... (match-next abs s v g+s . rest))))
85        ;; match-one analyzes the pattern for us
86        (match-one abs s v pat g+s (match-drop-ids (begin . body)) 
87                   (match-drop-ids (failure)) ())))
88
89     ((match-next abs s v g+s (pat (=> failure qq) . body) . rest)
90      (let ((failure (lambda () qq (match-next abs s v g+s . rest))))
91        ;; match-one analyzes the pattern for us
92        (match-one abs s v pat g+s (match-drop-ids (begin . body)) 
93                   (match-drop-ids (failure)) ())))
94
95     ;; anonymous failure continuation, give it a dummy name
96     ((match-next abs s v g+s (pat . body) . rest)
97      (match-next abs s v g+s (pat (=> failure) . body) . rest))))
98
99 (define-syntax match-one
100   (lambda (x)
101     (syntax-case x ()
102       ((q . l) 
103        ;(pk `(match-one ,(syntax->datum (syntax l))))
104        (syntax (match-one* . l))))))
105
106
107 (define-syntax abs-drop
108   (syntax-rules ()
109     ((_ a k        ) k)
110     ((_ a (k ...) v) (k ... v))))
111
112 (define-syntax match-one*
113   (syntax-rules ()
114     ;; If it's a list of two or more values, check to see if the
115     ;; second one is an ellipse and handle accordingly, otherwise go
116     ;; to MATCH-TWO.
117     ((match-one* abs s v (p q . r) g+s sk fk i)
118      (match-check-ellipse
119       q
120       (match-extract-vars abs p 
121                           (abs-drop (match-gen-ellipses 
122                                      abs s v p r  g+s sk fk i)) i ())
123       (match-two abs s v (p q . r) g+s sk fk i)))
124     ;; Go directly to MATCH-TWO.
125     ((match-one* . x)
126      (match-two . x))))
127
128 (define-syntax insert-abs
129   (lambda (x)
130     (syntax-case x ()
131       ((q . l) 
132        ;(pk `(insert-abs ,(syntax->datum (syntax l))))
133        (syntax (insert-abs* . l))))))
134
135
136 (define-syntax insert-abs*
137   (syntax-rules (begin)
138     ((insert-abs abs (begin . l)) (begin . l))
139     ((insert-abs abs (x))         (x))
140     ((insert-abs abs (n nn ...))  (n abs nn ...))))
141     
142 (define-syntax match-two
143   (lambda (x)
144     (syntax-case x ()
145       ((q . l) 
146        ;(pk `(match-two ,(syntax->datum (syntax l))))
147        (syntax (match-two* . l))))))
148   
149 (define-syntax match-two*
150   (syntax-rules (_ ___ *** <> arguments cond unquote unquote-splicing 
151                    quote quasiquote ? $ = and or not set! get!)
152
153     ((match-two (abs ((car cdr pair? null? equal? id) pp)) s v () 
154                 g+s (sk ...) fk i)
155      (let* ((s (null? v s)))
156        (if s
157            (insert-abs (abs ((car cdr pair? null? equal? id) pp)) (sk ... i))
158            (insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
159
160     ((match-two (abs ((car cdr pair? null? equal? id) pp)) s v (quote p) 
161                 g+s (sk ...) fk i)
162      (let ((s (equal? v 'p s)))
163        (if s
164            (insert-abs (abs ((car cdr pair? null? equal? id) pp)) (sk ... i))
165            (insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
166     
167     ;;Stis unquote logic
168     ((match-two (abs ((car cdr pair? null? equal? id) pp)) s v (unquote p)  
169                 g+s (sk ...) fk i)
170      (let ((s (equal? v p s)))
171        (if s
172            (insert-abs (abs ((car cdr pair? null? equal? id) pp)) (sk ... i))
173            (insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
174
175     ((match-two (abs ((ccar ccdr ppair? null? equal? id) rr)) s v 
176                 ((unquote-splicing p) . ps)  g+s sk fk i)
177      (let loop ((vv (id v s))
178                 (pp p))       
179        (if (pair? pp)
180            (let ((s (ppair? vv s)))
181              (if s
182                  (let ((s (equal? (ccar vv s) (car pp) s)))
183                    (if s
184                        (loop (id (ccdr vv s) s) (cdr pp))
185                        (insert-abs (abs ((ccar ccdr ppair? null? equal? id) 
186                                          rr)) fk)))
187                  (insert-abs (abs ((ccar ccdr ppair? null? equal? id) 
188                                    rr)) fk)))
189              
190            (match-one (abs ((ccar ccdr ppair? null? equal? id) rr)) 
191                       s vv ps g+s sk fk i))))
192
193     ((match-two abs s () (arguments) g+s (sk ...) fk i)
194      (insert-abs abs (sk ... i)))
195     
196     ((match-two abs s (a as ...) (arguments p ps ...) g+s sk fk i)
197      (let ((v a))
198        (match-two abs s v p g+s (match-one s (as ...) (arguments ps ...) 
199                                            g+s sk fk) fk i)))
200
201     ((match-two abs s v (quasiquote p) . x)
202      (match-quasiquote abs s v p . x))    
203     ((match-two abs s v (and) g+s (sk ...) fk i) (insert-abs abs (sk ... i)))
204     ((match-two abs s v (and p q ...) g+s sk fk i)
205      (match-one abs s v p g+s (match-one s v (and q ...) g+s sk fk) fk i))
206     ((match-two abs s v (or) g+s sk fk i) (insert-abs abs fk))
207     ((match-two abs s v (or p) . x)
208      (match-one abs s v p . x))
209     ((match-two abs s v (or p ...) g+s sk fk i)
210      (match-extract-vars abs (or p ...) 
211                          (abs-drop (match-gen-or abs s v (p ...) 
212                                                  g+s sk fk i)) i ()))
213
214     ((match-two abs s v (cond) g+s sk fk i) (insert-abs abs fk))
215     ((match-two abs s v (cond p) . x)
216      (match-one abs s v p . x))
217     ((match-two abs s v (cond p ps ...) g+s sk fk i)
218      (match-one abs s v p g+s sk (abs-drop (match-one abs s v (cond ps ...) 
219                                                       g+s sk fk i)) i))
220
221     ((match-two abs s v (not p) g+s (sk ...) (fk fkk ...) i)
222      (match-one abs s v p g+s (match-drop-ids (fk abs fkk ...)) (sk ... i) i))
223     ((match-two abs ss v (get! getter) (g s) (sk ...) fk i)
224      (let ((getter (lambda () g))) (insert-abs abs (sk ... i))))
225     ((match-two abs ss v (set! setter) (g (s ...)) (sk ...) fk i)
226      (let ((setter (lambda (x) (s ... x)))) (insert-abs abs (sk ... i))))
227     ((match-two abs s v (? pred . p) g+s sk fk i)
228      (if (pred (id v s)) 
229          (match-one abs s v (and . p) g+s sk fk i) (insert-abs abs fk)))
230     
231     ;; stis, added $ support!
232     ((match-two abs s v ($ n) g-s sk fk i)
233      (if (n v) 
234          (insert-abs abs sk)
235          (insert-abs abs fk)))
236     
237     ((match-two abs s v ($ nn p ...) g+s sk fk i)
238      (if (nn v)
239          (match-$ abs (and) 0 (p ...) s v sk fk i)
240          (insert-abs abs fk)))
241      
242     ;; stis, added the possibility to use set! and get to records    
243     ((match-two abs s v (= 0 m p) g+s sk fk i)
244      (let ((w  (struct-ref v m)))
245        (match-one abs s w p ((struct-ref v m) (struct-set! v m)) sk fk i)))
246
247     ((match-two abs ss v (= g s p) g+s sk fk i)
248      (let ((w (g v))) (match-one abs ss w p ((g v) (s v)) sk fk i)))
249
250     ((match-two abs s v (= proc p) g+s . x)
251      (let ((w (proc v))) (match-one abs s w p () . x)))
252
253     ((match-two abs s v ((<> f p) . l) g+s sk fk i)
254      (let ((res (f v)))
255        (if res
256            (match-one abs s (car res) p g+s 
257                       (match-one s (cdr res) l g+s sk fk)
258                       fk i)
259            (insert-abs abs fk))))
260
261     ((match-two abs s v (p ___ . r) g+s sk fk i)
262      (match-extract-vars abs p (abs-drop (match-gen-ellipses abs s v p r g+s sk fk i) i ())))
263     ((match-two (abs phd) s v p       g+s sk fk i)
264      (match-abstract () abs phd s v p g+s sk fk i))))
265
266 (define-syntax match-gen-or
267   (syntax-rules ()
268     ((_ abs s v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
269      (let ((sk2 (lambda (id ...) (insert-abs abs (sk ... (i ... id ...))))))
270        (match-gen-or-step abs s v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
271
272 (define-syntax match-gen-or-step
273   (syntax-rules ()
274     ((_ abs s v () g+s sk fk . x)
275      ;; no OR clauses, call the failure continuation
276      (insert-abs abs fk))
277     ((_ abs s v (p) . x)
278      ;; last (or only) OR clause, just expand normally
279      (match-one abs s v p . x))
280     ((_ abs s v (p . q) g+s sk fk i)
281      ;; match one and try the remaining on failure
282      (match-one abs s v p g+s sk (match-gen-or-step v q g+s sk fk i) i))
283     ))
284
285 (define-syntax match-three
286   (lambda (x)
287     (syntax-case x ()
288       ((q abs s w p g+s sk fk i)
289        (check-sym (syntax->datum (syntax p))) 
290        (syntax (match-three* abs s w p g+s sk fk i))))))
291
292 (define-syntax match-three*
293   (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
294     ((match-two (abs ((car cdr pair? null? id) rr)) s v (p) g+s sk fk i)
295      (let-values (((w cd s) (pair? v s)))
296        (if s
297            (let ((s (null? cd s)))
298              (if s
299                  (match-one (abs ((car cdr pair? null? id)  rr)) s w p 
300                             ((car w) 
301                              (set-car! w)) sk fk i)
302                  (insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk)))
303            (insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
304
305     ((match-two abs s v (p *** q) g+s sk fk i)
306      (match-extract-vars abs p (match-gen-search s v p q g+s sk fk i) i ()))
307
308     ((match-two abs s v (p *** . q) g+s sk fk i)
309      (match-syntax-error "invalid use of ***" (p *** . q)))
310
311     ((match-two (abs ((car cdr pair? null? equal? id) pp)) s v (p . q) 
312                 g+s sk fk i)
313      (let-values (((w x s) (pair? v s)))
314        (if s
315            (match-one (abs ((car cdr pair? null? equal? id) pp)) s w p 
316                       ((car ww) (set-car! ww))
317                       (match-one s x q ((cdr ww) (set-cdr! ww)) sk fk)
318                       fk
319                       i)
320            (insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
321
322     ((match-two abs s v #(p ...) g+s . x)
323      (match-vector abs s v 0 () (p ...) . x))
324
325     ((match-two abs s v _ g+s (sk ...) fk i) (insert-abs abs (sk ... i)))
326
327     ;; Not a pair or vector or special literal, test to see if it's a
328     ;; new symbol, in which case we just bind it, or if it's an
329     ;; already bound symbol or some other literal, in which case we
330     ;; compare it with EQUAL?.
331     ((match-two (abs ((car cdr pair? null? equal? iid) pp)) s v x 
332                 g+s (sk ...) fk (id ...))
333      (let-syntax
334          ((new-sym?
335            (syntax-rules (id ...)
336              ((new-sym? x sk2 fk2) sk2)
337              ((new-sym? y sk2 fk2) fk2))))
338        (new-sym? random-sym-to-match
339                  (let ((x v)) 
340                    (insert-abs (abs ((car cdr pair? null? equal? iid) pp)) 
341                                (sk ... (id ... x))))
342                  (let ((s (equal? v x s)))
343                    (if s
344                        (insert-abs (abs ((car cdr pair? null? equal? iid) pp)) 
345                                    (sk ... (id ...)))
346                        (insert-abs (abs ((car cdr pair? null? equal? iid) pp)) 
347                                    fk))))))))
348      
349
350 ;;warn agains miss spelled abstractions
351 (define (check-sym x)
352   (let ((f (lambda (x)
353              (let ((l (string->list (symbol->string x))))
354                (if (eq? (car l) #\<)
355                    (if (not (and (pair? (cdr l)) 
356                                  (eq? #\> (cadr l)) (null? (cddr l))))
357                        (let loop ((l l))
358                          (if (pair? l)
359                              (if (null? (cdr l))
360                                  (if (eq? (car l) #\>)
361                                      (warn (format #f
362                                                    "<> like variable that is not an abstraction e.g. ~a"
363                                                    x)))
364                                  (loop (cdr l)))))))))))
365     (if (symbol? x)
366         (f x)
367         (if (and (pair? x) (symbol? (car x)))
368             (f (car x))))))
369             
370
371          
372
373         
374     
375 (define-syntax match-abstract
376   (lambda (x)
377     (syntax-case x ()
378       ((q . l) 
379        ;(pk `(match-abstract ,(syntax->datum (syntax l))))
380        (syntax (match-abstract* . l))))))
381
382 (define-syntax match-abstract*
383   (lambda (x)
384     (syntax-case x ()
385       ((q x () phd         s  y p               . l)
386        (syntax (match-phd () phd x s y p . l)))
387                
388       ((q (x ...) ((a) us ...) phd s y ((b bs ...) . ps) g+s sk fk i)
389        (if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
390            (syntax (let ((ret ((a bs ...) y)))
391                      (if ret
392                          (match-one  (((a) us ... x ...) phd) s (cdr ret) ps g+s sk fk i)
393                          (insert-abs (((a) us ... x ...) phd) fk))))
394            (syntax (match-abstract ((a) x ...) (us ...) phd s y ((b bs ...) . ps) g+s sk fk i))))
395
396       ((q (x ...) ((a aa as ...) us ...) phd s y ((b  bs ...) . ps) g+s sk fk i)
397        (if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
398            (syntax (let ((ret ((a bs ...) y)))
399                      (if ret
400                          (let ((aa (car ret)))
401                            (match-one  (((a as ...) us ... x ...) phd) s (cdr ret) ps g+s sk fk (aa . i)))
402                          (insert-abs (((a as ...) us ... x ...) phd) fk))))
403            (syntax (match-abstract ((a aa as ...) x ...) (us ...) phd s y ((b bs ...) . ps) g+s sk fk i))))
404
405
406
407       ((q (x ...) ((a) us ...) phd s y (b . ps) g+s sk fk i)
408        (if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
409            (syntax (let ((ret (a y)))
410                      (if ret
411                          (match-one  (((a) us ... x ...) phd) s (cdr ret) ps g+s sk fk i)
412                          (insert-abs (((a) us ... x ...) phd) fk))))
413            (syntax (match-abstract ((a) x ...) (us ...) phd s y (b . ps) g+s sk fk i))))
414
415       ((q (x ...) ((a aa as ...) us ...) phd s y (b . ps) g+s sk fk i)
416        (if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
417            (syntax (let ((ret (a y)))
418                      (if ret
419                          (let ((aa  (car ret)))
420                            (match-one  (((a as ...) us ... x ...) phd) s (cdr ret) ps g+s sk fk (aa . i)))
421                          (insert-abs (((a as ...) us ... x ...) phd) fk))))
422            (syntax (match-abstract ((a aa as ...) x ...) (us ...) phd s y (b . ps) g+s sk fk i))))
423       ((q () abs phd s y p g+s sk fk i)
424        (syntax (match-phd () phd abs s y p g+s sk fk i))))))
425
426 (define-syntax match-phd
427   (lambda (x)
428     (syntax-case x ()
429       ((_ phd (c (            )) abs . l) (syntax (match-three (abs (c phd)) . l)))
430       ((_ (phd ...) (c ((h a) hh ...)) abs s v (h2 h3 x) g+s sk fk i)
431        (if (eq? (syntax->datum (syntax h)) (syntax->datum (syntax h2)))
432            (if (eq? (syntax->datum (syntax h)) (syntax->datum (syntax h3)))                     
433                (syntax (match-one (abs (a ((h a) hh ... phd ...))) s v x g+s 
434                                   (set-phd-sk c sk) (set-phd-fk c fk) i))
435                (syntax (match-one (abs (a ((h a) hh ... phd ...))) s v (h3 x) g+s 
436                                   (set-phd-sk c sk) (set-phd-fk c fk) i)))
437            (syntax (match-phd ((h a) phd ...) (c (hh ...)) abs s v (h2 h3 x) g+s sk fk i))))
438
439       ((_ (phd ...) (c ((h a) hh ...)) abs s v (h2 . l) g+s sk fk i)
440        (if (eq? (syntax->datum (syntax h)) (syntax->datum (syntax h2)))
441            (syntax (match-one (abs (a ((h a) hh ... phd ...))) s v l g+s (set-phd-sk c sk) (set-phd-fk c fk) i))
442            (syntax (match-phd ((h a) phd ...) (c (hh ...)) abs s v (h2 . l) g+s sk fk i))))
443       ((_ () phd abs . l)
444        (syntax (match-three (abs phd) . l))))))
445
446 (define-syntax set-phd-fk
447   (syntax-rules (begin)
448     ((_ abs          cc (begin . l))  (begin . l))
449     ((_ abs          cc (fk))         (fk))
450     ((_ (abs (c pp)) cc (fk fkk ...)) (fk (abs (cc pp)) fkk ...))))
451
452 (define-syntax set-phd-sk
453   (syntax-rules (begin)
454     ((_ abs          cc (begin . l)  i ...)  (begin . l))
455     ((_ abs          cc (fk)         i ...)  (fk))
456     ((_ (abs (c pp)) cc (fk fkk ...) i ...)  (fk (abs (cc pp)) fkk ... i ...))))
457
458 (define-syntax match-$
459   (lambda (x)
460     (syntax-case x ()
461       ((q abs (a ...) m (p1 p2 ...) . v)
462        (with-syntax ((m+1 (datum->syntax (syntax q) 
463                                          (+ (syntax->datum (syntax m)) 1))))
464           (syntax (match-$ abs (a ... (= 0 m p1)) m+1 (p2 ...) . v))))
465       ((_ abs newpat  m ()            s v kt ke i)
466        (syntax (match-one abss  s v newpat () kt ke i))))))
467
468
469 (define-syntax match-gen-ellipses
470   (lambda (x)
471     (syntax-case x ()
472       ((q . l) 
473        ;(pk `(match-gen-ellipses ,@(syntax->datum (syntax l))))
474        (syntax (match-gen-ellipses* . l))))))
475
476
477 (define-syntax match-gen-ellipses*
478   (syntax-rules ()
479     ((_ abs s v p () g+s (sk ...) fk i ((id id-ls) ...))
480      (match-check-identifier p
481        ;; simplest case equivalent to (p ...), just bind the list
482        (let ((p v))
483          (if (list? p)
484              (insert-abs abs (sk ... i))
485              (insert-abs abs fk)))
486        ;; simple case, match all elements of the list
487        (let loop ((ls v) (id-ls '()) ...)
488          (cond
489            ((null? ls)
490             (let ((id (reverse id-ls)) ...) (insert-abs abs (sk ... i))))
491            ((pair? ls)
492             (let ((w (car ls)))
493               (match-one abs s w p ((car ls) (set-car! ls))
494                          (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
495                          fk i)))
496            (else
497             (insert-abs abs fk))))))
498
499     ((_ abs s v p r g+s (sk ...) fk i ((id id-ls) ...))
500      ;; general case, trailing patterns to match, keep track of the
501      ;; remaining list length so we don't need any backtracking
502      (match-verify-no-ellipses
503       r
504       (let* ((tail-len (length 'r))
505              (ls v)
506              (len (length ls)))
507         (if (< len tail-len)
508             fk
509             (let loop ((ls ls) (n len) (id-ls '()) ...)
510               (cond
511                 ((= n tail-len)
512                  (let ((id (reverse id-ls)) ...)
513                    (match-one abs s ls r (#f #f) (sk ...) fk i)))
514                 ((pair? ls)
515                  (let ((w (car ls)))
516                    (match-one abs s w p ((car ls) (set-car! ls))
517                               (match-drop-ids
518                                (loop (cdr ls) (- n 1) (cons id id-ls) ...))
519                               fk
520                               i)))
521                 (else
522                  fk)))))))))
523
524
525 (define-syntax match-drop-ids
526   (syntax-rules ()
527     ((_ expr            ) expr)
528     ((_ abs expr ids ...) expr)))
529
530 (define-syntax match-gen-search
531   (syntax-rules ()
532     ((match-gen-search abs s v p q g+s sk fk i ((id id-ls) ...))
533      (letrec ((try (lambda (w fail id-ls ...)
534                      (match-one abs s w q g+s
535                                 (match-drop-ids
536                                  (let ((id (reverse id-ls)) ...)
537                                    sk))
538                                 (match-drop-ids (next w fail id-ls ...)) i)))
539               (next (lambda (w fail id-ls ...)
540                       (if (not (pair? w))
541                           (fail)
542                           (let ((u (car w)))
543                             (match-one
544                              abs s u p ((car w) (set-car! w))
545                              (match-drop-ids
546                               ;; accumulate the head variables from
547                               ;; the p pattern, and loop over the tail
548                               (let ((id-ls (cons id id-ls)) ...)
549                                 (let lp ((ls (cdr w)))
550                                   (if (pair? ls)
551                                       (try (car ls)
552                                            (lambda () (lp (cdr ls)))
553                                            id-ls ...)
554                                       (fail)))))
555                              (fail) i))))))
556        ;; the initial id-ls binding here is a dummy to get the right
557        ;; number of '()s
558        (let ((id-ls '()) ...)
559          (try v (lambda () (insert-abs abs fk)) id-ls ...))))))
560
561 (define-syntax match-quasiquote
562   (syntax-rules (unquote unquote-splicing quasiquote)
563     ((_ abs s v (unquote p) g+s sk fk i)
564      (match-one abs s v p g+s sk fk i))
565     ((_ abs s v ((unquote-splicing p) . rest) g+s sk fk i)
566      (if (pair? v)
567        (match-one abs s v
568                   (p . tmp)
569                   (match-quasiquote s tmp rest g+s sk fk)
570                   fk
571                   i)
572        (insert-abs abs fk)))
573     ((_ abs s v (quasiquote p) g+s sk fk i . depth)
574      (match-quasiquote abs s v p g+s sk fk i #f . depth))
575     ((_ abs s v (unquote p) g+s sk fk i x . depth)
576      (match-quasiquote abs s v p g+s sk fk i . depth))
577     ((_ abs s v (unquote-splicing p) g+s sk fk i x . depth)
578      (match-quasiquote abs s v p g+s sk fk i . depth))
579     ((_ abs s v (p . q) g+s sk fk i . depth)
580      (if (pair? v)
581        (let ((w (car v)) (x (cdr v)))
582          (match-quasiquote
583           abs s w p g+s
584           (match-quasiquote-step s x q g+s sk fk depth)
585           fk i . depth))
586        (insert-abs abs fk)))
587     ((_ abs s v #(elt ...) g+s sk fk i . depth)
588      (if (vector? v)
589        (let ((ls (vector->list v)))
590          (match-quasiquote abs s ls (elt ...) g+s sk fk i . depth))
591        (insert-abs abs fk)))
592     ((_ abs s v x g+s sk fk i . depth)
593      (match-one abs s v 'x g+s sk fk i))))
594
595 (define-syntax match-quasiquote-step
596   (syntax-rules ()
597     ((match-quasiquote-step abs s x q g+s sk fk depth i)
598      (match-quasiquote abs s x q g+s sk fk i . depth))))
599
600 (define-syntax match-extract-vars
601   (lambda (x)
602     (syntax-case x ()
603       ((q . l) 
604        ;(pk `(match-extract-vars ,(syntax->datum (syntax l))))
605        (syntax (match-extract-vars* . l))))))
606
607
608 ;;We must be able to extract vars in the new constructs!!
609 (define-syntax match-extract-vars*
610   (syntax-rules (_ ___ *** ? $ <> = quote quasiquote unquote unquote-splicing and or not get! set!)
611     ((match-extract-vars abs (? pred . p) . x)
612      (match-extract-vars abs p . x))
613     ((match-extract-vars abs ($ rec . p) . x)
614      (match-extract-vars abs p . x))
615     ((match-extract-vars abs (= proc p) . x)
616      (match-extract-vars abs p . x))
617     ((match-extract-vars abs (= u m p) . x)
618      (match-extract-vars abs p . x))
619     ((match-extract-vars abs (quote x) (k kk ...) i v)
620      (k abs kk ... v))
621     ((match-extract-vars abs (unquote x) (k kk ...) i v)
622      (k abs kk ... v))
623     ((match-extract-vars abs (unquote-splicing x) (k kk ...) i v)
624      (k abs kk ... v))
625     ((match-extract-vars abs (quasiquote x) k i v)
626      (match-extract-quasiquote-vars abs x k i v (#t)))
627     ((match-extract-vars abs (and . p) . x)
628      (match-extract-vars abs p . x))
629     ((match-extract-vars abs (or . p) . x)
630      (match-extract-vars abs p . x))
631     ((match-extract-vars abs (not . p) . x)
632      (match-extract-vars abs p . x))
633     ;; A non-keyword pair, expand the CAR with a continuation to
634     ;; expand the CDR.
635     ((match-extract-vars abs (<> f p) k i v)
636      (match-extract-vars abs p k i v))
637     ((match-extract-vars (abs phd) p k i v)
638      (abs-extract-vars () abs phd p k i v))))
639
640 (define-syntax match-extract-vars2
641   (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!)
642     ((match-extract-vars abs (p q . r) k i v)
643      (match-check-ellipse
644       q
645       (match-extract-vars abs (p . r) k i v)
646       (match-extract-vars abs p (match-extract-vars-step (q . r) k i v) i ())))
647     ((match-extract-vars abs (p . q) k i v)
648      (match-extract-vars abs p (match-extract-vars-step q k i v) i ()))
649     ((match-extract-vars abs #(p ...) . x)
650      (match-extract-vars abs (p ...) . x))
651     ((match-extract-vars abs _ (k kk ...) i v)    (k abs kk ... v))
652     ((match-extract-vars abs ___ (k kk ...) i v)  (k abs kk ... v))
653     ((match-extract-vars abs *** (k kk ...) i v)  (k abs kk ... v))
654     ;; This is the main part, the only place where we might add a new
655     ;; var if it's an unbound symbol.
656     ((match-extract-vars abs p (k kk ...) (i ...) v)
657      (let-syntax
658          ((new-sym?
659            (syntax-rules (i ...)
660              ((new-sym? p sk fk) sk)
661              ((new-sym? x sk fk) fk))))
662        (new-sym? random-sym-to-match
663                  (k abs kk ... ((p p-ls) . v))
664                  (k abs kk ... v))))
665     ))
666
667 (define-syntax abs-extract-vars
668   (lambda (x)
669     (syntax-case x ()
670       ((q . l) 
671        ;(pk `(abs-extract-vars ,@(syntax->datum (syntax l))))
672        (syntax (abs-extract-vars* . l))))))
673
674 (define-syntax abs-extract-vars*
675   (lambda (x)
676     (syntax-case x ()
677       ((q abs () phd p . l) (syntax (match-extract-phd () phd abs p . l)))
678       ((q (abs ...) ((a x . xs) us ...) phd ((b bs ...) w ...) k i v)
679        (if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
680            (syntax (match-extract-vars 
681                     (((a . xs) us ... abs ...) phd) (w ...) k i ((x x-ls) . v)))
682            (syntax (abs-extract-vars   
683                     ((a x . xs) abs ...) (us ...) phd ((b bs ...) w ...) k i v))))
684
685       ((q (abs ...) ((a) us ...) phd ((b bs ...) w ...) k i v)
686        (if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
687            (syntax (match-extract-vars 
688                     (((a) us ... abs ...) phd) (w ...) k i v)))
689            (syntax (abs-extract-vars   
690                     ((a) abs ...) (us ...) phd ((b bs ...) w ...) k i v)))
691
692       ((q (abs ...) ((a x . xs) us ...) phd (b w ...) k i v)
693        (if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
694            (syntax (match-extract-vars 
695                     (((a . xs) us ... abs ...) phd) (w ...) k i ((x x-ls) . v)))
696            (syntax (abs-extract-vars   
697                     ((a x . xs) abs ...) (us ...) phd (b w ...) k i v))))
698
699       ((q (abs ...) ((a) us ...) phd (b w ...) k i v)
700        (if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
701            (syntax (match-extract-vars 
702                     (((a) us ... abs ...) phd) (w ...) k i v))
703            (syntax (abs-extract-vars   
704                     ((a) abs ...) (us ...) phd (b w ...) k i v))))
705       ((q () a phd p k i v)
706        (syntax (match-extract-phd () phd a p k i v))))))
707
708 (define-syntax match-extract-phd
709   (syntax-rules ()
710     ((_ _ phd abs . l) (match-extract-vars2 (abs phd) . l))))
711
712 (define-syntax match-extract-vars-step
713   (syntax-rules ()
714     ((_ abs p k i v ((v2 v2-ls) ...))
715      (match-extract-vars abs p k (v2 ... . i) ((v2 v2-ls) ... . v)))
716     ))
717
718 (define-syntax match-extract-quasiquote-vars
719   (syntax-rules (quasiquote unquote unquote-splicing)
720     ((match-extract-quasiquote-vars abs (quasiquote x) k i v d)
721      (match-extract-quasiquote-vars abs x k i v (#t . d)))
722     ((match-extract-quasiquote-vars abs (unquote-splicing x) k i v d)
723      (match-extract-quasiquote-vars abs (unquote x) k i v d))
724     ((match-extract-quasiquote-vars abs (unquote x) k i v (#t))
725      (match-extract-vars abs x k i v))
726     ((match-extract-quasiquote-vars abs (unquote x) k i v (#t . d))
727      (match-extract-quasiquote-vars abs x k i v d))
728     ((match-extract-quasiquote-vars abs (x . y) k i v (#t . d))
729      (match-extract-quasiquote-vars abs
730       x
731       (match-extract-quasiquote-vars-step y k i v d) i ()))
732     ((match-extract-quasiquote-vars abs #(x ...) k i v (#t . d))
733      (match-extract-quasiquote-vars abs (x ...) k i v d))
734     ((match-extract-quasiquote-vars abs x (k kk ...) i v (#t . d))
735      (k abs kk ... v))
736     ))
737
738 (define-syntax match-extract-quasiquote-vars-step
739   (syntax-rules ()
740     ((_ abs x k i v d ((v2 v2-ls) ...))
741      (match-extract-quasiquote-vars abs x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
742     ))
743
744
745 (define-syntax match-define
746   (syntax-rules (abstractions)
747     ((q abstractions abs arg code)
748      (match-extract-vars abs arg (sieve (match-define-helper0 arg code) ()) () ()))
749     ((q arg code)
750      (match-extract-vars ()  arg (sieve (match-define-helper0 arg code) ()) () ()))))
751
752 (define-syntax sieve
753   (syntax-rules ()
754     ((_ cc (w ...) ((v q) v2 ...))
755      (sieve cc (v w ...) (v2 ...)))
756     ((_ cc (w ...) (v v2 ...))
757      (sieve cc (v w ...) (v2 ...)))
758     ((_ (cc ...) w ())
759      (cc ... w))))
760   
761 (define-syntax match-define-helper0
762   (lambda (x)
763     (syntax-case x ()
764       ((q arg code v)
765        (with-syntax ((vtemp (map (lambda (x)
766                                    (datum->syntax
767                                     (syntax q) (gensym "temp")))
768                                  (syntax->datum (syntax v)))))
769           (syntax (match-define-helper v vtemp arg code)))))))
770
771 (define-syntax match-define-helper
772   (syntax-rules ()
773     ((_ (v ...) (vt ...) arg code) 
774      (begin 
775        (begin (define v 0) 
776               ...)
777        (let ((vt 0) ...)
778          (match  code 
779                  (arg (begin (set! vt v) 
780                              ...)))
781          (begin (set! v vt) 
782                 ...))))))
783
784
785 ;;;Reading the rest from upstream
786
787 ;;Utility
788 (define-syntax include-from-path/filtered
789   (lambda (x)
790     (define (hit? sexp reject-list)
791       (if (null? reject-list)
792           #f
793           (let ((h (car reject-list))
794                 (l (cdr reject-list)))
795             (if (and (pair? sexp)
796                      (eq? 'define-syntax (car sexp))
797                      (pair? (cdr sexp))
798                      (eq? h (cadr sexp)))
799                 #t
800                 (hit? sexp l)))))
801
802     (define (read-filtered reject-list file)
803       (with-input-from-file (%search-load-path file)
804         (lambda ()
805           (let loop ((sexp (read)) (out '()))
806             (cond
807              ((eof-object? sexp) (reverse out))
808              ((hit? sexp reject-list)
809               (loop (read) out))
810              (else
811               (loop (read) (cons sexp out))))))))
812
813     (syntax-case x ()
814       ((_ reject-list file)
815        (with-syntax (((exp ...) (datum->syntax
816                                  x 
817                                  (read-filtered
818                                   (syntax->datum #'reject-list)
819                                   (syntax->datum #'file)))))
820                     #'(begin exp ...))))))
821
822 (include-from-path/filtered
823  (match-extract-vars  match-one       match-gen-or      match-gen-or-step 
824                       match-two       match match-next  match-gen-ellipses
825                       match-drop-ids  match-gen-search  match-quasiquote
826                       match-quasiquote-step  match-extract-vars-step
827                       match-extract-quasiquote-vars  match-extract-quasiquote-vars-step)
828  "ice-9/match.upstream.scm")
829
830
831
832 (define-syntax make-phd-matcher
833   (syntax-rules ()
834     ((_ name pd)
835      (begin
836        (define-syntax name 
837          (lambda (x)
838            (syntax-case x ()
839              ((_ s . l)
840               (syntax (match s -phd pd . l))))))))))
841   
842