diff -crB guile-master-20100512/module/ice-9/match.scm guile-master-20100512_new//module/ice-9/match.scm
*** guile-master-20100512/module/ice-9/match.scm	2010-05-12 06:00:07.000000000 +0200
--- guile-master-20100512_new//module/ice-9/match.scm	2010-05-23 16:55:51.891684063 +0200
***************
*** 1,199 ****
! ;;; installed-scm-file
  
! ;;;; 	Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
! ;;;;
! ;;;; This library is free software; you can redistribute it and/or
! ;;;; modify it under the terms of the GNU Lesser General Public
! ;;;; License as published by the Free Software Foundation; either
! ;;;; version 3 of the License, or (at your option) any later version.
! ;;;; 
! ;;;; This library is distributed in the hope that it will be useful,
! ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
! ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
! ;;;; Lesser General Public License for more details.
! ;;;; 
! ;;;; You should have received a copy of the GNU Lesser General Public
! ;;;; License along with this library; if not, write to the Free Software
! ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
! ;;;;
  
  (define-module (ice-9 match)
!   :use-module (ice-9 pretty-print)
!   :export (match match-lambda match-lambda* match-define
! 		 match-let match-let* match-letrec
! 		 define-structure define-const-structure
!                  match:andmap
! 		 match:error match:set-error
! 		 match:error-control match:set-error-control
! 		 match:structure-control match:set-structure-control
! 		 match:runtime-structures match:set-runtime-structures))
! 
! ;; The original code can be found at the Scheme Repository
! ;;
! ;;   http://www.cs.indiana.edu/scheme-repository/code.match.html
! ;;
! ;; or Andrew K. Wright's web page:
! ;;
! ;;   http://www.star-lab.com/wright/code.html
! 
! 
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;; Pattern Matching Syntactic Extensions for Scheme
! ;;
! (define match:version "Version 1.19, Sep 15, 1995")
! ;;
! ;; Written by Andrew K. Wright, 1993 (address@hidden).
! ;; Adapted from code originally written by Bruce F. Duba, 1991.
! ;; This package also includes a modified version of Kent Dybvig's
! ;; define-structure (see Dybvig, R.K., The Scheme Programming Language,
! ;; Prentice-Hall, NJ, 1987).
! ;;
! ;; This macro package extends Scheme with several new expression forms.
! ;; Following is a brief summary of the new forms.  See the associated
! ;; LaTeX documentation for a full description of their functionality.
! ;;
! ;;
! ;;         match expressions:
! ;;
! ;; exp ::= ...
! ;;       | (match exp clause ...)
! ;;       | (match-lambda clause ...)
! ;;       | (match-lambda* clause ...)
! ;;       | (match-let ((pat exp) ...) body)
! ;;       | (match-let* ((pat exp) ...) body)
! ;;       | (match-letrec ((pat exp) ...) body)
! ;;       | (match-define pat exp)
! ;;
! ;; clause ::= (pat body) | (pat => exp)
! ;;
! ;;         patterns:                       matches:
! ;;
! ;; pat ::= identifier                      anything, and binds identifier
! ;;       | _                               anything
! ;;       | ()                              the empty list
! ;;       | #t                              #t
! ;;       | #f                              #f
! ;;       | string                          a string
! ;;       | number                          a number
! ;;       | character                       a character
! ;;       | 'sexp                           an s-expression
! ;;       | 'symbol                         a symbol (special case of s-expr)
! ;;       | (pat_1 ... pat_n)               list of n elements
! ;;       | (pat_1 ... pat_n . pat_{n+1})   list of n or more
! ;;       | (pat_1 ... pat_n pat_n+1 ooo)   list of n or more, each element
! ;;                                           of remainder must match pat_n+1
! ;;       | #(pat_1 ... pat_n)              vector of n elements
! ;;       | #(pat_1 ... pat_n pat_n+1 ooo)  vector of n or more, each element
! ;;                                           of remainder must match pat_n+1
! ;;       | #&pat                           box
! ;;       | ($ struct-name pat_1 ... pat_n) a structure
! ;;       | (= field pat)                   a field of a structure
! ;;       | (and pat_1 ... pat_n)           if all of pat_1 thru pat_n match
! ;;       | (or pat_1 ... pat_n)            if any of pat_1 thru pat_n match
! ;;       | (not pat_1 ... pat_n)           if all pat_1 thru pat_n don't match
! ;;       | (? predicate pat_1 ... pat_n)   if predicate true and all of
! ;;                                           pat_1 thru pat_n match
! ;;       | (set! identifier)               anything, and binds setter
! ;;       | (get! identifier)               anything, and binds getter
! ;;       | `qp                             a quasi-pattern
! ;;
! ;; ooo ::= ...                             zero or more
! ;;       | ___                             zero or more
! ;;       | ..k                             k or more
! ;;       | __k                             k or more
! ;;
! ;;         quasi-patterns:                 matches:
! ;;
! ;; qp  ::= ()                              the empty list
! ;;       | #t                              #t
! ;;       | #f                              #f
! ;;       | string                          a string
! ;;       | number                          a number
! ;;       | character                       a character
! ;;       | identifier                      a symbol
! ;;       | (qp_1 ... qp_n)                 list of n elements
! ;;       | (qp_1 ... qp_n . qp_{n+1})      list of n or more
! ;;       | (qp_1 ... qp_n qp_n+1 ooo)      list of n or more, each element
! ;;                                           of remainder must match qp_n+1
! ;;       | #(qp_1 ... qp_n)                vector of n elements
! ;;       | #(qp_1 ... qp_n qp_n+1 ooo)     vector of n or more, each element
! ;;                                           of remainder must match qp_n+1
! ;;       | #&qp                            box
! ;;       | ,pat                            a pattern
! ;;       | ,@pat                           a pattern
! ;;
! ;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
! ;; and, or, not, set!, get!, ..., ___) cannot be used as pattern variables.
! ;;
! ;;
! ;;         structure expressions:
! ;;
! ;; exp ::= ...
! ;;       | (define-structure (id_0 id_1 ... id_n))
! ;;       | (define-structure (id_0 id_1 ... id_n)
! ;;                           ((id_{n+1} exp_1) ... (id_{n+m} exp_m)))
! ;;       | (define-const-structure (id_0 arg_1 ... arg_n))
! ;;       | (define-const-structure (id_0 arg_1 ... arg_n)
! ;;                                 ((arg_{n+1} exp_1) ... (arg_{n+m} exp_m)))
! ;;
! ;; arg ::= id | (! id) | (@ id)
! ;;
! ;;
! ;; match:error-control controls what code is generated for failed matches.
! ;; Possible values:
! ;;  'unspecified - do nothing, ie., evaluate (cond [#f #f])
! ;;  'fail - call match:error, or die at car or cdr
! ;;  'error - call match:error with the unmatched value
! ;;  'match - call match:error with the unmatched value _and_
! ;;             the quoted match expression
! ;; match:error-control is set by calling match:set-error-control with
! ;; the new value.
! ;;
! ;; match:error is called for a failed match.
! ;; match:error is set by calling match:set-error with the new value.
! ;;
! ;; match:structure-control controls the uniqueness of structures
! ;; (does not exist for Scheme 48 version).
! ;; Possible values:
! ;;  'vector - (default) structures are vectors with a symbol in position 0
! ;;  'disjoint - structures are fully disjoint from all other values
! ;; match:structure-control is set by calling match:set-structure-control
! ;; with the new value.
! ;;
! ;; match:runtime-structures controls whether local structure declarations
! ;; generate new structures each time they are reached
! ;; (does not exist for Scheme 48 version).
! ;; Possible values:
! ;;  #t - (default) each runtime occurrence generates a new structure
! ;;  #f - each lexical occurrence generates a new structure
! ;;
! ;; End of user visible/modifiable stuff.
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! 
! (define match:error (lambda (val . args) (for-each pretty-print args) (error "no matching clause for " val)))
! (define match:andmap (lambda (f l) (if (null? l) (and) (and (f (car l)) (match:andmap f (cdr l))))))
! (define match:syntax-err (lambda (obj msg) (error msg obj)))
! (define match:disjoint-structure-tags (quote ()))
! (define match:make-structure-tag (lambda (name) (if (or (eq? match:structure-control (quote disjoint)) match:runtime-structures) (let ((tag (gensym))) (set! match:disjoint-structure-tags (cons tag match:disjoint-structure-tags)) tag) (string->symbol (string-append "<" (symbol->string name) ">")))))
! (define match:structure? (lambda (tag) (memq tag match:disjoint-structure-tags)))
! (define match:structure-control (quote vector))
! (define match:set-structure-control (lambda (v) (set! match:structure-control v)))
! (define match:set-error (lambda (v) (set! match:error v)))
! (define match:error-control (quote error))
! (define match:set-error-control (lambda (v) (set! match:error-control v)))
! (define match:disjoint-predicates (cons (quote null) (quote (pair? symbol? boolean? number? string? char? procedure? vector?))))
! (define match:vector-structures (quote ()))
! (define match:expanders (letrec ((genmatch (lambda (x clauses match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (blist (car eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (car c)))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (fail (and (pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) (quote =>)) (symbol? (cadadr c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadadr c))) (bv2 (if fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons (quasiquote ((unquote code) (lambda (unquote bv2) (unquote-splicing body)))) (append bindings blist))) (list p code bv (and fail (gensym)) #f))) clauses)) (code (gen x (quote ()) plist (cdr eb-errf) length>= (gensym)))) (unreachable plist match-expr) (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing blist)) (unquote code))))))) (genletrec (lambda (pat exp body match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (letrec (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing (map (lambda (v) (quasiquote ((unquote v) #f))) bv)) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (unquote-splicing body))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))) (gendefine (lambda (pat exp match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (begin (unquote-splicing (map (lambda (v) (quasiquote (define (unquote v) #f))) bv)) (unquote (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (cond (#f #f)))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))))))) (pattern-var? (lambda (x) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x (quote (quasiquote quote unquote unquote-splicing ? _ $ = and or not set! get! ... ___))))))) (dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s (quote (... ___))) 0 (let* ((s (symbol->string s)) (n (string-length s))) (and (<= 3 n) (memq (string-ref s 0) (quote (#\. #\_))) (memq (string-ref s 1) (quote (#\. #\_))) (match:andmap char-numeric? (string->list (substring s 2 n))) (string->number (substring s 2 n)))))))) (error-maker (lambda (match-expr) (cond ((eq? match:error-control (quote unspecified)) (cons (quote ()) (lambda (x) (quasiquote (cond (#f #f)))))) ((memq match:error-control (quote (error fail))) (cons (quote ()) (lambda (x) (quasiquote (match:error (unquote x)))))) ((eq? match:error-control (quote match)) (let ((errf (gensym)) (arg (gensym))) (cons (quasiquote (((unquote errf) (lambda ((unquote arg)) (match:error (unquote arg) (quote (unquote match-expr))))))) (lambda (x) (quasiquote ((unquote errf) (unquote x))))))) (else (match:syntax-err (quote (unspecified error fail match)) "invalid value for match:error-control, legal values are"))))) (unreachable (lambda (plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x))) (begin (display "Warning: unreachable pattern ") (display (car x)) (display " in ") (display match-expr) (newline)))) plist))) (validate-pattern (lambda (pattern) (letrec ((simple? (lambda (x) (or (string? x) (boolean? x) (char? x) (number? x) (null? x)))) (ordinary (lambda (p) (let ((g157 (lambda (x y) (cons (ordinary x) (ordinary y))))) (if (simple? p) ((lambda (p) p) p) (if (equal? p (quote _)) ((lambda () (quote _))) (if (pattern-var? p) ((lambda (p) p) p) (if (pair? p) (if (equal? (car p) (quote quasiquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (quasi p)) (cadr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote quote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote ?)) (if (and (pair? (cdr p)) (list? (cddr p))) ((lambda (pred ps) (quasiquote (? (unquote pred) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote =)) (if (and (pair? (cdr p)) (pair? (cddr p)) (null? (cdddr p))) ((lambda (sel p) (quasiquote (= (unquote sel) (unquote (ordinary p))))) (cadr p) (caddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote and)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (and (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote or)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (or (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote not)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (not (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote $)) (if (and (pair? (cdr p)) (symbol? (cadr p)) (list? (cddr p))) ((lambda (r ps) (quasiquote ($ (unquote r) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote set!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote get!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote unquote)) (g157 (car p) (cdr p)) (if (equal? (car p) (quote unquote-splicing)) (g157 (car p) (cdr p)) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (ordinary p)) (unquote ddk)))) (car p) (cadr p)) (g157 (car p) (cdr p))))))))))))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (and (not (null? rpl)) (dot-dot-k? (car rpl))) (reverse (cons (car rpl) (map ordinary (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern"))))))))))) (quasi (lambda (p) (let ((g178 (lambda (x y) (cons (quasi x) (quasi y))))) (if (simple? p) ((lambda (p) p) p) (if (symbol? p) ((lambda (p) (quasiquote (quote (unquote p)))) p) (if (pair? p) (if (equal? (car p) (quote unquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (ordinary p)) (cadr p)) (g178 (car p) (cdr p))) (if (and (pair? (car p)) (equal? (caar p) (quote unquote-splicing)) (pair? (cdar p)) (null? (cddar p))) (if (null? (cdr p)) ((lambda (p) (ordinary p)) (cadar p)) ((lambda (p y) (append (ordlist p) (quasi y))) (cadar p) (cdr p))) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (quasi p)) (unquote ddk)))) (car p) (cadr p)) (g178 (car p) (cdr p))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (dot-dot-k? (car rpl)) (reverse (cons (car rpl) (map quasi (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern")))))))))) (ordlist (lambda (p) (cond ((null? p) (quote ())) ((pair? p) (cons (ordinary (car p)) (ordlist (cdr p)))) (else (match:syntax-err pattern "invalid use of unquote-splicing in pattern")))))) (ordinary pattern)))) (bound (lambda (pattern) (letrec ((pred-bodies (quote ())) (bound (lambda (p a k) (cond ((eq? (quote _) p) (k p a)) ((symbol? p) (if (memq p a) (match:syntax-err pattern "duplicate variable in pattern")) (k p (cons p a))) ((and (pair? p) (eq? (quote quote) (car p))) (k p a)) ((and (pair? p) (eq? (quote ?) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (and (? (unquote (cadr p))) (unquote-splicing (cddr p)))) a k)) ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (k (quasiquote (? (unquote g))) a))) (else (k p a)))) ((and (pair? p) (eq? (quote =) (car p))) (cond ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (bound (quasiquote (= (unquote g) (unquote (caddr p)))) a k))) (else (bound (caddr p) a (lambda (p2 a) (k (quasiquote (= (unquote (cadr p)) (unquote p2))) a)))))) ((and (pair? p) (eq? (quote and) (car p))) (bound* (cdr p) a (lambda (p a) (k (quasiquote (and (unquote-splicing p))) a)))) ((and (pair? p) (eq? (quote or) (car p))) (bound (cadr p) a (lambda (first-p first-a) (let or* ((plist (cddr p)) (k (lambda (plist) (k (quasiquote (or (unquote first-p) (unquote-splicing plist))) first-a)))) (if (null? plist) (k plist) (bound (car plist) a (lambda (car-p car-a) (if (not (permutation car-a first-a)) (match:syntax-err pattern "variables of or-pattern differ in")) (or* (cdr plist) (lambda (cdr-p) (k (cons car-p cdr-p))))))))))) ((and (pair? p) (eq? (quote not) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (not (or (unquote-splicing (cdr p))))) a k)) (else (bound (cadr p) a (lambda (p2 a2) (if (not (permutation a a2)) (match:syntax-err p "no variables allowed in")) (k (quasiquote (not (unquote p2))) a)))))) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (bound (car p) a (lambda (q b) (let ((bvars (find-prefix b a))) (k (quasiquote ((unquote q) (unquote (cadr p)) (unquote bvars) (unquote (gensym)) (unquote (gensym)) (unquote (map (lambda (_) (gensym)) bvars)))) b))))) ((and (pair? p) (eq? (quote $) (car p))) (bound* (cddr p) a (lambda (p1 a) (k (quasiquote ($ (unquote (cadr p)) (unquote-splicing p1))) a)))) ((and (pair? p) (eq? (quote set!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((and (pair? p) (eq? (quote get!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((pair? p) (bound (car p) a (lambda (car-p a) (bound (cdr p) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) ((vector? p) (boundv (vector->list p) a (lambda (pl a) (k (list->vector pl) a)))) (else (k p a))))) (boundv (lambda (plist a k) (let ((g184 (lambda () (k plist a)))) (if (pair? plist) (if (and (pair? (cdr plist)) (dot-dot-k? (cadr plist)) (null? (cddr plist))) ((lambda () (bound plist a k))) (if (null? plist) (g184) ((lambda (x y) (bound x a (lambda (car-p a) (boundv y a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) (car plist) (cdr plist)))) (if (null? plist) (g184) (match:error plist)))))) (bound* (lambda (plist a k) (if (null? plist) (k plist a) (bound (car plist) a (lambda (car-p a) (bound* (cdr plist) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))))) (find-prefix (lambda (b a) (if (eq? b a) (quote ()) (cons (car b) (find-prefix (cdr b) a))))) (permutation (lambda (p1 p2) (and (= (length p1) (length p2)) (match:andmap (lambda (x1) (memq x1 p2)) p1))))) (bound pattern (quote ()) (lambda (p a) (list p (reverse a) pred-bodies)))))) (inline-let (lambda (let-exp) (letrec ((occ (lambda (x e) (let loop ((e e)) (cond ((pair? e) (+ (loop (car e)) (loop (cdr e)))) ((eq? x e) 1) (else 0))))) (subst (lambda (e old new) (let loop ((e e)) (cond ((pair? e) (cons (loop (car e)) (loop (cdr e)))) ((eq? old e) new) (else e))))) (const? (lambda (sexp) (or (symbol? sexp) (boolean? sexp) (string? sexp) (char? sexp) (number? sexp) (null? sexp) (and (pair? sexp) (eq? (car sexp) (quote quote)) (pair? (cdr sexp)) (symbol? (cadr sexp)) (null? (cddr sexp)))))) (isval? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (memq (car sexp) (quote (lambda quote match-lambda match-lambda*))))))) (small? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (eq? (car sexp) (quote lambda)) (pair? (cdr sexp)) (pair? (cddr sexp)) (const? (caddr sexp)) (null? (cdddr sexp))))))) (let loop ((b (cadr let-exp)) (new-b (quote ())) (e (caddr let-exp))) (cond ((null? b) (if (null? new-b) e (quasiquote (let (unquote (reverse new-b)) (unquote e))))) ((isval? (cadr (car b))) (let* ((x (caar b)) (n (occ x e))) (cond ((= 0 n) (loop (cdr b) new-b e)) ((or (= 1 n) (small? (cadr (car b)))) (loop (cdr b) new-b (subst e x (cadr (car b))))) (else (loop (cdr b) (cons (car b) new-b) e))))) (else (loop (cdr b) (cons (car b) new-b) e))))))) (gen (lambda (x sf plist erract length>= eta) (if (null? plist) (erract x) (let* ((v (quote ())) (val (lambda (x) (cdr (assq x v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>= eta))) (success (lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((code (cadr (car plist))) (bv (caddr (car plist))) (fail-sym (cadddr (car plist)))) (if fail-sym (let ((ap (quasiquote ((unquote code) (unquote fail-sym) (unquote-splicing (map val bv)))))) (quasiquote (call-with-current-continuation (lambda ((unquote fail-sym)) (let (((unquote fail-sym) (lambda () ((unquote fail-sym) (unquote (fail sf)))))) (unquote ap)))))) (quasiquote ((unquote code) (unquote-splicing (map val bv))))))))) (let next ((p (caar plist)) (e x) (sf sf) (kf fail) (ks success)) (cond ((eq? (quote _) p) (ks sf)) ((symbol? p) (set! v (cons (cons p e) v)) (ks sf)) ((null? p) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((equal? p (quote (quote ()))) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((string? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((boolean? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((char? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((number? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote quote) (car p))) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote ?) (car p))) (let ((tst (quasiquote ((unquote (cadr p)) (unquote e))))) (emit tst sf kf ks))) ((and (pair? p) (eq? (quote =) (car p))) (next (caddr p) (quasiquote ((unquote (cadr p)) (unquote e))) sf kf ks)) ((and (pair? p) (eq? (quote and) (car p))) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (ks sf) (next (car p) e sf kf (lambda (sf) (loop (cdr p) sf)))))) ((and (pair? p) (eq? (quote or) (car p))) (let ((or-v v)) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (kf sf) (begin (set! v or-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pair? p) (eq? (quote not) (car p))) (next (cadr p) e sf ks kf)) ((and (pair? p) (eq? (quote $) (car p))) (let* ((tag (cadr p)) (fields (cdr p)) (rlen (length fields)) (tst (quasiquote ((unquote (symbol-append tag (quote ?))) (unquote e))))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (= n rlen) (ks sf) (next (list-ref fields n) (quasiquote ((unquote (symbol-append tag (quote -) n)) (unquote e))) sf kf (rloop (+ 1 n))))))))) ((and (pair? p) (eq? (quote set!) (car p))) (set! v (cons (cons (cadr p) (setter e p)) v)) (ks sf)) ((and (pair? p) (eq? (quote get!) (car p))) (set! v (cons (cons (cadr p) (getter e p)) v)) (ks sf)) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (emit (quasiquote (list? (unquote e))) sf kf (lambda (sf) (let* ((k (dot-dot-k? (cadr p))) (ks (lambda (sf) (let ((bound (list-ref p 2))) (cond ((eq? (car p) (quote _)) (ks sf)) ((null? bound) (let* ((ptst (next (car p) eta sf (lambda (sf) #f) (lambda (sf) #t))) (tst (if (and (pair? ptst) (symbol? (car ptst)) (pair? (cdr ptst)) (eq? eta (cadr ptst)) (null? (cddr ptst))) (car ptst) (quasiquote (lambda ((unquote eta)) (unquote ptst)))))) (assm (quasiquote (match:andmap (unquote tst) (unquote e))) (kf sf) (ks sf)))) ((and (symbol? (car p)) (equal? (list (car p)) bound)) (next (car p) e sf kf ks)) (else (let* ((gloop (list-ref p 3)) (ge (list-ref p 4)) (fresh (list-ref p 5)) (p1 (next (car p) (quasiquote (car (unquote ge))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (cdr (unquote ge)) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound (map (lambda (x) (quasiquote (reverse (unquote x)))) fresh)) v)) (quasiquote (let (unquote gloop) (((unquote ge) (unquote e)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (null? (unquote ge)) (unquote (ks sf)) (unquote p1))))))))))) (case k ((0) (ks sf)) ((1) (emit (quasiquote (pair? (unquote e))) sf kf ks)) (else (emit (quasiquote (((unquote length>=) (unquote k)) (unquote e))) sf kf ks))))))) ((pair? p) (emit (quasiquote (pair? (unquote e))) sf kf (lambda (sf) (next (car p) (add-a e) sf kf (lambda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>= (vector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (let* ((vlen (- (vector-length p) 6)) (k (dot-dot-k? (vector-ref p (+ vlen 1)))) (minlen (+ vlen k)) (bound (vector-ref p (+ vlen 2)))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (assm (quasiquote (>= (vector-length (unquote e)) (unquote minlen))) (kf sf) ((let vloop ((n 0)) (lambda (sf) (cond ((not (= n vlen)) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vlen) (quote _)) (ks sf)) (else (let* ((gloop (vector-ref p (+ vlen 3))) (ind (vector-ref p (+ vlen 4))) (fresh (vector-ref p (+ vlen 5))) (p1 (next (vector-ref p vlen) (quasiquote (vector-ref (unquote e) (unquote ind))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (- (unquote ind) 1) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound fresh) v)) (quasiquote (let (unquote gloop) (((unquote ind) (- (vector-length (unquote e)) 1)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (> (unquote minlen) (unquote ind)) (unquote (ks sf)) (unquote p1))))))))) sf)))))) ((vector? p) (let ((vlen (vector-length p))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (emit (quasiquote (equal? (vector-length (unquote e)) (unquote vlen))) sf kf (let vloop ((n 0)) (lambda (sf) (if (= n vlen) (ks sf) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n))))))))))) (else (display "FATAL ERROR IN PATTERN MATCHER") (newline) (error #f "THIS NEVER HAPPENS")))))))) (emit (lambda (tst sf kf ks) (cond ((in tst sf) (ks sf)) ((in (quasiquote (not (unquote tst))) sf) (kf sf)) (else (let* ((e (cadr tst)) (implied (cond ((eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quasiquote ((string? (unquote e))))) ((boolean? p) (quasiquote ((boolean? (unquote e))))) ((char? p) (quasiquote ((char? (unquote e))))) ((number? p) (quasiquote ((number? (unquote e))))) ((and (pair? p) (eq? (quote quote) (car p))) (quasiquote ((symbol? (unquote e))))) (else (quote ()))))) ((eq? (car tst) (quote null?)) (quasiquote ((list? (unquote e))))) ((vec-structure? tst) (quasiquote ((vector? (unquote e))))) (else (quote ())))) (not-imp (case (car tst) ((list?) (quasiquote ((not (null? (unquote e)))))) (else (quote ())))) (s (ks (cons tst (append implied sf)))) (k (kf (cons (quasiquote (not (unquote tst))) (append not-imp sf))))) (assm tst k s)))))) (assm (lambda (tst f s) (cond ((equal? s f) s) ((and (eq? s #t) (eq? f #f)) tst) ((and (eq? (car tst) (quote pair?)) (memq match:error-control (quote (unspecified fail))) (memq (car f) (quote (cond match:error))) (guarantees s (cadr tst))) s) ((and (pair? s) (eq? (car s) (quote if)) (equal? (cadddr s) f)) (if (eq? (car (cadr s)) (quote and)) (quasiquote (if (and (unquote tst) (unquote-splicing (cdr (cadr s)))) (unquote (caddr s)) (unquote f))) (quasiquote (if (and (unquote tst) (unquote (cadr s))) (unquote (caddr s)) (unquote f))))) ((and (pair? s) (equal? (car s) (quote call-with-current-continuation)) (pair? (cdr s)) (pair? (cadr s)) (equal? (caadr s) (quote lambda)) (pair? (cdadr s)) (pair? (cadadr s)) (null? (cdr (cadadr s))) (pair? (cddadr s)) (pair? (car (cddadr s))) (equal? (caar (cddadr s)) (quote let)) (pair? (cdar (cddadr s))) (pair? (cadar (cddadr s))) (pair? (caadar (cddadr s))) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr (caadar (cddadr s)))) (equal? (caadr (caadar (cddadr s))) (quote lambda)) (pair? (cdadr (caadar (cddadr s)))) (null? (cadadr (caadar (cddadr s)))) (pair? (cddadr (caadar (cddadr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair? (cdar (cddadr (caadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr s))))) (null? (cdr (cddadr (caadar (cddadr s))))) (null? (cddr (caadar (cddadr s)))) (null? (cdadar (cddadr s))) (pair? (cddar (cddadr s))) (null? (cdddar (cddadr s))) (null? (cdr (cddadr s))) (null? (cddr s)) (equal? f (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr s)))) (s2 (caddar (cddadr s)))) (quasiquote (call-with-current-continuation (lambda ((unquote k)) (let (((unquote fail) (lambda () ((unquote k) (unquote f))))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))))) ((and #f (pair? s) (equal? (car s) (quote let)) (pair? (cdr s)) (pair? (cadr s)) (pair? (caadr s)) (pair? (cdaadr s)) (pair? (car (cdaadr s))) (equal? (caar (cdaadr s)) (quote lambda)) (pair? (cdar (cdaadr s))) (null? (cadar (cdaadr s))) (pair? (cddar (cdaadr s))) (null? (cdddar (cdaadr s))) (null? (cdr (cdaadr s))) (null? (cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr s)) (s2 (caddr s))) (quasiquote (let (((unquote fail) (lambda () (unquote f)))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))) (else (quasiquote (if (unquote tst) (unquote s) (unquote f))))))) (guarantees (lambda (code x) (let ((a (add-a x)) (d (add-d x))) (let loop ((code code)) (cond ((not (pair? code)) #f) ((memq (car code) (quote (cond match:error))) #t) ((or (equal? code a) (equal? code d)) #t) ((eq? (car code) (quote if)) (or (loop (cadr code)) (and (loop (caddr code)) (loop (cadddr code))))) ((eq? (car code) (quote lambda)) #f) ((and (eq? (car code) (quote let)) (symbol? (cadr code))) #f) (else (or (loop (car code)) (loop (cdr code))))))))) (in (lambda (e l) (or (member e l) (and (eq? (car e) (quote list?)) (or (member (quasiquote (null? (unquote (cadr e)))) l) (member (quasiquote (pair? (unquote (cadr e)))) l))) (and (eq? (car e) (quote not)) (let* ((srch (cadr e)) (const-class (equal-test? srch))) (cond (const-class (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? const-class (car x)))) (equal? x (quasiquote (not ((unquote const-class) (unquote (cadr srch)))))) (and (equal? (cadr x) (cadr srch)) (equal-test? x) (not (equal? (caddr srch) (caddr x)))) (mem (cdr l))))))) ((disjoint? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? (car x) (car srch)))) (mem (cdr l))))))) ((eq? (car srch) (quote list?)) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (memq (car x) (quote (list? pair? null?))))) (mem (cdr l))))))) ((vec-structure? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (or (disjoint? x) (vec-structure? x)) (not (equal? (car x) (quote vector?))) (not (equal? (car x) (car srch)))) (equal? x (quasiquote (not (vector? (unquote (cadr srch)))))) (mem (cdr l))))))) (else #f))))))) (equal-test? (lambda (tst) (and (eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quote string?)) ((boolean? p) (quote boolean?)) ((char? p) (quote char?)) ((number? p) (quote number?)) ((and (pair? p) (pair? (cdr p)) (null? (cddr p)) (eq? (quote quote) (car p)) (symbol? (cadr p))) (quote symbol?)) (else #f)))))) (disjoint? (lambda (tst) (memq (car tst) match:disjoint-predicates))) (vec-structure? (lambda (tst) (memq (car tst) match:vector-structures))) (add-a (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cadr new) (cdr a)) (quasiquote (car (unquote a))))))) (add-d (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cddr new) (cdr a)) (quasiquote (cdr (unquote a))))))) (c---rs (quote ((car caar . cdar) (cdr cadr . cddr) (caar caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr) (caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar . cdddar) (cdddr cadddr . cddddr)))) (setter (lambda (e p) (let ((mk-setter (lambda (s) (symbol-append (quote set-) s (quote !))))) (cond ((not (pair? e)) (match:syntax-err p "unnested set! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (vector-set! x (unquote (caddr e)) y))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-box! x y))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-car! x y))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-cdr! x y))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda (y) ((unquote (mk-setter (cddr a))) x y))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) ((unquote (mk-setter (car e))) x y))))))))) (getter (lambda (e p) (cond ((not (pair? e)) (match:syntax-err p "unnested get! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (vector-ref x (unquote (caddr e))))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (unbox x))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (car x))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (cdr x))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda () ((unquote (cddr a)) x))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda () ((unquote (car e)) x)))))))) (get-c---rs (quote ((caar car . car) (cadr cdr . car) (cdar car . cdr) (cddr cdr . cdr) (caaar caar . car) (caadr cadr . car) (cadar cdar . car) (caddr cddr . car) (cdaar caar . cdr) (cdadr cadr . cdr) (cddar cdar . cdr) (cdddr cddr . cdr) (caaaar caaar . car) (caaadr caadr . car) (caadar cadar . car) (caaddr caddr . car) (cadaar cdaar . car) (cadadr cdadr . car) (caddar cddar . car) (cadddr cdddr . car) (cdaaar caaar . cdr) (cdaadr caadr . cdr) (cdadar cadar . cdr) (cdaddr caddr . cdr) (cddaar cdaar . cdr) (cddadr cdadr . cdr) (cdddar cddar . cdr) (cddddr cdddr . cdr)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l))))) (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) (rdc (lambda (l) (if (null? (cdr l)) (quote ()) (cons (car l) (rdc (cdr l))))))) (list genmatch genletrec gendefine pattern-var?)))
! (defmacro match args (cond ((and (list? args) (<= 1 (length args)) (match:andmap (lambda (y) (and (list? y) (<= 2 (length y)))) (cdr args))) (let* ((exp (car args)) (clauses (cdr args)) (e (if (symbol? exp) exp (gensym)))) (if (symbol? exp) ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))) (quasiquote (let (((unquote e) (unquote exp))) (unquote ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splicing args))) "syntax error in"))))
! (defmacro match-lambda args (if (and (list? args) (match:andmap (lambda (g195) (if (and (pair? g195) (list? (cdr g195))) (pair? (cdr g195)) #f)) args)) ((lambda () (let ((e (gensym))) (quasiquote (lambda ((unquote e)) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda (unquote-splicing args))) "syntax error in")))))
! (defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda (g203) (if (and (pair? g203) (list? (cdr g203))) (pair? (cdr g203)) #f)) args)) ((lambda () (let ((e (gensym))) (quasiquote (lambda (unquote e) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda* (unquote-splicing args))) "syntax error in")))))
! (defmacro match-let args (let ((g227 (lambda (pat exp body) (quasiquote (match (unquote exp) ((unquote pat) (unquote-splicing body)))))) (g223 (lambda (pat exp body) (let ((g (map (lambda (x) (gensym)) pat)) (vpattern (list->vector pat))) (quasiquote (let (unquote (map list g exp)) (match (vector (unquote-splicing g)) ((unquote vpattern) (unquote-splicing body)))))))) (g215 (lambda () (match:syntax-err (quasiquote (match-let (unquote-splicing args))) "syntax error in"))) (g214 (lambda (p1 e1 p2 e2 body) (let ((g1 (gensym)) (g2 (gensym))) (quasiquote (let (((unquote g1) (unquote e1)) ((unquote g2) (unquote e2))) (match (cons (unquote g1) (unquote g2)) (((unquote p1) unquote p2) (unquote-splicing body)))))))) (g205 (cadddr match:expanders))) (if (pair? args) (if (symbol? (car args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g230 ((g231 (cadr args)) (g229 (quote ())) (g228 (quote ()))) (if (null? g231) (if (and (list? (cddr args)) (pair? (cddr args))) ((lambda (name pat exp body) (if (match:andmap (cadddr match:expanders) pat) (quasiquote (let (unquote-splicing args))) (quasiquote (letrec (((unquote name) (match-lambda* ((unquote pat) (unquote-splicing body))))) ((unquote name) (unquote-splicing exp)))))) (car args) (reverse g228) (reverse g229) (cddr args)) (g215)) (if (and (pair? (car g231)) (pair? (cdar g231)) (null? (cddar g231))) (g230 (cdr g231) (cons (cadar g231) g229) (cons (caar g231) g228)) (g215)))) (g215)) (if (list? (car args)) (if (match:andmap (lambda (g236) (if (and (pair? g236) (g205 (car g236)) (pair? (cdr g236))) (null? (cddr g236)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (let (unquote-splicing args))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (g215)))) (g215))))
! (defmacro match-let* args (let ((g245 (lambda () (match:syntax-err (quasiquote (match-let* (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (null? (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda (body) (quasiquote (let* (unquote-splicing args)))) (cdr args)) (g245)) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args)) (list? (cdar args)) (list? (cdr args)) (pair? (cdr args))) ((lambda (pat exp rest body) (if ((cadddr match:expanders) pat) (quasiquote (let (((unquote pat) (unquote exp))) (match-let* (unquote rest) (unquote-splicing body)))) (quasiquote (match (unquote exp) ((unquote pat) (match-let* (unquote rest) (unquote-splicing body))))))) (caaar args) (cadaar args) (cdar args) (cdr args)) (g245))) (g245))))
! (defmacro match-letrec args (let ((g269 (cadddr match:expanders)) (g268 (lambda (p1 e1 p2 e2 body) (quasiquote (match-letrec ((((unquote p1) unquote p2) (cons (unquote e1) (unquote e2)))) (unquote-splicing body))))) (g264 (lambda () (match:syntax-err (quasiquote (match-letrec (unquote-splicing args))) "syntax error in"))) (g263 (lambda (pat exp body) (quasiquote (match-letrec (((unquote (list->vector pat)) (vector (unquote-splicing exp)))) (unquote-splicing body))))) (g255 (lambda (pat exp body) ((cadr match:expanders) pat exp body (quasiquote (match-letrec (((unquote pat) (unquote exp))) (unquote-splicing body))))))) (if (pair? args) (if (list? (car args)) (if (match:andmap (lambda (g275) (if (and (pair? g275) (g269 (car g275)) (pair? (cdr g275))) (null? (cddr g275)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (letrec (unquote-splicing args))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (g264))) (g264))))
! (defmacro match-define args (let ((g279 (cadddr match:expanders)) (g278 (lambda () (match:syntax-err (quasiquote (match-define (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (g279 (car args)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda () (quasiquote (begin (define (unquote-splicing args)))))) (g278)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda (pat exp) ((caddr match:expanders) pat exp (quasiquote (match-define (unquote-splicing args))))) (car args) (cadr args)) (g278))) (g278))))
! (define match:runtime-structures #f)
! (define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v)))
! (define match:primitive-vector? vector?)
! (defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
! (defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311))))
! (defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335)))))
--- 1,728 ----
! ;;
! 
! ;;;; match.scm -- portable hygienic pattern matcher
! ;;
! ;; This code is written by Alex Shinn and placed in the
! ;; Public Domain.  All warranties are disclaimed.
! 
! ;; This is a full superset of the popular MATCH package by Andrew
! ;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks
! ;; in R6RS SYNTAX-RULES), and thus preserving hygiene.
! 
! ;; This is a simple generative pattern matcher - each pattern is
! ;; expanded into the required tests, calling a failure continuation if
! ;; the tests fail.  This makes the logic easy to follow and extend,
! ;; but produces sub-optimal code in cases where you have many similar
! ;; clauses due to repeating the same tests.  Nonetheless a smart
! ;; compiler should be able to remove the redundant tests.  For
! ;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance
! ;; hit.
  
! ;; The original version was written on 2006/11/29 and described in the
! ;; following Usenet post:
! ;;   http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd
! ;; and is still available at
! ;;   http://synthcode.com/scheme/match-simple.scm
! ;; It's just 80 lines for the core MATCH, and an extra 40 lines for
! ;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar.
! ;;
! ;; A variant of this file which uses COND-EXPAND in a few places for
! ;; performance can be found at
! ;;   http://synthcode.com/scheme/match-cond-expand.scm
! ;;
! ;; 2010/05/20 - record matching for guile (Stefan Israelsson Tampe)
! ;; 2009/11/25 - adding `***' tree search patterns
! ;; 2008/03/20 - fixing bug where (a ...) matched non-lists
! ;; 2008/03/15 - removing redundant check in vector patterns
! ;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell)
! ;; 2007/09/04 - fixing quasiquote patterns
! ;; 2007/07/21 - allowing ellipse patterns in non-final list positions
! ;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
! ;;              (thanks to Taylor Campbell)
! ;; 2007/04/08 - clean up, commenting
! ;; 2006/12/24 - bugfixes
! ;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
  
  (define-module (ice-9 match)
!   #:use-module (srfi srfi-9)
!   #:export     (match-define match-let* match-let match-letrec match-lambda*
! 			     match-lambda match))
! 
! 
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;; force compile-time syntax errors with useful messages
! (define-syntax match-syntax-error
!   (syntax-rules ()
!     ((_) (match-syntax-error "invalid match-syntax-error usage"))))
! 
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! 
! ;; The basic interface.  MATCH just performs some basic syntax
! ;; validation, binds the match expression to a temporary variable `v',
! ;; and passes it on to MATCH-NEXT.  It's a constant throughout the
! ;; code below that the binding `v' is a direct variable reference, not
! ;; an expression.
! 
! (define-syntax match
!   (syntax-rules ()
!     ((match)
!      (match-syntax-error "missing match expression"))
!     ((match atom)
!      (match-syntax-error "no match clauses"))
!     ((match (app ...) (pat . body) ...)
!      (let ((v (app ...)))
!        (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
!     ((match #(vec ...) (pat . body) ...)
!      (let ((v #(vec ...)))
!        (match-next v (v (set! v)) (pat . body) ...)))
!     ((match atom (pat . body) ...)
!      (let ((v atom))
!        (match-next v (atom (set! atom)) (pat . body) ...)))
!     ))
! 
! ;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
! ;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
! ;; clauses.  `g+s' is a list of two elements, the get! and set!
! ;; expressions respectively.
! 
! (define-syntax match-next
!   (syntax-rules (=>)
!     ;; no more clauses, the match failed
!     ((match-next v g+s)
!      (error 'match "no matching pattern"))
!     ;; named failure continuation
!     ((match-next v g+s (pat (=> failure) . body) . rest)
!      (let ((failure (lambda () (match-next v g+s . rest))))
!        ;; match-one analyzes the pattern for us
!        (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
!     ;; anonymous failure continuation, give it a dummy name
!     ((match-next v g+s (pat . body) . rest)
!      (match-next v g+s (pat (=> failure) . body) . rest))))
! 
! ;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
! ;; MATCH-TWO.
! 
! (define-syntax match-one
!   (syntax-rules ()
!     ;; If it's a list of two or more values, check to see if the
!     ;; second one is an ellipse and handle accordingly, otherwise go
!     ;; to MATCH-TWO.
!     ((match-one v (p q . r) g+s sk fk i)
!      (match-check-ellipse
!       q
!       (match-extract-vars p (match-gen-ellipses v p r  g+s sk fk i) i ())
!       (match-two v (p q . r) g+s sk fk i)))
!     ;; Go directly to MATCH-TWO.
!     ((match-one . x)
!      (match-two . x))))
! 
! ;; This is the guts of the pattern matcher.  We are passed a lot of
! ;; information in the form:
! ;;
! ;;   (match-two var pattern getter setter success-k fail-k (ids ...))
! ;;
! ;; usually abbreviated
! ;;
! ;;   (match-two v p g+s sk fk i)
! ;;
! ;; where VAR is the symbol name of the current variable we are
! ;; matching, PATTERN is the current pattern, getter and setter are the
! ;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
! ;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
! ;; continuation (which is just a thunk call and is thus safe to expand
! ;; multiple times) and IDS are the list of identifiers bound in the
! ;; pattern so far.
! 
! (define-syntax match-two
!   (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
!     ((match-two v () g+s (sk ...) fk i)
!      (if (null? v) (sk ... i) fk))
!     ((match-two v (quote p) g+s (sk ...) fk i)
!      (if (equal? v 'p) (sk ... i) fk))
!     ((match-two v (quasiquote p) . x)
!      (match-quasiquote v p . x))
!     ((match-two v (and) g+s (sk ...) fk i) (sk ... i))
!     ((match-two v (and p q ...) g+s sk fk i)
!      (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
!     ((match-two v (or) g+s sk fk i) fk)
!     ((match-two v (or p) . x)
!      (match-one v p . x))
!     ((match-two v (or p ...) g+s sk fk i)
!      (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
!     ((match-two v (not p) g+s (sk ...) fk i)
!      (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
!     ((match-two v (get! getter) (g s) (sk ...) fk i)
!      (let ((getter (lambda () g))) (sk ... i)))
!     ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
!      (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
!     ((match-two v (? pred . p) g+s sk fk i)
!      (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
!     
!     ;; stis, added $ support!
!     ((match-two v ($ n) g-s sk fk i)
!      (if (n v) sk fk))
!     
!     ((match-two v ($ nn p ...) g+s sk fk i)
!      (if (nn v)
! 	 (match-$ (and) 0 (p ...) v sk fk i)
! 	 fk))
!      
!     ;; stis, added the possibility to use set! and get to records    
!     ((match-two v (= 0 m p) g+s sk fk i)
!      (let ((w  (struct-ref v m)))
!        (match-one w p ((struct-ref v m) (struct-set! v m)) sk fk i)))
! 
!     ((match-two v (= g s p) g+s sk fk i)
!      (let ((w (g v))) (match-one w p ((g v) (s v)) sk fk i)))
! 
!     ((match-two v (= proc p) g+s . x)
!      (let ((w (proc v))) '() (match-one w p . x)))
!     
!     ((match-two v (p ___ . r) g+s sk fk i)
!      (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
!     ((match-two v (p) g+s sk fk i)
!      (if (and (pair? v) (null? (cdr v)))
!          (let ((w (car v)))
!            (match-one w p ((car v) (set-car! v)) sk fk i))
!          fk))
!     ((match-two v (p *** q) g+s sk fk i)
!      (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
!     ((match-two v (p *** . q) g+s sk fk i)
!      (match-syntax-error "invalid use of ***" (p *** . q)))
!     ((match-two v (p . q) g+s sk fk i)
!      (if (pair? v)
!          (let ((w (car v)) (x (cdr v)))
!            (match-one w p ((car v) (set-car! v))
!                       (match-one x q ((cdr v) (set-cdr! v)) sk fk)
!                       fk
!                       i))
!          fk))
!     ((match-two v #(p ...) g+s . x)
!      (match-vector v 0 () (p ...) . x))
!     ((match-two v _ g+s (sk ...) fk i) (sk ... i))
!     ;; Not a pair or vector or special literal, test to see if it's a
!     ;; new symbol, in which case we just bind it, or if it's an
!     ;; already bound symbol or some other literal, in which case we
!     ;; compare it with EQUAL?.
!     ((match-two v x g+s (sk ...) fk (id ...))
!      (let-syntax
!          ((new-sym?
!            (syntax-rules (id ...)
!              ((new-sym? x sk2 fk2) sk2)
!              ((new-sym? y sk2 fk2) fk2))))
!        (new-sym? random-sym-to-match
!                  (let ((x v)) (sk ... (id ... x)))
!                  (if (equal? v x) (sk ... (id ...)) fk))))
!     ))
! 
! 
! (define-syntax match-$
!   (lambda (x)
!     (syntax-case x ()
!       ((q (a ...) m (p1 p2 ...) . v)
!        (with-syntax ((m+1 (datum->syntax (syntax q) 
! 					 (+ (syntax->datum (syntax m)) 1))))
! 	 (syntax (match-$ (a ... (= 0 m p1)) m+1 (p2 ...) . v))))
!       ((_ newpat  m ()            v kt ke i)
!        (syntax (match-one v newpat () kt ke i))))))
! 
! 
!  
! ;; QUASIQUOTE patterns
! 
! (define-syntax match-quasiquote
!   (syntax-rules (unquote unquote-splicing quasiquote)
!     ((_ v (unquote p) g+s sk fk i)
!      (match-one v p g+s sk fk i))
!     ((_ v ((unquote-splicing p) . rest) g+s sk fk i)
!      (if (pair? v)
!        (match-one v
!                   (p . tmp)
!                   (match-quasiquote tmp rest g+s sk fk)
!                   fk
!                   i)
!        fk))
!     ((_ v (quasiquote p) g+s sk fk i . depth)
!      (match-quasiquote v p g+s sk fk i #f . depth))
!     ((_ v (unquote p) g+s sk fk i x . depth)
!      (match-quasiquote v p g+s sk fk i . depth))
!     ((_ v (unquote-splicing p) g+s sk fk i x . depth)
!      (match-quasiquote v p g+s sk fk i . depth))
!     ((_ v (p . q) g+s sk fk i . depth)
!      (if (pair? v)
!        (let ((w (car v)) (x (cdr v)))
!          (match-quasiquote
!           w p g+s
!           (match-quasiquote-step x q g+s sk fk depth)
!           fk i . depth))
!        fk))
!     ((_ v #(elt ...) g+s sk fk i . depth)
!      (if (vector? v)
!        (let ((ls (vector->list v)))
!          (match-quasiquote ls (elt ...) g+s sk fk i . depth))
!        fk))
!     ((_ v x g+s sk fk i . depth)
!      (match-one v 'x g+s sk fk i))))
! 
! (define-syntax match-quasiquote-step
!   (syntax-rules ()
!     ((match-quasiquote-step x q g+s sk fk depth i)
!      (match-quasiquote x q g+s sk fk i . depth))))
! 
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;; Utilities
! 
! ;; Takes two values and just expands into the first.
! (define-syntax match-drop-ids
!   (syntax-rules ()
!     ((_ expr ids ...) expr)))
! 
! (define-syntax match-drop-first-arg
!   (syntax-rules ()
!     ((_ arg expr) expr)))
! 
! ;; To expand an OR group we try each clause in succession, passing the
! ;; first that succeeds to the success continuation.  On failure for
! ;; any clause, we just try the next clause, finally resorting to the
! ;; failure continuation fk if all clauses fail.  The only trick is
! ;; that we want to unify the identifiers, so that the success
! ;; continuation can refer to a variable from any of the OR clauses.
! 
! (define-syntax match-gen-or
!   (syntax-rules ()
!     ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
!      (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
!        (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
! 
! (define-syntax match-gen-or-step
!   (syntax-rules ()
!     ((_ v () g+s sk fk . x)
!      ;; no OR clauses, call the failure continuation
!      fk)
!     ((_ v (p) . x)
!      ;; last (or only) OR clause, just expand normally
!      (match-one v p . x))
!     ((_ v (p . q) g+s sk fk i)
!      ;; match one and try the remaining on failure
!      (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i))
!     ))
! 
! ;; We match a pattern (p ...) by matching the pattern p in a loop on
! ;; each element of the variable, accumulating the bound ids into lists.
! 
! ;; Look at the body of the simple case - it's just a named let loop,
! ;; matching each element in turn to the same pattern.  The only trick
! ;; is that we want to keep track of the lists of each extracted id, so
! ;; when the loop recurses we cons the ids onto their respective list
! ;; variables, and on success we bind the ids (what the user input and
! ;; expects to see in the success body) to the reversed accumulated
! ;; list IDs.
! 
! (define-syntax match-gen-ellipses
!   (syntax-rules ()
!     ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
!      (match-check-identifier p
!        ;; simplest case equivalent to (p ...), just bind the list
!        (let ((p v))
!          (if (list? p)
!              (sk ... i)
!              fk))
!        ;; simple case, match all elements of the list
!        (let loop ((ls v) (id-ls '()) ...)
!          (cond
!            ((null? ls)
!             (let ((id (reverse id-ls)) ...) (sk ... i)))
!            ((pair? ls)
!             (let ((w (car ls)))
!               (match-one w p ((car ls) (set-car! ls))
!                          (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
!                          fk i)))
!            (else
!             fk)))))
!     ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
!      ;; general case, trailing patterns to match, keep track of the
!      ;; remaining list length so we don't need any backtracking
!      (match-verify-no-ellipses
!       r
!       (let* ((tail-len (length 'r))
!              (ls v)
!              (len (length ls)))
!         (if (< len tail-len)
!             fk
!             (let loop ((ls ls) (n len) (id-ls '()) ...)
!               (cond
!                 ((= n tail-len)
!                  (let ((id (reverse id-ls)) ...)
!                    (match-one ls r (#f #f) (sk ... i) fk i)))
!                 ((pair? ls)
!                  (let ((w (car ls)))
!                    (match-one w p ((car ls) (set-car! ls))
!                               (match-drop-ids
!                                (loop (cdr ls) (- n 1) (cons id id-ls) ...))
!                               fk
!                               i)))
!                 (else
!                  fk)))))))))
! 
! ;; This is just a safety check.  Although unlike syntax-rules we allow
! ;; trailing patterns after an ellipses, we explicitly disable multiple
! ;; ellipses at the same level.  This is because in the general case
! ;; such patterns are exponential in the number of ellipses, and we
! ;; don't want to make it easy to construct very expensive operations
! ;; with simple looking patterns.  For example, it would be O(n^2) for
! ;; patterns like (a ... b ...) because we must consider every trailing
! ;; element for every possible break for the leading "a ...".
! 
! (define-syntax match-verify-no-ellipses
!   (syntax-rules ()
!     ((_ (x . y) sk)
!      (match-check-ellipse
!       x
!       (match-syntax-error
!        "multiple ellipse patterns not allowed at same level")
!       (match-verify-no-ellipses y sk)))
!     ((_ () sk)
!      sk)
!     ((_ x sk)
!      (match-syntax-error "dotted tail not allowed after ellipse" x))))
! 
! ;; Matching a tree search pattern is only slightly more complicated.
! ;; Here we allow patterns of the form
! ;;
! ;;     (x *** y)
! ;;
! ;; to represent the pattern y located somewhere in a tree where the
! ;; path from the current object to y can be seen as a list of the form
! ;; (X ...).  Y can immediately match the current object in which case
! ;; the path is the empty list.  In a sense it's a 2-dimensional
! ;; version of the ... pattern.
! ;;
! ;; As a common case the pattern (_ *** y) can be used to search for Y
! ;; anywhere in a tree, regardless of the path used.
! ;;
! ;; To implement the search, we use two recursive procedures.  TRY
! ;; attempts to match Y once, and on success it calls the normal SK on
! ;; the accumulated list ids as in MATCH-GEN-ELLIPSES.  On failure, we
! ;; call NEXT which first checks if the current value is a list
! ;; beginning with X, then calls TRY on each remaining element of the
! ;; list.  Since TRY will recursively call NEXT again on failure, this
! ;; effects a full depth-first search.
! ;;
! ;; The failure continuation throughout is a jump to the next step in
! ;; the tree search, initialized with the original failure continuation
! ;; FK.
! 
! (define-syntax match-gen-search
!   (syntax-rules ()
!     ((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
!      (letrec ((try (lambda (w fail id-ls ...)
!                      (match-one w q g+s
!                                 (match-drop-ids
!                                  (let ((id (reverse id-ls)) ...)
!                                    sk))
!                                 (next w fail id-ls ...) i)))
!               (next (lambda (w fail id-ls ...)
!                       (if (not (pair? w))
!                           (fail)
!                           (let ((u (car w)))
!                             (match-one
!                              u p ((car w) (set-car! w))
!                              (match-drop-ids
!                               ;; accumulate the head variables from
!                               ;; the p pattern, and loop over the tail
!                               (let ((id-ls (cons id id-ls)) ...)
!                                 (let lp ((ls (cdr w)))
!                                   (if (pair? ls)
!                                       (try (car ls)
!                                            (lambda () (lp (cdr ls)))
!                                            id-ls ...)
!                                       (fail)))))
!                              (fail) i))))))
!        ;; the initial id-ls binding here is a dummy to get the right
!        ;; number of '()s
!        (let ((id-ls '()) ...)
!          (try v (lambda () fk) id-ls ...))))))
! 
! ;; Vector patterns are just more of the same, with the slight
! ;; exception that we pass around the current vector index being
! ;; matched.
! 
! (define-syntax match-vector
!   (syntax-rules (___)
!     ((_ v n pats (p q) . x)
!      (match-check-ellipse q
!                           (match-gen-vector-ellipses v n pats p . x)
!                           (match-vector-two v n pats (p q) . x)))
!     ((_ v n pats (p ___) sk fk i)
!      (match-gen-vector-ellipses v n pats p sk fk i))
!     ((_ . x)
!      (match-vector-two . x))))
! 
! ;; Check the exact vector length, then check each element in turn.
! 
! (define-syntax match-vector-two
!   (syntax-rules ()
!     ((_ v n ((pat index) ...) () sk fk i)
!      (if (vector? v)
!          (let ((len (vector-length v)))
!            (if (= len n)
!                (match-vector-step v ((pat index) ...) sk fk i)
!                fk))
!          fk))
!     ((_ v n (pats ...) (p . q) . x)
!      (match-vector v (+ n 1) (pats ... (p n)) q . x))))
! 
! (define-syntax match-vector-step
!   (syntax-rules ()
!     ((_ v () (sk ...) fk i) (sk ... i))
!     ((_ v ((pat index) . rest) sk fk i)
!      (let ((w (vector-ref v index)))
!        (match-one w pat ((vector-ref v index) (vector-set! v index))
!                   (match-vector-step v rest sk fk)
!                   fk i)))))
! 
! ;; With a vector ellipse pattern we first check to see if the vector
! ;; length is at least the required length.
! 
! (define-syntax match-gen-vector-ellipses
!   (syntax-rules ()
!     ((_ v n ((pat index) ...) p sk fk i)
!      (if (vector? v)
!        (let ((len (vector-length v)))
!          (if (>= len n)
!            (match-vector-step v ((pat index) ...)
!                               (match-vector-tail v p n len sk fk)
!                               fk i)
!            fk))
!        fk))))
! 
! (define-syntax match-vector-tail
!   (syntax-rules ()
!     ((_ v p n len sk fk i)
!      (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
! 
! (define-syntax match-vector-tail-two
!   (syntax-rules ()
!     ((_ v p n len (sk ...) fk i ((id id-ls) ...))
!      (let loop ((j n) (id-ls '()) ...)
!        (if (>= j len)
!          (let ((id (reverse id-ls)) ...) (sk ... i))
!          (let ((w (vector-ref v j)))
!            (match-one w p ((vector-ref v j) (vetor-set! v j))
!                       (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
!                       fk i)))))))
! 
! ;; Extract all identifiers in a pattern.  A little more complicated
! ;; than just looking for symbols, we need to ignore special keywords
! ;; and non-pattern forms (such as the predicate expression in ?
! ;; patterns), and also ignore previously bound identifiers.
! ;;
! ;; Calls the continuation with all new vars as a list of the form
! ;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely
! ;; pair with the original variable (e.g. it's used in the ellipse
! ;; generation for list variables).
! ;;
! ;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
! 
! (define-syntax match-extract-vars
!   (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!)
!     ((match-extract-vars (? pred . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars ($ rec . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (= proc p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (= u m p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (quote x) (k ...) i v)
!      (k ... v))
!     ((match-extract-vars (quasiquote x) k i v)
!      (match-extract-quasiquote-vars x k i v (#t)))
!     ((match-extract-vars (and . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (or . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (not . p) . x)
!      (match-extract-vars p . x))
!     ;; A non-keyword pair, expand the CAR with a continuation to
!     ;; expand the CDR.
!     ((match-extract-vars (p q . r) k i v)
!      (match-check-ellipse
!       q
!       (match-extract-vars (p . r) k i v)
!       (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
!     ((match-extract-vars (p . q) k i v)
!      (match-extract-vars p (match-extract-vars-step q k i v) i ()))
!     ((match-extract-vars #(p ...) . x)
!      (match-extract-vars (p ...) . x))
!     ((match-extract-vars _ (k ...) i v)    (k ... v))
!     ((match-extract-vars ___ (k ...) i v)  (k ... v))
!     ((match-extract-vars *** (k ...) i v)  (k ... v))
!     ;; This is the main part, the only place where we might add a new
!     ;; var if it's an unbound symbol.
!     ((match-extract-vars p (k ...) (i ...) v)
!      (let-syntax
!          ((new-sym?
!            (syntax-rules (i ...)
!              ((new-sym? p sk fk) sk)
!              ((new-sym? x sk fk) fk))))
!        (new-sym? random-sym-to-match
!                  (k ... ((p p-ls) . v))
!                  (k ... v))))
!     ))
! 
! ;; Stepper used in the above so it can expand the CAR and CDR
! ;; separately.
! 
! (define-syntax match-extract-vars-step
!   (syntax-rules ()
!     ((_ p k i v ((v2 v2-ls) ...))
!      (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
!     ))
! 
! (define-syntax match-extract-quasiquote-vars
!   (syntax-rules (quasiquote unquote unquote-splicing)
!     ((match-extract-quasiquote-vars (quasiquote x) k i v d)
!      (match-extract-quasiquote-vars x k i v (#t . d)))
!     ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
!      (match-extract-quasiquote-vars (unquote x) k i v d))
!     ((match-extract-quasiquote-vars (unquote x) k i v (#t))
!      (match-extract-vars x k i v))
!     ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
!      (match-extract-quasiquote-vars x k i v d))
!     ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
!      (match-extract-quasiquote-vars
!       x
!       (match-extract-quasiquote-vars-step y k i v d) i ()))
!     ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
!      (match-extract-quasiquote-vars (x ...) k i v d))
!     ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
!      (k ... v))
!     ))
! 
! (define-syntax match-extract-quasiquote-vars-step
!   (syntax-rules ()
!     ((_ x k i v d ((v2 v2-ls) ...))
!      (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
!     ))
! 
! 
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;; Gimme some sugar baby.
! (define-syntax match-lambda
!   (syntax-rules ()
!     ((_ clause ...) (lambda (expr) (match expr clause ...)))))
! 
! (define-syntax match-lambda*
!   (syntax-rules ()
!     ((_ clause ...) (lambda expr (match expr clause ...)))))
! 
! (define-syntax match-let
!   (syntax-rules ()
!     ((_ (vars ...) . body)
!      (match-let/helper let () () (vars ...) . body))
!     ((_ loop . rest)
!      (match-named-let loop () . rest))))
! 
! (define-syntax match-letrec
!   (syntax-rules ()
!     ((_ vars . body) (match-let/helper letrec () () vars . body))))
! 
! (define-syntax match-let/helper
!   (syntax-rules ()
!     ((_ let ((var expr) ...) () () . body)
!      (let ((var expr) ...) . body))
!     ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
!      (let ((var expr) ...)
!        (match-let* ((pat tmp) ...)
!          . body)))
!     ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
!      (match-let/helper
!       let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
!     ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
!      (match-let/helper
!       let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
!     ((_ let (v ...) (p ...) ((a expr) . rest) . body)
!      (match-let/helper let (v ... (a expr)) (p ...) rest . body))))
! 
! (define-syntax match-named-let
!   (syntax-rules ()
!     ((_ loop ((pat expr var) ...) () . body)
!      (let loop ((var expr) ...)
!        (match-let ((pat var) ...)
!          . body)))
!     ((_ loop (v ...) ((pat expr) . rest) . body)
!      (match-named-let loop (v ... (pat expr tmp)) rest . body))))
! 
! (define-syntax match-let*
!   (syntax-rules ()
!     ((_ () . body)
!      (begin . body))
!     ((_ ((pat expr) . rest) . body)
!      (match expr (pat (match-let* rest . body))))))
! 
! 
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;; Otherwise COND-EXPANDed bits.
! 
! ;; This *should* work, but doesn't :(
! ;;   (define-syntax match-check-ellipse
! ;;     (syntax-rules (...)
! ;;       ((_ ... sk fk) sk)
! ;;       ((_ x sk fk) fk)))
! 
! ;; This is a little more complicated, and introduces a new let-syntax,
! ;; but should work portably in any R[56]RS Scheme.  Taylor Campbell
! ;; originally came up with the idea.
! (define-syntax match-check-ellipse
!   (syntax-rules ()
!     ;; these two aren't necessary but provide fast-case failures
!     ((match-check-ellipse (a . b) success-k failure-k) failure-k)
!     ((match-check-ellipse #(a ...) success-k failure-k) failure-k)
!     ;; matching an atom
!     ((match-check-ellipse id success-k failure-k)
!      (let-syntax ((ellipse? (syntax-rules ()
!                               ;; iff `id' is `...' here then this will
!                               ;; match a list of any length
!                               ((ellipse? (foo id) sk fk) sk)
!                               ((ellipse? other sk fk) fk))))
!        ;; this list of three elements will only many the (foo id) list
!        ;; above if `id' is `...'
!        (ellipse? (a b c) success-k failure-k)))))
! 
! 
! ;; This is portable but can be more efficient with non-portable
! ;; extensions.  This trick was originally discovered by Oleg Kiselyov.
! 
! (define-syntax match-check-identifier
!   (syntax-rules ()
!     ;; fast-case failures, lists and vectors are not identifiers
!     ((_ (x . y) success-k failure-k) failure-k)
!     ((_ #(x ...) success-k failure-k) failure-k)
!     ;; x is an atom
!     ((_ x success-k failure-k)
!      (let-syntax
!          ((sym?
!            (syntax-rules ()
!              ;; if the symbol `abracadabra' matches x, then x is a
!              ;; symbol
!              ((sym? x sk fk) sk)
!              ;; otherwise x is a non-symbol datum
!              ((sym? y sk fk) fk))))
!        (sym? abracadabra success-k failure-k)))))
! 
! (defmacro match-define (arg code)
!   (let* ((vars  (macroexpand `(match-extract-vars ,arg () () ())))
! 	 (vars  (map car (car vars)))
! 	 (vars2 (map (lambda (x)    (gensym "x"))   vars))
! 	 (sets  (map (lambda (x y) `(set! ,x ,y))   vars2 vars))
! 	 (sets2 (map (lambda (x y) `(set! ,x ,y))   vars  vars2))
! 	 (lets  (map (lambda (x)   `(,x #f))        vars2))
! 	 (defs  (map (lambda (x)   `(define ,x #f)) vars)))
!     
!     `(begin
!        ,@defs
!        (let ,lets
! 	 (match ,code (,arg (begin ,@sets)))
! 	 ,@sets2))))
!