Merge branch 'master' of 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.factor

@@ -16,7 +16,7 @@ IN: binary-search
     [ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
     [ drop ] [ dup ] [ ] tri* nth ; inline
 
-: (search) ( quot seq -- i elt )
+: (search) ( quot: ( elt -- <=> ) seq -- i elt )
     dup length 1 <= [
         finish
     ] [
@@ -25,7 +25,7 @@ IN: binary-search
             { +lt+ [ dup midpoint@ head-slice (search) ] }
             { +gt+ [ dup midpoint@ tail-slice (search) ] }
         } case
-    ] if ; inline
+    ] if ; inline recursive
 
 PRIVATE>
 

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

@@ -52,14 +52,14 @@ TUPLE: merge
 : r-next  [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
 : decide  [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
 
-: (merge) ( merge quot -- )
+: (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- )
     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
+    ] if ; inline recursive
 
 : flip-accum ( merge -- )
     dup [ accum>> ] [ accum1>> ] bi eq? [
@@ -111,10 +111,9 @@ TUPLE: merge
     [ merge ] 2curry each-chunk ; inline
 
 : sort-loop ( merge quot -- )
-    2 swap
+    [ 2 [ over seq>> length over > ] ] dip
-    [ pick seq>> length pick > ]
+    [ [ 1 shift 2dup ] dip sort-pass ] curry
-    [ [ dup ] [ 1 shift ] [ ] tri* [ sort-pass ] 2keep ]
+    [ ] while 2drop ; inline
-    [ ] while 3drop ; inline
 
 : each-pair ( seq quot -- )
     [ [ length 1+ 2/ ] keep ] dip

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/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

@@ -12,18 +12,6 @@ IN: benchmark.backtrack
 
 : nop ;
 
-MACRO: amb-execute ( seq -- quot )
-    [ length ] [ <enum> [ 1quotation ] assoc-map ] bi
-    '[ , amb , case ] ;
-
-: if-amb ( true false -- )
-    [
-        [ { t f } amb ]
-        [ '[ @ require t ] ]
-        [ '[ @ f ] ]
-        tri* if
-    ] with-scope ; inline
-
 : do-something ( a b -- c )
     { + - * } amb-execute ;
 

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/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/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/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/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/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

@@ -31,6 +31,20 @@ 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 )
@@ -46,6 +60,9 @@ SYMBOL: +server-listener+
 ! 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
@@ -70,19 +87,27 @@ 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* ;
 
-: remove-participant-from-all ( nick -- )
+: listeners-with-participant ( nick -- seq )
-    irc> listeners>>
+    irc> listeners>> values
-    [ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with
+    [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
-    assoc-each ;
+    with filter ;
 
-: add-participant ( nick mode channel -- )
+: 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?
@@ -142,12 +167,31 @@ DEFER: me?
     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) ;
@@ -162,34 +206,43 @@ M: privmsg handle-incoming-irc ( privmsg -- )
     dup irc-message-origin to-listener ;
 
 M: join handle-incoming-irc ( join -- )
-    [ maybe-forward-join ]
+    { [ maybe-forward-join ] ! keep
-    [ dup trailing>> to-listener ]
+      [ dup trailing>> to-listener ]
-    [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
+      [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
-    tri ;
+      [ handle-participant-change ]
+    } cleave ;
 
 M: part handle-incoming-irc ( part -- )
-    [ dup channel>> to-listener ] keep
+    [ dup channel>> to-listener ]
-    [ prefix>> parse-name ] [ channel>> ] bi remove-participant ;
+    [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
-
+    [ handle-participant-change ]
-M: kick handle-incoming-irc ( kick -- )
-    [ dup channel>>  to-listener ]
-    [ [ who>> ] [ channel>> ] bi remove-participant ] 
-    [ dup who>> me? [ unregister-listener ] [ drop ] if ]
     tri ;
 
+M: kick handle-incoming-irc ( kick -- )
+    { [ dup channel>>  to-listener ]
+      [ [ who>> ] [ channel>> ] bi remove-participant ]
+      [ handle-participant-change ]
+      [ dup who>> me? [ unregister-listener ] [ drop ] if ]
+    } cleave ;
+
 M: quit handle-incoming-irc ( quit -- )
-    [ prefix>> parse-name remove-participant-from-all ] keep
+    { [ dup prefix>> parse-name listeners-with-participant
-    call-next-method ;
+        [ 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 ] [ f ] if ;
+    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) ;
+    [ names-reply>participants ] [ channel>> listener> ] bi
+    [ (>>participants) ] [ drop ] if* ;
 
 M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
     broadcast-message-to-listeners ;
@@ -200,8 +253,8 @@ 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 ;
@@ -213,11 +266,6 @@ M: part handle-outgoing-irc ( part -- )
 ! Reader/Writer
 ! ======================================
 
-: irc-mailbox-get ( mailbox quot -- )
-    [ 5 seconds ] dip
-    '[ , , ,  [ mailbox-get-timeout ] dip call ]
-    [ drop ] recover ; inline
-
 : handle-reader-message ( irc-message -- )
     irc> in-messages>> mailbox-put ;
 
@@ -225,7 +273,7 @@ DEFER: (connect-irc)
 
 : (handle-disconnect) ( -- )
     irc>
-        [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
+        [ [ irc-disconnected ] dip to-listener ]
         [ dup reconnect-time>> sleep (connect-irc) ]
         [ profile>> nickname>> /LOGIN ]
     tri ;
@@ -247,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 ;
@@ -267,9 +315,8 @@ DEFER: (connect-irc)
     } 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

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

@@ -21,6 +21,10 @@ 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 )
@@ -30,6 +34,7 @@ M: irc-message irc-message>client-line ( irc-message -- string )
     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" ;
 
@@ -58,6 +63,8 @@ M: irc-message irc-message>server-line ( irc-message -- string )
 : split-trailing ( string -- string string/f )
     ":" split1 ;
 
+PRIVATE>
+
 : string>irc-message ( string -- object )
     dup split-prefix split-trailing
     [ [ blank? ] trim " " split unclip swap ] dip
@@ -82,4 +89,3 @@ M: irc-message irc-message>server-line ( irc-message -- string )
     [ [ tuple-slots ] [ parameters>> ] bi append ] dip
     [ all-slots over [ length ] bi@ min head ] keep slots>tuple ;
 
-PRIVATE>

extra/irc/ui/load/load.factor

@@ -5,7 +5,7 @@ USING: kernel io.files parser editors sequences ;
 
 IN: irc.ui.load
 
-: file-or ( path path -- path ) over exists? ? ;
+: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ;
 
 : personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;
 

extra/irc/ui/ui.factor

@@ -5,8 +5,8 @@ USING: accessors kernel threads combinators concurrency.mailboxes
        sequences strings hashtables splitting fry assocs hashtables
        ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
        ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
-       ui.gadgets.tabs ui.gadgets.grids
+       ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels
-       io io.styles namespaces calendar calendar.format
+       io io.styles namespaces calendar calendar.format models
        irc.client irc.client.private irc.messages irc.messages.private
        irc.ui.commandparser irc.ui.load ;
 
@@ -18,11 +18,18 @@ 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 } ;
+
+: colors H{ { +operator+ { 0 0.5 0 1 } }
+            { +voice+ { 0 0 1 1 } }
+            { +normal+ { 0 0 0 1 } } } ;
 
 : dot-or-parens ( string -- string )
     dup empty? [ drop "." ]
@@ -64,6 +71,14 @@ M: quit write-irc
     " has left IRC" red write-color
     trailing>> dot-or-parens 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 ;
 
@@ -84,20 +99,39 @@ M: irc-message write-irc
     [ print-irc ]
     [ listener get write-message ] bi ;
 
-: 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> ( page 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
     over client>> >>client ;
 
 : editor-send ( irc-editor -- )
@@ -113,25 +147,36 @@ irc-editor "general" f {
     { T{ key-down f f "ENTER" } editor-send }
 } define-command-map
 
-TUPLE: irc-page < frame listener client ;
+: <irc-list> ( -- gadget model )
+    [ drop ]
+    [ first2 [ <label> ] dip >>color ]
+    { } <model> [ <list> ] keep ;
 
-: <irc-page> ( listener client -- irc-page )
+: <irc-tab> ( listener client -- irc-tab )
-    irc-page new-frame
+    irc-tab new-frame
-    swap client>> >>client swap [ >>listener ] keep
+    swap client>> >>client swap >>listener
-    [ <irc-pane> [ <scroller> @center grid-add* ] keep ]
+    <irc-pane> [ <scroller> @center grid-add* ] keep
-    [ <irc-editor> <scroller> @bottom grid-add* ] bi ;
+    <irc-editor> <scroller> @bottom grid-add* ;
 
-M: irc-page graft*
+: <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-page ungraft*
+M: irc-tab ungraft*
     [ listener>> ] [ client>> ] bi
     remove-listener ;
 
 : join-channel ( name ui-window -- )
     [ dup <irc-channel-listener> ] dip
-    [ <irc-page> swap ] keep
+    [ <irc-channel-tab> swap ] keep
     tabs>> add-page ;
 
 : irc-window ( ui-window -- )
@@ -142,12 +187,12 @@ M: irc-page ungraft*
 : 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 ;
 
 : server-open ( server port nick password channels -- )
     [ <irc-profile> ui-connect [ irc-window ] keep ] dip
-    [ over join-channel ] each ;
+    [ over join-channel ] each drop ;
 
 : main-run ( -- ) run-ircui ;
 

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/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/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/project-euler/079/079.factor

@@ -35,7 +35,7 @@ IN: project-euler.079
     ] { } make ;
 
 : find-source ( seq -- elt )
-    [ keys ] [ values ] bi diff prune
+    unzip diff prune
     dup empty? [ "Topological sort failed" throw ] [ first ] if ;
 
 : remove-source ( seq elt -- seq )

extra/project-euler/186/186.factor

@@ -1,4 +1,4 @@
-USING: circular disjoint-set kernel math math.ranges
+USING: circular disjoint-sets kernel math math.ranges
        sequences sequences.lib ;
 IN: project-euler.186
 
@@ -29,7 +29,10 @@ IN: project-euler.186
         drop nip
     ] if ;
 
+: <relation> ( n -- unionfind )
+    <disjoint-set> [ [ add-atom ] curry each ] keep ;
+
 : euler186 ( -- n )
-    <generator> 0 1000000 <disjoint-set> (p186) ;
+    <generator> 0 1000000 <relation> (p186) ;
 
 MAIN: euler186

extra/reports/optimizer/optimizer.factor

@@ -2,13 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs words sequences arrays compiler
 tools.time io.styles io prettyprint vocabs kernel sorting
-generator optimizer math math.order math.statistics combinators ;
+generator optimizer math math.order math.statistics combinators
+optimizer.debugger ;
 IN: report.optimizer
 
-: count-optimization-passes ( nodes n -- n )
-    >r optimize-1
-    [ r> 1+ count-optimization-passes ] [ drop r> ] if ;
-
 : table. ( alist -- )
     20 short tail*
     standard-table-style
@@ -28,13 +25,12 @@ IN: report.optimizer
         tri
     ] 2bi ; inline
 
+: optimization-passes ( word -- n )
+    word-dataflow nip 1 count-optimization-passes nip ;
+
 : optimizer-measurements ( -- alist )
     all-words [ compiled>> ] filter
-    [
+    [ dup [ optimization-passes ] benchmark 2array ] { } map>assoc ;
-        dup [
-            word-dataflow nip 1 count-optimization-passes
-        ] benchmark 2array
-    ] { } map>assoc ;
 
 : optimizer-measurements. ( alist -- )
     {

extra/sequences/deep/deep.factor

@@ -10,25 +10,25 @@ IN: sequences.deep
         dup string? swap number? or not
     ] [ drop f ] if ;
 
-: deep-each ( obj quot -- )
+: deep-each ( obj quot: ( elt -- ) -- )
     [ call ] 2keep over branch?
-    [ [ deep-each ] curry each ] [ 2drop ] if ; inline
+    [ [ deep-each ] curry each ] [ 2drop ] if ; inline recursive
 
-: deep-map ( obj quot -- newobj )
+: deep-map ( obj quot: ( elt -- elt' ) -- newobj )
     [ call ] keep over branch?
-    [ [ deep-map ] curry map ] [ drop ] if ; inline
+    [ [ deep-map ] curry map ] [ drop ] if ; inline recursive
 
-: deep-filter ( obj quot -- seq )
+: deep-filter ( obj quot: ( elt -- ? ) -- seq )
     over >r
     pusher >r deep-each r>
-    r> dup branch? [ like ] [ drop ] if ; inline
+    r> dup branch? [ like ] [ drop ] if ; inline recursive
 
-: deep-find-from ( obj quot -- elt ? )
+: deep-find-from ( obj quot: ( elt -- ? ) -- elt ? )
     [ call ] 2keep rot [ drop t ] [
         over branch? [
             f -rot [ >r nip r> deep-find-from ] curry find drop >boolean
         ] [ 2drop f f ] if  
-    ] if ; inline
+    ] if ; inline recursive
 
 : deep-find ( obj quot -- elt ) deep-find-from drop ; inline
 
@@ -37,10 +37,10 @@ IN: sequences.deep
 : deep-all? ( obj quot -- ? )
     [ not ] compose deep-contains? not ; inline
 
-: deep-change-each ( obj quot -- )
+: deep-change-each ( obj quot: ( elt -- elt' ) -- )
     over branch? [ [
         [ call ] keep over >r deep-change-each r>
-    ] curry change-each ] [ 2drop ] if ; inline
+    ] curry change-each ] [ 2drop ] if ; inline recursive
 
 : flatten ( obj -- seq )
     [ branch? not ] deep-filter ;

extra/sorting/insertion/insertion.factor

@@ -2,13 +2,13 @@ USING: locals sequences kernel math ;
 IN: sorting.insertion
 
 <PRIVATE
-:: insert ( seq quot n -- )
+:: insert ( seq quot: ( elt -- elt' ) n -- )
     n zero? [
         n n 1- [ seq nth quot call ] bi@ >= [
             n n 1- seq exchange
             seq quot n 1- insert
         ] unless
-    ] unless ; inline
+    ] unless ; inline recursive
 PRIVATE>
 
 : insertion-sort ( seq quot -- )

extra/ui/cocoa/cocoa.factor

@@ -16,10 +16,7 @@ SINGLETON: cocoa-ui-backend
 
 M: cocoa-ui-backend do-events ( -- )
     [
-        [
+        [ NSApp [ do-event ] curry loop ui-wait ] ui-try
-            NSApp [ dup do-event ] [ ] [ ] while drop
-            ui-wait
-        ] ui-try
     ] with-autorelease-pool ;
 
 TUPLE: pasteboard handle ;

extra/ui/freetype/freetype.factor

@@ -142,7 +142,7 @@ M: freetype-renderer string-height ( open-font string -- h )
     i end < [
         i j bitmap texture copy-pixel
             bitmap texture end (copy-row)
-    ] when ; inline
+    ] when ; inline recursive
 
 :: copy-row ( i j bitmap texture width width2 -- i j )
     i j bitmap texture i width + (copy-row)

extra/ui/render/render-docs.factor

@@ -5,17 +5,17 @@ IN: ui.render
 HELP: gadget
 { $class-description "An object which displays itself on the screen and acts on user input gestures. Gadgets have the following slots:"
     { $list
-        { { $link "pref-dim" } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
+        { { $snippet "pref-dim" } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
-        { { $link "parent" } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
+        { { $snippet "parent" } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
-        { { $link "children" } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
+        { { $snippet "children" } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
-        { { $link "orientation" } " - an orientation specifier. This slot is used by layout gadgets." }
+        { { $snippet "orientation" } " - an orientation specifier. This slot is used by layout gadgets." }
-        { { $link "layout-state" } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
+        { { $snippet "layout-state" } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
-        { { $link "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
+        { { $snippet "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
-        { { $link "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
+        { { $snippet "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
-        { { $link "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
+        { { $snippet "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
-        { { $link "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
+        { { $snippet "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
-        { { $link "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
+        { { $snippet "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
-        { { $link "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
+        { { $snippet "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
     }
 "Gadgets subclass the " { $link rect } " class, and thus all instances have " { $snippet "loc" } " and " { $snippet "dim" } " instances holding their location and dimensions." }
 { $notes

unfinished/compiler/cfg/alias/alias.factor

@@ -0,0 +1,293 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math namespaces assocs hashtables sequences
+accessors vectors combinators sets compiler.vops compiler.cfg ;
+IN: compiler.cfg.alias
+
+! Alias analysis -- must be run after compiler.cfg.stack.
+!
+! We try to eliminate redundant slot and stack
+! traffic using some simple heuristics.
+! 
+! All heap-allocated objects which are loaded from the stack, or
+! other object slots are pessimistically assumed to belong to
+! the same alias class.
+!
+! Freshly-allocated objects get their own alias class.
+!
+! The data and retain stack pointer registers are treated
+! uniformly, and each one gets its own alias class.
+! 
+! Simple pseudo-C example showing load elimination:
+! 
+! int *x, *y, z: inputs
+! int a, b, c, d, e: locals
+! 
+! Before alias analysis:
+!
+! a = x[2]
+! b = x[2]
+! c = x[3]
+! y[2] = z
+! d = x[2]
+! e = y[2]
+! f = x[3]
+!
+! After alias analysis:
+!
+! a = x[2]
+! b = a /* ELIMINATED */
+! c = x[3]
+! y[2] = z
+! d = x[2] /* if x=y, d=z, if x!=y, d=b; NOT ELIMINATED */
+! e = z /* ELIMINATED */
+! f = c /* ELIMINATED */
+!
+! Simple pseudo-C example showing store elimination:
+!
+! Before alias analysis:
+!
+! x[0] = a
+! b = x[n]
+! x[0] = c
+! x[1] = d
+! e = x[0]
+! x[1] = c
+!
+! After alias analysis:
+!
+! x[0] = a /* dead if n = 0, live otherwise; NOT ELIMINATED */
+! b = x[n]
+! x[0] = c
+! /* x[1] = d */  /* ELIMINATED */
+! e = c
+! x[1] = c
+
+! Map vregs -> alias classes
+SYMBOL: vregs>acs
+
+: check [ "BUG: static type error detected" throw ] unless* ; inline
+ 
+: vreg>ac ( vreg -- ac )
+    #! Only vregs produced by %%allot, %peek and %%slot can
+    #! ever be used as valid inputs to %%slot and %%set-slot,
+    #! so we assert this fact by not giving alias classes to
+    #! other vregs.
+    vregs>acs get at check ;
+
+! Map alias classes -> sequence of vregs
+SYMBOL: acs>vregs
+
+: ac>vregs ( ac -- vregs ) acs>vregs get at ;
+
+: aliases ( vreg -- vregs )
+    #! All vregs which may contain the same value as vreg.
+    vreg>ac ac>vregs ;
+
+: each-alias ( vreg quot -- )
+    [ aliases ] dip each ; inline
+
+! Map vregs -> slot# -> vreg
+SYMBOL: live-slots
+
+! Current instruction number
+SYMBOL: insn#
+
+! Load/store history, for dead store elimination
+TUPLE: load insn# ;
+TUPLE: store insn# ;
+
+: new-action ( class -- action )
+    insn# get swap boa ; inline
+
+! Maps vreg -> slot# -> sequence of loads/stores
+SYMBOL: histories
+
+: history ( vreg -- history ) histories get at ;
+
+: set-ac ( vreg ac -- )
+    #! Set alias class of newly-seen vreg.
+    {
+        [ drop H{ } clone swap histories get set-at ]
+        [ drop H{ } clone swap live-slots get set-at ]
+        [ swap vregs>acs get set-at ]
+        [ acs>vregs get push-at ]
+    } 2cleave ;
+
+: live-slot ( slot#/f vreg -- vreg' )
+    #! If the slot number is unknown, we never reuse a previous
+    #! value.
+    over [ live-slots get at at ] [ 2drop f ] if ;
+
+: load-constant-slot ( value slot# vreg -- )
+    live-slots get at check set-at ;
+
+: load-slot ( value slot#/f vreg -- )
+    over [ load-constant-slot ] [ 3drop ] if ;
+
+: record-constant-slot ( slot# vreg -- )
+    #! A load can potentially read every store of this slot#
+    #! in that alias class.
+    [
+        history [ load new-action swap ?push ] change-at
+    ] with each-alias ;
+
+: record-computed-slot ( vreg -- )
+    #! Computed load is like a load of every slot touched so far
+    [
+        history values [ load new-action swap push ] each
+    ] each-alias ;
+
+: remember-slot ( value slot#/f vreg -- )
+    over
+    [ [ record-constant-slot ] [ load-constant-slot ] 2bi ]
+    [ 2nip record-computed-slot ] if ;
+
+SYMBOL: ac-counter
+
+: next-ac ( -- n )
+    ac-counter [ dup 1+ ] change ;
+
+! Alias class for objects which are loaded from the data stack
+! or other object slots. We pessimistically assume that they
+! can all alias each other.
+SYMBOL: heap-ac
+
+: set-heap-ac ( vreg -- ) heap-ac get set-ac ;
+
+: set-new-ac ( vreg -- ) next-ac set-ac ;
+
+: kill-constant-set-slot ( slot# vreg -- )
+    [ live-slots get at delete-at ] with each-alias ;
+
+: record-constant-set-slot ( slot# vreg -- )
+    history [
+        dup empty? [ dup peek store? [ dup pop* ] when ] unless
+        store new-action swap ?push
+    ] change-at ;
+
+: kill-computed-set-slot ( ac -- )
+    [ live-slots get at clear-assoc ] each-alias ;
+
+: remember-set-slot ( slot#/f vreg -- )
+    over [
+        [ record-constant-set-slot ]
+        [ kill-constant-set-slot ] 2bi
+    ] [ nip kill-computed-set-slot ] if ;
+
+SYMBOL: copies
+
+: resolve ( vreg -- vreg )
+    dup copies get at swap or ;
+
+SYMBOL: constants
+
+: constant ( vreg -- n/f )
+    #! Return an %iconst value, or f if the vreg was not
+    #! assigned by an %iconst.
+    resolve constants get at ;
+
+! We treat slot accessors and stack traffic alike
+GENERIC: insn-slot# ( insn -- slot#/f )
+GENERIC: insn-object ( insn -- vreg )
+
+M: %peek insn-slot# n>> ;
+M: %replace insn-slot# n>> ;
+M: %%slot insn-slot# slot>> constant ;
+M: %%set-slot insn-slot# slot>> constant ;
+
+M: %peek insn-object stack>> ;
+M: %replace insn-object stack>> ;
+M: %%slot insn-object obj>> resolve ;
+M: %%set-slot insn-object obj>> resolve ;
+
+: init-alias-analysis ( -- )
+    H{ } clone histories set
+    H{ } clone vregs>acs set
+    H{ } clone acs>vregs set
+    H{ } clone live-slots set
+    H{ } clone constants set
+    H{ } clone copies set
+
+    0 ac-counter set
+    next-ac heap-ac set
+
+    %data next-ac set-ac
+    %retain next-ac set-ac ;
+
+GENERIC: analyze-aliases ( insn -- insn' )
+
+M: %iconst analyze-aliases
+    dup [ value>> ] [ out>> ] bi constants get set-at ;
+
+M: %%allot analyze-aliases
+    #! A freshly allocated object is distinct from any other
+    #! object.
+    dup out>> set-new-ac ;
+
+M: read-op analyze-aliases
+    dup out>> set-heap-ac
+    dup [ out>> ] [ insn-slot# ] [ insn-object ] tri
+    2dup live-slot dup [
+        2nip %copy boa analyze-aliases nip
+    ] [
+        drop remember-slot
+    ] if ;
+
+: idempotent? ( value slot#/f vreg -- ? )
+    #! Are we storing a value back to the same slot it was read
+    #! from?
+    live-slot = ;
+
+M: write-op analyze-aliases
+    dup
+    [ in>> resolve ] [ insn-slot# ] [ insn-object ] tri
+    3dup idempotent? [
+        2drop 2drop nop
+    ] [
+        [ remember-set-slot drop ] [ load-slot ] 3bi
+    ] if ;
+
+M: %copy analyze-aliases
+    #! The output vreg gets the same alias class as the input
+    #! vreg, since they both contain the same value.
+    dup [ in>> resolve ] [ out>> ] bi copies get set-at ;
+
+M: vop analyze-aliases ;
+
+SYMBOL: live-stores
+
+: compute-live-stores ( -- )
+    histories get
+    values [
+        values [ [ store? ] filter [ insn#>> ] map ] map concat
+    ] map concat unique
+    live-stores set ;
+
+GENERIC: eliminate-dead-store ( insn -- insn' )
+
+: (eliminate-dead-store) ( insn -- insn' )
+    dup insn-slot# [
+        insn# get live-stores get key? [
+            drop nop
+        ] unless
+    ] when ;
+
+M: %replace eliminate-dead-store
+    #! Writes to above the top of the stack can be pruned also.
+    #! This is sound since any such writes are not observable
+    #! after the basic block, and any reads of those locations
+    #! will have been converted to copies by analyze-slot,
+    #! and the final stack height of the basic block is set at
+    #! the beginning by compiler.cfg.stack.
+    dup n>> 0 < [ drop nop ] [ (eliminate-dead-store) ] if ;
+
+M: %%set-slot eliminate-dead-store (eliminate-dead-store) ;
+
+M: vop eliminate-dead-store ;
+
+: alias-analysis ( insns -- insns' )
+    init-alias-analysis
+    [ insn# set analyze-aliases ] map-index
+    compute-live-stores
+    [ insn# set eliminate-dead-store ] map-index ;

unfinished/compiler/cfg/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

unfinished/compiler/cfg/builder/builder.factor

@@ -0,0 +1,270 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel assocs sequences sequences.lib fry accessors
+compiler.cfg compiler.vops compiler.vops.builder
+namespaces math inference.dataflow optimizer.allot combinators
+math.order ;
+IN: compiler.cfg.builder
+
+! Convert dataflow IR to procedure CFG.
+! We construct the graph and set successors first, then we
+! set predecessors in a separate pass. This simplifies the
+! logic.
+
+SYMBOL: procedures
+
+SYMBOL: values>vregs
+
+SYMBOL: loop-nesting
+
+GENERIC: convert* ( node -- )
+
+GENERIC: convert ( node -- )
+
+: init-builder ( -- )
+    H{ } clone values>vregs set
+    V{ } clone loop-nesting set ;
+
+: end-basic-block ( -- )
+    basic-block get [ %b emit ] when ;
+
+: set-basic-block ( basic-block -- )
+    [ basic-block set ] [ instructions>> building set ] bi ;
+
+: begin-basic-block ( -- )
+    <basic-block> basic-block get
+    [
+        end-basic-block
+        dupd successors>> push
+    ] when*
+    set-basic-block ;
+
+: convert-nodes ( node -- )
+    dup basic-block get and [
+        [ convert ] [ successor>> convert-nodes ] bi
+    ] [ drop ] if ;
+
+: (build-cfg) ( node word -- )
+    init-builder
+    begin-basic-block
+    basic-block get swap procedures get set-at
+    %prolog emit
+    convert-nodes ;
+
+: build-cfg ( node word -- procedures )
+    H{ } clone [
+        procedures [ (build-cfg) ] with-variable
+    ] keep ;
+
+: value>vreg ( value -- vreg )
+    values>vregs get at ;
+
+: output-vreg ( value vreg -- )
+    swap values>vregs get set-at ;
+
+: produce-vreg ( value -- vreg )
+    next-vreg [ output-vreg ] keep ;
+
+: (load-inputs) ( seq stack -- )
+    over empty? [ 2drop ] [
+        [ <reversed> ] dip
+        [ '[ produce-vreg _ , %peek emit ] each-index ]
+        [ [ length neg ] dip %height emit ]
+        2bi
+    ] if ;
+
+: load-inputs ( node -- )
+    [ in-d>> %data (load-inputs) ]
+    [ in-r>> %retain (load-inputs) ]
+    bi ;
+
+: (store-outputs) ( seq stack -- )
+    over empty? [ 2drop ] [
+        [ <reversed> ] dip
+        [ [ length ] dip %height emit ]
+        [ '[ value>vreg _ , %replace emit ] each-index ]
+        2bi
+    ] if ;
+
+: store-outputs ( node -- )
+    [ out-d>> %data (store-outputs) ]
+    [ out-r>> %retain (store-outputs) ]
+    bi ;
+
+M: #push convert*
+    out-d>> [
+        [ produce-vreg ] [ value-literal ] bi
+        emit-literal
+    ] each ;
+
+M: #shuffle convert* drop ;
+
+M: #>r convert* drop ;
+
+M: #r> convert* drop ;
+
+M: node convert
+    [ load-inputs ]
+    [ convert* ]
+    [ store-outputs ]
+    tri ;
+
+: (emit-call) ( word -- )
+    begin-basic-block %call emit begin-basic-block ;
+
+: intrinsic-inputs ( node -- )
+    [ load-inputs ]
+    [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
+    bi ;
+
+: intrinsic-outputs ( node -- )
+    [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
+    [ store-outputs ]
+    bi ;
+
+: intrinsic ( node quot -- )
+    [
+        init-intrinsic
+
+        [ intrinsic-inputs ]
+        swap
+        [ intrinsic-outputs ]
+        tri
+    ] with-scope ; inline
+
+USING: kernel.private math.private slots.private
+optimizer.allot ;
+
+: maybe-emit-fixnum-shift-fast ( node -- node )
+    dup dup in-d>> second node-literal? [
+        dup dup in-d>> second node-literal
+        '[ , emit-fixnum-shift-fast ] intrinsic
+    ] [
+        dup param>> (emit-call)
+    ] if ;
+
+: emit-call ( node -- )
+    dup param>> {
+        { \ tag [ [ emit-tag ] intrinsic ] }
+
+        { \ slot [ [ dup emit-slot ] intrinsic ] }
+        { \ set-slot [ [ dup emit-set-slot ] intrinsic ] }
+
+        { \ fixnum-bitnot [ [ emit-fixnum-bitnot ] intrinsic ] }
+        { \ fixnum+fast [ [ emit-fixnum+fast ] intrinsic ] }
+        { \ fixnum-fast [ [ emit-fixnum-fast ] intrinsic ] }
+        { \ fixnum-bitand [ [ emit-fixnum-bitand ] intrinsic ] }
+        { \ fixnum-bitor [ [ emit-fixnum-bitor ] intrinsic ] }
+        { \ fixnum-bitxor [ [ emit-fixnum-bitxor ] intrinsic ] }
+        { \ fixnum*fast [ [ emit-fixnum*fast ] intrinsic ] }
+        { \ fixnum<= [ [ emit-fixnum<= ] intrinsic ] }
+        { \ fixnum>= [ [ emit-fixnum>= ] intrinsic ] }
+        { \ fixnum< [ [ emit-fixnum< ] intrinsic ] }
+        { \ fixnum> [ [ emit-fixnum> ] intrinsic ] }
+        { \ eq? [ [ emit-eq? ] intrinsic ] }
+
+        { \ fixnum-shift-fast [ maybe-emit-fixnum-shift-fast ] }
+
+        { \ float+ [ [ emit-float+ ] intrinsic ] }
+        { \ float- [ [ emit-float- ] intrinsic ] }
+        { \ float* [ [ emit-float* ] intrinsic ] }
+        { \ float/f [ [ emit-float/f ] intrinsic ] }
+        { \ float<= [ [ emit-float<= ] intrinsic ] }
+        { \ float>= [ [ emit-float>= ] intrinsic ] }
+        { \ float< [ [ emit-float< ] intrinsic ] }
+        { \ float> [ [ emit-float> ] intrinsic ] }
+        { \ float? [ [ emit-float= ] intrinsic ] }
+
+        { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
+        { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
+        { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
+
+        [ (emit-call) ]
+    } case drop ;
+
+M: #call convert emit-call ;
+
+M: #call-label convert
+    dup param>> loop-nesting get at [
+        basic-block get successors>> push
+        end-basic-block
+        basic-block off
+        drop
+    ] [
+        (emit-call)
+    ] if* ;
+
+: integer-conditional ( in1 in2 cc -- )
+    [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
+
+: float-conditional ( in1 in2 branch -- )
+    [ next-vreg [ %fcmp emit ] keep ] dip emit ; inline
+
+: emit-if ( #if -- )
+    in-d>> first value>vreg
+    next-vreg dup f emit-literal
+    cc/= integer-conditional ;
+
+: convert-nested ( node -- last-bb )
+    [
+        <basic-block>
+        [ set-basic-block ] keep
+        [ convert-nodes end-basic-block ] dip
+        basic-block get
+    ] with-scope
+    [ basic-block get successors>> push ] dip ;
+
+: convert-if-children ( #if -- )
+    children>> [ convert-nested ] map sift
+    <basic-block>
+    [ '[ , _ successors>> push ] each ]
+    [ set-basic-block ]
+    bi ;
+
+: phi-inputs ( #if -- vregs-seq )
+    children>>
+    [ last-node ] map
+    [ #values? ] filter
+    [ in-d>> [ value>vreg ] map ] map ;
+
+: phi-outputs ( #if -- vregs )
+    successor>> out-d>> [ produce-vreg ] map ;
+
+: emit-phi ( #if -- )
+    [ phi-outputs ] [ phi-inputs ] bi %phi emit ;
+
+M: #if convert
+    {
+        [ load-inputs ]
+        [ emit-if ]
+        [ convert-if-children ]
+        [ emit-phi ]
+    } cleave ;
+
+M: #values convert drop ;
+
+M: #merge convert drop ;
+
+M: #entry convert drop ;
+
+M: #declare convert drop ;
+
+M: #terminate convert drop ;
+
+M: #label convert
+    #! Labels create a new procedure.
+    [ [ param>> ] [ node-child ] bi (build-cfg) ] [ (emit-call) ] bi ;
+
+M: #loop convert
+    #! Loops become part of the current CFG.
+    begin-basic-block
+    [ param>> basic-block get 2array loop-nesting get push ]
+    [ node-child convert-nodes ]
+    bi
+    loop-nesting get pop* ;
+
+M: #return convert
+    param>> loop-nesting get key? [
+        %epilog emit
+        %return emit
+    ] unless ;

unfinished/compiler/cfg/cfg.factor

@@ -0,0 +1,47 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces assocs sequences sets fry ;
+IN: compiler.cfg
+
+! The id is a globally unique id used for fast hashcode* and
+! equal? on basic blocks. The number is assigned by
+! linearization.
+TUPLE: basic-block < identity-tuple
+id
+number
+instructions
+successors
+predecessors
+stack-frame ;
+
+SYMBOL: next-block-id
+
+: <basic-block> ( -- basic-block )
+    basic-block new
+        next-block-id counter >>id
+        V{ } clone >>instructions
+        V{ } clone >>successors
+        V{ } clone >>predecessors ;
+
+M: basic-block hashcode* id>> nip ;
+
+! Utilities
+SYMBOL: visited-blocks
+
+: visit-block ( basic-block quot -- )
+    over visited-blocks get 2dup key?
+    [ 2drop 2drop ] [ conjoin call ] if ; inline
+
+: (each-block) ( basic-block quot -- )
+    '[
+        ,
+        [ call ]
+        [ [ successors>> ] dip '[ , (each-block) ] each ]
+        2bi
+    ] visit-block ; inline
+
+: each-block ( basic-block quot -- )
+    H{ } clone visited-blocks [ (each-block) ] with-variable ; inline
+
+: copy-at ( from to assoc -- )
+    3dup nip at* [ -rot set-at drop ] [ 2drop 2drop ] if ; inline

unfinished/compiler/cfg/elaboration/elaboration.factor

@@ -0,0 +1,49 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces math layouts sequences locals
+combinators compiler.vops compiler.vops.builder
+compiler.cfg.builder ;
+IN: compiler.cfg.elaboration
+
+! This pass must run before conversion to machine IR to ensure
+! correctness.
+
+GENERIC: elaborate* ( insn -- )
+
+: slot-shift ( -- n )
+    tag-bits get cell log2 - ;
+
+:: compute-slot-known-tag ( insn -- addr )
+    { $1 $2 $3 $4 $5 } temps
+    init-intrinsic
+    $1 slot-shift %iconst emit  ! load shift offset
+    $2 insn slot>> $1 %shr emit ! shift slot by shift offset
+    $3 insn tag>> %iconst emit  ! load tag number
+    $4 $2 $3 %isub emit
+    $5 insn obj>> $4 %iadd emit ! compute slot offset
+    $5
+    ;
+
+:: compute-slot-any-tag ( insn -- addr )
+    { $1 $2 $3 $4 } temps
+    init-intrinsic
+    $1 insn obj>> emit-untag    ! untag object
+    $2 slot-shift %iconst emit  ! load shift offset
+    $3 insn slot>> $2 %shr emit ! shift slot by shift offset
+    $4 $1 $3 %iadd emit         ! compute slot offset
+    $4
+    ;
+
+: compute-slot ( insn -- addr )
+    dup tag>> [ compute-slot-known-tag ] [ compute-slot-any-tag ] if ;
+
+M: %%slot elaborate*
+    [ out>> ] [ compute-slot ] bi %load emit ;
+
+M: %%set-slot elaborate*
+    [ in>> ] [ compute-slot ] bi %store emit ;
+
+M: object elaborate* , ;
+
+: elaboration ( insns -- insns )
+    [ [ elaborate* ] each ] { } make ;

unfinished/compiler/cfg/kill-nops/kill-nops.factor

@@ -0,0 +1,9 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel compiler.vops ;
+IN: compiler.cfg.kill-nops
+
+! Smallest compiler pass ever.
+
+: kill-nops ( instructions -- instructions' )
+    [ nop? not ] filter ;

unfinished/compiler/cfg/live-ranges/live-ranges.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces assocs accessors math.order sequences
+compiler.vops ;
+IN: compiler.cfg.live-ranges
+
+TUPLE: live-range from to ;
+
+! Maps vregs to live ranges
+SYMBOL: live-ranges
+
+: def ( n vreg -- )
+    [ dup live-range boa ] dip live-ranges get set-at ;
+
+: use ( n vreg -- )
+    live-ranges get at [ max ] change-to drop ;
+
+GENERIC: compute-live-ranges* ( n insn -- )
+
+M: nullary-op compute-live-ranges*
+    2drop ;
+
+M: flushable-op compute-live-ranges*
+    out>> def ;
+
+M: effect-op compute-live-ranges*
+    in>> use ;
+
+M: unary-op compute-live-ranges*
+    [ out>> def ] [ in>> use ] 2bi ;
+
+M: binary-op compute-live-ranges*
+    [ call-next-method ] [ in1>> use ] [ in2>> use ] 2tri ;
+
+M: %store compute-live-ranges*
+    [ call-next-method ] [ addr>> use ] 2bi ;
+
+: compute-live-ranges ( insns -- )
+    H{ } clone live-ranges set
+    [ swap compute-live-ranges* ] each-index ;

unfinished/compiler/cfg/predecessors/predecessors.factor

@@ -0,0 +1,12 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.cfg kernel accessors sequences ;
+IN: compiler.cfg.predecessors
+
+! Pass to compute precedecessors.
+
+: compute-predecessors ( procedure -- )
+    [
+        dup successors>>
+        [ predecessors>> push ] with each
+    ] each-block ;

unfinished/compiler/cfg/simplifier/simplifier.factor

@@ -0,0 +1,25 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors sequences kernel
+compiler.cfg
+compiler.cfg.predecessors
+compiler.cfg.stack
+compiler.cfg.alias
+compiler.cfg.write-barrier
+compiler.cfg.elaboration
+compiler.cfg.vn
+compiler.cfg.vn.conditions
+compiler.cfg.kill-nops ;
+IN: compiler.cfg.simplifier
+
+: simplify ( insns -- insns' )
+    normalize-height
+    alias-analysis
+    elaboration
+    value-numbering
+    eliminate-write-barrier
+    kill-nops ;
+
+: simplify-cfg ( procedure -- procedure )
+    dup compute-predecessors
+    dup [ [ simplify ] change-instructions drop ] each-block ;

unfinished/compiler/cfg/stack/stack.factor

@@ -0,0 +1,42 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math namespaces sequences kernel fry
+compiler.vops ;
+IN: compiler.cfg.stack
+
+! Combine multiple stack height changes into one, done at the
+! start of the basic block.
+!
+! Alias analysis and value numbering assume this optimization
+! has been performed.
+
+! Current data and retain stack height is stored in
+! %data, %retain variables.
+GENERIC: compute-heights ( insn -- )
+
+M: %height compute-heights
+    [ n>> ] [ stack>> ] bi [ + ] change ;
+
+M: object compute-heights drop ;
+
+GENERIC: normalize-height* ( insn -- insn )
+
+M: %height normalize-height*
+    [ n>> ] [ stack>> ] bi [ swap - ] change nop ;
+
+: (normalize-height) ( insn -- insn )
+    dup stack>> get '[ , + ] change-n ; inline
+
+M: %peek normalize-height* (normalize-height) ;
+
+M: %replace normalize-height* (normalize-height) ;
+
+M: object normalize-height* ;
+
+: normalize-height ( insns -- insns' )
+    0 %data set
+    0 %retain set
+    [ [ compute-heights ] each ]
+    [ [ [ normalize-height* ] map ] with-scope ] bi
+    %data get dup zero? [ drop ] [ %data %height boa prefix ] if
+    %retain get dup zero? [ drop ] [ %retain %height boa prefix ] if ;

unfinished/compiler/cfg/summary.txt

@@ -0,0 +1 @@
+Low-level optimizer operating on control flow graph SSA IR

unfinished/compiler/cfg/vn/conditions/conditions.factor

@@ -0,0 +1,53 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences layouts accessors compiler.vops
+compiler.cfg.vn.graph
+compiler.cfg.vn.expressions
+compiler.cfg.vn.liveness
+compiler.cfg.vn ;
+IN: compiler.cfg.vn.conditions
+
+! The CFG generator produces naive code for the following code
+! sequence:
+!
+! fixnum< [ ... ] [ ... ] if
+!
+! The fixnum< comparison generates a boolean, which is then
+! tested against f.
+!
+! Using value numbering, we optimize the comparison of a boolean
+! against f where the boolean is the result of comparison.
+
+: expr-f? ( expr -- ? )
+    dup op>> %iconst eq?
+    [ value>> \ f tag-number = ] [ drop f ] if ;
+
+: comparison-with-f? ( insn -- expr/f ? )
+    #! The expr is a binary-op %icmp or %fcmp.
+    dup code>> cc/= eq? [
+        in>> vreg>vn vn>expr dup in2>> vn>expr expr-f?
+    ] [ drop f f ] if ;
+
+: of-boolean? ( expr -- expr/f ? )
+    #! The expr is a binary-op %icmp or %fcmp.
+    in1>> vn>expr dup op>> { %%iboolean %%fboolean } memq? ;
+
+: original-comparison ( expr -- in/f code/f )
+    [ in>> vn>vreg ] [ code>> ] bi ;
+
+: eliminate-boolean ( insn -- in/f code/f )
+    comparison-with-f? [
+        of-boolean? [
+            original-comparison
+        ] [ drop f f ] if
+    ] [ drop f f ] if ;
+
+M: cond-branch make-value-node
+    #! If the conditional branch is testing the result of an
+    #! earlier comparison against f, we only mark as live the
+    #! earlier comparison, so DCE will eliminate the boolean.
+    dup eliminate-boolean drop swap in>> or live-vreg ;
+ 
+M: cond-branch eliminate
+    dup eliminate-boolean dup
+    [ [ >>in ] [ >>code ] bi* ] [ 2drop ] if ;

unfinished/compiler/cfg/vn/constant-fold/constant-fold.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel compiler.vops compiler.cfg.vn.graph
+compiler.cfg.vn.expressions ;
+IN: compiler.cfg.vn.constant-fold
+
+GENERIC: constant-fold ( insn -- insn' )
+
+M: vop constant-fold ;
+
+: expr>insn ( out constant-expr -- constant-op )
+    [ value>> ] [ op>> ] bi new swap >>value swap >>out ;
+
+M: pure-op constant-fold
+    dup out>>
+    dup vreg>vn vn>expr
+    dup constant-expr? [ expr>insn nip ] [ 2drop ] if ;

unfinished/compiler/cfg/vn/expressions/expressions.factor

@@ -0,0 +1,64 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes kernel math namespaces sorting
+compiler.vops compiler.cfg.vn.graph ;
+IN: compiler.cfg.vn.expressions
+
+! Referentially-transparent expressions
+TUPLE: expr op ;
+TUPLE: nullary-expr < expr ;
+TUPLE: unary-expr < expr in ;
+TUPLE: binary-expr < expr in1 in2 ;
+TUPLE: commutative-expr < binary-expr ;
+TUPLE: boolean-expr < unary-expr code ;
+TUPLE: constant-expr < expr value ;
+TUPLE: literal-expr < unary-expr object ;
+
+! op is always %peek
+TUPLE: peek-expr < expr loc ;
+
+SYMBOL: input-expr-counter
+
+: next-input-expr ( -- n )
+    input-expr-counter [ dup 1 + ] change ;
+
+! Expressions whose values are inputs to the basic block. We
+! can eliminate a second computation having the same 'n' as
+! the first one; we can also eliminate input-exprs whose
+! result is not used.
+TUPLE: input-expr < expr n ;
+
+GENERIC: >expr ( insn -- expr )
+
+M: %literal-table >expr
+    class nullary-expr boa ;
+
+M: constant-op >expr
+    [ class ] [ value>> ] bi constant-expr boa ;
+
+M: %literal >expr
+    [ class ] [ in>> vreg>vn ] [ object>> ] tri literal-expr boa ;
+
+M: unary-op >expr
+    [ class ] [ in>> vreg>vn ] bi unary-expr boa ;
+
+M: binary-op >expr
+    [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
+    binary-expr boa ;
+
+M: commutative-op >expr
+    [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
+    sort-pair commutative-expr boa ;
+
+M: boolean-op >expr
+    [ class ] [ in>> vreg>vn ] [ code>> ] tri
+    boolean-expr boa ;
+
+M: %peek >expr
+    [ class ] [ stack-loc ] bi peek-expr boa ;
+
+M: flushable-op >expr
+    class next-input-expr input-expr boa ;
+
+: init-expressions ( -- )
+    0 input-expr-counter set ;

unfinished/compiler/cfg/vn/graph/graph.factor

@@ -0,0 +1,37 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math namespaces assocs biassocs accessors
+math.order prettyprint.backend parser ;
+IN: compiler.cfg.vn.graph
+
+TUPLE: vn n ;
+
+SYMBOL: vn-counter
+
+: next-vn ( -- vn ) vn-counter [ dup 1 + ] change vn boa ;
+
+: VN: scan-word vn boa parsed ; parsing
+
+M: vn <=> [ n>> ] compare ;
+
+M: vn pprint* \ VN: pprint-word n>> pprint* ;
+
+! biassoc mapping expressions to value numbers
+SYMBOL: exprs>vns
+
+: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
+
+: vn>expr ( vn -- expr ) exprs>vns get value-at ;
+
+SYMBOL: vregs>vns
+
+: vreg>vn ( vreg -- vn ) vregs>vns get at ;
+
+: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
+
+: set-vn ( vn vreg -- ) vregs>vns get set-at ;
+
+: init-value-graph ( -- )
+    0 vn-counter set
+    <bihash> exprs>vns set
+    <bihash> vregs>vns set ;

unfinished/compiler/cfg/vn/liveness/liveness.factor

@@ -0,0 +1,37 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces kernel assocs sets accessors compiler.vops
+compiler.cfg.vn.graph compiler.cfg.vn.expressions ;
+IN: compiler.cfg.vn.liveness
+
+! A set of VNs which are (transitively) used by effect-ops. This
+! is precisely the set of VNs whose value is needed outside of
+! the basic block.
+SYMBOL: live-vns
+
+GENERIC: live-expr ( expr -- )
+
+: live-vn ( vn -- )
+    #! Mark a VN and all VNs used in its computation as live.
+    dup live-vns get key? [ drop ] [
+        [ live-vns get conjoin ] [ vn>expr live-expr ] bi
+    ] if ;
+
+: live-vreg ( vreg -- ) vreg>vn live-vn ;
+
+M: expr live-expr drop ;
+M: literal-expr live-expr in>> live-vn ;
+M: unary-expr live-expr in>> live-vn ;
+M: binary-expr live-expr [ in1>> live-vn ] [ in2>> live-vn ] bi ;
+
+: live? ( vreg -- ? )
+    dup vreg>vn tuck vn>vreg =
+    [ live-vns get key? ] [ drop f ] if ;
+
+: init-liveness ( -- )
+    H{ } clone live-vns set ;
+
+GENERIC: eliminate ( insn -- insn' )
+
+M: flushable-op eliminate dup out>> live? ?nop ;
+M: vop eliminate ;

unfinished/compiler/cfg/vn/propagate/propagate.factor

@@ -0,0 +1,43 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs sequences kernel accessors
+compiler.vops
+compiler.cfg.vn.graph ;
+IN: compiler.cfg.vn.propagate
+
+! If two vregs compute the same value, replace references to
+! the latter with the former.
+
+: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ;
+
+GENERIC: propogate ( insn -- insn )
+
+M: effect-op propogate
+    [ resolve ] change-in ;
+
+M: unary-op propogate
+    [ resolve ] change-in ;
+
+M: binary-op propogate
+    [ resolve ] change-in1
+    [ resolve ] change-in2 ;
+
+M: %phi propogate
+    [ [ resolve ] map ] change-in ;
+
+M: %%slot propogate
+    [ resolve ] change-obj
+    [ resolve ] change-slot ;
+
+M: %%set-slot propogate
+    call-next-method
+    [ resolve ] change-obj
+    [ resolve ] change-slot ;
+
+M: %store propogate
+    call-next-method
+    [ resolve ] change-addr ;
+
+M: nullary-op propogate ;
+
+M: flushable-op propogate ;

unfinished/compiler/cfg/vn/simplify/simplify.factor

@@ -0,0 +1,220 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors combinators classes math math.order
+layouts locals
+compiler.vops
+compiler.cfg.vn.graph
+compiler.cfg.vn.expressions ;
+IN: compiler.cfg.vn.simplify
+
+! Return value of f means we didn't simplify.
+GENERIC: simplify* ( expr -- vn/expr/f )
+
+: constant ( val type -- expr ) swap constant-expr boa ;
+
+: simplify-not ( in -- vn/expr/f )
+    {
+        { [ dup constant-expr? ] [ value>> bitnot %iconst constant ] }
+        { [ dup op>> %not = ] [ in>> ] }
+        [ drop f ]
+    } cond ;
+
+: simplify-box-float ( in -- vn/expr/f )
+    {
+        { [ dup op>> %%unbox-float = ] [ in>> ] }
+        [ drop f ]
+    } cond ;
+
+: simplify-unbox-float ( in -- vn/expr/f )
+    {
+        { [ dup literal-expr? ] [ object>> %fconst constant ] }
+        { [ dup op>> %%box-float = ] [ in>> ] }
+        [ drop f ]
+    } cond ;
+
+M: unary-expr simplify*
+    #! Note the copy propagation: a %copy always simplifies to
+    #! its source vn.
+    [ in>> vn>expr ] [ op>> ] bi {
+        { %copy [ ] }
+        { %not [ simplify-not ] }
+        { %%box-float [ simplify-box-float ] }
+        { %%unbox-float [ simplify-unbox-float ] }
+        [ 2drop f ]
+    } case ;
+
+: izero? ( expr -- ? ) T{ constant-expr f %iconst 0 } = ;
+
+: ione? ( expr -- ? ) T{ constant-expr f %iconst 1 } = ;
+
+: ineg-one? ( expr -- ? ) T{ constant-expr f %iconst -1 } = ;
+
+: fzero? ( expr -- ? ) T{ constant-expr f %fconst 0 } = ;
+
+: fone? ( expr -- ? ) T{ constant-expr f %fconst 1 } = ;
+
+: fneg-one? ( expr -- ? ) T{ constant-expr f %fconst -1 } = ;
+
+: identity ( in1 in2 val type -- expr ) constant 2nip ;
+
+: constant-fold? ( in1 in2 -- ? )
+    [ constant-expr? ] both? ;
+
+:: constant-fold ( in1 in2 quot type -- expr )
+    in1 in2 constant-fold?
+    [ in1 value>> in2 value>> quot call type constant ]
+    [ f ]
+    if ; inline
+
+: simplify-iadd ( in1 in2 -- vn/expr/f )
+    {
+        { [ over izero? ] [ nip ] }
+        { [ dup izero? ] [ drop ] }
+        [ [ + ] %iconst constant-fold ]
+    } cond ;
+
+: simplify-imul ( in1 in2 -- vn/expr/f )
+    {
+        { [ over ione? ] [ nip ] }
+        { [ dup ione? ] [ drop ] }
+        [ [ * ] %iconst constant-fold ]
+    } cond ;
+
+: simplify-and ( in1 in2 -- vn/expr/f )
+    {
+        { [ dup izero? ] [ 0 %iconst identity ] }
+        { [ dup ineg-one? ] [ drop ] }
+        { [ 2dup = ] [ drop ] }
+        [ [ bitand ] %iconst constant-fold ]
+    } cond ;
+
+: simplify-or ( in1 in2 -- vn/expr/f )
+    {
+        { [ dup izero? ] [ drop ] }
+        { [ dup ineg-one? ] [ -1 %iconst identity ] }
+        { [ 2dup = ] [ drop ] }
+        [ [ bitor ] %iconst constant-fold ]
+    } cond ;
+
+: simplify-xor ( in1 in2 -- vn/expr/f )
+    {
+        { [ dup izero? ] [ drop ] }
+        [ [ bitxor ] %iconst constant-fold ]
+    } cond ;
+
+: simplify-fadd ( in1 in2 -- vn/expr/f )
+    {
+        { [ over fzero? ] [ nip ] }
+        { [ dup fzero? ] [ drop ] }
+        [ [ + ] %fconst constant-fold ]
+    } cond ;
+
+: simplify-fmul ( in1 in2 -- vn/expr/f )
+    {
+        { [ over fone? ] [ nip ] }
+        { [ dup fone? ] [ drop ] }
+        [ [ * ] %fconst constant-fold ]
+    } cond ;
+
+: commutative-operands ( expr -- in1 in2 )
+    [ in1>> vn>expr ] [ in2>> vn>expr ] bi
+    over constant-expr? [ swap ] when ;
+
+M: commutative-expr simplify*
+    [ commutative-operands ] [ op>> ] bi {
+        { %iadd [ simplify-iadd ] }
+        { %imul [ simplify-imul ] }
+        { %and [ simplify-and ] }
+        { %or [ simplify-or ] }
+        { %xor [ simplify-xor ] }
+        { %fadd [ simplify-fadd ] }
+        { %fmul [ simplify-fmul ] }
+        [ 3drop f ]
+    } case ;
+
+: simplify-isub ( in1 in2 -- vn/expr/f )
+    {
+        { [ dup izero? ] [ drop ] }
+        { [ 2dup = ] [ 0 %iconst identity ] }
+        [ [ - ] %iconst constant-fold ]
+    } cond ;
+
+: simplify-idiv ( in1 in2 -- vn/expr/f )
+    {
+        { [ dup ione? ] [ drop ] }
+        [ [ /i ] %iconst constant-fold ]
+    } cond ;
+
+: simplify-imod ( in1 in2 -- vn/expr/f )
+    {
+        { [ dup ione? ] [ 0 %iconst identity ] }
+        { [ 2dup = ] [ 0 %iconst identity ] }
+        [ [ mod ] %iconst constant-fold ]
+    } cond ;
+
+: simplify-shl ( in1 in2 -- vn/expr/f )
+    {
+        { [ dup izero? ] [ drop ] }
+        { [ over izero? ] [ drop ] }
+        [ [ shift ] %iconst constant-fold ]
+    } cond ;
+
+: unsigned ( n -- n' )
+    cell-bits 2^ 1- bitand ;
+
+: useless-shift? ( in1 in2 -- ? )
+    over op>> %shl = [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ;
+
+: simplify-shr ( in1 in2 -- vn/expr/f )
+    {
+        { [ dup izero? ] [ drop ] }
+        { [ over izero? ] [ drop ] }
+        { [ 2dup useless-shift? ] [ drop in1>> ] }
+        [ [ neg shift unsigned ] %iconst constant-fold ]
+    } cond ;
+
+: simplify-sar ( in1 in2 -- vn/expr/f )
+    {
+        { [ dup izero? ] [ drop ] }
+        { [ over izero? ] [ drop ] }
+        { [ 2dup useless-shift? ] [ drop in1>> ] }
+        [ [ neg shift ] %iconst constant-fold ]
+    } cond ;
+
+: simplify-icmp ( in1 in2 -- vn/expr/f )
+    = [ +eq+ %cconst constant ] [ f ] if ;
+
+: simplify-fsub ( in1 in2 -- vn/expr/f )
+    {
+        { [ dup izero? ] [ drop ] }
+        [ [ - ] %fconst constant-fold ]
+    } cond ;
+
+: simplify-fdiv ( in1 in2 -- vn/expr/f )
+    {
+        { [ dup fone? ] [ drop ] }
+        [ [ /i ] %fconst constant-fold ]
+    } cond ;
+
+M: binary-expr simplify*
+    [ in1>> vn>expr ] [ in2>> vn>expr ] [ op>> ] tri {
+        { %isub [ simplify-isub ] }
+        { %idiv [ simplify-idiv ] }
+        { %imod [ simplify-imod ] }
+        { %shl [ simplify-shl ] }
+        { %shr [ simplify-shr ] }
+        { %sar [ simplify-sar ] }
+        { %icmp [ simplify-icmp ] }
+        { %fsub [ simplify-fsub ] }
+        { %fdiv [ simplify-fdiv ] }
+        [ 3drop f ]
+    } case ;
+
+M: expr simplify* drop f ;
+
+: simplify ( expr -- vn )
+    dup simplify* {
+        { [ dup not ] [ drop expr>vn ] }
+        { [ dup expr? ] [ expr>vn nip ] }
+        { [ dup vn? ] [ nip ] }
+    } cond ;

unfinished/compiler/cfg/vn/vn.factor

@@ -0,0 +1,31 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs biassocs classes kernel math accessors
+sorting sets sequences compiler.vops
+compiler.cfg.vn.graph
+compiler.cfg.vn.expressions
+compiler.cfg.vn.simplify
+compiler.cfg.vn.liveness
+compiler.cfg.vn.constant-fold
+compiler.cfg.vn.propagate ;
+IN: compiler.cfg.vn
+
+: insn>vn ( insn -- vn ) >expr simplify ; inline
+
+GENERIC: make-value-node ( insn -- )
+M: flushable-op make-value-node [ insn>vn ] [ out>> ] bi set-vn ;
+M: effect-op make-value-node in>> live-vreg ;
+M: %store make-value-node [ in>> live-vreg ] [ addr>> live-vreg ] bi ;
+M: %%set-slot make-value-node [ in>> live-vreg ] [ obj>> live-vreg ] bi ;
+M: nullary-op make-value-node drop ;
+
+: init-value-numbering ( -- )
+    init-value-graph
+    init-expressions
+    init-liveness ;
+
+: value-numbering ( instructions -- instructions )
+    init-value-numbering
+    [ [ make-value-node ] each ]
+    [ [ eliminate constant-fold propogate ] map ]
+    bi ;

unfinished/compiler/cfg/write-barrier/write-barrier.factor

@@ -0,0 +1,26 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces assocs sets sequences
+compiler.vops compiler.cfg ;
+IN: compiler.cfg.write-barrier
+
+! Eliminate redundant write barrier hits.
+SYMBOL: hits
+
+GENERIC: eliminate-write-barrier* ( insn -- insn' )
+
+M: %%allot eliminate-write-barrier*
+    dup out>> hits get conjoin ;
+
+M: %write-barrier eliminate-write-barrier*
+    dup in>> hits get key?
+    [ drop nop ] [ dup in>> hits get conjoin ] if ;
+
+M: %copy eliminate-write-barrier*
+    dup in/out hits get copy-at ;
+
+M: vop eliminate-write-barrier* ;
+
+: eliminate-write-barrier ( insns -- insns )
+    H{ } clone hits set
+    [ eliminate-write-barrier* ] map ;

unfinished/compiler/frontend/frontend-docs.factor

@@ -0,0 +1,38 @@
+USING: help.markup help.syntax sequences quotations words 
+compiler.tree stack-checker.errors ;
+IN: compiler.frontend
+
+ARTICLE: "specializers" "Word specializers"
+"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class."
+$nl
+"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is either a sequence of classes, or a sequence of sequences of classes. Each element in the sequence (or the sequence itself, in the former case) is a specialization hint."
+$nl
+"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
+$nl
+"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
+$nl
+"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class."
+$nl
+"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
+{ $code
+"\\ append"
+"{ { string string } { array array } }"
+"\"specializer\" set-word-prop"
+}
+"The specialized version of a word which will be compiled by the compiler can be inspected:"
+{ $subsection specialized-def } ;
+
+HELP: dataflow
+{ $values { "quot" quotation } { "dataflow" node } }
+{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation." }
+{ $notes "This is the first stage of the compiler." }
+{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
+
+HELP: dataflow-with
+{ $values { "quot" quotation } { "stack" sequence } { "dataflow" node } }
+{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation, starting with an initial data stack of values." }
+{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
+
+HELP: specialized-def
+{ $values { "word" word } { "quot" quotation } }
+{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;

unfinished/compiler/frontend/frontend-tests.factor

@@ -0,0 +1,17 @@
+
+
+[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
+[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
+
+USE: inference.dataflow
+
+{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
+
+{ 1 0 }
+[
+    [ [ iterate-next ] iterate-nodes ] with-node-iterator
+] must-infer-as
+
+{ 1 0 } [ [ drop ] each-node ] must-infer-as
+
+{ 1 0 } [ [ ] map-children ] must-infer-as

unfinished/compiler/frontend/frontend.factor

@@ -0,0 +1,79 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors quotations kernel sequences namespaces assocs
+words generic generic.standard generic.standard.engines arrays
+kernel.private combinators vectors stack-checker
+stack-checker.state stack-checker.visitor stack-checker.errors
+stack-checker.backend compiler.tree.builder ;
+IN: compiler.frontend
+
+: with-dataflow ( quot -- dataflow )
+    [ tree-builder new dataflow-visitor set ] prepose
+    with-infer first>> ; inline
+
+GENERIC# dataflow-with 1 ( quot stack -- dataflow )
+
+M: callable dataflow-with
+    #! Not safe to call from inference transforms.
+    [
+        >vector meta-d set
+        f infer-quot
+    ] with-dataflow nip ;
+
+: dataflow ( quot -- dataflow ) f dataflow-with ;
+
+: (make-specializer) ( class picker -- quot )
+    swap "predicate" word-prop append ;
+
+: make-specializer ( classes -- quot )
+    dup length <reversed>
+    [ (picker) 2array ] 2map
+    [ drop object eq? not ] assoc-filter
+    dup empty? [ drop [ t ] ] [
+        [ (make-specializer) ] { } assoc>map
+        unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+    ] if ;
+
+: specializer-cases ( quot word -- default alist )
+    dup [ array? ] all? [ 1array ] unless [
+        [ make-specializer ] keep
+        '[ , declare ] pick append
+    ] { } map>assoc ;
+
+: method-declaration ( method -- quot )
+    dup "method-generic" word-prop dispatch# object <array>
+    swap "method-class" word-prop prefix ;
+
+: specialize-method ( quot method -- quot' )
+    method-declaration '[ , declare ] prepend ;
+
+: specialize-quot ( quot specializer -- quot' )
+    specializer-cases alist>quot ;
+
+: standard-method? ( method -- ? )
+    dup method-body? [
+        "method-generic" word-prop standard-generic?
+    ] [ drop f ] if ;
+
+: specialized-def ( word -- quot )
+    dup def>> swap {
+        { [ dup standard-method? ] [ specialize-method ] }
+        {
+            [ dup "specializer" word-prop ]
+            [ "specializer" word-prop specialize-quot ]
+        }
+        [ drop ]
+    } cond ;
+
+: word-dataflow ( word -- effect dataflow )
+    [
+        [
+            dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
+            dup "no-compile" word-prop [ cannot-infer-effect ] when
+            dup specialized-def over dup 2array 1array infer-quot
+            finish-word
+        ] maybe-cannot-infer
+    ] with-dataflow ;
+
+: specialized-length ( specializer -- n )
+    dup [ array? ] all? [ first ] when length ;

unfinished/compiler/lvops/lvops.factor

@@ -0,0 +1,21 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.lvops
+
+! Machine representation ("linear virtual operations"). Uses
+! same operations as CFG basic blocks, except edges and branches
+! are replaced by linear jumps (_b* instances).
+
+TUPLE: _label label ;
+
+! Unconditional jump to label
+TUPLE: _b label ;
+
+! Integer
+TUPLE: _bi label in code ;
+TUPLE: _bf label in code ;
+
+! Dispatch table, jumps to one of following _address
+! depending value of 'in'
+TUPLE: _dispatch in ;
+TUPLE: _address word ;

unfinished/compiler/machine/builder/builder.factor

@@ -0,0 +1,50 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math accessors sequences namespaces
+compiler.cfg compiler.vops compiler.lvops ;
+IN: compiler.machine.builder
+
+SYMBOL: block-counter
+
+: number-basic-block ( basic-block -- )
+    #! Make this fancy later.
+    dup number>> [ drop ] [
+        block-counter [ dup 1+ ] change >>number
+        [ , ] [
+            successors>> <reversed>
+            [ number-basic-block ] each
+        ] bi
+    ] if ;
+
+: flatten-basic-blocks ( procedure -- blocks )
+    [
+        0 block-counter
+        [ number-basic-block ]
+        with-variable
+    ] { } make ;
+
+GENERIC: linearize-instruction ( basic-block insn -- )
+
+M: object linearize-instruction
+    , drop ;
+
+M: %b linearize-instruction
+    drop successors>> first number>> _b emit ;
+
+: conditional-branch ( basic-block insn class -- )
+    [ successors>> ] 2dip
+    [ [ first number>> ] [ [ in>> ] [ code>> ] bi ] [ ] tri* emit ]
+    [ 2drop second number>> _b emit ]
+    3bi ; inline
+
+M: %bi linearize-instruction _bi conditional-branch ;
+M: %bf linearize-instruction _bf conditional-branch ;
+
+: build-mr ( procedure -- insns )
+    [
+        flatten-basic-blocks [
+            [ number>> _label emit ]
+            [ dup instructions>> [ linearize-instruction ] with each ]
+            bi
+        ] each
+    ] { } make ;

unfinished/compiler/machine/debug/debug.factor

@@ -0,0 +1,39 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces sequences assocs io
+prettyprint inference generator optimizer compiler.vops
+compiler.cfg.builder compiler.cfg.simplifier
+compiler.machine.builder compiler.machine.simplifier ;
+IN: compiler.machine.debug
+
+: dataflow>linear ( dataflow word -- linear )
+    [
+        init-counter
+        build-cfg
+        [ simplify-cfg build-mr simplify-mr ] assoc-map
+    ] with-scope ;
+
+: linear. ( linear -- )
+    [
+        "==== " write swap .
+        [ . ] each
+    ] assoc-each ;
+
+: linearized-quot. ( quot -- )
+    dataflow optimize
+    "Anonymous quotation" dataflow>linear
+    linear. ;
+
+: linearized-word. ( word -- )
+    dup word-dataflow nip optimize swap dataflow>linear linear. ;
+
+: >basic-block ( quot -- basic-block )
+    dataflow optimize
+    [
+        init-counter
+        "Anonymous quotation" build-cfg
+        >alist first second simplify-cfg
+    ] with-scope ;
+
+: basic-block. ( basic-block -- )
+    instructions>> [ . ] each ;

unfinished/compiler/machine/simplifier/simplifier.factor

@@ -0,0 +1,18 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces sequences.next compiler.lvops ;
+IN: compiler.machine.simplifier
+
+: useless-branch? ( next insn -- ? )
+    2dup [ _label? ] [ _b? ] bi* and
+    [ [ label>> ] bi@ = ] [ 2drop f ] if ;
+
+: simplify-mr ( insns -- insns )
+    #! Remove unconditional branches to labels immediately
+    #! following.
+    [
+        [
+            tuck useless-branch?
+            [ drop ] [ , ] if
+        ] each-next
+    ] { } make ;