Update (ice-9 match) from Chibi-Scheme.

* module/ice-9/match.scm (slot-ref, slot-set!, is-a?): New macros.

* module/ice-9/match.upstream.scm: Update from Chibi-Scheme.

* test-suite/Makefile.am (SCM_TESTS): Add `tests/match.test.upstream'.

* test-suite/tests/match.test (rtd-2-slots, rtd-3-slots): New record
  types.
  ("matches")["records"]: New test prefix.
  ("doesn't match")["records"]: New test prefix.
  Include `match.test.upstream'.

* test-suite/vm/t-match.scm (matches?): Fix `$' example.

6 files changed, 552 insertions, 45 deletions

diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm
index 7cedff0bd..686539bd3 100644
--- a/module/ice-9/match.scm
+++ b/module/ice-9/match.scm
@@ -1,6 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 ;;;
-;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2011 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
@@ -28,11 +28,32 @@
   ;; Error procedure for run-time "no matching pattern" errors.
   (throw 'match-error "match" msg))
 
+;; Support for record matching.
+
+(define-syntax slot-ref
+  (syntax-rules ()
+    ((_ rtd rec n)
+     (struct-ref rec n))))
+
+(define-syntax slot-set!
+  (syntax-rules ()
+    ((_ rtd rec n value)
+     (struct-set! rec n value))))
+
+(define-syntax is-a?
+  (syntax-rules ()
+    ((_ rec rtd)
+     (and (struct? rec)
+          (eq? (struct-vtable rec) rtd)))))
+
 ;; 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.  Also,
 ;; `match' doesn't support clauses of the form `(pat => exp)'.
 
 ;; Unmodified public domain code by Alex Shinn retrieved from
-;; <http://synthcode.com/scheme/match.scm>.
+;; the Chibi-Scheme repository, commit 833:6daa2971f3fe.
+;;
+;; Note: Make sure to update `match.test.upstream' when updating this
+;; file.
 (include-from-path "ice-9/match.upstream.scm")
diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
index df6b3d914..6fc01a6f3 100644
--- a/module/ice-9/match.upstream.scm
+++ b/module/ice-9/match.upstream.scm
@@ -1,20 +1,203 @@
 ;;;; match.scm -- portable hygienic pattern matcher
+;;;; -*- coding: utf-8 -*-
 ;;
 ;; 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.
+;;> @example-import[(srfi 9)]
 
-;; 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.
+;;> This is a full superset of the popular @hyperlink[
+;;> "http://www.cs.indiana.edu/scheme-repository/code.match.html"]{match}
+;;> package by Andrew Wright, written in fully portable @scheme{syntax-rules}
+;;> and thus preserving hygiene.
+
+;;> The most notable extensions are the ability to use @emph{non-linear}
+;;> patterns - patterns in which the same identifier occurs multiple
+;;> times, tail patterns after ellipsis, and the experimental tree patterns.
+
+;;> @subsubsection{Patterns}
+
+;;> Patterns are written to look like the printed representation of
+;;> the objects they match.  The basic usage is
+
+;;> @scheme{(match expr (pat body ...) ...)}
+
+;;> where the result of @var{expr} is matched against each pattern in
+;;> turn, and the corresponding body is evaluated for the first to
+;;> succeed.  Thus, a list of three elements matches a list of three
+;;> elements.
+
+;;> @example{(let ((ls (list 1 2 3))) (match ls ((1 2 3) #t)))}
+
+;;> If no patterns match an error is signalled.
+
+;;> Identifiers will match anything, and make the corresponding
+;;> binding available in the body.
+
+;;> @example{(match (list 1 2 3) ((a b c) b))}
+
+;;> If the same identifier occurs multiple times, the first instance
+;;> will match anything, but subsequent instances must match a value
+;;> which is @scheme{equal?} to the first.
+
+;;> @example{(match (list 1 2 1) ((a a b) 1) ((a b a) 2))}
+
+;;> The special identifier @scheme{_} matches anything, no matter how
+;;> many times it is used, and does not bind the result in the body.
+
+;;> @example{(match (list 1 2 1) ((_ _ b) 1) ((a b a) 2))}
+
+;;> To match a literal identifier (or list or any other literal), use
+;;> @scheme{quote}.
+
+;;> @example{(match 'a ('b 1) ('a 2))}
+
+;;> Analogous to its normal usage in scheme, @scheme{quasiquote} can
+;;> be used to quote a mostly literally matching object with selected
+;;> parts unquoted.
+
+;;> @example|{(match (list 1 2 3) (`(1 ,b ,c) (list b c)))}|
+
+;;> Often you want to match any number of a repeated pattern.  Inside
+;;> a list pattern you can append @scheme{...} after an element to
+;;> match zero or more of that pattern (like a regexp Kleene star).
+
+;;> @example{(match (list 1 2) ((1 2 3 ...) #t))}
+;;> @example{(match (list 1 2 3) ((1 2 3 ...) #t))}
+;;> @example{(match (list 1 2 3 3 3) ((1 2 3 ...) #t))}
+
+;;> Pattern variables matched inside the repeated pattern are bound to
+;;> a list of each matching instance in the body.
+
+;;> @example{(match (list 1 2) ((a b c ...) c))}
+;;> @example{(match (list 1 2 3) ((a b c ...) c))}
+;;> @example{(match (list 1 2 3 4 5) ((a b c ...) c))}
+
+;;> More than one @scheme{...} may not be used in the same list, since
+;;> this would require exponential backtracking in the general case.
+;;> However, @scheme{...} need not be the final element in the list,
+;;> and may be succeeded by a fixed number of patterns.
+
+;;> @example{(match (list 1 2 3 4) ((a b c ... d e) c))}
+;;> @example{(match (list 1 2 3 4 5) ((a b c ... d e) c))}
+;;> @example{(match (list 1 2 3 4 5 6 7) ((a b c ... d e) c))}
+
+;;> @scheme{___} is provided as an alias for @scheme{...} when it is
+;;> inconvenient to use the ellipsis (as in a syntax-rules template).
+
+;;> The @scheme{..1} syntax is exactly like the @scheme{...} except
+;;> that it matches one or more repetitions (like a regexp "+").
+
+;;> @example{(match (list 1 2) ((a b c ..1) c))}
+;;> @example{(match (list 1 2 3) ((a b c ..1) c))}
+
+;;> The boolean operators @scheme{and}, @scheme{or} and @scheme{not}
+;;> can be used to group and negate patterns analogously to their
+;;> Scheme counterparts.
+
+;;> The @scheme{and} operator ensures that all subpatterns match.
+;;> This operator is often used with the idiom @scheme{(and x pat)} to
+;;> bind @var{x} to the entire value that matches @var{pat}
+;;> (c.f. "as-patterns" in ML or Haskell).  Another common use is in
+;;> conjunction with @scheme{not} patterns to match a general case
+;;> with certain exceptions.
+
+;;> @example{(match 1 ((and) #t))}
+;;> @example{(match 1 ((and x) x))}
+;;> @example{(match 1 ((and x 1) x))}
+
+;;> The @scheme{or} operator ensures that at least one subpattern
+;;> matches.  If the same identifier occurs in different subpatterns,
+;;> it is matched independently.  All identifiers from all subpatterns
+;;> are bound if the @scheme{or} operator matches, but the binding is
+;;> only defined for identifiers from the subpattern which matched.
+
+;;> @example{(match 1 ((or) #t) (else #f))}
+;;> @example{(match 1 ((or x) x))}
+;;> @example{(match 1 ((or x 2) x))}
+
+;;> The @scheme{not} operator succeeds if the given pattern doesn't
+;;> match.  None of the identifiers used are available in the body.
+
+;;> @example{(match 1 ((not 2) #t))}
+
+;;> The more general operator @scheme{?} can be used to provide a
+;;> predicate.  The usage is @scheme{(? predicate pat ...)} where
+;;> @var{predicate} is a Scheme expression evaluating to a predicate
+;;> called on the value to match, and any optional patterns after the
+;;> predicate are then matched as in an @scheme{and} pattern.
+
+;;> @example{(match 1 ((? odd? x) x))}
+
+;;> The field operator @scheme{=} is used to extract an arbitrary
+;;> field and match against it.  It is useful for more complex or
+;;> conditional destructuring that can't be more directly expressed in
+;;> the pattern syntax.  The usage is @scheme{(= field pat)}, where
+;;> @var{field} can be any expression, and should result in a
+;;> procedure of one argument, which is applied to the value to match
+;;> to generate a new value to match against @var{pat}.
+
+;;> Thus the pattern @scheme{(and (= car x) (= cdr y))} is equivalent
+;;> to @scheme{(x . y)}, except it will result in an immediate error
+;;> if the value isn't a pair.
+
+;;> @example{(match '(1 . 2) ((= car x) x))}
+;;> @example{(match 4 ((= sqrt x) x))}
+
+;;> The record operator @scheme{$} is used as a concise way to match
+;;> records defined by SRFI-9 (or SRFI-99).  The usage is
+;;> @scheme{($ rtd field ...)}, where @var{rtd} should be the record
+;;> type descriptor specified as the first argument to
+;;> @scheme{define-record-type}, and each @var{field} is a subpattern
+;;> matched against the fields of the record in order.  Not all fields
+;;> must be present.
+
+;;> @example{
+;;> (let ()
+;;>   (define-record-type employee
+;;>     (make-employee name title)
+;;>     employee?
+;;>     (name get-name)
+;;>     (title get-title))
+;;>   (match (make-employee "Bob" "Doctor")
+;;>     (($ employee n t) (list t n))))
+;;> }
+
+;;> The @scheme{set!} and @scheme{get!} operators are used to bind an
+;;> identifier to the setter and getter of a field, respectively.  The
+;;> setter is a procedure of one argument, which mutates the field to
+;;> that argument.  The getter is a procedure of no arguments which
+;;> returns the current value of the field.
+
+;;> @example{(let ((x (cons 1 2))) (match x ((1 . (set! s)) (s 3) x)))}
+;;> @example{(match '(1 . 2) ((1 . (get! g)) (g)))}
+
+;;> The new operator @scheme{***} can be used to search a tree for
+;;> subpatterns.  A pattern of the form @scheme{(x *** y)} represents
+;;> the subpattern @var{y} located somewhere in a tree where the path
+;;> from the current object to @var{y} can be seen as a list of the
+;;> form @scheme{(x ...)}.  @var{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 @scheme{...} pattern.
+
+;;> As a common case the pattern @scheme{(_ *** y)} can be used to
+;;> search for @var{y} anywhere in a tree, regardless of the path
+;;> used.
+
+;;> @example{(match '(a (a (a b))) ((x *** 'b) x))}
+;;> @example{(match '(a (b) (c (d e) (f g))) ((x *** 'g) x))}
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Notes
+
+;; The implementation 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:
@@ -28,6 +211,9 @@
 ;; performance can be found at
 ;;   http://synthcode.com/scheme/match-cond-expand.scm
 ;;
+;; 2011/01/27 - fixing bug when matching tail patterns against improper lists
+;; 2010/09/26 - adding `..1' patterns (thanks to Ludovic Courtès)
+;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns
 ;; 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
@@ -49,6 +235,21 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+;;> @subsubsection{Syntax}
+
+;;> @subsubsubsection{@rawcode{(match expr (pattern . body) ...)@br{}
+;;> (match expr (pattern (=> failure) . body) ...)}}
+
+;;> The result of @var{expr} is matched against each @var{pattern} in
+;;> turn, according to the pattern rules described in the previous
+;;> section, until the the first @var{pattern} matches.  When a match is
+;;> found, the corresponding @var{body}s are evaluated in order,
+;;> and the result of the last expression is returned as the result
+;;> of the entire @scheme{match}.  If a @var{failure} is provided,
+;;> then it is bound to a procedure of no arguments which continues,
+;;> processing at the next @var{pattern}.  If no @var{pattern} matches,
+;;> an error is signalled.
+
 ;; 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
@@ -165,6 +366,10 @@
      (if (pair? v)
          (match-one v (p ___) g+s sk fk i)
          fk))
+    ((match-two v ($ rec p ...) g+s sk fk i)
+     (if (is-a? v rec)
+         (match-record-refs v rec 0 (p ...) g+s sk fk i)
+         fk))
     ((match-two v (p . q) g+s sk fk i)
      (if (pair? v)
          (let ((w (car v)) (x (cdr v)))
@@ -240,6 +445,11 @@
   (syntax-rules ()
     ((_ expr ids ...) expr)))
 
+(define-syntax match-tuck-ids
+  (syntax-rules ()
+    ((_ (letish args (expr ...)) ids ...)
+     (letish args (expr ... ids ...)))))
+
 (define-syntax match-drop-first-arg
   (syntax-rules ()
     ((_ arg expr) expr)))
@@ -309,14 +519,14 @@
       r
       (let* ((tail-len (length 'r))
              (ls v)
-             (len (length ls)))
-        (if (< len tail-len)
+             (len (and (list? ls) (length ls))))
+        (if (or (not len) (< 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)))
+                   (match-one ls r (#f #f) (sk ...) fk i)))
                 ((pair? ls)
                  (let ((w (car ls)))
                    (match-one w p ((car ls) (set-car! ls))
@@ -349,21 +559,7 @@
     ((_ 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
+;; To implement the tree 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
@@ -380,7 +576,7 @@
     ((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
+                                (match-tuck-ids
                                  (let ((id (reverse id-ls)) ...)
                                    sk))
                                 (next w fail id-ls ...) i)))
@@ -475,6 +671,15 @@
                       (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
                       fk i)))))))
 
+(define-syntax match-record-refs
+  (syntax-rules ()
+    ((_ v rec n (p . q) g+s sk fk i)
+     (let ((w (slot-ref rec v n)))
+       (match-one w p ((slot-ref rec v n) (slot-set! rec v n))
+                  (match-record-refs v rec (+ n 1) q g+s sk fk) fk i)))
+    ((_ v rec n () g+s (sk ...) fk i)
+     (sk ... 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 ?
@@ -518,8 +723,8 @@
      (match-extract-vars (p ...) . x))
     ((match-extract-vars _ (k ...) i v)    (k ... v))
     ((match-extract-vars ___ (k ...) i v)  (k ... v))
-    ((match-extract-vars ..1 (k ...) i v)  (k ... v))
     ((match-extract-vars *** (k ...) i v)  (k ... v))
+    ((match-extract-vars ..1 (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)
@@ -527,7 +732,7 @@
          ((new-sym?
            (syntax-rules (i ...)
              ((new-sym? p sk fk) sk)
-             ((new-sym? x sk fk) fk))))
+             ((new-sym? any sk fk) fk))))
        (new-sym? random-sym-to-match
                  (k ... ((p p-ls) . v))
                  (k ... v))))
@@ -572,24 +777,42 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Gimme some sugar baby.
 
+;;> Shortcut for @scheme{lambda} + @scheme{match}.  Creates a
+;;> procedure of one argument, and matches that argument against each
+;;> clause.
+
 (define-syntax match-lambda
   (syntax-rules ()
-    ((_ clause ...) (lambda (expr) (match expr clause ...)))))
+    ((_ (pattern . body) ...) (lambda (expr) (match expr (pattern . body) ...)))))
+
+;;> Similar to @scheme{match-lambda}.  Creates a procedure of any
+;;> number of arguments, and matches the argument list against each
+;;> clause.
 
 (define-syntax match-lambda*
   (syntax-rules ()
-    ((_ clause ...) (lambda expr (match expr clause ...)))))
+    ((_ (pattern . body) ...) (lambda expr (match expr (pattern . body) ...)))))
+
+;;> Matches each var to the corresponding expression, and evaluates
+;;> the body with all match variables in scope.  Raises an error if
+;;> any of the expressions fail to match.  Syntax analogous to named
+;;> let can also be used for recursive functions which match on their
+;;> arguments as in @scheme{match-lambda*}.
 
 (define-syntax match-let
   (syntax-rules ()
-    ((_ (vars ...) . body)
-     (match-let/helper let () () (vars ...) . body))
-    ((_ loop . rest)
-     (match-named-let loop () . rest))))
+    ((_ ((var value) ...) . body)
+     (match-let/helper let () () ((var value) ...) . body))
+    ((_ loop ((var init) ...) . body)
+     (match-named-let loop ((var init) ...) . body))))
+
+;;> Similar to @scheme{match-let}, but analogously to @scheme{letrec}
+;;> matches and binds the variables with all match variables in scope.
 
 (define-syntax match-letrec
   (syntax-rules ()
-    ((_ vars . body) (match-let/helper letrec () () vars . body))))
+    ((_ ((var value) ...) . body)
+     (match-let/helper letrec () () ((var value) ...) . body))))
 
 (define-syntax match-let/helper
   (syntax-rules ()
@@ -617,6 +840,12 @@
     ((_ loop (v ...) ((pat expr) . rest) . body)
      (match-named-let loop (v ... (pat expr tmp)) rest . body))))
 
+;;> @subsubsubsection{@rawcode{(match-let* ((var value) ...) body ...)}}
+
+;;> Similar to @scheme{match-let}, but analogously to @scheme{let*}
+;;> matches and binds the variables in sequence, with preceding match
+;;> variables in scope.
+
 (define-syntax match-let*
   (syntax-rules ()
     ((_ () . body)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 8ee570b32..05aee7837 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -67,6 +67,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/list.test			\
 	    tests/load.test			\
 	    tests/match.test			\
+	    tests/match.test.upstream		\
 	    tests/modules.test			\
 	    tests/multilingual.nottest		\
 	    tests/net-db.test			\
diff --git a/test-suite/tests/match.test b/test-suite/tests/match.test
index f2e670c08..93358fc27 100644
--- a/test-suite/tests/match.test
+++ b/test-suite/tests/match.test
@@ -1,6 +1,6 @@
 ;;;; match.test --- (ice-9 match)  -*- mode: scheme; coding: utf-8; -*-
 ;;;;
-;;;; 	Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2010, 2011 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
@@ -18,11 +18,25 @@
 
 (define-module (test-match)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
   #:use-module (test-suite lib))
 
 (define exception:match-error
   (cons 'match-error "^.*$"))
 
+(define-record-type rtd-2-slots
+  (make-2-slot-record a b)
+  two-slot-record?
+  (a slot-first)
+  (b slot-second))
+
+(define-record-type rtd-3-slots
+  (make-3-slot-record a b c)
+  three-slot-record?
+  (a slot-one)
+  (b slot-two)
+  (c slot-three))
+
 
 (with-test-prefix "matches"
 
@@ -86,7 +100,49 @@
     (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)))))))
+         (equal? (list x y z) '(2 3 4))))))
+
+  (with-test-prefix "records"
+
+    (pass-if "all slots, bind"
+      (let ((r (make-3-slot-record 1 2 3)))
+        (match r
+          (($ rtd-3-slots a b c)
+           (equal? (list a b c) '(1 2 3))))))
+
+    (pass-if "all slots, literals"
+      (let ((r (make-3-slot-record 1 2 3)))
+        (match r
+          (($ rtd-3-slots 1 2 3)
+           #t))))
+
+    (pass-if "2 slots"
+      (let ((r (make-3-slot-record 1 2 3)))
+        (match r
+          (($ rtd-3-slots x y)
+           (equal? (list x y) '(1 2))))))
+
+    (pass-if "RTD correctly checked"
+      (let ((r (make-2-slot-record 1 2)))
+        (match r
+          (($ rtd-3-slots a b)
+           #f)
+          (($ rtd-2-slots a b)
+           (equal? (list a b) '(1 2))))))
+
+    (pass-if "getter"
+      (match (make-2-slot-record 1 2)
+        (($ rtd-2-slots (get! first) (get! second))
+         (equal? (list (first) (second)) '(1 2)))))
+
+    (pass-if "setter"
+      (let ((r (make-2-slot-record 1 2)))
+        (match r
+          (($ rtd-2-slots (set! set-first!) (set! set-second!))
+           (set-first! 'one)
+           (set-second! 'two)
+           (equal? (list (slot-first r) (slot-second r))
+                   '(one two))))))))
 
 
 (with-test-prefix "doesn't match"
@@ -105,4 +161,36 @@
     exception:match-error
     (match '(a 0)
       (((and x (? symbol?)) ..1)
-       (equal? x '(a b c))))))
+       (equal? x '(a b c)))))
+
+  (with-test-prefix "records"
+
+    (pass-if "not a record"
+      (match "hello"
+        (($ rtd-2-slots) #f)
+        (_               #t)))
+
+    (pass-if-exception "too many slots"
+      exception:out-of-range
+      (let ((r (make-3-slot-record 1 2 3)))
+        (match r
+          (($ rtd-3-slots a b c d)
+           #f))))))
+
+
+;;;
+;;; Upstream tests, from Chibi-Scheme (3-clause BSD license).
+;;;
+
+(let-syntax ((load       (syntax-rules ()
+                           ((_ file) #t)))
+             (test       (syntax-rules ()
+                           ((_ name expected expr)
+                            (pass-if name
+                                     (equal? expected expr)))))
+             (test-begin (syntax-rules ()
+                           ((_ name) #t)))
+             (test-end   (syntax-rules ()
+                           ((_) #t))))
+  (with-test-prefix "upstream tests"
+    (include-from-path "test-suite/tests/match.test.upstream")))
diff --git a/test-suite/tests/match.test.upstream b/test-suite/tests/match.test.upstream
new file mode 100644
index 000000000..47bf44e72
--- /dev/null
+++ b/test-suite/tests/match.test.upstream
@@ -0,0 +1,168 @@
+
+(cond-expand
+ (modules (import (chibi match) (only (chibi test) test-begin test test-end)))
+ (else (load "lib/chibi/match/match.scm")))
+
+(test-begin "match")
+
+(test "any" 'ok (match 'any (_ 'ok)))
+(test "symbol" 'ok (match 'ok (x x)))
+(test "number" 'ok (match 28 (28 'ok)))
+(test "string" 'ok (match "good" ("bad" 'fail) ("good" 'ok)))
+(test "literal symbol" 'ok (match 'good ('bad 'fail) ('good 'ok)))
+(test "null" 'ok (match '() (() 'ok)))
+(test "pair" 'ok (match '(ok) ((x) x)))
+(test "vector" 'ok (match '#(ok) (#(x) x)))
+(test "any doubled" 'ok (match '(1 2) ((_ _) 'ok)))
+(test "and empty" 'ok (match '(o k) ((and) 'ok)))
+(test "and single" 'ok (match 'ok ((and x) x)))
+(test "and double" 'ok (match 'ok ((and (? symbol?) y) 'ok)))
+(test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok)))
+(test "or single" 'ok (match 'ok ((or x) 'ok)))
+(test "or double" 'ok (match 'ok ((or (? symbol? y) y) y)))
+(test "not" 'ok (match 28 ((not (a . b)) 'ok)))
+(test "pred" 'ok (match 28 ((? number?) 'ok)))
+(test "named pred" 29 (match 28 ((? number? x) (+ x 1))))
+
+(test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x)))
+(test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok)))
+(test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)))
+
+(test "ellipses" '((a b c) (1 2 3))
+  (match '((a . 1) (b . 2) (c . 3))
+    (((x . y) ___) (list x y))))
+
+(test "real ellipses" '((a b c) (1 2 3))
+  (match '((a . 1) (b . 2) (c . 3))
+    (((x . y) ...) (list x y))))
+
+(test "vector ellipses" '(1 2 3 (a b c) (1 2 3))
+  (match '#(1 2 3 (a . 1) (b . 2) (c . 3))
+    (#(a b c (hd . tl) ...) (list a b c hd tl))))
+
+(test "pred ellipses" '(1 2 3)
+  (match '(1 2 3)
+    (((? odd? n) ___) n)
+    (((? number? n) ___) n)))
+
+(test "failure continuation" 'ok
+  (match '(1 2)
+    ((a . b) (=> next) (if (even? a) 'fail (next)))
+    ((a . b) 'ok)))
+
+(test "let" '(o k)
+  (match-let ((x 'ok) (y '(o k))) y))
+
+(test "let*" '(f o o f)
+  (match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w)))
+
+(test "getter car" '(1 2)
+  (match '(1 . 2) (((get! a) . b) (list (a) b))))
+
+(test "getter cdr" '(1 2)
+  (match '(1 . 2) ((a . (get! b)) (list a (b)))))
+
+(test "getter vector" '(1 2 3)
+  (match '#(1 2 3) (#((get! a) b c) (list (a) b c))))
+
+(test "setter car" '(3 . 2)
+  (let ((x (cons 1 2)))
+    (match x (((set! a) . b) (a 3)))
+    x))
+
+(test "setter cdr" '(1 . 3)
+  (let ((x (cons 1 2)))
+    (match x ((a . (set! b)) (b 3)))
+    x))
+
+(test "setter vector" '#(1 0 3)
+  (let ((x (vector 1 2 3)))
+    (match x (#(a (set! b) c) (b 0)))
+    x))
+
+(test "single tail" '((a b) (1 2) (c . 3))
+  (match '((a . 1) (b . 2) (c . 3))
+    (((x . y) ... last) (list x y last))))
+
+(test "single tail 2" '((a b) (1 2) 3)
+  (match '((a . 1) (b . 2) 3)
+    (((x . y) ... last) (list x y last))))
+
+(test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5))
+  (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
+    (((x . y) ... u v w) (list x y u v w))))
+
+(test "tail against improper list" #f
+  (match '(a b c d e f . g)
+    ((x ... y u v w) (list x y u v w))
+    (else #f)))
+
+(test "Riastradh quasiquote" '(2 3)
+  (match '(1 2 3) (`(1 ,b ,c) (list b c))))
+
+(test "trivial tree search" '(1 2 3)
+  (match '(1 2 3) ((_ *** (a b c)) (list a b c))))
+
+(test "simple tree search" '(1 2 3)
+  (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))))
+
+(test "deep tree search" '(1 2 3)
+  (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))))
+
+(test "non-tail tree search" '(1 2 3)
+  (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))))
+
+(test "restricted tree search" '(1 2 3)
+  (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))))
+
+(test "fail restricted tree search" #f
+  (match '(x (y (x a b c (1 2 3) d e f)))
+    (('x *** (a b c)) (list a b c))
+    (else #f)))
+
+(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode"))
+  (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
+     (list attrs text))
+    (else #f)))
+
+(test "failed sxml tree search" #f
+  (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
+     (list attrs text))
+    (else #f)))
+
+(test "collect tree search"
+    '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))
+  (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...))
+     (list tag attrs text))
+    (else #f)))
+
+(test "anded tail pattern" '(1 2)
+      (match '(1 2 3) ((and (a ... b) x) a)))
+
+(test "anded search pattern" '(a b c)
+      (match '(a (b (c d))) ((and (p *** 'd) x) p)))
+
+(test "joined tail" '(1 2)
+      (match '(1 2 3) ((and (a ... b) x) a)))
+
+(test "list ..1" '(a b c)
+    (match '(a b c) ((x ..1) x)))
+
+(test "list ..1 failed" #f
+    (match '()
+      ((x ..1) x)
+      (else #f)))
+
+(test "list ..1 with predicate" '(a b c)
+    (match '(a b c)
+      (((and x (? symbol?)) ..1) x)))
+
+(test "list ..1 with failed predicate" #f
+    (match '(a b 3)
+      (((and x (? symbol?)) ..1) x)
+      (else #f)))
+
+(test-end)
diff --git a/test-suite/vm/t-match.scm b/test-suite/vm/t-match.scm
index ed56ae7ef..2032fbe17 100644
--- a/test-suite/vm/t-match.scm
+++ b/test-suite/vm/t-match.scm
@@ -12,7 +12,7 @@
 (define (matches? obj)
 ;  (format #t "matches? ~a~%" obj)
   (match obj
-	 (($ stuff) #t)
+	 (($ <stuff>) #t)
 ;	 (blurps    #t)
 	 ("hello"   #t)
 	 (else #f)))