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

basis/disjoint-sets/disjoint-sets-docs.factor

@@ -0,0 +1,58 @@
+IN: disjoint-sets
+USING: help.markup help.syntax kernel assocs math ;
+
+HELP: <disjoint-set>
+{ $values { "disjoint-set" disjoint-set } }
+{ $description "Creates a new disjoint set data structure with no elements." } ;
+
+HELP: add-atom
+{ $values { "a" object } { "disjoint-set" disjoint-set } }
+{ $description "Adds a new element to the disjoint set, initially only equivalent to itself." } ;
+
+HELP: equiv-set-size
+{ $values { "a" object } { "disjoint-set" disjoint-set } { "n" integer } }
+{ $description "Outputs the number of elements in the equivalence class of " { $snippet "a" } "." } ;
+
+HELP: equiv?
+{ $values { "a" object } { "b" object } { "disjoint-set" disjoint-set } { "?" "a boolean" } }
+{ $description "Tests if two elements belong to the same equivalence class." } ;
+
+HELP: equate
+{ $values { "a" object } { "b" object } { "disjoint-set" disjoint-set } }
+{ $description "Merges the equivalence classes of two elements, which must previously have been added with " { $link add-atom } "." } ;
+
+HELP: assoc>disjoint-set
+{ $values { "assoc" assoc } { "disjoint-set" disjoint-set } }
+{ $description "Given an assoc representation of a graph where the keys are vertices and key/value pairs are edges, creates a disjoint set whose elements are the keys of assoc, and two keys are equvalent if they belong to the same connected component of the graph." }
+{ $examples
+    { $example
+        "USING: disjoint-sets kernel prettyprint ;"
+        "H{ { 1 1 } { 2 1 } { 3 4 } { 4 4 } { 5 3 } } assoc>disjoint-set"
+        "1 2 pick equiv? ."
+        "4 5 pick equiv? ."
+        "1 5 pick equiv? ."
+        "drop"
+        "t\nt\nf"
+    }
+} ;
+
+ARTICLE: "disjoint-sets" "Disjoint sets"
+"The " { $emphasis "disjoint set" } " data structure, also known as " { $emphasis "union-find" } " (after the two main operations which it supports) represents a set of elements partitioned into disjoint equivalence classes, or alternatively, an equivalence relation on a set."
+$nl
+"The two main supported operations are equating two elements, which joins their equivalence classes, and checking if two elements belong to the same equivalence class. Both operations have the time complexity of the inverse Ackermann function, which for all intents and purposes is constant time."
+$nl
+"The class of disjoint sets:"
+{ $subsection disjoint-set }
+"Creating new disjoint sets:"
+{ $subsection <disjoint-set> }
+{ $subsection assoc>disjoint-set }
+"Queries:"
+{ $subsection equiv? }
+{ $subsection equiv-set-size }
+"Adding elements:"
+{ $subsection add-atom }
+"Equating elements:"
+{ $subsection equate }
+"Additionally, disjoint sets implement the " { $link clone } " generic word." ;
+
+ABOUT: "disjoint-sets"

basis/disjoint-sets/disjoint-sets.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Eric Mertens.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays hints kernel locals math hashtables
-assocs ;
+assocs fry ;
 
 IN: disjoint-sets
 
@@ -36,8 +36,6 @@ TUPLE: disjoint-set
 : representative? ( a disjoint-set -- ? )
     dupd parent = ; inline
 
-PRIVATE>
-
 GENERIC: representative ( a disjoint-set -- p )
 
 M: disjoint-set representative
@@ -45,8 +43,6 @@ M: disjoint-set representative
         [ [ parent ] keep representative dup ] 2keep set-parent
     ] if ;
 
-<PRIVATE
-
 : representatives ( a b disjoint-set -- r r )
     [ representative ] curry bi@ ; inline
 
@@ -90,3 +86,10 @@ M:: disjoint-set equate ( a b disjoint-set -- )
 M: disjoint-set clone
     [ parents>> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@
     disjoint-set boa ;
+
+: assoc>disjoint-set ( assoc -- disjoint-set )
+    <disjoint-set>
+    [ '[ drop , add-atom ] assoc-each ]
+    [ '[ , equate ] assoc-each ]
+    [ nip ]
+    2tri ;

basis/io/windows/nt/launcher/launcher-tests.factor

@@ -1,7 +1,7 @@
 IN: io.windows.launcher.nt.tests
 USING: io.launcher tools.test calendar accessors
 namespaces kernel system arrays io io.files io.encodings.ascii
-sequences parser assocs hashtables math continuations ;
+sequences parser assocs hashtables math continuations eval ;
 
 [ ] [
     <process>

basis/persistent/assocs/assocs.factor

@@ -0,0 +1,18 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs ;
+IN: persistent.assocs
+
+GENERIC: new-at ( value key assoc -- assoc' )
+
+M: assoc new-at clone [ set-at ] keep ;
+
+GENERIC: pluck-at ( key assoc -- assoc' )
+
+M: assoc pluck-at clone [ delete-at ] keep ;
+
+: changed-at ( key assoc quot -- assoc' )
+    [ [ at ] dip call ] [ drop new-at ] 3bi ; inline
+
+: conjoined ( key assoc -- assoc' )
+    dupd new-at ;

basis/persistent/assocs/summary.txt

@@ -0,0 +1 @@
+Persistent associative mapping protocol

basis/persistent/hashtables/authors.txt

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

basis/persistent/hashtables/config/config.factor

@@ -0,0 +1,8 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: layouts kernel parser math ;
+IN: persistent.hashtables.config
+
+: radix-bits ( -- n ) << cell 4 = 4 5 ? parsed >> ; foldable
+: radix-mask ( -- n ) radix-bits 2^ 1- ; foldable
+: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1- ; inline

basis/persistent/hashtables/hashtables-tests.factor

@@ -0,0 +1,110 @@
+IN: persistent.hashtables.tests
+USING: persistent.hashtables persistent.assocs hashtables assocs
+tools.test kernel namespaces random math.ranges sequences fry ;
+
+[ t ] [ PH{ } assoc-empty? ] unit-test
+
+[ PH{ { "A" "B" } } ] [ PH{ } "B" "A" rot new-at ] unit-test
+
+[ "B" ] [ "A" PH{ { "A" "B" } } at ] unit-test
+
+[ f ] [ "X" PH{ { "A" "B" } } at ] unit-test
+
+TUPLE: hash-0-a ;
+
+M: hash-0-a hashcode* 2drop 0 ;
+
+TUPLE: hash-0-b ;
+
+M: hash-0-b hashcode* 2drop 0 ;
+
+[ ] [
+    PH{ }
+    "a" T{ hash-0-a } rot new-at
+    "b" T{ hash-0-b } rot new-at
+    "ph" set
+] unit-test
+
+[
+    H{
+        { T{ hash-0-a } "a" }
+        { T{ hash-0-b } "b" }
+    }
+] [ "ph" get >hashtable ] unit-test
+ 
+[
+    H{
+        { T{ hash-0-b } "b" }
+    }
+] [ "ph" get T{ hash-0-a } swap pluck-at >hashtable ] unit-test
+
+[
+    H{
+        { T{ hash-0-a } "a" }
+    }
+] [ "ph" get T{ hash-0-b } swap pluck-at >hashtable ] unit-test
+
+[
+    H{
+        { T{ hash-0-a } "a" }
+        { T{ hash-0-b } "b" }
+    }
+] [ "ph" get "X" swap pluck-at >hashtable ] unit-test
+
+[ ] [
+    PH{ }
+    "B" "A" rot new-at
+    "D" "C" rot new-at
+    "ph" set
+] unit-test
+
+[ H{ { "A" "B" } { "C" "D" } } ] [
+    "ph" get >hashtable
+] unit-test
+
+[ H{ { "C" "D" } } ] [
+    "ph" get "A" swap pluck-at >hashtable
+] unit-test
+
+[ H{ { "A" "B" } { "C" "D" } { "E" "F" } } ] [
+    "ph" get "F" "E" rot new-at >hashtable
+] unit-test
+
+[ H{ { "C" "D" } { "E" "F" } } ] [
+    "ph" get "F" "E" rot new-at "A" swap pluck-at >hashtable
+] unit-test
+
+: random-string ( -- str )
+    1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
+
+: random-assocs ( -- hash phash )
+    [ random-string ] replicate
+    [ H{ } clone [ '[ swap , set-at ] each-index ] keep ]
+    [ PH{ } clone swap [ spin new-at ] each-index ]
+    bi ;
+
+: ok? ( assoc1 assoc2 -- ? )
+    [ assoc= ] [ [ assoc-size ] bi@ = ] 2bi and ;
+
+: test-persistent-hashtables-1 ( n -- )
+    random-assocs ok? ;
+
+[ t ] [ 10 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 20 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 30 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 50 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 100 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 500 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 1000 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 5000 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 10000 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 50000 test-persistent-hashtables-1 ] unit-test
+
+: test-persistent-hashtables-2 ( n -- )
+    random-assocs
+    dup keys [
+        [ nip over delete-at ] [ swap pluck-at nip ] 3bi
+        2dup ok?
+    ] all? 2nip ;
+
+[ t ] [ 6000 test-persistent-hashtables-2 ] unit-test

basis/persistent/hashtables/hashtables.factor

@@ -0,0 +1,48 @@
+! Based on Clojure's PersistentHashMap by Rich Hickey.
+
+USING: kernel math accessors assocs fry combinators parser
+prettyprint.backend namespaces
+persistent.assocs
+persistent.hashtables.nodes
+persistent.hashtables.nodes.empty
+persistent.hashtables.nodes.leaf
+persistent.hashtables.nodes.full
+persistent.hashtables.nodes.bitmap
+persistent.hashtables.nodes.collision ;
+IN: persistent.hashtables
+
+TUPLE: persistent-hash
+{ root read-only initial: empty-node }
+{ count fixnum read-only } ;
+
+M: persistent-hash assoc-size count>> ;
+
+M: persistent-hash at*
+     [ dup hashcode >fixnum ] [ root>> ] bi* (entry-at)
+     dup [ value>> t ] [ f ] if ;
+
+M: persistent-hash new-at ( value key assoc -- assoc' )
+    [
+        { [ 0 ] [ ] [ dup hashcode >fixnum ] [ root>> ] } spread
+        (new-at) 1 0 ?
+    ] [ count>> ] bi +
+    persistent-hash boa ;
+
+M: persistent-hash pluck-at
+    [ [ dup hashcode >fixnum ] [ root>> ] bi* (pluck-at) ] keep
+    {
+        { [ 2dup root>> eq? ] [ nip ] }
+        { [ over not ] [ 2drop T{ persistent-hash } ] }
+        [ count>> 1- persistent-hash boa ]
+    } cond ;
+
+M: persistent-hash >alist [ root>> >alist% ] { } make ;
+
+: >persistent-hash ( assoc -- phash )
+    T{ persistent-hash } swap [ spin new-at ] assoc-each ;
+
+: PH{ \ } [ >persistent-hash ] parse-literal ; parsing
+
+M: persistent-hash pprint-delims drop \ PH{ \ } ;
+
+M: persistent-hash >pprint-sequence >alist ;

basis/persistent/hashtables/nodes/bitmap/bitmap.factor

@@ -0,0 +1,86 @@
+! Based on Clojure's PersistentHashMap by Rich Hickey.
+
+USING: math math.bit-count arrays kernel accessors locals sequences
+sequences.private sequences.lib
+persistent.sequences
+persistent.hashtables.config
+persistent.hashtables.nodes ;
+IN: persistent.hashtables.nodes.bitmap
+
+: index ( bit bitmap -- n ) [ 1- ] dip bitand bit-count ; inline
+
+M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry )
+    [let* | shift [ bitmap-node shift>> ]
+            bit [ hashcode shift bitpos ]
+            bitmap [ bitmap-node bitmap>> ]
+            nodes [ bitmap-node nodes>> ] |
+       bitmap bit bitand 0 eq? [ f ] [
+           key hashcode
+           bit bitmap index nodes nth-unsafe
+           (entry-at)
+        ] if
+    ] ;
+
+M:: bitmap-node (new-at) ( shift value key hashcode bitmap-node -- node' added-leaf )
+    [let* | shift [ bitmap-node shift>> ]
+            bit [ hashcode shift bitpos ]
+            bitmap [ bitmap-node bitmap>> ]
+            idx [ bit bitmap index ]
+            nodes [ bitmap-node nodes>> ] |
+        bitmap bit bitand 0 eq? [
+            [let | new-leaf [ value key hashcode <leaf-node> ] |
+                bitmap bit bitor
+                new-leaf idx nodes insert-nth
+                shift
+                <bitmap-node>
+                new-leaf
+            ]
+        ] [
+            [let | n [ idx nodes nth ] |
+                shift radix-bits + value key hashcode n (new-at)
+                [let | new-leaf [ ] n' [ ] |
+                    n n' eq? [
+                        bitmap-node
+                    ] [
+                        bitmap
+                        n' idx nodes new-nth
+                        shift
+                        <bitmap-node>
+                    ] if
+                    new-leaf
+                ]
+            ]
+        ] if
+    ] ;
+
+M:: bitmap-node (pluck-at) ( key hashcode bitmap-node -- node' )
+    [let | bit [ hashcode bitmap-node shift>> bitpos ]
+           bitmap [ bitmap-node bitmap>> ]
+           nodes [ bitmap-node nodes>> ]
+           shift [ bitmap-node shift>> ] |
+           bit bitmap bitand 0 eq? [ bitmap-node ] [
+            [let* | idx [ bit bitmap index ]
+                    n [ idx nodes nth-unsafe ]
+                    n' [ key hashcode n (pluck-at) ] |
+                n n' eq? [
+                    bitmap-node
+                ] [
+                    n' [
+                        bitmap
+                        n' idx nodes new-nth
+                        shift
+                        <bitmap-node>
+                    ] [
+                        bitmap bit eq? [ f ] [
+                            bitmap bit bitnot bitand
+                            idx nodes remove-nth
+                            shift
+                            <bitmap-node>
+                        ] if
+                    ] if
+                ] if
+            ]
+        ] if
+    ] ;
+
+M: bitmap-node >alist% ( node -- ) nodes>> >alist-each% ;

basis/persistent/hashtables/nodes/collision/collision.factor

@@ -0,0 +1,59 @@
+! Based on Clojure's PersistentHashMap by Rich Hickey.
+
+USING: kernel accessors math arrays fry sequences sequences.lib
+locals persistent.sequences
+persistent.hashtables.config
+persistent.hashtables.nodes
+persistent.hashtables.nodes.leaf ;
+IN: persistent.hashtables.nodes.collision
+
+: find-index ( key hashcode collision-node -- n leaf-node )
+    leaves>> -rot '[ , , _ matching-key? ] find ; inline
+
+M:: collision-node (entry-at) ( key hashcode collision-node -- leaf-node )
+    key hashcode collision-node find-index nip ;
+
+M:: collision-node (pluck-at) ( key hashcode collision-node -- leaf-node )
+    hashcode collision-node hashcode>> eq? [
+        [let | idx [ key hashcode collision-node find-index drop ] |
+            idx [
+                idx collision-node leaves>> smash [
+                    collision-node hashcode>>
+                    <collision-node>
+                ] when
+            ] [ collision-node ] if
+        ]
+    ] [ collision-node ] if ;
+
+M:: collision-node (new-at) ( shift value key hashcode collision-node -- node' added-leaf )
+    hashcode collision-node hashcode>> eq? [
+        key hashcode collision-node find-index
+        [let | leaf-node [ ] idx [ ] |
+            idx [
+                value leaf-node value>> = [
+                    collision-node f
+                ] [
+                    hashcode
+                    value key hashcode <leaf-node>
+                    idx
+                    collision-node leaves>>
+                    new-nth
+                    <collision-node>
+                    f
+                ] if
+            ] [
+                [let | new-leaf-node [ value key hashcode <leaf-node> ] |
+                    hashcode
+                    collision-node leaves>>
+                    new-leaf-node
+                    suffix
+                    <collision-node>
+                    new-leaf-node
+                ]
+            ] if
+        ]
+    ] [
+        shift collision-node value key hashcode make-bitmap-node
+    ] if ;
+
+M: collision-node >alist% leaves>> >alist-each% ;

basis/persistent/hashtables/nodes/empty/empty.factor

@@ -0,0 +1,15 @@
+! Based on Clojure's PersistentHashMap by Rich Hickey.
+
+USING: accessors kernel locals persistent.hashtables.nodes ;
+IN: persistent.hashtables.nodes.empty
+
+M: empty-node (entry-at) 3drop f ;
+
+M: empty-node (pluck-at) 2nip ;
+
+M:: empty-node (new-at) ( shift value key hashcode node -- node' added-leaf )
+    value key hashcode <leaf-node> dup ;
+
+M: empty-node >alist% drop ;
+
+M: empty-node hashcode>> drop 0 ;

basis/persistent/hashtables/nodes/full/full.factor

@@ -0,0 +1,51 @@
+! Based on Clojure's PersistentHashMap by Rich Hickey.
+
+USING: math accessors kernel arrays sequences sequences.private
+locals sequences.lib
+persistent.sequences
+persistent.hashtables.config
+persistent.hashtables.nodes ;
+IN: persistent.hashtables.nodes.full
+
+M:: full-node (new-at) ( shift value key hashcode full-node -- node' added-leaf )
+    [let* | nodes [ full-node nodes>> ] 
+            idx [ hashcode full-node shift>> mask ]
+            n [ idx nodes nth-unsafe ] |
+        shift radix-bits + value key hashcode n (new-at)
+        [let | new-leaf [ ] n' [ ] |
+            n n' eq? [
+                full-node
+            ] [
+                n' idx nodes new-nth shift <full-node>
+            ] if
+            new-leaf
+        ]
+    ] ;
+
+M:: full-node (pluck-at) ( key hashcode full-node -- node' )
+    [let* | idx [ hashcode full-node shift>> mask ]
+            n [ idx full-node nodes>> nth ]
+            n' [ key hashcode n (pluck-at) ] |
+        n n' eq? [
+            full-node
+        ] [
+            n' [
+                n' idx full-node nodes>> new-nth
+                full-node shift>>
+                <full-node>
+            ] [
+                hashcode full-node shift>> bitpos bitnot full-bitmap-mask bitand
+                idx full-node nodes>> remove-nth
+                full-node shift>>
+                <bitmap-node>
+            ] if
+        ] if
+    ] ;
+
+M:: full-node (entry-at) ( key hashcode full-node -- node' )
+    key hashcode
+    hashcode full-node shift>> mask
+    full-node nodes>> nth-unsafe
+    (entry-at) ;
+
+M: full-node >alist% nodes>> >alist-each% ;

basis/persistent/hashtables/nodes/leaf/leaf.factor

@@ -0,0 +1,28 @@
+! Based on Clojure's PersistentHashMap by Rich Hickey.
+
+USING: kernel accessors locals math arrays namespaces
+persistent.hashtables.config
+persistent.hashtables.nodes ;
+IN: persistent.hashtables.nodes.leaf
+
+: matching-key? ( key hashcode leaf-node -- ? )
+    tuck hashcode>> eq? [ key>> = ] [ 2drop f ] if ; inline
+
+M: leaf-node (entry-at) [ matching-key? ] keep and ;
+
+M: leaf-node (pluck-at) [ matching-key? not ] keep and ;
+
+M:: leaf-node (new-at) ( shift value key hashcode leaf-node -- node' added-leaf )
+    hashcode leaf-node hashcode>> eq? [
+        key leaf-node key>> = [
+            value leaf-node value>> =
+            [ leaf-node f ] [ value key hashcode <leaf-node> f ] if
+        ] [
+            [let | new-leaf [ value key hashcode <leaf-node> ] |
+                hashcode leaf-node new-leaf 2array <collision-node>
+                new-leaf
+            ]
+        ] if
+    ] [ shift leaf-node value key hashcode make-bitmap-node ] if ;
+
+M: leaf-node >alist% [ key>> ] [ value>> ] bi 2array , ;

basis/persistent/hashtables/nodes/nodes.factor

@@ -0,0 +1,64 @@
+! Based on Clojure's PersistentHashMap by Rich Hickey.
+
+USING: math arrays kernel sequences sequences.lib
+accessors locals persistent.hashtables.config ;
+IN: persistent.hashtables.nodes
+
+SINGLETON: empty-node
+
+TUPLE: leaf-node
+{ value read-only }
+{ key read-only }
+{ hashcode fixnum read-only } ;
+
+C: <leaf-node> leaf-node
+
+TUPLE: collision-node
+{ hashcode fixnum read-only }
+{ leaves array read-only } ;
+
+C: <collision-node> collision-node
+
+TUPLE: full-node
+{ nodes array read-only }
+{ shift fixnum read-only }
+{ hashcode fixnum read-only } ;
+
+: <full-node> ( nodes shift -- node )
+    over first hashcode>> full-node boa ;
+
+TUPLE: bitmap-node
+{ bitmap fixnum read-only }
+{ nodes array read-only }
+{ shift fixnum read-only }
+{ hashcode fixnum read-only } ;
+
+: <bitmap-node> ( bitmap nodes shift -- node )
+    pick full-bitmap-mask =
+    [ <full-node> nip ]
+    [ over first hashcode>> bitmap-node boa ] if ;
+
+GENERIC: (entry-at) ( key hashcode node -- entry )
+
+GENERIC: (new-at) ( shift value key hashcode node -- node' added-leaf )
+
+GENERIC: (pluck-at) ( key hashcode node -- node' )
+
+GENERIC: >alist% ( node -- )
+
+: >alist-each% ( nodes -- ) [ >alist% ] each ;
+
+: mask ( hash shift -- n ) neg shift radix-mask bitand ; inline
+
+: bitpos ( hash shift -- n ) mask 2^ ; inline
+
+: smash ( idx seq -- seq/elt ? )
+    dup length 2 = [ [ 1 = ] dip first2 ? f ] [ remove-nth t ] if ; inline
+
+:: make-bitmap-node ( shift branch value key hashcode -- node' added-leaf )
+    shift value key hashcode
+    branch hashcode>> shift bitpos
+    branch 1array
+    shift
+    <bitmap-node>
+    (new-at) ; inline

basis/persistent/hashtables/summary.txt

@@ -0,0 +1 @@
+Persistent hashtables with O(1) insertion, removal and lookup

basis/persistent/heaps/heaps-docs.factor

@@ -1,5 +1,5 @@
 USING: help.syntax help.markup kernel arrays assocs ;
-IN: persistent-heaps
+IN: persistent.heaps
 
 HELP: <persistent-heap>
 { $values { "heap" "a persistent heap" } }

basis/persistent/heaps/heaps-tests.factor

@@ -1,5 +1,5 @@
-USING: persistent-heaps tools.test ;
+USING: persistent.heaps tools.test ;
-IN: persistent-heaps.tests
+IN: persistent.heaps.tests
 
 : test-input
     { { "hello" 3 } { "goodbye" 2 } { "whatever" 5 }

basis/persistent/heaps/heaps.factor

@@ -1,6 +1,6 @@
 USING: kernel accessors multi-methods locals combinators math arrays
 assocs namespaces sequences ;
-IN: persistent-heaps
+IN: persistent.heaps
 ! These are minheaps
 
 <PRIVATE

basis/persistent/heaps/tags.txt

@@ -0,0 +1 @@
+collections

basis/persistent/sequences/authors.txt

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

basis/persistent/sequences/sequences-docs.factor

@@ -0,0 +1,17 @@
+IN: persistent.sequences
+USING: help.markup help.syntax math sequences kernel ;
+
+HELP: new-nth
+{ $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." }
+{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
+
+HELP: ppush
+{ $values { "val" object } { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." }
+{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
+
+HELP: ppop
+{ $values { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." }
+{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;

basis/persistent/sequences/sequences.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel ;
+IN: persistent.sequences
+
+GENERIC: ppush ( val seq -- seq' )
+
+M: sequence ppush swap suffix ;
+
+GENERIC: ppop ( seq -- seq' )
+
+M: sequence ppop 1 head* ;
+
+GENERIC: new-nth ( val i seq -- seq' )
+
+M: sequence new-nth clone [ set-nth ] keep ;

basis/persistent/sequences/summary.txt

@@ -0,0 +1 @@
+Persistent sequence protocol

basis/persistent/sequences/tags.txt

@@ -0,0 +1 @@
+collections

basis/persistent/vectors/authors.txt

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

basis/persistent/vectors/summary.txt

@@ -0,0 +1 @@
+Immutable vectors with O(log_32 n) random access, push, and pop

basis/persistent/vectors/tags.txt

@@ -0,0 +1 @@
+collections

basis/persistent/vectors/vectors-docs.factor

@@ -1,21 +1,6 @@
 USING: help.markup help.syntax kernel math sequences ;
 IN: persistent-vectors
 
-HELP: new-nth
-{ $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } }
-{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." }
-{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
-
-HELP: ppush
-{ $values { "val" object } { "seq" sequence } { "seq'" sequence } }
-{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." }
-{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
-
-HELP: ppop
-{ $values { "seq" sequence } { "seq'" sequence } }
-{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." }
-{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
-
 HELP: PV{
 { $syntax "elements... }" }
 { $description "Parses a literal " { $link persistent-vector } "." } ;

basis/persistent/vectors/vectors-tests.factor

@@ -1,6 +1,7 @@
 IN: persistent-vectors.tests
-USING: accessors tools.test persistent-vectors sequences kernel
+USING: accessors tools.test persistent.vectors
-arrays random namespaces vectors math math.order ;
+persistent.sequences sequences kernel arrays random namespaces
+vectors math math.order ;
 
 \ new-nth must-infer
 \ ppush must-infer

basis/persistent/vectors/vectors.factor

@@ -1,8 +1,9 @@
 ! Based on Clojure's PersistentVector by Rich Hickey.
 
 USING: math accessors kernel sequences.private sequences arrays
-combinators combinators.short-circuit parser prettyprint.backend ;
+combinators combinators.short-circuit parser prettyprint.backend
-IN: persistent-vectors
+persistent.sequences ;
+IN: persistent.vectors
 
 <PRIVATE
 
@@ -12,18 +13,6 @@ PRIVATE>
 
 ERROR: empty-error pvec ;
 
-GENERIC: ppush ( val seq -- seq' )
-
-M: sequence ppush swap suffix ;
-
-GENERIC: ppop ( seq -- seq' )
-
-M: sequence ppop 1 head* ;
-
-GENERIC: new-nth ( val i seq -- seq' )
-
-M: sequence new-nth clone [ set-nth ] keep ;
-
 TUPLE: persistent-vector
 { count fixnum }
 { root node initial: T{ node f { } 1 } }

basis/windows/com/com-tests.factor

@@ -45,7 +45,7 @@ C: <test-implementation> test-implementation
     } }
     { "IUnrelated" {
         [ swap x>> + ] ! IUnrelated::xPlus
-        [ spin x>> * + ] ! IUnrealted::xMulAdd
+        [ spin x>> * + ] ! IUnrelated::xMulAdd
     } }
 } <com-wrapper>
 dup +test-wrapper+ set [

basis/windows/com/wrapper/wrapper.factor

@@ -1,11 +1,11 @@
-USING: alien alien.c-types windows.com.syntax
+USING: alien alien.c-types windows.com.syntax init
 windows.com.syntax.private windows.com continuations kernel
 namespaces windows.ole32 libc vocabs assocs accessors arrays
 sequences quotations combinators math words compiler.units
-destructors fry math.parser generalizations ;
+destructors fry math.parser generalizations sets ;
 IN: windows.com.wrapper
 
-TUPLE: com-wrapper vtbls disposed ;
+TUPLE: com-wrapper callbacks vtbls disposed ;
 
 <PRIVATE
 
@@ -14,6 +14,11 @@ SYMBOL: +wrapped-objects+
 [ H{ } +wrapped-objects+ set-global ]
 unless
 
+SYMBOL: +live-wrappers+
++live-wrappers+ get-global
+[ V{ } +live-wrappers+ set-global ]
+unless
+
 SYMBOL: +vtbl-counter+
 +vtbl-counter+ get-global
 [ 0 +vtbl-counter+ set-global ]
@@ -82,13 +87,12 @@ unless
     [ '[ ,                   [ swap 2array ] curry map ] ] bi bi*
     swap append ;
 
-: compile-alien-callback ( word return parameters abi quot -- alien )
+: compile-alien-callback ( word return parameters abi quot -- word )
     '[ , , , , alien-callback ]
     [ [ (( -- alien )) define-declared ] pick slip ]
-    with-compilation-unit
+    with-compilation-unit ;
-    execute ;
 
-: (byte-array-to-malloced-buffer) ( byte-array -- alien )
+: byte-array>malloc ( byte-array -- alien )
     [ byte-length malloc ] [ over byte-array>memory ] bi ;
 
 : (callback-word) ( function-name interface-name counter -- word )
@@ -99,7 +103,7 @@ unless
     [ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ]
     dip compose ;
 
-: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl )
+: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
     (thunk) (thunked-quots)
     swap [ find-com-interface-definition family-tree-functions ]
     keep (next-vtbl-counter) '[
@@ -114,12 +118,12 @@ unless
             first2 (finish-thunk)
         ] bi*
         "stdcall" swap compile-alien-callback
-    ] 2map >c-void*-array
+    ] 2map ;
-    (byte-array-to-malloced-buffer) ;
 
-: (make-vtbls) ( implementations -- vtbls )
+: (make-callbacks) ( implementations -- sequence )
     dup [ first ] map (make-iunknown-methods)
-    [ >r >r first2 r> r> swap (make-vtbl) ] curry map-index ;
+    [ >r >r first2 r> r> swap (make-interface-callbacks) ]
+    curry map-index ;
 
 : (malloc-wrapped-object) ( wrapper -- wrapped-object )
     vtbls>> length "void*" heap-size *
@@ -127,13 +131,34 @@ unless
     over <displaced-alien>
     1 0 rot set-ulong-nth ;
 
+: (callbacks>vtbl) ( callbacks -- vtbl )
+    [ execute ] map >c-void*-array byte-array>malloc ;
+: (callbacks>vtbls) ( callbacks -- vtbls )
+    [ (callbacks>vtbl) ] map ;
+
+: (allocate-wrapper) ( wrapper -- )
+    dup callbacks>> (callbacks>vtbls) >>vtbls
+    f >>disposed drop ;
+
+: (init-hook) ( -- )
+    +live-wrappers+ get-global [ (allocate-wrapper) ] each
+    H{ } +wrapped-objects+ set-global ;
+
+[ (init-hook) ] "windows.com.wrapper" add-init-hook
+
 PRIVATE>
 
+: allocate-wrapper ( wrapper -- )
+    [ (allocate-wrapper) ]
+    [ +live-wrappers+ get adjoin ] bi ;
+
 : <com-wrapper> ( implementations -- wrapper )
-    (make-vtbls) f com-wrapper boa ;
+    (make-callbacks) f f com-wrapper boa
+    dup allocate-wrapper ;
 
 M: com-wrapper dispose*
-    vtbls>> [ free ] each ;
+    [ [ free ] each f ] change-vtbls
+    +live-wrappers+ get-global delete ;
 
 : com-wrap ( object wrapper -- wrapped-object )
     [ vtbls>> ] [ (malloc-wrapped-object) ] bi

core/math/math-docs.factor

@@ -212,7 +212,7 @@ HELP: bit?
 
 HELP: log2
 { $values { "x" "a positive integer" } { "n" integer } }
-{ $description "Outputs the largest integer " { $snippet "n" } " such that " { $snippet "2^n" } " is less than " { $snippet "x" } "." }
+{ $description "Outputs the largest integer " { $snippet "n" } " such that " { $snippet "2^n" } " is less than or equal to " { $snippet "x" } "." }
 { $errors "Throws an error if " { $snippet "x" } " is zero or negative." } ;
 
 HELP: 1+

extra/animations/animations-docs.factor

@@ -0,0 +1,34 @@
+USING: help.markup help.syntax ;
+IN: extra.animations
+
+HELP: animate ( quot duration -- )
+{ $values
+    { "quot" "a quot which uses " { $link progress } }
+    { "duration" "a duration of time" }
+}
+{ $description { $link animate } " calls " { $link reset-progress } " , then continously calls the given quot until the duration of time has elapsed. The quot should use " { $link progress } " at least once."  }
+{ $example 
+    "USING: extra.animations calendar threads prettyprint ;"
+    "[ 1 sleep progress unparse write \" ms elapsed\" print ] 1/20 seconds animate ;"
+    "46 ms elapsed\n17 ms elapsed"
+} ;
+
+HELP: reset-progress ( -- )
+{ $description "Initiates the timer. Call this before using a loop which makes use of " { $link progress } "." } ;
+
+HELP: progress ( -- time )
+{ $values { "time" "an integer" } }
+{ $description "Gives the time elapsed since the last time this word was called, in milliseconds." }
+{ $example
+    "USING: extra.animations threads prettyprint ;"
+    "reset-progress 3 [ 1 sleep progress unparse write \"ms elapsed\" print ] times ;"
+    "31 ms elapsed\n18 ms elapsed\n16 ms elapsed"
+} ;
+
+ARTICLE: "extra.animations" "Animations"
+"Provides a lightweight framework for properly simulating continuous functions of real time. This framework helps one create animations that use rates which do not change across platforms. The speed of the computer should correlate with the smoothness of the animation, not the speed of the animation!"
+{ $subsection animate }
+{ $subsection reset-progress }
+{ $subsection progress }
+{ $link progress } " specifically provides the length of time since " { $link reset-progress } " was called, and also calls " { $link reset-progress } " as its last action. This can be directly used when one's quote runs for a specific number of iterations, instead of a length of time. If the animation is like most, and is expected to run for a specific length of time, " { $link animate } " should be used." ;
+ABOUT: "extra.animations"

extra/animations/animations.factor

@@ -0,0 +1,12 @@
+! Small library for cross-platform continuous functions of real time
+
+USING: kernel shuffle system locals
+prettyprint math io namespaces threads calendar ;
+IN: extra.animations
+
+SYMBOL: last-loop
+: reset-progress ( -- ) millis last-loop set ;
+: progress ( -- progress ) millis last-loop get - reset-progress ;
+: set-end ( duration -- end-time ) dt>milliseconds millis + ;
+: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ;
+: animate ( quot duration -- ) reset-progress set-end loop ;

extra/animations/authors.txt

@@ -0,0 +1 @@
+Reginald Keith Ford II

extra/boolean-expr/tags.txt

@@ -1 +1 @@
-demos
+

extra/bunny/cel-shaded/cel-shaded.factor

@@ -1,6 +1,6 @@
 USING: arrays bunny.model continuations destructors kernel
 multiline opengl opengl.shaders opengl.capabilities opengl.gl
-sequences sequences.lib accessors ;
+sequences sequences.lib accessors combinators ;
 IN: bunny.cel-shaded
 
 STRING: vertex-shader-source
@@ -78,13 +78,15 @@ TUPLE: bunny-cel-shaded program ;
     ] [ f ] if ;
 
 : (draw-cel-shaded-bunny) ( geom program -- )
-    {
+    [
-        { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
+        {
-        { "color"           [ 0.6 0.5 0.5 1.0 glUniform4f ] }
+            [ "light_direction" glGetUniformLocation 1.0 -1.0 1.0 glUniform3f ]
-        { "ambient"         [ 0.2 0.2 0.2 0.2 glUniform4f ] }
+            [ "color"           glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ]
-        { "diffuse"         [ 0.8 0.8 0.8 0.8 glUniform4f ] }
+            [ "ambient"         glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ]
-        { "shininess"       [ 100.0 glUniform1f ] }
+            [ "diffuse"         glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ]
-    } [ bunny-geom ] with-gl-program ;
+            [ "shininess"       glGetUniformLocation 100.0 glUniform1f ]
+        } cleave bunny-geom
+    ] with-gl-program ;
 
 M: bunny-cel-shaded draw-bunny
     program>> (draw-cel-shaded-bunny) ;

extra/bunny/outlined/outlined.factor

@@ -220,13 +220,14 @@ TUPLE: bunny-outlined
         [ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
         [ depth-texture>>  GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ]
         [
-            pass2-program>> {
+            pass2-program>> [
-                { "colormap"   [ 0 glUniform1i ] }
+                {
-                { "normalmap"  [ 1 glUniform1i ] }
+                    [ "colormap"   glGetUniformLocation 0 glUniform1i ]
-                { "depthmap"   [ 2 glUniform1i ] }
+                    [ "normalmap"  glGetUniformLocation 1 glUniform1i ]
-                { "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] }
+                    [ "depthmap"   glGetUniformLocation 2 glUniform1i ]
-            } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ]
+                    [ "line_color" glGetUniformLocation 0.1 0.0 0.1 1.0 glUniform4f ]
-            with-gl-program
+                } cleave { -1.0 -1.0 } { 1.0 1.0 } rect-vertices
+            ] with-gl-program
         ]
     } cleave ;
 

extra/cfdg/cfdg.factor

@@ -4,7 +4,8 @@ USING: kernel alien.c-types combinators namespaces arrays
        math math.functions math.vectors math.trig
        opengl.gl opengl.glu opengl ui ui.gadgets.slate
        vars colors self self.slots
-       random-weighted colors.hsv cfdg.gl accessors ;
+       random-weighted colors.hsv cfdg.gl accessors
+       ui.gadgets.handler ui.gestures assocs ui.gadgets macros ;
 
 IN: cfdg
 
@@ -130,12 +131,31 @@ VAR: threshold
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: recursive ( quot -- ) iterate? swap when ;
+: recursive ( quot -- ) iterate? swap when ; inline
 
 : multi ( seq -- ) random-weighted* call ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: [rules] ( seq -- quot )
+  [ unclip swap [ [ do ] curry ] map concat 2array ] map
+  [ call-random-weighted ] swap prefix
+  [ when ] swap prefix
+  [ iterate? ] swap append ;
+
+MACRO: rules ( seq -- quot ) [rules] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [rule] ( seq -- quot )
+  [ [ do ] swap prefix ] map concat
+  [ when ] swap prefix
+  [ iterate? ] prepend ;
+
+MACRO: rule ( seq -- quot ) [rule] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 VAR: background
 
 : set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;
@@ -155,6 +175,28 @@ VAR: start-shape
 
 : set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: dlist
+
+! : build-model-dlist ( -- )
+!   1 glGenLists dlist set
+!   dlist get GL_COMPILE_AND_EXECUTE glNewList
+!   start-shape> call
+!   glEndList ;
+
+: build-model-dlist ( -- )
+  1 glGenLists dlist set
+  dlist get GL_COMPILE_AND_EXECUTE glNewList
+
+  set-initial-color
+
+  self> set-color
+
+  start-shape> call
+      
+  glEndList ;
+
 : display ( -- )
 
   GL_PROJECTION glMatrixMode
@@ -172,15 +214,43 @@ VAR: start-shape
   init-modelview-matrix-stack
   init-color-stack
 
-  set-initial-color
+  dlist get not
+    [ build-model-dlist ]
+    [ dlist get glCallList ]
+  if ;
 
-  self> set-color
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-  start-shape> call ;
+: delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ;
 
 : cfdg-window* ( -- )
-  [ display ] closed-quot <slate>
+  C[ display ] <slate>
-  { 500 500 } over set-slate-pdim
+    { 500 500 }       >>pdim
+    C[ delete-dlist ] >>ungraft
   dup "CFDG" open-window ;
 
-: cfdg-window ( -- ) [ cfdg-window* ] with-ui ;
+: cfdg-window ( -- ) [ cfdg-window* ] with-ui ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: the-slate
+
+: rebuild ( -- ) delete-dlist the-slate get relayout-1 ;
+
+: <cfdg-gadget> ( -- slate )
+  C[ display ] <slate>
+    dup the-slate set
+    { 500 500 } >>pdim
+    C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft
+  <handler>
+    H{ } clone
+      T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at
+      T{ button-down }          C[ drop rebuild ] swap pick set-at
+    >>table ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: fry
+
+: cfdg-window. ( quot -- )
+  '[ [ @ <cfdg-gadget> "CFDG" open-window ] with-scope ] with-ui ;

extra/cfdg/models/aqua-star/aqua-star.factor

@@ -25,11 +25,12 @@ iterate? [
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: run ( -- )
+: init ( -- )
-[ -1 b ] >background
+  [ -1 b ]             >background
-{ -60 140 -120 140 } viewport set
+  { -60 140 -120 140 } >viewport
-0.1 threshold set
+  0.1                  >threshold
-[ anemone-begin ] start-shape set
+  [ anemone-begin ]    >start-shape ;
-cfdg-window ;
+
+: run ( -- ) [ init ] cfdg-window. ;
 
 MAIN: run

extra/cfdg/models/chiaroscuro/chiaroscuro.factor

@@ -5,35 +5,34 @@ USING: kernel namespaces sequences math
 
 IN: cfdg.models.chiaroscuro
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 DEFER: white
 
-: black ( -- ) iterate? [
+: black ( -- )
-  { { 60 [ [ 0.6 s circle ] do
+  {
-           [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] }
+    { 60 [ 0.6 s circle ] [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] }
-    { 1 [ white black ] } }
+    {  1 [ white black ]                                             }
-  call-random-weighted
+  }
-] when ;
+  rules ;
 
-: white ( -- ) iterate? [
+: white ( -- )
-  { { 60 [
+  {
-           [ 0.6 s circle ] do
+    { 60 [ 0.6 s circle ] [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] }
-           [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do
+    {  1 [ black white ] }
-         ] }
+  }
-    { 1 [
+  rules ;
-          black white
-        ] } }
-  call-random-weighted
-] when ;
 
-: chiaroscuro ( -- ) [ 0.5 b black ] do ;
+: chiaroscuro ( -- ) { [ 0.5 b black ] } rule ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: run ( -- )
+: init ( -- )
-[ -0.5 b ] >background
+  [ -0.5 b ]      >background
-{ -3 6 -2 6 } viewport set
+  { -3 6 -2 6 }   >viewport
-0.01 threshold set
+  0.03            >threshold  
-[ chiaroscuro ] start-shape set
+  [ chiaroscuro ] >start-shape ;
-cfdg-window ;
+
+: run ( -- ) [ init ] cfdg-window. ;
 
 MAIN: run

extra/cfdg/models/flower6/flower6.factor

@@ -18,12 +18,13 @@ iterate? [
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: run ( -- )
+: init ( -- )
-[ ] >background
+  [ ]           >background
-{ -1 2 -1 2 } viewport set
+  { -1 2 -1 2 } >viewport
-0.01 threshold set
+  0.01          >threshold
-[ flower6 ] start-shape set
+  [ flower6 ]   >start-shape ;
-cfdg-window ;
+
+: run ( -- ) [ init ] cfdg-window. ;
 
 MAIN: run
 

extra/cfdg/models/game1-turn6/game1-turn6.factor

@@ -37,11 +37,12 @@ DEFER: start
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: run ( -- )
+: init ( -- )
-[ 66 hue 0.4 sat 0.5 b ] >background
+  [ 66 hue 0.4 sat 0.5 b ] >background
-{ -5 10 -5 10 } viewport set
+  { -5 10 -5 10 }          >viewport
-0.001 >threshold
+  0.001                    >threshold
-[ start ] >start-shape
+  [ start ]                >start-shape ;
-cfdg-window ;
+
+: run ( -- ) [ init ] cfdg-window. ;
 
 MAIN: run

extra/cfdg/models/lesson/lesson.factor

@@ -96,12 +96,13 @@ iterate? [
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: run ( -- )
+: init ( -- )
-[ ] >background
+  [ ]              >background
-{ -5 25 -15 25 } viewport set
+  { -5 25 -15 25 } >viewport
-0.03 threshold set
+  0.03             >threshold
-[ toc ] start-shape set
+  [ toc ]          >start-shape ;
-cfdg-window ;
+
+: run ( -- ) [ init ] cfdg-window. ;
 
 MAIN: run
 

extra/cfdg/models/rules08/rules08.factor

@@ -51,12 +51,13 @@ DEFER: line
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: run ( -- )
+: init ( -- )
   [ -1 b ] >background
   { -20 40 -20 40 } viewport set
   [ centre ] >start-shape
-  0.0001 >threshold
+  0.0001 >threshold ;
-  cfdg-window ;
+
+: run ( -- ) [ init ] cfdg-window. ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/cfdg/models/sierpinski/sierpinski.factor

@@ -26,14 +26,12 @@ iterate? [
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: run ( -- )
+: init ( -- )
-[ ] >background
+  [ ]           >background
-{ -4 8 -4 8 } viewport set
+  { -4 8 -4 8 } >viewport
-0.01 >threshold
+  0.01          >threshold
-[ top ] >start-shape
+  [ top ]       >start-shape ;
-cfdg-window ;
-
-MAIN: run
-
 
+: run ( -- ) [ init ] cfdg-window. ;
 
+MAIN: run

extra/cfdg/models/snowflake/snowflake.factor

@@ -25,12 +25,13 @@ spike
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: run ( -- )
+: init ( -- )
-[ ] >background
+  [ ]               >background
-{ -40 80 -40 80 } viewport set
+  { -40 80 -40 80 } >viewport
-0.1 threshold set
+  0.1               >threshold
-[ snowflake ] start-shape set
+  [ snowflake ]     >start-shape ;
-cfdg-window ;
+
+: run ( -- ) [ init ] cfdg-window. ;
 
 MAIN: run
 

extra/cfdg/models/spirales/spirales.factor

@@ -0,0 +1,42 @@
+
+USING: namespaces sequences math random-weighted cfdg ;
+
+IN: cfdg.models.spirales
+
+DEFER: line
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: block ( -- )
+  [
+    [ circle ] do
+    [ 0.3 s 60 flip line ] do
+  ]
+  recursive ;
+
+: a1 ( -- )
+  [
+    [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] do
+    [ block ] do
+  ]
+  recursive ;
+
+: line ( -- )
+  -0.3 a
+  [   0 rotate a1 ] do
+  [ 120 rotate a1 ] do
+  [ 240 rotate a1 ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+  [ -1 b ] >background
+  { -20 40 -20 40 } viewport set
+  [ line ] >start-shape
+  0.03 >threshold ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: run

extra/cfdg/models/spirales/tags.txt

@@ -0,0 +1 @@
+demos

extra/csv/csv.factor

@@ -4,12 +4,16 @@
 ! Simple CSV Parser
 ! Phil Dawes phil@phildawes.net
 
-USING: kernel sequences io namespaces combinators unicode.categories vars ;
+USING: kernel sequences io namespaces combinators unicode.categories ;
 IN: csv
 
-DEFER: quoted-field
+SYMBOL: delimiter
 
-VAR: delimiter
+CHAR: , delimiter set-global
+
+: delimiter> delimiter get ; inline
+    
+DEFER: quoted-field ( -- endchar )
     
 ! trims whitespace from either end of string
 : trim-whitespace ( str -- str )
@@ -44,7 +48,7 @@ VAR: delimiter
 
 : (row) ( -- sep )
   field , 
-  dup delimiter> = [ drop (row) ] when ;
+  dup delimiter get = [ drop (row) ] when ;
 
 : row ( -- eof? array[string] )
   [ (row) ] { } make ;
@@ -55,25 +59,18 @@ VAR: delimiter
 : (csv) ( -- )
   row append-if-row-not-empty
   [ (csv) ] when ;
-
-: init-vars ( -- )
-  delimiter> [ CHAR: , >delimiter ] unless ; inline 
   
 : csv-row ( stream -- row )
-  init-vars
   [ row nip ] with-input-stream ;
 
 : csv ( stream -- rows )
-  init-vars
   [ [ (csv) ] { } make ] with-input-stream ;
 
 : with-delimiter ( char quot -- )
   delimiter swap with-variable ; inline
 
-
-    
 : needs-escaping? ( cell -- ? )
-  [ "\n\"" delimiter> suffix member? ] contains? ; inline ! "
+  [ [ "\n\"" member? ] [ delimiter get = ] bi or ] contains? ; inline ! "
 
 : escape-quotes ( cell -- cell' )
   [ [ dup , CHAR: " = [ CHAR: " , ] when ] each ] "" make ; inline
@@ -85,8 +82,7 @@ VAR: delimiter
   dup needs-escaping? [ escape-quotes enclose-in-quotes ] when ; inline
     
 : write-row ( row -- )
-  [ delimiter> write1 ] [ escape-if-required write ] interleave nl ; inline
+  [ delimiter get write1 ] [ escape-if-required write ] interleave nl ; inline
     
 : write-csv ( rows outstream -- )
-  init-vars
   [ [ write-row ] each ] with-output-stream ;

extra/demos/demos.factor

@@ -10,7 +10,7 @@ IN: demos
 : demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
 
 : <run-vocab-button> ( vocab-name -- button )
-  dup '[ drop [ , run ] call-listener ] <bevel-button> ;
+  dup '[ drop [ , run ] call-listener ] <bevel-button> { 0 0 } >>align ;
 
 : <demo-runner> ( -- gadget )
   <pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;

extra/game-input/backend/backend.factor

@@ -1,8 +1,19 @@
-USING: kernel system combinators parser ;
+USING: multiline system parser combinators ;
 IN: game-input.backend
 
-<< {
+STRING: set-backend-for-macosx
-    { [ os macosx? ] [ "game-input.backend.iokit" use+ ] }
+USING: namespaces game-input.backend.iokit game-input ;
-    { [ os windows? ] [ "game-input.backend.dinput" use+ ] }
+iokit-game-input-backend game-input-backend set-global
+;
+
+STRING: set-backend-for-windows
+USING: namespaces game-input.backend.dinput game-input ;
+dinput-game-input-backend game-input-backend set-global
+;
+
+{
+    { [ os macosx? ] [ set-backend-for-macosx eval ] }
+    { [ os windows? ] [ set-backend-for-windows eval ] }
     { [ t ] [ ] }
-} cond >>
+} cond
+

extra/game-input/backend/dinput/dinput.factor

@@ -206,6 +206,13 @@ M: dinput-game-input-backend (close-game-input)
     close-device-change-window
     delete-dinput ;
 
+M: dinput-game-input-backend (reset-game-input)
+    {
+        +dinput+ +keyboard-device+ +keyboard-state+
+        +controller-devices+ +controller-guids+
+        +device-change-window+ +device-change-handle+
+    } [ f swap set-global ] each ;
+
 M: dinput-game-input-backend get-controllers
     +controller-devices+ get
     [ drop controller boa ] { } assoc>map ;
@@ -278,5 +285,3 @@ M: dinput-game-input-backend read-keyboard
     +keyboard-device+ get
     [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
     [ ] [ f ] with-acquisition ;
-
-dinput-game-input-backend game-input-backend set-global

extra/game-input/backend/iokit/iokit.factor

@@ -231,6 +231,10 @@ M: iokit-game-input-backend (open-game-input)
         ]
     } cleave ;
 
+M: iokit-game-input-backend (reset-game-input)
+    { +hid-manager+ +keyboard-state+ +controller-states+ }
+    [ f swap set-global ] each ;
+
 M: iokit-game-input-backend (close-game-input)
     +hid-manager+ get-global [
         +hid-manager+ global [ 
@@ -271,5 +275,3 @@ M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
 
 M: iokit-game-input-backend calibrate-controller ( controller -- )
     drop ;
-
-iokit-game-input-backend game-input-backend set-global

extra/game-input/game-input.factor

@@ -1,26 +1,34 @@
 USING: arrays accessors continuations kernel symbols
-combinators.lib sequences namespaces init ;
+combinators.lib sequences namespaces init vocabs ;
 IN: game-input
 
 SYMBOLS: game-input-backend game-input-opened ;
 
 HOOK: (open-game-input)  game-input-backend ( -- )
 HOOK: (close-game-input) game-input-backend ( -- )
+HOOK: (reset-game-input) game-input-backend ( -- )
 
 : game-input-opened? ( -- ? )
     game-input-opened get ;
 
 <PRIVATE
 
+M: f (reset-game-input) ;
+
 : reset-game-input ( -- )
-    game-input-opened off ;
+    game-input-opened off
+    (reset-game-input) ;
+
+: load-game-input-backend ( -- )
+    game-input-backend get
+    [ "game-input.backend" load-vocab drop ] unless ;
 
 [ reset-game-input ] "game-input" add-init-hook
 
 PRIVATE>
 
-
 : open-game-input ( -- )
+    load-game-input-backend
     game-input-opened? [
         (open-game-input) 
         game-input-opened on

extra/html/streams/streams-tests.factor

@@ -1,6 +1,8 @@
+
 USING: html.streams html.streams.private
-io io.streams.string io.styles kernel
+       io io.streams.string io.styles kernel
-namespaces tools.test xml.writer sbufs sequences inspector ;
+       namespaces tools.test xml.writer sbufs sequences inspector colors ;
+
 IN: html.streams.tests
 
 : make-html-string
@@ -52,7 +54,7 @@ M: funky browser-link-href
 [
     [
         "car"
-        H{ { foreground { 1 0 1 1 } } }
+        H{ { foreground T{ rgba f 1 0 1 1 } } }
         format
     ] make-html-string
 ] unit-test
@@ -60,7 +62,7 @@ M: funky browser-link-href
 [ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
 [
     [
-        H{ { page-color { 1 0 1 1 } } }
+        H{ { page-color T{ rgba f 1 0 1 1 } } }
         [ "cdr" write ] with-nesting
     ] make-html-string
 ] unit-test

extra/html/streams/streams.factor

@@ -1,9 +1,11 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: generic assocs help http io io.styles io.files continuations
+
-io.streams.string kernel math math.order math.parser namespaces
+USING: combinators generic assocs help http io io.styles io.files
-quotations assocs sequences strings words html.elements
+       continuations io.streams.string kernel math math.order math.parser
-xml.entities sbufs continuations destructors accessors ;
+       namespaces quotations assocs sequences strings words html.elements
+       xml.entities sbufs continuations destructors accessors arrays ;
+
 IN: html.streams
 
 GENERIC: browser-link-href ( presented -- href )
@@ -47,9 +49,9 @@ TUPLE: html-sub-stream < html-stream style parent ;
         ] [ call ] if*
     ] [ call ] if* ; inline
 
-: hex-color, ( triplet -- )
+: hex-color, ( color -- )
-    3 head-slice
+    [ red>> ] [ green>> ] [ blue>> ] tri
-    [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
+    [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ;
 
 : fg-css, ( color -- )
     "color: #" % hex-color, "; " % ;

extra/irc/ui/ui.factor

@@ -3,12 +3,13 @@
 
 USING: accessors kernel threads combinators concurrency.mailboxes
        sequences strings hashtables splitting fry assocs hashtables colors
+       sorting qualified unicode.collation math.order
        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.packs ui.gadgets.labels
        io io.styles namespaces calendar calendar.format models continuations
        irc.client irc.client.private irc.messages irc.messages.private
-       irc.ui.commandparser irc.ui.load qualified ;
+       irc.ui.commandparser irc.ui.load ;
 
 RENAME: join sequences => sjoin
 
@@ -75,6 +76,14 @@ M: quit write-irc
     " has left IRC" dark-red write-color
     trailing>> dot-or-parens dark-red write-color ;
 
+M: kick write-irc
+    "* " dark-red write-color
+    [ prefix>> parse-name write ] keep
+    " has kicked " dark-red write-color
+    [ who>> write ] keep
+    " from the channel" dark-red write-color
+    trailing>> dot-or-parens dark-red write-color ;
+
 : full-mode ( message -- mode )
     parameters>> rest " " sjoin ;
 
@@ -86,6 +95,12 @@ M: mode write-irc
     " to " blue write-color
     channel>> write ;
 
+M: nick write-irc
+    "* " blue write-color
+    [ prefix>> parse-name write ] keep
+    " is now known as " blue write-color
+    trailing>> write ;
+
 M: unhandled write-irc
     "UNHANDLED: " write
     line>> blue write-color ;
@@ -118,15 +133,18 @@ M: irc-message write-irc
 
 GENERIC: handle-inbox ( tab message -- )
 
-: filter-participants ( pack alist val color -- pack )
+: value-labels ( assoc val -- seq )
-   '[ , = [ <label> , >>color add-gadget ] [ drop ] if ] assoc-each ;
+    '[ nip , = ] assoc-filter keys sort-strings [ <label> ] map ;
+
+: add-gadget-color ( pack seq color -- pack )
+    '[ , >>color add-gadget ] each ;
 
 : update-participants ( tab -- )
     [ userlist>> [ clear-gadget ] keep ]
     [ listener>> participants>> ] bi
-    [ +operator+ dark-green filter-participants ]
+    [ +operator+ value-labels dark-green add-gadget-color ]
-    [ +voice+ blue filter-participants ]
+    [ +voice+ value-labels blue add-gadget-color ]
-    [ +normal+ black filter-participants ] tri drop ;
+    [ +normal+ value-labels black add-gadget-color ] tri drop ;
 
 M: participant-changed handle-inbox
     drop update-participants ;

extra/joystick-demo/joystick-demo.factor

@@ -1,6 +1,6 @@
 USING: ui ui.gadgets sequences kernel arrays math colors
 ui.render math.vectors accessors fry ui.gadgets.packs game-input
-game-input.backend ui.gadgets.labels ui.gadgets.borders alarms
+ui.gadgets.labels ui.gadgets.borders alarms
 calendar locals combinators.lib strings ui.gadgets.buttons
 combinators math.parser assocs threads ;
 IN: joystick-demo

extra/key-caps/key-caps.factor

@@ -1,4 +1,4 @@
-USING: game-input game-input.backend game-input.scancodes
+USING: game-input game-input.scancodes
 kernel ui.gadgets ui.gadgets.buttons sequences accessors
 words arrays assocs math calendar fry alarms ui
 ui.gadgets.borders ui.gestures ;

extra/lisppaste/tags.txt

@@ -1,3 +1,2 @@
-demos
 web
 network

extra/log-viewer/tags.txt

@@ -1 +1 @@
-demos
+

extra/lsys/ui/ui.factor

@@ -41,7 +41,7 @@ VAR: model
 
 : display ( -- )
 
-black gl-clear
+black set-clear-color GL_COLOR_BUFFER_BIT glClear
 
 GL_FLAT glShadeModel
 
@@ -57,7 +57,9 @@ camera> do-look-at
 
 GL_FRONT_AND_BACK GL_LINE glPolygonMode
 
-white gl-color
+white color>raw glColor4d
+
+! white set-color
 
 GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
 

extra/math/bit-count/bit-count.factor

@@ -0,0 +1,38 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions quotations words sequences
+sequences.private combinators fry ;
+IN: math.bit-count
+
+<PRIVATE
+
+DEFER: byte-bit-count
+
+<<
+
+\ byte-bit-count
+256 [
+    0 swap [ [ 1+ ] when ] each-bit
+] B{ } map-as '[ HEX: ff bitand , nth-unsafe ] define-inline
+
+>>
+
+GENERIC: (bit-count) ( x -- n )
+
+M: fixnum (bit-count)
+    {
+        [           byte-bit-count ]
+        [ -8  shift byte-bit-count ]
+        [ -16 shift byte-bit-count ]
+        [ -24 shift byte-bit-count ]
+    } cleave + + + ;
+
+M: bignum (bit-count)
+    dup 0 = [ drop 0 ] [
+        [ byte-bit-count ] [ -8 shift (bit-count) ] bi +
+    ] if ;
+
+PRIVATE>
+
+: bit-count ( x -- n )
+    dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline

extra/math/derivatives/derivatives.factor

@@ -3,7 +3,8 @@
 USING: kernel math math.points math.function-tools ;
 IN: math.derivatives
 
-: small-amount ( -- n ) 1.0e-12 ;
+: small-amount ( -- n ) 1.0e-14 ;
-: near ( x -- y ) small-amount + ;
+: some-more ( x -- y ) small-amount + ;
-: derivative ( x function -- m ) 2dup [ near ] dip [ eval ] 2bi@ slope ;
+: some-less ( x -- y ) small-amount - ;
+: derivative ( x function -- m ) [ [ some-more ] dip eval ] [ [ some-less ] dip eval ] 2bi slope ;
 : derivative-func ( function -- function ) [ derivative ] curry ;

extra/math/function-tools/function-tools.factor

@@ -1,8 +1,9 @@
 ! Copyright © 2008 Reginald Keith Ford II
 ! Tools for quickly comparing, transforming, and evaluating mathematical Factor functions
 
-USING: kernel math arrays ;
+USING: kernel math arrays sequences sequences.lib ;
 IN: math.function-tools 
 : difference-func ( func func -- func ) [ bi - ] 2curry ;
 : eval ( x func -- pt ) dupd call 2array ;
+: eval-inverse ( y func -- pt ) dupd call swap 2array ;
 : eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ;

extra/math/newtons-method/newtons-method.factor

@@ -1,4 +1,4 @@
-! Copyright © 2008 Reginald Keith Ford II
+! Copyright © 2008 Reginald Keith Ford II
 ! Newton's Method of approximating roots
 
 USING: kernel math math.derivatives ;
@@ -6,6 +6,6 @@ IN: math.newtons-method
 
 <PRIVATE
 : newton-step ( x function -- x2 ) dupd [ call ] [ derivative ] 2bi / - ;
-: newton-precision ( -- n ) 7 ;
+: newton-precision ( -- n ) 13 ;
 PRIVATE>
-: newton-method ( guess function -- x ) newton-precision [ [ newton-step ] keep ] times drop ;
+: newtons-method ( guess function -- x ) newton-precision [ [ newton-step ] keep ] times drop ;

extra/math/secant-method/secant-method.factor

@@ -7,8 +7,8 @@ IN: math.secant-method
 <PRIVATE
 : secant-solution ( x1 x2 function -- solution ) [ eval ] curry bi@ linear-solution ;
 : secant-step ( x1 x2 func -- x2 x3 func ) 2dup [ secant-solution ] 2dip swapd ;
-: secant-precision ( -- n ) 11 ;
+: secant-precision ( -- n ) 15 ;
 PRIVATE>
-: secant-method ( left right function -- x ) secant-precision [ secant-step ] times drop v+ 2 v*n ;
+: secant-method ( left right function -- x ) secant-precision [ secant-step ] times drop + 2 / ;
 ! : close-enough? ( a b -- t/f ) - abs tiny-amount < ;
 ! : secant-method2 ( left right function -- x ) 2over close-enough? [ drop average ] [ secant-step secant-method ] if  ;

extra/morse/tags.txt

@@ -1 +1 @@
-demos
+example

extra/msxml-to-csv/tags.txt

@@ -1 +1 @@
-demos
+

extra/opengl/shaders/shaders-docs.factor

@@ -95,18 +95,7 @@ HELP: delete-gl-program
 { $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
 
 HELP: with-gl-program
-{ $values { "program" "A " { $link gl-program } " object" } { "uniforms" "An " { $link assoc } " between uniform parameter names and quotations with effect " { $snippet "( uniform-location -- )" } } { "quot" "A quotation" } }
+{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation with stack effect " { $snippet "( program -- )" } } }
-{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } ". Before calling " { $snippet "quot" } ", calls " { $link glGetUniformLocation } " on each key of " { $snippet "uniforms" } " to get the address of the uniform parameter, which is then placed on top of the stack as the associated quotation is called.\n\nExample:" }
+{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". " { $snippet "program" } " is left on the top of the stack when " { $snippet "quot" } " is called. The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ;
-{ $code <"
-! From bunny.cel-shaded
-: (draw-cel-shaded-bunny) ( geom program -- )
-    {
-        { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
-        { "color"           [ 0.6 0.5 0.5 1.0 glUniform4f ] }
-        { "ambient"         [ 0.2 0.2 0.2 0.2 glUniform4f ] }
-        { "diffuse"         [ 0.8 0.8 0.8 0.8 glUniform4f ] }
-        { "shininess"       [ 100.0 glUniform1f ] }
-    } [ bunny-geom ] with-gl-program ;
-"> } ;
 
 ABOUT: "gl-utilities"

extra/opengl/shaders/shaders.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel opengl.gl alien.c-types continuations namespaces
 assocs alien alien.strings libc opengl math sequences combinators
-combinators.lib macros arrays io.encodings.ascii ;
+combinators.lib macros arrays io.encodings.ascii fry ;
 IN: opengl.shaders
 
 : with-gl-shader-source-ptr ( string quot -- )
@@ -107,22 +107,8 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
         2dup detach-gl-program-shader delete-gl-shader
     ] each delete-gl-program-only ;
 
-: (with-gl-program) ( program quot -- )
+: with-gl-program ( program quot -- )
-    swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
+    over glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
-
-: (with-gl-program-uniforms) ( uniforms -- quot )
-    [ [ swap , \ glGetUniformLocation , % ] [ ] make ]
-    { } assoc>map ;
-: (make-with-gl-program) ( uniforms quot -- q )
-    [
-        \ dup ,
-        [ swap (with-gl-program-uniforms) , \ cleave , % ]
-        [ ] make ,
-        \ (with-gl-program) ,
-    ] [ ] make ;
-
-MACRO: with-gl-program ( uniforms quot -- )
-    (make-with-gl-program) ;
 
 PREDICATE: gl-program < integer (gl-program?) ;
 

extra/persistent-vectors/summary.txt

@@ -1 +0,0 @@
-Immutable vectors with O(log_32 n) random access and amortized O(1) push/pop

extra/roman/tags.txt

@@ -1 +1 @@
-demos
+

extra/sequences/lib/lib.factor

@@ -205,8 +205,11 @@ PRIVATE>
 : nths ( seq indices -- seq' )
     swap [ nth ] curry map ;
 
-: remove-nth ( seq n -- seq' )
+: remove-nth ( n seq -- seq' )
-    cut-slice rest-slice append ;
+    [ swap head-slice ] [ swap 1+ tail-slice ] 2bi append ;
+
+: insert-nth ( elt n seq -- seq' )
+    swap cut-slice [ swap 1array ] dip 3append ;
 
 : if-seq ( seq quot1 quot2 -- )
     [ f like ] 2dip if* ; inline

extra/spheres/spheres.factor

@@ -194,10 +194,9 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
 : sphere-scene ( gadget -- )
     GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
     [
-        solid-sphere-program>> dup {
+        solid-sphere-program>> [
-            { "light_position" [ 0.0 0.0 100.0 glUniform3f ] }
-        } [
             {
+                [ "light_position" glGetUniformLocation 0.0 0.0 100.0 glUniform3f ]
                 [ {  7.0  0.0  0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ]
                 [ { -7.0  0.0  0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ]
                 [ {  0.0  0.0  7.0 } 1.0 { 0.0 0.0 1.0 1.0 } (draw-sphere) ]
@@ -207,7 +206,8 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
             } cleave
         ] with-gl-program
     ] [
-        plane-program>> { } [
+        plane-program>> [
+            drop
             GL_QUADS [
                 -1000.0 -30.0  1000.0 glVertex3f
                 -1000.0 -30.0 -1000.0 glVertex3f
@@ -269,10 +269,10 @@ M: spheres-gadget draw-gadget* ( gadget -- )
         [ sphere-scene ]
         [ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ]
         [
-            texture-sphere-program>> dup {
+            texture-sphere-program>> [
-                { "surface_texture" [ 0 glUniform1i ] }
+                [ "surface_texture" glGetUniformLocation 0 glUniform1i ]
-            } [
+                [ { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ]
-                { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere)
+                bi
             ] with-gl-program
         ]
     } cleave ;

extra/taxes/tags.txt

@@ -1 +1 @@
-demos
+

extra/turing/tags.txt

@@ -1 +1 @@
-demos
+

extra/wordtimer/wordtimer-docs.factor

@@ -34,8 +34,13 @@ HELP: profile-vocab
 { $description "Annotates the words in the vocab with timing code then runs the quotation. Finally resets the words and prints the timings information."
 } ;
 
+HELP: wordtimer-call
+{ $values { "quot" "a quotation to run" } }
+{ $description "Resets the wordtimer hash and runs the quotation. After the quotation has run it prints out the timed words"
+} ;
+
     
 ARTICLE: "wordtimer" "Word Timer"
-"The " { $vocab-link "wordtimer" } " vocabulary measures accumulated execution time for words. If you just want to profile the accumulated time taken by all words in a vocab you can use " { $vocab-link "profile-vocab" } ". If you need more fine grained control then do the following: First annotate individual words with the " { $link add-timer } " word or whole vocabularies with " { $link add-timers } ". Then reset the clock with " { $link reset-word-timer } " and execute your code. Finally you can view the timings with " { $link print-word-timings } ". If you have functions that are quick and called often you may want to " { $link correct-for-timing-overhead } ". To remove all the annotations in the vocab you can use " { $link reset-vocab } ". Alternatively if you just want to time the contents of a vocabulary you can use profile-vocab." ;
+"The " { $vocab-link "wordtimer" } " vocabulary measures accumulated execution time for words. If you just want to profile the accumulated time taken by all words in a vocab you can use " { $vocab-link "profile-vocab" } ". If you need more fine grained control then do the following: First annotate individual words with the " { $link add-timer } " word or whole vocabularies with " { $link add-timers } ". Then use " { $link wordtimer-call } " to invoke a quotation and print out the timings." ;
     
 ABOUT: "wordtimer"

extra/wordtimer/wordtimer.factor

@@ -67,6 +67,12 @@ SYMBOL: *calling*
 : print-word-timings ( -- )
   *wordtimes* get-global [ swap suffix ] { } assoc>map natural-sort reverse pprint ;
 
+: wordtimer-call ( quot -- )
+  reset-word-timer 
+  [ call ] micro-time >r
+  correct-for-timing-overhead
+  "total time:" write r> pprint nl
+  print-word-timings nl ;
 
 : profile-vocab ( vocabspec quot -- )
   "annotating vocab..." print flush

extra/yahoo/tags.txt

@@ -1,2 +1 @@
-demos
 web

unfinished/compiler/tree/copy-equiv/copy-equiv.factor

@@ -8,7 +8,8 @@ compiler.tree.combinators ;
 IN: compiler.tree.copy-equiv
 
 ! Two values are copy-equivalent if they are always identical
-! at run-time ("DS" relation).
+! at run-time ("DS" relation). This is just a weak form of
+! value numbering.
 
 ! Mapping from values to their canonical leader
 SYMBOL: copies
@@ -25,7 +26,8 @@ SYMBOL: copies
         ] if
     ] ;
 
-: resolve-copy ( copy -- val ) copies get compress-path ;
+: resolve-copy ( copy -- val )
+    copies get compress-path [ "Unknown value" throw ] unless* ;
 
 : is-copy-of ( val copy -- ) copies get set-at ;
 
@@ -55,7 +57,7 @@ M: #return-recursive compute-copy-equiv*
     #! An output is a copy of every input if all inputs are
     #! copies of the same original value.
     [
-        swap [ resolve-copy ] map sift
+        swap sift [ resolve-copy ] map
         dup [ all-equal? ] [ empty? not ] bi and
         [ first swap is-copy-of ] [ 2drop ] if
     ] 2each ;

unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor

@@ -8,11 +8,9 @@ IN: compiler.tree.dataflow-analysis
 ! Dataflow analysis
 SYMBOL: work-list
 
-: look-at-value ( values -- )
+: look-at-value ( values -- ) work-list get push-front ;
-    work-list get push-front ;
 
-: look-at-values ( values -- )
+: look-at-values ( values -- ) work-list get push-all-front ;
-    work-list get '[ , push-front ] each ;
 
 : look-at-inputs ( node -- ) in-d>> look-at-values ;
 

unfinished/compiler/tree/escape-analysis/allocations/allocations.factor

@@ -1,28 +1,84 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs namespaces sequences kernel math
+USING: accessors assocs namespaces sequences kernel math
-stack-checker.state compiler.tree.copy-equiv ;
+combinators sets disjoint-sets fry stack-checker.state
+compiler.tree.copy-equiv ;
 IN: compiler.tree.escape-analysis.allocations
 
-SYMBOL: escaping
+! A map from values to one of the following:
+! - f -- initial status, assigned to values we have not seen yet;
+!        may potentially become an allocation later
+! - a sequence of values -- potentially unboxed tuple allocations
+! - t -- not allocated in this procedure, can never be unboxed
 
-! A map from values to sequences of values or 'escaping'
 SYMBOL: allocations
 
-: allocation ( value -- allocation )
+TUPLE: slot-access slot# value ;
-    resolve-copy allocations get at ;
 
-: record-allocation ( allocation value -- )
+C: <slot-access> slot-access
-    allocations get set-at ;
+
+: (allocation) ( value -- value' allocations )
+    resolve-copy allocations get ; inline
+
+: allocation ( value -- allocation )
+    (allocation) at dup slot-access? [
+        [ slot#>> ] [ value>> allocation ] bi nth
+        allocation
+    ] when ;
+
+: record-allocation ( allocation value -- ) (allocation) set-at ;
+
+: unknown-allocation ( value -- ) t swap record-allocation ;
 
 : record-allocations ( allocations values -- )
     [ record-allocation ] 2each ;
 
-: record-slot-access ( out slot# in -- )
+: unknown-allocations ( values -- )
-    over zero? [ 3drop ] [ allocation ?nth swap is-copy-of ] if ;
+    [ unknown-allocation ] each ;
 
-! A map from values to sequences of values
+! We track escaping values with a disjoint set.
-SYMBOL: slot-merging
+SYMBOL: escaping-values
+
+SYMBOL: +escaping+
+
+: <escaping-values> ( -- disjoint-set )
+    <disjoint-set> +escaping+ over add-atom ;
+
+: init-escaping-values ( -- )
+    copies get assoc>disjoint-set +escaping+ over add-atom
+    escaping-values set ;
+
+: <slot-value> ( -- value )
+    <value>
+    [ introduce-value ]
+    [ escaping-values get add-atom ]
+    [ ]
+    tri ;
+
+: record-slot-access ( out slot# in -- )
+    over zero? [ 3drop ] [
+        <slot-access> swap record-allocation
+    ] if ;
+
+: merge-values ( in-values out-value -- )
+    escaping-values get '[ , , equate ] each ;
 
 : merge-slots ( values -- value )
-    <value> [ introduce-value ] [ slot-merging get set-at ] [ ] tri ;
+    <slot-value> [ merge-values ] keep ;
+
+: add-escaping-values ( values -- )
+    escaping-values get
+    '[ +escaping+ , equate ] each ;
+
+: escaping-value? ( value -- ? )
+    +escaping+ escaping-values get equiv? ;
+
+SYMBOL: escaping-allocations
+
+: compute-escaping-allocations ( -- )
+    allocations get
+    [ drop escaping-value? ] assoc-filter
+    escaping-allocations set ;
+
+: escaping-allocation? ( value -- ? )
+    escaping-allocations get key? ;

unfinished/compiler/tree/escape-analysis/branches/branches.factor

@@ -1,30 +1,34 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces sequences
+USING: accessors kernel namespaces sequences sets fry
+stack-checker.branches
 compiler.tree
 compiler.tree.propagation.branches
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.branches
 
-SYMBOL: children-escape-data
-
 M: #branch escape-analysis*
     live-children sift [ (escape-analysis) ] each ;
 
 : (merge-allocations) ( values -- allocation )
     [
-        [ allocation ] map dup [ ] all? [
+        dup [ allocation ] map sift dup empty? [ 2drop f ] [
-            dup [ length ] map all-equal? [
+            dup [ t eq? not ] all? [
-                flip
+                dup [ length ] map all-equal? [
-                [ (merge-allocations) ] [ [ merge-slots ] map ] bi
+                    nip flip
-                [ record-allocations ] keep
+                    [ (merge-allocations) ] [ [ merge-slots ] map ] bi
-            ] [ drop f ] if
+                    [ record-allocations ] keep
-        ] [ drop f ] if
+                ] [ drop add-escaping-values t ] if
+            ] [ drop add-escaping-values t ] if
+        ] if
     ] map ;
 
 : merge-allocations ( in-values out-values -- )
-    [ (merge-allocations) ] dip record-allocations ;
+    [ [ sift ] map ] dip
+    [ [ merge-values ] 2each ]
+    [ [ (merge-allocations) ] dip record-allocations ]
+    2bi ;
 
 M: #phi escape-analysis*
     [ [ phi-in-d>> ] [ out-d>> ] bi merge-allocations ]

unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -0,0 +1,189 @@
+IN: compiler.tree.escape-analysis.tests
+USING: compiler.tree.escape-analysis
+compiler.tree.escape-analysis.allocations compiler.tree.builder
+compiler.tree.normalization compiler.tree.copy-equiv
+compiler.tree.propagation compiler.tree.cleanup
+compiler.tree.combinators compiler.tree sequences math
+kernel tools.test accessors slots.private quotations.private
+prettyprint classes.tuple.private classes classes.tuple ;
+
+\ escape-analysis must-infer
+
+GENERIC: count-unboxed-allocations* ( m node -- n )
+
+: (count-unboxed-allocations) ( m node -- n )
+    out-d>> first escaping-allocation? [ 1+ ] unless ;
+
+M: #call count-unboxed-allocations*
+    dup word>> \ <tuple-boa> =
+    [ (count-unboxed-allocations) ] [ drop ] if ;
+
+M: #push count-unboxed-allocations*
+    dup literal>> class immutable-tuple-class?
+    [ (count-unboxed-allocations) ] [ drop ] if ;
+
+M: node count-unboxed-allocations* drop ;
+
+: count-unboxed-allocations ( quot -- sizes )
+    build-tree
+    normalize
+    compute-copy-equiv
+    propagate
+    cleanup
+    compute-copy-equiv
+    escape-analysis
+    0 swap [ count-unboxed-allocations* ] each-node ;
+
+[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry drop ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry 3 slot ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry 3 slot drop ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry uncurry ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry call ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry call ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [ [ [ [ + ] curry ] [ drop [ ] ] if ] count-unboxed-allocations ] unit-test
+
+[ 2 ] [
+    [ [ [ + ] curry ] [ [ * ] curry ] if uncurry ] count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [ [ [ + ] curry ] [ [ * ] curry ] if ] count-unboxed-allocations
+] unit-test
+
+[ 3 ] [
+    [ [ [ + ] curry ] [ dup [ [ * ] curry ] [ [ / ] curry ] if ] if uncurry ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+    [ [ [ + ] curry 4 ] [ dup [ [ * ] curry ] [ [ / ] curry ] if uncurry ] if ] count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [ [ [ + ] curry ] [ dup [ [ * ] curry ] [ [ / ] curry ] if ] if ] count-unboxed-allocations
+] unit-test
+
+TUPLE: cons { car read-only } { cdr read-only } ;
+
+[ 0 ] [
+    [
+        dup 0 = [
+            2 cons boa
+        ] [
+            dup 1 = [
+                3 cons boa
+            ] when
+        ] if car>>
+    ] count-unboxed-allocations
+] unit-test
+
+[ 3 ] [
+    [
+        dup 0 = [
+            2 cons boa
+        ] [
+            dup 1 = [
+                3 cons boa
+            ] [
+                4 cons boa
+            ] if
+        ] if car>>
+    ] count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [
+        dup 0 = [
+            dup 1 = [
+                3 cons boa
+            ] [
+                4 cons boa
+            ] if
+        ] unless car>>
+    ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+    [
+        dup 0 = [
+            2 cons boa
+        ] [
+            dup 1 = [
+                3 cons boa
+            ] [
+                4 cons boa
+            ] if car>>
+        ] if
+    ] count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [
+        dup 0 = [
+            2 cons boa
+        ] [
+            dup 1 = [
+                3 cons boa dup .
+            ] [
+                4 cons boa
+            ] if
+        ] if drop
+    ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+    [
+        [ dup cons boa ] [ drop 1 2 cons boa ] if car>>
+    ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+    [
+        3dup
+        [ cons boa ] [ cons boa 3 cons boa ] if
+        [ car>> ] [ cdr>> ] bi
+    ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+    [
+        3dup [ cons boa ] [ cons boa . 1 2 cons boa ] if
+        [ car>> ] [ cdr>> ] bi
+    ] count-unboxed-allocations
+] unit-test
+
+[ 1 ] [
+    [ [ 3 cons boa ] [ "A" throw ] if car>> ]
+    count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [ 10 [ drop ] each-integer ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+    [
+        1 2 cons boa 10 [ 2drop 1 2 cons boa ] each-integer car>>
+    ] count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [
+        1 2 cons boa 10 [ drop 2 cons boa ] each-integer car>>
+    ] count-unboxed-allocations
+] unit-test
+
+: infinite-cons-loop ( a -- b ) 2 cons boa infinite-cons-loop ; inline recursive
+
+[ 0 ] [
+    [
+        1 2 cons boa infinite-cons-loop
+    ] count-unboxed-allocations
+] unit-test

unfinished/compiler/tree/escape-analysis/escape-analysis.factor

@@ -1,18 +1,19 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces search-dequeues
+USING: kernel namespaces search-dequeues assocs fry sequences
+disjoint-sets
 compiler.tree
 compiler.tree.def-use
+compiler.tree.copy-equiv
 compiler.tree.escape-analysis.allocations
 compiler.tree.escape-analysis.recursive
 compiler.tree.escape-analysis.branches
 compiler.tree.escape-analysis.nodes
-compiler.tree.escape-analysis.simple
+compiler.tree.escape-analysis.simple ;
-compiler.tree.escape-analysis.work-list ;
 IN: compiler.tree.escape-analysis
 
 : escape-analysis ( node -- node )
-    H{ } clone slot-merging set
+    init-escaping-values
     H{ } clone allocations set
-    <hashed-dlist> work-list set
+    dup (escape-analysis)
-    dup (escape-analysis) ;
+    compute-escaping-allocations ;

unfinished/compiler/tree/escape-analysis/recursive/recursive.factor

@@ -10,12 +10,16 @@ compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.recursive
 
 : congruent? ( alloc1 alloc2 -- ? )
-    2dup [ length ] bi@ = [
+    {
-        [ [ allocation ] bi@ congruent? ] 2all?
+        { [ 2dup [ f eq? ] either? ] [ eq? ] }
-    ] [ 2drop f ] if ;
+        { [ 2dup [ t eq? ] either? ] [ eq? ] }
+        { [ 2dup [ length ] bi@ = not ] [ 2drop f ] }
+        [ [ [ allocation ] bi@ congruent? ] 2all? ]
+    } cond ;
 
 : check-fixed-point ( node alloc1 alloc2 -- node )
-    congruent? [ dup label>> f >>fixed-point drop ] unless ; inline
+    [ congruent? ] 2all?
+    [ dup label>> f >>fixed-point drop ] unless ; inline
 
 : node-input-allocations ( node -- allocations )
     in-d>> [ allocation ] map ;
@@ -27,13 +31,18 @@ IN: compiler.tree.escape-analysis.recursive
     [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
 
 : analyze-recursive-phi ( #enter-recursive -- )
-    [ ] [ recursive-stacks flip (merge-allocations) ] [ out-d>> ] tri
+    [ ] [ recursive-stacks flip ] [ out-d>> ] tri
-    [ [ allocation ] map check-fixed-point drop ] 2keep
+    [ [ merge-values ] 2each ]
-    record-allocations ;
+    [
+        [ (merge-allocations) ] dip
+        [ [ allocation ] map check-fixed-point drop ]
+        [ record-allocations ]
+        2bi
+    ] 2bi ;
 
 M: #recursive escape-analysis* ( #recursive -- )
     [
-        copies [ clone ] change
+        ! copies [ clone ] change
 
         child>>
         [ first analyze-recursive-phi ]

unfinished/compiler/tree/escape-analysis/simple/simple.factor

@@ -2,33 +2,57 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences classes.tuple
 classes.tuple.private math math.private slots.private
-combinators dequeues search-dequeues namespaces fry
+combinators dequeues search-dequeues namespaces fry classes
+stack-checker.state
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.nodes
-compiler.tree.escape-analysis.work-list
 compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.simple
 
+M: #introduce escape-analysis*
+    value>> unknown-allocation ;
+
+: record-literal-allocation ( value object -- )
+    dup class immutable-tuple-class? [
+        tuple-slots rest-slice
+        [ <slot-value> [ swap record-literal-allocation ] keep ] map
+        swap record-allocation
+    ] [
+        drop unknown-allocation
+    ] if ;
+
+M: #push escape-analysis*
+    #! Delegation.
+    [ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
+
 : record-tuple-allocation ( #call -- )
     #! Delegation.
     dup dup in-d>> peek node-value-info literal>>
-    class>> all-slots rest-slice [ read-only>> ] all? [
+    class>> immutable-tuple-class? [
         [ in-d>> but-last ] [ out-d>> first ] bi
         record-allocation
-    ] [ drop ] if ;
+    ] [ out-d>> unknown-allocations ] if ;
 
 : record-slot-call ( #call -- )
     [ out-d>> first ]
     [ dup in-d>> second node-value-info literal>> ]
     [ in-d>> first ] tri
-    over fixnum? [ [ 3 - ] dip record-slot-access ] [ 3drop ] if ;
+    over fixnum? [
+        [ 3 - ] dip record-slot-access
+    ] [
+        2drop unknown-allocation
+    ] if ;
 
 M: #call escape-analysis*
     dup word>> {
         { \ <tuple-boa> [ record-tuple-allocation ] }
         { \ slot [ record-slot-call ] }
-        [ drop in-d>> add-escaping-values ]
+        [
+            drop
+            [ in-d>> add-escaping-values ]
+            [ out-d>> unknown-allocations ] bi
+        ]
     } case ;
 
 M: #return escape-analysis*

unfinished/compiler/tree/escape-analysis/work-list/work-list.factor

@@ -1,9 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: dequeues namespaces sequences fry ;
-IN: compiler.tree.escape-analysis.work-list
-
-SYMBOL: work-list
-
-: add-escaping-values ( values -- )
-    work-list get '[ , push-front ] each ;

unfinished/compiler/tree/propagation/branches/branches.factor

@@ -59,7 +59,7 @@ SYMBOL: infer-children-data
 
 : compute-phi-input-infos ( phi-in -- phi-info )
     infer-children-data get
-    '[ , [ [ value-info ] bind ] 2map ] map ;
+    '[ , [ [ [ value-info ] [ null-info ] if* ] bind ] 2map ] map ;
 
 : annotate-phi-inputs ( #phi -- )
     dup phi-in-d>> compute-phi-input-infos >>phi-info-d

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

@@ -536,3 +536,15 @@ M: array iterate first t ;
 [ V{ f } ] [
     [ 10 eq? [ drop 3 ] unless ] final-literals
 ] unit-test
+
+GENERIC: bad-generic ( a -- b )
+M: fixnum bad-generic 1 fixnum+fast ;
+: bad-behavior 4 bad-generic ; inline recursive
+
+[ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test
+
+[ V{ number } ] [
+    [
+        0 10 [ bad-generic dup 123 bitand drop bad-generic 1 + ] times
+    ] final-classes
+] unit-test