]> gitweb.factorcode.org Git - factor.git/commitdiff
Merge branch 'master' of git://factorcode.org/git/factor
authorMatthew Willis <matthew.willis@mac.com>
Sun, 30 Mar 2008 13:28:13 +0000 (06:28 -0700)
committerMatthew Willis <matthew.willis@mac.com>
Sun, 30 Mar 2008 13:28:13 +0000 (06:28 -0700)
1  2 
extra/match/match.factor

diff --combined extra/match/match.factor
index 36af5c990a0417b8adc9a1f11f68d62328acb11e,2c6923a6ba9d561044ebe0f1720569882cb06f81..dbc42f53e3f0c40b77f7e77973ea2b5e100cf746
@@@ -2,7 -2,7 +2,7 @@@
  ! See http://factorcode.org/license.txt for BSD license.
  !
  ! Based on pattern matching code from Paul Graham's book 'On Lisp'.
- USING: parser kernel words namespaces sequences tuples
+ USING: parser kernel words namespaces sequences classes.tuple
  combinators macros assocs math ;
  IN: match
  
@@@ -32,10 -32,10 +32,10 @@@ SYMBOL: 
          { [ 2dup = ] [ 2drop t ] }
          { [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
          { [ 2dup [ sequence? ] both? ] [
-             2dup [ length ] 2apply =
+             2dup [ length ] bi@ =
              [ [ (match) ] 2all? ] [ 2drop f ] if ] }
          { [ 2dup [ tuple? ] both? ]
-           [ [ tuple>array ] 2apply [ (match) ] 2all? ] }
+           [ [ tuple>array ] bi@ [ (match) ] 2all? ] }
          { [ t ] [ 2drop f ] }
      } cond ;
  
@@@ -65,26 -65,3 +65,26 @@@ MACRO: match-cond ( assoc -- 
      -rot
      match [ "Pattern does not match" throw ] unless*
      [ replace-patterns ] bind ;
 +
 +: ?1-tail ( seq -- tail/f )
 +    dup length zero? not [ 1 tail ] [ drop f ] if ;
 +
 +: (match-first) ( seq pattern-seq -- bindings leftover/f )
 +    2dup [ length ] 2apply < [ 2drop f f ]
 +    [
 +        2dup length head over match
 +        [ nip swap ?1-tail ] [ >r 1 tail r> (match-first) ] if*
 +    ] if ;
 +    
 +: match-first ( seq pattern-seq -- bindings )
 +    (match-first) drop ;
 +
 +: (match-all) ( seq pattern-seq -- )
 +    tuck (match-first) swap 
 +    [ 
 +        , [ swap (match-all) ] [ drop ] if* 
 +    ] [ 2drop ] if* ;
 +
 +: match-all ( seq pattern-seq -- bindings-seq )
 +    [ (match-all) ] { } make ;
 +