Merge branch 'master' of git://factorcode.org/git/factor into clean-linux-x86-32

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/globs/globs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel regexp.combinators regexp.matchers strings unicode.case
+USING: sequences kernel regexp.combinators strings unicode.case
 peg.ebnf regexp arrays ;
 IN: globs
 

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

@@ -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 [

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.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/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/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/prettyprint/prettyprint.factor

@@ -165,7 +165,7 @@ SYMBOL: pprint-string-cells?
                 ] each
             ] with-row
         ] each
-    ] tabular-output ;
+    ] tabular-output nl ;
 
 GENERIC: see ( defspec -- )
 

basis/regexp/classes/classes-tests.factor

@@ -30,15 +30,15 @@ IN: regexp.classes.tests
 [ T{ or-class { seq { 3 2 } } } ] [ { 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 replace-question ] unit-test
+[ f ] [ 1 <not-class> 1 t answer ] 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 answer ] 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 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
@@ -46,13 +46,13 @@ 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 replace-question ] unit-test
+[ t ] [ foo <primitive-class> dup t answer ] unit-test
-[ f ] [ foo <primitive-class> dup f replace-question ] unit-test
+[ f ] [ foo <primitive-class> dup f answer ] unit-test
-[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> t replace-question ] 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 replace-question ] 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 replace-question ] 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 replace-question ] 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 replace-question ] 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 replace-question ] 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 replace-question ] 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 replace-question ] 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

@@ -163,20 +163,32 @@ M: integer combine-or
 : try-combine ( elt1 elt2 quot -- combined/f ? )
     3dup call [ [ 3drop ] dip t ] [ drop swapd call ] if ; inline
 
+DEFER: answer
+
+:: try-cancel ( elt1 elt2 empty -- combined/f ? )
+    [ elt1 elt2 empty answer dup elt1 = not ] try-combine ;
+
 :: prefix-combining ( seq elt quot: ( elt1 elt2 -- combined/f ? ) -- newseq )
     f :> combined!
-    seq [ elt quot try-combine swap combined! ] find drop
+    seq [ elt quot call swap combined! ] find drop
     [ seq remove-nth combined prefix ]
     [ seq elt prefix ] if* ; inline
 
+: combine-by ( seq quot -- new-seq )
+    { } swap '[ _ prefix-combining ] reduce ; inline
+
+:: seq>instance ( seq empty class -- instance )
+    seq length {
+        { 0 [ empty ] }
+        { 1 [ seq first ] }
+        [ drop class new seq >>seq ]
+    } case ; inline
+
 :: combine ( seq quot: ( elt1 elt2 -- combined/f ? ) empty class -- newseq )
     seq class flatten
-    { } [ quot prefix-combining ] reduce
+    [ quot try-combine ] combine-by
-    dup length {
+    ! [ empty try-cancel ] combine-by ! This makes the algorithm O(n^4)
-        { 0 [ drop empty ] }
+    empty class seq>instance ; inline
-        { 1 [ first ] }
-        [ drop class new swap >>seq ]
-    } case ; inline
 
 : <and-class> ( seq -- class )
     [ combine-and ] t and-class combine ;
@@ -218,36 +230,36 @@ UNION: class primitive-class not-class or-class and-class range ;
 TUPLE: condition question yes no ;
 C: <condition> condition
 
-GENERIC# replace-question 2 ( class from to -- new-class )
+GENERIC# answer 2 ( class from to -- new-class )
 
-M:: object replace-question ( 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 '[ _ _ replace-question ] map ;
+    [ seq>> ] 2dip '[ _ _ answer ] map ;
 
-M: and-class replace-question
+M: and-class answer
     replace-compound <and-class> ;
 
-M: or-class replace-question
+M: or-class answer
     replace-compound <or-class> ;
 
-M: not-class replace-question
+M: not-class answer
-    [ class>> ] 2dip replace-question <not-class> ;
+    [ class>> ] 2dip answer <not-class> ;
 
-: answer ( table question answer -- new-table )
+: assoc-answer ( table question answer -- new-table )
-    '[ _ _ replace-question ] assoc-map
+    '[ _ _ answer ] assoc-map
     [ nip ] assoc-filter ;
 
-: answers ( table questions answer -- new-table )
+: assoc-answers ( table questions answer -- new-table )
-    '[ _ answer ] each ;
+    '[ _ assoc-answer ] each ;
 
 DEFER: make-condition
 
 : (make-condition) ( table questions question -- condition )
     [ 2nip ]
-    [ swap [ t answer ] dip make-condition ]
+    [ swap [ t assoc-answer ] dip make-condition ]
-    [ swap [ f answer ] dip make-condition ] 3tri
+    [ swap [ f assoc-answer ] dip make-condition ] 3tri
     2dup = [ 2nip ] [ <condition> ] if ;
 
 : make-condition ( table questions -- condition )

basis/regexp/combinators/combinators-tests.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: regexp.combinators tools.test regexp kernel sequences regexp.matchers ;
+USING: regexp.combinators tools.test regexp kernel sequences ;
 IN: regexp.combinators.tests
 
 : strings ( -- regexp )
@@ -16,7 +16,7 @@ USE: multiline
     { R' .*a' R' b.*' } <and> ;
 
 [ t ] [ "bljhasflsda" conj matches? ] unit-test
-[ f ] [ "bsdfdfs" conj matches? ] unit-test ! why does this fail?
+[ f ] [ "bsdfdfs" conj matches? ] unit-test
 [ f ] [ "fsfa" conj matches? ] unit-test
 
 [ f ] [ "bljhasflsda" conj <not> matches? ] unit-test

basis/regexp/compiler/compiler.factor

@@ -1,19 +1,19 @@
 ! Copyright (C) 2009 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: regexp.classes kernel sequences regexp.negation
-quotations regexp.minimize assocs fry math locals combinators
+quotations assocs fry math locals combinators
 accessors words compiler.units kernel.private strings
-sequences.private arrays regexp.matchers call namespaces
+sequences.private arrays call namespaces
 regexp.transition-tables combinators.short-circuit ;
 IN: regexp.compiler
 
 GENERIC: question>quot ( question -- quot )
 
-<PRIVATE
-
 SYMBOL: shortest?
 SYMBOL: backwards?
 
+<PRIVATE
+
 M: t question>quot drop [ 2drop t ] ;
 
 M: beginning-of-input question>quot
@@ -64,7 +64,7 @@ C: <box> box
 
 : non-literals>dispatch ( literals non-literals  -- quot )
     [ swap ] assoc-map ! we want state => predicate, and get the opposite as input
-    swap keys f answers
+    swap keys f assoc-answers
     table>condition [ <box> ] condition-map condition>quot ;
 
 : literals>cases ( literal-transitions -- case-body )
@@ -106,13 +106,15 @@ C: <box> box
     transitions>quot ;
 
 : states>code ( words dfa -- )
-    '[
+    [ ! with-compilation-unit doesn't compile, so we need call( -- )
         [
-            dup _ word>quot
+            '[
-            (( last-match index string -- ? ))
+                dup _ word>quot
-            define-declared
+                (( last-match index string -- ? ))
-        ] each
+                define-declared
-    ] with-compilation-unit ;
+            ] each
+        ] with-compilation-unit
+    ] call( words dfa -- ) ;
 
 : states>words ( dfa -- words dfa )
     dup transitions>> keys [ gensym ] H{ } map>assoc
@@ -120,34 +122,23 @@ C: <box> box
     [ values ]
     bi swap ; 
 
-: dfa>word ( dfa -- word )
+: dfa>main-word ( dfa -- word )
     states>words [ states>code ] keep start-state>> ;
 
-: check-string ( string -- string )
-    ! Make this configurable
-    dup string? [ "String required" throw ] unless ;
-
-: setup-regexp ( start-index string -- f start-index string )
-    [ f ] [ >fixnum ] [ check-string ] tri* ; inline
-
 PRIVATE>
 
-! The quotation returned is ( start-index string -- i/f )
+: simple-define-temp ( quot effect -- word )
+    [ [ define-temp ] with-compilation-unit ] call( quot effect -- word ) ;
 
-: dfa>quotation ( dfa -- quot )
+: dfa>word ( dfa -- quot )
-    dfa>word execution-quot '[ setup-regexp @ ] ;
+    dfa>main-word execution-quot '[ drop [ f ] 2dip @ ]
+    (( start-index string regexp -- i/f )) simple-define-temp ;
 
-: dfa>shortest-quotation ( dfa -- quot )
+: dfa>shortest-word ( dfa -- word )
-    t shortest? [ dfa>quotation ] with-variable ;
+    t shortest? [ dfa>word ] with-variable ;
 
-: dfa>reverse-quotation ( dfa -- quot )
+: dfa>reverse-word ( dfa -- word )
-    t backwards? [ dfa>quotation ] with-variable ;
+    t backwards? [ dfa>word ] with-variable ;
 
-: dfa>reverse-shortest-quotation ( dfa -- quot )
+: dfa>reverse-shortest-word ( dfa -- word )
-    t backwards? [ dfa>shortest-quotation ] with-variable ;
+    t backwards? [ dfa>shortest-word ] with-variable ;
-
-TUPLE: quot-matcher quot ;
-C: <quot-matcher> quot-matcher
-
-M: quot-matcher match-index-from
-    quot>> call( index string -- i/f ) ;

basis/regexp/negation/negation.factor

@@ -6,9 +6,6 @@ regexp.ast regexp.transition-tables regexp.minimize
 regexp.dfa namespaces ;
 IN: regexp.negation
 
-: ast>dfa ( parse-tree -- minimal-dfa )
-    construct-nfa disambiguate construct-dfa minimize ;
-
 CONSTANT: fail-state -1
 
 : add-default-transition ( state's-transitions -- new-state's-transitions )
@@ -49,5 +46,8 @@ CONSTANT: fail-state -1
     [ 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/regexp-docs.factor

@@ -1,6 +1,6 @@
 ! 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.matchers math ;
+USING: kernel strings help.markup help.syntax math ;
 IN: regexp
 
 ABOUT: "regexp"
@@ -39,13 +39,14 @@ ARTICLE: { "regexp" "theory" } "The theory of regular expressions"
 "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 all-matches }
 { $subsection matches? }
+{ $subsection re-contains? }
+{ $subsection first-match }
+{ $subsection all-matches }
 { $subsection re-split1 }
 { $subsection re-split }
 { $subsection re-replace }
-{ $subsection count-matches }
+{ $subsection count-matches } ;
-{ $subsection re-replace } ;
 
 HELP: <regexp>
 { $values { "string" string } { "regexp" regexp } }
@@ -63,25 +64,33 @@ HELP: regexp
 { $class-description "The class of regular expressions. To construct these, see " { $link { "regexp" "construction" } } "." } ;
 
 HELP: matches?
-{ $values { "string" string } { "matcher" regexp } { "?" "a boolean" } }
+{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } }
 { $description "Tests if the string as a whole matches the given regular expression." } ;
 
 HELP: re-split1
-{ $values { "string" string } { "matcher" regexp } { "before" string } { "after/f" string } }
+{ $values { "string" string } { "regexp" regexp } { "before" string } { "after/f" string } }
 { $description "Searches the string for a substring which matches the pattern. If found, the input string is split on the leftmost and longest occurence of the match, and the two halves are given as output. If no match is found, then the input string and " { $link f } " are output." } ;
 
 HELP: all-matches
-{ $values { "string" string } { "matcher" regexp } { "seq" "a sequence of slices of the input" } }
+{ $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 } { "matcher" regexp } { "n" integer } }
+{ $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-matches } "." } ;
 
 HELP: re-split
-{ $values { "string" string } { "matcher" regexp } { "seq" "a sequence of slices of the input" } }
+{ $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-matches } "." } ;
 
 HELP: re-replace
-{ $values { "string" string } { "matcher" regexp } { "replacement" string } { "result" string } }
+{ $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-matches } "." } ;
+
+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,13 +1,12 @@
 ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: regexp tools.test kernel sequences regexp.parser regexp.private
-eval strings multiline accessors regexp.matchers ;
+eval strings multiline accessors ;
 IN: regexp-tests
 
 \ <regexp> must-infer
-! the following don't compile because [ ] with-compilation-unit doesn't compile
+\ compile-regexp must-infer
-! \ compile-regexp must-infer
+\ matches? must-infer
-! \ matches? must-infer
 
 [ f ] [ "b" "a*" <regexp> matches? ] unit-test
 [ t ] [ "" "a*" <regexp> matches? ] unit-test
@@ -212,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-index-head ] unit-test
+[ "aaa" ] [ "aaacb" "a*" <regexp> first-match >string ] unit-test
-[ 2 ] [ "aaacb" "aa?" <regexp> match-index-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
@@ -240,11 +239,11 @@ IN: regexp-tests
 [ f ] [ "A" "\\p{Lower}" <regexp> matches? ] unit-test
 [ t ] [ "A" R/ \p{Lower}/i matches? ] unit-test
 
-[ t ] [ "abc" reverse R/ abc/r matches? ] unit-test
+[ t ] [ "abc" R/ abc/r matches? ] unit-test
-[ t ] [ "abc" reverse R/ a[bB][cC]/r matches? ] unit-test
+[ t ] [ "abc" R/ a[bB][cC]/r matches? ] unit-test
 
-[ t ] [ 3 "xabc" R/ abc/ <reverse-matcher> match-index-from >boolean ] unit-test
+[ t ] [ 3 "xabc" R/ abc/r match-index-from >boolean ] unit-test
-[ t ] [ 3 "xabc" R/ a[bB][cC]/ <reverse-matcher> 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
@@ -269,13 +268,13 @@ IN: regexp-tests
 
 [ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test
 
-[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> match-head >string ] unit-test
+[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
-[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> match-head >string ] unit-test
+[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
 
-[ "ab" ] [ "ab" "(ab|a)(bc)?" <regexp> match-head >string ] unit-test
+[ "ab" ] [ "ab" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
-[ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> match-head >string ] unit-test
+[ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
 
-[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> match-head >string ] unit-test
+[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
 
 [ { "1" "2" "3" "4" } ]
 [ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
@@ -301,18 +300,18 @@ IN: regexp-tests
   
 [ "-- title --" ] [ "== title ==" R/ =/ "-" re-replace ] unit-test
 
-[ "" ] [ "ab" "a(?!b)" <regexp> match-head >string ] unit-test
+[ "" ] [ "ab" "a(?!b)" <regexp> first-match >string ] unit-test
-[ "a" ] [ "ac" "a(?!b)" <regexp> match-head >string ] 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> match-head >string ] unit-test
+[ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> first-match >string ] unit-test
-[ "a" ] [ "ba" "(?<=b)(?<=b)a" <regexp> match-head >string ] unit-test
+[ "a" ] [ "ba" "(?<=b)(?<=b)a" <regexp> first-match >string ] unit-test
-[ "a" ] [ "cab" "(?<=c)a(?=b)" <regexp> match-head >string ] unit-test
+[ "a" ] [ "cab" "(?<=c)a(?=b)" <regexp> first-match >string ] unit-test
 
-[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-index-head ] unit-test
+[ 3 ] [ "foobar" "foo(?=bar)" <regexp> first-match length ] unit-test
-[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-index-head ] unit-test
+[ f ] [ "foobxr" "foo(?=bar)" <regexp> first-match ] unit-test
 
 ! Bug in parsing word
 [ t ] [ "a" R' a' matches? ] unit-test
@@ -342,9 +341,19 @@ IN: regexp-tests
 
 [ t ] [ "aaaa" R/ .*a./ matches? ] unit-test
 
+[ f ] [ "ab" R/ (?~ac|\p{Lower}b)/ matches? ] unit-test
+[ f ] [ "ab" R/ (?~ac|[a-z]b)/ matches? ] unit-test
+[ f ] [ "ac" R/ (?~ac|\p{Lower}b)/ 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
+
 ! DFA is compiled when needed, or when literal
-[ f ] [ "foo" <regexp> dfa>> >boolean ] unit-test
+[ regexp-initial-word ] [ "foo" <regexp> dfa>> ] unit-test
-[ t ] [ R/ foo/ dfa>> >boolean ] unit-test
+[ f ] [ R/ foo/ dfa>> \ regexp-initial-word = ] unit-test
 
 [ t ] [ "a" R/ ^a/ matches? ] unit-test
 [ f ] [ "\na" R/ ^a/ matches? ] unit-test
@@ -415,8 +424,12 @@ IN: regexp-tests
 [ 1 ] [ "a\r" R/ a$/m count-matches ] unit-test
 [ 1 ] [ "a\r\n" R/ a$/m count-matches ] unit-test
 
-[ f ] [ "foobxr" "foo\\z" <regexp> match-index-head ] unit-test
+[ f ] [ "foobxr" "foo\\z" <regexp> first-match ] unit-test
-[ 3 ] [ "foo" "foo\\z" <regexp> match-index-head ] unit-test
+[ 3 ] [ "foo" "foo\\z" <regexp> first-match length ] unit-test
+
+[ t ] [ "a foo b" R/ foo/ re-contains? ] unit-test
+[ f ] [ "a bar b" R/ foo/ re-contains? ] unit-test
+[ t ] [ "foo" R/ foo/ re-contains? ] unit-test
 
 ! [ t ] [ "foo" "\\bfoo\\b" <regexp> matches? ] unit-test
 ! [ t ] [ "afoob" "\\Bfoo\\B" <regexp> matches? ] unit-test

basis/regexp/regexp.factor

@@ -2,71 +2,166 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators kernel math sequences strings sets
 assocs prettyprint.backend prettyprint.custom make lexer
-namespaces parser arrays fry locals regexp.minimize
+namespaces parser arrays fry locals regexp.parser splitting
-regexp.parser regexp.nfa regexp.dfa regexp.classes
+sorting regexp.ast regexp.negation regexp.compiler words
-regexp.transition-tables splitting sorting regexp.ast
+call call.private math.ranges ;
-regexp.negation regexp.matchers regexp.compiler ;
 IN: regexp
 
 TUPLE: regexp
     { raw read-only }
     { parse-tree read-only }
     { options read-only }
-    dfa reverse-dfa ;
+    dfa next-match ;
 
-: make-regexp ( string ast -- regexp )
+TUPLE: reverse-regexp < regexp ;
-    f f <options> f f regexp boa ; foldable
-    ! Foldable because, when the dfa slot is set,
-    ! it'll be set to the same thing regardless of who sets it
 
-: <optioned-regexp> ( string options -- regexp )
+<PRIVATE
-    [ dup parse-regexp ] [ string>options ] bi*
-    f f regexp boa ;
 
-: <regexp> ( string -- regexp ) "" <optioned-regexp> ;
+: maybe-negated ( lookaround quot -- regexp-quot )
+    '[ term>> @ ] [ positive?>> [ ] [ not ] ? ] bi compose ; inline
 
-TUPLE: reverse-matcher regexp ;
+M: lookahead question>quot ! Returns ( index string -- ? )
-C: <reverse-matcher> reverse-matcher
+    [ ast>dfa dfa>shortest-word '[ f _ execute ] ] maybe-negated ;
-! Reverse matchers won't work properly with most combinators, for now
+
+: <reversed-option> ( ast -- reversed )
+    "r" string>options <with-options> ;
+
+M: lookbehind question>quot ! Returns ( index string -- ? )
+    [
+        <reversed-option>
+        ast>dfa dfa>reverse-shortest-word
+        '[ [ 1- ] dip f _ execute ]
+    ] maybe-negated ;
+
+<PRIVATE
+
+: check-string ( string -- string )
+    ! Make this configurable
+    dup string? [ "String required" throw ] unless ;
+
+: match-index-from ( i string regexp -- index/f )
+    ! This word is unsafe. It assumes that i is a fixnum
+    ! and that string is a string.
+    dup dfa>> execute( index string regexp -- i/f ) ;
+
+GENERIC: end/start ( string regexp -- end start )
+M: regexp end/start drop length 0 ;
+M: reverse-regexp end/start drop length 1- -1 swap ;
+
+PRIVATE>
+
+: matches? ( string regexp -- ? )
+    [ end/start ] 2keep
+    [ check-string ] dip
+    match-index-from
+    [ swap = ] [ drop f ] if* ;
+
+<PRIVATE
+
+: match-slice ( i string quot -- slice/f )
+    [ 2dup ] dip call
+    [ swap <slice> ] [ 2drop f ] if* ; inline
+
+: match-from ( i string quot -- slice/f )
+    [ [ length [a,b) ] keep ] dip
+    '[ _ _ match-slice ] map-find drop ; inline
+
+: next-match ( i string quot -- i match/f )
+    match-from [ dup [ to>> ] when ] keep ; inline
+
+: do-next-match ( i string regexp -- i match/f )
+    dup next-match>> execute( i string regexp -- i match/f ) ;
+
+PRIVATE>
+
+: all-matches ( string regexp -- seq )
+    [ check-string ] dip
+    [ 0 [ dup ] ] 2dip '[ _ _ do-next-match ] produce
+    nip but-last ;
+
+: count-matches ( string regexp -- n )
+    all-matches length ;
+
+<PRIVATE
+
+:: split-slices ( string slices -- new-slices )
+    slices [ to>> ] map 0 prefix
+    slices [ from>> ] map string length suffix
+    [ string <slice> ] 2map ;
+
+PRIVATE>
+
+: first-match ( string regexp -- slice/f )
+    [ 0 ] [ check-string ] [ ] tri*
+    do-next-match nip ;
+
+: re-contains? ( string regexp -- ? )
+    first-match >boolean ;
+
+: re-split1 ( string regexp -- before after/f )
+    dupd first-match [ 1array split-slices first2 ] [ f ] if* ;
+
+: re-split ( string regexp -- seq )
+    dupd all-matches split-slices ;
+
+: re-replace ( string regexp replacement -- result )
+    [ re-split ] dip join ;
 
 <PRIVATE
 
 : get-ast ( regexp -- ast )
     [ parse-tree>> ] [ options>> ] bi <with-options> ;
 
-: compile-regexp ( regexp -- regexp )
+GENERIC: compile-regexp ( regex -- regexp )
-    dup '[ [ _ get-ast ast>dfa dfa>quotation ] unless* ] change-dfa ;
 
-: <reversed-option> ( ast -- reversed )
+: regexp-initial-word ( i string regexp -- i/f )
-    "r" string>options <with-options> ;
+    compile-regexp match-index-from ;
 
-: maybe-negated ( lookaround quot -- regexp-quot )
+: do-compile-regexp ( regexp -- regexp )
-    '[ term>> @ ] [ positive?>> [ ] [ not ] ? ] bi compose ; inline
-
-M: lookahead question>quot ! Returns ( index string -- ? )
-    [ ast>dfa dfa>shortest-quotation ] maybe-negated ;
-
-M: lookbehind question>quot ! Returns ( index string -- ? )
-    [
-        <reversed-option>
-        ast>dfa dfa>reverse-shortest-quotation
-        [ [ 1- ] dip ] prepose
-    ] maybe-negated ;
-
-: compile-reverse ( regexp -- regexp )
     dup '[
-        [
+        dup \ regexp-initial-word =
-            _ get-ast <reversed-option>
+        [ drop _ get-ast ast>dfa dfa>word ] when
-            ast>dfa dfa>reverse-quotation
+    ] change-dfa ;
-        ] unless*
-    ] change-reverse-dfa ;
 
-M: regexp match-index-from
+M: regexp compile-regexp ( regexp -- regexp )
-    compile-regexp dfa>> <quot-matcher> match-index-from ;
+    do-compile-regexp ;
 
-M: reverse-matcher match-index-from
+M: reverse-regexp compile-regexp ( regexp -- regexp )
-    regexp>> compile-reverse reverse-dfa>>
+    t backwards? [ do-compile-regexp ] with-variable ;
-    <quot-matcher> match-index-from ;
+
+GENERIC: compile-next-match ( regexp -- regexp )
+
+: next-initial-word ( i string regexp -- i slice/f )
+    compile-next-match do-next-match ;
+
+M: regexp compile-next-match ( regexp -- regexp )
+    dup '[
+        dup \ next-initial-word = [
+            drop _ compile-regexp dfa>>
+            '[ _ '[ _ _ execute ] next-match ]
+            (( i string -- i match/f )) simple-define-temp
+        ] when
+    ] change-next-match ;
+
+! Write M: reverse-regexp compile-next-match
+
+PRIVATE>
+
+: new-regexp ( string ast options class -- regexp )
+    [ \ regexp-initial-word \ next-initial-word ] dip boa ; inline
+
+: make-regexp ( string ast -- regexp )
+    f f <options> regexp new-regexp ;
+
+: <optioned-regexp> ( string options -- regexp )
+    [ dup parse-regexp ] [ string>options ] bi*
+    dup on>> reversed-regexp swap member?
+    [ reverse-regexp new-regexp ]
+    [ regexp new-regexp ] if ;
+
+: <regexp> ( string -- regexp ) "" <optioned-regexp> ;
+
+<PRIVATE
 
 ! The following two should do some caching
 
@@ -97,7 +192,7 @@ M: reverse-matcher match-index-from
 
 : parsing-regexp ( accum end -- accum )
     lexer get [ take-until ] [ parse-noblank-token ] bi
-    <optioned-regexp> compile-regexp parsed ;
+    <optioned-regexp> compile-next-match parsed ;
 
 PRIVATE>
 
@@ -120,3 +215,4 @@ M: regexp pprint*
             [ options>> options>string % ] bi
         ] "" make
     ] keep present-text ;
+

basis/stack-checker/backend/backend.factor

@@ -155,7 +155,7 @@ M: object apply-object push-literal ;
     "cannot-infer" word-prop rethrow ;
 
 : maybe-cannot-infer ( word quot -- )
-    [ [ "cannot-infer" set-word-prop ] keep throw ] recover ; inline
+    [ [ "cannot-infer" set-word-prop ] keep rethrow ] recover ; inline
 
 : infer-word ( word -- effect )
     [

basis/tools/memory/memory.factor

@@ -63,11 +63,12 @@ PRIVATE>
         { "" "Total" "Used" "Free" } write-headings
         (data-room.)
     ] tabular-output
-    nl
+    nl nl
     "==== CODE HEAP" print
     standard-table-style [
         (code-room.)
-    ] tabular-output ;
+    ] tabular-output
+    nl ;
 
 : heap-stats ( -- counts sizes )
     [ ] instances H{ } clone H{ } clone
@@ -83,4 +84,4 @@ PRIVATE>
                 pick at pprint-cell
             ] with-row
         ] each 2drop
-    ] tabular-output ;
+    ] tabular-output nl ;

basis/tools/profiler/profiler.factor

@@ -46,9 +46,7 @@ IN: tools.profiler
     profiler-usage counters ;
 
 : counters. ( assoc -- )
-    standard-table-style [
+    sort-values simple-table. ;
-        sort-values simple-table.
-    ] tabular-output ;
 
 : profile. ( -- )
     "Call counts for all words:" print

basis/tools/threads/threads.factor

@@ -29,4 +29,4 @@ IN: tools.threads
         threads >alist sort-keys values [
             [ thread. ] with-row
         ] each
-    ] tabular-output ;
+    ] tabular-output nl ;

basis/tools/vocabs/browser/browser.factor

@@ -66,15 +66,18 @@ C: <vocab-author> vocab-author
 : describe-children ( vocab -- )
     vocab-name all-child-vocabs $vocab-roots ;
 
+: files. ( seq -- )
+    snippet-style get [
+        code-style get [
+            [ nl ] [ [ string>> ] keep write-object ] interleave
+        ] with-nesting
+    ] with-style ;
+
 : describe-files ( vocab -- )
     vocab-files [ <pathname> ] map [
         "Files" $heading
         [
-            snippet-style get [
+            files.
-                code-style get [
-                    stack.
-                ] with-nesting
-            ] with-style
         ] ($block)
     ] unless-empty ;
 

basis/ui/gadgets/glass/glass-docs.factor

@@ -0,0 +1,55 @@
+IN: ui.gadgets.glass
+USING: help.markup help.syntax ui.gadgets math.rectangles ;
+
+HELP: show-glass
+{ $values { "owner" gadget } { "child" gadget } { "visible-rect" rect } }
+{ $description "Displays " { $snippet "child" } " in the glass layer of the window containing " { $snippet "owner" } "."
+  $nl
+  "The child's position is calculated with a heuristic:"
+  { $list
+    "The child must fit inside the window"
+    { "The child must not obscure " { $snippet "visible-rect" } ", which is a rectangle whose origin is relative to " { $snippet "owner" } }
+    { "The child must otherwise be as close as possible to the edges of " { $snippet "visible-rect" } }
+  }
+  "For example, when displaying a menu, " { $snippet "visible-rect" } " is a single point at the mouse location, and when displaying a completion popup, " { $snippet "visible-rect" } " contains the bounds of the text element being completed."
+} ;
+
+HELP: hide-glass
+{ $values { "child" gadget } }
+{ $description "Hides a gadget displayed in a glass layer." } ;
+
+HELP: hide-glass-hook
+{ $values { "gadget" gadget } }
+{ $description "Called when a gadget displayed in a glass layer is hidden. The gadget can perform cleanup tasks here." } ;
+
+HELP: pass-to-popup
+{ $values { "gesture" "a gesture" } { "owner" "the popup's owner" } { "?" "a boolean" } }
+{ $description "Resends the gesture to the popup displayed by " { $snippet "owner" } ". The owner must have a " { $slot "popup" } " slot. Outputs " { $link f } " if the gesture was handled, " { $link t } " otherwise." } ;
+
+HELP: show-popup
+{ $values { "owner" gadget } { "popup" gadget } { "visible-rect" rect } }
+{ $description "Displays " { $snippet "popup" } " in the glass layer of the window containing " { $snippet "owner" } " as a popup."
+  $nl
+  "This word differs from " { $link show-glass } " in two respects:"
+  { $list
+    { "The popup is stored in the owner's " { $slot "popup" } " slot; the owner can call " { $link pass-to-popup } " to pass keyboard gestures to the popup" }
+    { "Pressing " { $snippet "ESC" } " with the popup visible will hide it" }
+  }
+} ;
+
+ARTICLE: "ui.gadgets.glass" "Glass layers"
+"The " { $vocab-link "ui.gadgets.glass" } " vocabulary implements support for displaying gadgets in the glass layer of a window. The gadget can be positioned arbitrarily within the glass layer, and while it is visible, mouse clicks outside of the glass layer are intercepted to hide the glass layer. Multiple glass layers can be active at a time; they behave as if stacked on top of each other."
+$nl
+"This feature is used for completion popups and " { $link "ui.gadgets.menus" } " in the " { $link "ui-tools" } "."
+$nl
+"Displaying a gadget in a glass layer:"
+{ $subsection show-glass }
+"Hiding a gadget in a glass layer:"
+{ $subsection hide-glass }
+"Callback generic invoked on the gadget when its glass layer is hidden:"
+{ $subsection hide-glass-hook }
+"Popup gadgets add support for forwarding keyboard gestures from an owner gadget to the glass layer:"
+{ $subsection show-popup }
+{ $subsection pass-to-popup } ;
+
+ABOUT: "ui.gadgets.glass"

basis/ui/gadgets/glass/glass.factor

@@ -71,7 +71,7 @@ popup H{
     { T{ key-down f f "ESC" } [ hide-glass ] }
 } set-gestures
 
-: pass-to-popup ( gesture interactor -- ? )
+: pass-to-popup ( gesture owner -- ? )
     popup>> focusable-child resend-gesture ;
 
 : show-popup ( owner popup visible-rect -- )

basis/ui/gadgets/menus/menus-docs.factor

@@ -16,7 +16,7 @@ HELP: show-commands-menu
 { $notes "Useful for right-click context menus." } ;
 
 ARTICLE: "ui.gadgets.menus" "Popup menus"
-"The " { $vocab-link "ui.gadgets.menus" } " vocabulary implements popup menus."
+"The " { $vocab-link "ui.gadgets.menus" } " vocabulary displays popup menus in " { $link "ui.gadgets.glass" } "."
 { $subsection <commands-menu> }
 { $subsection show-menu }
 { $subsection show-commands-menu } ;

basis/ui/gadgets/panes/panes-tests.factor

@@ -19,7 +19,7 @@ IN: ui.gadgets.panes.tests
 
 : test-gadget-text ( quot -- ? )
     dup make-pane gadget-text dup print "======" print
-    swap with-string-writer dup print "\n" ?tail drop "\n" ?tail drop = ;
+    swap with-string-writer dup print = ;
 
 [ t ] [ [ "hello" write ] test-gadget-text ] unit-test
 [ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
@@ -87,6 +87,28 @@ IN: ui.gadgets.panes.tests
     ] test-gadget-text
 ] unit-test
 
+[ t ] [
+    [
+        last-element off
+        \ = >link title-style get [
+            $navigation-table
+        ] with-nesting
+        "Hello world" print-content
+    ] test-gadget-text
+] unit-test
+
+[ t ] [
+    [ { { "a\n" } } simple-table. ] test-gadget-text
+] unit-test
+
+[ t ] [
+    [ { { "a" } } simple-table. "x" write ] test-gadget-text
+] unit-test
+
+[ t ] [
+    [ H{ } [ { { "a" } } simple-table. ] with-nesting "x" write ] test-gadget-text
+] unit-test
+
 ARTICLE: "test-article-1" "This is a test article"
 "Hello world, how are you today." ;
 

basis/ui/gadgets/panes/panes.factor

@@ -17,6 +17,12 @@ TUPLE: pane < track
 output current input last-line prototype scrolls?
 selection-color caret mark selecting? ;
 
+TUPLE: pane-stream pane ;
+
+C: <pane-stream> pane-stream
+
+<PRIVATE
+
 : clear-selection ( pane -- pane )
     f >>caret f >>mark ; inline
 
@@ -49,12 +55,6 @@ M: pane gadget-selection? pane-caret&mark and ;
 M: pane gadget-selection ( pane -- string/f )
     selected-children gadget-text ;
 
-: pane-clear ( pane -- )
-    clear-selection
-    [ output>> clear-incremental ]
-    [ current>> clear-gadget ]
-    bi ;
-
 : init-prototype ( pane -- pane )
     <shelf> +baseline+ >>align >>prototype ; inline
 
@@ -70,17 +70,6 @@ M: pane gadget-selection ( pane -- string/f )
     [ >>last-line ] [ 1 track-add ] bi
     dup prepare-last-line ; inline
 
-: new-pane ( input class -- pane )
-    [ vertical ] dip new-track
-        swap >>input
-        pane-theme
-        init-prototype
-        init-output
-        init-current
-        init-last-line ; inline
-
-: <pane> ( -- pane ) f pane new-pane ;
-
 GENERIC: draw-selection ( loc obj -- )
 
 : if-fits ( rect quot -- )
@@ -112,10 +101,6 @@ M: pane draw-gadget*
 : scroll-pane ( pane -- )
     dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
 
-TUPLE: pane-stream pane ;
-
-C: <pane-stream> pane-stream
-
 : smash-line ( current -- gadget )
     dup children>> {
         { [ dup empty? ] [ 2drop "" <label> ] }
@@ -123,14 +108,18 @@ C: <pane-stream> pane-stream
         [ drop ]
     } cond ;
 
-: smash-pane ( pane -- gadget ) output>> smash-line ;
-
 : pane-nl ( pane -- )
     [
         [ current>> [ unparent ] [ smash-line ] bi ] [ output>> ] bi
         add-incremental
     ] [ next-line ] bi ;
 
+: ?pane-nl ( pane -- )
+    [ dup current>> children>> empty? [ pane-nl ] [ drop ] if ]
+    [ pane-nl ] bi ;
+
+: smash-pane ( pane -- gadget ) [ pane-nl ] [ output>> smash-line ] bi ;
+
 : pane-write ( seq pane -- )
     [ pane-nl ] [ current>> stream-write ]
     bi-curry interleave ;
@@ -139,43 +128,6 @@ C: <pane-stream> pane-stream
     [ nip pane-nl ] [ current>> stream-format ]
     bi-curry bi-curry interleave ;
 
-GENERIC: write-gadget ( gadget stream -- )
-
-M: pane-stream write-gadget ( gadget pane-stream -- )
-    pane>> current>> swap add-gadget drop ;
-
-M: style-stream write-gadget
-    stream>> write-gadget ;
-
-: print-gadget ( gadget stream -- )
-    [ write-gadget ] [ nip stream-nl ] 2bi ;
-
-: gadget. ( gadget -- )
-    output-stream get print-gadget ;
-
-: ?nl ( stream -- )
-    dup pane>> current>> children>> empty?
-    [ dup stream-nl ] unless drop ;
-
-: with-pane ( pane quot -- )
-    over scroll>top
-    over pane-clear [ <pane-stream> ] dip
-    over [ with-output-stream* ] dip ?nl ; inline
-
-: make-pane ( quot -- gadget )
-    <pane> [ swap with-pane ] keep smash-pane ; inline
-
-TUPLE: pane-control < pane quot ;
-
-M: pane-control model-changed ( model pane-control -- )
-    [ value>> ] [ dup quot>> ] bi*
-    '[ _ call( value -- ) ] with-pane ;
-
-: <pane-control> ( model quot -- pane )
-    f pane-control new-pane
-        swap >>quot
-        swap >>model ;
-
 : do-pane-stream ( pane-stream quot -- )
     [ pane>> ] dip keep scroll-pane ; inline
 
@@ -198,7 +150,59 @@ M: pane-stream stream-flush drop ;
 M: pane-stream make-span-stream
     swap <style-stream> <ignore-close-stream> ;
 
+PRIVATE>
+
+: new-pane ( input class -- pane )
+    [ vertical ] dip new-track
+        swap >>input
+        pane-theme
+        init-prototype
+        init-output
+        init-current
+        init-last-line ; inline
+
+: <pane> ( -- pane ) f pane new-pane ;
+
+GENERIC: write-gadget ( gadget stream -- )
+
+M: pane-stream write-gadget ( gadget pane-stream -- )
+    pane>> current>> swap add-gadget drop ;
+
+M: style-stream write-gadget
+    stream>> write-gadget ;
+
+: print-gadget ( gadget stream -- )
+    [ write-gadget ] [ nip stream-nl ] 2bi ;
+
+: gadget. ( gadget -- )
+    output-stream get print-gadget ;
+
+: pane-clear ( pane -- )
+    clear-selection
+    [ output>> clear-incremental ]
+    [ current>> clear-gadget ]
+    bi ;
+
+: with-pane ( pane quot -- )
+    [ [ scroll>top ] [ pane-clear ] [ <pane-stream> ] tri ] dip
+    with-output-stream* ; inline
+
+: make-pane ( quot -- gadget )
+    [ <pane> ] dip [ with-pane ] [ drop smash-pane ] 2bi ; inline
+
+TUPLE: pane-control < pane quot ;
+
+M: pane-control model-changed ( model pane-control -- )
+    [ value>> ] [ dup quot>> ] bi*
+    '[ _ call( value -- ) ] with-pane ;
+
+: <pane-control> ( model quot -- pane )
+    f pane-control new-pane
+        swap >>quot
+        swap >>model ;
+
 ! Character styles
+<PRIVATE
 
 MEMO: specified-font ( assoc -- font )
     #! We memoize here to avoid creating lots of duplicate font objects.
@@ -279,10 +283,7 @@ TUPLE: nested-pane-stream < pane-stream style parent ;
     inline
 
 : unnest-pane-stream ( stream -- child parent )
-    dup ?nl
+    [ [ style>> ] [ pane>> smash-pane ] bi style-pane ] [ parent>> ] bi ;
-    dup style>>
-    over pane>> smash-pane style-pane
-    swap parent>> ;
 
 TUPLE: pane-block-stream < nested-pane-stream ;
 
@@ -309,7 +310,7 @@ M: pane-stream make-block-stream
 
 TUPLE: pane-cell-stream < nested-pane-stream ;
 
-M: pane-cell-stream dispose ?nl ;
+M: pane-cell-stream dispose drop ;
 
 M: pane-stream make-cell-stream
     pane-cell-stream new-nested-pane-stream ;
@@ -318,7 +319,7 @@ M: pane-stream stream-write-table
     [
         swap [ [ pane>> smash-pane ] map ] map
         styled-grid
-    ] dip print-gadget ;
+    ] dip write-gadget ;
 
 ! Stream utilities
 M: pack dispose drop ;
@@ -433,6 +434,8 @@ M: f sloppy-pick-up*
 
 : pane-menu ( pane -- ) { com-copy } show-commands-menu ;
 
+PRIVATE>
+
 pane H{
     { T{ button-down } [ begin-selection ] }
     { T{ button-down f { S+ } 1 } [ select-to-caret ] }

basis/ui/gadgets/status-bar/status-bar-docs.factor

@@ -3,7 +3,7 @@ ui.gadgets ui.gadgets.worlds ui ;
 IN: ui.gadgets.status-bar
 
 HELP: show-status
-{ $values { "string" string } { "gadget" gadget } }
+{ $values { "string/f" string } { "gadget" gadget } }
 { $description "Displays a status message in the gadget's world." }
 { $notes "The status message will only be visible if the window was opened with " { $link open-status-window } ", and not " { $link open-window } "." } ;
 

basis/ui/pens/gradient/gradient.factor

@@ -41,4 +41,6 @@ M: gradient draw-interior
         [ last-vertices>> gl-vertex-pointer ]
         [ last-colors>> gl-color-pointer ]
         [ colors>> draw-gradient ]
-    } cleave ;
+    } cleave ;
+
+M: gradient pen-background 2drop transparent ;

basis/ui/pens/solid/solid.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors opengl ui.pens ui.pens.caching ;
+USING: kernel accessors opengl math colors ui.pens ui.pens.caching ;
 IN: ui.pens.solid
 
 TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
@@ -29,4 +29,4 @@ M: solid draw-boundary
     (gl-rect) ;
 
 M: solid pen-background
-    nip color>> ;
+    nip color>> dup alpha>> 1 number= [ drop transparent ] unless ;

basis/ui/tools/inspector/inspector.factor

@@ -33,19 +33,19 @@ M: inspector-renderer column-titles
             [
                 [
                     [ "Class:" write ] with-cell
-                    [ class . ] with-cell
+                    [ class pprint ] with-cell
                 ] with-row
             ]
             [
                 [
                     [ "Object:" write ] with-cell
-                    [ short. ] with-cell
+                    [ pprint-short ] with-cell
                 ] with-row
             ]
             [
                 [
                     [ "Summary:" write ] with-cell
-                    [ summary. ] with-cell
+                    [ print-summary ] with-cell
                 ] with-row
             ] tri
         ] tabular-output

basis/ui/tools/listener/listener.factor

@@ -175,7 +175,7 @@ TUPLE: listener-gadget < tool input output scroller ;
     [ listener-gadget? ] find-parent ;
 
 : listener-streams ( listener -- input output )
-    [ input>> ] [ output>> ] bi <pane-stream> ;
+    [ input>> ] [ output>> <pane-stream> ] bi ;
 
 : init-listener ( listener -- listener )
     <interactor>

basis/ui/ui-docs.factor

@@ -171,6 +171,7 @@ ARTICLE: "ui-layouts" "Gadget hierarchy and layouts"
 { $subsection "ui-frame-layout" }
 { $subsection "ui-book-layout" }
 "Advanced topics:"
+{ $subsection "ui.gadgets.glass" }
 { $subsection "ui-null-layout" }
 { $subsection "ui-incremental-layout" }
 { $subsection "ui-layout-impl" }

basis/validators/validators.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel continuations sequences math namespaces make sets
-math.parser math.ranges assocs regexp regexp.matchers unicode.categories arrays
+math.parser math.ranges assocs regexp unicode.categories arrays
 hashtables words classes quotations xmode.catalog unicode.case ;
 IN: validators
 

basis/xmode/marker/marker.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: xmode.marker
 USING: kernel namespaces make xmode.rules xmode.tokens
 xmode.marker.state xmode.marker.context xmode.utilities
 xmode.catalog sequences math assocs combinators strings
-regexp splitting ascii unicode.case regexp.matchers
+regexp splitting unicode.case ascii
-ascii combinators.short-circuit accessors ;
+combinators.short-circuit accessors ;
+IN: xmode.marker
 
 ! Next two words copied from parser-combinators
 ! Just like head?, but they optionally ignore case
@@ -84,7 +84,7 @@ M: string-matcher text-matches?
     ] keep string>> length and ;
 
 M: regexp text-matches?
-    [ >string ] dip match-head ;
+    [ >string ] dip re-contains? ;
 
 : rule-start-matches? ( rule -- match-count/f )
     dup start>> tuck swap can-match-here? [

extra/benchmark/regex-dna/regex-dna.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors regexp.matchers prettyprint io io.encodings.ascii
+USING: accessors prettyprint io io.encodings.ascii
 io.files kernel sequences assocs namespaces regexp ;
 IN: benchmark.regex-dna
 

extra/cap/cap.factor

@@ -1,30 +1,31 @@
 ! Copyright (C) 2008 Doug Coleman, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays byte-arrays kernel math namespaces
-opengl.gl sequences math.vectors ui images.bitmap images.viewer
+opengl.gl sequences math.vectors ui images images.viewer
 models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
 IN: cap
 
 : screenshot-array ( world -- byte-array )
-    dim>> [ first 3 * 4 align ] [ second ] bi * <byte-array> ;
+    dim>> [ first 4 * ] [ second ] bi * <byte-array> ;
 
 : gl-screenshot ( gadget -- byte-array )
     [
-        GL_BACK glReadBuffer
+        [
-        GL_PACK_ALIGNMENT 4 glPixelStorei
+            GL_BACK glReadBuffer
-        0 0
+            GL_PACK_ALIGNMENT 4 glPixelStorei
-    ] dip
+            0 0
-    [ dim>> first2 GL_BGR GL_UNSIGNED_BYTE ]
+        ] dip
+        dim>> first2 GL_RGBA GL_UNSIGNED_BYTE
+    ]
     [ screenshot-array ] bi
     [ glReadPixels ] keep ;
 
 : screenshot ( window -- bitmap )
-    [ gl-screenshot ]
+    [ <image> ] dip
-    [ dim>> first2 ] bi
+    [ gl-screenshot >>bitmap ] [ dim>> >>dim ] bi
-    bgr>bitmap ;
+    RGBA >>component-order
-
+    t >>upside-down?
-: save-screenshot ( window path -- )
+    normalize-image ;
-    [ screenshot ] dip save-bitmap ;
 
 : screenshot. ( window -- )
     [ screenshot <image-gadget> ] [ title>> ] bi open-window ; 

extra/images/viewer/viewer.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors images images.loader io.pathnames kernel
+USING: accessors images images.loader io.pathnames kernel namespaces
-namespaces opengl opengl.gl sequences strings ui ui.gadgets
+opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
 ui.gadgets.panes ui.render ;
 IN: images.viewer
 
@@ -12,8 +12,8 @@ M: image-gadget pref-dim*
 
 : draw-image ( image -- )
     0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
-    [ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE ]
+    [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
-    [ bitmap>> ] bi glDrawPixels ;
+    glDrawPixels ;
 
 M: image-gadget draw-gadget* ( gadget -- )
     image>> draw-image ;

extra/otug-talk/otug-talk.factor

@@ -1,41 +1,14 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: slides help.markup math arrays hashtables namespaces
+USING: slides help.markup math arrays hashtables namespaces sequences
-sequences kernel sequences parser memoize io.encodings.binary
+kernel sequences parser memoize io.encodings.binary locals
-locals kernel.private tools.vocabs.browser assocs quotations
+kernel.private tools.vocabs.browser assocs quotations tools.vocabs
- tools.vocabs tools.annotations tools.crossref
+tools.annotations tools.crossref help.topics math.functions
-help.topics math.functions compiler.tree.optimizer
+compiler.tree.optimizer compiler.cfg.optimizer fry ui.gadgets.panes
-compiler.cfg.optimizer fry
+tetris tetris.game combinators generalizations multiline
-ui.gadgets.panes tetris tetris.game combinators generalizations
+sequences.private ;
-multiline sequences.private ;
 IN: otug-talk
 
-USING: cairo cairo.ffi cairo.gadgets accessors
-io.backend ui.gadgets ;
-
-TUPLE: png-gadget < cairo-gadget surface ;
-
-: <png-gadget> ( file -- gadget )
-    png-gadget new-gadget
-    swap normalize-path
-    cairo_image_surface_create_from_png >>surface ; inline
-
-M: png-gadget pref-dim* ( gadget -- )
-    surface>>
-    [ cairo_image_surface_get_width ]
-    [ cairo_image_surface_get_height ]
-    bi 2array ;
-
-M: png-gadget render-cairo* ( gadget -- )
-    cr swap surface>> 0 0 cairo_set_source_surface
-    cr cairo_paint ;
-
-M: png-gadget ungraft* ( gadget -- )
-    surface>> cairo_surface_destroy ;
-
-: $bitmap ( element -- )
-    [ first <png-gadget> gadget. ] ($block) ;
-
 : $tetris ( element -- )
     drop [ <default-tetris> <tetris-gadget> gadget. ] ($block) ;
 
@@ -105,11 +78,11 @@ CONSTANT: otug-slides
     }
     { $slide "Data flow combinators - cleave family"
         { { $link bi } ", " { $link tri } ", " { $link cleave } }
-        { $bitmap "resource:extra/otug-talk/bi.png" }
+        { $image "resource:extra/otug-talk/bi.tiff" }
     }
     { $slide "Data flow combinators - cleave family"
         { { $link 2bi } ", " { $link 2tri } ", " { $link 2cleave } }
-        { $bitmap "resource:extra/otug-talk/2bi.png" }
+        { $image "resource:extra/otug-talk/2bi.tiff" }
     }
     { $slide "Data flow combinators"
         "First, let's define a data type:"
@@ -128,19 +101,19 @@ CONSTANT: otug-slides
     }
     { $slide "Data flow combinators - spread family"
         { { $link bi* } ", " { $link tri* } ", " { $link spread } }
-        { $bitmap "resource:extra/otug-talk/bi_star.png" }
+        { $image "resource:extra/otug-talk/bi_star.tiff" }
     }
     { $slide "Data flow combinators - spread family"
         { { $link 2bi* } }
-        { $bitmap "resource:extra/otug-talk/2bi_star.png" }
+        { $image "resource:extra/otug-talk/2bi_star.tiff" }
     }
     { $slide "Data flow combinators - apply family"
         { { $link bi@ } ", " { $link tri@ } ", " { $link napply } }
-        { $bitmap "resource:extra/otug-talk/bi_at.png" }
+        { $image "resource:extra/otug-talk/bi_at.tiff" }
     }
     { $slide "Data flow combinators - apply family"
         { { $link 2bi@ } }
-        { $bitmap "resource:extra/otug-talk/2bi_at.png" }
+        { $image "resource:extra/otug-talk/2bi_at.tiff" }
     }
     { $slide "Shuffle words"
         "When data flow combinators are not enough"

extra/slides/slides.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays hashtables help.markup help.stylesheet io
 io.styles kernel math models namespaces sequences ui ui.gadgets
-ui.gadgets.books ui.gadgets.panes ui.gestures ui.pens.gradient ui.render
+ui.gadgets.books ui.gadgets.panes ui.gestures ui.pens.gradient
 parser accessors colors ;
 IN: slides
 
@@ -98,6 +98,7 @@ TUPLE: slides < book ;
     parse-definition strip-tease [ parsed ] each ; parsing
 
 \ slides H{
+    { T{ button-down } [ request-focus ] }
     { T{ key-down f f "DOWN" } [ next-page ] }
     { T{ key-down f f "UP" } [ prev-page ] }
 } set-gestures

extra/tetris/gl/gl.factor

@@ -35,7 +35,7 @@ IN: tetris.gl
 : scale-board ( width height board -- )
     [ width>> ] [ height>> ] bi swapd [ / ] dup 2bi* 1 glScalef ;
 
-: (draw-tetris) ( width height tetris -- )
+: draw-tetris ( width height tetris -- )
     #! width and height are in pixels
     GL_MODELVIEW [
         {
@@ -44,7 +44,4 @@ IN: tetris.gl
             [ next-piece draw-next-piece ]
             [ current-piece draw-piece ]
         } cleave
-    ] do-matrix ;
+    ] do-matrix ;
-
-: draw-tetris ( width height tetris -- )
-    origin get [ (draw-tetris) ] with-translation ;