Merge branch 'master' of git://factorcode.org/git/factor

README.txt

@@ -24,7 +24,7 @@ The Factor runtime is written in GNU C99, and is built with GNU make and
 gcc.
 
 Factor supports various platforms. For an up-to-date list, see
-<http://factorcode.org/getfactor.fhtml>.
+<http://factorcode.org>.
 
 Factor requires gcc 3.4 or later.
 
@@ -36,17 +36,6 @@ arguments for make.
 
 Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
 
-Compilation will yield an executable named 'factor' on Unix,
-'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
-
-* Libraries needed for compilation
-
-For X11 support, you need recent development libraries for libc,
-Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
-(like Ubuntu), you can use the following line to grab everything:
-
-    sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
-
 * Bootstrapping the Factor image
 
 Once you have compiled the Factor runtime, you must bootstrap the Factor
@@ -69,6 +58,12 @@ machines.
 On Unix, Factor can either run a graphical user interface using X11, or
 a terminal listener.
 
+For X11 support, you need recent development libraries for libc,
+Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
+(like Ubuntu), you can use the following line to grab everything:
+
+    sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev
+
 If your DISPLAY environment variable is set, the UI will start
 automatically:
 
@@ -78,14 +73,6 @@ To run an interactive terminal listener:
 
   ./factor -run=listener
 
-If you're inside a terminal session, you can start the UI with one of
-the following two commands:
-
-  ui
-  [ ui ] in-thread
-  
-The latter keeps the terminal listener running.
-
 * Running Factor on Mac OS X - Cocoa UI
 
 On Mac OS X, a Cocoa UI is available in addition to the terminal
@@ -110,7 +97,7 @@ When compiling Factor, pass the X11=1 parameter:
 
 Then bootstrap with the following switches:
 
-  ./factor -i=boot.<cpu>.image -ui-backend=x11
+  ./factor -i=boot.<cpu>.image -ui-backend=x11 -ui-text-backend=pango
 
 Now if $DISPLAY is set, running ./factor will start the UI.
 
@@ -126,6 +113,12 @@ the command prompt using the console application:
 
   factor.com -i=boot.<cpu>.image
 
+Before bootstrapping, you will need to download the DLLs for the Pango
+text rendering library. The required DLLs are listed in
+build-support/dlls.txt and are available from the following location:
+
+  <http://factorcode.org/dlls>
+
 Once bootstrapped, double-clicking factor.exe or factor.com starts
 the Factor UI.
 
@@ -135,7 +128,9 @@ To run the listener in the command prompt:
 
 * The Factor FAQ
 
-The Factor FAQ is available at <http://factorcode.org/faq.fhtml>.
+The Factor FAQ is available at the following location:
+
+  <http://concatenative.org/wiki/view/Factor/FAQ>
 
 * Command line usage
 

basis/alien/c-types/c-types-docs.factor

@@ -217,6 +217,8 @@ $nl
 "Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
 { $subsection &free }
 { $subsection |free }
+"The " { $link &free } " and " { $link |free } " words are generated using " { $link "alien.destructors" } "."
+$nl
 "You can unsafely copy a range of bytes from one memory location to another:"
 { $subsection memcpy }
 "You can copy a range of bytes from memory into a byte array:"
@@ -243,4 +245,6 @@ $nl
 "New C types can be defined:"
 { $subsection "c-structs" }
 { $subsection "c-unions" }
+"A utility for defining " { $link "destructors" } " for deallocating memory:"
+{ $subsection "alien.destructors" }
 { $see-also "aliens" } ;

basis/alien/destructors/destructors-docs.factor

@@ -0,0 +1,30 @@
+IN: alien.destructors
+USING: help.markup help.syntax alien destructors ;
+
+HELP: DESTRUCTOR:
+{ $syntax "DESTRUCTOR: word" }
+{ $description "Defines four things:"
+  { $list
+    { "a tuple named " { $snippet "word" } " with a single slot holding a " { $link c-ptr } }
+    { "a " { $link dispose } " method on the tuple which calls " { $snippet "word" } " with the " { $link c-ptr } }
+    { "a pair of words, " { $snippet "&word" } " and " { $snippet "|word" } ", which call " { $link &dispose } " and " { $link |dispose } " with a new instance of the tuple" }
+  }
+  "The " { $snippet "word" } " must be defined in the current vocabulary, and must have stack effect " { $snippet "( c-ptr -- )" } "."
+}
+{ $examples
+  "Suppose you are writing a binding to the GLib library, which as a " { $snippet "g_object_unref" } " function. Then you can define the function and destructor like so,"
+  { $code
+    "FUNCTION: void g_object_unref ( gpointer object ) ;"
+    "DESTRUCTOR: g_object_unref"
+  }
+  "Now, memory management becomes easier:"
+  { $code
+    "[ g_new_foo &g_object_unref ... ] with-destructors"
+  }
+} ;
+
+ARTICLE: "alien.destructors" "Alien destructors"
+"The " { $vocab-link "alien.destructors" } " vocabulary defines a utility parsing word for defining new disposable classes."
+{ $subsection POSTPONE: DESTRUCTOR: } ;
+
+ABOUT: "alien.destructors"

basis/ascii/ascii.factor

@@ -10,7 +10,7 @@ IN: ascii
 : LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
 : digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
 : printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
-: control? ( ch -- ? ) "\0\e\r\n\t\u000008\u00007f" member? ; inline
+: control? ( ch -- ? ) { [ 0 HEX: 1F between? ] [ HEX: 7F = ] } 1|| ; inline
 : quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
 : Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
 : alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline

basis/binary-search/binary-search.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences sequences.private accessors math
 math.order combinators hints arrays ;
@@ -16,14 +16,19 @@ IN: binary-search
     [ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
     [ drop ] [ dup ] [ ] tri* nth ; inline
 
+DEFER: (search)
+
+: keep-searching ( seq quot -- slice )
+    [ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline
+
 : (search) ( quot: ( elt -- <=> ) seq -- i elt )
     dup length 1 <= [
         finish
     ] [
         decide {
             { +eq+ [ finish ] }
-            { +lt+ [ dup midpoint@ head-slice (search) ] }
+            { +lt+ [ [ (head) ] keep-searching ] }
-            { +gt+ [ dup midpoint@ tail-slice (search) ] }
+            { +gt+ [ [ (tail) ] keep-searching ] }
         } case
     ] if ; inline recursive
 

basis/bitstreams/bitstreams-tests.factor

@@ -6,17 +6,17 @@ io.streams.byte-array ;
 IN: bitstreams.tests
 
 [ 1 t ]
-[ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test
+[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
 
 [ 254 8 t ]
-[ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test
+[ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
 
 [ 4095 12 t ]
-[ B{ 255 255 } <string-reader> <bitstream-reader> 12 swap read-bits ] unit-test
+[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
 
 [ B{ 254 } ]
 [
-    <string-writer> <bitstream-writer> 254 8 rot
+    binary <byte-writer> <bitstream-writer> 254 8 rot
     [ write-bits ] keep stream>> >byte-array
 ] unit-test
 

basis/cocoa/plists/plists-tests.factor

@@ -7,4 +7,34 @@ assocs cocoa.enumeration ;
     [ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
     [ V{ "A" } ] [ { "A" } >cf &CFRelease plist> ] unit-test
     [ H{ { "A" "B" } } ] [ "B" "A" associate >cf &CFRelease plist> ] unit-test
+    [ H{ { "A" "B" } } ] [ "B" "A" associate >cf &CFRelease plist> ] unit-test
+
+    [ t ] [
+        {
+            H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 4 } }
+            H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 5 } }
+            H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 6 } }
+        } [ >cf &CFRelease ] [ >cf &CFRelease ] bi
+        [ plist> ] bi@ =
+    ] unit-test
+
+    [ t ] [
+        { "DeviceUsagePage" 1 }
+        [ >cf &CFRelease ] [ >cf &CFRelease ] bi
+        [ plist> ] bi@ =
+    ] unit-test
+
+    [ V{ "DeviceUsagePage" "Yes" } ] [
+        { "DeviceUsagePage" "Yes" }
+        >cf &CFRelease plist>
+    ] unit-test
+
+    [ V{ 2.0 1.0 } ] [
+        { 2.0 1.0 }
+        >cf &CFRelease plist>
+    ] unit-test
+
+    [ 3.5 ] [
+        3.5 >cf &CFRelease plist>
+    ] unit-test
 ] with-destructors

basis/colors/constants/constants-docs.factor

@@ -2,7 +2,7 @@ IN: colors.constants
 USING: help.markup help.syntax strings colors ;
 
 HELP: named-color
-{ $values { "string" string } { "color" color } }
+{ $values { "name" string } { "color" color } }
 { $description "Outputs a named color from the " { $snippet "rgb.txt" } " database." }
 { $notes "In most cases, " { $link POSTPONE: COLOR: } " should be used instead." }
 { $errors "Throws an error if the color is not listed in " { $snippet "rgb.txt" } "." } ;

basis/colors/constants/constants.factor

@@ -27,7 +27,7 @@ PRIVATE>
 
 ERROR: no-such-color name ;
 
-: named-color ( name -- rgb )
+: named-color ( name -- color )
     dup rgb.txt at [ ] [ no-such-color ] ?if ;
 
 : COLOR: scan named-color parsed ; parsing

basis/compiler/compiler.factor

@@ -1,15 +1,14 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces arrays sequences io words fry
-continuations vocabs assocs dlists definitions math graphs
+continuations vocabs assocs dlists definitions math graphs generic
-generic combinators deques search-deques io stack-checker
+combinators deques search-deques macros io stack-checker
-stack-checker.state stack-checker.inlining
+stack-checker.state stack-checker.inlining combinators.short-circuit
-combinators.short-circuit compiler.errors compiler.units
+compiler.errors compiler.units compiler.tree.builder
-compiler.tree.builder compiler.tree.optimizer
+compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
-compiler.cfg.builder compiler.cfg.optimizer
 compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.linear-scan compiler.cfg.stack-frame
+compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
-compiler.codegen compiler.utilities ;
+compiler.utilities ;
 IN: compiler
 
 SYMBOL: compile-queue
@@ -50,8 +49,12 @@ SYMBOLS: +optimized+ +unoptimized+ ;
     H{ } clone generic-dependencies set
     f swap compiler-error ;
 
+: ignore-error? ( word error -- ? )
+    [ [ inline? ] [ macro? ] bi or ]
+    [ compiler-error-type +warning+ eq? ] bi* and ;
+
 : fail ( word error -- * )
-    [ swap compiler-error ]
+    [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
     [
         drop
         [ compiled-unxref ]

basis/compiler/tests/redefine1.factor

@@ -1,24 +1,42 @@
 USING: accessors compiler compiler.units tools.test math parser
 kernel sequences sequences.private classes.mixin generic
-definitions arrays words assocs eval ;
+definitions arrays words assocs eval strings ;
 IN: compiler.tests
 
-GENERIC: method-redefine-test ( a -- b )
+GENERIC: method-redefine-generic-1 ( a -- b )
 
-M: integer method-redefine-test 3 + ;
+M: integer method-redefine-generic-1 3 + ;
 
-: method-redefine-test-1 ( -- b ) 3 method-redefine-test ;
+: method-redefine-test-1 ( -- b ) 3 method-redefine-generic-1 ;
 
 [ 6 ] [ method-redefine-test-1 ] unit-test
 
-[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test
+[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test
 
 [ 7 ] [ method-redefine-test-1 ] unit-test
 
-[ ] [ [ fixnum \ method-redefine-test method forget ] with-compilation-unit ] unit-test
+[ ] [ [ fixnum \ method-redefine-generic-1 method forget ] with-compilation-unit ] unit-test
 
 [ 6 ] [ method-redefine-test-1 ] unit-test
 
+GENERIC: method-redefine-generic-2 ( a -- b )
+
+M: integer method-redefine-generic-2 3 + ;
+
+: method-redefine-test-2 ( -- b ) 3 method-redefine-generic-2 ;
+
+[ 6 ] [ method-redefine-test-2 ] unit-test
+
+[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test
+
+[ 7 ] [ method-redefine-test-2 ] unit-test
+
+[ ] [
+    [
+        fixnum string [ \ method-redefine-generic-2 method forget ] bi@
+    ] with-compilation-unit
+] unit-test
+
 ! Test ripple-up behavior
 : hey ( -- ) ;
 : there ( -- ) hey ;

basis/compiler/tree/cleanup/cleanup-tests.factor

@@ -515,3 +515,8 @@ cell-bits 32 = [
     [ { fixnum fixnum } declare = ]
     \ both-fixnums? inlined?
 ] unit-test
+
+[ t ] [
+    [ { integer integer } declare + drop ]
+    { + +-integer-integer } inlined?
+] unit-test

basis/compiler/tree/finalization/finalization.factor

@@ -46,9 +46,6 @@ M: predicate finalize-word
         [ drop ]
     } cond ;
 
-! M: math-partial finalize-word
-!     dup primitive? [ drop ] [ nip cached-expansion ] if ;
-
 M: word finalize-word drop ;
 
 M: #call finalize*

basis/compiler/tree/propagation/info/info.factor

@@ -238,7 +238,7 @@ DEFER: (value-info-union)
 
 : value-infos-union ( infos -- info )
     [ null-info ]
-    [ dup first [ value-info-union ] reduce ] if-empty ;
+    [ unclip-slice [ value-info-union ] reduce ] if-empty ;
 
 : literals<= ( info1 info2 -- ? )
     {

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -17,8 +17,10 @@ IN: compiler.tree.propagation.inlining
 ! we are more eager to inline
 SYMBOL: node-count
 
-: count-nodes ( nodes -- )
+: count-nodes ( nodes -- n )
-    0 swap [ drop 1+ ] each-node node-count set ;
+    0 swap [ drop 1+ ] each-node ;
+
+: compute-node-count ( nodes -- ) count-nodes node-count set ;
 
 ! We try not to inline the same word too many times, to avoid
 ! combinatorial explosion
@@ -33,9 +35,6 @@ M: word splicing-nodes
 M: callable splicing-nodes
     build-sub-tree analyze-recursive normalize ;
 
-: propagate-body ( #call -- )
-    body>> (propagate) ;
-
 ! Dispatch elimination
 : eliminate-dispatch ( #call class/f word/quot/f -- ? )
     dup [
@@ -44,7 +43,7 @@ M: callable splicing-nodes
             2dup splicing-nodes
             [ >>method ] [ >>body ] bi*
         ] if
-        propagate-body t
+        body>> (propagate) t
     ] [ 2drop f >>method f >>body f >>class drop f ] if ;
 
 : inlining-standard-method ( #call word -- class/f method/f )
@@ -161,10 +160,10 @@ SYMBOL: history
 : inline-word-def ( #call word quot -- ? )
     over history get memq? [ 3drop f ] [
         [
-            swap remember-inlining
+            [ remember-inlining ] dip
-            dupd splicing-nodes >>body
+            [ drop ] [ splicing-nodes ] 2bi
-            propagate-body
+            [ >>body drop ] [ count-nodes ] [ (propagate) ] tri
-        ] with-scope
+        ] with-scope node-count +@
         t
     ] if ;
 

basis/compiler/tree/propagation/propagation-tests.factor

@@ -655,3 +655,36 @@ MIXIN: empty-mixin
 ! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
 
 ! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
+
+! generalize-counter-interval wasn't being called in all the right places.
+! bug found by littledan
+
+TUPLE: littledan-1 { a read-only } ;
+
+: (littledan-1-test) ( a -- ) a>> 1+ littledan-1 boa (littledan-1-test) ; inline recursive
+
+: littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline
+
+[ ] [ [ littledan-1-test ] final-classes drop ] unit-test
+
+TUPLE: littledan-2 { from read-only } { to read-only } ;
+
+: (littledan-2-test) ( x -- i elt )
+    [ from>> ] [ to>> ] bi + dup littledan-2 boa (littledan-2-test) ; inline recursive
+
+: littledan-2-test ( x -- i elt )
+    [ 0 ] dip { array-capacity } declare littledan-2 boa (littledan-2-test) ; inline
+
+[ ] [ [ littledan-2-test ] final-classes drop ] unit-test
+
+: (littledan-3-test) ( x -- )
+    length 1+ f <array> (littledan-3-test) ; inline recursive
+
+: littledan-3-test ( x -- )
+    0 f <array> (littledan-3-test) ; inline
+
+[ ] [ [ littledan-3-test ] final-classes drop ] unit-test
+
+[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
+
+[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test

basis/compiler/tree/propagation/propagation.factor

@@ -20,5 +20,5 @@ IN: compiler.tree.propagation
     H{ } clone 1array value-infos set
     H{ } clone 1array constraints set
     H{ } clone inlining-count set
-    dup count-nodes
+    dup compute-node-count
     dup (propagate) ;

basis/compiler/tree/propagation/recursive/recursive.factor

@@ -34,9 +34,14 @@ IN: compiler.tree.propagation.recursive
     } cond interval-union nip ;
 
 : generalize-counter ( info' initial -- info )
-    2dup [ class>> null-class? ] either? [ drop ] [
+    2dup [ not ] either? [ drop ] [
-        [ drop clone ] [ [ interval>> ] bi@ ] 2bi
+        2dup [ class>> null-class? ] either? [ drop ] [
-        generalize-counter-interval >>interval
+            [ clone ] dip
+            [ [ drop ] [ [ interval>> ] bi@ generalize-counter-interval ] 2bi >>interval ]
+            [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
+            [ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ]
+            tri
+        ] if
     ] if ;
 
 : unify-recursive-stacks ( stacks initial -- infos )

basis/core-foundation/arrays/arrays.factor

@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel sequences ;
+USING: alien.syntax kernel sequences fry ;
 IN: core-foundation.arrays
 
 TYPEDEF: void* CFArrayRef
@@ -17,6 +17,5 @@ FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ;
     dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
 
 : <CFArray> ( seq -- alien )
-    [ f swap length f CFArrayCreateMutable ] keep
+    f over length &: kCFTypeArrayCallBacks CFArrayCreateMutable
-    [ length ] keep
+    [ '[ [ _ ] 2dip swap CFArraySetValueAtIndex ] each-index ] keep ;
-    [ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;

basis/core-foundation/attributed-strings/tags.txt

@@ -1 +1,2 @@
 unportable
+bindings

basis/core-text/core-text-tests.factor

@@ -1,10 +1,9 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-text core-foundation
+USING: tools.test core-text core-text.fonts core-foundation
-core-foundation.dictionaries destructors
+core-foundation.dictionaries destructors arrays kernel generalizations
-arrays kernel generalizations math accessors
+math accessors core-foundation.utilities combinators hashtables colors
-core-foundation.utilities
+colors.constants ;
-combinators hashtables colors ;
 IN: core-text.tests
 
 : test-font ( name -- font )
@@ -21,8 +20,8 @@ IN: core-text.tests
 
 : test-typographic-bounds ( string font -- ? )
     [
-        test-font &CFRelease white <CTLine> &CFRelease
+        test-font &CFRelease tuck COLOR: white <CTLine> &CFRelease
-        line-typographic-bounds {
+        compute-line-metrics {
             [ width>> float? ]
             [ ascent>> float? ]
             [ descent>> float? ]

basis/core-text/fonts/tags.txt

@@ -1 +1,2 @@
 unportable
+bindings

basis/debugger/debugger.factor

@@ -220,7 +220,7 @@ M: assert error.
         5 line-limit set
         [ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
         [ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
-    ] tabular-output ;
+    ] tabular-output nl ;
 
 M: immutable summary drop "Sequence is immutable" ;
 

basis/delegate/delegate-docs.factor

@@ -1,4 +1,4 @@
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup delegate.private ;
 IN: delegate
 
 HELP: define-protocol
@@ -8,13 +8,13 @@ HELP: define-protocol
 
 HELP: PROTOCOL:
 { $syntax "PROTOCOL: protocol-name words... ;" }
-{ $description "Defines an explicit protocol, which can be used as a basis for delegation or mimicry." } ;
+{ $description "Defines an explicit protocol, which can be used as a basis for delegation." } ;
 
 { define-protocol POSTPONE: PROTOCOL: } related-words
 
 HELP: define-consult
-{ $values { "class" "a class" } { "group" "a protocol, generic word or tuple class" } { "quot" "a quotation" } }
+{ $values { "consultation" consultation } }
-{ $description "Defines a class to consult, using the given quotation, on the generic words contained in the group." }
+{ $description "Defines a class to consult, using the quotation, on the generic words contained in the group." }
 { $notes "Usually, " { $link POSTPONE: CONSULT: } " should be used instead. This is only for runtime use." } ;
 
 HELP: CONSULT:
@@ -22,6 +22,12 @@ HELP: CONSULT:
 { $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "getter" "code to get where the method should be forwarded" } }
 { $description "Defines a class to consult, using the given code, on the generic words contained in the group. This means that, when one of the words in the group is called on an object of this class, the quotation will be called, and then the generic word called again. If the getter is empty, this will cause an infinite loop. Consultation overwrites the existing methods, but others can be defined afterwards." } ;
 
+HELP: SLOT-PROTOCOL:
+{ $syntax "SLOT-PROTOCOL: protocol-name slots... ;" }
+{ $description "Defines a protocol consisting of reader and writer words for the listen slot names." } ;
+
+{ define-protocol POSTPONE: PROTOCOL: } related-words
+
 { define-consult POSTPONE: CONSULT: } related-words
 
 HELP: group-words
@@ -40,6 +46,8 @@ $nl
 "Defining new protocols:"
 { $subsection POSTPONE: PROTOCOL: }
 { $subsection define-protocol }
+"Defining new protocols consisting of slot accessors:"
+{ $subsection POSTPONE: SLOT-PROTOCOL: }
 "Defining consultation:"
 { $subsection POSTPONE: CONSULT: }
 { $subsection define-consult }

basis/delegate/delegate-tests.factor

@@ -1,6 +1,7 @@
 USING: delegate kernel arrays tools.test words math definitions
 compiler.units parser generic prettyprint io.streams.string
-accessors eval multiline ;
+accessors eval multiline generic.standard delegate.protocols
+delegate.private assocs see ;
 IN: delegate.tests
 
 TUPLE: hello this that ;
@@ -35,7 +36,7 @@ M: hello bing hello-test ;
 [ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
 
 [ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test
-[ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test
+[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
 [ H{ } ] [ bee protocol-consult ] unit-test
 
 [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test
@@ -112,6 +113,7 @@ PROTOCOL: silly-protocol do-me ;
 
 [ ] [ T{ a-tuple } do-me ] unit-test
 
+! Change method definition to consultation
 [ [ ] ] [
     <" IN: delegate.tests
     USE: kernel
@@ -119,13 +121,22 @@ PROTOCOL: silly-protocol do-me ;
     CONSULT: silly-protocol a-tuple drop f ; "> <string-reader> "delegate-test" parse-stream
 ] unit-test
 
+! Method should be there
 [ ] [ T{ a-tuple } do-me ] unit-test
 
+! Now try removing the consulation
+[ [ ] ] [
+    <" IN: delegate.tests "> <string-reader> "delegate-test" parse-stream
+] unit-test
+
+! Method should be gone
+[ T{ a-tuple } do-me ] [ no-method? ] must-fail-with
+
 ! A slot protocol issue
 DEFER: slot-protocol-test-3
 SLOT: y
 
-[ f ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
+[ f ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
 
 [ [ ] ] [
     <" IN: delegate.tests
@@ -135,7 +146,7 @@ CONSULT: y>> slot-protocol-test-3 x>> ;">
     <string-reader> "delegate-test-1" parse-stream
 ] unit-test
 
-[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
+[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
 
 [ [ ] ] [
     <" IN: delegate.tests
@@ -143,4 +154,46 @@ TUPLE: slot-protocol-test-3 x y ;">
     <string-reader> "delegate-test-1" parse-stream
 ] unit-test
 
-[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
+! We now have a real accessor for the y slot; we don't want it to
+! get lost
+[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
+
+! We want to be able to override methods after consultation
+[ [ ] ] [
+    <" IN: delegate.tests
+    USING: delegate kernel sequences delegate.protocols accessors ;
+    TUPLE: override-method-test seq ;
+    CONSULT: sequence-protocol override-method-test seq>> ;
+    M: override-method-test like drop ; ">
+    <string-reader> "delegate-test-2" parse-stream
+] unit-test
+
+DEFER: seq-delegate
+    
+! See if removing a consultation updates protocol-consult word prop
+[ [ ] ] [
+    <" IN: delegate.tests
+    USING: accessors delegate delegate.protocols ;
+    TUPLE: seq-delegate seq ;
+    CONSULT: sequence-protocol seq-delegate seq>> ;">
+    <string-reader> "remove-consult-test" parse-stream
+] unit-test
+
+[ t ] [
+    seq-delegate
+    sequence-protocol \ protocol-consult word-prop
+    key?
+] unit-test
+
+[ [ ] ] [
+    <" IN: delegate.tests
+    USING: delegate delegate.protocols ;
+    TUPLE: seq-delegate seq ;">
+    <string-reader> "remove-consult-test" parse-stream
+] unit-test
+
+[ f ] [
+    seq-delegate
+    sequence-protocol \ protocol-consult word-prop
+    key?
+] unit-test

basis/delegate/delegate.factor

@@ -2,10 +2,13 @@
 ! Portions copyright (C) 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs classes.tuple definitions generic
-generic.standard hashtables kernel lexer make math parser
+generic.standard hashtables kernel lexer math parser
-generic.parser sequences sets slots words words.symbol fry ;
+generic.parser sequences sets slots words words.symbol fry
+compiler.units ;
 IN: delegate
 
+<PRIVATE
+
 : protocol-words ( protocol -- words )
     \ protocol-words word-prop ;
 
@@ -27,27 +30,74 @@ M: tuple-class group-words
 
 ! Consultation
 
-: consult-method ( word class quot -- )
+TUPLE: consultation group class quot loc ;
-    [ drop swap first create-method-in ]
+
-    [ nip [ swap [ second [ [ dip ] curry ] times % ] [ first , ] bi ] [ ] make ] 3bi
+: <consultation> ( group class quot -- consultation )
+    f consultation boa ; 
+
+: create-consult-method ( word consultation -- method )
+    [ class>> swap first create-method dup fake-definition ] keep
+    [ drop ] [ "consultation" set-word-prop ] 2bi ;
+
+PREDICATE: consult-method < method-body "consultation" word-prop ;
+
+M: consult-method reset-word
+    [ call-next-method ] [ f "consultation" set-word-prop ] bi ;
+
+: consult-method-quot ( quot word -- object )
+    [ second [ [ dip ] curry ] times ] [ first ] bi
+    '[ _ call _ execute ] ;
+
+: consult-method ( word consultation -- )
+    [ create-consult-method ]
+    [ quot>> swap consult-method-quot ] 2bi
     define ;
 
 : change-word-prop ( word prop quot -- )
     [ swap props>> ] dip change-at ; inline
 
-: register-protocol ( group class quot -- )
+: each-generic ( consultation quot -- )
-    [ \ protocol-consult ] 2dip
+    [ [ group>> group-words ] keep ] dip curry each ; inline
-    '[ [ _ _ swap ] dip ?set-at ] change-word-prop ;
 
-: define-consult ( group class quot -- )
+: register-consult ( consultation -- )
-    [ register-protocol ]
+    [ group>> \ protocol-consult ] [ ] [ class>> ] tri
-    [ [ group-words ] 2dip '[ _ _ consult-method ] each ]
+    '[ [ _ _ ] dip ?set-at ] change-word-prop ;
-    3bi ;
+
+: consult-methods ( consultation -- )
+    [ consult-method ] each-generic ;
+
+: unregister-consult ( consultation -- )
+    [ class>> ] [ group>> ] bi
+    \ protocol-consult word-prop delete-at ;
+
+: unconsult-method ( word consultation -- )
+    [ class>> swap first method ] keep
+    over [
+        over "consultation" word-prop eq?
+        [ forget ] [ drop ] if
+    ] [ 2drop ] if ;
+
+: unconsult-methods ( consultation -- )
+    [ unconsult-method ] each-generic ;
+
+PRIVATE>
+
+: define-consult ( consultation -- )
+    [ register-consult ] [ consult-methods ] bi ;
 
 : CONSULT:
-    scan-word scan-word parse-definition define-consult ; parsing
+    scan-word scan-word parse-definition <consultation>
+    [ save-location ] [ define-consult ] bi ; parsing
+
+M: consultation where loc>> ;
+
+M: consultation set-where (>>loc) ;
+
+M: consultation forget*
+    [ unconsult-methods ] [ unregister-consult ] bi ;
 
 ! Protocols
+<PRIVATE
 
 : cross-2each ( seq1 seq2 quot -- )
     [ with each ] 2curry each ; inline
@@ -69,8 +119,8 @@ M: tuple-class group-words
     swap protocol-words diff ;
 
 : add-new-definitions ( protocol wordlist -- )
-    [ drop protocol-consult >alist ] [ added-words ] 2bi
+    [ drop protocol-consult values ] [ added-words ] 2bi
-    [ swap first2 consult-method ] cross-2each ;
+    [ swap consult-method ] cross-2each ;
 
 : initialize-protocol-props ( protocol wordlist -- )
     [
@@ -81,6 +131,11 @@ M: tuple-class group-words
 : fill-in-depth ( wordlist -- wordlist' )
     [ dup word? [ 0 2array ] when ] map ;
 
+: show-words ( wordlist' -- wordlist )
+    [ dup second zero? [ first ] when ] map ;
+
+PRIVATE>
+
 : define-protocol ( protocol wordlist -- )
     [ drop define-symbol ] [
         fill-in-depth
@@ -97,8 +152,6 @@ PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
 M: protocol forget*
     [ f forget-old-definitions ] [ call-next-method ] bi ;
 
-: show-words ( wordlist' -- wordlist )
-    [ dup second zero? [ first ] when ] map ;
 
 M: protocol definition protocol-words show-words ;
 

basis/farkup/farkup-tests.factor

@@ -99,6 +99,7 @@ link-no-follow? off
 [ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
 [ "<p><a href=\"http://lol.com\">http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
 [ "<p><a href=\"http://lol.com\">haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
+[ "<p><a href=\"http://lol.com/search?q=sex\">haha</a></p>" ] [ "[[http://lol.com/search?q=sex|haha]]" convert-farkup ] unit-test
 [ "<p><a href=\"Foo/Bar\">Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
 
 "/wiki/view/" relative-link-prefix [

basis/farkup/farkup.factor

@@ -165,12 +165,12 @@ CONSTANT: invalid-url "javascript:alert('Invalid URL in farkup');"
         { [ dup [ 127 > ] any? ] [ drop invalid-url ] }
         { [ dup first "/\\" member? ] [ drop invalid-url ] }
         { [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
-        [ relative-link-prefix get prepend "" like ]
+        [ relative-link-prefix get prepend "" like url-encode ]
-    } cond url-encode ;
+    } cond ;
 
 : write-link ( href text -- xml )
-    [ check-url link-no-follow? get "true" and ] dip
+    [ check-url link-no-follow? get "nofollow" and ] dip
-    [XML <a href=<-> nofollow=<->><-></a> XML] ;
+    [XML <a href=<-> rel=<->><-></a> XML] ;
 
 : write-image-link ( href text -- xml )
     disable-images? get [

basis/fry/fry.factor

@@ -53,4 +53,4 @@ M: callable deep-fry
 
 M: object deep-fry , ;
 
-: '[ \ ] parse-until fry over push-all ; parsing
+: '[ parse-quotation fry over push-all ; parsing

basis/functors/functors.factor

@@ -122,20 +122,13 @@ DEFER: ;FUNCTOR delimiter
     functor-words use get delq ;
 
 : parse-functor-body ( -- form )
-    t in-lambda? [
+    push-functor-words
-        V{ } clone
+    "WHERE" parse-bindings*
-        push-functor-words
+    [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) <let*> 1quotation
-        "WHERE" parse-bindings* \ ;FUNCTOR (parse-lambda)
+    pop-functor-words ;
-        <let*> parsed-lambda
-        pop-functor-words
-        >quotation
-    ] with-variable ;
 
 : (FUNCTOR:) ( -- word def )
-    CREATE
+    CREATE-WORD [ parse-functor-body ] parse-locals-definition ;
-    parse-locals dup push-locals
-    parse-functor-body swap pop-locals <lambda>
-    rewrite-closures first ;
 
 PRIVATE>
 

basis/globs/globs-tests.factor

@@ -14,5 +14,6 @@ USING: tools.test globs ;
 [ f ] [ "foo.java" "*.{xml,txt}" glob-matches? ] unit-test
 [ t ] [ "foo.txt" "*.{xml,txt}" glob-matches? ] unit-test
 [ t ] [ "foo.xml" "*.{xml,txt}" glob-matches? ] unit-test
-[ f ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
+[ f ] [ "foo." "*.{xml,txt}" glob-matches? ] unit-test
+[ t ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
 [ t ] [ "foo.{" "*.{" glob-matches? ] unit-test

basis/globs/globs.factor

@@ -1,42 +1,42 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser-combinators parser-combinators.regexp lists sequences kernel
+USING: sequences kernel regexp.combinators strings unicode.case
-promises strings unicode.case ;
+peg.ebnf regexp arrays ;
 IN: globs
 
-<PRIVATE
+EBNF: <glob>
 
-: 'char' ( -- parser )
+Character = "\\" .:c => [[ c 1string <literal> ]]
-    [ ",*?" member? not ] satisfy ;
+          | !(","|"}") . => [[ 1string <literal> ]]
 
-: 'string' ( -- parser )
+RangeCharacter = !("]") .
-    'char' <+> [ >lower token ] <@ ;
 
-: 'escaped-char' ( -- parser )
+Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b <char-range> ]]
-    "\\" token any-char-parser &> [ 1token ] <@ ;
+      | RangeCharacter => [[ 1string <literal> ]]
 
-: 'escaped-string' ( -- parser )
+StartRange = .:a "-" RangeCharacter:b => [[ a b <char-range> ]]
-    'string' 'escaped-char' <|> ;
+           | . => [[ 1string <literal> ]]
 
-DEFER: 'term'
+Ranges = StartRange:s Range*:r => [[ r s prefix ]]
 
-: 'glob' ( -- parser )
+CharClass = "^"?:n Ranges:e => [[ e <or> n [ <not> ] when ]]
-    'term' <*> [ <and-parser> ] <@ ;
 
-: 'union' ( -- parser )
+AlternationBody = Concatenation:c "," AlternationBody:a => [[ a c prefix ]]
-    'glob' "," token nonempty-list-of "{" "}" surrounded-by
+                | Concatenation => [[ 1array ]]
-    [ <or-parser> ] <@ ;
 
-LAZY: 'term' ( -- parser )
+Element = "*" => [[ R/ .*/ ]]
-    'union'
+        | "?" => [[ R/ ./ ]]
-    'character-class' <|>
+        | "[" CharClass:c "]" => [[ c ]]
-    "?" token [ drop any-char-parser ] <@ <|>
+        | "{" AlternationBody:b "}" => [[ b <or> ]]
-    "*" token [ drop any-char-parser <*> ] <@ <|>
+        | Character
-    'escaped-string' <|> ;
 
-PRIVATE>
+Concatenation = Element* => [[ <sequence> ]]
 
-: <glob> ( string -- glob ) 'glob' just parse-1 just ;
+End = !(.)
+
+Main = Concatenation End
+
+;EBNF
 
 : glob-matches? ( input glob -- ? )
-    [ >lower ] [ <glob> ] bi* parse nil? not ;
+    [ >case-fold ] bi@ <glob> matches? ;

basis/help/cookbook/cookbook.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax io kernel math namespaces parser
 prettyprint sequences vocabs.loader namespaces stack-checker
-help command-line multiline ;
+help command-line multiline see ;
 IN: help.cookbook
 
 ARTICLE: "cookbook-syntax" "Basic syntax cookbook"

basis/help/definitions/definitions-tests.factor

@@ -1,6 +1,6 @@
 USING: math definitions help.topics help tools.test
 prettyprint parser io.streams.string kernel source-files
-assocs namespaces words io sequences eval accessors ;
+assocs namespaces words io sequences eval accessors see ;
 IN: help.definitions.tests
 
 [ ] [ \ + >link see ] unit-test

basis/help/definitions/definitions.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors definitions help help.topics help.syntax
 prettyprint.backend prettyprint.custom prettyprint words kernel
-effects ;
+effects see ;
 IN: help.definitions
 
 ! Definition protocol implementation

basis/help/handbook/handbook.factor

@@ -194,6 +194,7 @@ ARTICLE: "io" "Input and output"
 ARTICLE: "tools" "Developer tools"
 { $subsection "tools.vocabs" }
 "Exploratory tools:"
+{ $subsection "see" }
 { $subsection "editor" }
 { $subsection "listener" }
 { $subsection "tools.crossref" }

basis/help/help-docs.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.crossref help.stylesheet help.topics
 help.syntax definitions io prettyprint summary arrays math
-sequences vocabs strings ;
+sequences vocabs strings see ;
 IN: help
 
 ARTICLE: "printing-elements" "Printing markup elements"

basis/help/lint/lint.factor

@@ -132,6 +132,11 @@ SYMBOL: vocabs-quot
         [ check-descriptions ]
     } cleave ;
 
+: check-class-description ( word element -- )
+    [ class? not ]
+    [ { $class-description } swap elements empty? not ] bi* and
+    [ "A word that is not a class has a $class-description" throw ] when ;
+
 : all-word-help ( words -- seq )
     [ word-help ] filter ;
 
@@ -153,7 +158,8 @@ M: help-error error.
         dup '[
             _ dup word-help
             [ check-values ]
-            [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2bi
+            [ check-class-description ]
+            [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2tri
         ] check-something
     ] [ drop ] if ;
 

basis/help/markup/markup.factor

@@ -4,7 +4,7 @@ USING: accessors arrays definitions generic io kernel assocs
 hashtables namespaces make parser prettyprint sequences strings
 io.styles vectors words math sorting splitting classes slots fry
 sets vocabs help.stylesheet help.topics vocabs.loader quotations
-combinators call ;
+combinators call see ;
 IN: help.markup
 
 PREDICATE: simple-element < array
@@ -13,7 +13,6 @@ PREDICATE: simple-element < array
 SYMBOL: last-element
 SYMBOL: span
 SYMBOL: block
-SYMBOL: table
 
 : last-span? ( -- ? ) last-element get span eq? ;
 : last-block? ( -- ? ) last-element get block eq? ;
@@ -44,7 +43,7 @@ M: f print-element drop ;
     [ print-element ] with-default-style ;
 
 : ($block) ( quot -- )
-    last-element get { f table } member? [ nl ] unless
+    last-element get [ nl ] when
     span last-element set
     call
     block last-element set ; inline
@@ -218,7 +217,7 @@ ALIAS: $slot $snippet
         table-content-style get [
             swap [ last-element off call ] tabular-output
         ] with-style
-    ] ($block) table last-element set ; inline
+    ] ($block) ; inline
 
 : $list ( element -- )
     list-style get [
@@ -301,7 +300,7 @@ M: f ($instance)
         ] with-style
     ] ($block) ; inline
 
-: $see ( element -- ) first [ see ] ($see) ;
+: $see ( element -- ) first [ see* ] ($see) ;
 
 : $synopsis ( element -- ) first [ synopsis write ] ($see) ;
 
@@ -346,6 +345,8 @@ M: f ($instance)
     drop
     "Throws an error if the I/O operation fails." $errors ;
 
+FROM: prettyprint.private => with-pprint ;
+
 : $prettyprinting-note ( children -- )
     drop {
         "This word should only be called from inside the "

basis/html/components/components-tests.factor

@@ -4,6 +4,8 @@ io.streams.null accessors inspector html.streams
 html.components html.forms namespaces
 xml.writer ;
 
+\ render must-infer
+
 [ ] [ begin-form ] unit-test
 
 [ ] [ 3 "hi" set-value ] unit-test

basis/http/http-tests.factor

@@ -9,14 +9,10 @@ IN: http.tests
 
 [ "text/html" utf8 ] [ "text/html;  charset=UTF-8" parse-content-type ] unit-test
 
+[ "text/html" utf8 ] [ "text/html; charset=\"utf-8\"" parse-content-type ] unit-test
+
 [ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test
 
-[ { } ] [ "" parse-cookie ] unit-test
-[ { } ] [ "" parse-set-cookie ] unit-test
-
-! Make sure that totally invalid cookies don't confuse us
-[ { } ] [ "hello world; how are you" parse-cookie ] unit-test
-
 : lf>crlf "\n" split "\r\n" join ;
 
 STRING: read-request-test-1

basis/http/http.factor

@@ -34,7 +34,7 @@ IN: http
 
 : check-header-string ( str -- str )
     #! http://en.wikipedia.org/wiki/HTTP_Header_Injection
-    dup "\r\n\"" intersects?
+    dup "\r\n" intersects?
     [ "Header injection attack" throw ] when ;
 
 : write-header ( assoc -- )
@@ -213,7 +213,10 @@ TUPLE: post-data data params content-type content-encoding ;
         swap >>content-type ;
 
 : parse-content-type-attributes ( string -- attributes )
-    " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
+    " " split harvest [
+        "=" split1
+        [ >lower ] [ "\"" ?head drop "\"" ?tail drop ] bi*
+    ] { } map>assoc ;
 
 : parse-content-type ( content-type -- type encoding )
     ";" split1

basis/http/parsers/parsers-tests.factor

@@ -0,0 +1,16 @@
+IN: http.parsers.tests
+USING: http http.parsers tools.test ;
+
+[ { } ] [ "" parse-cookie ] unit-test
+[ { } ] [ "" parse-set-cookie ] unit-test
+
+! Make sure that totally invalid cookies don't confuse us
+[ { } ] [ "hello world; how are you" parse-cookie ] unit-test
+
+[ { T{ cookie { name "__s" } { value "12345567" } } } ]
+[ "__s=12345567" parse-cookie ]
+unit-test
+
+[ { T{ cookie { name "__s" } { value "12345567" } } } ]
+[ "__s=12345567;" parse-cookie ]
+unit-test

basis/http/parsers/parsers.factor

@@ -162,7 +162,7 @@ PEG: (parse-set-cookie) ( string -- alist )
         'value' ,
         'space' ,
     ] seq*
-    [ ";,=" member? not ] satisfy repeat1 [ drop f ] action
+    [ ";,=" member? not ] satisfy repeat0 [ drop f ] action
     2choice ;
 
 PEG: (parse-cookie) ( string -- alist )

basis/http/server/cgi/cgi.factor

@@ -53,9 +53,9 @@ IN: http.server.cgi
     "CGI output follows" >>message
     swap '[
         binary encode-output
-        _ output-stream get swap <cgi-process> binary <process-stream> [
+        output-stream get _ <cgi-process> binary <process-stream> [
             post-request? [ request get post-data>> data>> write flush ] when
-            '[ _ write ] each-block
+            '[ _ stream-write ] each-block
         ] with-stream
     ] >>body ;
 

basis/images/bitmap/bitmap.factor

@@ -108,11 +108,6 @@ M: bitmap-image load-image* ( path bitmap -- bitmap )
     load-bitmap-data process-bitmap-data
     fill-image-slots ;
 
-M: bitmap-image normalize-scan-line-order
-    dup dim>> '[
-        _ first 4 * <sliced-groups> reverse concat
-    ] change-bitmap ;
-
 MACRO: (nbits>bitmap) ( bits -- )
     [ -3 shift ] keep '[
         bitmap-image new
@@ -121,6 +116,7 @@ MACRO: (nbits>bitmap) ( bits -- )
             swap >>width
             swap array-copy [ >>bitmap ] [ >>color-index ] bi
             _ >>bit-count fill-image-slots
+            t >>upside-down?
     ] ;
 
 : bgr>bitmap ( array height width -- bitmap )

basis/images/images.factor

@@ -27,7 +27,7 @@ R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
         { R32G32B32A32 [ 16 ] }
     } case ;
 
-TUPLE: image dim component-order bitmap ;
+TUPLE: image dim component-order upside-down? bitmap ;
 
 : <image> ( -- image ) image new ; inline
 
@@ -82,11 +82,16 @@ M: ARGB normalize-component-order*
 M: ABGR normalize-component-order*
     drop ARGB>RGBA 4 BGR>RGB ;
 
-GENERIC: normalize-scan-line-order ( image -- image )
+: normalize-scan-line-order ( image -- image )
-
+    dup upside-down?>> [
-M: image normalize-scan-line-order ;
+        dup dim>> first 4 * '[
+            _ <groups> reverse concat
+        ] change-bitmap
+        f >>upside-down?
+    ] when ;
 
 : normalize-image ( image -- image )
     [ >byte-array ] change-bitmap
     normalize-component-order
-    normalize-scan-line-order ;
+    normalize-scan-line-order
+    RGBA >>component-order ;

basis/images/tiff/tiff.factor

@@ -503,7 +503,7 @@ ERROR: unknown-component-order ifd ;
 : ifd>image ( ifd -- image )
     {
         [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
-        [ ifd-component-order ]
+        [ ifd-component-order f ]
         [ bitmap>> ]
     } cleave tiff-image boa ;
 

basis/inspector/inspector-tests.factor

@@ -8,7 +8,7 @@ f describe
 H{ } describe
 H{ } describe
 
-[ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test
+[ "fixnum instance\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test
 
 [ ] [ H{ } clone inspect ] unit-test
 

basis/inspector/inspector.factor

@@ -9,7 +9,7 @@ IN: inspector
 
 SYMBOL: +number-rows+
 
-: summary. ( obj -- ) [ summary ] keep write-object nl ;
+: print-summary ( obj -- ) [ summary ] keep write-object ;
 
 <PRIVATE
 
@@ -40,7 +40,7 @@ M: mirror fix-slot-names
 
 : (describe) ( obj assoc -- keys )
     t pprint-string-cells? [
-        [ summary. ] [
+        [ print-summary nl ] [
             dup hashtable? [ sort-unparsed-keys ] when
             [ fix-slot-names add-numbers simple-table. ] [ keys ] bi
         ] bi*

basis/io/encodings/big5/big5.factor

@@ -3,7 +3,7 @@
 USING: io.encodings.iana io.encodings.euc ;
 IN: io.encodings.big5
 
-EUC: big5 "vocab:io/encodings/big5/CP950.txt"
+EUC: big5 "vocab:io/encodings/big5/CP950.TXT"
 
 big5 "Big5" register-encoding
 

basis/io/encodings/euc-kr/euc-kr-docs.factor

@@ -3,8 +3,11 @@
 USING: help.syntax help.markup ;
 IN: io.encodings.euc-kr
 
-ABOUT: euc-kr
-
 HELP: euc-kr
-{ $class-description "This encoding class implements Microsoft's code page #949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatibility to EUC-KR, in practice." }
+{ $class-description "This encoding class implements Microsoft's CP949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatible with EUC-KR in practice." }
 { $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.euc-kr" "EUC-KR encoding"
+{ $subsection euc-kr } ;
+
+ABOUT: "io.encodings.euc-kr"

basis/io/encodings/johab/johab-docs.factor

@@ -3,7 +3,10 @@
 USING: help.syntax help.markup ;
 IN: io.encodings.johab
 
-ABOUT: johab
-
 HELP: johab
 { $class-description "Korean Johab encoding (KSC5601-1992). This encoding is not commonly used anymore." } ;
+
+ARTICLE: "io.encodings.johab" "Korean Johab encoding"
+{ $subsection johab } ;
+
+ABOUT: "io.encodings.johab"

basis/io/streams/byte-array/byte-array.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
 sequences io namespaces io.encodings.private accessors sequences.private
-io.streams.sequence destructors ;
+io.streams.sequence destructors math combinators ;
 IN: io.streams.byte-array
 
 : <byte-writer> ( encoding -- stream )
@@ -20,6 +20,14 @@ M: byte-reader stream-read1 sequence-read1 ;
 M: byte-reader stream-read-until sequence-read-until ;
 M: byte-reader dispose drop ;
 
+M: byte-reader stream-seek ( n seek-type stream -- )
+    swap {
+        { seek-absolute [ (>>i) ] }
+        { seek-relative [ [ + ] change-i drop ] }
+        { seek-end [ dup underlying>> length >>i [ + ] change-i drop ] }
+        [ bad-seek-type ]
+    } case ;
+
 : <byte-reader> ( byte-array encoding -- stream )
     [ B{ } like 0 byte-reader boa ] dip <decoder> ;
 

basis/io/styles/styles.factor

@@ -97,7 +97,7 @@ M: plain-writer make-block-stream
     nip <ignore-close-stream> ;
 
 M: plain-writer stream-write-table
-    [ drop format-table [ print ] each ] with-output-stream* ;
+    [ drop format-table [ nl ] [ write ] interleave ] with-output-stream* ;
 
 M: plain-writer make-cell-stream 2drop <string-writer> ;
 

basis/listener/listener.factor

@@ -84,7 +84,7 @@ SYMBOL: max-stack-items
                     bi
                 ] with-row
             ] each
-        ] tabular-output
+        ] tabular-output nl
     ] unless-empty ;
     
 : trimmed-stack. ( seq -- )

basis/locals/definitions/definitions.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors definitions effects generic kernel locals
-macros memoize prettyprint prettyprint.backend words ;
+macros memoize prettyprint prettyprint.backend see words ;
 IN: locals.definitions
 
 PREDICATE: lambda-word < word "lambda" word-prop >boolean ;

basis/locals/errors/errors.factor

@@ -29,12 +29,12 @@ ERROR: :>-outside-lambda-error ;
 M: :>-outside-lambda-error summary
     drop ":> cannot be used outside of lambda expressions" ;
 
-ERROR: bad-lambda-rewrite output ;
-
-M: bad-lambda-rewrite summary
-    drop "You have found a bug in locals. Please report." ;
-
 ERROR: bad-local args obj ;
 
 M: bad-local summary
     drop "You have found a bug in locals. Please report." ;
+
+ERROR: bad-rewrite args obj ;
+
+M: bad-rewrite summary
+    drop "You have found a bug in locals. Please report." ;

basis/locals/locals-docs.factor

@@ -1,5 +1,5 @@
 USING: help.syntax help.markup kernel macros prettyprint
-memoize combinators arrays generalizations ;
+memoize combinators arrays generalizations see ;
 IN: locals
 
 HELP: [|
@@ -134,19 +134,30 @@ $nl
     "ordinary-word-test ordinary-word-test eq? ."
     "t"
 }
-"In a word with locals, literals expand into code which constructs the literal, and so every invocation pushes a new object:"
+"In a word with locals, literals which do not contain locals still behave in the same way:"
 { $example
     "USE: locals"
     "IN: scratchpad"
     "TUPLE: person first-name last-name ;"
-    ":: ordinary-word-test ( -- tuple )"
+    ":: locals-word-test ( -- tuple )"
     "    T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
-    "ordinary-word-test ordinary-word-test eq? ."
+    "locals-word-test locals-word-test eq? ."
+    "t"
+}
+"However, literals with locals in them actually expand into code for constructing a new object:"
+{ $example
+    "USING: locals splitting ;"
+    "IN: scratchpad"
+    "TUPLE: person first-name last-name ;"
+    ":: constructor-test ( -- tuple )"
+    "    \"Jane Smith\" \" \" split1 :> last :> first"
+    "    T{ person { first-name first } { last-name last } } ;"
+    "constructor-test constructor-test eq? ."
     "f"
 }
 "One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time."
 { $heading "Example" }
-"For example, here is an implementation of the " { $link 3array } " word which uses this feature:"
+"Here is an implementation of the " { $link 3array } " word which uses this feature:"
 { $code ":: 3array ( x y z -- array ) { x y z } ;" } ;
 
 ARTICLE: "locals-mutable" "Mutable locals"

basis/locals/locals-tests.factor

@@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel
 namespaces arrays strings prettyprint io.streams.string parser
 accessors generic eval combinators combinators.short-circuit
 combinators.short-circuit.smart math.order math.functions
-definitions compiler.units fry lexer words.symbol ;
+definitions compiler.units fry lexer words.symbol see ;
 IN: locals.tests
 
 :: foo ( a b -- a a ) a a ;
@@ -357,12 +357,12 @@ ERROR: punned-class x ;
 [ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test
 
 :: literal-identity-test ( -- a b )
-    { } V{ } ;
+    { 1 } V{ } ;
 
-[ t f ] [
+[ t t ] [
     literal-identity-test
     literal-identity-test
-    swapd [ eq? ] [ eq? ] 2bi*
+    [ eq? ] [ eq? ] bi-curry* bi*
 ] unit-test
 
 :: mutable-local-in-literal-test ( a! -- b ) a 1 + a! { a } ;
@@ -401,7 +401,8 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 [ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test
 
 [
-    "USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
+    "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
+    eval call
 ] [ error>> >r/r>-in-fry-error? ] must-fail-with
     
 :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
@@ -492,7 +493,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
     [| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
 ] unit-test
 
-! Discovered by littledan
+! littledan found this problem
 [ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
 [ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
 
@@ -503,8 +504,25 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 [ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test
 
 ! erg found this problem
-:: erg's-:>-bug ( n ? -- n ) [ n :> n n ] [ n :> b b ] if ;
+:: erg's-:>-bug ( n ? -- n ) ? [ n :> n n ] [ n :> b b ] if ;
 
 [ 3 ] [ 3 f erg's-:>-bug ] unit-test
     
 [ 3 ] [ 3 t erg's-:>-bug ] unit-test
+
+:: erg's-:>-bug-2 ( n ? -- n ) ? n '[ _ :> n n ] [ n :> b b ] if ;
+
+[ 3 ] [ 3 f erg's-:>-bug-2 ] unit-test
+    
+[ 3 ] [ 3 t erg's-:>-bug-2 ] unit-test
+
+! dharmatech found this problem
+GENERIC: ed's-bug ( a -- b )
+
+M: string ed's-bug reverse ;
+M: integer ed's-bug neg ;
+
+:: ed's-test-case ( a -- b )
+   { [ a ed's-bug ] } && ;
+
+[ t ] [ \ ed's-test-case optimized>> ] unit-test

basis/locals/locals.factor

@@ -9,19 +9,13 @@ IN: locals
     scan locals get [ :>-outside-lambda-error ] unless*
     [ make-local ] bind <def> parsed ; parsing
 
-: [| parse-lambda parsed-lambda ; parsing
+: [| parse-lambda over push-all ; parsing
 
-: [let
+: [let parse-let over push-all ; parsing
-    "|" expect "|" parse-bindings
-    \ ] (parse-lambda) <let> parsed-lambda ; parsing
 
-: [let*
+: [let* parse-let* over push-all ; parsing
-    "|" expect "|" parse-bindings*
-    \ ] (parse-lambda) <let*> parsed-lambda ; parsing
 
-: [wlet
+: [wlet parse-wlet over push-all ; parsing
-    "|" expect "|" parse-wbindings
-    \ ] (parse-lambda) <wlet> parsed-lambda ; parsing
 
 : :: (::) define ; parsing
 
@@ -31,6 +25,8 @@ IN: locals
 
 : MEMO:: (::) define-memoized ; parsing
 
+USE: syntax
+
 {
     "locals.macros"
     "locals.fry"

basis/locals/parser/parser.factor

@@ -6,6 +6,11 @@ locals.rewrite.closures locals.types make namespaces parser
 quotations sequences splitting words vocabs.parser ;
 IN: locals.parser
 
+SYMBOL: in-lambda?
+
+: ?rewrite-closures ( form -- form' )
+    in-lambda? get [ 1array ] [ rewrite-closures ] if ;
+
 : make-local ( name -- word )
     "!" ?tail [
         <local-reader>
@@ -20,28 +25,33 @@ IN: locals.parser
     [ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
     "local-word-def" set-word-prop ;
 
-SYMBOL: locals
-
 : push-locals ( assoc -- )
     use get push ;
 
 : pop-locals ( assoc -- )
-    use get delete ;
+    use get delq ;
 
-SYMBOL: in-lambda?
+SINGLETON: lambda-parser
 
-: (parse-lambda) ( assoc end -- quot )
+SYMBOL: locals
-    [
+
+: ((parse-lambda)) ( assoc quot -- quot' )
+    '[
         in-lambda? on
-        over locals set
+        lambda-parser quotation-parser set
-        over push-locals
+        [ locals set ] [ push-locals @ ] [ pop-locals ] tri
-        parse-until >quotation
+    ] with-scope ; inline
-        swap pop-locals
+    
-    ] with-scope ;
+: (parse-lambda) ( assoc -- quot )
+    [ \ ] parse-until >quotation ] ((parse-lambda)) ;
 
 : parse-lambda ( -- lambda )
     "|" parse-tokens make-locals
-    \ ] (parse-lambda) <lambda> ;
+    (parse-lambda) <lambda>
+    ?rewrite-closures ;
+
+M: lambda-parser parse-quotation ( -- quotation )
+    H{ } clone (parse-lambda) ;
 
 : parse-binding ( end -- pair/f )
     scan {
@@ -65,6 +75,10 @@ SYMBOL: in-lambda?
 : parse-bindings ( end -- bindings vars )
     [ (parse-bindings) ] with-bindings ;
 
+: parse-let ( -- form )
+    "|" expect "|" parse-bindings
+    (parse-lambda) <let> ?rewrite-closures ;
+
 : parse-bindings* ( end -- words assoc )
     [
         namespace push-locals
@@ -72,6 +86,10 @@ SYMBOL: in-lambda?
         namespace pop-locals
     ] with-bindings ;
 
+: parse-let* ( -- form )
+    "|" expect "|" parse-bindings*
+    (parse-lambda) <let*> ?rewrite-closures ;
+
 : (parse-wbindings) ( end -- )
     dup parse-binding dup [
         first2 [ make-local-word ] keep 2array ,
@@ -81,21 +99,29 @@ SYMBOL: in-lambda?
 : parse-wbindings ( end -- bindings vars )
     [ (parse-wbindings) ] with-bindings ;
 
+: parse-wlet ( -- form )
+    "|" expect "|" parse-wbindings
+    (parse-lambda) <wlet> ?rewrite-closures ;
+
 : parse-locals ( -- vars assoc )
     "(" expect ")" parse-effect
     word [ over "declared-effect" set-word-prop ] when*
     in>> [ dup pair? [ first ] when ] map make-locals ;
 
-: parse-locals-definition ( word -- word quot )
+: parse-locals-definition ( word reader -- word quot )
-    parse-locals \ ; (parse-lambda) <lambda>
+    [ parse-locals ] dip
+    ((parse-lambda)) <lambda>
     [ "lambda" set-word-prop ]
-    [ rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ] 2bi ;
+    [ rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ] 2bi ; inline
 
-: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
+: (::) ( -- word def )
+    CREATE-WORD
+    [ parse-definition ]
+    parse-locals-definition ;
 
 : (M::) ( -- word def )
     CREATE-METHOD
-    [ parse-locals-definition ] with-method-definition ;
+    [
-
+        [ parse-definition ] 
-: parsed-lambda ( accum form -- accum )
+        parse-locals-definition
-    in-lambda? get [ parsed ] [ rewrite-closures over push-all ] if ;
+    ] with-method-definition ;

basis/locals/rewrite/sugar/sugar.factor

@@ -37,13 +37,13 @@ M: array rewrite-literal? [ rewrite-literal? ] any? ;
 
 M: quotation rewrite-literal? [ rewrite-literal? ] any? ;
 
+M: vector rewrite-literal? [ rewrite-literal? ] any? ;
+
 M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
 
-M: hashtable rewrite-literal? drop t ;
+M: hashtable rewrite-literal? >alist rewrite-literal? ;
 
-M: vector rewrite-literal? drop t ;
+M: tuple rewrite-literal? tuple>array rewrite-literal? ;
-
-M: tuple rewrite-literal? drop t ;
 
 M: object rewrite-literal? drop f ;
 
@@ -58,12 +58,16 @@ GENERIC: rewrite-element ( obj -- )
 M: array rewrite-element
     dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
 
-M: vector rewrite-element rewrite-sequence ;
+M: vector rewrite-element
+    dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
 
-M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
+M: hashtable rewrite-element
+    dup rewrite-literal? [ >alist rewrite-sequence \ >hashtable , ] [ , ] if ;
 
 M: tuple rewrite-element
-    [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % ;
+    dup rewrite-literal? [
+        [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] %
+    ] [ , ] if ;
 
 M: quotation rewrite-element rewrite-sugar* ;
 

basis/macros/macros-tests.factor

@@ -1,6 +1,6 @@
 IN: macros.tests
 USING: tools.test macros math kernel arrays
-vectors io.streams.string prettyprint parser eval ;
+vectors io.streams.string prettyprint parser eval see ;
 
 MACRO: see-test ( a b -- c ) + ;
 

basis/math/partial-dispatch/partial-dispatch.factor

@@ -84,7 +84,7 @@ M: word integer-op-input-classes
 
 : define-integer-op-word ( fix-word big-word triple -- )
     [
-        [ 2nip integer-op-word ] [ integer-op-quot ] 3bi
+        [ 2nip integer-op-word dup make-foldable ] [ integer-op-quot ] 3bi
         (( x y -- z )) define-declared
     ] [
         2nip

basis/memoize/memoize-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel memoize tools.test parser generalizations
-prettyprint io.streams.string sequences eval namespaces ;
+prettyprint io.streams.string sequences eval namespaces see ;
 IN: memoize.tests
 
 MEMO: fib ( m -- n )

basis/models/models-docs.factor

@@ -137,7 +137,7 @@ $nl
 { $subsection "models-delay" } ;
 
 ARTICLE: "models-impl" "Implementing models"
-"New types of models can be defined, for example see " { $vocab-link "models.filter" } "."
+"New types of models can be defined, for example see " { $vocab-link "models.arrow" } "."
 $nl
 "Models can execute hooks when activated:"
 { $subsection model-activated }

basis/opengl/opengl.factor

@@ -42,7 +42,7 @@ MACRO: all-enabled ( seq quot -- )
     [ words>values ] dip '[ _ _ (all-enabled) ] ;
 
 MACRO: all-enabled-client-state ( seq quot -- )
-    [ words>values ] dip '[ _ (all-enabled-client-state) ] ;
+    [ words>values ] dip '[ _ _ (all-enabled-client-state) ] ;
 
 : do-matrix ( mode quot -- )
     swap [ glMatrixMode glPushMatrix call ] keep

basis/opengl/textures/textures-tests.factor

@@ -5,15 +5,19 @@ images kernel namespaces ;
 IN: opengl.textures.tests
 
 [ ] [
-    { 3 5 }
+    T{ image
-    RGB
+       { dim { 3 5 } }
-    B{
+       { component-order RGB }
-        1 2 3 4 5 6 7 8 9
+       { bitmap
-        10 11 12 13 14 15 16 17 18
+         B{
-        19 20 21 22 23 24 25 26 27
+             1 2 3 4 5 6 7 8 9
-        28 29 30 31 32 33 34 35 36
+             10 11 12 13 14 15 16 17 18
-        37 38 39 40 41 42 43 44 45
+             19 20 21 22 23 24 25 26 27
-    } image boa "image" set
+             28 29 30 31 32 33 34 35 36
+             37 38 39 40 41 42 43 44 45
+         }
+       }
+    } "image" set
 ] unit-test
 
 [

basis/opengl/textures/textures.factor

@@ -11,14 +11,16 @@ IN: opengl.textures
 
 TUPLE: texture loc dim texture-coords texture display-list disposed ;
 
-<PRIVATE
-
 GENERIC: component-order>format ( component-order -- format type )
 
+M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
+M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
 M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
 M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
 M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
 
+<PRIVATE
+
 : repeat-last ( seq n -- seq' )
     over peek pad-tail concat ;
 

basis/peg/ebnf/ebnf.factor

@@ -128,28 +128,28 @@ PEG: escaper ( string -- ast )
   #! in the EBNF syntax itself.
   [
     {
-      [ dup blank?    ]
+      [ blank?    ]
-      [ dup CHAR: " = ]
+      [ CHAR: " = ]
-      [ dup CHAR: ' = ]
+      [ CHAR: ' = ]
-      [ dup CHAR: | = ]
+      [ CHAR: | = ]
-      [ dup CHAR: { = ]
+      [ CHAR: { = ]
-      [ dup CHAR: } = ]
+      [ CHAR: } = ]
-      [ dup CHAR: = = ]
+      [ CHAR: = = ]
-      [ dup CHAR: ) = ]
+      [ CHAR: ) = ]
-      [ dup CHAR: ( = ]
+      [ CHAR: ( = ]
-      [ dup CHAR: ] = ]
+      [ CHAR: ] = ]
-      [ dup CHAR: [ = ]
+      [ CHAR: [ = ]
-      [ dup CHAR: . = ]
+      [ CHAR: . = ]
-      [ dup CHAR: ! = ]
+      [ CHAR: ! = ]
-      [ dup CHAR: & = ]
+      [ CHAR: & = ]
-      [ dup CHAR: * = ]
+      [ CHAR: * = ]
-      [ dup CHAR: + = ]
+      [ CHAR: + = ]
-      [ dup CHAR: ? = ]
+      [ CHAR: ? = ]
-      [ dup CHAR: : = ]
+      [ CHAR: : = ]
-      [ dup CHAR: ~ = ]
+      [ CHAR: ~ = ]
-      [ dup CHAR: < = ]
+      [ CHAR: < = ]
-      [ dup CHAR: > = ]
+      [ CHAR: > = ]
-    } 0|| not nip    
+    } 1|| not
   ] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
 
 : 'terminal' ( -- parser )
@@ -161,9 +161,9 @@ PEG: escaper ( string -- ast )
   #! Parse a valid foreign parser name
   [
     {
-      [ dup blank?    ]
+      [ blank?    ]
-      [ dup CHAR: > = ]
+      [ CHAR: > = ]
-    } 0|| not nip    
+    } 1|| not
   ] satisfy repeat1 [ >string ] action ;
 
 : 'foreign' ( -- parser )

basis/prettyprint/prettyprint-docs.factor

@@ -1,6 +1,7 @@
 USING: prettyprint.backend prettyprint.config prettyprint.custom
 prettyprint.sections prettyprint.private help.markup help.syntax
-io kernel words definitions quotations strings generic classes ;
+io kernel words definitions quotations strings generic classes
+prettyprint.private ;
 IN: prettyprint
 
 ARTICLE: "prettyprint-numbers" "Prettyprinting numbers"
@@ -149,10 +150,6 @@ $nl
 { $subsection unparse-use }
 "Utility for tabular output:"
 { $subsection pprint-cell }
-"Printing a definition (see " { $link "definitions" } "):"
-{ $subsection see }
-"Printing the methods defined on a generic word or class (see " { $link "objects" } "):"
-{ $subsection see-methods }
 "More prettyprinter usage:"
 { $subsection "prettyprint-numbers" }
 { $subsection "prettyprint-stacks" }
@@ -160,7 +157,7 @@ $nl
 { $subsection "prettyprint-variables" }
 { $subsection "prettyprint-extension" }
 { $subsection "prettyprint-limitations" }
-{ $see-also "number-strings" } ;
+{ $see-also "number-strings" "see" } ;
 
 ABOUT: "prettyprint"
 
@@ -233,50 +230,3 @@ HELP: in.
 { $values { "vocab" "a vocabulary specifier" } }
 { $description "Prettyprints a " { $snippet "IN:" } " declaration." }
 $prettyprinting-note ;
-
-HELP: synopsis
-{ $values { "defspec" "a definition specifier" } { "str" string } }
-{ $contract "Prettyprints the prologue of a definition." } ;
-
-HELP: synopsis*
-{ $values { "defspec" "a definition specifier" } }
-{ $contract "Adds sections to the current block corresponding to a the prologue of a definition, in source code-like form." }
-{ $notes "This word should only be called from inside the " { $link with-pprint } " combinator. Client code should call " { $link synopsis } " instead." } ;
-
-HELP: comment.
-{ $values { "string" "a string" } }
-{ $description "Prettyprints some text with the comment style." }
-$prettyprinting-note ;
-
-HELP: see
-{ $values { "defspec" "a definition specifier" } }
-{ $contract "Prettyprints a definition." } ;
-
-HELP: see-methods
-{ $values { "word" "a " { $link generic } " or a " { $link class } } }
-{ $contract "Prettyprints the methods defined on a generic word or class." } ;
-
-HELP: definer
-{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
-{ $contract "Outputs the parsing words which delimit the definition." }
-{ $examples
-    { $example "USING: definitions prettyprint ;"
-               "IN: scratchpad"
-               ": foo ; \\ foo definer . ."
-               ";\nPOSTPONE: :"
-    }
-    { $example "USING: definitions prettyprint ;"
-               "IN: scratchpad"
-               "SYMBOL: foo \\ foo definer . ."
-               "f\nPOSTPONE: SYMBOL:"
-    }
-}
-{ $notes "This word is used in the implementation of " { $link see } "." } ;
-
-HELP: definition
-{ $values { "defspec" "a definition specifier" } { "seq" "a sequence" } }
-{ $contract "Outputs the body of a definition." }
-{ $examples
-    { $example "USING: definitions math prettyprint ;" "\\ sq definition ." "[ dup * ]" }
-}
-{ $notes "This word is used in the implementation of " { $link see } "." } ;

basis/prettyprint/prettyprint-tests.factor

@@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint prettyprint.config
 prettyprint.sections sequences tools.test vectors words
 effects splitting generic.standard prettyprint.private
 continuations generic compiler.units tools.walker eval
-accessors make vocabs.parser ;
+accessors make vocabs.parser see ;
 IN: prettyprint.tests
 
 [ "4" ] [ 4 unparse ] unit-test

basis/prettyprint/prettyprint.factor

@@ -1,16 +1,14 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic generic.standard assocs io kernel math
+USING: accessors assocs colors combinators grouping io
-namespaces make sequences strings io.styles io.streams.string
+io.streams.string io.styles kernel make math math.parser namespaces
-vectors words words.symbol prettyprint.backend prettyprint.custom
+parser prettyprint.backend prettyprint.config prettyprint.custom
-prettyprint.sections prettyprint.config sorting splitting
+prettyprint.sections quotations sequences sorting strings vocabs
-grouping math.parser vocabs definitions effects classes.builtin
+vocabs.parser words sets ;
-classes.tuple io.pathnames classes continuations hashtables
-classes.mixin classes.union classes.intersection
-classes.predicate classes.singleton combinators quotations sets
-accessors colors parser summary vocabs.parser ;
 IN: prettyprint
 
+<PRIVATE
+
 : make-pprint ( obj quot -- block in use )
     [
         0 position set
@@ -34,7 +32,7 @@ IN: prettyprint
     [ \ IN: pprint-word pprint-vocab ] with-pprint ;
 
 : in. ( vocab -- )
-    [ write-in nl ] when* ;
+    [ write-in ] when* ;
 
 : use. ( seq -- )
     [
@@ -54,19 +52,23 @@ IN: prettyprint
     [ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ;
 
 : prelude. ( -- )
-    in get use get vocab-names use/in. ;
+    in get use get vocab-names prune in get ".private" append swap remove use/in. ;
 
 [
     nl
-    "Restarts were invoked adding vocabularies to the search path." print
+    { { font-style bold } { font-name "sans-serif" } } [
-    "To avoid doing this in the future, add the following USING:" print
+        "Restarts were invoked adding vocabularies to the search path." print
-    "and IN: forms at the top of the source file:" print nl
+        "To avoid doing this in the future, add the following USING:" print
-    prelude.
+        "and IN: forms at the top of the source file:" print nl
-    nl
+    ] with-style
+    { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } } [ prelude. ] with-nesting
+    nl nl
 ] print-use-hook set-global
 
+PRIVATE>
+
 : with-use ( obj quot -- )
-    make-pprint use/in. do-pprint ; inline
+    make-pprint use/in. nl do-pprint ; inline
 
 : with-in ( obj quot -- )
     make-pprint drop [ write-in bl ] when* do-pprint ; inline
@@ -165,214 +167,4 @@ SYMBOL: pprint-string-cells?
                 ] each
             ] with-row
         ] each
-    ] tabular-output ;
+    ] tabular-output nl ;
-
-GENERIC: see ( defspec -- )
-
-: comment. ( string -- )
-    [ H{ { font-style italic } } styled-text ] when* ;
-
-: seeing-word ( word -- )
-    vocabulary>> pprinter-in set ;
-
-: definer. ( defspec -- )
-    definer drop pprint-word ;
-
-: stack-effect. ( word -- )
-    [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
-    [ effect>string comment. ] when* ;
-
-: word-synopsis ( word -- )
-    {
-        [ seeing-word ]
-        [ definer. ]
-        [ pprint-word ]
-        [ stack-effect. ] 
-    } cleave ;
-
-M: word synopsis* word-synopsis ;
-
-M: simple-generic synopsis* word-synopsis ;
-
-M: standard-generic synopsis*
-    {
-        [ definer. ]
-        [ seeing-word ]
-        [ pprint-word ]
-        [ dispatch# pprint* ]
-        [ stack-effect. ]
-    } cleave ;
-
-M: hook-generic synopsis*
-    {
-        [ definer. ]
-        [ seeing-word ]
-        [ pprint-word ]
-        [ "combination" word-prop var>> pprint* ]
-        [ stack-effect. ]
-    } cleave ;
-
-M: method-spec synopsis*
-    first2 method synopsis* ;
-
-M: method-body synopsis*
-    [ definer. ]
-    [ "method-class" word-prop pprint-word ]
-    [ "method-generic" word-prop pprint-word ] tri ;
-
-M: mixin-instance synopsis*
-    [ definer. ]
-    [ class>> pprint-word ]
-    [ mixin>> pprint-word ] tri ;
-
-M: pathname synopsis* pprint* ;
-
-: synopsis ( defspec -- str )
-    [
-        0 margin set
-        1 line-limit set
-        [ synopsis* ] with-in
-    ] with-string-writer ;
-
-M: word summary synopsis ;
-
-GENERIC: declarations. ( obj -- )
-
-M: object declarations. drop ;
-
-: declaration. ( word prop -- )
-    [ nip ] [ name>> word-prop ] 2bi
-    [ pprint-word ] [ drop ] if ;
-
-M: word declarations.
-    {
-        POSTPONE: parsing
-        POSTPONE: delimiter
-        POSTPONE: inline
-        POSTPONE: recursive
-        POSTPONE: foldable
-        POSTPONE: flushable
-    } [ declaration. ] with each ;
-
-: pprint-; ( -- ) \ ; pprint-word ;
-
-M: object see
-    [
-        12 nesting-limit set
-        100 length-limit set
-        <colon dup synopsis*
-        <block dup definition pprint-elements block>
-        dup definer nip [ pprint-word ] when* declarations.
-        block>
-    ] with-use nl ;
-
-M: method-spec see
-    first2 method see ;
-
-GENERIC: see-class* ( word -- )
-
-M: union-class see-class*
-    <colon \ UNION: pprint-word
-    dup pprint-word
-    members pprint-elements pprint-; block> ;
-
-M: intersection-class see-class*
-    <colon \ INTERSECTION: pprint-word
-    dup pprint-word
-    participants pprint-elements pprint-; block> ;
-
-M: mixin-class see-class*
-    <block \ MIXIN: pprint-word
-    dup pprint-word <block
-    dup members [
-        hard line-break
-        \ INSTANCE: pprint-word pprint-word pprint-word
-    ] with each block> block> ;
-
-M: predicate-class see-class*
-    <colon \ PREDICATE: pprint-word
-    dup pprint-word
-    "<" text
-    dup superclass pprint-word
-    <block
-    "predicate-definition" word-prop pprint-elements
-    pprint-; block> block> ;
-
-M: singleton-class see-class* ( class -- )
-    \ SINGLETON: pprint-word pprint-word ;
-
-GENERIC: pprint-slot-name ( object -- )
-
-M: string pprint-slot-name text ;
-
-M: array pprint-slot-name
-    <flow \ { pprint-word
-    f <inset unclip text pprint-elements block>
-    \ } pprint-word block> ;
-
-: unparse-slot ( slot-spec -- array )
-    [
-        dup name>> ,
-        dup class>> object eq? [
-            dup class>> ,
-            initial: ,
-            dup initial>> ,
-        ] unless
-        dup read-only>> [
-            read-only ,
-        ] when
-        drop
-    ] { } make ;
-
-: pprint-slot ( slot-spec -- )
-    unparse-slot
-    dup length 1 = [ first ] when
-    pprint-slot-name ;
-
-M: tuple-class see-class*
-    <colon \ TUPLE: pprint-word
-    dup pprint-word
-    dup superclass tuple eq? [
-        "<" text dup superclass pprint-word
-    ] unless
-    <block "slots" word-prop [ pprint-slot ] each block>
-    pprint-; block> ;
-
-M: word see-class* drop ;
-
-M: builtin-class see-class*
-    drop "! Built-in class" comment. ;
-
-: see-class ( class -- )
-    dup class? [
-        [
-            dup seeing-word dup see-class*
-        ] with-use nl
-    ] when drop ;
-
-M: word see
-    [ see-class ]
-    [ [ class? ] [ symbol? not ] bi and [ nl ] when ]
-    [
-        dup [ class? ] [ symbol? ] bi and
-        [ drop ] [ call-next-method ] if
-    ] tri ;
-
-: see-all ( seq -- )
-    natural-sort [ nl ] [ see ] interleave ;
-
-: (see-implementors) ( class -- seq )
-    dup implementors [ method ] with map natural-sort ;
-
-: (see-methods) ( generic -- seq )
-    "methods" word-prop values natural-sort ;
-
-: methods ( word -- seq )
-    [
-        dup class? [ dup (see-implementors) % ] when
-        dup generic? [ dup (see-methods) % ] when
-        drop
-    ] { } make prune ;
-
-: see-methods ( word -- )
-    methods see-all ;

basis/prettyprint/sections/sections-docs.factor

@@ -199,7 +199,7 @@ HELP: <flow
 
 HELP: colon
 { $class-description "A " { $link block } " section. When printed as a " { $link long-section } ", indents every line except the first." }
-{ $notes "Colon sections are used to enclose word definitions printed by " { $link see } "." } ;
+{ $notes "Colon sections are used to enclose word definitions when " { $link "see" } "." } ;
 
 HELP: <colon
 { $description "Begins a " { $link colon } " section." } ;

basis/regexp/ast/ast.factor

@@ -0,0 +1,65 @@
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays accessors fry sequences regexp.classes ;
+FROM: math.ranges => [a,b] ;
+IN: regexp.ast
+
+TUPLE: negation term ;
+C: <negation> negation
+
+TUPLE: from-to n m ;
+C: <from-to> from-to
+
+TUPLE: at-least n ;
+C: <at-least> at-least
+
+TUPLE: tagged-epsilon tag ;
+C: <tagged-epsilon> tagged-epsilon
+
+CONSTANT: epsilon T{ tagged-epsilon { tag t } }
+
+TUPLE: concatenation first second ;
+
+: <concatenation> ( seq -- concatenation )
+    [ epsilon ] [ unclip [ concatenation boa ] reduce ] if-empty ;
+
+TUPLE: alternation first second ;
+
+: <alternation> ( seq -- alternation )
+    unclip [ alternation boa ] reduce ;
+
+TUPLE: star term ;
+C: <star> star
+
+TUPLE: with-options tree options ;
+C: <with-options> with-options
+
+TUPLE: options on off ;
+C: <options> options
+
+SINGLETONS: unix-lines dotall multiline comments case-insensitive
+unicode-case reversed-regexp ;
+
+: <maybe> ( term -- term' )
+    f <concatenation> 2array <alternation> ;
+
+: <plus> ( term -- term' )
+    dup <star> 2array <concatenation> ;
+
+: repetition ( n term -- term' )
+    <array> <concatenation> ;
+
+GENERIC: <times> ( term times -- term' )
+M: at-least <times>
+    n>> swap [ repetition ] [ <star> ] bi 2array <concatenation> ;
+M: from-to <times>
+    [ n>> ] [ m>> ] bi [a,b] swap '[ _ repetition ] map <alternation> ;
+
+: char-class ( ranges ? -- term )
+    [ <or-class> ] dip [ <not-class> ] when ;
+
+TUPLE: lookahead term ;
+C: <lookahead> lookahead
+
+TUPLE: lookbehind term ;
+C: <lookbehind> lookbehind

basis/regexp/backend/backend.factor

@@ -1,27 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors hashtables kernel math vectors ;
-IN: regexp.backend
-
-TUPLE: regexp
-    raw
-    { options hashtable }
-    stack
-    parse-tree
-    nfa-table
-    dfa-table
-    minimized-table
-    matchers
-    { nfa-traversal-flags hashtable }
-    { dfa-traversal-flags hashtable }
-    { state integer }
-    { new-states vector }
-    { visited-states hashtable } ;
-
-: reset-regexp ( regexp -- regexp )
-    0 >>state
-    V{ } clone >>stack
-    V{ } clone >>new-states
-    H{ } clone >>visited-states ;
-
-SYMBOL: current-regexp

basis/regexp/classes/classes-tests.factor

@@ -0,0 +1,60 @@
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp.classes tools.test arrays kernel ;
+IN: regexp.classes.tests
+
+! Class algebra
+
+[ f ] [ { 1 2 } <and-class> ] unit-test
+[ T{ or-class f { 1 2 } } ] [ { 1 2 } <or-class> ] unit-test
+[ 3 ] [ { 1 2 } <and-class> 3 2array <or-class> ] unit-test
+[ CHAR: A ] [ CHAR: A LETTER-class <primitive-class> 2array <and-class> ] unit-test
+[ CHAR: A ] [ LETTER-class <primitive-class> CHAR: A 2array <and-class> ] unit-test
+[ T{ primitive-class { class LETTER-class } } ] [ CHAR: A LETTER-class <primitive-class> 2array <or-class> ] unit-test
+[ T{ primitive-class { class LETTER-class } } ] [ LETTER-class <primitive-class> CHAR: A 2array <or-class> ] unit-test
+[ t ] [ { t 1 } <or-class> ] unit-test
+[ t ] [ { 1 t } <or-class> ] unit-test
+[ f ] [ { f 1 } <and-class> ] unit-test
+[ f ] [ { 1 f } <and-class> ] unit-test
+[ 1 ] [ { f 1 } <or-class> ] unit-test
+[ 1 ] [ { 1 f } <or-class> ] unit-test
+[ 1 ] [ { t 1 } <and-class> ] unit-test
+[ 1 ] [ { 1 t } <and-class> ] unit-test
+[ 1 ] [ 1 <not-class> <not-class> ] unit-test
+[ 1 ] [ { 1 1 } <and-class> ] unit-test
+[ 1 ] [ { 1 1 } <or-class> ] unit-test
+[ t ] [ { t t } <or-class> ] unit-test
+[ T{ primitive-class { class letter-class } } ] [ letter-class <primitive-class> dup 2array <and-class> ] unit-test
+[ T{ primitive-class { class letter-class } } ] [ letter-class <primitive-class> dup 2array <or-class> ] unit-test
+[ T{ or-class { seq { 1 2 3 } } } ] [ { 1 2 } <or-class> { 2 3 } <or-class> 2array <or-class> ] unit-test
+[ T{ or-class { seq { 2 3 } } } ] [ { 2 3 } <or-class> 1 <not-class> 2array <and-class> ] unit-test
+[ f ] [ t <not-class> ] unit-test
+[ t ] [ f <not-class> ] unit-test
+[ f ] [ 1 <not-class> 1 t answer ] unit-test
+[ t ] [ { 1 2 } <or-class> <not-class> 1 2 3array <or-class> ] unit-test
+[ f ] [ { 1 2 } <and-class> <not-class> 1 2 3array <and-class> ] unit-test
+
+! Making classes into nested conditionals
+
+[ V{ 1 2 3 4 } ] [ T{ and-class f { 1 T{ not-class f 2 } T{ or-class f { 3 4 } } 2 } } class>questions ] unit-test
+[ { 3 } ] [ { { 3 t } } table>condition ] unit-test
+[ { T{ primitive-class } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>questions ] unit-test
+[ { { 1 t } { 2 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } t assoc-answer ] unit-test
+[ { { 1 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } f assoc-answer ] unit-test
+[ T{ condition f T{ primitive-class } { 1 2 } { 1 } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>condition ] unit-test
+
+SYMBOL: foo
+SYMBOL: bar
+
+[ T{ condition f T{ primitive-class f bar } T{ condition f T{ primitive-class f foo } { 1 3 2 } { 1 3 } } T{ condition f T{ primitive-class f foo } { 1 2 } { 1 } } } ] [ { { 1 t } { 3 T{ primitive-class f bar } } { 2 T{ primitive-class f foo } } } table>condition ] unit-test
+
+[ t ] [ foo <primitive-class> dup t answer ] unit-test
+[ f ] [ foo <primitive-class> dup f answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> t answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> f answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> t answer ] unit-test
+[ T{ primitive-class f bar } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> t answer ] unit-test
+[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> f answer ] unit-test
+[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> f answer ] unit-test
+[ t ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> t answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> f answer ] unit-test

basis/regexp/classes/classes.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math math.order words regexp.utils
+USING: accessors kernel math math.order words combinators locals
-unicode.categories combinators.short-circuit ;
+ascii unicode.categories combinators.short-circuit sequences
+fry macros arrays assocs sets classes mirrors ;
 IN: regexp.classes
 
 SINGLETONS: any-char any-char-no-nl
@@ -11,19 +12,18 @@ 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 beginning-of-line
+SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file word-break ;
-end-of-input end-of-line ;
 
-MIXIN: node
+TUPLE: range from to ;
-TUPLE: character-class-range from to ; INSTANCE: character-class-range node
+C: <range> range
 
 GENERIC: class-member? ( obj class -- ? )
 
-M: t class-member? ( obj class -- ? ) 2drop f ;
+M: t class-member? ( obj class -- ? ) 2drop t ;
 
-M: integer class-member? ( obj class -- ? ) 2drop f ;
+M: integer class-member? ( obj class -- ? ) = ;
 
-M: character-class-range class-member? ( obj class -- ? )
+M: range class-member? ( obj class -- ? )
     [ from>> ] [ to>> ] bi between? ;
 
 M: any-char class-member? ( obj class -- ? )
@@ -47,16 +47,24 @@ M: ascii-class class-member? ( obj class -- ? )
 M: digit-class class-member? ( obj class -- ? )
     drop digit? ;
 
+: c-identifier-char? ( ch -- ? )
+    { [ alpha? ] [ CHAR: _ = ] } 1|| ;
+
 M: c-identifier-class class-member? ( obj class -- ? )
-    drop
+    drop c-identifier-char? ;
-    { [ digit? ] [ Letter? ] [ CHAR: _ = ] } 1|| ;
 
 M: alpha-class class-member? ( obj class -- ? )
     drop alpha? ;
 
+: punct? ( ch -- ? )
+    "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
+
 M: punctuation-class class-member? ( obj class -- ? )
     drop punct? ;
 
+: java-printable? ( ch -- ? )
+    { [ alpha? ] [ punct? ] } 1|| ;
+
 M: java-printable-class class-member? ( obj class -- ? )
     drop java-printable? ;
 
@@ -64,11 +72,24 @@ M: non-newline-blank-class class-member? ( obj class -- ? )
     drop { [ blank? ] [ CHAR: \n = not ] } 1&& ;
 
 M: control-character-class class-member? ( obj class -- ? )
-    drop control-char? ;
+    drop control? ;
+
+: hex-digit? ( ch -- ? )
+    {
+        [ CHAR: A CHAR: F between? ]
+        [ CHAR: a CHAR: f between? ]
+        [ CHAR: 0 CHAR: 9 between? ]
+    } 1|| ;
 
 M: hex-digit-class class-member? ( obj class -- ? )
     drop hex-digit? ;
 
+: java-blank? ( ch -- ? )
+    {
+        CHAR: \s CHAR: \t CHAR: \n
+        HEX: b HEX: 7 CHAR: \r
+    } member? ;
+
 M: java-blank-class class-member? ( obj class -- ? )
     drop java-blank? ;
 
@@ -76,16 +97,219 @@ M: unmatchable-class class-member? ( obj class -- ? )
     2drop f ;
 
 M: terminator-class class-member? ( obj class -- ? )
-    drop {
+    drop "\r\n\u000085\u002029\u002028" member? ;
-        [ CHAR: \r = ]
+
-        [ CHAR: \n = ]
+M: ^ class-member? ( obj class -- ? )
-        [ CHAR: \u000085 = ]
+    2drop f ;
-        [ CHAR: \u002028 = ]
+
-        [ CHAR: \u002029 = ]
+M: $ class-member? ( obj class -- ? )
+    2drop f ;
+
+M: f class-member? 2drop f ;
+
+TUPLE: primitive-class class ;
+C: <primitive-class> primitive-class
+
+TUPLE: not-class class ;
+
+PREDICATE: not-integer < not-class class>> integer? ;
+PREDICATE: not-primitive < not-class class>> primitive-class? ;
+
+M: not-class class-member?
+    class>> class-member? not ;
+
+TUPLE: or-class seq ;
+
+M: or-class class-member?
+    seq>> [ class-member? ] with any? ;
+
+TUPLE: and-class seq ;
+
+M: and-class class-member?
+    seq>> [ class-member? ] with all? ;
+
+DEFER: substitute
+
+: flatten ( seq class -- newseq )
+    '[ dup _ instance? [ seq>> ] [ 1array ] if ] map concat ; inline
+
+:: seq>instance ( seq empty class -- instance )
+    seq length {
+        { 0 [ empty ] }
+        { 1 [ seq first ] }
+        [ drop class new seq { } like >>seq ]
+    } case ; inline
+
+TUPLE: class-partition integers not-integers primitives not-primitives and or other ;
+
+: partition-classes ( seq -- class-partition )
+    prune
+    [ integer? ] partition
+    [ not-integer? ] partition
+    [ primitive-class? ] partition ! extend primitive-class to epsilon tags
+    [ not-primitive? ] partition
+    [ and-class? ] partition
+    [ or-class? ] partition
+    class-partition boa ;
+
+: class-partition>seq ( class-partition -- seq )
+    make-mirror values concat ;
+
+: repartition ( partition -- partition' )
+    ! This could be made more efficient; only and and or are effected
+    class-partition>seq partition-classes ;
+
+: filter-not-integers ( partition -- partition' )
+    dup
+    [ primitives>> ] [ not-primitives>> ] [ or>> ] tri
+    3append and-class boa
+    '[ [ class>> _ class-member? ] filter ] change-not-integers ;
+
+: answer-ors ( partition -- partition' )
+    dup [ not-integers>> ] [ not-primitives>> ] [ primitives>> ] tri 3append
+    '[ [ _ [ t substitute ] each ] map ] change-or ;
+
+: contradiction? ( partition -- ? )
+    {
+        [ [ primitives>> ] [ not-primitives>> ] bi intersects? ]
+        [ other>> f swap member? ]
     } 1|| ;
 
-M: beginning-of-line class-member? ( obj class -- ? )
+: make-and-class ( partition -- and-class )
-    2drop f ;
+    answer-ors repartition
+    [ t swap remove ] change-other
+    dup contradiction?
+    [ drop f ]
+    [ filter-not-integers class-partition>seq prune t and-class seq>instance ] if ;
 
-M: end-of-line class-member? ( obj class -- ? )
+: <and-class> ( seq -- class )
-    2drop f ;
+    dup and-class flatten partition-classes
+    dup integers>> length {
+        { 0 [ nip make-and-class ] }
+        { 1 [ integers>> first [ '[ _ swap class-member? ] all? ] keep and ] }
+        [ 3drop f ]
+    } case ;
+
+: filter-integers ( partition -- partition' )
+    dup
+    [ primitives>> ] [ not-primitives>> ] [ and>> ] tri
+    3append or-class boa
+    '[ [ _ class-member? not ] filter ] change-integers ;
+
+: answer-ands ( partition -- partition' )
+    dup [ integers>> ] [ not-primitives>> ] [ primitives>> ] tri 3append
+    '[ [ _ [ f substitute ] each ] map ] change-and ;
+
+: tautology? ( partition -- ? )
+    {
+        [ [ primitives>> ] [ not-primitives>> ] bi intersects? ]
+        [ other>> t swap member? ]
+    } 1|| ;
+
+: make-or-class ( partition -- and-class )
+    answer-ands repartition
+    [ f swap remove ] change-other
+    dup tautology?
+    [ drop t ]
+    [ filter-integers class-partition>seq prune f or-class seq>instance ] if ;
+
+: <or-class> ( seq -- class )
+    dup or-class flatten partition-classes
+    dup not-integers>> length {
+        { 0 [ nip make-or-class ] }
+        { 1 [ not-integers>> first [ class>> '[ _ swap class-member? ] any? ] keep or ] }
+        [ 3drop t ]
+    } case ;
+
+GENERIC: <not-class> ( class -- inverse )
+
+M: object <not-class>
+    not-class boa ;
+
+M: not-class <not-class>
+    class>> ;
+
+M: and-class <not-class>
+    seq>> [ <not-class> ] map <or-class> ;
+
+M: or-class <not-class>
+    seq>> [ <not-class> ] map <and-class> ;
+
+M: t <not-class> drop f ;
+M: f <not-class> drop t ;
+
+M: primitive-class class-member?
+    class>> class-member? ;
+
+UNION: class primitive-class not-class or-class and-class range ;
+
+TUPLE: condition question yes no ;
+C: <condition> condition
+
+GENERIC# answer 2 ( class from to -- new-class )
+
+M:: object answer ( class from to -- new-class )
+    class from = to class ? ;
+
+: replace-compound ( class from to -- seq )
+    [ seq>> ] 2dip '[ _ _ answer ] map ;
+
+M: and-class answer
+    replace-compound <and-class> ;
+
+M: or-class answer
+    replace-compound <or-class> ;
+
+M: not-class answer
+    [ class>> ] 2dip answer <not-class> ;
+
+GENERIC# substitute 1 ( class from to -- new-class )
+M: object substitute answer ;
+M: not-class substitute [ <not-class> ] bi@ answer ;
+
+: assoc-answer ( table question answer -- new-table )
+    '[ _ _ substitute ] assoc-map
+    [ nip ] assoc-filter ;
+
+: assoc-answers ( table questions answer -- new-table )
+    '[ _ assoc-answer ] each ;
+
+DEFER: make-condition
+
+: (make-condition) ( table questions question -- condition )
+    [ 2nip ]
+    [ swap [ t assoc-answer ] dip make-condition ]
+    [ swap [ f assoc-answer ] dip make-condition ] 3tri
+    2dup = [ 2nip ] [ <condition> ] if ;
+
+: make-condition ( table questions -- condition )
+    [ keys ] [ unclip (make-condition) ] if-empty ;
+
+GENERIC: class>questions ( class -- questions )
+: compound-questions ( class -- questions ) seq>> [ class>questions ] gather ;
+M: or-class class>questions compound-questions ;
+M: and-class class>questions compound-questions ;
+M: not-class class>questions class>> class>questions ;
+M: object class>questions 1array ;
+
+: table>questions ( table -- questions )
+    values [ class>questions ] gather >array t swap remove ;
+
+: table>condition ( table -- condition )
+    ! input table is state => class
+    >alist dup table>questions make-condition ;
+
+: condition-map ( condition quot: ( obj -- obj' ) -- new-condition ) 
+    over condition? [
+        [ [ question>> ] [ yes>> ] [ no>> ] tri ] dip
+        '[ _ condition-map ] bi@ <condition>
+    ] [ call ] if ; inline recursive
+
+: condition-states ( condition -- states )
+    dup condition? [
+        [ yes>> ] [ no>> ] bi
+        [ condition-states ] bi@ append prune
+    ] [ 1array ] if ;
+
+: condition-at ( condition assoc -- new-condition )
+    '[ _ at ] condition-map ;

basis/regexp/combinators/combinators-docs.factor

@@ -0,0 +1,54 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup regexp strings ;
+IN: regexp.combinators
+
+ABOUT: "regexp.combinators"
+
+ARTICLE: "regexp.combinators" "Regular expression combinators"
+"The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This is in addition to the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary."
+{ $subsection <literal> }
+{ $subsection <nothing> }
+{ $subsection <or> }
+{ $subsection <and> }
+{ $subsection <not> }
+{ $subsection <sequence> }
+{ $subsection <zero-or-more> }
+{ $subsection <one-or-more> }
+{ $subsection <option> } ;
+
+HELP: <literal>
+{ $values { "string" string } { "regexp" regexp } }
+{ $description "Creates a regular expression which matches the given literal string." } ;
+
+HELP: <nothing>
+{ $values { "value" regexp } }
+{ $description "The empty regular language." } ;
+
+HELP: <or>
+{ $values { "regexps" "a sequence of regular expressions" } { "disjunction" regexp } }
+{ $description "Creates a new regular expression which matches the union of what elements of the sequence match." } ;
+
+HELP: <and>
+{ $values { "regexps" "a sequence of regular expressions" } { "conjunction" regexp } }
+{ $description "Creates a new regular expression which matches the intersection of what elements of the sequence match." } ;
+
+HELP: <sequence>
+{ $values { "regexps" "a sequence of regular expressions" } { "regexp" regexp } }
+{ $description "Creates a new regular expression which matches strings that match each element of the sequence in order." } ;
+
+HELP: <not>
+{ $values { "regexp" regexp } { "not-regexp" regexp } }
+{ $description "Creates a new regular expression which matches everything that the given regexp does not match." } ;
+
+HELP: <one-or-more>
+{ $values { "regexp" regexp } { "regexp+" regexp } }
+{ $description "Creates a new regular expression which matches one or more copies of the given regexp." } ;
+
+HELP: <option>
+{ $values { "regexp" regexp } { "regexp?" regexp } }
+{ $description "Creates a new regular expression which matches zero or one copies of the given regexp." } ;
+
+HELP: <zero-or-more>
+{ $values { "regexp" regexp } { "regexp*" regexp } }
+{ $description "Creates a new regular expression which matches zero or more copies of the given regexp." } ;

basis/regexp/combinators/combinators-tests.factor

@@ -0,0 +1,28 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp.combinators tools.test regexp kernel sequences ;
+IN: regexp.combinators.tests
+
+: strings ( -- regexp )
+    { "foo" "bar" "baz" } <any-of> ;
+
+[ t t t ] [ "foo" "bar" "baz" [ strings matches? ] tri@ ] unit-test
+[ f f f ] [ "food" "ibar" "ba" [ strings matches? ] tri@ ] unit-test
+
+: conj ( -- regexp )
+    { R' .*a' R' b.*' } <and> ;
+
+[ t ] [ "bljhasflsda" conj matches? ] unit-test
+[ f ] [ "bsdfdfs" conj matches? ] unit-test
+[ f ] [ "fsfa" conj matches? ] unit-test
+
+[ f ] [ "bljhasflsda" conj <not> matches? ] unit-test
+[ t ] [ "bsdfdfs" conj <not> matches? ] unit-test
+[ t ] [ "fsfa" conj <not> matches? ] unit-test
+
+[ f f ] [ "" "hi" [ <nothing> matches? ] bi@ ] unit-test
+[ t t ] [ "" "hi" [ <nothing> <not> matches? ] bi@ ] unit-test
+
+[ { t t t f } ] [ { "" "a" "aaaaa" "aab" } [ "a" <literal> <zero-or-more> matches? ] map ] unit-test
+[ { f t t f } ] [ { "" "a" "aaaaa" "aab" } [ "a" <literal> <one-or-more> matches? ] map ] unit-test
+[ { t t f f } ] [ { "" "a" "aaaaa" "aab" } [ "a" <literal> <option> matches? ] map ] unit-test

basis/regexp/combinators/combinators.factor

@@ -0,0 +1,56 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp sequences kernel regexp.negation regexp.ast
+accessors fry regexp.classes ;
+IN: regexp.combinators
+
+<PRIVATE
+
+: modify-regexp ( regexp raw-quot tree-quot -- new-regexp )
+    [ '[ raw>> @ ] ]
+    [ '[ parse-tree>> @ ] ] bi* bi
+    make-regexp ; inline
+
+PRIVATE>
+
+CONSTANT: <nothing> R/ (?~.*)/
+
+: <literal> ( string -- regexp )
+    [ "\\Q" "\\E" surround ] [ <concatenation> ] bi make-regexp ; foldable
+
+: <char-range> ( char1 char2 -- regexp )
+    [ [ "[" "-" surround ] [ "]" append ] bi* append ]
+    [ <range> ]
+    2bi make-regexp ;
+
+: <or> ( regexps -- disjunction )
+    [ [ raw>> "(" ")" surround ] map "|" join ]
+    [ [ parse-tree>> ] map <alternation> ] bi
+    make-regexp ; foldable
+
+: <any-of> ( strings -- regexp )
+    [ <literal> ] map <or> ; foldable
+
+: <sequence> ( regexps -- regexp )
+    [ [ raw>> ] map concat ]
+    [ [ parse-tree>> ] map <concatenation> ] bi
+    make-regexp ; foldable
+
+: <not> ( regexp -- not-regexp )
+    [ "(?~" ")" surround ]
+    [ <negation> ] modify-regexp ; foldable
+
+: <and> ( regexps -- conjunction )
+    [ <not> ] map <or> <not> ; foldable
+
+: <zero-or-more> ( regexp -- regexp* )
+    [ "(" ")*" surround ]
+    [ <star> ] modify-regexp ; foldable
+
+: <one-or-more> ( regexp -- regexp+ )
+    [ "(" ")+" surround ]
+    [ <plus> ] modify-regexp ; foldable
+
+: <option> ( regexp -- regexp? )
+    [ "(" ")?" surround ]
+    [ <maybe> ] modify-regexp ; foldable

basis/regexp/combinators/summary.txt

@@ -0,0 +1 @@
+Combinators for creating regular expressions

basis/regexp/combinators/tags.txt

@@ -1,2 +1 @@
-lisp
 parsing

basis/regexp/compiler/compiler.factor

@@ -0,0 +1,142 @@
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp.classes kernel sequences regexp.negation
+quotations assocs fry math locals combinators
+accessors words compiler.units kernel.private strings
+sequences.private arrays call namespaces unicode.breaks
+regexp.transition-tables combinators.short-circuit ;
+IN: regexp.compiler
+
+GENERIC: question>quot ( question -- quot )
+
+SYMBOL: shortest?
+SYMBOL: backwards?
+
+<PRIVATE
+
+M: t question>quot drop [ 2drop t ] ;
+M: f question>quot drop [ 2drop f ] ;
+
+M: not-class question>quot
+    class>> question>quot [ not ] compose ;
+
+M: beginning-of-input question>quot
+    drop [ drop zero? ] ;
+
+M: end-of-input question>quot
+    drop [ length = ] ;
+
+M: end-of-file question>quot
+    drop [
+        {
+            [ length swap - 2 <= ]
+            [ swap tail { "\n" "\r\n" "\r" "" } member? ]
+        } 2&&
+    ] ;
+
+M: $ question>quot
+    drop [ { [ length = ] [ ?nth "\r\n" member? ] } 2|| ] ;
+
+M: ^ question>quot
+    drop [ { [ drop zero? ] [ [ 1- ] dip ?nth "\r\n" member? ] } 2|| ] ;
+
+M: word-break question>quot
+    drop [ word-break-at? ] ;
+
+: (execution-quot) ( next-state -- quot )
+    ! The conditions here are for lookaround and anchors, etc
+    dup condition? [
+        [ question>> question>quot ] [ yes>> ] [ no>> ] tri
+        [ (execution-quot) ] bi@
+        '[ 2dup @ _ _ if ]
+    ] [ '[ _ execute ] ] if ;
+
+: execution-quot ( next-state -- quot )
+    dup sequence? [ first ] when
+    (execution-quot) ;
+
+TUPLE: box contents ;
+C: <box> box
+
+: condition>quot ( condition -- quot )
+    ! Conditions here are for different classes
+    dup condition? [
+        [ question>> ] [ yes>> ] [ no>> ] tri
+        [ condition>quot ] bi@
+        '[ dup _ class-member? _ _ if ]
+    ] [
+        contents>>
+        [ [ 3drop ] ] [ execution-quot '[ drop @ ] ] if-empty
+    ] if ;
+
+: non-literals>dispatch ( literals non-literals  -- quot )
+    [ swap ] assoc-map ! we want state => predicate, and get the opposite as input
+    swap keys f assoc-answers
+    table>condition [ <box> ] condition-map condition>quot ;
+
+: literals>cases ( literal-transitions -- case-body )
+    [ execution-quot ] assoc-map ;
+
+: split-literals ( transitions -- case default )
+    { } assoc-like [ first integer? ] partition
+    [ [ literals>cases ] keep ] dip non-literals>dispatch ;
+
+:: step ( last-match index str quot final? direction -- last-index/f )
+    final? index last-match ?
+    index str bounds-check? [
+        index direction + str
+        index str nth-unsafe
+        quot call
+    ] when ; inline
+
+: direction ( -- n )
+    backwards? get -1 1 ? ;
+
+: transitions>quot ( transitions final-state? -- quot )
+    dup shortest? get and [ 2drop [ drop nip ] ] [
+        [ split-literals swap case>quot ] dip direction
+        '[ { array-capacity string } declare _ _ _ step ]
+    ] if ;
+
+: word>quot ( word dfa -- quot )
+    [ transitions>> at ]
+    [ final-states>> key? ] 2bi
+    transitions>quot ;
+
+: states>code ( words dfa -- )
+    [ ! with-compilation-unit doesn't compile, so we need call( -- )
+        [
+            '[
+                dup _ word>quot
+                (( last-match index string -- ? ))
+                define-declared
+            ] each
+        ] with-compilation-unit
+    ] call( words dfa -- ) ;
+
+: states>words ( dfa -- words dfa )
+    dup transitions>> keys [ gensym ] H{ } map>assoc
+    [ transitions-at ]
+    [ values ]
+    bi swap ; 
+
+: dfa>main-word ( dfa -- word )
+    states>words [ states>code ] keep start-state>> ;
+
+PRIVATE>
+
+: simple-define-temp ( quot effect -- word )
+    [ [ define-temp ] with-compilation-unit ] call( quot effect -- word ) ;
+
+: dfa>word ( dfa -- quot )
+    dfa>main-word execution-quot '[ drop [ f ] 2dip @ ]
+    (( start-index string regexp -- i/f )) simple-define-temp ;
+
+: dfa>shortest-word ( dfa -- word )
+    t shortest? [ dfa>word ] with-variable ;
+
+: dfa>reverse-word ( dfa -- word )
+    t backwards? [ dfa>word ] with-variable ;
+
+: dfa>reverse-shortest-word ( dfa -- word )
+    t backwards? [ dfa>shortest-word ] with-variable ;

basis/regexp/dfa/dfa-tests.factor

@@ -0,0 +1,3 @@
+USING: regexp.dfa tools.test ;
+IN: regexp.dfa.tests
+

basis/regexp/dfa/dfa.factor

@@ -1,84 +1,84 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators fry kernel locals
 math math.order regexp.nfa regexp.transition-tables sequences
-sets sorting vectors regexp.utils sequences.deep ;
+sets sorting vectors regexp.ast regexp.classes ;
-USING: io prettyprint threads ;
 IN: regexp.dfa
 
-: find-delta ( states transition regexp -- new-states )
+: find-delta ( states transition nfa -- new-states )
-    nfa-table>> transitions>>
+    transitions>> '[ _ swap _ at at ] gather sift ;
-    rot [ swap at at ] with with gather sift ;
 
-: (find-epsilon-closure) ( states regexp -- new-states )
+:: epsilon-loop ( state table nfa question -- )
-    eps swap find-delta ;
+    state table at :> old-value
+    old-value question 2array <or-class> :> new-question
+    new-question old-value = [
+        new-question state table set-at
+        state nfa transitions>> at
+        [ drop tagged-epsilon? ] assoc-filter
+        [| trans to |
+            to [
+                table nfa
+                trans tag>> new-question 2array <and-class>
+                epsilon-loop
+            ] each
+        ] assoc-each
+    ] unless ;
 
-: find-epsilon-closure ( states regexp -- new-states )
+: epsilon-table ( states nfa -- table )
-    '[ dup _ (find-epsilon-closure) union ] [ length ] while-changes
+    [ H{ } clone tuck ] dip
-    natural-sort ;
+    '[ _ _ t epsilon-loop ] each ;
 
-: find-closure ( states transition regexp -- new-states )
+: find-epsilon-closure ( states nfa -- dfa-state )
-    [ find-delta ] 2keep nip find-epsilon-closure ;
+    epsilon-table table>condition ;
 
-: find-start-state ( regexp -- state )
+: find-closure ( states transition nfa -- new-states )
-    [ nfa-table>> start-state>> 1vector ] keep find-epsilon-closure ;
+    [ find-delta ] keep find-epsilon-closure ;
 
-: find-transitions ( seq1 regexp -- seq2 )
+: find-start-state ( nfa -- state )
-    nfa-table>> transitions>>
+    [ start-state>> 1array ] keep find-epsilon-closure ;
-    [ at keys ] curry gather
-    eps swap remove ;
 
-: add-todo-state ( state regexp -- )
+: find-transitions ( dfa-state nfa -- next-dfa-state )
-    2dup visited-states>> key? [
+    transitions>>
-        2drop
+    '[ _ at keys [ condition-states ] map concat ] gather
-    ] [
+    [ tagged-epsilon? not ] filter ;
-        [ visited-states>> conjoin ]
+
-        [ new-states>> push ] 2bi
+: add-todo-state ( state visited-states new-states -- )
+    3dup drop key? [ 3drop ] [
+        [ conjoin ] [ push ] bi-curry* bi
     ] if ;
 
-: new-transitions ( regexp -- )
+: add-todo-states ( state/condition visited-states new-states -- )
-    dup new-states>> [
+    [ condition-states ] 2dip
-        drop
+    '[ _ _ add-todo-state ] each ;
-    ] [
+
-        dupd pop dup pick find-transitions rot
+:: new-transitions ( nfa dfa new-states visited-states -- nfa dfa )
-        [
+    new-states [ nfa dfa ] [
-            [ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep
+        pop :> state
-            [ swapd transition make-transition ] dip
+        state dfa transitions>> maybe-initialize-key
-            dfa-table>> add-transition 
+        state nfa find-transitions
-        ] curry with each
+        [| trans |
-        new-transitions
+            state trans nfa find-closure :> new-state
+            new-state visited-states new-states add-todo-states
+            state new-state trans dfa set-transition
+        ] each
+        nfa dfa new-states visited-states new-transitions
     ] if-empty ;
 
-: states ( hashtable -- array )
+: set-final-states ( nfa dfa -- )
-    [ keys ]
+    [
-    [ values [ values concat ] map concat append ] bi ;
+        [ final-states>> keys ]
+        [ transitions>> keys ] bi*
+        [ intersects? ] with filter
+        unique
+    ] keep (>>final-states) ;
 
-: set-final-states ( regexp -- )
+: initialize-dfa ( nfa -- dfa )
-    dup
+    <transition-table>
-    [ nfa-table>> final-states>> keys ]
+        swap find-start-state >>start-state ;
-    [ dfa-table>> transitions>> states ] bi
-    [ intersects? ] with filter
 
-    swap dfa-table>> final-states>>
+: construct-dfa ( nfa -- dfa )
-    [ conjoin ] curry each ;
+    dup initialize-dfa
-
+    dup start-state>> condition-states >vector
-: set-initial-state ( regexp -- )
+    H{ } clone
-    dup
+    new-transitions
-    [ dfa-table>> ] [ find-start-state ] bi
+    [ set-final-states ] keep ;
-    [ >>start-state drop ] keep
-    1vector >>new-states drop ;
-
-: set-traversal-flags ( regexp -- )
-    dup
-    [ nfa-traversal-flags>> ]
-    [ dfa-table>> transitions>> keys ] bi
-    [ [ nip ] [ [ swap at ] with map concat ] 2bi ] with H{ } map>assoc
-    >>dfa-traversal-flags drop ;
-
-: construct-dfa ( regexp -- )
-    {
-        [ set-initial-state ]
-        [ new-transitions ]
-        [ set-final-states ]
-        [ set-traversal-flags ]
-    } cleave ;

basis/regexp/disambiguate/disambiguate.factor

@@ -0,0 +1,43 @@
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors regexp.classes math.bits assocs sequences
+arrays sets regexp.dfa math fry regexp.minimize regexp.ast regexp.transition-tables ;
+IN: regexp.disambiguate
+
+TUPLE: parts in out ;
+
+: make-partition ( choices classes -- partition )
+    zip [ first ] partition [ values ] bi@ parts boa ;
+
+: powerset-partition ( classes -- partitions )
+    [ length [ 2^ ] keep ] keep '[
+        _ <bits> _ make-partition
+    ] map rest ;
+
+: partition>class ( parts -- class )
+    [ out>> [ <not-class> ] map ]
+    [ in>> <and-class> ] bi
+    prefix <and-class> ;
+
+: get-transitions ( partition state-transitions -- next-states )
+    [ in>> ] dip '[ _ at ] gather sift ;
+
+: new-transitions ( transitions -- assoc ) ! assoc is class, partition
+    values [ keys ] gather
+    [ tagged-epsilon? not ] filter
+    powerset-partition
+    [ [ partition>class ] keep ] { } map>assoc
+    [ drop ] assoc-filter ;
+
+: preserving-epsilon ( state-transitions quot -- new-state-transitions )
+    [ [ drop tagged-epsilon? ] assoc-filter ] bi
+    assoc-union H{ } assoc-like ; inline
+: disambiguate ( nfa -- nfa )  
+    expand-ors [
+        dup new-transitions '[
+            [
+                _ swap '[ _ get-transitions ] assoc-map
+                [ nip empty? not ] assoc-filter 
+            ] preserving-epsilon
+        ] assoc-map
+    ] change-transitions ;

basis/regexp/minimize/minimize-tests.factor

@@ -0,0 +1,58 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test regexp.minimize assocs regexp
+accessors regexp.transition-tables regexp.parser
+regexp.classes regexp.negation ;
+IN: regexp.minimize.tests
+
+[ t ] [ 1 2 H{ { { 1 2 } t } } same-partition? ] unit-test
+[ t ] [ 2 1 H{ { { 1 2 } t } } same-partition? ] unit-test
+[ f ] [ 2 3 H{ { { 1 2 } t } } same-partition? ] unit-test
+
+[ H{ { 1 1 } { 2 1 } { 3 3 } { 4 3 } } ]
+[ { { 1 1 } { 1 2 } { 2 2 } { 3 3 } { 3 4 } { 4 4 } } [ t ] H{ } map>assoc partition>classes ] unit-test
+
+[ { { 1 2 } { 3 4 } } ] [ H{ { "elephant" 1 } { "tiger" 3 } } H{ { "elephant" 2 } { "tiger" 4 } } assemble-values ] unit-test
+
+: regexp-states ( string -- n )
+    parse-regexp ast>dfa transitions>> assoc-size ;
+
+[ 3 ] [ "ab|ac" regexp-states ] unit-test
+[ 3 ] [ "a(b|c)" regexp-states ] unit-test
+[ 1 ] [ "((aa*)*)*" regexp-states ] unit-test
+[ 1 ] [ "a|((aa*)*)*" regexp-states ] unit-test
+[ 2 ] [ "ab|((aa*)*)*b" regexp-states ] unit-test
+[ 4 ] [ "ab|cd" regexp-states ] unit-test
+[ 1 ] [ "(?i:[a-z]*|[A-Z]*)" regexp-states ] unit-test
+
+[
+    T{ transition-table
+        { transitions H{
+            { 0 H{ { CHAR: a 1 } { CHAR: b 1 } } }
+            { 1 H{ { CHAR: a 2 } { CHAR: b 2 } } }
+            { 2 H{ { CHAR: c 3 } } }
+            { 3 H{ } }
+        } }
+        { start-state 0 }
+        { final-states H{ { 3 3 } } }
+    }
+] [ 
+    T{ transition-table
+        { transitions H{
+            { 0 H{ { CHAR: a 1 } { CHAR: b 4 } } }
+            { 1 H{ { CHAR: a 2 } { CHAR: b 5 } } }
+            { 2 H{ { CHAR: c 3 } } }
+            { 3 H{ } }
+            { 4 H{ { CHAR: a 2 } { CHAR: b 5 } } }
+            { 5 H{ { CHAR: c 6 } } }
+            { 6 H{ } }
+        } }
+        { start-state 0 }
+        { final-states H{ { 3 3 } { 6 6 } } }
+    } combine-states
+] unit-test
+
+[ [ ] [ ] while-changes ] must-infer
+
+[ H{ { T{ or-class f { 2 1 } } 3 } { 4 5 } } ]
+[ H{ { 1 3 } { 2 3 } { 4 5 } } combine-state-transitions ] unit-test

basis/regexp/minimize/minimize.factor

@@ -0,0 +1,100 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences regexp.transition-tables fry assocs
+accessors locals math sorting arrays sets hashtables regexp.dfa
+combinators.short-circuit regexp.classes ;
+IN: regexp.minimize
+
+: table>state-numbers ( table -- assoc )
+    transitions>> keys <enum> [ swap ] H{ } assoc-map-as ;
+
+: number-states ( table -- newtable )
+    dup table>state-numbers transitions-at ;
+
+: has-conditions? ( assoc -- ? )
+    values [ condition? ] any? ;
+
+: initially-same? ( s1 s2 transition-table -- ? )
+    {
+        [ drop <= ]
+        [ transitions>> '[ _ at keys ] bi@ set= ]
+        [ final-states>> '[ _ key? ] bi@ = ]
+    } 3&& ;
+
+:: initialize-partitions ( transition-table -- partitions )
+    ! Partition table is sorted-array => ?
+    H{ } clone :> out
+    transition-table transitions>> keys :> states
+    states [| s1 |
+        states [| s2 |
+            s1 s2 transition-table initially-same?
+            [ s1 s2 2array out conjoin ] when
+        ] each
+    ] each out ;
+
+: same-partition? ( s1 s2 partitions -- ? )
+    { [ [ 2array natural-sort ] dip key? ] [ drop = ] } 3|| ;
+
+: assemble-values ( assoc1 assoc2 -- values )
+    dup keys '[ _ swap [ at ] curry map ] bi@ zip ;
+
+: stay-same? ( s1 s2 transition partitions -- ? )
+    [ '[ _ transitions>> at ] bi@ assemble-values ] dip
+    '[ _ same-partition? ] assoc-all? ;
+
+: partition-more ( partitions transition-table -- partitions )
+    over '[ drop first2 _ _ stay-same? ] assoc-filter ;
+
+: partition>classes ( partitions -- synonyms ) ! old-state => new-state
+    >alist sort-keys
+    [ drop first2 swap ] assoc-map
+    <reversed>
+    >hashtable ;
+
+:: (while-changes) ( obj quot: ( obj -- obj' ) comp: ( obj -- key ) old-key -- obj )
+    obj quot call :> new-obj
+    new-obj comp call :> new-key
+    new-key old-key =
+    [ new-obj ]
+    [ new-obj quot comp new-key (while-changes) ]
+    if ; inline recursive
+
+: while-changes ( obj quot pred -- obj' )
+    3dup nip call (while-changes) ; inline
+
+: (state-classes) ( transition-table -- partition )
+    [ initialize-partitions ] keep
+    '[ _ partition-more ] [ assoc-size ] while-changes ;
+
+: assoc>set ( assoc -- keys-set )
+    [ drop dup ] assoc-map ;
+
+: state-classes ( transition-table -- synonyms )
+    clone [ [ nip has-conditions? ] assoc-partition ] change-transitions
+    [ assoc>set ] [ (state-classes) partition>classes ] bi* assoc-union ;
+
+: canonical-state? ( state transitions state-classes -- ? )
+    '[ dup _ at =  ] swap '[ _ at has-conditions? ] bi or ;
+
+: delete-duplicates ( transitions state-classes -- new-transitions )
+    dupd '[ drop _ _ canonical-state? ] assoc-filter ;
+
+: combine-states ( table -- smaller-table )
+    dup state-classes
+    [ transitions-at ] keep
+    '[ _ delete-duplicates ] change-transitions ;
+
+: combine-state-transitions ( hash -- hash )
+    H{ } clone tuck '[
+        _ [ 2array <or-class> ] change-at
+    ] assoc-each [ swap ] assoc-map ;
+
+: combine-transitions ( table -- table )
+    [ [ combine-state-transitions ] assoc-map ] change-transitions ;
+
+: minimize ( table -- minimal-table )
+    clone
+    number-states
+    combine-states
+    combine-transitions
+    expand-ors ;

basis/regexp/negation/negation-tests.factor

@@ -0,0 +1,27 @@
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test regexp.negation regexp.transition-tables regexp.classes ;
+IN: regexp.negation.tests
+
+[
+    ! R/ |[^a]|.+/
+    T{ transition-table
+        { transitions H{
+            { 0 H{ { CHAR: a 1 } { T{ not-class f CHAR: a } -1 } } }
+            { 1 H{ { t -1 } } }
+            { -1 H{ { t -1 } } }
+        } } 
+        { start-state 0 }
+        { final-states H{ { 0 0 } { -1 -1 } } }
+    }
+] [
+    ! R/ a/
+    T{ transition-table
+        { transitions H{
+            { 0 H{ { CHAR: a 1 } } }
+            { 1 H{ } } 
+        } }
+        { start-state 0 }
+        { final-states H{ { 1 1 } } }
+    } negate-table
+] unit-test

basis/regexp/negation/negation.factor

@@ -0,0 +1,53 @@
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp.nfa regexp.disambiguate kernel sequences
+assocs regexp.classes hashtables accessors fry vectors
+regexp.ast regexp.transition-tables regexp.minimize
+regexp.dfa namespaces ;
+IN: regexp.negation
+
+CONSTANT: fail-state -1
+
+: add-default-transition ( state's-transitions -- new-state's-transitions )
+    clone dup
+    [ [ fail-state ] dip keys [ <not-class> ] map <and-class> ] keep set-at ;
+
+: fail-state-recurses ( transitions -- new-transitions )
+    clone dup
+    [ fail-state t associate fail-state ] dip set-at ;
+
+: add-fail-state ( transitions -- new-transitions )
+    [ add-default-transition ] assoc-map
+    fail-state-recurses ;
+
+: inverse-final-states ( transition-table -- final-states )
+    [ transitions>> assoc>set ] [ final-states>> ] bi assoc-diff ;
+
+: negate-table ( transition-table -- transition-table )
+    clone
+        [ add-fail-state ] change-transitions
+        dup inverse-final-states >>final-states ;
+
+: renumber-states ( transition-table -- transition-table )
+    dup transitions>> keys [ next-state ] H{ } map>assoc
+    transitions-at ;
+
+: box-transitions ( transition-table -- transition-table )
+    [ [ [ 1vector ] assoc-map ] assoc-map ] change-transitions ;
+
+: unify-final-state ( transition-table -- transition-table )
+    dup [ final-states>> keys ] keep
+    '[ -2 epsilon _ set-transition ] each
+    H{ { -2 -2 } } >>final-states ;
+
+: adjoin-dfa ( transition-table -- start end )
+    unify-final-state renumber-states box-transitions 
+    [ start-state>> ]
+    [ final-states>> keys first ]
+    [ nfa-table get [ transitions>> ] bi@ swap update ] tri ;
+
+: ast>dfa ( parse-tree -- minimal-dfa )
+    construct-nfa disambiguate construct-dfa minimize ;
+
+M: negation nfa-node ( node -- start end )
+    term>> ast>dfa negate-table adjoin-dfa ;

basis/regexp/nfa/nfa.factor

@@ -1,235 +1,153 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs grouping kernel regexp.backend
+USING: accessors arrays assocs grouping kernel
-locals math namespaces regexp.parser sequences fry quotations
+locals math namespaces sequences fry quotations
-math.order math.ranges vectors unicode.categories regexp.utils
+math.order math.ranges vectors unicode.categories
-regexp.transition-tables words sets regexp.classes unicode.case.private ;
+regexp.transition-tables words sets hashtables combinators.short-circuit
+unicode.case.private regexp.ast regexp.classes ;
+IN: regexp.nfa
+
 ! This uses unicode.case.private for ch>upper and ch>lower
 ! but case-insensitive matching should be done by case-folding everything
 ! before processing starts
-IN: regexp.nfa
 
-ERROR: feature-is-broken feature ;
+SYMBOL: option-stack
 
-SYMBOL: negation-mode
+SYMBOL: state
-: negated? ( -- ? ) negation-mode get 0 or odd? ; 
 
-SINGLETON: eps
+: next-state ( -- state )
+    state [ get ] [ inc ] bi ;
 
-MIXIN: traversal-flag
+SYMBOL: nfa-table
-SINGLETON: lookahead-on INSTANCE: lookahead-on traversal-flag
-SINGLETON: lookahead-off INSTANCE: lookahead-off traversal-flag
-SINGLETON: lookbehind-on INSTANCE: lookbehind-on traversal-flag
-SINGLETON: lookbehind-off INSTANCE: lookbehind-off traversal-flag
-SINGLETON: capture-group-on INSTANCE: capture-group-on traversal-flag
-SINGLETON: capture-group-off INSTANCE: capture-group-off traversal-flag
-SINGLETON: front-anchor INSTANCE: front-anchor traversal-flag
-SINGLETON: back-anchor INSTANCE: back-anchor traversal-flag
-SINGLETON: word-boundary INSTANCE: word-boundary traversal-flag
 
-: options ( -- obj ) current-regexp get options>> ;
+: set-each ( keys value hashtable -- )
+    '[ _ swap _ set-at ] each ;
 
-: option? ( obj -- ? ) options key? ;
+: options>hash ( options -- hashtable )
+    H{ } clone [
+        [ [ on>> t ] dip set-each ]
+        [ [ off>> f ] dip set-each ] 2bi
+    ] keep ;
 
-: option-on ( obj -- ) options conjoin ;
+: using-options ( options quot -- )
+    [ options>hash option-stack [ ?push ] change ] dip
+    call option-stack get pop* ; inline
 
-: option-off ( obj -- ) options delete-at ;
+: option? ( obj -- ? )
+    option-stack get assoc-stack ;
 
-: next-state ( regexp -- state )
+GENERIC: nfa-node ( node -- start-state end-state )
-    [ state>> ] [ [ 1+ ] change-state drop ] bi ;
 
-: set-start-state ( regexp -- )
+: add-simple-entry ( obj -- start-state end-state )
-    dup stack>> [
+    [ next-state next-state 2dup ] dip
-        drop
+    nfa-table get add-transition ;
-    ] [
-        [ nfa-table>> ] [ pop first ] bi* >>start-state drop
-    ] if-empty ;
 
-GENERIC: nfa-node ( node -- )
+: epsilon-transition ( source target -- )
+    epsilon nfa-table get add-transition ;
 
-:: add-simple-entry ( obj class -- )
+M:: star nfa-node ( node -- start end )
-    [let* | regexp [ current-regexp get ]
+    node term>> nfa-node :> s1 :> s0
-            s0 [ regexp next-state ]
+    next-state :> s2
-            s1 [ regexp next-state ]
+    next-state :> s3
-            stack [ regexp stack>> ]
+    s1 s0 epsilon-transition
-            table [ regexp nfa-table>> ] |
+    s2 s0 epsilon-transition
-        negated? [
+    s2 s3 epsilon-transition
-            s0 f obj class make-transition table add-transition
+    s1 s3 epsilon-transition
-            s0 s1 <default-transition> table add-transition
+    s2 s3 ;
-        ] [
-            s0 s1 obj class make-transition table add-transition
-        ] if
-        s0 s1 2array stack push
-        t s1 table final-states>> set-at ] ;
 
-: add-traversal-flag ( flag -- )
+GENERIC: modify-epsilon ( tag -- newtag )
-    stack peek second
+! Potential off-by-one errors when lookaround nested in lookbehind
-    current-regexp get nfa-traversal-flags>> push-at ;
 
-:: concatenate-nodes ( -- )
+M: object modify-epsilon ;
-    [let* | regexp [ current-regexp get ]
-            stack [ regexp stack>> ]
-            table [ regexp nfa-table>> ]
-            s2 [ stack peek first ]
-            s3 [ stack pop second ]
-            s0 [ stack peek first ]
-            s1 [ stack pop second ] |
-        s1 s2 eps <literal-transition> table add-transition
-        s1 table final-states>> delete-at
-        s0 s3 2array stack push ] ;
 
-:: alternate-nodes ( -- )
+M: $ modify-epsilon
-    [let* | regexp [ current-regexp get ]
+    multiline option? [ drop end-of-input ] unless ;
-            stack [ regexp stack>> ]
-            table [ regexp nfa-table>> ]
-            s2 [ stack peek first ]
-            s3 [ stack pop second ]
-            s0 [ stack peek first ]
-            s1 [ stack pop second ]
-            s4 [ regexp next-state ]
-            s5 [ regexp next-state ] |
-        s4 s0 eps <literal-transition> table add-transition
-        s4 s2 eps <literal-transition> table add-transition
-        s1 s5 eps <literal-transition> table add-transition
-        s3 s5 eps <literal-transition> table add-transition
-        s1 table final-states>> delete-at
-        s3 table final-states>> delete-at
-        t s5 table final-states>> set-at
-        s4 s5 2array stack push ] ;
 
-M: kleene-star nfa-node ( node -- )
+M: ^ modify-epsilon
-    term>> nfa-node
+    multiline option? [ drop beginning-of-input ] unless ;
-    [let* | regexp [ current-regexp get ]
-            stack [ regexp stack>> ]
-            s0 [ stack peek first ]
-            s1 [ stack pop second ]
-            s2 [ regexp next-state ]
-            s3 [ regexp next-state ]
-            table [ regexp nfa-table>> ] |
-        s1 table final-states>> delete-at
-        t s3 table final-states>> set-at
-        s1 s0 eps <literal-transition> table add-transition
-        s2 s0 eps <literal-transition> table add-transition
-        s2 s3 eps <literal-transition> table add-transition
-        s1 s3 eps <literal-transition> table add-transition
-        s2 s3 2array stack push ] ;
 
-M: concatenation nfa-node ( node -- )
+M: tagged-epsilon nfa-node
-    seq>>
+    clone [ modify-epsilon ] change-tag add-simple-entry ;
-    reversed-regexp option? [ <reversed> ] when
-    [ [ nfa-node ] each ]
-    [ length 1- [ concatenate-nodes ] times ] bi ;
 
-M: alternation nfa-node ( node -- )
+M: concatenation nfa-node ( node -- start end )
-    seq>>
+    [ first>> ] [ second>> ] bi
-    [ [ nfa-node ] each ]
+    reversed-regexp option? [ swap ] when
-    [ length 1- [ alternate-nodes ] times ] bi ;
+    [ nfa-node ] bi@
+    [ epsilon-transition ] dip ;
 
-M: constant nfa-node ( node -- )
+:: alternate-nodes ( s0 s1 s2 s3 -- start end )
+    next-state :> s4
+    next-state :> s5
+    s4 s0 epsilon-transition
+    s4 s2 epsilon-transition
+    s1 s5 epsilon-transition
+    s3 s5 epsilon-transition
+    s4 s5 ;
+
+M: alternation nfa-node ( node -- start end )
+    [ first>> ] [ second>> ] bi
+    [ nfa-node ] bi@
+    alternate-nodes ;
+
+GENERIC: modify-class ( char-class -- char-class' )
+
+M: object modify-class ;
+
+M: integer modify-class
     case-insensitive option? [
-        dup char>> [ ch>lower ] [ ch>upper ] bi
+        dup Letter? [
-        2dup = [
+            [ ch>lower ] [ ch>upper ] bi 2array <or-class>
-            2drop
+        ] when
-            char>> literal-transition add-simple-entry
+    ] when ;
-        ] [
-            [ literal-transition add-simple-entry ] bi@
-            alternate-nodes drop
-        ] if
-    ] [
-        char>> literal-transition add-simple-entry
-    ] if ;
 
-M: epsilon nfa-node ( node -- )
+M: integer nfa-node ( node -- start end )
-    drop eps literal-transition add-simple-entry ;
+    modify-class add-simple-entry ;
 
-M: word nfa-node ( node -- ) class-transition add-simple-entry ;
+M: primitive-class modify-class
+    class>> modify-class <primitive-class> ;
 
-M: any-char nfa-node ( node -- )
+M: or-class modify-class
-    [ dotall option? ] dip any-char-no-nl ?
+    seq>> [ modify-class ] map <or-class> ;
-    class-transition add-simple-entry ;
 
-! M: beginning-of-text nfa-node ( node -- ) ;
+M: not-class modify-class
+    class>> modify-class <not-class> ;
 
-M: beginning-of-line nfa-node ( node -- ) class-transition add-simple-entry ;
+M: any-char modify-class
+    drop dotall option? t any-char-no-nl ? ;
 
-M: end-of-line nfa-node ( node -- ) class-transition add-simple-entry ;
+: modify-letter-class ( class -- newclass )
+    case-insensitive option? [ drop Letter-class ] when ;
+M: letter-class modify-class modify-letter-class ;
+M: LETTER-class modify-class modify-letter-class ;
 
-: choose-letter-class ( node -- node' )
+: cased-range? ( range -- ? )
-    case-insensitive option? Letter-class rot ? ;
+    [ from>> ] [ to>> ] bi {
+        [ [ letter? ] bi@ and ]
+        [ [ LETTER? ] bi@ and ]
+    } 2|| ;
 
-M: letter-class nfa-node ( node -- )
+M: range modify-class
-    choose-letter-class class-transition add-simple-entry ;
-
-M: LETTER-class nfa-node ( node -- )
-    choose-letter-class class-transition add-simple-entry ;
-
-M: character-class-range nfa-node ( node -- )
     case-insensitive option? [
-        ! This should be implemented for Unicode by case-folding
+        dup cased-range? [
-        ! the input and all strings in the regexp.
+            [ from>> ] [ to>> ] bi
-        dup [ from>> ] [ to>> ] bi
+            [ [ ch>lower ] bi@ <range> ]
-        2dup [ Letter? ] bi@ and [
+            [ [ ch>upper ] bi@ <range> ] 2bi 
-            rot drop
+            2array <or-class>
-            [ [ ch>lower ] bi@ character-class-range boa ]
+        ] when
-            [ [ ch>upper ] bi@ character-class-range boa ] 2bi 
+    ] when ;
-            [ class-transition add-simple-entry ] bi@
-            alternate-nodes
-        ] [
-            2drop
-            class-transition add-simple-entry
-        ] if
-    ] [
-        class-transition add-simple-entry
-    ] if ;
 
-M: capture-group nfa-node ( node -- )
+M: class nfa-node
-    "capture-groups" feature-is-broken
+    modify-class add-simple-entry ;
-    eps literal-transition add-simple-entry
-    capture-group-on add-traversal-flag
-    term>> nfa-node
-    eps literal-transition add-simple-entry
-    capture-group-off add-traversal-flag
-    2 [ concatenate-nodes ] times ;
 
-! xyzzy
+M: with-options nfa-node ( node -- start end )
-M: non-capture-group nfa-node ( node -- )
+    dup options>> [ tree>> nfa-node ] using-options ;
-    term>> nfa-node ;
 
-M: reluctant-kleene-star nfa-node ( node -- )
+: construct-nfa ( ast -- nfa-table )
-    term>> <kleene-star> nfa-node ;
-
-M: negation nfa-node ( node -- )
-    negation-mode inc
-    term>> nfa-node 
-    negation-mode dec ;
-
-M: lookahead nfa-node ( node -- )
-    "lookahead" feature-is-broken
-    eps literal-transition add-simple-entry
-    lookahead-on add-traversal-flag
-    term>> nfa-node
-    eps literal-transition add-simple-entry
-    lookahead-off add-traversal-flag
-    2 [ concatenate-nodes ] times ;
-
-M: lookbehind nfa-node ( node -- )
-    "lookbehind" feature-is-broken
-    eps literal-transition add-simple-entry
-    lookbehind-on add-traversal-flag
-    term>> nfa-node
-    eps literal-transition add-simple-entry
-    lookbehind-off add-traversal-flag
-    2 [ concatenate-nodes ] times ;
-
-M: option nfa-node ( node -- )
-    [ option>> ] [ on?>> ] bi [ option-on ] [ option-off ] if
-    eps literal-transition add-simple-entry ;
-
-: construct-nfa ( regexp -- )
     [
-        reset-regexp
+        0 state set
-        negation-mode off
+        <transition-table> nfa-table set
-        [ current-regexp set ]
+        nfa-node
-        [ parse-tree>> nfa-node ]
+        nfa-table get
-        [ set-start-state ] tri
+            swap dup associate >>final-states
+            swap >>start-state
     ] with-scope ;

basis/regexp/parser/parser-tests.factor

@@ -1,34 +1,24 @@
-USING: kernel tools.test regexp.backend regexp ;
+USING: kernel tools.test regexp.parser fry sequences ;
-IN: regexp.parser
+IN: regexp.parser.tests
 
-: test-regexp ( string -- )
+: regexp-parses ( string -- )
-    default-regexp parse-regexp ;
+    [ [ ] ] dip '[ _ parse-regexp drop ] unit-test ;
 
-! [ "(" ] [ unmatched-parentheses? ] must-fail-with
+: regexp-fails ( string -- )
+    '[ _ parse-regexp ] must-fail ;
 
-[ ] [ "a|b" test-regexp ] unit-test
+{
-[ ] [ "a.b" test-regexp ] unit-test
+    "a|b" "a.b" "a|b|c" "abc|b" "a|bcd" "a|(b)" "(?-i:a)" "||"
-[ ] [ "a|b|c" test-regexp ] unit-test
+    "(a)|b" "(a|b)" "((a)|(b))" "(?:a)" "(?i:a)" "|b" "b|"
-[ ] [ "abc|b" test-regexp ] unit-test
+    "[abc]" "[a-c]" "[^a-c]" "[^]]" "[]a]" "[[]" "[]-a]" "[a-]" "[-]"
-[ ] [ "a|bcd" test-regexp ] unit-test
+    "[--a]" "foo*" "(foo)*" "(a|b)|c" "(foo){2,3}" "(foo){2,}"
-[ ] [ "a|(b)" test-regexp ] unit-test
+    "(foo){2}" "{2,3}" "{," "{,}" "}" "foo}" "[^]-a]" "[^-]a]"
-[ ] [ "(a)|b" test-regexp ] unit-test
+    "[a-]" "[^a-]" "[^a-]" "a{,2}" "(?#foobar)"
-[ ] [ "(a|b)" test-regexp ] unit-test
+    "\\p{Space}" "\\t" "\\[" "[\\]]" "\\P{Space}"
-[ ] [ "((a)|(b))" test-regexp ] unit-test
+    "\\ueeee" "\\0333" "\\xff" "\\\\" "\\w"
+} [ regexp-parses ] each
 
-[ ] [ "(?:a)" test-regexp ] unit-test
+{
-[ ] [ "(?i:a)" test-regexp ] unit-test
+    "[^]" "[]" "a{foo}" "a{,}" "a{}" "(?)" "\\p{foo}" "\\P{foo}"
-[ ] [ "(?-i:a)" test-regexp ] unit-test
+    "\\ueeeg" "\\0339" "\\xfg"
-[ "(?z:a)" test-regexp ] [ unknown-regexp-option? ] must-fail-with
+} [ regexp-fails ] each
-[ "(?-z:a)" test-regexp ] [ unknown-regexp-option? ] must-fail-with
-
-[ ] [ "(?=a)" test-regexp ] unit-test
-
-[ ] [ "[abc]" test-regexp ] unit-test
-[ ] [ "[a-c]" test-regexp ] unit-test
-[ ] [ "[^a-c]" test-regexp ] unit-test
-[ "[^]" test-regexp ] must-fail
-
-[ ] [ "|b" test-regexp ] unit-test
-[ ] [ "b|" test-regexp ] unit-test
-[ ] [ "||" test-regexp ] unit-test

basis/regexp/parser/parser.factor

@@ -1,437 +1,179 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators io io.streams.string
+USING: peg.ebnf kernel math.parser sequences assocs arrays fry math
-kernel math math.parser namespaces sets
+combinators regexp.classes strings splitting peg locals accessors
-quotations sequences splitting vectors math.order
+regexp.ast ;
-strings regexp.backend regexp.utils
-unicode.case unicode.categories words locals regexp.classes ;
 IN: regexp.parser
 
-FROM: math.ranges => [a,b] ;
+: allowed-char? ( ch -- ? )
+    ".()|[*+?$^" member? not ;
 
-TUPLE: concatenation seq ; INSTANCE: concatenation node
+ERROR: bad-number ;
-TUPLE: alternation seq ; INSTANCE: alternation node
-TUPLE: kleene-star term ; INSTANCE: kleene-star node
 
-! !!!!!!!!
+: ensure-number ( n -- n )
-TUPLE: possessive-question term ; INSTANCE: possessive-question node
+    [ bad-number ] unless* ;
-TUPLE: possessive-kleene-star term ; INSTANCE: possessive-kleene-star node
 
-! !!!!!!!!
+:: at-error ( key assoc quot: ( key -- replacement ) -- value )
-TUPLE: reluctant-question term ; INSTANCE: reluctant-question node
+    key assoc at* [ drop key quot call ] unless ; inline
-TUPLE: reluctant-kleene-star term ; INSTANCE: reluctant-kleene-star node
 
-TUPLE: negation term ; INSTANCE: negation node
+ERROR: bad-class name ;
-TUPLE: constant char ; INSTANCE: constant node
-TUPLE: range from to ; INSTANCE: range node
 
-MIXIN: parentheses-group
+: name>class ( name -- class )
-TUPLE: lookahead term ; INSTANCE: lookahead node
+    {
-INSTANCE: lookahead parentheses-group
+        { "Lower" letter-class }
-TUPLE: lookbehind term ; INSTANCE: lookbehind node
+        { "Upper" LETTER-class }
-INSTANCE: lookbehind parentheses-group
+        { "Alpha" Letter-class }
-TUPLE: capture-group term ; INSTANCE: capture-group node
+        { "ASCII" ascii-class }
-INSTANCE: capture-group parentheses-group
+        { "Digit" digit-class }
-TUPLE: non-capture-group term ; INSTANCE: non-capture-group node
+        { "Alnum" alpha-class }
-INSTANCE: non-capture-group parentheses-group
+        { "Punct" punctuation-class }
-TUPLE: independent-group term ; INSTANCE: independent-group node ! atomic group
+        { "Graph" java-printable-class }
-INSTANCE: independent-group parentheses-group
+        { "Print" java-printable-class }
-TUPLE: comment-group term ; INSTANCE: comment-group node
+        { "Blank" non-newline-blank-class }
-INSTANCE: comment-group parentheses-group
+        { "Cntrl" control-character-class }
+        { "XDigit" hex-digit-class }
+        { "Space" java-blank-class }
+        ! TODO: unicode-character-class
+    } [ bad-class ] at-error ;
 
-SINGLETON: epsilon INSTANCE: epsilon node
+: lookup-escape ( char -- ast )
+    {
+        { CHAR: t [ CHAR: \t ] }
+        { CHAR: n [ CHAR: \n ] }
+        { CHAR: r [ CHAR: \r ] }
+        { CHAR: f [ HEX: c ] }
+        { CHAR: a [ HEX: 7 ] }
+        { CHAR: e [ HEX: 1b ] }
+        { CHAR: \\ [ CHAR: \\ ] }
 
-TUPLE: option option on? ; INSTANCE: option node
+        { CHAR: w [ c-identifier-class <primitive-class> ] }
+        { CHAR: W [ c-identifier-class <primitive-class> <not-class> ] }
+        { CHAR: s [ java-blank-class <primitive-class> ] }
+        { CHAR: S [ java-blank-class <primitive-class> <not-class> ] }
+        { CHAR: d [ digit-class <primitive-class> ] }
+        { CHAR: D [ digit-class <primitive-class> <not-class> ] }
 
-SINGLETONS: unix-lines dotall multiline comments case-insensitive
+        { CHAR: z [ end-of-input <tagged-epsilon> ] }
-unicode-case reversed-regexp ;
+        { CHAR: Z [ end-of-file <tagged-epsilon> ] }
+        { CHAR: A [ beginning-of-input <tagged-epsilon> ] }
+        { CHAR: b [ word-break <tagged-epsilon> ] }
+        { CHAR: B [ word-break <not-class> <tagged-epsilon> ] }
+        [ ]
+    } case ;
 
-SINGLETONS: beginning-of-character-class end-of-character-class
+: options-assoc ( -- assoc )
-left-parenthesis pipe caret dash ;
+    H{
-
+        { CHAR: i case-insensitive }
-: push1 ( obj -- ) input-stream get stream>> push ;
+        { CHAR: d unix-lines }
-: peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ;
+        { CHAR: m multiline }
-: pop3 ( seq -- obj1 obj2 obj3 ) [ pop ] [ pop ] [ pop ] tri spin ;
+        { CHAR: n multiline }
-: drop1 ( -- ) read1 drop ;
+        { CHAR: r reversed-regexp }
-
+        { CHAR: s dotall }
-: stack ( -- obj ) current-regexp get stack>> ;
+        { CHAR: u unicode-case }
-: change-whole-stack ( quot -- )
+        { CHAR: x comments }
-    current-regexp get
+    } ;
-    [ stack>> swap call ] keep (>>stack) ; inline
-: push-stack ( obj -- ) stack push ;
-: pop-stack ( -- obj ) stack pop ;
-: cut-out ( vector n -- vector' vector ) cut rest ;
-ERROR: cut-stack-error ;
-: cut-stack ( obj vector -- vector' vector )
-    [ nip ] [ last-index ] 2bi [ cut-stack-error ] unless* cut-out swap ;
-
-: <possessive-kleene-star> ( obj -- kleene ) possessive-kleene-star boa ;
-: <reluctant-kleene-star> ( obj -- kleene ) reluctant-kleene-star boa ;
-: <possessive-question> ( obj -- kleene ) possessive-question boa ;
-: <reluctant-question> ( obj -- kleene ) reluctant-question boa ;
-
-: <negation> ( obj -- negation ) negation boa ;
-: <concatenation> ( seq -- concatenation )
-    >vector [ epsilon ] [ concatenation boa ] if-empty ;
-: <alternation> ( seq -- alternation ) >vector alternation boa ;
-: <capture-group> ( obj -- capture-group ) capture-group boa ;
-: <kleene-star> ( obj -- kleene-star ) kleene-star boa ;
-: <constant> ( obj -- constant ) constant boa ;
-
-: first|concatenation ( seq -- first/concatenation )
-    dup length 1 = [ first ] [ <concatenation> ] if ;
-
-: first|alternation ( seq -- first/alternation )
-    dup length 1 = [ first ] [ <alternation> ] if ;
-
-: <character-class-range> ( from to -- obj )
-    2dup <
-    [ character-class-range boa ] [ 2drop unmatchable-class ] if ;
-
-ERROR: unmatched-parentheses ;
-
-ERROR: unknown-regexp-option option ;
 
 : ch>option ( ch -- singleton )
-    {
+    options-assoc at ;
-        { CHAR: i [ case-insensitive ] }
-        { CHAR: d [ unix-lines ] }
-        { CHAR: m [ multiline ] }
-        { CHAR: n [ multiline ] }
-        { CHAR: r [ reversed-regexp ] }
-        { CHAR: s [ dotall ] }
-        { CHAR: u [ unicode-case ] }
-        { CHAR: x [ comments ] }
-        [ unknown-regexp-option ]
-    } case ;
 
 : option>ch ( option -- string )
-    {
+    options-assoc value-at ;
-        { case-insensitive [ CHAR: i ] }
-        { multiline [ CHAR: m ] }
-        { reversed-regexp [ CHAR: r ] }
-        { dotall [ CHAR: s ] }
-        [ unknown-regexp-option ]
-    } case ;
 
-: toggle-option ( ch ? -- ) 
+: parse-options ( on off -- options )
-    [ ch>option ] dip option boa push-stack ;
+    [ [ ch>option ] { } map-as ] bi@ <options> ;
 
-: (parse-options) ( string ? -- ) [ toggle-option ] curry each ;
+: string>options ( string -- options )
+    "-" split1 parse-options ;
  
-: parse-options ( string -- )
+: options>string ( options -- string )
-    "-" split1 [ t (parse-options) ] [ f (parse-options) ] bi* ;
+    [ on>> ] [ off>> ] bi
+    [ [ option>ch ] map ] bi@
+    [ "-" glue ] unless-empty
+    "" like ;
 
-ERROR: bad-special-group string ;
+! TODO: add syntax for various parenthized things,
+!       add greedy and nongreedy forms of matching
+! (once it's all implemented)
 
-DEFER: (parse-regexp)
+EBNF: parse-regexp
-: nested-parse-regexp ( token ? -- )
-    [ push-stack (parse-regexp) pop-stack ] dip
-    [ <negation> ] when pop-stack new swap >>term push-stack ;
 
-! non-capturing groups
+CharacterInBracket = !("}") Character
-: (parse-special-group) ( -- )
-    read1 {
-        { [ dup CHAR: # = ] ! comment
-            [ drop comment-group f nested-parse-regexp pop-stack drop ] }
-        { [ dup CHAR: : = ]
-            [ drop non-capture-group f nested-parse-regexp ] }
-        { [ dup CHAR: = = ]
-            [ drop lookahead f nested-parse-regexp ] }
-        { [ dup CHAR: ! = ]
-            [ drop lookahead t nested-parse-regexp ] }
-        { [ dup CHAR: > = ]
-            [ drop non-capture-group f nested-parse-regexp ] }
-        { [ dup CHAR: < = peek1 CHAR: = = and ]
-            [ drop drop1 lookbehind f nested-parse-regexp ] }
-        { [ dup CHAR: < = peek1 CHAR: ! = and ]
-            [ drop drop1 lookbehind t nested-parse-regexp ] }
-        [
-            ":)" read-until
-            [ swap prefix ] dip
-            {
-                { CHAR: : [ parse-options non-capture-group f nested-parse-regexp ] }
-                { CHAR: ) [ parse-options ] }
-                [ drop bad-special-group ]
-            } case
-        ]
-    } cond ;
 
-: handle-left-parenthesis ( -- )
+QuotedCharacter = !("\\E") .
-    peek1 CHAR: ? =
-    [ drop1 (parse-special-group) ]
-    [ capture-group f nested-parse-regexp ] if ;
 
-: handle-dot ( -- ) any-char push-stack ;
+Escape = "p{" CharacterInBracket*:s "}" => [[ s >string name>class <primitive-class> ]]
-: handle-pipe ( -- ) pipe push-stack ;
+       | "P{" CharacterInBracket*:s "}" => [[ s >string name>class <primitive-class> <negation> ]]
-: (handle-star) ( obj -- kleene-star )
+       | "Q" QuotedCharacter*:s "\\E" => [[ s <concatenation> ]]
-    peek1 {
+       | "u" Character:a Character:b Character:c Character:d
-        { CHAR: + [ drop1 <possessive-kleene-star> ] }
+            => [[ { a b c d } hex> ensure-number ]]
-        { CHAR: ? [ drop1 <reluctant-kleene-star> ] }
+       | "x" Character:a Character:b
-        [ drop <kleene-star> ]
+            => [[ { a b } hex> ensure-number ]]
-    } case ;
+       | "0" Character:a Character:b Character:c
-: handle-star ( -- ) stack pop (handle-star) push-stack ;
+            => [[ { a b c } oct> ensure-number ]]
-: handle-question ( -- )
+       | . => [[ lookup-escape ]]
-    stack pop peek1 {
-        { CHAR: + [ drop1 <possessive-question> ] }
-        { CHAR: ? [ drop1 <reluctant-question> ] }
-        [ drop epsilon 2array <alternation> ]
-    } case push-stack ;
-: handle-plus ( -- )
-    stack pop dup (handle-star)
-    2array <concatenation> push-stack ;
 
-ERROR: unmatched-brace ;
+EscapeSequence = "\\" Escape:e => [[ e ]]
-: parse-repetition ( -- start finish ? )
-    "}" read-until [ unmatched-brace ] unless
-    [ "," split1 [ string>number ] bi@ ]
-    [ CHAR: , swap index >boolean ] bi ;
 
-: replicate/concatenate ( n obj -- obj' )
+Character = EscapeSequence
-    over zero? [ 2drop epsilon ]
+          | "$" => [[ $ <tagged-epsilon> ]]
-    [ <repetition> first|concatenation ] if ;
+          | "^" => [[ ^ <tagged-epsilon> ]]
+          | . ?[ allowed-char? ]?
 
-: exactly-n ( n -- )
+AnyRangeCharacter = EscapeSequence | .
-    stack pop replicate/concatenate push-stack ;
 
-: at-least-n ( n -- )
+RangeCharacter = !("]") AnyRangeCharacter
-    stack pop
-    [ replicate/concatenate ] keep
-    <kleene-star> 2array <concatenation> push-stack ;
 
-: at-most-n ( n -- )
+Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b <range> ]]
-    1+
+      | RangeCharacter
-    stack pop
-    [ replicate/concatenate ] curry map <alternation> push-stack ;
 
-: from-m-to-n ( m n -- )
+StartRange = AnyRangeCharacter:a "-" RangeCharacter:b => [[ a b <range> ]]
-    [a,b]
+           | AnyRangeCharacter
-    stack pop
-    [ replicate/concatenate ] curry map
-    <alternation> push-stack ;
 
-ERROR: invalid-range a b ;
+Ranges = StartRange:s Range*:r => [[ r s prefix ]]
 
-: handle-left-brace ( -- )
+CharClass = "^"?:n Ranges:e => [[ e n char-class ]]
-    parse-repetition
-    [ 2dup [ [ 0 < [ invalid-range ] when ] when* ] bi@ ] dip
-    [
-        2dup and [ from-m-to-n ]
-        [ [ nip at-most-n ] [ at-least-n ] if* ] if
-    ] [ drop 0 max exactly-n ] if ;
 
-: handle-front-anchor ( -- ) beginning-of-line push-stack ;
+Options = [idmsux]*
-: handle-back-anchor ( -- ) end-of-line push-stack ;
 
-ERROR: bad-character-class obj ;
+Parenthized = "?:" Alternation:a => [[ a ]]
-ERROR: expected-posix-class ;
+            | "?" Options:on "-"? Options:off ":" Alternation:a
+                => [[ a on off parse-options <with-options> ]]
+            | "?#" [^)]* => [[ f ]]
+            | "?~" Alternation:a => [[ a <negation> ]]
+            | "?=" Alternation:a => [[ a <lookahead> <tagged-epsilon> ]]
+            | "?!" Alternation:a => [[ a <lookahead> <not-class> <tagged-epsilon> ]]
+            | "?<=" Alternation:a => [[ a <lookbehind> <tagged-epsilon> ]]
+            | "?<!" Alternation:a => [[ a <lookbehind> <not-class> <tagged-epsilon> ]]
+            | Alternation
 
-: parse-posix-class ( -- obj )
+Element = "(" Parenthized:p ")" => [[ p ]]
-    read1 CHAR: { = [ expected-posix-class ] unless
+        | "[" CharClass:r "]" => [[ r ]]
-    "}" read-until [ bad-character-class ] unless
+        | ".":d => [[ any-char <primitive-class> ]]
-    {
+        | Character
-        { "Lower" [ letter-class ] }
-        { "Upper" [ LETTER-class ] }
-        { "Alpha" [ Letter-class ] }
-        { "ASCII" [ ascii-class ] }
-        { "Digit" [ digit-class ] }
-        { "Alnum" [ alpha-class ] }
-        { "Punct" [ punctuation-class ] }
-        { "Graph" [ java-printable-class ] }
-        { "Print" [ java-printable-class ] }
-        { "Blank" [ non-newline-blank-class ] }
-        { "Cntrl" [ control-character-class ] }
-        { "XDigit" [ hex-digit-class ] }
-        { "Space" [ java-blank-class ] }
-        ! TODO: unicode-character-class, fallthrough in unicode is bad-char-clss
-        [ bad-character-class ]
-    } case ;
 
-: parse-octal ( -- n ) 3 read oct> check-octal ;
+Number = (!(","|"}").)* => [[ string>number ensure-number ]]
-: parse-short-hex ( -- n ) 2 read hex> check-hex ;
-: parse-long-hex ( -- n ) 6 read hex> check-hex ;
-: parse-control-character ( -- n ) read1 ;
 
-ERROR: bad-escaped-literals seq ;
+Times = "," Number:n "}" => [[ 0 n <from-to> ]]
+      | Number:n ",}" => [[ n <at-least> ]]
+      | Number:n "}" => [[ n n <from-to> ]]
+      | "}" => [[ bad-number ]]
+      | Number:n "," Number:m "}" => [[ n m <from-to> ]]
 
-: parse-til-E ( -- obj )
+Repeated = Element:e "{" Times:t => [[ e t <times> ]]
-    "\\E" read-until [ bad-escaped-literals ] unless ;
+         | Element:e "??" => [[ e <maybe> ]]
+         | Element:e "*?" => [[ e <star> ]]
+         | Element:e "+?" => [[ e <plus> ]]
+         | Element:e "?" => [[ e <maybe> ]]
+         | Element:e "*" => [[ e <star> ]]
+         | Element:e "+" => [[ e <plus> ]]
+         | Element
 
-:: (parse-escaped-literals) ( quot: ( obj -- obj' ) -- obj )
+Concatenation = Repeated*:r => [[ r sift <concatenation> ]]
-    parse-til-E
-    drop1
-    [ epsilon ] [
-        quot call [ <constant> ] V{ } map-as
-        first|concatenation
-    ] if-empty ; inline
 
-: parse-escaped-literals ( -- obj )
+Alternation = Concatenation:c ("|" Concatenation)*:a
-    [ ] (parse-escaped-literals) ;
+                => [[ a empty? [ c ] [ a values c prefix <alternation> ] if ]]
 
-: lower-case-literals ( -- obj )
+End = !(.)
-    [ >lower ] (parse-escaped-literals) ;
 
-: upper-case-literals ( -- obj )
+Main = Alternation End
-    [ >upper ] (parse-escaped-literals) ;
+;EBNF
-
-: parse-escaped ( -- obj )
-    read1
-    {
-        { CHAR: t [ CHAR: \t <constant> ] }
-        { CHAR: n [ CHAR: \n <constant> ] }
-        { CHAR: r [ CHAR: \r <constant> ] }
-        { CHAR: f [ HEX: c <constant> ] }
-        { CHAR: a [ HEX: 7 <constant> ] }
-        { CHAR: e [ HEX: 1b <constant> ] }
-
-        { CHAR: w [ c-identifier-class ] }
-        { CHAR: W [ c-identifier-class <negation> ] }
-        { CHAR: s [ java-blank-class ] }
-        { CHAR: S [ java-blank-class <negation> ] }
-        { CHAR: d [ digit-class ] }
-        { CHAR: D [ digit-class <negation> ] }
-
-        { CHAR: p [ parse-posix-class ] }
-        { CHAR: P [ parse-posix-class <negation> ] }
-        { CHAR: x [ parse-short-hex <constant> ] }
-        { CHAR: u [ parse-long-hex <constant> ] }
-        { CHAR: 0 [ parse-octal <constant> ] }
-        { CHAR: c [ parse-control-character ] }
-
-        { CHAR: Q [ parse-escaped-literals ] }
-
-        ! { CHAR: b [ word-boundary-class ] }
-        ! { CHAR: B [ word-boundary-class <negation> ] }
-        ! { CHAR: A [ handle-beginning-of-input ] }
-        ! { CHAR: z [ handle-end-of-input ] }
-
-        ! { CHAR: Z [ handle-end-of-input ] } ! plus a final terminator
-
-        ! m//g mode
-        ! { CHAR: G [ end of previous match ] }
-
-        ! Group capture
-        ! { CHAR: 1 [ CHAR: 1 <constant> ] }
-        ! { CHAR: 2 [ CHAR: 2 <constant> ] }
-        ! { CHAR: 3 [ CHAR: 3 <constant> ] }
-        ! { CHAR: 4 [ CHAR: 4 <constant> ] }
-        ! { CHAR: 5 [ CHAR: 5 <constant> ] }
-        ! { CHAR: 6 [ CHAR: 6 <constant> ] }
-        ! { CHAR: 7 [ CHAR: 7 <constant> ] }
-        ! { CHAR: 8 [ CHAR: 8 <constant> ] }
-        ! { CHAR: 9 [ CHAR: 9 <constant> ] }
-
-        ! Perl extensions
-        ! can't do \l and \u because \u is already a 4-hex
-        { CHAR: L [ lower-case-literals ] }
-        { CHAR: U [ upper-case-literals ] }
-
-        [ <constant> ]
-    } case ;
-
-: handle-escape ( -- ) parse-escaped push-stack ;
-
-: handle-dash ( vector -- vector' )
-    H{ { dash CHAR: - } } substitute ;
-
-: character-class>alternation ( seq -- alternation )
-    [ dup number? [ <constant> ] when ] map first|alternation ;
-
-: handle-caret ( vector -- vector' )
-    dup [ length 2 >= ] [ first caret eq? ] bi and [
-        rest-slice character-class>alternation <negation>
-    ] [
-        character-class>alternation
-    ] if ;
-
-: make-character-class ( -- character-class )
-    [ beginning-of-character-class swap cut-stack ] change-whole-stack
-    handle-dash handle-caret ;
-
-: apply-dash ( -- )
-    stack [ pop3 nip <character-class-range> ] keep push ;
-
-: apply-dash? ( -- ? )
-    stack dup length 3 >=
-    [ [ length 2 - ] keep nth dash eq? ] [ drop f ] if ;
-
-ERROR: empty-negated-character-class ;
-DEFER: handle-left-bracket
-: (parse-character-class) ( -- )
-    read1 [ empty-negated-character-class ] unless* {
-        { CHAR: [ [ handle-left-bracket t ] }
-        { CHAR: ] [ make-character-class push-stack f ] }
-        { CHAR: - [ dash push-stack t ] }
-        { CHAR: \ [ parse-escaped push-stack t ] }
-        [ push-stack apply-dash? [ apply-dash ] when t ]
-    } case
-    [ (parse-character-class) ] when ;
-
-: push-constant ( ch -- ) <constant> push-stack ;
-
-: parse-character-class-second ( -- )
-    read1 {
-        { CHAR: [ [ CHAR: [ push-constant ] }
-        { CHAR: ] [ CHAR: ] push-constant ] }
-        { CHAR: - [ CHAR: - push-constant ] }
-        [ push1 ]
-    } case ;
-
-: parse-character-class-first ( -- )
-    read1 {
-        { CHAR: ^ [ caret push-stack parse-character-class-second ] }
-        { CHAR: [ [ CHAR: [ push-constant ] }
-        { CHAR: ] [ CHAR: ] push-constant ] }
-        { CHAR: - [ CHAR: - push-constant ] }
-        [ push1 ]
-    } case ;
-
-: handle-left-bracket ( -- )
-    beginning-of-character-class push-stack
-    parse-character-class-first (parse-character-class) ;
-
-: finish-regexp-parse ( stack -- obj )
-    { pipe } split
-    [ first|concatenation ] map first|alternation ;
-
-: handle-right-parenthesis ( -- )
-    stack dup [ parentheses-group "members" word-prop member? ] find-last
-    -rot cut rest
-    [ [ push ] keep current-regexp get (>>stack) ]
-    [ finish-regexp-parse push-stack ] bi* ;
-
-: parse-regexp-token ( token -- ? )
-    {
-        { CHAR: ( [ handle-left-parenthesis t ] } ! handle (?..) at beginning?
-        { CHAR: ) [ handle-right-parenthesis f ] }
-        { CHAR: . [ handle-dot t ] }
-        { CHAR: | [ handle-pipe t ] }
-        { CHAR: ? [ handle-question t ] }
-        { CHAR: * [ handle-star t ] }
-        { CHAR: + [ handle-plus t ] }
-        { CHAR: { [ handle-left-brace t ] }
-        { CHAR: [ [ handle-left-bracket t ] }
-        { CHAR: \ [ handle-escape t ] }
-        [
-            dup CHAR: $ = peek1 f = and
-            [ drop handle-back-anchor f ]
-            [ push-constant t ] if
-        ]
-    } case ;
-
-: (parse-regexp) ( -- )
-    read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ;
-
-: parse-regexp-beginning ( -- )
-    peek1 CHAR: ^ = [ drop1 handle-front-anchor ] when ;
-
-: parse-regexp ( regexp -- )
-    dup current-regexp [
-        raw>> [
-            <string-reader> [
-                parse-regexp-beginning (parse-regexp)
-            ] with-input-stream
-        ] unless-empty
-        current-regexp get [ finish-regexp-parse ] change-stack
-        dup stack>> >>parse-tree drop
-    ] with-variable ;

basis/regexp/regexp-docs.factor

@@ -1,8 +1,92 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel strings help.markup help.syntax regexp.backend ;
+USING: kernel strings help.markup help.syntax math ;
 IN: regexp
 
+ABOUT: "regexp"
+
+ARTICLE: "regexp" "Regular expressions"
+"The " { $vocab-link "regexp" } " vocabulary provides word for creating and using regular expressions."
+{ $subsection { "regexp" "syntax" } }
+{ $subsection { "regexp" "construction" } }
+{ $vocab-subsection "regexp.combinators" "Regular expression combinators" }
+{ $subsection { "regexp" "operations" } }
+{ $subsection regexp }
+{ $subsection { "regexp" "theory" } } ;
+
+ARTICLE: { "regexp" "construction" } "Constructing regular expressions"
+"Words which are useful for creating regular expressions:"
+{ $subsection POSTPONE: R/ }
+{ $subsection <regexp> } 
+{ $subsection <optioned-regexp> }
+{ $heading "See also" }
+{ $vocab-link "regexp.combinators" } ;
+
+ARTICLE: { "regexp" "syntax" } "Regular expression syntax"
+"Regexp syntax is largely compatible with Perl, Java and extended POSIX regexps, but not completely." $nl
+"A new addition is the inclusion of a negation operator, with the syntax " { $snippet "(?~foo)" } " to match everything that does not match " { $snippet "foo" } "." $nl
+"One missing feature is backreferences. This is because of a design decision to allow only regular expressions following the formal theory of regular languages. For more information, see " { $link { "regexp" "theory" } } ". You can create a new regular expression to match a particular string using " { $vocab-link "regexp.combinators" } " and group capture is available to extract parts of a regular expression match." $nl
+"A distinction from Perl is that " { $snippet "\\G" } ", which references the previous match, is not included. This is because that sequence is inherently stateful, and Factor regexps don't hold state." $nl
+"Additionally, none of the operations which embed code into a regexp are supported, as this would require the inclusion of the Factor parser and compiler in any application which wants to expose regexps to the user. None of the casing operations are included, for simplicity." ; ! Also describe syntax, from the beginning
+
+ARTICLE: { "regexp" "theory" } "The theory of regular expressions"
+"Far from being just a practical tool invented by Unix hackers, regular expressions were studied formally before computer programs were written to process them." $nl
+"A regular language is a set of strings that is matched by a regular expression, which is defined to have characters and the empty string, along with the operations concatenation, disjunction and Kleene star. Another way to define the class of regular languages is as the class of languages which can be recognized with constant space overhead, ie with a DFA. These two definitions are provably equivalent." $nl
+"One basic result in the theory of regular language is that the complement of a regular language is regular. In other words, for any regular expression, there exists another regular expression which matches exactly the strings that the first one doesn't match." $nl
+"This implies, by DeMorgan's law, that, if you have two regular languages, their intersection is also regular. That is, for any two regular expressions, there exists a regular expression which matches strings that match both inputs." $nl
+"Traditionally, regular expressions on computer support an additional operation: backreferences. For example, the Perl regexp " { $snippet "/(.*)$1/" } " matches a string repated twice. If a backreference refers to a string with a predetermined maximum length, then the resulting language is still regular." $nl
+"But, if not, the language is not regular. There is strong evidence that there is no efficient way to parse with backreferences in the general case. Perl uses a naive backtracking algorithm which has pathological behavior in some cases, taking exponential time to match even if backreferences aren't used. Additionally, expressions with backreferences don't have the properties with negation and intersection described above." $nl
+"The Factor regular expression engine was built with the design decision to support negation and intersection at the expense of backreferences. This lets us have a guaranteed linear-time matching algorithm. Systems like Ragel and Lex also use this algorithm, but in the Factor regular expression engine, all other features of regexps are still present." ;
+
+ARTICLE: { "regexp" "operations" } "Matching operations with regular expressions"
+{ $subsection matches? }
+{ $subsection re-contains? }
+{ $subsection first-match }
+{ $subsection all-matching-slices }
+{ $subsection all-matching-subseqs }
+{ $subsection re-split }
+{ $subsection re-replace }
+{ $subsection count-matches } ;
+
 HELP: <regexp>
 { $values { "string" string } { "regexp" regexp } }
-{ $description "Compiles a regular expression into a DFA and returns this object.  Regular expressions only have to be compiled once and can then be used multiple times to match input strings." } ;
+{ $description "Creates a regular expression object, given a string in regular expression syntax. When it is first used for matching, a DFA is compiled, and this DFA is stored for reuse so it is only compiled once." } ;
+
+HELP: <optioned-regexp>
+{ $values { "string" string } { "options" string } { "regexp" regexp } }
+{ $description "Given a string in regular expression syntax, and a string of options, creates a regular expression object. When it is first used for matching, a DFA is compiled, and this DFA is stored for reuse so it is only compiled once." } ;
+
+HELP: R/
+{ $syntax "R/ foo.*|[a-zA-Z]bar/i" }
+{ $description "Literal syntax for a regular expression. When this syntax is used, the DFA is compiled at compile-time, rather than on first use." } ;
+
+HELP: regexp
+{ $class-description "The class of regular expressions. To construct these, see " { $link { "regexp" "construction" } } "." } ;
+
+HELP: matches?
+{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } }
+{ $description "Tests if the string as a whole matches the given regular expression." } ;
+
+HELP: all-matching-slices
+{ $values { "string" string } { "regexp" regexp } { "seq" "a sequence of slices of the input" } }
+{ $description "Finds a sequence of disjoint substrings which each match the pattern. It chooses this by finding the leftmost longest match, and then the leftmost longest match which starts after the end of the previous match, and so on." } ;
+
+HELP: count-matches
+{ $values { "string" string } { "regexp" regexp } { "n" integer } }
+{ $description "Counts how many disjoint matches the regexp has in the string, as made unambiguous by " { $link all-matching-slices } "." } ;
+
+HELP: re-split
+{ $values { "string" string } { "regexp" regexp } { "seq" "a sequence of slices of the input" } }
+{ $description "Splits the input string into chunks separated by the regular expression. Each chunk contains no match of the regexp. The chunks are chosen by the strategy of " { $link all-matching-slices } "." } ;
+
+HELP: re-replace
+{ $values { "string" string } { "regexp" regexp } { "replacement" string } { "result" string } }
+{ $description "Replaces substrings which match the input regexp with the given replacement text. The boundaries of the substring are chosen by the strategy used by " { $link all-matching-slices } "." } ;
+
+HELP: first-match
+{ $values { "string" string } { "regexp" regexp } { "slice/f" "the match, if one exists" } }
+{ $description "Finds the first match of the regular expression in the string, and returns it as a slice. If there is no match, then " { $link f } " is returned." } ;
+
+HELP: re-contains?
+{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } }
+{ $description "Determines whether the string has a substring which matches the regular expression given." } ;

basis/regexp/regexp-tests.factor

@@ -1,8 +1,11 @@
-USING: regexp tools.test kernel sequences regexp.parser
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg
-regexp.traversal eval strings multiline ;
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp tools.test kernel sequences regexp.parser regexp.private
+eval strings multiline accessors ;
 IN: regexp-tests
 
 \ <regexp> must-infer
+\ compile-regexp must-infer
 \ matches? must-infer
 
 [ f ] [ "b" "a*" <regexp> matches? ] unit-test
@@ -21,8 +24,8 @@ IN: regexp-tests
 [ t ] [ "b" "b|" <regexp> matches? ] unit-test
 [ t ] [ "" "b|" <regexp> matches? ] unit-test
 [ t ] [ "" "b|" <regexp> matches? ] unit-test
-[ f ] [ "" "|" <regexp> matches? ] unit-test
+[ t ] [ "" "|" <regexp> matches? ] unit-test
-[ f ] [ "" "|||||||" <regexp> matches? ] unit-test
+[ t ] [ "" "|||||||" <regexp> matches? ] unit-test
 
 [ f ] [ "aa" "a|b|c" <regexp> matches? ] unit-test
 [ f ] [ "bb" "a|b|c" <regexp> matches? ] unit-test
@@ -44,9 +47,9 @@ IN: regexp-tests
 ! Dotall mode -- when on, . matches newlines.
 ! Off by default.
 [ f ] [ "\n" "." <regexp> matches? ] unit-test
-[ t ] [ "\n" "(?s)." <regexp> matches? ] unit-test
+[ t ] [ "\n" "(?s:.)" <regexp> matches? ] unit-test
 [ t ] [ "\n" R/ ./s matches? ] unit-test
-[ f ] [ "\n\n" "(?s).(?-s)." <regexp> matches? ] unit-test
+[ f ] [ "\n\n" "(?s:.)." <regexp> matches? ] unit-test
 
 [ f ] [ "" ".+" <regexp> matches? ] unit-test
 [ t ] [ "a" ".+" <regexp> matches? ] unit-test
@@ -76,8 +79,6 @@ IN: regexp-tests
 [ t ] [ "bar" "foo|bar" <regexp> matches? ] unit-test
 [ f ] [ "foobar" "foo|bar" <regexp> matches? ] unit-test
 
-/*
-! FIXME
 [ f ] [ "" "(a)" <regexp> matches? ] unit-test
 [ t ] [ "a" "(a)" <regexp> matches? ] unit-test
 [ f ] [ "aa" "(a)" <regexp> matches? ] unit-test
@@ -85,7 +86,6 @@ IN: regexp-tests
 
 [ f ] [ "aababaaabbac" "(a|b)+" <regexp> matches? ] unit-test
 [ t ] [ "ababaaabba" "(a|b)+" <regexp> matches? ] unit-test
-*/
 
 [ f ] [ "" "a{1}" <regexp> matches? ] unit-test
 [ t ] [ "a" "a{1}" <regexp> matches? ] unit-test
@@ -168,12 +168,9 @@ IN: regexp-tests
 [ f ] [ "0" "[^\\d]" <regexp> matches? ] unit-test
 [ t ] [ "a" "[^\\d]" <regexp> matches? ] unit-test
 
-/*
-! FIXME
 [ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" <regexp> matches? ] unit-test
 [ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" <regexp> matches? ] unit-test
 [ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" <regexp> matches? ] unit-test
-*/
 
 [ t ] [ "1000" "\\d{4,6}" <regexp> matches? ] unit-test
 [ t ] [ "1000" "[0-9]{4,6}" <regexp> matches? ] unit-test
@@ -185,7 +182,7 @@ IN: regexp-tests
 [ f ] [ "abc" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
 [ t ] [ "ABC" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
 
-[ f ] [ "" "\\Q\\E" <regexp> matches? ] unit-test
+[ t ] [ "" "\\Q\\E" <regexp> matches? ] unit-test
 [ f ] [ "a" "\\Q\\E" <regexp> matches? ] unit-test
 [ t ] [ "|*+" "\\Q|*+\\E" <regexp> matches? ] unit-test
 [ f ] [ "abc" "\\Q|*+\\E" <regexp> matches? ] unit-test
@@ -195,8 +192,8 @@ IN: regexp-tests
 [ t ] [ "SXY" "\\0123XY" <regexp> matches? ] unit-test
 [ t ] [ "x" "\\x78" <regexp> matches? ] unit-test
 [ f ] [ "y" "\\x78" <regexp> matches? ] unit-test
-[ t ] [ "x" "\\u000078" <regexp> matches? ] unit-test
+[ t ] [ "x" "\\u0078" <regexp> matches? ] unit-test
-[ f ] [ "y" "\\u000078" <regexp> matches? ] unit-test
+[ f ] [ "y" "\\u0078" <regexp> matches? ] unit-test
 
 [ t ] [ "ab" "a+b" <regexp> matches? ] unit-test
 [ f ] [ "b" "a+b" <regexp> matches? ] unit-test
@@ -214,8 +211,8 @@ IN: regexp-tests
 [ f ] [ "aaaxb" "a+ab" <regexp> matches? ] unit-test
 [ t ] [ "aaacb" "a+cb" <regexp> matches? ] unit-test
 
-[ 3 ] [ "aaacb" "a*" <regexp> match-head ] unit-test
+[ "aaa" ] [ "aaacb" "a*" <regexp> first-match >string ] unit-test
-[ 2 ] [ "aaacb" "aa?" <regexp> match-head ] unit-test
+[ "aa" ] [ "aaacb" "aa?" <regexp> first-match >string ] unit-test
 
 [ t ] [ "aaa" R/ AAA/i matches? ] unit-test
 [ f ] [ "aax" R/ AAA/i matches? ] unit-test
@@ -226,15 +223,15 @@ IN: regexp-tests
 [ t ] [ "c" R/ [A-Z]/i matches? ] unit-test
 [ f ] [ "3" R/ [A-Z]/i matches? ] unit-test
 
-[ t ] [ "a" "(?i)a" <regexp> matches? ] unit-test
+[ t ] [ "a" "(?i:a)" <regexp> matches? ] unit-test
-[ t ] [ "a" "(?i)a" <regexp> matches? ] unit-test
+[ t ] [ "a" "(?i:a)" <regexp> matches? ] unit-test
-[ t ] [ "A" "(?i)a" <regexp> matches? ] unit-test
+[ t ] [ "A" "(?i:a)" <regexp> matches? ] unit-test
-[ t ] [ "A" "(?i)a" <regexp> matches? ] unit-test
+[ t ] [ "A" "(?i:a)" <regexp> matches? ] unit-test
 
-[ t ] [ "a" R/ (?-i)a/i matches? ] unit-test
+[ t ] [ "a" R/ (?-i:a)/i matches? ] unit-test
-[ t ] [ "a" R/ (?-i)a/i matches? ] unit-test
+[ t ] [ "a" R/ (?-i:a)/i matches? ] unit-test
-[ f ] [ "A" R/ (?-i)a/i matches? ] unit-test
+[ f ] [ "A" R/ (?-i:a)/i matches? ] unit-test
-[ f ] [ "A" R/ (?-i)a/i matches? ] unit-test
+[ f ] [ "A" R/ (?-i:a)/i matches? ] unit-test
 
 [ f ] [ "A" "[a-z]" <regexp> matches? ] unit-test
 [ t ] [ "A" R/ [a-z]/i matches? ] unit-test
@@ -242,9 +239,11 @@ IN: regexp-tests
 [ f ] [ "A" "\\p{Lower}" <regexp> matches? ] unit-test
 [ t ] [ "A" R/ \p{Lower}/i matches? ] unit-test
 
-[ t ] [ "abc" <reversed> R/ abc/r matches? ] unit-test
+[ t ] [ "abc" R/ abc/r matches? ] unit-test
-[ t ] [ "abc" <reversed> R/ a[bB][cC]/r matches? ] unit-test
+[ t ] [ "abc" R/ a[bB][cC]/r matches? ] unit-test
-! [ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/ matches? ] unit-test ! FIXME
+
+[ t ] [ 3 "xabc" R/ abc/r match-index-from >boolean ] unit-test
+[ t ] [ 3 "xabc" R/ a[bB][cC]/r match-index-from >boolean ] unit-test
 
 [ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
 [ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
@@ -253,8 +252,6 @@ IN: regexp-tests
 [ t ] [ "abc*" "[^\\*]*\\*" <regexp> matches? ] unit-test
 [ t ] [ "bca" "[^a]*a" <regexp> matches? ] unit-test
 
-/*
-! FIXME
 [ ] [
     "(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))"
     <regexp> drop
@@ -278,11 +275,6 @@ IN: regexp-tests
 [ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
 
 [ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
-*/
-
-! [ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
-
-! [ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test
 
 [ { "1" "2" "3" "4" } ]
 [ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
@@ -295,7 +287,7 @@ IN: regexp-tests
 [ { "a" "" } ] [ "a=" R/ =/ re-split [ >string ] map ] unit-test
 
 [ { "ABC" "DEF" "GHI" } ]
-[ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matches [ >string ] map ] unit-test
+[ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matching-subseqs ] unit-test
 
 [ 3 ]
 [ "1ABC2DEF3GHI4" R/ [A-Z]+/ count-matches ] unit-test
@@ -308,127 +300,173 @@ IN: regexp-tests
   
 [ "-- title --" ] [ "== title ==" R/ =/ "-" re-replace ] unit-test
 
-/*
+[ "" ] [ "ab" "a(?!b)" <regexp> first-match >string ] unit-test
-! FIXME
-[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
 [ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
+[ t ] [ "fxxbar" ".{3}(?!foo)bar" <regexp> matches? ] unit-test
+[ t ] [ "foobar" ".{3}(?!foo)bar" <regexp> matches? ] unit-test
 [ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
 [ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
 [ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> first-match >string ] unit-test
-[ "a" ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match >string ] unit-test
+[ "a" ] [ "ba" "(?<=b)(?<=b)a" <regexp> first-match >string ] unit-test
-[ "a" ] [ "cab" "a(?=b)(?<=c)" <regexp> first-match >string ] unit-test
+[ "a" ] [ "cab" "(?<=c)a(?=b)" <regexp> first-match >string ] unit-test
 
-[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
+[ 3 ] [ "foobar" "foo(?=bar)" <regexp> first-match length ] unit-test
-[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
+[ f ] [ "foobxr" "foo(?=bar)" <regexp> first-match ] unit-test
-*/
 
 ! Bug in parsing word
 [ t ] [ "a" R' a' matches? ] unit-test
 
-! Convert to lowercase until E
+! Testing negation
-[ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test
+[ f ] [ "a" R/ (?~a)/ matches? ] unit-test
-[ t ] [ "aa" R/ \LAA\E/ matches? ] unit-test
+[ t ] [ "aa" R/ (?~a)/ matches? ] unit-test
+[ t ] [ "bb" R/ (?~a)/ matches? ] unit-test
+[ t ] [ "" R/ (?~a)/ matches? ] unit-test
 
-! Convert to uppercase until E
+[ f ] [ "a" R/ (?~a+|b)/ matches? ] unit-test
-[ t ] [ "AA" R/ \Uaa\E/ matches? ] unit-test
+[ f ] [ "aa" R/ (?~a+|b)/ matches? ] unit-test
-[ f ] [ "aa" R/ \Uaa\E/ matches? ] unit-test
+[ t ] [ "bb" R/ (?~a+|b)/ matches? ] unit-test
+[ f ] [ "b" R/ (?~a+|b)/ matches? ] unit-test
+[ t ] [ "" R/ (?~a+|b)/ matches? ] unit-test
 
-! [ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
+! Intersecting classes
+[ t ] [ "ab" R/ ac|\p{Lower}b/ matches? ] unit-test
+[ t ] [ "ab" R/ ac|[a-z]b/ matches? ] unit-test
+[ t ] [ "ac" R/ ac|\p{Lower}b/ matches? ] unit-test
+[ t ] [ "ac" R/ ac|[a-z]b/ matches? ] unit-test
+[ t ] [ "ac" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
+[ t ] [ "ab" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
+[ t ] [ "πb" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
+[ f ] [ "πc" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
+[ f ] [ "Ab" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
 
-! [ t ] [ "a" R/ ^a/ matches? ] unit-test
+[ t ] [ "aaaa" R/ .*a./ matches? ] unit-test
-! [ f ] [ "\na" R/ ^a/ matches? ] unit-test
-! [ f ] [ "\r\na" R/ ^a/ matches? ] unit-test
-! [ f ] [ "\ra" R/ ^a/ matches? ] unit-test
 
-! [ t ] [ "a" R/ a$/ matches? ] unit-test
+[ f ] [ "ab" R/ (?~ac|\p{Lower}b)/ matches? ] unit-test
-! [ f ] [ "a\n" R/ a$/ matches? ] unit-test
+[ f ] [ "ab" R/ (?~ac|[a-z]b)/ matches? ] unit-test
-! [ f ] [ "a\r" R/ a$/ matches? ] unit-test
+[ f ] [ "ac" R/ (?~ac|\p{Lower}b)/ matches? ] unit-test
-! [ f ] [ "a\r\n" R/ a$/ matches? ] unit-test
+[ f ] [ "ac" R/ (?~ac|[a-z]b)/ matches? ] unit-test
+[ f ] [ "ac" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
+[ f ] [ "ab" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
+[ f ] [ "πb" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
+[ t ] [ "πc" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
+[ t ] [ "Ab" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
 
-! [ t ] [ "a" R/ a$|b$/ matches? ] unit-test
+! DFA is compiled when needed, or when literal
-! [ t ] [ "b" R/ a$|b$/ matches? ] unit-test
+[ regexp-initial-word ] [ "foo" <regexp> dfa>> ] unit-test
-! [ t ] [ "ab" R/ a$|b$/ matches? ] unit-test
+[ f ] [ R/ foo/ dfa>> \ regexp-initial-word = ] unit-test
-! [ t ] [ "ba" R/ ba$|b$/ matches? ] unit-test
 
-! [ t ] [ "a" R/ \Aa/ matches? ] unit-test
+[ t ] [ "a" R/ ^a/ matches? ] unit-test
-! [ f ] [ "\na" R/ \Aaa/ matches? ] unit-test
+[ f ] [ "\na" R/ ^a/ matches? ] unit-test
-! [ f ] [ "\r\na" R/ \Aa/ matches? ] unit-test
+[ f ] [ "\r\na" R/ ^a/ matches? ] unit-test
-! [ f ] [ "\ra" R/ \Aa/ matches? ] unit-test
+[ f ] [ "\ra" R/ ^a/ matches? ] unit-test
 
-! [ t ] [ "a" R/ \Aa/m matches? ] unit-test
+[ 1 ] [ "a" R/ ^a/ count-matches ] unit-test
-! [ f ] [ "\na" R/ \Aaa/m matches? ] unit-test
+[ 0 ] [ "\na" R/ ^a/ count-matches ] unit-test
-! [ f ] [ "\r\na" R/ \Aa/m matches? ] unit-test
+[ 0 ] [ "\r\na" R/ ^a/ count-matches ] unit-test
-! [ f ] [ "\ra" R/ \Aa/m matches? ] unit-test
+[ 0 ] [ "\ra" R/ ^a/ count-matches ] unit-test
 
-! [ t ] [ "\r\n\n\n\nam" R/ ^am/m matches? ] unit-test
+[ t ] [ "a" R/ a$/ matches? ] unit-test
+[ f ] [ "a\n" R/ a$/ matches? ] unit-test
+[ f ] [ "a\r" R/ a$/ matches? ] unit-test
+[ f ] [ "a\r\n" R/ a$/ matches? ] unit-test
 
-! [ t ] [ "a" R/ \Aa\z/m matches? ] unit-test
+[ 1 ] [ "a" R/ a$/ count-matches ] unit-test
-! [ f ] [ "a\n" R/ \Aa\z/m matches? ] unit-test
+[ 0 ] [ "a\n" R/ a$/ count-matches ] unit-test
+[ 0 ] [ "a\r" R/ a$/ count-matches ] unit-test
+[ 0 ] [ "a\r\n" R/ a$/ count-matches ] unit-test
 
-! [ t ] [ "a\r\n" R/ \Aa\Z/m matches? ] unit-test
+[ t ] [ "a" R/ a$|b$/ matches? ] unit-test
-! [ t ] [ "a\n" R/ \Aa\Z/m matches? ] unit-test
+[ t ] [ "b" R/ a$|b$/ matches? ] unit-test
+[ f ] [ "ab" R/ a$|b$/ matches? ] unit-test
+[ t ] [ "ba" R/ ba$|b$/ matches? ] unit-test
 
-! [ t ] [ "a" R/ \Aa\Z/m matches? ] unit-test
+[ t ] [ "a" R/ \Aa/ matches? ] unit-test
-! [ f ] [ "\na" R/ \Aaa\Z/m matches? ] unit-test
+[ f ] [ "\na" R/ \Aaa/ matches? ] unit-test
-! [ f ] [ "\r\na" R/ \Aa\Z/m matches? ] unit-test
+[ f ] [ "\r\na" R/ \Aa/ matches? ] unit-test
-! [ f ] [ "\ra" R/ \Aa\Z/m matches? ] unit-test
+[ f ] [ "\ra" R/ \Aa/ matches? ] unit-test
 
-! [ t ] [ "a" R/ ^a/m matches? ] unit-test
+[ t ] [ "a" R/ \Aa/m matches? ] unit-test
-! [ t ] [ "\na" R/ ^a/m matches? ] unit-test
+[ f ] [ "\na" R/ \Aaa/m matches? ] unit-test
-! [ t ] [ "\r\na" R/ ^a/m matches? ] unit-test
+[ f ] [ "\r\na" R/ \Aa/m matches? ] unit-test
-! [ t ] [ "\ra" R/ ^a/m matches? ] unit-test
+[ f ] [ "\ra" R/ \Aa/m matches? ] unit-test
+[ 0 ] [ "\ra" R/ \Aa/m count-matches ] unit-test
 
-! [ t ] [ "a" "a$" R/ a$/m matches? ] unit-test
+[ f ] [ "\r\n\n\n\nam" R/ ^am/m matches? ] unit-test
-! [ t ] [ "a\n" "a$" R/ a$/m matches? ] unit-test
+[ 1 ] [ "\r\n\n\n\nam" R/ ^am/m count-matches ] unit-test
-! [ t ] [ "a\r" "a$" R/ a$/m matches? ] unit-test
-! [ t ] [ "a\r\n" "a$" R/ a$/m matches? ] unit-test
 
-! [ f ] [ "foobxr" "foo\\z" <regexp> match-head ] unit-test
+[ t ] [ "a" R/ \Aa\z/m matches? ] unit-test
-! [ 3 ] [ "foo" "foo\\z" <regexp> match-head ] unit-test
+[ f ] [ "a\n" R/ \Aa\z/m matches? ] unit-test
 
-! [ t ] [ "foo" "\\bfoo\\b" <regexp> matches? ] unit-test
+[ f ] [ "a\r\n" R/ \Aa\Z/m matches? ] unit-test
-! [ t ] [ "afoob" "\\Bfoo\\B" <regexp> matches? ] unit-test
+[ f ] [ "a\n" R/ \Aa\Z/m matches? ] unit-test
-! [ t ] [ "afoob" "\\bfoo\\b" <regexp> matches? ] unit-test
+[ 1 ] [ "a\r\n" R/ \Aa\Z/m count-matches ] unit-test
-! [ f ] [ "foo" "\\Bfoo\\B" <regexp> matches? ] unit-test
+[ 1 ] [ "a\n" R/ \Aa\Z/m count-matches ] unit-test
 
-! [ 3 ] [ "foo bar" "foo\\b" <regexp> match-head ] unit-test
+[ t ] [ "a" R/ \Aa\Z/m matches? ] unit-test
-! [ f ] [ "fooxbar" "foo\\b" <regexp> matches? ] unit-test
+[ f ] [ "\na" R/ \Aaa\Z/m matches? ] unit-test
-! [ t ] [ "foo" "foo\\b" <regexp> matches? ] unit-test
+[ f ] [ "\r\na" R/ \Aa\Z/m matches? ] unit-test
-! [ t ] [ "foo bar" "foo\\b bar" <regexp> matches? ] unit-test
+[ f ] [ "\ra" R/ \Aa\Z/m matches? ] unit-test
-! [ f ] [ "fooxbar" "foo\\bxbar" <regexp> matches? ] unit-test
-! [ f ] [ "foo" "foo\\bbar" <regexp> matches? ] unit-test
 
-! [ f ] [ "foo bar" "foo\\B" <regexp> matches? ] unit-test
+[ 1 ] [ "a" R/ \Aa\Z/m count-matches ] unit-test
-! [ 3 ] [ "fooxbar" "foo\\B" <regexp> match-head ] unit-test
+[ 0 ] [ "\na" R/ \Aaa\Z/m count-matches ] unit-test
-! [ t ] [ "foo" "foo\\B" <regexp> matches? ] unit-test
+[ 0 ] [ "\r\na" R/ \Aa\Z/m count-matches ] unit-test
-! [ f ] [ "foo bar" "foo\\B bar" <regexp> matches? ] unit-test
+[ 0 ] [ "\ra" R/ \Aa\Z/m count-matches ] unit-test
-! [ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
-! [ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
 
-! [ 1 ] [ "aaacb" "a+?" <regexp> match-head ] unit-test
+[ t ] [ "a" R/ ^a/m matches? ] unit-test
-! [ 1 ] [ "aaacb" "aa??" <regexp> match-head ] unit-test
+[ f ] [ "\na" R/ ^a/m matches? ] unit-test
-! [ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
+[ 1 ] [ "\na" R/ ^a/m count-matches ] unit-test
-! [ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
+[ 1 ] [ "\r\na" R/ ^a/m count-matches ] unit-test
-! [ 3 ] [ "aacb" "aa?c" <regexp> match-head ] unit-test
+[ 1 ] [ "\ra" R/ ^a/m count-matches ] unit-test
-! [ 3 ] [ "aacb" "aa??c" <regexp> match-head ] unit-test
 
-! "ab" "a(?=b*)" <regexp> match
+[ t ] [ "a" R/ a$/m matches? ] unit-test
-! "abbbbbc" "a(?=b*c)" <regexp> match
+[ f ] [ "a\n" R/ a$/m matches? ] unit-test
-! "ab" "a(?=b*)" <regexp> match
+[ 1 ] [ "a\n" R/ a$/m count-matches ] unit-test
+[ 1 ] [ "a\r" R/ a$/m count-matches ] unit-test
+[ 1 ] [ "a\r\n" R/ a$/m count-matches ] unit-test
 
-! "baz" "(az)(?<=b)" <regexp> first-match
+[ f ] [ "foobxr" "foo\\z" <regexp> first-match ] unit-test
-! "cbaz" "a(?<=b*)" <regexp> first-match
+[ 3 ] [ "foo" "foo\\z" <regexp> first-match length ] unit-test
-! "baz" "a(?<=b)" <regexp> first-match
 
-! "baz" "a(?<!b)" <regexp> first-match
+[ t ] [ "a foo b" R/ foo/ re-contains? ] unit-test
-! "caz" "a(?<!b)" <regexp> first-match
+[ f ] [ "a bar b" R/ foo/ re-contains? ] unit-test
+[ t ] [ "foo" R/ foo/ re-contains? ] unit-test
 
-! "abcdefg" "a(?=bcdefg)bcd" <regexp> first-match
+[ { "foo" "fxx" "fab" } ] [ "fab fxx foo" R/ f../r all-matching-subseqs ] unit-test
-! "abcdefg" "a(?#bcdefg)bcd" <regexp> first-match
-! "abcdefg" "a(?:bcdefg)" <regexp> first-match
 
-! "caba" "a(?<=b)" <regexp> first-match
+[ t ] [ "foo" "\\bfoo\\b" <regexp> re-contains? ] unit-test
+[ t ] [ "afoob" "\\Bfoo\\B" <regexp> re-contains? ] unit-test
+[ f ] [ "afoob" "\\bfoo\\b" <regexp> re-contains? ] unit-test
+[ f ] [ "foo" "\\Bfoo\\B" <regexp> re-contains? ] unit-test
 
-! capture group 1: "aaaa"  2: ""
+[ 3 ] [ "foo bar" "foo\\b" <regexp> first-match length ] unit-test
-! "aaaa" "(a*)(a*)" <regexp> match*
+[ f ] [ "fooxbar" "foo\\b" <regexp> re-contains? ] unit-test
-! "aaaa" "(a*)(a+)" <regexp> match*
+[ t ] [ "foo" "foo\\b" <regexp> re-contains? ] unit-test
+[ t ] [ "foo bar" "foo\\b bar" <regexp> matches? ] unit-test
+[ f ] [ "fooxbar" "foo\\bxbar" <regexp> matches? ] unit-test
+[ f ] [ "foo" "foo\\bbar" <regexp> matches? ] unit-test
+
+[ f ] [ "foo bar" "foo\\B" <regexp> re-contains? ] unit-test
+[ 3 ] [ "fooxbar" "foo\\B" <regexp> first-match length ] unit-test
+[ f ] [ "foo" "foo\\B" <regexp> re-contains? ] unit-test
+[ f ] [ "foo bar" "foo\\B bar" <regexp> matches? ] unit-test
+[ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
+[ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
+
+[ t ] [ "ab" "a(?=b*)" <regexp> re-contains? ] unit-test
+[ t ] [ "abbbbbc" "a(?=b*c)" <regexp> re-contains? ] unit-test
+[ f ] [ "abbbbb" "a(?=b*c)" <regexp> re-contains? ] unit-test
+[ t ] [ "ab" "a(?=b*)" <regexp> re-contains? ] unit-test
+
+[ "az" ] [ "baz" "(?<=b)(az)" <regexp> first-match >string ] unit-test
+[ f ] [ "chaz" "(?<=b)(az)" <regexp> re-contains? ] unit-test
+[ "a" ] [ "cbaz" "(?<=b*)a" <regexp> first-match >string ] unit-test
+[ f ] [ "baz" "a(?<=b)" <regexp> re-contains? ] unit-test
+
+[ f ] [ "baz" "(?<!b)a" <regexp> re-contains? ] unit-test
+[ t ] [ "caz" "(?<!b)a" <regexp> re-contains? ] unit-test
+
+[ "abcd" ] [ "abcdefg" "a(?=bcdefg)bcd" <regexp> first-match >string ] unit-test
+[ t ] [ "abcdefg" "a(?#bcdefg)bcd" <regexp> re-contains? ] unit-test
+[ t ] [ "abcdefg" "a(?:bcdefg)" <regexp> matches? ] unit-test
+
+[ 3 ] [ "caba" "(?<=b)a" <regexp> first-match from>> ] unit-test