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

core/arrays/arrays.factor

@@ -1,11 +1,11 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private math math.private sequences
+USING: accessors kernel kernel.private math math.private
-sequences.private ;
+sequences sequences.private ;
 IN: arrays
 
 M: array clone (clone) ;
-M: array length array-capacity ;
+M: array length length>> ;
 M: array nth-unsafe >r >fixnum r> array-nth ;
 M: array set-nth-unsafe >r >fixnum r> set-array-nth ;
 M: array resize resize-array ;

core/assocs/assocs.factor

@@ -84,7 +84,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     ] [
         3dup nth-unsafe at*
         [ >r 3drop r> ] [ drop >r 1- r> (assoc-stack) ] if
-    ] if ; inline
+    ] if ; inline recursive
 
 : assoc-stack ( key seq -- value )
     dup length 1- swap (assoc-stack) ;
@@ -158,6 +158,9 @@ M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
 : zip ( keys values -- alist )
     2array flip ; inline
 
+: unzip ( assoc -- keys values )
+    dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
+
 : search-alist ( key alist -- pair i )
     [ first = ] with find swap ; inline
 

core/binary-search/binary-search-docs.factor

@@ -0,0 +1,43 @@
+IN: binary-search
+USING: help.markup help.syntax sequences kernel math.order ;
+
+ARTICLE: "binary-search" "Binary search"
+"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
+{ $subsection search }
+"Variants of sequence words optimized for sorted sequences:"
+{ $subsection sorted-index }
+{ $subsection sorted-member? }
+{ $subsection sorted-memq? }
+{ $see-also "order-specifiers" "sequences-sorting" } ;
+
+ABOUT: "binary-search"
+
+HELP: search
+{ $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
+{ $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")."
+$nl
+"If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "."
+$nl
+"If the sequence is empty, outputs " { $link f } " " { $link f } "." }
+{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link find } "." } ;
+
+{ find find-from find-last find-last find-last-from search } related-words
+
+HELP: sorted-index
+{ $values { "elt" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
+{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
+{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ;
+
+{ index index-from last-index last-index-from sorted-index } related-words
+
+HELP: sorted-member?
+{ $values { "elt" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
+{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link = } "." } ;
+
+{ member? sorted-member? } related-words
+
+HELP: sorted-memq?
+{ $values { "elt" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
+{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;
+
+{ memq? sorted-memq? } related-words

core/binary-search/binary-search-tests.factor

@@ -0,0 +1,17 @@
+IN: binary-search.tests
+USING: binary-search math.order vectors kernel tools.test ;
+
+\ sorted-member? must-infer
+
+[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
+[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
+[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test
+[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test
+[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
+[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
+[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
+
+[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
+[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
+[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test

core/binary-search/binary-search.factor

@@ -0,0 +1,46 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences sequences.private accessors math
+math.order combinators ;
+IN: binary-search
+
+<PRIVATE
+
+: midpoint ( seq -- elt )
+    [ midpoint@ ] keep nth-unsafe ; inline
+
+: decide ( quot seq -- quot seq <=> )
+    [ midpoint swap call ] 2keep rot ; inline
+
+: finish ( quot slice -- i elt )
+    [ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
+    [ drop ] [ dup ] [ ] tri* nth ; inline
+
+: (search) ( quot: ( elt -- <=> ) seq -- i elt )
+    dup length 1 <= [
+        finish
+    ] [
+        decide {
+            { +eq+ [ finish ] }
+            { +lt+ [ dup midpoint@ head-slice (search) ] }
+            { +gt+ [ dup midpoint@ tail-slice (search) ] }
+        } case
+    ] if ; inline recursive
+
+PRIVATE>
+
+: search ( seq quot -- i elt )
+    over empty? [ 2drop f f ] [ swap <flat-slice> (search) ] if ;
+    inline
+
+: natural-search ( obj seq -- i elt )
+    [ <=> ] with search ;
+
+: sorted-index ( obj seq -- i )
+    natural-search drop ;
+
+: sorted-member? ( obj seq -- ? )
+    dupd natural-search nip = ;
+
+: sorted-memq? ( obj seq -- ? )
+    dupd natural-search nip eq? ;

core/bootstrap/compiler/compiler.factor

@@ -37,7 +37,7 @@ nl
     array? hashtable? vector?
     tuple? sbuf? node? tombstone?
 
-    array-capacity array-nth set-array-nth
+    array-nth set-array-nth
 
     wrap probe
 

core/bootstrap/primitives.factor

@@ -6,7 +6,8 @@ sequences strings vectors words quotations assocs layouts
 classes classes.builtin classes.tuple classes.tuple.private
 kernel.private vocabs vocabs.loader source-files definitions
 slots classes.union classes.intersection classes.predicate
-compiler.units bootstrap.image.private io.files accessors combinators ;
+compiler.units bootstrap.image.private io.files accessors
+combinators ;
 IN: bootstrap.primitives
 
 "Creating primitives and basic runtime structures..." print flush
@@ -225,7 +226,9 @@ bi
     { "imaginary" { "real" "math" } read-only }
 } define-builtin
 
-"array" "arrays" create { } define-builtin
+"array" "arrays" create {
+    { "length" { "array-capacity" "sequences.private" } read-only }
+} define-builtin
 
 "wrapper" "kernel" create {
     { "wrapped" read-only }
@@ -261,7 +264,9 @@ bi
     { "sub-primitive" read-only }
 } define-builtin
 
-"byte-array" "byte-arrays" create { } define-builtin
+"byte-array" "byte-arrays" create {
+    { "length" { "array-capacity" "sequences.private" } read-only }
+} define-builtin
 
 "callstack" "kernel" create { } define-builtin
 
@@ -306,9 +311,12 @@ tuple
 } prepare-slots define-tuple-class
 
 "curry" "kernel" lookup
-[ f "inline" set-word-prop ]
+{
-[ ]
+    [ f "inline" set-word-prop ]
-[ tuple-layout [ <tuple-boa> ] curry ] tri
+    [ make-flushable ]
+    [ ]
+    [ tuple-layout [ <tuple-boa> ] curry ]
+} cleave
 (( obj quot -- curry )) define-declared
 
 "compose" "kernel" create
@@ -319,9 +327,12 @@ tuple
 } prepare-slots define-tuple-class
 
 "compose" "kernel" lookup
-[ f "inline" set-word-prop ]
+{
-[ ]
+    [ f "inline" set-word-prop ]
-[ tuple-layout [ <tuple-boa> ] curry ] tri
+    [ make-flushable ]
+    [ ]
+    [ tuple-layout [ <tuple-boa> ] curry ]
+} cleave
 (( quot1 quot2 -- compose )) define-declared
 
 ! Sub-primitive words

core/bootstrap/stage1.factor

@@ -32,7 +32,6 @@ load-help? off
     "libc" require
 
     "io.streams.c" require
-    "io.thread" require
     "vocabs.loader" require
     
     "syntax" require

core/bootstrap/stage2.factor

@@ -56,6 +56,8 @@ parse-command-line
 
 "-no-crossref" cli-args member? [ do-crossref ] unless
 
+"io.thread" require
+
 ! Set dll paths
 os wince? [ "windows.ce" require ] when
 os winnt? [ "windows.nt" require ] when

core/bootstrap/syntax.factor

@@ -59,6 +59,7 @@ IN: bootstrap.syntax
     "flushable"
     "foldable"
     "inline"
+    "recursive"
     "parsing"
     "t"
     "{"

core/byte-arrays/byte-arrays.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private alien.accessors sequences
+USING: accessors kernel kernel.private alien.accessors sequences
 sequences.private math ;
 IN: byte-arrays
 
 M: byte-array clone (clone) ;
-M: byte-array length array-capacity ;
+M: byte-array length length>> ;
 M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
 M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
 : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline

core/classes/tuple/tuple.factor

@@ -91,7 +91,7 @@ ERROR: bad-superclass class ;
     #! 4 slot == superclasses>>
     rot dup tuple? [
         layout-of 4 slot
-        2dup array-capacity fixnum<
+        2dup 1 slot fixnum<
         [ array-nth eq? ] [ 3drop f ] if
     ] [ 3drop f ] if ; inline
 

core/combinators/combinators.factor

@@ -90,10 +90,10 @@ ERROR: no-case ;
 : <buckets> ( initial length -- array )
     next-power-of-2 swap [ nip clone ] curry map ;
 
-: distribute-buckets ( assoc initial quot -- buckets )
+: distribute-buckets ( alist initial quot -- buckets )
-    spin [ length <buckets> ] keep
+    swapd [ >r dup first r> call 2array ] curry map
-    [ >r 2dup r> dup first roll call (distribute-buckets) ] each
+    [ length <buckets> dup ] keep
-    nip ; inline
+    [ first2 (distribute-buckets) ] with each ; inline
 
 : hash-case-table ( default assoc -- array )
     V{ } [ 1array ] distribute-buckets

core/compiler/tests/stack-trace.factor

@@ -30,10 +30,3 @@ words splitting grouping sorting ;
     \ + stack-trace-contains?
     \ > stack-trace-contains?
 ] unit-test
-
-: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ;
-
-[ t ] [
-    [ 10 quux ] ignore-errors
-    \ sort stack-trace-contains?
-] unit-test

core/dequeues/dequeues.factor

@@ -37,8 +37,7 @@ GENERIC: node-value ( node -- value )
     [ peek-back ] [ pop-back* ] bi ;
 
 : slurp-dequeue ( dequeue quot -- )
-    over dequeue-empty? [ 2drop ] [
+    [ drop [ dequeue-empty? not ] curry ]
-        [ [ pop-back ] dip call ] [ slurp-dequeue ] 2bi
+    [ [ pop-back ] prepose curry ] 2bi [ ] while ; inline
-    ] if ; inline
 
 MIXIN: dequeue

core/dlists/dlists.factor

@@ -48,11 +48,11 @@ M: dlist-node node-value obj>> ;
 : set-front-to-back ( dlist -- )
     dup front>> [ dup back>> >>front ] unless drop ;
 
-: (dlist-find-node) ( dlist-node quot -- node/f ? )
+: (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
     over [
         [ call ] 2keep rot
         [ drop t ] [ >r next>> r> (dlist-find-node) ] if
-    ] [ 2drop f f ] if ; inline
+    ] [ 2drop f f ] if ; inline recursive
 
 : dlist-find-node ( dlist quot -- node/f ? )
     >r front>> r> (dlist-find-node) ; inline

core/effects/effects.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math namespaces sequences strings words assocs
-combinators accessors ;
+combinators accessors arrays ;
 IN: effects
 
 TUPLE: effect in out terminated? ;
@@ -22,15 +22,16 @@ TUPLE: effect in out terminated? ;
         [ t ]
     } cond 2nip ;
 
-GENERIC: (stack-picture) ( obj -- str )
+GENERIC: effect>string ( obj -- str )
-M: string (stack-picture) ;
+M: string effect>string ;
-M: word (stack-picture) name>> ;
+M: word effect>string name>> ;
-M: integer (stack-picture) drop "object" ;
+M: integer effect>string drop "object" ;
+M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ;
 
 : stack-picture ( seq -- string )
-    [ [ (stack-picture) % CHAR: \s , ] each ] "" make ;
+    [ [ effect>string % CHAR: \s , ] each ] "" make ;
 
-: effect>string ( effect -- string )
+M: effect effect>string ( effect -- string )
     [
         "( " %
         [ in>> stack-picture % "-- " % ]
@@ -51,6 +52,9 @@ M: word stack-effect
 M: effect clone
     [ in>> clone ] [ out>> clone ] bi <effect> ;
 
+: stack-height ( word -- n )
+    stack-effect effect-height ;
+
 : split-shuffle ( stack shuffle -- stack1 stack2 )
     in>> length cut* ;
 

core/effects/parser/parser.factor

@@ -1,15 +1,31 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: lexer sets sequences kernel splitting effects ;
+USING: lexer sets sequences kernel splitting effects summary
+combinators debugger arrays parser ;
 IN: effects.parser
 
-: parse-effect ( end -- effect )
+DEFER: parse-effect
-    parse-tokens dup { "(" "((" } intersect empty? [
+
-        { "--" } split1 dup [
+ERROR: bad-effect ;
-            <effect>
+
-        ] [
+M: bad-effect summary
-            "Stack effect declaration must contain --" throw
+    drop "Bad stack effect declaration" ;
+
+: parse-effect-token ( end -- token/f )
+    scan tuck = [ drop f ] [
+        dup { f "(" "((" } member? [ bad-effect ] [
+            ":" ?tail [
+                scan-word {
+                    { \ ( [ ")" parse-effect ] }
+                    [ ]
+                } case 2array
+            ] when
         ] if
-    ] [
-        "Stack effect declaration must not contain ( or ((" throw
     ] if ;
+
+: parse-effect-tokens ( end -- tokens )
+    [ parse-effect-token dup ] curry [ ] [ drop ] produce ;
+
+: parse-effect ( end -- effect )
+    parse-effect-tokens { "--" } split1 dup
+    [ <effect> ] [ "Stack effect declaration must contain --" throw ] if ;

core/generic/generic.factor

@@ -77,6 +77,9 @@ TUPLE: check-method class generic ;
 PREDICATE: method-body < word
     "method-generic" word-prop >boolean ;
 
+M: method-body inline?
+    "method-generic" word-prop inline? ;
+
 M: method-body stack-effect
     "method-generic" word-prop stack-effect ;
 

core/generic/standard/engines/tuple/tuple.factor

@@ -64,6 +64,9 @@ M: engine-word stack-effect
     [ extra-values ] [ stack-effect ] bi
     dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
 
+M: engine-word inline?
+    "tuple-dispatch-generic" word-prop inline? ;
+
 M: engine-word crossref? "forgotten" word-prop not ;
 
 M: engine-word irrelevant? drop t ;

core/graphs/graphs.factor

@@ -37,14 +37,14 @@ SYMBOL: graph
 
 SYMBOL: previous
 
-: (closure) ( obj quot -- )
+: (closure) ( obj quot: ( elt -- assoc ) -- )
     over previous get key? [
         2drop
     ] [
         over previous get conjoin
         dup slip
         [ nip (closure) ] curry assoc-each
-    ] if ; inline
+    ] if ; inline recursive
 
 : closure ( obj quot -- assoc )
     H{ } clone [

core/hashtables/hashtables.factor

@@ -12,7 +12,7 @@ TUPLE: hashtable
 <PRIVATE
 
 : wrap ( i array -- n )
-    array-capacity 1 fixnum-fast fixnum-bitand ; inline
+    length>> 1 fixnum-fast fixnum-bitand ; inline
 
 : hash@ ( key array -- i )
     >r hashcode >fixnum dup fixnum+fast r> wrap ; inline
@@ -27,10 +27,10 @@ TUPLE: hashtable
     dup ((empty)) eq?
     [ 3drop no-key ] [
         = [ rot drop t ] [ probe (key@) ] if
-    ] if ; inline
+    ] if ; inline recursive
 
 : key@ ( key hash -- array n ? )
-    array>> dup array-capacity 0 eq?
+    array>> dup length>> 0 eq?
     [ no-key ] [ 2dup hash@ (key@) ] if ; inline
 
 : <hash-array> ( n -- array )
@@ -51,7 +51,7 @@ TUPLE: hashtable
         ] [
             probe (new-key@)
         ] if
-    ] if ; inline
+    ] if ; inline recursive
 
 : new-key@ ( key hash -- array n empty? )
     array>> 2dup hash@ (new-key@) ; inline
@@ -71,7 +71,7 @@ TUPLE: hashtable
 
 : hash-large? ( hash -- ? )
     [ count>> 3 fixnum*fast 1 fixnum+fast ]
-    [ array>> array-capacity ] bi fixnum> ; inline
+    [ array>> length>> ] bi fixnum> ; inline
 
 : hash-stale? ( hash -- ? )
     [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline

core/inference/backend/backend.factor

@@ -365,7 +365,8 @@ TUPLE: unbalanced-branches-error quots in out ;
     [ unify-effects ] [ unify-dataflow ] bi ; inline
 
 : infer-branches ( last branches node -- )
-    #! last is a quotation which provides a #return or a #values
+    #! last -> #return or #values
+    #! node -> #if or #dispatch
     1 reify-curries
     call dup node,
     pop-d drop

core/inference/class/class-tests.factor

@@ -620,6 +620,8 @@ TUPLE: declared-fixnum { x fixnum } ;
     [ { ascii } declare decode-char ] \ decode-char inlined?
 ] unit-test
 
+[ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
+
 ! Later
 
 ! [ t ] [

core/inference/dataflow/dataflow.factor

@@ -144,7 +144,8 @@ TUPLE: #dispatch < #branch ;
 
 : #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ;
 
-TUPLE: #merge < node ;
+! Phi node: merging is a sequence of sequences of values
+TUPLE: #merge < node merging ;
 
 : #merge ( -- node ) \ #merge all-out-node ;
 
@@ -191,7 +192,7 @@ TUPLE: #declare < node ;
 : #drop ( n -- #shuffle )
     d-tail flatten-curries \ #shuffle in-node ;
 
-: node-exists? ( node quot -- ? )
+: node-exists? ( node quot: ( node -- ? ) -- ? )
     over [
         2dup 2slip rot [
             2drop t
@@ -201,7 +202,7 @@ TUPLE: #declare < node ;
         ] if
     ] [
         2drop f
-    ] if ; inline
+    ] if ; inline recursive
 
 GENERIC: calls-label* ( label node -- ? )
 
@@ -223,21 +224,21 @@ SYMBOL: node-stack
 
 : iterate-next ( -- node ) node@ successor>> ;
 
-: iterate-nodes ( node quot -- )
+: iterate-nodes ( node quot: ( -- ) -- )
     over [
         [ swap >node call node> drop ] keep iterate-nodes
     ] [
         2drop
-    ] if ; inline
+    ] if ; inline recursive
 
-: (each-node) ( quot -- next )
+: (each-node) ( quot: ( node -- ) -- next )
     node@ [ swap call ] 2keep
     node-children [
         [
             [ (each-node) ] keep swap
         ] iterate-nodes
     ] each drop
-    iterate-next ; inline
+    iterate-next ; inline recursive
 
 : with-node-iterator ( quot -- )
     >r V{ } clone node-stack r> with-variable ; inline
@@ -260,14 +261,14 @@ SYMBOL: node-stack
         2drop
     ] if ; inline
 
-: (transform-nodes) ( prev node quot -- )
+: (transform-nodes) ( prev node quot: ( node -- newnode ) -- )
     dup >r call dup [
         >>successor
         successor>> dup successor>>
         r> (transform-nodes)
     ] [
         r> 2drop f >>successor drop
-    ] if ; inline
+    ] if ; inline recursive
 
 : transform-nodes ( node quot -- new-node )
     over [

core/inference/transforms/transforms-tests.factor

@@ -10,16 +10,6 @@ classes classes.tuple ;
 
 [ 6 ] [ 1 2 3 compose-n-test ] unit-test
 
-[ 0 ] [ { } bitfield-quot call ] unit-test
-
-[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test
-
-[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test
-
-[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
-
-[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
-
 TUPLE: color r g b ;
 
 C: <color> color

core/inference/transforms/transforms.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel words sequences generic math
-namespaces quotations assocs combinators math.bitfields
+namespaces quotations assocs combinators
 inference.backend inference.dataflow inference.state
 classes.tuple classes.tuple.private effects summary hashtables
 classes generic sets definitions generic.standard slots.private ;
@@ -48,25 +48,6 @@ IN: inference.transforms
 
 \ spread [ spread>quot ] 1 define-transform
 
-! Bitfields
-GENERIC: (bitfield-quot) ( spec -- quot )
-
-M: integer (bitfield-quot) ( spec -- quot )
-    [ swapd shift bitor ] curry ;
-
-M: pair (bitfield-quot) ( spec -- quot )
-    first2 over word? [ >r swapd execute r> ] [ ] ?
-    [ shift bitor ] append 2curry ;
-
-: bitfield-quot ( spec -- quot )
-    [ (bitfield-quot) ] map [ 0 ] prefix concat ;
-
-\ bitfield [ bitfield-quot ] 1 define-transform
-
-\ flags [
-    [ 0 , [ , \ bitor , ] each ] [ ] make
-] 1 define-transform
-
 ! Tuple operations
 : [get-slots] ( slots -- quot )
     [ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ;

core/io/encodings/encodings.factor

@@ -93,11 +93,10 @@ M: decoder stream-read-partial stream-read ;
         { CHAR: \n [ line-ends\n ] }
     } case ; inline
 
-: ((read-until)) ( buf quot -- string/f sep/f )
+: ((read-until)) ( buf quot: ( -- char stop? ) -- string/f sep/f )
-    ! quot: -- char stop?
     dup call
     [ >r drop "" like r> ]
-    [ pick push ((read-until)) ] if ; inline
+    [ pick push ((read-until)) ] if ; inline recursive
 
 : (read-until) ( quot -- string/f sep/f )
     100 <sbuf> swap ((read-until)) ; inline

core/kernel/kernel.factor

@@ -109,10 +109,13 @@ DEFER: if
 : 2bi@ ( w x y z quot -- )
     dup 2bi* ; inline
 
-: while ( pred body tail -- )
+: loop ( pred: ( -- ? ) -- )
+    dup slip swap [ loop ] [ drop ] if ; inline recursive
+
+: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
     >r >r dup slip r> r> roll
     [ >r tuck 2slip r> while ]
-    [ 2nip call ] if ; inline
+    [ 2nip call ] if ; inline recursive
 
 ! Object protocol
 GENERIC: hashcode* ( depth obj -- code )

core/listener/listener.factor

@@ -59,9 +59,7 @@ SYMBOL: error-hook
     ] recover ;
 
 : until-quit ( -- )
-    quit-flag get
+    quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
-    [ quit-flag off ]
-    [ listen until-quit ] if ; inline
 
 : listener ( -- )
     [ until-quit ] with-interactive-vocabs ;

core/math/bitfields/bitfields-tests.factor

@@ -15,3 +15,13 @@ IN: math.bitfields.tests
 [ 3 ] [ foo ] unit-test
 [ 3 ] [ { a b } flags ] unit-test
 \ foo must-infer
+
+[ 0 ] [ { } bitfield-quot call ] unit-test
+
+[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test
+
+[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test
+
+[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
+
+[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test

core/math/bitfields/bitfields.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math sequences words ;
+USING: arrays kernel math sequences words
+namespaces inference.transforms ;
 IN: math.bitfields
 
 GENERIC: (bitfield) ( value accum shift -- newaccum )
@@ -16,3 +17,21 @@ M: pair (bitfield) ( value accum pair -- newaccum )
 
 : flags ( values -- n )
     0 [ dup word? [ execute ] when bitor ] reduce ;
+
+GENERIC: (bitfield-quot) ( spec -- quot )
+
+M: integer (bitfield-quot) ( spec -- quot )
+    [ swapd shift bitor ] curry ;
+
+M: pair (bitfield-quot) ( spec -- quot )
+    first2 over word? [ >r swapd execute r> ] [ ] ?
+    [ shift bitor ] append 2curry ;
+
+: bitfield-quot ( spec -- quot )
+    [ (bitfield-quot) ] map [ 0 ] prefix concat ;
+
+\ bitfield [ bitfield-quot ] 1 define-transform
+
+\ flags [
+    [ 0 , [ , \ bitor , ] each ] [ ] make
+] 1 define-transform

core/math/integers/integers.factor

@@ -40,7 +40,7 @@ M: fixnum bit? neg shift 1 bitand 0 > ;
 
 : (fixnum-log2) ( accum n -- accum )
     dup 1 number= [ drop ] [ >r 1+ r> 2/ (fixnum-log2) ] if ;
-    inline
+    inline recursive
 
 M: fixnum (log2) 0 swap (fixnum-log2) ;
 

core/math/math.factor

@@ -124,21 +124,21 @@ M: float fp-nan?
 
 PRIVATE>
 
-: (each-integer) ( i n quot -- )
+: (each-integer) ( i n quot: ( i -- ) -- )
     [ iterate-step iterate-next (each-integer) ]
-    [ 3drop ] if-iterate? ; inline
+    [ 3drop ] if-iterate? ; inline recursive
 
-: (find-integer) ( i n quot -- i )
+: (find-integer) ( i n quot: ( i -- ? ) -- i )
     [
         iterate-step roll
         [ 2drop ] [ iterate-next (find-integer) ] if
-    ] [ 3drop f ] if-iterate? ; inline
+    ] [ 3drop f ] if-iterate? ; inline recursive
 
-: (all-integers?) ( i n quot -- ? )
+: (all-integers?) ( i n quot: ( i -- ? ) -- ? )
     [
         iterate-step roll
         [ iterate-next (all-integers?) ] [ 3drop f ] if
-    ] [ 3drop t ] if-iterate? ; inline
+    ] [ 3drop t ] if-iterate? ; inline recursive
 
 : each-integer ( n quot -- )
     iterate-prep (each-integer) ; inline
@@ -152,7 +152,7 @@ PRIVATE>
 : all-integers? ( n quot -- ? )
     iterate-prep (all-integers?) ; inline
 
-: find-last-integer ( n quot -- i )
+: find-last-integer ( n quot: ( i -- ? ) -- i )
     over 0 < [
         2drop f
     ] [
@@ -161,4 +161,4 @@ PRIVATE>
         ] [
             >r 1- r> find-last-integer
         ] if
-    ] if ; inline
+    ] if ; inline recursive

core/math/parser/parser-tests.factor

@@ -77,10 +77,6 @@ unit-test
 [ "-101.0e-2" string>number number>string ]
 unit-test
 
-[ 5.0 ]
-[ "10.0/2" string>number ]
-unit-test
-
 [ f ]
 [ "1e1/2" string>number ]
 unit-test
@@ -104,3 +100,11 @@ unit-test
 [ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test
 
 [ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test
+
+[ 0.0/0.0 ] [ "0/0." string>number ] unit-test
+
+[ 1.0/0.0 ] [ "1/0." string>number ] unit-test
+
+[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test
+
+[ "-0.0" ] [ -0.0 number>string ] unit-test

core/math/parser/parser.factor

@@ -55,8 +55,9 @@ SYMBOL: negative?
     dup [ (base>) ] [ drop 0 swap ] if ;
 
 : string>ratio ( str -- a/b )
+    "-" ?head dup negative? set swap
     "/" split1 (base>) >r whole-part r>
-    3dup and and [ / + ] [ 3drop f ] if ;
+    3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
 
 : valid-digits? ( seq -- ? )
     {
@@ -66,20 +67,23 @@ SYMBOL: negative?
     } cond ;
 
 : string>integer ( str -- n/f )
+    "-" ?head swap
     string>digits dup valid-digits?
-    [ radix get digits>integer ] [ drop f ] if ;
+    [ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ;
 
 PRIVATE>
 
 : base> ( str radix -- n/f )
     [
-        "-" ?head dup negative? set >r
+        CHAR: / over member? [
-        {
+            string>ratio
-            { [ CHAR: / over member? ] [ string>ratio ] }
+        ] [
-            { [ CHAR: . over member? ] [ string>float ] }
+            CHAR: . over member? [
-            [ string>integer ]
+                string>float
-        } cond
+            ] [
-        r> [ dup [ neg ] when ] when
+                string>integer
+            ] if
+        ] if
     ] with-radix ;
 
 : string>number ( str -- n/f ) 10 base> ;

core/memory/memory.factor

@@ -5,9 +5,8 @@ USING: arrays kernel sequences vectors system hashtables
 kernel.private sbufs growable assocs namespaces quotations
 math strings combinators ;
 
-: (each-object) ( quot -- )
+: (each-object) ( quot: ( obj -- ) -- )
-    next-object dup
+    [ next-object dup ] swap [ drop ] while ; inline
-    [ swap [ call ] keep (each-object) ] [ 2drop ] if ; inline
 
 : each-object ( quot -- )
     begin-scan (each-object) end-scan ; inline

core/optimizer/control/control.factor

@@ -70,8 +70,6 @@ M: #label collect-label-info*
     [ V{ } clone node-stack get length 3array ] keep
     node-param label-info get set-at ;
 
-USE: prettyprint
-
 M: #call-label collect-label-info*
     node-param label-info get at
     node-stack get over third tail

core/optimizer/known-words/known-words.factor

@@ -143,6 +143,14 @@ IN: optimizer.known-words
     { [ dup optimize-instance? ] [ optimize-instance ] }
 } define-optimizers
 
+! This is a special-case hack
+: redundant-array-capacity-check? ( #call -- ? )
+    dup in-d>> first node-literal [ 0 = ] [ fixnum? ] bi and ;
+
+\ array-capacity? {
+    { [ dup redundant-array-capacity-check? ] [ [ drop t ] f splice-quot ] }
+} define-optimizers
+
 ! eq? on the same object is always t
 { eq? = } {
     { { @ @ } [ 2drop t ] }

core/optimizer/optimizer-tests.factor

@@ -219,7 +219,7 @@ M: number detect-number ;
 
 ! Regression
 USE: sorting
-USE: sorting.private
+USE: binary-search.private
 
 : old-binsearch ( elt quot seq -- elt quot i )
     dup length 1 <= [
@@ -227,7 +227,7 @@ USE: sorting.private
     ] [
         [ midpoint swap call ] 3keep roll dup zero?
         [ drop dup slice-from swap midpoint@ + ]
-        [ partition old-binsearch ] if
+        [ dup midpoint@ cut-slice old-binsearch ] if
     ] if ; inline
 
 [ 10 ] [

core/quotations/quotations.factor

@@ -5,11 +5,19 @@ kernel kernel.private math assocs quotations.private
 slots.private ;
 IN: quotations
 
+<PRIVATE
+
+: uncurry dup 3 slot swap 4 slot ; inline
+
+: uncompose dup 3 slot swap 4 slot ; inline
+
+PRIVATE>
+
 M: quotation call (call) ;
 
-M: curry call dup 3 slot swap 4 slot call ;
+M: curry call uncurry call ;
 
-M: compose call dup 3 slot swap 4 slot slip call ;
+M: compose call uncompose slip call ;
 
 M: wrapper equal?
     over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ;

core/sequences/sequences-docs.factor

@@ -243,6 +243,7 @@ $nl
 { $subsection "sequences-destructive" }
 { $subsection "sequences-stacks" }
 { $subsection "sequences-sorting" }
+{ $subsection "binary-search" }
 { $subsection "sets" }
 "For inner loops:"
 { $subsection "sequences-unsafe" } ;
@@ -585,8 +586,6 @@ HELP: index
 { $values { "obj" object } { "seq" sequence } { "n" "an index" } }
 { $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ;
 
-{ index index-from last-index last-index-from member? memq? } related-words
-
 HELP: index-from
 { $values { "obj" object } { "i" "a start index" } { "seq" sequence } { "n" "an index" } }
 { $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ", starting the search from the " { $snippet "i" } "th element. If no element is found, outputs " { $link f } "." } ;

core/sequences/sequences.factor

@@ -60,9 +60,6 @@ INSTANCE: immutable-sequence sequence
 
 <PRIVATE
 
-: array-capacity ( array -- n )
-    1 slot { array-capacity } declare ; inline
-
 : array-nth ( n array -- elt )
     swap 2 fixnum+fast slot ; inline
 
@@ -241,7 +238,8 @@ INSTANCE: repetition immutable-sequence
     ] 3keep ; inline
 
 : (copy) ( dst i src j n -- dst )
-    dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; inline
+    dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ;
+    inline recursive
 
 : prepare-subseq ( from to seq -- dst i src j n )
     [ >r swap - r> new-sequence dup 0 ] 3keep
@@ -653,7 +651,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
 : halves ( seq -- first second )
     dup midpoint@ cut-slice ;
 
-: binary-reduce ( seq start quot -- value )
+: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value )
     #! We can't use case here since combinators depends on
     #! sequences
     pick length dup 0 3 between? [
@@ -668,7 +666,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
         >r >r halves r> r>
         [ [ binary-reduce ] 2curry bi@ ] keep
         call
-    ] if ; inline
+    ] if ; inline recursive
 
 : cut ( seq n -- before after )
     [ head ] [ tail ] 2bi ;

core/sorting/sorting-docs.factor

@@ -2,18 +2,19 @@ USING: help.markup help.syntax kernel words math
 sequences math.order ;
 IN: sorting
 
-ARTICLE: "sequences-sorting" "Sorting and binary search"
+ARTICLE: "sequences-sorting" "Sorting sequences"
-"Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
+"The " { $vocab-link "sorting" } " vocabulary implements the merge-sort algorithm. It runs in " { $snippet "O(n log n)" } " time, and is a " { $emphasis "stable" } " sort, meaning that the order of equal elements is preserved."
+$nl
+"The algorithm only allocates two additional arrays, both the size of the input sequence, and uses iteration rather than recursion, and thus is suitable for sorting large sequences."
+$nl
+"Sorting combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
 $nl
 "Sorting a sequence with a custom comparator:"
 { $subsection sort }
 "Sorting a sequence with common comparators:"
 { $subsection natural-sort }
 { $subsection sort-keys }
-{ $subsection sort-values }
+{ $subsection sort-values } ;
-"Binary search:"
-{ $subsection binsearch }
-{ $subsection binsearch* } ;
 
 ABOUT: "sequences-sorting"
 
@@ -41,24 +42,4 @@ HELP: midpoint@
 { $values { "seq" "a sequence" } { "n" integer } }
 { $description "Outputs the index of the midpoint of " { $snippet "seq" } "." } ;
 
-HELP: midpoint
-{ $values { "seq" "a sequence" } { "elt" object } }
-{ $description "Outputs the element at the midpoint of a sequence." } ;
-
-HELP: partition
-{ $values { "seq" "a sequence" } { "n" integer } { "slice" slice } }
-{ $description "Outputs a slice of the first or second half of the sequence, respectively, depending on the integer's sign." } ;
-
-HELP: binsearch
-{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "i" "the index of the search result" } }
-{ $description "Given a sequence that is sorted with respect to the " { $snippet "quot" } " comparator, searches for an element equal to " { $snippet "elt" } ", or failing that, the greatest element smaller than " { $snippet "elt" } ". Comparison is performed with " { $snippet "quot" } "."
-$nl
-"Outputs f if the sequence is empty. If the sequence has at least one element, this word always outputs a valid index." } ;
-
-HELP: binsearch*
-{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "result" "the search result" } }
-{ $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence."
-$nl
-"Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ;
-
 { <=> compare natural-sort sort-keys sort-values } related-words

core/sorting/sorting-tests.factor

@@ -1,8 +1,8 @@
 USING: sorting sequences kernel math math.order random
-tools.test vectors ;
+tools.test vectors sets ;
 IN: sorting.tests
 
-[ [ ] ] [ [ ] natural-sort ] unit-test
+[ { } ] [ { } natural-sort ] unit-test
 
 [ { 270000000 270000001 } ]
 [ T{ slice f 270000000 270000002 270000002 } natural-sort ]
@@ -11,18 +11,16 @@ unit-test
 [ t ] [
     100 [
         drop
-        100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic?
+        100 [ 20 random [ 1000 random ] replicate ] replicate
+        dup natural-sort
+        [ set= ] [ nip [ before=? ] monotonic? ] 2bi and
     ] all?
 ] unit-test
 
 [ ] [ { 1 2 } [ 2drop 1 ] sort drop ] unit-test
 
-[ 3 ] [ { 1 2 3 4 } midpoint ] unit-test
+! Is it a stable sort?
+[ t ] [ { { 1 "a" } { 1 "b" } { 1 "c" } } dup sort-keys = ] unit-test
 
-[ f ] [ 3 { } [ <=> ] binsearch ] unit-test
+[ { { 1 "a" } { 1 "b" } { 1 "c" } { 1 "e" } { 2 "d" } } ]
-[ 0 ] [ 3 { 3 } [ <=> ] binsearch ] unit-test
+[ { { 1 "a" } { 1 "b" } { 1 "c" } { 2 "d" } { 1 "e" } } sort-keys ] unit-test
-[ 1 ] [ 2 { 1 2 3 } [ <=> ] binsearch ] unit-test
-[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] binsearch ] unit-test
-[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
-[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
-[ 10 ] [ 10 20 >vector [ <=> ] binsearch ] unit-test

core/sorting/sorting.factor

@@ -1,49 +1,141 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel math sequences vectors math.order
 sequences sequences.private math.order ;
 IN: sorting
 
-DEFER: sort
+! Optimized merge-sort:
+!
+! 1) only allocates 2 temporary arrays
+
+! 2) first phase (interchanging pairs x[i], x[i+1] where
+! x[i] > x[i+1]) is handled specially
 
 <PRIVATE
 
-: <iterator> 0 tail-slice ; inline
+TUPLE: merge
+{ seq    array }
+{ accum  vector }
+{ accum1 vector }
+{ accum2 vector }
+{ from1  array-capacity }
+{ to1    array-capacity }
+{ from2  array-capacity }
+{ to2    array-capacity } ;
 
-: this ( slice -- obj )
+: dump ( from to seq accum -- )
-    dup slice-from swap slice-seq nth-unsafe ; inline
+    #! Optimize common case where to - from = 1, 2, or 3.
-
+    >r >r 2dup swap - dup 1 =
-: next ( iterator -- )
+    [ 2drop r> nth-unsafe r> push ] [
-    dup slice-from 1+ swap set-slice-from ; inline
+        dup 2 = [
-
+            2drop dup 1+
-: smallest ( iter1 iter2 quot -- elt )
+            r> [ nth-unsafe ] curry bi@
-    >r over this over this r> call +lt+ eq?
+            r> [ push ] curry bi@
-    -rot ? [ this ] keep next ; inline
-
-: (merge) ( iter1 iter2 quot accum -- )
-    >r pick empty? [
-        drop nip r> push-all
-    ] [
-        over empty? [
-            2drop r> push-all
         ] [
-            3dup smallest r> [ push ] keep (merge)
+            dup 3 = [
+                2drop dup 1+ dup 1+
+                r> [ nth-unsafe ] curry tri@
+                r> [ push ] curry tri@
+            ] [
+                drop r> subseq r> push-all
+            ] if
         ] if
     ] if ; inline
 
-: merge ( sorted1 sorted2 quot -- result )
+: l-elt   [ from1>> ] [ seq>> ] bi nth-unsafe ; inline
-    >r [ [ <iterator> ] bi@ ] 2keep r>
+: r-elt   [ from2>> ] [ seq>> ] bi nth-unsafe ; inline
-    rot length rot length + <vector>
+: l-done? [ from1>> ] [ to1>> ] bi number= ; inline
-    [ (merge) ] [ underlying>> ] bi ; inline
+: r-done? [ from2>> ] [ to2>> ] bi number= ; inline
+: dump-l  [ [ from1>> ] [ to1>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
+: dump-r  [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
+: l-next  [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
+: r-next  [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
+: decide  [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
 
-: conquer ( first second quot -- result )
+: (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- )
-    [ tuck >r >r sort r> r> sort ] keep merge ; inline
+    over r-done? [ drop dump-l ] [
+        over l-done? [ drop dump-r ] [
+            2dup decide
+            [ over r-next ] [ over l-next ] if
+            (merge)
+        ] if
+    ] if ; inline recursive
+
+: flip-accum ( merge -- )
+    dup [ accum>> ] [ accum1>> ] bi eq? [
+        dup accum1>> underlying>> >>seq
+        dup accum2>> >>accum
+    ] [
+        dup accum1>> >>accum
+        dup accum2>> underlying>> >>seq
+    ] if
+    dup accum>> 0 >>length 2drop ; inline
+
+: <merge> ( seq -- merge )
+    \ merge new
+        over >vector >>accum1
+        swap length <vector> >>accum2
+        dup accum1>> underlying>> >>seq
+        dup accum2>> >>accum
+        dup accum>> 0 >>length drop ; inline
+
+: compute-midpoint ( merge -- merge )
+    dup [ from1>> ] [ to2>> ] bi + 2/ >>to1 ; inline
+
+: merging ( from to merge -- )
+    swap >>to2
+    swap >>from1
+    compute-midpoint
+    dup [ to1>> ] [ seq>> length ] bi min >>to1
+    dup [ to2>> ] [ seq>> length ] bi min >>to2
+    dup to1>> >>from2
+    drop ; inline
+
+: nth-chunk ( n size -- from to ) [ * dup ] keep + ; inline
+
+: chunks ( length size -- n ) [ align ] keep /i ; inline
+
+: each-chunk ( length size quot -- )
+    [ [ chunks ] keep ] dip
+    [ nth-chunk ] prepose curry
+    each-integer ; inline
+
+: merge ( from to merge quot -- )
+    [ [ merging ] keep ] dip (merge) ; inline
+
+: sort-pass ( merge size quot -- )
+    [
+        over flip-accum
+        over [ seq>> length ] 2dip
+    ] dip
+    [ merge ] 2curry each-chunk ; inline
+
+: sort-loop ( merge quot -- )
+    [ 2 [ over seq>> length over > ] ] dip
+    [ [ 1 shift 2dup ] dip sort-pass ] curry
+    [ ] while 2drop ; inline
+
+: each-pair ( seq quot -- )
+    [ [ length 1+ 2/ ] keep ] dip
+    [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline
+
+: (sort-pairs) ( i1 i2 seq quot accum -- )
+    >r >r 2dup length = [
+        nip nth r> drop r> push
+    ] [
+        tuck [ nth-unsafe ] 2bi@ 2dup r> call +gt+ eq?
+        [ swap ] when r> tuck [ push ] 2bi@
+    ] if ; inline
+
+: sort-pairs ( merge quot -- )
+    [ [ seq>> ] [ accum>> ] bi ] dip swap
+    [ (sort-pairs) ] 2curry each-pair ; inline
 
 PRIVATE>
 
-: sort ( seq quot -- sortedseq )
+: sort ( seq quot -- seq' )
-    over length 1 <=
+    [ <merge> ] dip
-    [ drop ] [ over >r >r halves r> conquer r> like ] if ;
+    [ sort-pairs ] [ sort-loop ] [ drop accum>> underlying>> ] 2tri ;
     inline
 
 : natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
@@ -53,25 +145,3 @@ PRIVATE>
 : sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
 
 : sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;
-
-: midpoint ( seq -- elt )
-    [ midpoint@ ] keep nth-unsafe ; inline
-
-: partition ( seq n -- slice )
-    +gt+ eq? not swap halves ? ; inline
-
-: (binsearch) ( elt quot seq -- i )
-    dup length 1 <= [
-        slice-from 2nip
-    ] [
-        [ midpoint swap call ] 3keep roll dup +eq+ eq?
-        [ drop dup slice-from swap midpoint@ + 2nip ]
-        [ partition (binsearch) ] if
-    ] if ; inline
-
-: binsearch ( elt seq quot -- i )
-    swap dup empty?
-    [ 3drop f ] [ <flat-slice> (binsearch) ] if ; inline
-
-: binsearch* ( elt seq quot -- result )
-    over >r binsearch [ r> ?nth ] [ r> drop f ] if* ; inline

core/splitting/splitting.factor

@@ -30,7 +30,7 @@ IN: splitting
 : (split) ( separators n seq -- )
     3dup rot [ member? ] curry find-from drop
     [ [ swap subseq , ] 2keep 1+ swap (split) ]
-    [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline
+    [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive
 
 : split, ( seq separators -- ) 0 rot (split) ;
 

core/syntax/syntax.factor

@@ -89,6 +89,7 @@ IN: bootstrap.syntax
     "POSTPONE:" [ scan-word parsed ] define-syntax
     "\\" [ scan-word literalize parsed ] define-syntax
     "inline" [ word make-inline ] define-syntax
+    "recursive" [ word make-recursive ] define-syntax
     "foldable" [ word make-foldable ] define-syntax
     "flushable" [ word make-flushable ] define-syntax
     "delimiter" [ word t "delimiter" set-word-prop ] define-syntax

core/threads/threads.factor

@@ -195,7 +195,7 @@ M: real sleep
     <thread> [ (spawn) ] keep ;
 
 : spawn-server ( quot name -- thread )
-    >r [ [ ] [ ] while ] curry r> spawn ;
+    >r [ loop ] curry r> spawn ;
 
 : in-thread ( quot -- )
     >r datastack r>

core/words/words.factor

@@ -164,6 +164,9 @@ M: object redefined drop ;
 : make-inline ( word -- )
     t "inline" set-word-prop ;
 
+: make-recursive ( word -- )
+    t "recursive" set-word-prop ;
+
 : make-flushable ( word -- )
     t "flushable" set-word-prop ;
 
@@ -181,7 +184,7 @@ GENERIC: reset-word ( word -- )
 M: word reset-word
     {
         "unannotated-def"
-        "parsing" "inline" "foldable" "flushable"
+        "parsing" "inline" "recursive" "foldable" "flushable"
         "predicating"
         "reading" "writing"
         "constructing"
@@ -222,6 +225,10 @@ ERROR: bad-create name vocab ;
 : constructor-word ( name vocab -- word )
     >r "<" swap ">" 3append r> create ;
 
+GENERIC: inline? ( word -- ? )
+
+M: word inline? "inline" word-prop ;
+
 PREDICATE: parsing-word < word "parsing" word-prop ;
 
 : delimiter? ( obj -- ? )

extra/automata/ui/ui.factor

@@ -6,7 +6,6 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
        ui
        ui.gestures
        ui.gadgets
-       ui.gadgets.handler
        ui.gadgets.slate
        ui.gadgets.labels
        ui.gadgets.buttons
@@ -14,8 +13,8 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
        ui.gadgets.packs
        ui.gadgets.grids
        ui.gadgets.theme
+       ui.gadgets.handler
        accessors
-       qualified
        namespaces.lib assocs.lib vars
        rewrite-closures automata math.geometry.rect newfx ;
 
@@ -23,13 +22,6 @@ IN: automata.ui
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-QUALIFIED: ui.gadgets.grids
-
-: grid-add ( grid child i j -- grid )
-  >r >r dupd swap r> r> ui.gadgets.grids:grid-add ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
 
 : draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ;
@@ -80,13 +72,15 @@ DEFER: automata-window
       "5 - Random Rule" [ random-rule     ] view-button add-gadget
       "n - New"         [ automata-window ] view-button add-gadget
 
-    @top grid-add
+    @top grid-add*
 
     C[ display ] <slate>
-      { 400 400 } >>dim
+      { 400 400 } >>pdim
     dup >slate
 
-    @center grid-add
+    @center grid-add*
+
+  <handler>
 
   H{ }
     T{ key-down f f "1" } [ start-center    ] view-action is
@@ -95,9 +89,7 @@ DEFER: automata-window
     T{ key-down f f "5" } [ random-rule     ] view-action is
     T{ key-down f f "n" } [ automata-window ] view-action is
 
-  <handler>
+  >>table
-
-    tuck set-gadget-delegate
 
   "Automata" open-window ;
 

extra/backtrack/backtrack.factor

@@ -1,20 +1,68 @@
 ! Copyright (C) 2008 William Schlieper
 ! See http://factorcode.org/license.txt for BSD license.
 
-USING: kernel continuations sequences namespaces fry ;
+USING: kernel continuations combinators sequences quotations arrays namespaces
+       fry summary assocs math math.order macros ;
 
 IN: backtrack
 
 SYMBOL: failure
 
-: amb ( seq -- elt )
+ERROR: amb-failure ;
-    failure get
+
-    '[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each
+M: amb-failure summary drop "Backtracking failure" ;
-       , continue ] callcc1 ;
 
 : fail ( -- )
-    f amb drop ;
+    failure get [ continue ]
+    [ amb-failure ] if* ;
 
 : require ( ? -- )
     [ fail ] unless ;
 
+MACRO: checkpoint ( quot -- quot' )
+    '[ failure get ,
+       '[ '[ failure set , continue ] callcc0
+          , failure set @ ] callcc0 ] ;
+
+: number-from ( from -- from+n )
+    [ 1 + number-from ] checkpoint ;
+
+<PRIVATE
+
+: unsafe-number-from-to ( to from -- to from+n )
+    2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;
+
+: number-from-to ( to from -- to from+n )
+    2dup < [ fail ] when unsafe-number-from-to ;
+
+: amb-integer ( seq -- int )
+    length 1 - 0 number-from-to nip ;
+
+MACRO: unsafe-amb ( seq -- quot )
+    dup length 1 =
+    [ first 1quotation ]
+    [ [ first ] [ rest ] bi
+      '[ , [ drop , unsafe-amb ] checkpoint ] ] if ;
+
+PRIVATE> 
+
+: amb-lazy ( seq -- elt )
+    [ amb-integer ] [ nth ] bi ;
+
+: amb ( seq -- elt )
+    dup empty?
+    [ drop fail f ]
+    [ unsafe-amb ] if ; inline
+
+MACRO: amb-execute ( seq -- quot )
+    [ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi
+    '[ , 0 unsafe-number-from-to nip , case ] ;
+
+: if-amb ( true false -- )
+    [
+        [ { t f } amb ]
+        [ '[ @ require t ] ]
+        [ '[ @ f ] ]
+        tri* if
+    ] with-scope ; inline
+

extra/benchmark/backtrack/backtrack.factor

@@ -0,0 +1,55 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: backtrack shuffle math math.ranges quotations locals fry
+kernel words io memoize macros io prettyprint sequences assocs
+combinators namespaces ;
+IN: benchmark.backtrack
+
+! This was suggested by Dr_Ford. Compute the number of quadruples
+! (a,b,c,d) with 1 <= a,b,c,d <= 10 such that we can make 24 by
+! placing them on the stack, and applying the operations
+! +, -, * and rot as many times as we wish.
+
+: nop ;
+
+: do-something ( a b -- c )
+    { + - * } amb-execute ;
+
+: some-rots ( a b c -- a b c )
+    #! Try to rot 0, 1 or 2 times.
+    { nop rot -rot } amb-execute ;
+
+MEMO: 24-from-1 ( a -- ? )
+    24 = ;
+
+MEMO: 24-from-2 ( a b -- ? )
+    [ do-something 24-from-1 ] [ 2drop ] if-amb ;
+
+MEMO: 24-from-3 ( a b c -- ? )
+    [ some-rots do-something 24-from-2 ] [ 3drop ] if-amb ;
+
+MEMO: 24-from-4 ( a b c d -- ? )
+    [ some-rots do-something 24-from-3 ] [ 4drop ] if-amb ;
+
+: find-impossible-24 ( -- n )
+    1 10 [a,b] [| a |
+        1 10 [a,b] [| b |
+            1 10 [a,b] [| c |
+                1 10 [a,b] [| d |
+                    a b c d 24-from-4
+                ] count
+            ] sigma
+        ] sigma
+    ] sigma ;
+
+: words { 24-from-1 24-from-2 24-from-3 24-from-4 } ;
+
+: backtrack-benchmark ( -- )
+    words [ reset-memoized ] each
+    find-impossible-24 pprint "/10000 quadruples can make 24." print
+    words [
+        dup pprint " tested " write "memoize" word-prop assoc-size pprint
+        " possibilities" print
+    ] each ;
+
+MAIN: backtrack-benchmark

extra/boids/ui/ui.factor

@@ -102,7 +102,7 @@ VARS: population-label cohesion-label alignment-label separation-label ;
 
   C[ display ] <slate> >slate
     t                      slate> set-gadget-clipped?
-    { 600 400 }            slate> set-slate-dim
+    { 600 400 }            slate> set-slate-pdim
     C[ [ run ] in-thread ] slate> set-slate-graft
     C[ loop off ]          slate> set-slate-ungraft
 
@@ -143,9 +143,11 @@ VARS: population-label cohesion-label alignment-label separation-label ;
 
   } [ call ] map [ add-gadget ] each
     1 over set-pack-fill
-    over @top grid-add
+    @top grid-add*
 
-  slate> over @center grid-add
+  slate> @center grid-add*
+
+  <handler> 
 
   H{ } clone
     T{ key-down f f "1" } C[ drop randomize    ] is
@@ -162,7 +164,10 @@ VARS: population-label cohesion-label alignment-label separation-label ;
     T{ key-down f f "d" } C[ drop dec-separation-weight ] is
 
     T{ key-down f f "ESC" } C[ drop toggle-loop ] is
-  <handler> tuck set-gadget-delegate "Boids" open-window ;
+
+  >>table
+
+  "Boids" open-window ;
 
 : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;
 

extra/cfdg/cfdg.factor

@@ -204,7 +204,7 @@ VAR: start-shape
 
 : cfdg-window* ( -- )
   [ display ] closed-quot <slate>
-  { 500 500 } over set-slate-dim
+  { 500 500 } over set-slate-pdim
   dup "CFDG" open-window ;
 
 : cfdg-window ( -- ) [ cfdg-window* ] with-ui ;

extra/channels/channels-tests.factor

@@ -17,7 +17,7 @@ IN: channels.tests
     from 
 ] unit-test
 
-{ V{ 1 2 3 4 } } [
+{ { 1 2 3 4 } } [
     V{ } clone <channel>
     [ from swap push ] in-thread
     [ from swap push ] in-thread
@@ -30,7 +30,7 @@ IN: channels.tests
     natural-sort
 ] unit-test
 
-{ V{ 1 2 4 9 } } [
+{ { 1 2 4 9 } } [
     V{ } clone <channel>
     [ 4 swap to ] in-thread
     [ 2 swap to ] in-thread

extra/cocoa/enumeration/enumeration.factor

@@ -11,13 +11,13 @@ IN: cocoa.enumeration
         ] with-malloc
     ] with-malloc ; inline
 
-:: (NSFastEnumeration-each) ( object quot state stackbuf count -- )
+:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
     object state stackbuf count -> countByEnumeratingWithState:objects:count:
     dup zero? [ drop ] [
         state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
         '[ , void*-nth quot call ] each
         object quot state stackbuf count (NSFastEnumeration-each)
-    ] if ; inline
+    ] if ; inline recursive
 
 : NSFastEnumeration-each ( object quot -- )
     [ (NSFastEnumeration-each) ] (with-enumeration-buffers) ; inline

extra/concurrency/mailboxes/mailboxes.factor

@@ -23,13 +23,13 @@ M: mailbox dispose* threads>> notify-all ;
 : wait-for-mailbox ( mailbox timeout -- )
     >r threads>> r> "mailbox" wait ;
 
-: block-unless-pred ( mailbox timeout pred -- )
+: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
     pick check-disposed
     pick data>> over dlist-contains? [
         3drop
     ] [
         >r 2dup wait-for-mailbox r> block-unless-pred
-    ] if ; inline
+    ] if ; inline recursive
 
 : block-if-empty ( mailbox timeout -- mailbox )
     over check-disposed
@@ -58,11 +58,7 @@ M: mailbox dispose* threads>> notify-all ;
     f mailbox-get-all-timeout ;
 
 : while-mailbox-empty ( mailbox quot -- )
-    over mailbox-empty? [
+    [ [ mailbox-empty? ] curry ] dip [ ] while ; inline
-        dup >r dip r> while-mailbox-empty
-    ] [
-        2drop
-    ] if ; inline
 
 : mailbox-get-timeout? ( mailbox timeout pred -- obj )
     3dup block-unless-pred

extra/concurrency/messaging/messaging-tests.factor

@@ -47,7 +47,7 @@ SYMBOL: exit
     } match-cond ;
 
 [ -5 ] [
-    [ 0 [ counter ] [ ] [ ] while ] "Counter" spawn "counter" set
+    [ 0 [ counter ] loop ] "Counter" spawn "counter" set
     { increment 10 } "counter" get send
     { decrement 15 } "counter" get send
     [ value , self , ] { } make "counter" get send

extra/cords/cords.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sequences sorting math math.order
+USING: accessors assocs sequences sorting binary-search math
-arrays combinators kernel ;
+math.order arrays combinators kernel ;
 IN: cords
 
 <PRIVATE
@@ -23,7 +23,7 @@ M: multi-cord length count>> ;
 
 M: multi-cord virtual@
     dupd
-    seqs>> [ first <=> ] binsearch*
+    seqs>> [ first <=> ] with search nip
     [ first - ] [ second ] bi ;
 
 M: multi-cord virtual-seq

extra/core-foundation/core-foundation-docs.factor

@@ -1,4 +1,4 @@
-USING: alien strings arrays help.markup help.syntax ;
+USING: alien strings arrays help.markup help.syntax destructors ;
 IN: core-foundation
 
 HELP: CF>array
@@ -37,6 +37,16 @@ HELP: load-framework
 { $values { "name" "a pathname string" } }
 { $description "Loads a Core Foundation framework." } ;
 
+HELP: &CFRelease
+{ $values { "alien" "Pointer to a Core Foundation object" } }
+{ $description "Marks the given Core Foundation object for unconditional release via " { $link CFRelease } " at the end of the enclosing " { $link with-destructors } " scope." } ;
+
+HELP: |CFRelease
+{ $values { "interface" "Pointer to a Core Foundation object" } }
+{ $description "Marks the given Core Foundation object for release via " { $link CFRelease } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ;
+
+{ CFRelease |CFRelease &CFRelease } related-words
+
 ARTICLE: "core-foundation" "Core foundation utilities"
 "The " { $vocab-link "core-foundation" } " vocabulary defines bindings for some frequently-used Core Foundation functions. It also provides some utility words."
 $nl
@@ -51,7 +61,9 @@ $nl
 { $subsection <CFFileSystemURL> }
 { $subsection <CFURL> }
 "Frameworks:"
-{ $subsection load-framework } ;
+{ $subsection load-framework }
+"Memory management:"
+{ $subsection &CFRelease }
+{ $subsection |CFRelease } ;
 
-IN: core-foundation
 ABOUT: "core-foundation"

extra/core-foundation/core-foundation.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings alien.syntax kernel
-math sequences io.encodings.utf16 ;
+math sequences io.encodings.utf16 destructors accessors ;
 IN: core-foundation
 
 TYPEDEF: void* CFAllocatorRef
@@ -135,3 +135,9 @@ M: f <CFNumber>
         "Cannot load bundled named " prepend throw
     ] ?if ;
 
+TUPLE: CFRelease-destructor alien disposed ;
+M: CFRelease-destructor dispose* alien>> CFRelease ;
+: &CFRelease ( alien -- alien )
+    dup f CFRelease-destructor boa &dispose drop ; inline
+: |CFRelease ( alien -- alien )
+    dup f CFRelease-destructor boa |dispose drop ; inline

extra/disjoint-set/disjoint-set.factor

@@ -1,72 +0,0 @@
-USING: accessors arrays hints kernel locals math sequences ;
-
-IN: disjoint-set
-
-<PRIVATE
-
-TUPLE: disjoint-set parents ranks counts ;
-
-: count ( a disjoint-set -- n )
-    counts>> nth ; inline
-
-: add-count ( p a disjoint-set -- )
-    [ count [ + ] curry ] keep counts>> swap change-nth ; inline
-
-: parent ( a disjoint-set -- p )
-    parents>> nth ; inline
-
-: set-parent ( p a disjoint-set -- )
-    parents>> set-nth ; inline
-
-: link-sets ( p a disjoint-set -- )
-    [ set-parent ]
-    [ add-count ] 3bi ; inline
-
-: rank ( a disjoint-set -- r )
-    ranks>> nth ; inline
-
-: inc-rank ( a disjoint-set -- )
-    ranks>> [ 1+ ] change-nth ; inline
-
-: representative? ( a disjoint-set -- ? )
-    dupd parent = ; inline
-
-: representative ( a disjoint-set -- p )
-    2dup representative? [ drop ] [
-        [ [ parent ] keep representative dup ] 2keep set-parent
-    ] if ;
-
-: representatives ( a b disjoint-set -- r r )
-    [ representative ] curry bi@ ; inline
-
-: ranks ( a b disjoint-set -- r r )
-    [ rank ] curry bi@ ; inline
-
-:: branch ( a b neg zero pos -- )
-    a b = zero [ a b < neg pos if ] if ; inline
-
-PRIVATE>
-
-: <disjoint-set> ( n -- disjoint-set )
-    [ >array ]
-    [ 0 <array> ]
-    [ 1 <array> ] tri
-    disjoint-set boa ;
-
-: equiv-set-size ( a disjoint-set -- n )
-    [ representative ] keep count ;
-
-: equiv? ( a b disjoint-set -- ? )
-    representatives = ; inline
-
-:: equate ( a b disjoint-set -- )
-    a b disjoint-set representatives
-    2dup = [ 2drop ] [
-        2dup disjoint-set ranks
-        [ swap ] [ over disjoint-set inc-rank ] [ ] branch
-        disjoint-set link-sets
-    ] if ;
-
-HINTS: equate disjoint-set ;
-HINTS: representative disjoint-set ;
-HINTS: equiv-set-size disjoint-set ;

extra/disjoint-sets/disjoint-sets.factor

@@ -0,0 +1,88 @@
+! Copyright (C) 2008 Eric Mertens.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays hints kernel locals math hashtables
+assocs ;
+
+IN: disjoint-sets
+
+TUPLE: disjoint-set
+{ parents hashtable read-only }
+{ ranks hashtable read-only }
+{ counts hashtable read-only } ;
+
+<PRIVATE
+
+: count ( a disjoint-set -- n )
+    counts>> at ; inline
+
+: add-count ( p a disjoint-set -- )
+    [ count [ + ] curry ] keep counts>> swap change-at ; inline
+
+: parent ( a disjoint-set -- p )
+    parents>> at ; inline
+
+: set-parent ( p a disjoint-set -- )
+    parents>> set-at ; inline
+
+: link-sets ( p a disjoint-set -- )
+    [ set-parent ] [ add-count ] 3bi ; inline
+
+: rank ( a disjoint-set -- r )
+    ranks>> at ; inline
+
+: inc-rank ( a disjoint-set -- )
+    ranks>> [ 1+ ] change-at ; inline
+
+: representative? ( a disjoint-set -- ? )
+    dupd parent = ; inline
+
+PRIVATE>
+
+GENERIC: representative ( a disjoint-set -- p )
+
+M: disjoint-set representative
+    2dup representative? [ drop ] [
+        [ [ parent ] keep representative dup ] 2keep set-parent
+    ] if ;
+
+<PRIVATE
+
+: representatives ( a b disjoint-set -- r r )
+    [ representative ] curry bi@ ; inline
+
+: ranks ( a b disjoint-set -- r r )
+    [ rank ] curry bi@ ; inline
+
+:: branch ( a b neg zero pos -- )
+    a b = zero [ a b < neg pos if ] if ; inline
+
+PRIVATE>
+
+: <disjoint-set> ( -- disjoint-set )
+    H{ } clone H{ } clone H{ } clone disjoint-set boa ;
+
+GENERIC: add-atom ( a disjoint-set -- )
+
+M: disjoint-set add-atom
+    [ dupd parents>> set-at ]
+    [ 0 -rot ranks>> set-at ]
+    [ 1 -rot counts>> set-at ]
+    2tri ;
+
+GENERIC: equiv-set-size ( a disjoint-set -- n )
+
+M: disjoint-set equiv-set-size [ representative ] keep count ;
+
+GENERIC: equiv? ( a b disjoint-set -- ? )
+
+M: disjoint-set equiv? representatives = ;
+
+GENERIC: equate ( a b disjoint-set -- )
+
+M:: disjoint-set equate ( a b disjoint-set -- )
+    a b disjoint-set representatives
+    2dup = [ 2drop ] [
+        2dup disjoint-set ranks
+        [ swap ] [ over disjoint-set inc-rank ] [ ] branch
+        disjoint-set link-sets
+    ] if ;

extra/display-stack/display-stack.factor

@@ -0,0 +1,43 @@
+
+USING: kernel namespaces sequences math
+       listener io prettyprint sequences.lib fry ;
+
+IN: display-stack
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: watched-variables
+
+: watch-var ( sym -- ) watched-variables get push ;
+
+: watch-vars ( seq -- ) watched-variables get [ push ] curry each ;
+
+: unwatch-var ( sym -- ) watched-variables get delete ;
+
+: unwatch-vars ( seq -- ) watched-variables get [ delete ] curry each ;
+
+: print-watched-variables ( -- )
+  watched-variables get length 0 >
+    [
+      "----------" print
+      watched-variables get
+        watched-variables get [ unparse ] map longest length 2 +
+        '[ [ unparse ": " append , 32 pad-right write ] [ get . ] bi ]
+      each
+
+    ]
+  when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: display-stack ( -- )
+  V{ } clone watched-variables set
+    [
+      print-watched-variables
+      "----------" print
+      datastack [ . ] each
+      "----------" print
+      retainstack reverse [ . ] each
+    ]
+  listener-hook set ;
+

extra/farkup/authors.txt

@@ -1 +1,2 @@
 Doug Coleman
+Slava Pestov

extra/farkup/farkup-tests.factor

@@ -1,12 +1,19 @@
-USING: farkup kernel tools.test ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: farkup kernel peg peg.ebnf tools.test ;
 IN: farkup.tests
 
-[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
+[ ] [
-[ "<ul><li>foo</li></ul>\n" ] [ "-foo\n" convert-farkup ] unit-test
+    "abcd-*strong*\nasdifj\nweouh23ouh23"
-[ "<ul><li>foo</li><li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
+    "paragraph" \ farkup rule parse drop
-[ "<ul><li>foo</li><li>bar</li></ul>\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
+] unit-test
 
-[ "<ul><li>foo</li></ul>\n<p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
+[ ] [
+    "abcd-*strong*\nasdifj\nweouh23ouh23\n"
+    "paragraph" \ farkup rule parse drop
+] unit-test
+
+[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
 [ "<p>*foo\nbar\n</p>" ] [ "*foo\nbar\n" convert-farkup ] unit-test
 [ "<p><strong>Wow!</strong></p>" ] [ "*Wow!*" convert-farkup ] unit-test
 [ "<p><em>Wow.</em></p>" ] [ "_Wow._" convert-farkup ] unit-test
@@ -15,11 +22,20 @@ IN: farkup.tests
 [ "<p>*</p>" ] [ "\\*" convert-farkup ] unit-test
 [ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test
 
-[ "" ] [ "\n\n" convert-farkup ] unit-test
+[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
-[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test
+[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
-[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test
+[ "<ul><li>foo</li>\n</ul>" ] [ "-foo\n" convert-farkup ] unit-test
-[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test
+[ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
-[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test
+[ "<ul><li>foo</li>\n<li>bar</li>\n</ul>" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
+
+[ "<ul><li>foo</li>\n</ul><p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
+
+
+[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test
+[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test
+[ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test
+[ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test
+[ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test
 [ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
 [ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
 [ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
@@ -29,7 +45,7 @@ IN: farkup.tests
 [ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
 [ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
 
-[ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
+[ "<p>foo</p><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
 
 [ "" ] [ "" convert-farkup ] unit-test
 
@@ -77,8 +93,5 @@ IN: farkup.tests
 ] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
 
 [
-    "<p>Feature comparison:\n\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
+    "<p>Feature comparison:</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
 ] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
-
-[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
-[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test

extra/farkup/farkup.factor

@@ -1,72 +1,111 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io io.styles kernel memoize namespaces peg math
+USING: accessors arrays combinators html.elements io io.streams.string
-combinators sequences strings html.elements xml.entities
+kernel math memoize namespaces peg peg.ebnf prettyprint
-xmode.code2html splitting io.streams.string peg.parsers
+sequences sequences.deep strings xml.entities vectors splitting
-sequences.deep unicode.categories ;
+xmode.code2html ;
 IN: farkup
 
 SYMBOL: relative-link-prefix
 SYMBOL: disable-images?
 SYMBOL: link-no-follow?
 
-<PRIVATE
+TUPLE: heading1 obj ;
+TUPLE: heading2 obj ;
+TUPLE: heading3 obj ;
+TUPLE: heading4 obj ;
+TUPLE: strong obj ;
+TUPLE: emphasis obj ;
+TUPLE: superscript obj ;
+TUPLE: subscript obj ;
+TUPLE: inline-code obj ;
+TUPLE: paragraph obj ;
+TUPLE: list-item obj ;
+TUPLE: list obj ;
+TUPLE: table obj ;
+TUPLE: table-row obj ;
+TUPLE: link href text ;
+TUPLE: image href text ;
+TUPLE: code mode string ;
 
-: delimiters ( -- string )
+EBNF: farkup
-    "*_^~%[-=|\\\r\n" ; inline
+nl               = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
+2nl              = nl nl
 
-MEMO: text ( -- parser )
+heading1      = "=" (!("=" | nl).)+ "="
-    [ delimiters member? not ] satisfy repeat1
+    => [[ second >string heading1 boa ]]
-    [ >string escape-string ] action ;
 
-MEMO: delimiter ( -- parser )
+heading2      = "==" (!("=" | nl).)+ "=="
-    [ dup delimiters member? swap "\r\n=" member? not and ] satisfy
+    => [[ second >string heading2 boa ]]
-    [ 1string ] action ;
 
-: surround-with-foo ( string tag -- seq )
+heading3      = "===" (!("=" | nl).)+ "==="
-    dup <foo> swap </foo> swapd 3array ;
+    => [[ second >string heading3 boa ]]
 
-: delimited ( str html -- parser )
+heading4      = "====" (!("=" | nl).)+ "===="
-    [
+    => [[ second >string heading4 boa ]]
-        over token hide ,
-        text [ surround-with-foo ] swapd curry action ,
-        token hide ,
-    ] seq* ;
 
-MEMO: escaped-char ( -- parser )
+strong        = "*" (!("*" | nl).)+ "*"
-    [ "\\" token hide , any-char , ] seq* [ >string ] action ;
+    => [[ second >string strong boa ]]
 
-MEMO: strong ( -- parser ) "*" "strong" delimited ;
+emphasis      = "_" (!("_" | nl).)+ "_"
-MEMO: emphasis ( -- parser ) "_" "em" delimited ;
+    => [[ second >string emphasis boa ]]
-MEMO: superscript ( -- parser ) "^" "sup" delimited ;
+
-MEMO: subscript ( -- parser ) "~" "sub" delimited ;
+superscript   = "^" (!("^" | nl).)+ "^"
-MEMO: inline-code ( -- parser ) "%" "code" delimited ;
+    => [[ second >string superscript boa ]]
-MEMO: nl ( -- parser )
+
-    "\r\n" token [ drop "\n" ] action
+subscript     = "~" (!("~" | nl).)+ "~"
-    "\r" token [ drop "\n" ] action
+    => [[ second >string subscript boa ]]
-    "\n" token 3choice ;
+
-MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ;
+inline-code   = "%" (!("%" | nl).)+ "%"
-MEMO: h1 ( -- parser ) "=" "h1" delimited ;
+    => [[ second >string inline-code boa ]]
-MEMO: h2 ( -- parser ) "==" "h2" delimited ;
+
-MEMO: h3 ( -- parser ) "===" "h3" delimited ;
+escaped-char  = "\" .                => [[ second ]]
-MEMO: h4 ( -- parser ) "====" "h4" delimited ;
+
+image-link       = "[[image:" (!("|") .)+  "|" (!("]]").)+ "]]"
+                    => [[ [ second >string ] [ fourth >string ] bi image boa ]]
+                  | "[[image:" (!("]").)+ "]]"
+                    => [[ second >string f image boa ]]
+
+simple-link      = "[[" (!("|]" | "]]") .)+ "]]"
+    => [[ second >string dup link boa ]]
+
+labelled-link    = "[[" (!("|") .)+ "|" (!("]]").)+ "]]"
+    => [[ [ second >string ] [ fourth >string ] bi link boa ]]
+
+link             = image-link | labelled-link | simple-link
+
+heading          = heading4 | heading3 | heading2 | heading1
+
+inline-tag       = strong | emphasis | superscript | subscript | inline-code
+                   | link | escaped-char
+
+inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
+
+table-column     = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter  ) '|'
+    => [[ first ]]
+table-row        = "|" (table-column)+
+    => [[ second table-row boa ]]
+table            =  ((table-row nl => [[ first ]] )+ table-row? | table-row)
+    => [[ table boa ]]
+
+paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+
+paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
+             | (paragraph-item nl)+ paragraph-item?
+             | paragraph-item)
+    => [[ paragraph boa ]]
+                
+list-item      = '-' ((!(inline-delimiter | nl).)+ | inline-tag)*
+    => [[ second list-item boa ]]
+list = ((list-item nl)+ list-item? | list-item)
+    => [[ list boa ]]
+
+code       =  '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
+    => [[ [ second >string ] [ fourth >string ] bi code boa ]]
+
+stand-alone      = (code | heading | list | table | paragraph | nl)*
+;EBNF
 
-MEMO: eq ( -- parser )
-    [
-        h1 ensure-not ,
-        h2 ensure-not ,
-        h3 ensure-not ,
-        h4 ensure-not ,
-        "=" token ,
-    ] seq* ;
 
-: render-code ( string mode -- string' )
-    >r string-lines r>
-    [
-        <pre>
-            htmlize-lines
-        </pre>
-    ] with-string-writer ;
 
 : invalid-url "javascript:alert('Invalid URL in farkup');" ;
 
@@ -85,116 +124,57 @@ MEMO: eq ( -- parser )
 : escape-link ( href text -- href-esc text-esc )
     >r check-url escape-quoted-string r> escape-string ;
 
-: make-link ( href text -- seq )
+: write-link ( text href -- )
     escape-link
-    [
+    "<a" write
-        "<a" ,
+    " href=\"" write write "\"" write
-        " href=\"" , >r , r> "\"" ,
+    link-no-follow? get [ " nofollow=\"true\"" write ] when
-        link-no-follow? get [ " nofollow=\"true\"" , ] when
+    ">" write write "</a>" write ;
-        ">" , , "</a>" ,
-    ] { } make ;
 
-: make-image-link ( href alt -- seq )
+: write-image-link ( href text -- )
     disable-images? get [
-        2drop "<strong>Images are not allowed</strong>"
+        2drop "<strong>Images are not allowed</strong>" write
     ] [
         escape-link
-        [
+        >r "<img src=\"" write write "\"" write r>
-            "<img src=\"" , swap , "\"" ,
+        dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if
-            dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
+        "/>" write
-            "/>" ,
-        ] { } make
     ] if ;
 
-MEMO: image-link ( -- parser )
+: render-code ( string mode -- string' )
+    >r string-lines r>
     [
-        "[[image:" token hide ,
+        <pre>
-        [ "|]" member? not ] satisfy repeat1 [ >string ] action ,
+            htmlize-lines
-        "|" token hide
+        </pre>
-            [ CHAR: ] = not ] satisfy repeat0 2seq
+    ] with-string-writer write ;
-            [ first >string ] action optional ,
-        "]]" token hide ,
-    ] seq* [ first2 make-image-link ] action ;
 
-MEMO: simple-link ( -- parser )
+GENERIC: write-farkup ( obj -- )
-    [
+: <foo.> ( string -- ) <foo> write ;
-        "[[" token hide ,
+: </foo.> ( string -- ) </foo> write ;
-        [ "|]" member? not ] satisfy repeat1 ,
+: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
-        "]]" token hide ,
+M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
-    ] seq* [ first dup make-link ] action ;
+M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
-
+M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
-MEMO: labelled-link ( -- parser )
+M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
-    [
+M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
-        "[[" token hide ,
+M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
-        [ CHAR: | = not ] satisfy repeat1 ,
+M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
-        "|" token hide ,
+M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
-        [ CHAR: ] = not ] satisfy repeat1 ,
+M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
-        "]]" token hide ,
+M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
-    ] seq* [ first2 make-link ] action ;
+M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
-
+M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
-MEMO: link ( -- parser )
+M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
-    [ image-link , simple-link , labelled-link , ] choice* ;
+M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
-
+M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
-DEFER: line
+M: table-row write-farkup ( obj -- )
-MEMO: list-item ( -- parser )
+    obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
-    [
+M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
-        "-" token hide , ! text ,
+M: fixnum write-farkup ( obj -- ) write1 ;
-        [ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action ,
+M: string write-farkup ( obj -- ) write ;
-    ] seq* [ "li" surround-with-foo ] action ;
+M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
-
+M: f write-farkup ( obj -- ) drop ;
-MEMO: list ( -- parser )
-    list-item nl hide list-of
-    [ "ul" surround-with-foo ] action ;
-
-MEMO: table-column ( -- parser )
-    text [ "td" surround-with-foo ] action ;
-
-MEMO: table-row ( -- parser )
-    "|" token hide
-    table-column "|" token hide list-of
-    "|" token hide nl hide optional 4seq
-    [ "tr" surround-with-foo ] action ;
-
-MEMO: table ( -- parser )
-    table-row repeat1
-    [ "table" surround-with-foo ] action ;
-
-MEMO: code ( -- parser )
-    [
-        "[" token hide ,
-        [ CHAR: { = not ] satisfy repeat1 optional [ >string ] action ,
-        "{" token hide ,
-        "}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action ,
-        "}]" token hide ,
-    ] seq* [ first2 swap render-code ] action ;
-
-MEMO: line ( -- parser )
-    [
-        nl table 2seq ,
-        nl list 2seq ,
-        text , strong , emphasis , link ,
-        superscript , subscript , inline-code ,
-        escaped-char , delimiter , eq ,
-    ] choice* repeat1 ;
-
-MEMO: paragraph ( -- parser )
-    line
-    nl over 2seq repeat0
-    nl nl ensure-not 2seq optional 3seq
-    [
-        dup [ dup string? not swap [ blank? ] all? or ] deep-all?
-        [ "<p>" swap "</p>" 3array ] unless
-    ] action ;
-
-PRIVATE>
-
-PEG: parse-farkup ( -- parser )
-    [
-        list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
-    ] choice* repeat0 nl optional 2seq ;
-
-: write-farkup ( parse-result  -- )
-    [ dup string? [ write ] [ drop ] if ] deep-each ;
 
 : convert-farkup ( string -- string' )
-    parse-farkup [ write-farkup ] with-string-writer ;
+    farkup [ write-farkup ] with-string-writer ;

extra/fry/fry-docs.factor

@@ -19,10 +19,11 @@ HELP: fry
 
 HELP: '[
 { $syntax "code... ]" }
-{ $description "Literal fried quotation. Expands into code which takes values from the stack and substituting them in." } ;
+{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link , } " and " { $link @ } "." }
+{ $examples "See " { $link "fry.examples" } "." } ;
 
 ARTICLE: "fry.examples" "Examples of fried quotations"
-"Conceptually, " { $link fry } " is tricky however the general idea is easy to grasp once presented with examples."
+"The easiest way to understand fried quotations is to look at some examples."
 $nl
 "If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"
 { $code "{ 10 20 30 } '[ . ] each" }
@@ -38,9 +39,10 @@ $nl
     "{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"
     "{ 10 20 30 } [ 3 5 / ] map"
 }
-"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:"
+"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following four lines are equivalent:"
 { $code 
     "{ 10 20 30 } [ sq ] '[ @ . ] each"
+    "{ 10 20 30 } [ sq ] [ call . ] curry each"
     "{ 10 20 30 } [ sq ] [ . ] compose each"
     "{ 10 20 30 } [ sq . ] each"
 }
@@ -50,16 +52,17 @@ $nl
     "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"
     "{ 8 13 14 27 } [ even? dup 5 ? ] map"
 }
-"Occurrences of " { $link _ } " have the effect of enclosing all code to their left with " { $link >r } " and " { $link r> } ":"
+"Occurrences of " { $link _ } " have the effect of enclosing all code to their left in a quotation passed to " { $link dip } ". The following four lines are equivalent:"
 { $code 
     "{ 10 20 30 } 1 '[ , _ / ] map"
+    "{ 10 20 30 } 1 [ [ ] curry dip / ] curry map"
     "{ 10 20 30 } 1 [ swap / ] curry map"
     "{ 10 20 30 } [ 1 swap / ] map"
 }
 "For any quotation body " { $snippet "X" } ", the following two are equivalent:"
 { $code
-    "[ >r X r> ]"
+    "[ [ X ] dip ]"
-    "[ X _ ]"
+    "'[ X _ ]"
 }
 "Here are some built-in combinators rewritten in terms of fried quotations:"
 { $table
@@ -73,8 +76,11 @@ $nl
 } ;
 
 ARTICLE: "fry.philosophy" "Fried quotation philosophy"
-"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } "."
+"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } ". They can clean up code with lots of currying and composition, particularly when quotations are nested:"
-$nl
+{ $code
+    "'[ [ , key? ] all? ] filter"
+    "[ [ key? ] curry all? ] curry filter"
+}
 "There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
 { $code
     "'[ 3 , + 4 , / ]"
@@ -87,7 +93,7 @@ $nl
 } ;
 
 ARTICLE: "fry.limitations" "Fried quotation limitations"
-"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } "." ;
+"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ;
 
 ARTICLE: "fry" "Fried quotations"
 "A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation."

extra/golden-section/golden-section.factor

@@ -1,64 +1,64 @@
+
 USING: kernel namespaces math math.constants math.functions arrays sequences
-    opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
+       opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
-    ui.gadgets.slate colors ;
+       ui.gadgets.slate colors accessors combinators.cleave ;
+
 IN: golden-section
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-! To run:
+: disk ( radius center -- )
-! "golden-section" run
+  glPushMatrix
+  gl-translate
+  dup 0 glScalef
+  gluNewQuadric [ 0 1 20 20 gluDisk ] [ gluDeleteQuadric ] bi
+  glPopMatrix ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: disk ( quadric radius center -- )
+! omega(i) = 2*pi*i*(phi-1)
-    glPushMatrix
+
-    gl-translate
+! x(i) = 0.5*i*cos(omega(i))
-    dup 0 glScalef
+! y(i) = 0.5*i*sin(omega(i))
-    0 1 10 10 gluDisk
+
-    glPopMatrix ;
+! radius(i) = 10*sin((pi*i)/720)
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : omega ( i -- omega ) phi 1- * 2 * pi * ;
 
-: x ( i -- x ) dup omega cos * 0.5 * ;
+: x ( i -- x ) [ omega cos ] [ 0.5 * ] bi * ;
+: y ( i -- y ) [ omega sin ] [ 0.5 * ] bi * ;
 
-: y ( i -- y ) dup omega sin * 0.5 * ;
+: center ( i -- point ) { x y } 1arr ;
-
-: center ( i -- point ) dup x swap y 2array ;
 
 : radius ( i -- radius ) pi * 720 / sin 10 * ;
 
 : color ( i -- color ) 360.0 / dup 0.25 1 4array ;
 
-: rim ( quadric i -- )
+: rim   ( i -- ) [ drop black gl-color ] [ radius 1.5 * ] [ center ] tri disk ;
-    black gl-color dup radius 1.5 * swap center disk ;
+: inner ( i -- ) [      color gl-color ] [ radius       ] [ center ] tri disk ;
 
-: inner ( quadric i -- )
+: dot ( i -- ) [ rim ] [ inner ] bi ;
-    dup color gl-color dup radius swap center disk ;
 
-: dot ( quadric i -- ) 2dup rim inner ;
+: golden-section ( -- ) 720 [ dot ] each ;
-
-: golden-section ( quadric -- ) 720 [ dot ] with each ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: with-quadric ( quot -- )
-    gluNewQuadric [ swap call ] keep gluDeleteQuadric ; inline
-
 : display ( -- )
-    GL_PROJECTION glMatrixMode
+  GL_PROJECTION glMatrixMode
-    glLoadIdentity
+  glLoadIdentity
-    -400 400 -400 400 -1 1 glOrtho
+  -400 400 -400 400 -1 1 glOrtho
-    GL_MODELVIEW glMatrixMode
+  GL_MODELVIEW glMatrixMode
-    glLoadIdentity
+  glLoadIdentity
-    [ golden-section ] with-quadric ;
+  golden-section ;
 
 : golden-section-window ( -- )
     [
-        [ display ] <slate>
+      [ display ] <slate>
-        { 600 600 } over set-slate-dim
+        { 600 600 } >>pdim
-        "Golden Section" open-window
+      "Golden Section" open-window
-    ] with-ui ;
+    ]
+  with-ui ;
 
 MAIN: golden-section-window

extra/help/handbook/handbook.factor

@@ -137,7 +137,7 @@ ARTICLE: "collections" "Collections"
 { $subsection "heaps" }
 { $subsection "graphs" }
 { $subsection "buffers" }
-"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-set" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ;
+"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-sets" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ;
 
 USING: io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ;
 

extra/help/lint/lint.factor

@@ -29,7 +29,7 @@ IN: help.lint
 : effect-values ( word -- seq )
     stack-effect
     [ in>> ] [ out>> ] bi append
-    [ (stack-picture) ] map
+    [ dup pair? [ first ] when effect>string ] map
     prune natural-sort ;
 
 : contains-funky-elements? ( element -- ? )

extra/html/components/components-tests.factor

@@ -155,7 +155,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
 
 [ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
 
-[ "<ul><li>foo</li><li>bar</li></ul>" ] [
+[ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [
     [ "farkup" T{ farkup } render ] with-string-writer
 ] unit-test
 

extra/interval-maps/interval-maps.factor

@@ -1,5 +1,7 @@
-USING: kernel sequences arrays accessors grouping
+! Copyright (C) 2008 Daniel Ehrenberg.
-math.order sorting math assocs locals namespaces ;
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences arrays accessors grouping math.order
+sorting binary-search math assocs locals namespaces ;
 IN: interval-maps
 
 TUPLE: interval-map array ;
@@ -7,7 +9,7 @@ TUPLE: interval-map array ;
 <PRIVATE
 
 : find-interval ( key interval-map -- interval-node )
-    [ first <=> ] binsearch* ;
+    [ first <=> ] with search nip ;
 
 : interval-contains? ( key interval-node -- ? )
     first2 between? ;

extra/io/monitors/monitors-tests.factor

@@ -55,7 +55,7 @@ os { winnt linux macosx } member? [
                     dup print flush
                     dup parent-directory
                     [ right-trim-separators "xyz" tail? ] either? not
-                ] [ ] [ ] while
+                ] loop
 
                 "c1" get count-down
                 
@@ -64,7 +64,7 @@ os { winnt linux macosx } member? [
                     dup print flush
                     dup parent-directory
                     [ right-trim-separators "yxy" tail? ] either? not
-                ] [ ] [ ] while
+                ] loop
 
                 "c2" get count-down
             ] "Monitor test thread" spawn drop

extra/iokit/iokit.factor

@@ -2,10 +2,11 @@ USING: alien.syntax alien.c-types core-foundation system
 combinators kernel sequences debugger io accessors ;
 IN: iokit
 
-<< {
+<<
-    { [ os macosx? ] [ "/System/Library/Frameworks/IOKit.framework" load-framework ] }
+    os macosx?
-    [ "IOKit only supported on Mac OS X" ]
+    [ "/System/Library/Frameworks/IOKit.framework" load-framework ]
-} cond >>
+    when
+>>
 
 : kIOKitBuildVersionKey   "IOKitBuildVersion" ; inline
 : kIOKitDiagnosticsKey   "IOKitDiagnostics" ; inline

extra/irc/client/client-tests.factor

@@ -1,7 +1,7 @@
 USING: kernel tools.test accessors arrays sequences qualified
        io.streams.string io.streams.duplex namespaces threads
        calendar irc.client.private irc.client irc.messages.private
-       concurrency.mailboxes classes ;
+       concurrency.mailboxes classes assocs ;
 EXCLUDE: irc.messages => join ;
 RENAME: join irc.messages => join_
 IN: irc.client.tests
@@ -20,28 +20,6 @@ IN: irc.client.tests
 : with-dummy-client ( quot -- )
      rot with-variable ; inline
 
-! Parsing tests
-irc-message new
-    ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
-    "someuser!n=user@some.where" >>prefix
-                       "PRIVMSG" >>command
-               { "#factortest" } >>parameters
-                            "hi" >>trailing
-1array
-[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
-  string>irc-message f >>timestamp ] unit-test
-
-privmsg new
-    ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
-    "someuser!n=user@some.where" >>prefix
-                       "PRIVMSG" >>command
-               { "#factortest" } >>parameters
-                            "hi" >>trailing
-                   "#factortest" >>name
-1array
-[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
-  parse-irc-line f >>timestamp ] unit-test
-
 { "" } make-client dup "factorbot" set-nick current-irc-client [
     { t } [ irc> profile>> nickname>> me? ] unit-test
 
@@ -64,21 +42,29 @@ privmsg new
                     ":some.where 001 factorbot :Welcome factorbot"
                   } make-client
                   [ connect-irc ] keep 1 seconds sleep
-                    profile>> nickname>> ] unit-test
+                  profile>> nickname>> ] unit-test
 
 { join_ "#factortest" } [
-             { ":factorbot!n=factorbo@some.where JOIN :#factortest"
+           { ":factorbot!n=factorbo@some.where JOIN :#factortest"
              ":ircserver.net MODE #factortest +ns"
              ":ircserver.net 353 factorbot @ #factortest :@factorbot "
              ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
              ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
              } make-client dup "factorbot" set-nick
              [ connect-irc ] keep 1 seconds sleep
-             join-messages>> 5 seconds mailbox-get-timeout
+             join-messages>> 1 seconds mailbox-get-timeout
              [ class ] [ trailing>> ] bi ] unit-test
-! TODO: user join
+
-! ":somedude!n=user@isp.net JOIN :#factortest"
+{ +join+ "somebody" } [
+           { ":somebody!n=somebody@some.where JOIN :#factortest"
+             } make-client dup "factorbot" set-nick
+             [ listeners>> [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
+             [ connect-irc ]
+             [ listeners>> [ "#factortest" ] dip at
+               [ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri
+             [ action>> ] [ nick>> ] bi
+             ] unit-test
 ! TODO: channel message
-! ":somedude!n=user@isp.net PRIVMSG #factortest :hello"
+! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello"
 ! TODO: direct private message
 ! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello"

extra/irc/client/client.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
        accessors destructors namespaces io assocs arrays qualified fry
-       continuations threads strings classes combinators
+       continuations threads strings classes combinators splitting hashtables
-       irc.messages irc.messages.private ;
+       ascii irc.messages irc.messages.private ;
 RENAME: join sequences => sjoin
 EXCLUDE: sequences => join ;
 IN: irc.client
@@ -27,33 +27,50 @@ TUPLE: irc-client profile stream in-messages out-messages join-messages
 
 TUPLE: irc-listener in-messages out-messages ;
 TUPLE: irc-server-listener < irc-listener ;
-TUPLE: irc-channel-listener < irc-listener name password timeout ;
+TUPLE: irc-channel-listener < irc-listener name password timeout participants ;
 TUPLE: irc-nick-listener < irc-listener name ;
 SYMBOL: +server-listener+
 
+! participant modes
+SYMBOL: +operator+
+SYMBOL: +voice+
+SYMBOL: +normal+
+
+: participant-mode ( n -- mode )
+    H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
+
+! participant changed actions
+SYMBOL: +join+
+SYMBOL: +part+
+SYMBOL: +mode+
+
+! listener objects
 : <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
 
 : <irc-server-listener> ( -- irc-server-listener )
      <mailbox> <mailbox> irc-server-listener boa ;
 
 : <irc-channel-listener> ( name -- irc-channel-listener )
-     <mailbox> <mailbox> rot f 60 seconds irc-channel-listener boa ;
+     [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone irc-channel-listener boa ;
 
 : <irc-nick-listener> ( name -- irc-nick-listener )
-     <mailbox> <mailbox> rot irc-nick-listener boa ;
+     [ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
 
 ! ======================================
 ! Message objects
 ! ======================================
 
+TUPLE: participant-changed nick action ;
+C: <participant-changed> participant-changed
+
 SINGLETON: irc-end          ! sent when the client isn't running anymore
 SINGLETON: irc-disconnected ! sent when connection is lost
 SINGLETON: irc-connected    ! sent when connection is established
 UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
 
 : terminate-irc ( irc-client -- )
-    [ in-messages>> irc-end swap mailbox-put ]
+    [ [ irc-end ] dip in-messages>> mailbox-put ]
-    [ f >>is-running drop ]
+    [ [ f ] dip (>>is-running) ]
     [ stream>> dispose ]
     tri ;
 
@@ -70,22 +87,39 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
 : listener> ( name -- listener/f ) irc> listeners>> at ;
 : unregister-listener ( name -- ) irc> listeners>> delete-at ;
 
-: to-listener ( message name -- )
+GENERIC: to-listener ( message obj -- )
+
+M: string to-listener ( message string -- )
     listener> [ +server-listener+ listener> ] unless*
-    [ in-messages>> mailbox-put ] [ drop ] if* ;
+    [ to-listener ] [ drop ] if* ;
+
+M: irc-listener to-listener ( message irc-listener -- )
+    in-messages>> mailbox-put ;
+
+: remove-participant ( nick channel -- )
+    listener> [ participants>> delete-at ] [ drop ] if* ;
+
+: listeners-with-participant ( nick -- seq )
+    irc> listeners>> values
+    [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
+    with filter ;
+
+: remove-participant-from-all ( nick -- )
+    dup listeners-with-participant [ delete-at ] with each ;
+
+: add-participant ( mode nick channel -- )
+    listener> [ participants>> set-at ] [ 2drop ] if* ;
+
+DEFER: me?
+
+: maybe-forward-join ( join -- )
+    [ prefix>> parse-name me? ] keep and
+    [ irc> join-messages>> mailbox-put ] when* ;
 
 ! ======================================
 ! IRC client messages
 ! ======================================
 
-GENERIC: irc-message>string ( irc-message -- string )
-
-M: irc-message irc-message>string ( irc-message -- string )
-    [ command>> ]
-    [ parameters>> " " sjoin ]
-    [ trailing>> dup [ CHAR: : prefix ] when ]
-    tri 3array " " sjoin ;
-
 : /NICK ( nick -- )
     "NICK " irc-write irc-print ;
 
@@ -99,7 +133,7 @@ M: irc-message irc-message>string ( irc-message -- string )
 
 : /JOIN ( channel password -- )
     "JOIN " irc-write
-    [ " :" swap 3append ] when* irc-print ;
+    [ [ " :" ] dip 3append ] when* irc-print ;
 
 : /PART ( channel text -- )
     [ "PART " irc-write irc-write ] dip
@@ -133,12 +167,31 @@ M: irc-message irc-message>string ( irc-message -- string )
     dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
 
 : broadcast-message-to-listeners ( message -- )
-    irc> listeners>> values [ in-messages>> mailbox-put ] with each ;
+    irc> listeners>> values [ to-listener ] with each ;
+
+GENERIC: handle-participant-change ( irc-message -- )
+
+M: join handle-participant-change ( join -- )
+    [ prefix>> parse-name +join+ <participant-changed> ]
+    [ trailing>> ] bi to-listener ;
+
+M: part handle-participant-change ( part -- )
+    [ prefix>> parse-name +part+ <participant-changed> ]
+    [ channel>> ] bi to-listener ;
+
+M: kick handle-participant-change ( kick -- )
+    [ who>> +part+ <participant-changed> ]
+    [ channel>> ] bi to-listener ;
+
+M: quit handle-participant-change ( quit -- )
+    prefix>> parse-name
+    [ +part+ <participant-changed> ] [ listeners-with-participant ] bi
+    [ to-listener ] with each ;
 
 GENERIC: handle-incoming-irc ( irc-message -- )
 
 M: irc-message handle-incoming-irc ( irc-message -- )
-    +server-listener+ listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
+    +server-listener+ listener> [ to-listener ] [ drop ] if* ;
 
 M: logged-in handle-incoming-irc ( logged-in -- )
     name>> irc> profile>> (>>nickname) ;
@@ -153,17 +206,43 @@ M: privmsg handle-incoming-irc ( privmsg -- )
     dup irc-message-origin to-listener ;
 
 M: join handle-incoming-irc ( join -- )
-    [ [ prefix>> parse-name me? ] keep and
+    { [ maybe-forward-join ] ! keep
-      [ irc> join-messages>> mailbox-put ] when* ]
+      [ dup trailing>> to-listener ]
-    [ dup trailing>> to-listener ]
+      [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
-    bi ;
+      [ handle-participant-change ]
+    } cleave ;
 
 M: part handle-incoming-irc ( part -- )
-    dup channel>> to-listener ;
+    [ dup channel>> to-listener ]
+    [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
+    [ handle-participant-change ]
+    tri ;
 
 M: kick handle-incoming-irc ( kick -- )
-    [ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when
+    { [ dup channel>>  to-listener ]
-    to-listener ;
+      [ [ who>> ] [ channel>> ] bi remove-participant ]
+      [ handle-participant-change ]
+      [ dup who>> me? [ unregister-listener ] [ drop ] if ]
+    } cleave ;
+
+M: quit handle-incoming-irc ( quit -- )
+    { [ dup prefix>> parse-name listeners-with-participant
+        [ to-listener ] with each ]
+      [ handle-participant-change ]
+      [ prefix>> parse-name remove-participant-from-all ]
+      [ ]
+    } cleave call-next-method ;
+
+: >nick/mode ( string -- nick mode )
+    dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
+
+: names-reply>participants ( names-reply -- participants )
+    trailing>> [ blank? ] trim " " split
+    [ >nick/mode 2array ] map >hashtable ;
+
+M: names-reply handle-incoming-irc ( names-reply -- )
+    [ names-reply>participants ] [ channel>> listener> ] bi
+    [ (>>participants) ] [ drop ] if* ;
 
 M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
     broadcast-message-to-listeners ;
@@ -174,24 +253,19 @@ M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
 
 GENERIC: handle-outgoing-irc ( obj -- )
 
-! M: irc-message handle-outgoing-irc ( irc-message -- )
+M: irc-message handle-outgoing-irc ( irc-message -- )
-!    irc-message>string irc-print ;
+    irc-message>client-line irc-print ;
 
 M: privmsg handle-outgoing-irc ( privmsg -- )
     [ name>> ] [ trailing>> ] bi /PRIVMSG ;
 
-M: part handle-outgoing-irc ( privmsg -- )
+M: part handle-outgoing-irc ( part -- )
     [ channel>> ] [ trailing>> "" or ] bi /PART ;
 
 ! ======================================
 ! Reader/Writer
 ! ======================================
 
-: irc-mailbox-get ( mailbox quot -- )
-    swap 5 seconds
-    '[ , , , mailbox-get-timeout swap call ]
-    [ drop ] recover ; inline
-
 : handle-reader-message ( irc-message -- )
     irc> in-messages>> mailbox-put ;
 
@@ -199,11 +273,12 @@ DEFER: (connect-irc)
 
 : (handle-disconnect) ( -- )
     irc>
-        [ in-messages>> irc-disconnected swap mailbox-put ]
+        [ [ irc-disconnected ] dip to-listener ]
         [ dup reconnect-time>> sleep (connect-irc) ]
         [ profile>> nickname>> /LOGIN ]
     tri ;
 
+! FIXME: do something with the exception, store somewhere to help debugging
 : handle-disconnect ( error -- )
     drop irc> is-running>> [ (handle-disconnect) ] when ;
 
@@ -220,14 +295,14 @@ DEFER: (connect-irc)
     [ (reader-loop) ] [ handle-disconnect ] recover ;
 
 : writer-loop ( -- )
-    irc> out-messages>> [ handle-outgoing-irc ] irc-mailbox-get ;
+    irc> out-messages>> mailbox-get handle-outgoing-irc ;
 
 ! ======================================
 ! Processing loops
 ! ======================================
 
 : in-multiplexer-loop ( -- )
-    irc> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ;
+    irc> in-messages>> mailbox-get handle-incoming-irc ;
 
 : strings>privmsg ( name string -- privmsg )
     privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
@@ -236,12 +311,12 @@ DEFER: (connect-irc)
     {
         { [ dup string? ] [ strings>privmsg ] }
         { [ dup privmsg instance? ] [ swap >>name ] }
+        [ nip ]
     } cond ;
 
 : listener-loop ( name listener -- )
-    out-messages>> swap
+    out-messages>> mailbox-get maybe-annotate-with-name
-    '[ , swap maybe-annotate-with-name irc> out-messages>> mailbox-put ]
+    irc> out-messages>> mailbox-put ;
-    irc-mailbox-get ;
 
 : spawn-irc-loop ( quot name -- )
     [ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip
@@ -275,7 +350,7 @@ M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
     [ name>> ] keep set+run-listener ;
 
 M: irc-server-listener (add-listener) ( irc-server-listener -- )
-    +server-listener+ swap set+run-listener ;
+    [ +server-listener+ ] dip set+run-listener ;
 
 GENERIC: (remove-listener) ( irc-listener -- )
 
@@ -283,8 +358,8 @@ M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
     name>> unregister-listener ;
 
 M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
-    [ [ out-messages>> ] [ name>> ] bi
+    [ [ name>> ] [ out-messages>> ] bi
-      \ part new swap >>channel mailbox-put ] keep
+      [ [ part new ] dip >>channel ] dip mailbox-put ] keep
     name>> unregister-listener ;
 
 M: irc-server-listener (remove-listener) ( irc-server-listener -- )
@@ -294,10 +369,10 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
     [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
         swap >>stream
         t >>is-running
-    in-messages>> irc-connected swap mailbox-put ;
+    in-messages>> [ irc-connected ] dip mailbox-put ;
 
 : with-irc-client ( irc-client quot -- )
-    >r current-irc-client r> with-variable ; inline
+    [ current-irc-client ] dip with-variable ; inline
 
 PRIVATE>
 

extra/irc/messages/messages-tests.factor

@@ -0,0 +1,37 @@
+USING: kernel tools.test accessors arrays qualified
+       irc.messages irc.messages.private ;
+EXCLUDE: sequences => join ;
+IN: irc.messages.tests
+
+! Parsing tests
+irc-message new
+    ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
+    "someuser!n=user@some.where" >>prefix
+                       "PRIVMSG" >>command
+               { "#factortest" } >>parameters
+                            "hi" >>trailing
+1array
+[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+  string>irc-message f >>timestamp ] unit-test
+
+privmsg new
+    ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
+    "someuser!n=user@some.where" >>prefix
+                       "PRIVMSG" >>command
+               { "#factortest" } >>parameters
+                            "hi" >>trailing
+                   "#factortest" >>name
+1array
+[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+  parse-irc-line f >>timestamp ] unit-test
+
+join new
+    ":someuser!n=user@some.where JOIN :#factortest" >>line
+    "someuser!n=user@some.where" >>prefix
+                          "JOIN" >>command
+                             { } >>parameters
+                   "#factortest" >>trailing
+1array
+[ ":someuser!n=user@some.where JOIN :#factortest"
+  parse-irc-line f >>timestamp ] unit-test
+

extra/irc/messages/messages.factor

@@ -1,13 +1,15 @@
 ! Copyright (C) 2008 Bruno Deferrari
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel fry sequences splitting ascii calendar accessors combinators
+USING: kernel fry splitting ascii calendar accessors combinators qualified
-       classes.tuple math.order ;
+       arrays classes.tuple math.order ;
+RENAME: join sequences => sjoin
+EXCLUDE: sequences => join ;
 IN: irc.messages
 
 TUPLE: irc-message line prefix command parameters trailing timestamp ;
 TUPLE: logged-in < irc-message name ;
 TUPLE: ping < irc-message ;
-TUPLE: join < irc-message channel ;
+TUPLE: join < irc-message ;
 TUPLE: part < irc-message channel ;
 TUPLE: quit < irc-message ;
 TUPLE: privmsg < irc-message name ;
@@ -16,8 +18,26 @@ TUPLE: roomlist < irc-message channel names ;
 TUPLE: nick-in-use < irc-message asterisk name ;
 TUPLE: notice < irc-message type ;
 TUPLE: mode < irc-message name channel mode ;
+TUPLE: names-reply < irc-message who = channel ;
 TUPLE: unhandled < irc-message ;
 
+: <irc-client-message> ( command parameters trailing -- irc-message )
+    irc-message new now >>timestamp
+    [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ;
+
+GENERIC: irc-message>client-line ( irc-message -- string )
+
+M: irc-message irc-message>client-line ( irc-message -- string )
+    [ command>> ]
+    [ parameters>> " " sjoin ]
+    [ trailing>> dup [ CHAR: : prefix ] when ]
+    tri 3array " " sjoin ;
+
+GENERIC: irc-message>server-line ( irc-message -- string )
+
+M: irc-message irc-message>server-line ( irc-message -- string )
+   drop "not implemented yet" ;
+
 <PRIVATE
 ! ======================================
 ! Message parsing
@@ -43,6 +63,8 @@ TUPLE: unhandled < irc-message ;
 : split-trailing ( string -- string string/f )
     ":" split1 ;
 
+PRIVATE>
+
 : string>irc-message ( string -- object )
     dup split-prefix split-trailing
     [ [ blank? ] trim " " split unclip swap ] dip
@@ -55,6 +77,7 @@ TUPLE: unhandled < irc-message ;
         { "NOTICE" [ \ notice ] }
         { "001" [ \ logged-in ] }
         { "433" [ \ nick-in-use ] }
+        { "353" [ \ names-reply ] }
         { "JOIN" [ \ join ] }
         { "PART" [ \ part ] }
         { "PRIVMSG" [ \ privmsg ] }
@@ -66,4 +89,3 @@ TUPLE: unhandled < irc-message ;
     [ [ tuple-slots ] [ parameters>> ] bi append ] dip
     [ all-slots over [ length ] bi@ min head ] keep slots>tuple ;
 
-PRIVATE>

extra/irc/ui/commandparser/commandparser.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2008 William Schlieper
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel vocabs.loader sequences strings splitting words irc.messages ;
+
+IN: irc.ui.commandparser
+
+"irc.ui.commands" require
+
+: command ( string string -- string command )
+    dup empty? [ drop "say" ] when
+    dup "irc.ui.commands" lookup
+    [ nip ]
+    [ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;
+
+: parse-message ( string -- )
+    "/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;

extra/irc/ui/commands/commands.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2008 William Schlieper
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel irc.client irc.messages irc.ui namespaces ;
+
+IN: irc.ui.commands
+
+: say ( string -- )
+    [ client get profile>> nickname>> <own-message> print-irc ]
+    [ listener get write-message ] bi ;
+
+: quote ( string -- )
+    drop ; ! THIS WILL CHANGE

extra/irc/ui/ircui-rc

@@ -0,0 +1,9 @@
+! Default system ircui-rc file
+! Copy into .ircui-rc in your home directory and then change username and such
+! To find your home directory, type "home ." into a Factor listener
+
+USING: irc.client irc.ui ;
+
+"irc.freenode.org" 8001 "factor-irc" f ! server port nick password
+{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin
+server-open

extra/irc/ui/load/load.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2008 William Schlieper
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel io.files parser editors sequences ;
+
+IN: irc.ui.load
+
+: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ;
+
+: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;
+
+: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;
+
+: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;
+
+: run-ircui ( -- ) ircui-rc run-file ;

extra/irc/ui/ui.factor

@@ -3,52 +3,81 @@
 
 USING: accessors kernel threads combinators concurrency.mailboxes
        sequences strings hashtables splitting fry assocs hashtables
-       ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers
+       ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
-       ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs
+       ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
-       io io.styles namespaces irc.client irc.messages ;
+       ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels
+       io io.styles namespaces calendar calendar.format models
+       irc.client irc.client.private irc.messages irc.messages.private
+       irc.ui.commandparser irc.ui.load ;
 
 IN: irc.ui
 
+SYMBOL: listener
+
 SYMBOL: client
 
 TUPLE: ui-window client tabs ;
 
+TUPLE: irc-tab < frame listener client listmodel ;
+
 : write-color ( str color -- )
     foreground associate format ;
 : red { 0.5 0 0 1 } ;
 : green { 0 0.5 0 1 } ;
 : blue { 0 0 1 1 } ;
+: black { 0 0 0 1 } ;
 
-: prefix>nick ( prefix -- nick )
+: colors H{ { +operator+ { 0 0.5 0 1 } }
-    "!" split first ;
+            { +voice+ { 0 0 1 1 } }
+            { +normal+ { 0 0 0 1 } } } ;
+
+: dot-or-parens ( string -- string )
+    dup empty? [ drop "." ]
+    [ "(" prepend ")" append ] if ;
 
 GENERIC: write-irc ( irc-message -- )
 
 M: privmsg write-irc
     "<" blue write-color
-    [ prefix>> prefix>nick write ] keep
+    [ prefix>> parse-name write ] keep
-    ">" blue write-color
+    "> " blue write-color
-    " " write
     trailing>> write ;
 
+TUPLE: own-message message nick timestamp ;
+
+: <own-message> ( message nick -- own-message )
+    now own-message boa ;
+
+M: own-message write-irc
+    "<" blue write-color
+    [ nick>> bold font-style associate format ] keep
+    "> " blue write-color
+    message>> write ;
+
 M: join write-irc
     "* " green write-color
-    prefix>> prefix>nick write
+    prefix>> parse-name write
     " has entered the channel." green write-color ;
 
 M: part write-irc
     "* " red write-color
-    [ prefix>> prefix>nick write ] keep
+    [ prefix>> parse-name write ] keep
-    " has left the channel(" red write-color
+    " has left the channel" red write-color
-    trailing>> write
+    trailing>> dot-or-parens red write-color ;
-    ")" red write-color ;
 
 M: quit write-irc
     "* " red write-color
-    [ prefix>> prefix>nick write ] keep
+    [ prefix>> parse-name write ] keep
-    " has left IRC(" red write-color
+    " has left IRC" red write-color
-    trailing>> write
+    trailing>> dot-or-parens red write-color ;
-    ")" red write-color ;
+
+M: mode write-irc
+    "* " blue write-color
+    [ name>> write ] keep
+    " has applied mode " blue write-color
+    [ mode>> write ] keep
+    " to " blue write-color
+    channel>> write ;
 
 M: irc-end write-irc
     drop "* You have left IRC" red write-color ;
@@ -63,56 +92,92 @@ M: irc-message write-irc
     drop ; ! catch all unimplemented writes, THIS WILL CHANGE    
 
 : print-irc ( irc-message -- )
-    write-irc nl ;
+    [ timestamp>> timestamp>hms write " " write ]
+    [ write-irc nl ] bi ;
 
-: send-message ( message listener client -- )
+: send-message ( message -- )
-    "<" blue write-color
+    [ print-irc ]
-    profile>> nickname>> bold font-style associate format
+    [ listener get write-message ] bi ;
-    ">" blue write-color
-    " " write
-    over write nl
-    out-messages>> mailbox-put ;
 
-: display ( stream listener -- )
+GENERIC: handle-inbox ( tab message -- )
+
+: filter-participants ( assoc val -- alist )
+    [ >alist ] dip
+   '[ second , = ] filter ;
+
+: update-participants ( tab -- )
+    [ listmodel>> ] [ listener>> participants>> ] bi
+    [ +operator+ filter-participants ]
+    [ +voice+ filter-participants ]
+    [ +normal+ filter-participants ] tri
+    append append swap set-model ;
+
+M: participant-changed handle-inbox
+    drop update-participants ;
+
+M: object handle-inbox
+    nip print-irc ;
+
+: display ( stream tab -- )
     '[ , [ [ t ]
-           [ , read-message print-irc ]
+           [ , dup listener>> read-message handle-inbox ]
            [  ] while ] with-output-stream ] "ircv" spawn drop ;
 
-: <irc-pane> ( listener -- pane )
+: <irc-pane> ( tab -- tab pane )
     <scrolling-pane>
-    [ <pane-stream> swap display ] keep ;
+    [ <pane-stream> swap display ] 2keep ;
 
 TUPLE: irc-editor < editor outstream listener client ;
 
-: <irc-editor> ( pane listener client -- editor )
+: <irc-editor> ( tab pane -- tab editor )
-    [ irc-editor new-editor
+    over irc-editor new-editor
-    swap >>listener swap <pane-stream> >>outstream
+    swap listener>> >>listener swap <pane-stream> >>outstream
-    ] dip client>> >>client ;
+    over client>> >>client ;
 
 : editor-send ( irc-editor -- )
     { [ outstream>> ]
-      [ editor-string ]
       [ listener>> ]
       [ client>> ]
+      [ editor-string ]
       [ "" swap set-editor-string ] } cleave
-    '[ , , , send-message ] with-output-stream ;
+     '[ , listener set , client set , parse-message ] with-output-stream ;
 
 irc-editor "general" f {
     { T{ key-down f f "RET" } editor-send }
     { T{ key-down f f "ENTER" } editor-send }
 } define-command-map
 
-: irc-page ( name pane editor tabbed -- )
+: <irc-list> ( -- gadget model )
-    [ [ <scroller> @bottom frame, ! editor
+    [ drop ]
-        <scroller> @center frame, ! pane
+    [ first2 [ <label> ] dip >>color ]
-      ] make-frame swap ] dip add-page ;
+    { } <model> [ <list> ] keep ;
+
+: <irc-tab> ( listener client -- irc-tab )
+    irc-tab new-frame
+    swap client>> >>client swap >>listener
+    <irc-pane> [ <scroller> @center grid-add* ] keep
+    <irc-editor> <scroller> @bottom grid-add* ;
+
+: <irc-channel-tab> ( listener client -- irc-tab )
+    <irc-tab>
+    <irc-list> [ <scroller> @right grid-add* ] dip >>listmodel
+    [ update-participants ] keep ;
+
+: <irc-server-tab> ( listener client -- irc-tab )
+    <irc-tab> ;
+
+M: irc-tab graft*
+    [ listener>> ] [ client>> ] bi
+    add-listener ;
+
+M: irc-tab ungraft*
+    [ listener>> ] [ client>> ] bi
+    remove-listener ;
 
 : join-channel ( name ui-window -- )
     [ dup <irc-channel-listener> ] dip
-    [ client>> add-listener ]
+    [ <irc-channel-tab> swap ] keep
-    [ drop <irc-pane> dup ]
+    tabs>> add-page ;
-    [ [ <irc-editor> ] keep ] 2tri
-    tabs>> irc-page ;
 
 : irc-window ( ui-window -- )
     [ tabs>> ]
@@ -122,9 +187,13 @@ irc-editor "general" f {
 : ui-connect ( profile -- ui-window )
     <irc-client> ui-window new over >>client swap
     [ connect-irc ]
-    [ listeners>> +server-listener+ swap at <irc-pane> <scroller>
+    [ listeners>> +server-listener+ swap at over <irc-tab>
       "Server" associate <tabbed> >>tabs ] bi ;
 
-: freenode-connect ( -- ui-window )
+: server-open ( server port nick password channels -- )
-    "irc.freenode.org" 8001 "factor-irc" f
+    [ <irc-profile> ui-connect [ irc-window ] keep ] dip
-    <irc-profile> ui-connect [ irc-window ] keep ;
+    [ over join-channel ] each drop ;
+
+: main-run ( -- ) run-ircui ;
+
+MAIN: main-run

extra/koszul/koszul.factor

@@ -184,7 +184,7 @@ DEFER: (d)
     [ length ] keep [ (graded-ker/im-d) ] curry map ;
 
 : graded-betti ( generators -- seq )
-    basis graded graded-ker/im-d flip first2 but-last 0 prefix v- ;
+    basis graded graded-ker/im-d unzip but-last 0 prefix v- ;
 
 ! Bi-graded for two-step complexes
 : (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )

extra/locals/locals.factor

@@ -64,8 +64,8 @@ C: <quote> quote
     local-index 1+ [ get-local ] curry ;
 
 : localize-writer ( obj args -- quot )
-  >r "local-reader" word-prop r>
+    >r "local-reader" word-prop r>
-  read-local-quot [ set-local-value ] append ;
+    read-local-quot [ set-local-value ] append ;
 
 : localize ( obj args -- quot )
     {
@@ -275,7 +275,7 @@ M: wlet local-rewrite*
 : parse-locals ( -- vars assoc )
     ")" parse-effect
     word [ over "declared-effect" set-word-prop ] when*
-    effect-in make-locals dup push-locals ;
+    in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
 
 : parse-locals-definition ( word -- word quot )
     scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>

extra/lsys/ui/ui.factor

@@ -158,7 +158,9 @@ DEFER: empty-model
 : lsys-viewer ( -- )
 
 [ ] <slate> >slate
-{ 400 400 } clone slate> set-slate-dim
+{ 400 400 } clone slate> set-slate-pdim
+
+slate> <handler>
 
 {
 
@@ -194,13 +196,9 @@ DEFER: empty-model
 [ [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
     camera-action ] }
 
-! } [ make* ] map alist>hash <handler> >handler
+} [ make* ] map >hashtable >>table
 
-} [ make* ] map >hashtable <handler> >handler
+"L-system view" open-window
-
-slate> handler> set-gadget-delegate
-
-handler> "L-system view" open-window
 
 500 sleep
 

extra/math/functions/functions.factor

@@ -23,12 +23,12 @@ GENERIC: sqrt ( x -- y ) foldable
 M: real sqrt
     >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
 
-: each-bit ( n quot -- )
+: each-bit ( n quot: ( ? -- ) -- )
     over 0 number= pick -1 number= or [
         2drop
     ] [
         2dup >r >r >r odd? r> call r> 2/ r> each-bit
-    ] if ; inline
+    ] if ; inline recursive
 
 GENERIC: (^) ( x y -- z ) foldable
 

extra/math/geometry/geometry.factor

@@ -0,0 +1,8 @@
+
+IN: math.geometry
+
+GENERIC: width  ( object -- width )
+GENERIC: height ( object -- width )
+
+GENERIC# set-x! 1 ( object x -- object )
+GENERIC# set-y! 1 ( object y -- object )

extra/math/geometry/rect/rect.factor

@@ -1,13 +1,15 @@
 
-USING: kernel arrays math.vectors ;
+USING: kernel arrays sequences math.vectors math.geometry accessors ;
 
 IN: math.geometry.rect
 
-TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
+TUPLE: rect loc dim ;
 
-: <zero-rect> ( -- rect ) rect new ;
+: init-rect ( rect -- rect ) { 0 0 } clone >>loc { 0 0 } clone >>dim ;
 
-C: <rect> rect
+: <rect> ( loc dim -- rect ) rect boa ;
+
+: <zero-rect> ( -- rect ) rect new init-rect ;
 
 M: array rect-loc ;
 
@@ -40,3 +42,8 @@ M: array rect-dim drop { 0 0 } ;
 : rect-union ( rect1 rect2 -- newrect )
     (rect-union) <extent-rect> ;
 
+M: rect width  ( rect -- width  ) dim>> first  ;
+M: rect height ( rect -- height ) dim>> second ;
+
+M: rect set-x! ( rect x -- rect ) over loc>> set-first  ;
+M: rect set-y! ( rect y -- rect ) over loc>> set-second ;

extra/math/matrices/elimination/elimination.factor

@@ -11,7 +11,7 @@ SYMBOL: matrix
 
 : nth-row ( row# -- seq ) matrix get nth ;
 
-: change-row ( row# quot -- | quot: seq -- seq )
+: change-row ( row# quot: ( seq -- seq ) -- )
     matrix get swap change-nth ; inline
 
 : exchange-rows ( row# row# -- ) matrix get exchange ;

extra/math/primes/primes.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators kernel lists.lazy math math.functions math.miller-rabin
-       math.order math.primes.list math.ranges sequences sorting ;
+       math.order math.primes.list math.ranges sequences sorting
+       binary-search ;
 IN: math.primes
 
 <PRIVATE
@@ -13,14 +14,14 @@ PRIVATE>
 
 : next-prime ( n -- p )
   dup 999983 < [
-    primes-under-million [ [ <=> ] binsearch 1+ ] keep nth
+    primes-under-million [ natural-search drop 1+ ] keep nth
   ] [
     next-odd find-prime-miller-rabin
   ] if ; foldable
 
 : prime? ( n -- ? )
   dup 1000000 < [
-    dup primes-under-million [ <=> ] binsearch* =
+    dup primes-under-million natural-search nip =
   ] [
     miller-rabin
   ] if ; foldable
@@ -37,7 +38,7 @@ PRIVATE>
   {
     { [ dup 2 < ] [ drop { } ] }
     { [ dup 1000003 < ]
-      [ primes-under-million [ [ <=> ] binsearch 1+ 0 swap ] keep <slice> ] }
+      [ primes-under-million [ natural-search drop 1+ 0 swap ] keep <slice> ] }
     [ primes-under-million 1000003 lprimes-from
         rot [ <= ] curry lwhile list>array append ]
   } cond ; foldable
@@ -45,6 +46,6 @@ PRIVATE>
 : primes-between ( low high -- seq )
   primes-upto
   [ 1- next-prime ] dip
-  [ [ <=> ] binsearch ] keep [ length ] keep <slice> ; foldable
+  [ natural-search drop ] keep [ length ] keep <slice> ; foldable
 
 : coprime? ( a b -- ? ) gcd nip 1 = ; foldable

extra/multi-methods/tests/canonicalize.factor

@@ -49,7 +49,7 @@ kernel strings ;
         { { object ppc object } "b" }
         { { string object windows } "c" }
     }
-    V{ cpu os }
+    { cpu os }
 ] [
     example-1 canonicalize-specializers
 ] unit-test

extra/optimizer/debugger/debugger.factor

@@ -3,8 +3,8 @@
 USING: classes io kernel kernel.private math.parser namespaces
 optimizer prettyprint prettyprint.backend sequences words arrays
 match macros assocs sequences.private generic combinators
-sorting math quotations accessors inference inference.dataflow
+sorting math quotations accessors inference inference.backend
-optimizer.specializers ;
+inference.dataflow optimizer.specializers generator ;
 IN: optimizer.debugger
 
 ! A simple tool for turning dataflow IR into quotations, for
@@ -135,14 +135,21 @@ M: object node>quot
 
 : optimized-word. ( word ? -- ) >r specialized-def r> optimized-quot. ;
 
+SYMBOL: pass-count
 SYMBOL: words-called
 SYMBOL: generics-called
 SYMBOL: methods-called
 SYMBOL: intrinsics-called
 SYMBOL: node-count
 
-: dataflow>report ( node -- alist )
+: count-optimization-passes ( node n -- node n )
+    >r optimize-1
+    [ r> 1+ count-optimization-passes ] [ r> ] if ;
+
+: make-report ( word -- assoc )
     [
+        word-dataflow nip 1 count-optimization-passes pass-count set
+
         H{ } clone words-called set
         H{ } clone generics-called set
         H{ } clone methods-called set
@@ -164,14 +171,12 @@ SYMBOL: node-count
         node-count set
     ] H{ } make-assoc ;
 
-: quot-optimize-report ( quot -- report )
-    dataflow optimize dataflow>report ;
-
-: word-optimize-report ( word -- report )
-    def>> quot-optimize-report ;
-
 : report. ( report -- )
     [
+        "==== Optimization passes:" print
+        pass-count get .
+        nl
+
         "==== Total number of dataflow nodes:" print
         node-count get .
 
@@ -186,4 +191,4 @@ SYMBOL: node-count
     ] bind ;
 
 : optimizer-report. ( word -- )
-    word-optimize-report report. ;
+    make-report report. ;

extra/peg/ebnf/ebnf-tests.factor

@@ -449,7 +449,7 @@ foo=<foreign any-char> 'd'
 ] unit-test
 
 [
-  "USING: peg.ebnf ; \"ab\" [EBNF foo='a' foo='b' EBNF]" eval drop
+  "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval drop
 ] must-fail
 
 { t } [
@@ -519,4 +519,4 @@ Tok                = Spaces (Number | Special )
 
 { "\\" } [
   "\\" [EBNF foo="\\" EBNF]
-] unit-test
+] unit-test

extra/peg/ebnf/ebnf.factor

@@ -371,7 +371,7 @@ M: ebnf-tokenizer (transform) ( ast -- parser )
 M: ebnf-rule (transform) ( ast -- parser )
   dup elements>> 
   (transform) [
-    swap symbol>> dup get { [ tuple? ] [ delegate parser? ] } 1&& [ 
+    swap symbol>> dup get parser? [ 
       "Rule '" over append "' defined more than once" append throw 
     ] [ 
       set