Some reorganizing in Unicode; regexp class changes

diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor
index e3a177458591bff0d0b99d4ce6f2ebd75e31afef..c586932075f05fafd1cccd8a1a0b1d2ca54fbc41 100644 (file)
--- a/basis/regexp/classes/classes.factor
+++ b/basis/regexp/classes/classes.factor
@@ -5,18 +5,30 @@ ascii unicode.categories combinators.short-circuit sequences
 fry macros arrays assocs sets classes mirrors ;
 IN: regexp.classes
 
-SINGLETONS: any-char any-char-no-nl
-letter-class LETTER-class Letter-class digit-class
+SINGLETONS: dot letter-class LETTER-class Letter-class digit-class
 alpha-class non-newline-blank-class
 ascii-class punctuation-class java-printable-class blank-class
 control-character-class hex-digit-class java-blank-class c-identifier-class
 unmatchable-class terminator-class word-boundary-class ;
 
-SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file ^unix $unix word-break ;
+SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file
+^unix $unix word-break ;
 
 TUPLE: range from to ;
 C: <range> range
 
+TUPLE: primitive-class class ;
+C: <primitive-class> primitive-class
+
+TUPLE: category-class category ;
+C: <category-class> category-class
+
+TUPLE: category-range-class category ;
+C: <category-range-class> category-range-class
+
+TUPLE: script-class script ;
+C: <script-class> script-class
+
 GENERIC: class-member? ( obj class -- ? )
 
 M: t class-member? ( obj class -- ? ) 2drop t ;
@@ -26,12 +38,6 @@ M: integer class-member? ( obj class -- ? ) = ;
 M: range class-member? ( obj class -- ? )
     [ from>> ] [ to>> ] bi between? ;
 
-M: any-char class-member? ( obj class -- ? )
-    2drop t ;
-
-M: any-char-no-nl class-member? ( obj class -- ? )
-    drop CHAR: \n = not ;
-
 M: letter-class class-member? ( obj class -- ? )
     drop letter? ;
             
@@ -99,16 +105,16 @@ M: unmatchable-class class-member? ( obj class -- ? )
 M: terminator-class class-member? ( obj class -- ? )
     drop "\r\n\u000085\u002029\u002028" member? ;
 
-M: ^ class-member? ( obj class -- ? )
-    2drop f ;
+M: f class-member? 2drop f ;
 
-M: $ class-member? ( obj class -- ? )
-    2drop f ;
+M: script-class class-member?
+    [ script-of ] [ script>> ] bi* = ;
 
-M: f class-member? 2drop f ;
+M: category-class class-member?
+    [ category# ] [ category>> ] bi* = ;
 
-TUPLE: primitive-class class ;
-C: <primitive-class> primitive-class
+M: category-range-class class-member?
+    [ category first ] [ category>> ] bi* = ;
 
 TUPLE: not-class class ;
 

diff --git a/basis/regexp/nfa/nfa.factor b/basis/regexp/nfa/nfa.factor
index d59d4818ec7ef5926a8dbd13ca4f9c5c61bdf347..82c22a5af949316a6965ee206ceac477e64de5a9 100644 (file)
--- a/basis/regexp/nfa/nfa.factor
+++ b/basis/regexp/nfa/nfa.factor
@@ -117,8 +117,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 ;

diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor
index 7b2d6af2c1d17afb1fc8cd0de6d73ce5f22330e5..db18275f0440a424b98339c892c62d95c9a77d35 100644 (file)
--- a/basis/regexp/parser/parser.factor
+++ b/basis/regexp/parser/parser.factor
@@ -18,6 +18,13 @@ ERROR: bad-number ;
 
 ERROR: bad-class name ;
 
+: parse-unicode-class ( name -- class )
+    ! Implement this!
+    drop f ;
+
+: unicode-class ( name -- class )
+    parse-unicode-class [ bad-class ] unless* ;
+
 : name>class ( name -- class )
     >string >case-fold {
         { "lower" letter-class }
@@ -32,8 +39,7 @@ ERROR: bad-class name ;
         { "cntrl" control-character-class }
         { "xdigit" hex-digit-class }
         { "space" java-blank-class }
-        ! TODO: unicode-character-class
-    } [ bad-class ] at-error ;
+    } [ unicode-class ] at-error ;
 
 : lookup-escape ( char -- ast )
     {
@@ -144,7 +150,7 @@ Parenthized = "?:" Alternation:a => [[ a ]]
 
 Element = "(" Parenthized:p ")" => [[ p ]]
         | "[" CharClass:r "]" => [[ r ]]
-        | ".":d => [[ any-char <primitive-class> ]]
+        | ".":d => [[ dot ]]
         | Character
 
 Number = (!(","|"}").)* => [[ string>number ensure-number ]]

diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor
index 74914e8537cd37b6a31935281b0322f7483fe943..90064ca376d6bb76578419bd1c6e93011c3dbfdd 100644 (file)
--- a/basis/unicode/data/data.factor
+++ b/basis/unicode/data/data.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Daniel Ehrenberg.
+! Copyright (C) 2008, 2009 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators.short-circuit assocs math kernel sequences
 io.files hashtables quotations splitting grouping arrays io
@@ -29,6 +29,21 @@ VALUE: properties
 : char>name ( char -- name ) name-map value-at ;
 : property? ( char property -- ? ) properties at interval-key? ;
 
+: category# ( char -- category )
+    ! There are a few characters that should be Cn
+    ! that this gives Cf or Mn
+    ! Cf = 26; Mn = 5; Cn = 29
+    ! Use a compressed array instead?
+    dup category-map ?nth [ ] [
+        dup HEX: E0001 HEX: E007F between?
+        [ drop 26 ] [
+            HEX: E0100 HEX: E01EF between?  5 29 ?
+        ] if
+    ] ?if ;
+
+: category ( char -- category )
+    category# categories nth ;
+
 ! Loading data from UnicodeData.txt
 
 : split-; ( line -- array )
@@ -195,33 +210,5 @@ load-special-casing to: special-casing
 
 load-properties to: properties
 
-! Utility to load resource files that look like Scripts.txt
-
-SYMBOL: interned
-
-: parse-script ( filename -- assoc )
-    ! assoc is code point/range => name
-    ascii file-lines filter-comments [ split-; ] map ;
-
-: range, ( value key -- )
-    swap interned get
-    [ = ] with find nip 2array , ;
-
-: expand-ranges ( assoc -- interval-map )
-    [
-        [
-            swap CHAR: . over member? [
-                ".." split1 [ hex> ] bi@ 2array
-            ] [ hex> ] if range,
-        ] assoc-each
-    ] { } make <interval-map> ;
-
-: process-script ( ranges -- table )
-    dup values prune interned
-    [ expand-ranges ] with-variable ;
-
-: load-script ( filename -- table )
-    parse-script process-script ;
-
 [ name>char [ "Invalid character" throw ] unless* ]
 name>char-hook set-global

diff --git a/basis/unicode/script/script.factor b/basis/unicode/script/script.factor
index 383f9e3de3ca4c225325af461283327d29e1f888..c8f818dbaa226d065b5dc5f6d36f22974cc32da6 100644 (file)
--- a/basis/unicode/script/script.factor
+++ b/basis/unicode/script/script.factor
@@ -7,10 +7,40 @@ words words.symbol compiler.units arrays interval-maps
 unicode.data ;
 IN: unicode.script
 
+<PRIVATE
+
+SYMBOL: interned
+
+: parse-script ( filename -- assoc )
+    ! assoc is code point/range => name
+    ascii file-lines filter-comments [ split-; ] map ;
+
+: range, ( value key -- )
+    swap interned get
+    [ = ] with find nip 2array , ;
+
+: expand-ranges ( assoc -- interval-map )
+    [
+        [
+            swap CHAR: . over member? [
+                ".." split1 [ hex> ] bi@ 2array
+            ] [ hex> ] if range,
+        ] assoc-each
+    ] { } make <interval-map> ;
+
+: process-script ( ranges -- table )
+    dup values prune interned
+    [ expand-ranges ] with-variable ;
+
+: load-script ( filename -- table )
+    parse-script process-script ;
+
 VALUE: script-table
 
 "vocab:unicode/script/Scripts.txt" load-script
 to: script-table
 
+PRIVATE>
+
 : script-of ( char -- script )
     script-table interval-at ;

diff --git a/basis/unicode/syntax/syntax.factor b/basis/unicode/syntax/syntax.factor
index b7ac022d0e1cc7cc49261d3a7340ff5a3ec40caf..5bd8c05e153103658a6df5b25afdb10c49f503fa 100644 (file)
--- a/basis/unicode/syntax/syntax.factor
+++ b/basis/unicode/syntax/syntax.factor
@@ -5,22 +5,7 @@ bit-arrays namespaces make sequences.private arrays quotations
 assocs classes.predicate math.order strings.parser ;
 IN: unicode.syntax
 
-! Character classes (categories)
-
-: category# ( char -- category )
-    ! There are a few characters that should be Cn
-    ! that this gives Cf or Mn
-    ! Cf = 26; Mn = 5; Cn = 29
-    ! Use a compressed array instead?
-    dup category-map ?nth [ ] [
-        dup HEX: E0001 HEX: E007F between?
-        [ drop 26 ] [
-            HEX: E0100 HEX: E01EF between?  5 29 ?
-        ] if
-    ] ?if ;
-
-: category ( char -- category )
-    category# categories nth ;
+<PRIVATE
 
 : >category-array ( categories -- bitarray )
     categories [ swap member? ] with map >bit-array ;
@@ -40,6 +25,8 @@ IN: unicode.syntax
 : define-category ( word categories -- )
     [category] integer swap define-predicate-class ;
 
+PRIVATE>
+
 : CATEGORY:
     CREATE ";" parse-tokens define-category ; parsing