guile-commits
[Top][All Lists]
Advanced

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

[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-64-g856806


From: Ludovic Courtès
Subject: [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-64-g8568067
Date: Sat, 03 Sep 2011 20:22:55 +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=8568067836a7f127b18833a00d6bfc0509fa31ef

The branch, stable-2.0 has been updated
       via  8568067836a7f127b18833a00d6bfc0509fa31ef (commit)
       via  5fcb7b3cc58464b8895b09d0927e9364c079fe41 (commit)
       via  d9241a37e8184ac18e5836ff739212139aca91e3 (commit)
      from  5f237d6e0e5d16b131c739c8daed3de9b162ec96 (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 8568067836a7f127b18833a00d6bfc0509fa31ef
Author: Ludovic Courtès <address@hidden>
Date:   Sat Sep 3 22:16:54 2011 +0200

    doc: Augment "Pattern Matching" section.
    
    * doc/ref/match.texi (Pattern Matching): Mention records.  Add an
      example showing record matching and the `=' pattern.  Point users to
      `match.upstream.scm'.

commit 5fcb7b3cc58464b8895b09d0927e9364c079fe41
Author: Ludovic Courtès <address@hidden>
Date:   Sat Sep 3 21:39:51 2011 +0200

    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.

commit d9241a37e8184ac18e5836ff739212139aca91e3
Author: Ludovic Courtès <address@hidden>
Date:   Sat Sep 3 21:36:49 2011 +0200

    Remove Front-Cover and Back-Cover text from the manual.
    
    * doc/ref/guile.texi: Remove Front-Cover and Back-Cover text.

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

Summary of changes:
 doc/ref/guile.texi                   |    9 +-
 doc/ref/match.texi                   |   46 +++++-
 module/ice-9/match.scm               |   25 +++-
 module/ice-9/match.upstream.scm      |  307 +++++++++++++++++++++++++++++-----
 test-suite/Makefile.am               |    1 +
 test-suite/tests/match.test          |   94 ++++++++++-
 test-suite/tests/match.test.upstream |  168 +++++++++++++++++++
 test-suite/vm/t-match.scm            |    2 +-
 8 files changed, 596 insertions(+), 56 deletions(-)
 create mode 100644 test-suite/tests/match.test.upstream

diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index f43cc5a..9581f0c 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -17,11 +17,10 @@ Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 
2005, 2009,
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
-any later version published by the Free Software Foundation; with
-no Invariant Sections, with the Front-Cover Texts being ``A GNU
-Manual,'' and with the Back-Cover Text ``You are free to copy and
-modify this GNU Manual.''.  A copy of the license is included in the
-section entitled ``GNU Free Documentation License''.
+any later version published by the Free Software Foundation; with no
+Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.  A
+copy of the license is included in the section entitled ``GNU Free
+Documentation License.''
 @end copying
 
 
diff --git a/doc/ref/match.texi b/doc/ref/match.texi
index 66bb0bf..b6acf14 100644
--- a/doc/ref/match.texi
+++ b/doc/ref/match.texi
@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2010  Free Software Foundation, Inc.
address@hidden Copyright (C) 2010, 2011  Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 @c
 
@@ -26,7 +26,7 @@ matcher found in many Scheme implementations.
 @cindex pattern variable
 A pattern matcher can match an object against several patterns and
 extract the elements that make it up.  Patterns can represent any Scheme
-object: lists, strings, symbols, etc.  They can optionally contain
+object: lists, strings, symbols, records, etc.  They can optionally contain
 @dfn{pattern variables}.  When a matching pattern is found, an
 expression associated with the pattern is evaluated, optionally with all
 pattern variables bound to the corresponding elements of the object:
@@ -43,8 +43,8 @@ In this example, list @var{l} matches the pattern 
@code{('hello (who))},
 because it is a two-element list whose first element is the symbol
 @code{hello} and whose second element is a one-element list.  Here
 @var{who} is a pattern variable.  @code{match}, the pattern matcher,
-locally binds @var{who} to the value contained in this one-element list,
-i.e., the symbol @code{world}.
+locally binds @var{who} to the value contained in this one-element
+list---i.e., the symbol @code{world}.
 
 The same object can be matched against a simpler pattern:
 
@@ -112,8 +112,8 @@ pat ::= identifier                      anything, and binds 
identifier
       | #(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
+      | ($ record-name pat_1 ... pat_n) a record
+      | (= field pat)                   a ``field'' of an object
       | (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
@@ -154,6 +154,40 @@ The names @code{quote}, @code{quasiquote}, @code{unquote},
 @code{or}, @code{not}, @code{set!}, @code{get!}, @code{...}, and
 @code{___} cannot be used as pattern variables.
 
+Here is a more complex example:
+
address@hidden
+(use-modules (srfi srfi-9))
+
+(let ()
+  (define-record-type person
+    (make-person name friends)
+    person?
+    (name    person-name)
+    (friends person-friends))
+
+  (letrec ((alice (make-person "Alice" (delay (list bob))))
+           (bob   (make-person "Bob" (delay (list alice)))))
+    (match alice
+      (($ person name (= force (($ person "Bob"))))
+       (list 'friend-of-bob name))
+      (_ #f))))
+
address@hidden (friend-of-bob "Alice")
address@hidden example
+
address@hidden
+Here the @code{$} pattern is used to match a SRFI-9 record of type
address@hidden containing two or more slots.  The value of the first slot
+is bound to @var{name}.  The @code{=} pattern is used to apply
address@hidden on the second slot, and then checking that the result
+matches the given pattern.  In other words, the complete pattern matches
+any @var{person} whose second slot is a promise that evaluates to a
+one-element list containing a @var{person} whose first slot is
address@hidden"Bob"}.
+
+Please refer to the @code{ice-9/match.upstream.scm} file in your Guile
+installation for more details.
 
 Guile also comes with a pattern matcher specifically tailored to SXML
 trees, @xref{sxml-match}.
diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm
index 7cedff0..686539b 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 df6b3d9..6fc01a6 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}
+
+;;> @address@hidden(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))))
 
+;;> @address@hidden(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 8ee570b..05aee78 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 f2e670c..93358fc 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 0000000..47bf44e
--- /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 ed56ae7..2032fbe 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)))


hooks/post-receive
-- 
GNU Guile



reply via email to

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