regexp: fix case-insensitive lookahead and lookbehind.

[factor.git] / basis / regexp / nfa / nfa.factor

diff --git a/basis/regexp/nfa/nfa.factor b/basis/regexp/nfa/nfa.factor
index d59d4818ec7ef5926a8dbd13ca4f9c5c61bdf347..044313f5e44485f216d7e33156fdb75d0e42c6de 100644 (file)
--- a/basis/regexp/nfa/nfa.factor
+++ b/basis/regexp/nfa/nfa.factor
@@ -1,13 +1,11 @@
 ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs grouping kernel locals math namespaces
-sequences fry quotations math.order math.ranges vectors
-unicode.categories regexp.transition-tables words sets hashtables
-combinators.short-circuit unicode.case unicode.case.private regexp.ast
-regexp.classes ;
+USING: accessors arrays assocs combinators.short-circuit kernel
+math namespaces regexp.ast regexp.classes
+regexp.transition-tables sequences sets unicode vectors ;
 IN: regexp.nfa
 
-! This uses unicode.case.private for ch>upper and ch>lower
+! This uses unicode for ch>upper and ch>lower
 ! but case-insensitive matching should be done by case-folding everything
 ! before processing starts
 
@@ -46,7 +44,7 @@ GENERIC: nfa-node ( node -- start-state end-state )
     epsilon nfa-table get add-transition ;
 
 M:: star nfa-node ( node -- start end )
-    node term>> nfa-node :> s1 :> s0
+    node term>> nfa-node :> ( s0 s1 )
     next-state :> s2
     next-state :> s3
     s1 s0 epsilon-transition
@@ -55,26 +53,14 @@ M:: star nfa-node ( node -- start end )
     s1 s3 epsilon-transition
     s2 s3 ;
 
-GENERIC: modify-epsilon ( tag -- newtag )
-! Potential off-by-one errors when lookaround nested in lookbehind
-
-M: object modify-epsilon ;
-
-: line-option ( multiline unix-lines default -- option )
-    multiline option? [
-        drop [ unix-lines option? ] 2dip swap ?
-    ] [ 2nip ] if ;
+DEFER: modify-class
 
-M: $ modify-epsilon
-    $unix end-of-input line-option ;
-
-M: ^ modify-epsilon
-    ^unix beginning-of-input line-option ;
+! Potential off-by-one errors when lookaround nested in lookbehind
 
 M: tagged-epsilon nfa-node
-    clone [ modify-epsilon ] change-tag add-simple-entry ;
+    clone [ modify-class ] change-tag add-simple-entry ;
 
-M: concatenation nfa-node ( node -- start end )
+M: concatenation nfa-node
     [ first>> ] [ second>> ] bi
     reversed-regexp option? [ swap ] when
     [ nfa-node ] bi@
@@ -89,7 +75,7 @@ M: concatenation nfa-node ( node -- start end )
     s3 s5 epsilon-transition
     s4 s5 ;
 
-M: alternation nfa-node ( node -- start end )
+M: alternation nfa-node
     [ first>> ] [ second>> ] bi
     [ nfa-node ] bi@
     alternate-nodes ;
@@ -98,6 +84,31 @@ GENERIC: modify-class ( char-class -- char-class' )
 
 M: object modify-class ;
 
+M: concatenation modify-class
+    [ first>> ] [ second>> ] bi [ modify-class ] bi@
+    concatenation boa ;
+
+M: alternation modify-class
+    [ first>> ] [ second>> ] bi [ modify-class ] bi@
+    alternation boa ;
+
+M: lookahead modify-class
+    term>> modify-class lookahead boa ;
+
+M: lookbehind modify-class
+    term>> modify-class lookbehind boa ;
+
+: line-option ( multiline unix-lines default -- option )
+    multiline option? [
+        drop [ unix-lines option? ] 2dip swap ?
+    ] [ 2nip ] if ;
+
+M: $crlf modify-class
+    $unix end-of-input line-option ;
+
+M: ^crlf modify-class
+    ^unix beginning-of-input line-option ;
+
 M: integer modify-class
     case-insensitive option? [
         dup Letter? [
@@ -105,9 +116,6 @@ M: integer modify-class
         ] when
     ] when ;
 
-M: integer nfa-node ( node -- start end )
-    modify-class add-simple-entry ;
-
 M: primitive-class modify-class
     class>> modify-class <primitive-class> ;
 
@@ -117,8 +125,17 @@ M: or-class modify-class
 M: not-class modify-class
     class>> modify-class <not-class> ;
 
-M: any-char modify-class
-    drop dotall option? t any-char-no-nl ? ;
+MEMO: unix-dot ( -- class )
+    CHAR: \n <not-class> ;
+
+MEMO: nonl-dot ( -- class )
+    { CHAR: \n CHAR: \r } <or-class> <not-class> ;
+
+M: dot modify-class
+    drop dotall option? [ t ] [
+        unix-lines option?
+        unix-dot nonl-dot ?
+    ] if ;
 
 : modify-letter-class ( class -- newclass )
     case-insensitive option? [ drop Letter-class ] when ;
@@ -127,32 +144,32 @@ M: LETTER-class modify-class modify-letter-class ;
 
 : cased-range? ( range -- ? )
     [ from>> ] [ to>> ] bi {
-        [ [ letter? ] bi@ and ]
-        [ [ LETTER? ] bi@ and ]
+        [ [ letter? ] both? ]
+        [ [ LETTER? ] both? ]
     } 2|| ;
 
-M: range modify-class
+M: range-class modify-class
     case-insensitive option? [
         dup cased-range? [
             [ from>> ] [ to>> ] bi
-            [ [ ch>lower ] bi@ <range> ]
-            [ [ ch>upper ] bi@ <range> ] 2bi 
+            [ [ ch>lower ] bi@ <range-class> ]
+            [ [ ch>upper ] bi@ <range-class> ] 2bi
             2array <or-class>
         ] when
     ] when ;
 
-M: class nfa-node
+M: object nfa-node
     modify-class add-simple-entry ;
 
-M: with-options nfa-node ( node -- start end )
+M: with-options nfa-node
     dup options>> [ tree>> nfa-node ] using-options ;
 
 : construct-nfa ( ast -- nfa-table )
     [
-        0 state set
-        <transition-table> nfa-table set
+        0 state namespaces:set
+        <transition-table> nfa-table namespaces:set
         nfa-node
         nfa-table get
-            swap dup associate >>final-states
+            swap 1array fast-set >>final-states
             swap >>start-state
     ] with-scope ;