basis/regexp/compiler/compiler.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: regexp.classes kernel sequences regexp.negation
   4 quotations regexp.minimize assocs fry math locals combinators
   5 accessors words compiler.units kernel.private strings
   6 sequences.private arrays regexp.matchers call ;
   7 IN: regexp.compiler
   8
   9 : literals>cases ( literal-transitions -- case-body )
  10     [ 1quotation ] assoc-map ;
  11
  12 : non-literals>dispatch ( non-literal-transitions -- quot )
  13     [ [ '[ dup _ class-member? ] ] [ '[ drop _ execute ] ] bi* ] assoc-map
  14     [ 3drop ] suffix '[ _ cond ] ;
  15
  16 : expand-one-or ( or-class transition -- alist )
  17     [ seq>> ] dip '[ _ 2array ] map ;
  18
  19 : expand-or ( alist -- new-alist )
  20     [
  21         first2 over or-class?
  22         [ expand-one-or ] [ 2array 1array ] if
  23     ] map concat ;
  24
  25 : split-literals ( transitions -- case default )
  26     >alist expand-or [ first integer? ] partition
  27     [ literals>cases ] [ non-literals>dispatch ] bi* ;
  28
  29 :: step ( last-match index str case-body final? -- last-index/f )
  30     final? index last-match ?
  31     index str bounds-check? [
  32         index 1+ str
  33         index str nth-unsafe
  34         case-body case
  35     ] when ; inline
  36
  37 : transitions>quot ( transitions final-state? -- quot )
  38     [ split-literals suffix ] dip
  39     '[ _ _ step ] ;
  40     ! '[ { array-capacity string } declare _ _ step ] ;
  41
  42 : word>quot ( word dfa -- quot )
  43     [ transitions>> at ]
  44     [ final-states>> key? ] 2bi
  45     transitions>quot ;
  46
  47 : states>code ( words dfa -- )
  48     '[
  49         [
  50             dup _ word>quot
  51             (( last-match index string -- ? ))
  52             define-declared
  53         ] each
  54     ] with-compilation-unit ;
  55
  56 : transitions-at ( transitions assoc -- new-transitions )
  57     dup '[
  58         [ _ at ]
  59         [ [ _ at ] assoc-map ] bi*
  60     ] assoc-map ;
  61
  62 : states>words ( dfa -- words dfa )
  63     dup transitions>> keys [ gensym ] H{ } map>assoc
  64     [ [ transitions-at ] rewrite-transitions ]
  65     [ values ]
  66     bi swap ;
  67
  68 : dfa>word ( dfa -- word )
  69     states>words [ states>code ] keep start-state>> ;
  70
  71 : run-regexp ( string word -- ? )
  72     [ f 0 ] 2dip execute ; inline
  73
  74 : dfa>quotation ( dfa -- quot )
  75     dfa>word '[ _ run-regexp ] ;
  76
  77 TUPLE: quot-matcher quot ;
  78 C: <quot-matcher> quot-matcher
  79
  80 M: quot-matcher match-index
  81     quot>> call( string -- i/f ) ;