libs/match/match.factor

   1 ! Copyright (C) 2006 Chris Double.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 !
   4 ! Based on pattern matching code from Paul Graham's book 'On Lisp'.
   5 IN: match
   6 USING: kernel words sequences namespaces hashtables parser generic ;
   7
   8 SYMBOL: _
   9 USE: prettyprint
  10
  11 : define-match-var ( name -- )
  12   create-in dup t "match-var" set-word-prop [ dup <wrapper> , \ get , ] [ ] make define-compound ;
  13
  14 : define-match-vars ( seq -- )
  15   [ define-match-var ] each ;
  16
  17 : MATCH-VARS: ! vars ...
  18   string-mode on [ string-mode off define-match-vars ] f ; parsing
  19
  20 : match-var? ( symbol -- bool )
  21   dup word? [
  22     "match-var" word-prop
  23   ] [
  24     drop f
  25   ] if ;
  26
  27 : && ( obj seq -- ? ) [ call ] all-with? ;
  28
  29 : (match) ( seq1 seq2 -- matched? )
  30   {
  31     { [ 2dup = ] [ 2drop t ] }
  32     { [ over _ = ] [ 2drop t ] }
  33     { [ dup _ = ] [ 2drop t ] }
  34     { [ dup match-var? ] [ set t ] }
  35     { [ over match-var? ] [ swap set t ] }
  36     { [ over { [ sequence? ] [ empty? not ] } && over { [ sequence? ] [ empty? not ] } && and [ over first over first (match) ] [ f ] if ] [ >r 1 tail r> 1 tail (match) ] }
  37     { [ over tuple? over tuple? and ] [ >r tuple>array r> tuple>array (match) ] }
  38     { [ t ] [ 2drop f ] }
  39   } cond ;
  40
  41 : match ( seq1 seq2 -- bindings )
  42   [ (match) ] make-hash swap [ drop f ] unless ;
  43
  44 SYMBOL: result
  45
  46 : match-cond ( seq assoc -- )
  47   [
  48     [ first over match dup result set ] find 2nip dup [ result get [ second call ] bind ] [ no-cond ] if
  49   ] with-scope ;