basis/regexp/nfa/nfa.factor

   1 ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators.short-circuit kernel
   4 math namespaces regexp.ast regexp.classes
   5 regexp.transition-tables sequences sets unicode vectors ;
   6 IN: regexp.nfa
   7
   8 ! This uses unicode for ch>upper and ch>lower
   9 ! but case-insensitive matching should be done by case-folding everything
  10 ! before processing starts
  11
  12 SYMBOL: option-stack
  13
  14 SYMBOL: state
  15
  16 : next-state ( -- state )
  17     state [ get ] [ inc ] bi ;
  18
  19 SYMBOL: nfa-table
  20
  21 : set-each ( keys value hashtable -- )
  22     '[ _ swap _ set-at ] each ;
  23
  24 : options>hash ( options -- hashtable )
  25     H{ } clone [
  26         [ [ on>> t ] dip set-each ]
  27         [ [ off>> f ] dip set-each ] 2bi
  28     ] keep ;
  29
  30 : using-options ( options quot -- )
  31     [ options>hash option-stack [ ?push ] change ] dip
  32     call option-stack get pop* ; inline
  33
  34 : option? ( obj -- ? )
  35     option-stack get assoc-stack ;
  36
  37 GENERIC: nfa-node ( node -- start-state end-state )
  38
  39 : add-simple-entry ( obj -- start-state end-state )
  40     [ next-state next-state 2dup ] dip
  41     nfa-table get add-transition ;
  42
  43 : epsilon-transition ( source target -- )
  44     epsilon nfa-table get add-transition ;
  45
  46 M:: star nfa-node ( node -- start end )
  47     node term>> nfa-node :> ( s0 s1 )
  48     next-state :> s2
  49     next-state :> s3
  50     s1 s0 epsilon-transition
  51     s2 s0 epsilon-transition
  52     s2 s3 epsilon-transition
  53     s1 s3 epsilon-transition
  54     s2 s3 ;
  55
  56 DEFER: modify-class
  57
  58 ! Potential off-by-one errors when lookaround nested in lookbehind
  59
  60 M: tagged-epsilon nfa-node
  61     clone [ modify-class ] change-tag add-simple-entry ;
  62
  63 M: concatenation nfa-node
  64     [ first>> ] [ second>> ] bi
  65     reversed-regexp option? [ swap ] when
  66     [ nfa-node ] bi@
  67     [ epsilon-transition ] dip ;
  68
  69 :: alternate-nodes ( s0 s1 s2 s3 -- start end )
  70     next-state :> s4
  71     next-state :> s5
  72     s4 s0 epsilon-transition
  73     s4 s2 epsilon-transition
  74     s1 s5 epsilon-transition
  75     s3 s5 epsilon-transition
  76     s4 s5 ;
  77
  78 M: alternation nfa-node
  79     [ first>> ] [ second>> ] bi
  80     [ nfa-node ] bi@
  81     alternate-nodes ;
  82
  83 GENERIC: modify-class ( char-class -- char-class' )
  84
  85 M: object modify-class ;
  86
  87 M: concatenation modify-class
  88     [ first>> ] [ second>> ] bi [ modify-class ] bi@
  89     concatenation boa ;
  90
  91 M: alternation modify-class
  92     [ first>> ] [ second>> ] bi [ modify-class ] bi@
  93     alternation boa ;
  94
  95 M: lookahead modify-class
  96     term>> modify-class lookahead boa ;
  97
  98 M: lookbehind modify-class
  99     term>> modify-class lookbehind boa ;
 100
 101 : line-option ( multiline unix-lines default -- option )
 102     multiline option? [
 103         drop [ unix-lines option? ] 2dip swap ?
 104     ] [ 2nip ] if ;
 105
 106 M: $crlf modify-class
 107     $unix end-of-input line-option ;
 108
 109 M: ^crlf modify-class
 110     ^unix beginning-of-input line-option ;
 111
 112 M: integer modify-class
 113     case-insensitive option? [
 114         dup Letter? [
 115             [ ch>lower ] [ ch>upper ] bi 2array <or-class>
 116         ] when
 117     ] when ;
 118
 119 M: primitive-class modify-class
 120     class>> modify-class <primitive-class> ;
 121
 122 M: or-class modify-class
 123     seq>> [ modify-class ] map <or-class> ;
 124
 125 M: not-class modify-class
 126     class>> modify-class <not-class> ;
 127
 128 MEMO: unix-dot ( -- class )
 129     CHAR: \n <not-class> ;
 130
 131 MEMO: nonl-dot ( -- class )
 132     { CHAR: \n CHAR: \r } <or-class> <not-class> ;
 133
 134 M: dot modify-class
 135     drop dotall option? [ t ] [
 136         unix-lines option?
 137         unix-dot nonl-dot ?
 138     ] if ;
 139
 140 : modify-letter-class ( class -- newclass )
 141     case-insensitive option? [ drop Letter-class ] when ;
 142 M: letter-class modify-class modify-letter-class ;
 143 M: LETTER-class modify-class modify-letter-class ;
 144
 145 : cased-range? ( range -- ? )
 146     [ from>> ] [ to>> ] bi {
 147         [ [ letter? ] both? ]
 148         [ [ LETTER? ] both? ]
 149     } 2|| ;
 150
 151 M: range-class modify-class
 152     case-insensitive option? [
 153         dup cased-range? [
 154             [ from>> ] [ to>> ] bi
 155             [ [ ch>lower ] bi@ <range-class> ]
 156             [ [ ch>upper ] bi@ <range-class> ] 2bi
 157             2array <or-class>
 158         ] when
 159     ] when ;
 160
 161 M: object nfa-node
 162     modify-class add-simple-entry ;
 163
 164 M: with-options nfa-node
 165     dup options>> [ tree>> nfa-node ] using-options ;
 166
 167 : construct-nfa ( ast -- nfa-table )
 168     [
 169         0 state namespaces:set
 170         <transition-table> nfa-table namespaces:set
 171         nfa-node
 172         nfa-table get
 173             swap 1array fast-set >>final-states
 174             swap >>start-state
 175     ] with-scope ;