guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. release_1-9-11-75-g89


From: Ludovic Courtès
Subject: [Guile-commits] GNU Guile branch, master, updated. release_1-9-11-75-g89cdf5a
Date: Wed, 16 Jun 2010 22:49:48 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=89cdf5a3793379432c7a9399aa242b2923e1451a

The branch, master has been updated
       via  89cdf5a3793379432c7a9399aa242b2923e1451a (commit)
       via  cec386d1bb92b08275d2ec42776187f837146012 (commit)
       via  d967913f05301a35573c5d3f7217d0994bbb1016 (commit)
      from  e44d2e4d9884c25b746b95690bcfb601547220fd (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 89cdf5a3793379432c7a9399aa242b2923e1451a
Author: Ludovic Courtès <address@hidden>
Date:   Thu Jun 17 00:44:34 2010 +0200

    Remove outdated sponsorship info from `THANKS'.

commit cec386d1bb92b08275d2ec42776187f837146012
Author: Ludovic Courtès <address@hidden>
Date:   Thu Jun 17 00:42:20 2010 +0200

    Update `THANKS'.

commit d967913f05301a35573c5d3f7217d0994bbb1016
Author: Ludovic Courtès <address@hidden>
Date:   Thu Jun 17 00:06:20 2010 +0200

    Use Alex Shinn's pattern matcher for (ice-9 match).
    
    * module/ice-9/match.scm: Rewrite to simply load `match.upstream.scm'.
    
    * module/ice-9/match.upstream.scm: New file.
    
    * module/Makefile.am (NOCOMP_SOURCES): Add `ice-9/match.upstream.scm'.
    
    * test-suite/Makefile.am (SCM_TESTS): Add `tests/match.test'.
    
    * test-suite/tests/match.test: New file.

-----------------------------------------------------------------------

Summary of changes:
 THANKS                          |    6 +-
 module/Makefile.am              |    1 +
 module/ice-9/match.scm          |  226 ++-----------
 module/ice-9/match.upstream.scm |  670 +++++++++++++++++++++++++++++++++++++++
 test-suite/Makefile.am          |    1 +
 test-suite/tests/match.test     |   82 +++++
 6 files changed, 788 insertions(+), 198 deletions(-)
 create mode 100644 module/ice-9/match.upstream.scm
 create mode 100644 test-suite/tests/match.test

diff --git a/THANKS b/THANKS
index 96f22fb..403ff97 100644
--- a/THANKS
+++ b/THANKS
@@ -1,5 +1,6 @@
 Contributors since the last release:
 
+           Jim Bender
            Rob Browning
         Ludovic Courtès
          Julian Graham
@@ -13,13 +14,10 @@ Contributors since the last release:
          Jose A Ortega Ruiz
          Kevin Ryde
           Bill Schottstaedt
+          Alex Shinn
         Richard Todd
            Andy Wingo
 
-Sponsors since the last release:
-
-      The Linux Developers Group
-
 For fixes or providing information which led to a fix:
 
           David Allouche
diff --git a/module/Makefile.am b/module/Makefile.am
index 3668622..9ff50f8 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -342,6 +342,7 @@ EXTRA_DIST += oop/ChangeLog-2008
 
 NOCOMP_SOURCES =                               \
   ice-9/gds-client.scm                         \
+  ice-9/match.upstream.scm                     \
   ice-9/psyntax.scm                            \
   ice-9/r6rs-libraries.scm                     \
   ice-9/quasisyntax.scm                                \
diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm
index d758923..cbb2525 100644
--- a/module/ice-9/match.scm
+++ b/module/ice-9/match.scm
@@ -1,199 +1,37 @@
-;;; 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
-;;;;
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2010 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))
+  #:export (match
+            match-lambda
+            match-lambda*
+            match-let
+            match-let*
+            match-letrec))
 
-;; 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
+(define (error _ msg)
+  ;; Error procedure for run-time "no matching pattern" errors.
+  (throw 'match-error "match" msg))
 
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; 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.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Compared to Andrew K. Wright's `match', this one lacks `match-define',
+;; `match:error-control', `match:set-error-control', `match:error',
+;; `match:set-error', and all structure-related procedures.
 
-(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)))))
+;; Unmodified public domain code by Alex Shinn retrieved from
+;; <http://synthcode.com/scheme/match.scm>.
+(include-from-path "ice-9/match.upstream.scm")
diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
new file mode 100644
index 0000000..963b89f
--- /dev/null
+++ b/module/ice-9/match.upstream.scm
@@ -0,0 +1,670 @@
+;;;; 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
+;;
+;; 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!
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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) ...)
+     (match-next atom (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))
+    ((match-two v (= proc p) . 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))))
+    ))
+
+;; 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 (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)))))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 7d65645..9b52e3b 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -61,6 +61,7 @@ SCM_TESTS = tests/00-initial-env.test         \
            tests/keywords.test                 \
            tests/list.test                     \
            tests/load.test                     \
+           tests/match.test                    \
            tests/modules.test                  \
            tests/multilingual.nottest          \
            tests/net-db.test                   \
diff --git a/test-suite/tests/match.test b/test-suite/tests/match.test
new file mode 100644
index 0000000..70a15ec
--- /dev/null
+++ b/test-suite/tests/match.test
@@ -0,0 +1,82 @@
+;;;; match.test --- (ice-9 match)  -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;;   Copyright (C) 2010 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 (test-match)
+  #:use-module (ice-9 match)
+  #:use-module (test-suite lib))
+
+(define exception:match-error
+  (cons 'match-error "^.*$"))
+
+
+(with-test-prefix "matches"
+
+  (pass-if "wildcard"
+    (match "hello" (_ #t)))
+
+  (pass-if "symbol"
+    (match 'foo ('foo #t)))
+
+  (pass-if "string"
+    (match "bar" ("bar" #t)))
+
+  (pass-if "number"
+    (match 777 (777 #t)))
+
+  (pass-if "char"
+    (match #\g (#\g #t)))
+
+  (pass-if "sexp"
+    (match '(a b c) ('(a b c) #t)))
+
+  (pass-if "predicate"
+    (match '(a 1 2)
+      (('a (and (? odd?) one) (? even?))
+       (= one 1))))
+
+  (pass-if "list"
+    (let ((lst '(a b c)))
+      (match lst
+        ((x y z)
+         (equal? (list x y z) lst)))))
+
+  (pass-if "list rest..."
+    (let ((lst '(a b c)))
+      (match lst
+        ((x rest ...)
+         (and (eq? x 'a) (equal? rest '(b c)))))))
+
+  (pass-if "list . rest"
+    (let ((lst '(a b c)))
+      (match lst
+        ((x . rest)
+         (and (eq? x 'a) (equal? rest '(b c)))))))
+
+  (pass-if "tree"
+    (let ((tree '(one (two 2) (three 3 (and 4 (and 5))))))
+      (match tree
+        (('one ('two x) ('three y ('and z '(and 5))))
+         (equal? (list x y z) '(2 3 4)))))))
+
+
+(with-test-prefix "doesn't match"
+
+  (pass-if-exception "tree"
+    exception:match-error
+    (match '(a (b c))
+      ((foo (bar)) #t))))


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]