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

basis/disjoint-sets/disjoint-sets.factor

@@ -1,8 +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 fry ;
+assocs fry sequences ;
-
 IN: disjoint-sets
 
 TUPLE: disjoint-set
@@ -65,6 +64,8 @@ M: disjoint-set add-atom
     [ 1 -rot counts>> set-at ]
     2tri ;
 
+: add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ;
+
 GENERIC: equiv-set-size ( a disjoint-set -- n )
 
 M: disjoint-set equiv-set-size [ representative ] keep count ;

basis/persistent/hashtables/hashtables-tests.factor

@@ -10,6 +10,10 @@ tools.test kernel namespaces random math.ranges sequences fry ;
 
 [ f ] [ "X" PH{ { "A" "B" } } at ] unit-test
 
+! We have to define these first so that they're compiled before
+! the below hashtables are parsed...
+<<
+
 TUPLE: hash-0-a ;
 
 M: hash-0-a hashcode* 2drop 0 ;
@@ -18,6 +22,8 @@ TUPLE: hash-0-b ;
 
 M: hash-0-b hashcode* 2drop 0 ;
 
+>>
+
 [ ] [
     PH{ }
     "a" T{ hash-0-a } rot new-at

basis/persistent/hashtables/hashtables.factor

@@ -41,6 +41,13 @@ M: persistent-hash >alist [ root>> >alist% ] { } make ;
 : >persistent-hash ( assoc -- phash )
     T{ persistent-hash } swap [ spin new-at ] assoc-each ;
 
+M: persistent-hash equal?
+    over persistent-hash? [ assoc= ] [ 2drop f ] if ;
+
+M: persistent-hash hashcode* nip assoc-size ;
+
+M: persistent-hash clone ;
+
 : PH{ \ } [ >persistent-hash ] parse-literal ; parsing
 
 M: persistent-hash pprint-delims drop \ PH{ \ } ;

basis/persistent/sequences/sequences-docs.factor

@@ -3,15 +3,21 @@ 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" } "." }
+{ $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." }
+{ $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." }
+{ $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." } ;
+
+ARTICLE: "persistent.sequences" "Persistent sequence protocol"
+"The persistent sequence protocol consists of the non-mutating sequence protocol words, such as  " { $link length } " and " { $link nth } ", together with the following operations:"
+{ $subsection new-nth }
+{ $subsection ppush }
+{ $subsection ppop }
+"The default implementations of the above run in " { $snippet "O(n)" } " time; the " { $vocab-link "persistent.vectors" } " vocabulary provides an implementation of these operations in " { $snippet "O(1)" } " time." ;
+
+ABOUT: "persistent.sequences"

basis/persistent/vectors/vectors-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax kernel math sequences ;
-IN: persistent-vectors
+IN: persistent.vectors
 
 HELP: PV{
 { $syntax "elements... }" }
@@ -12,17 +12,11 @@ HELP: >persistent-vector
 HELP: persistent-vector
 { $class-description "The class of persistent vectors." } ;
 
-ARTICLE: "persistent-vectors" "Persistent vectors"
+ARTICLE: "persistent.vectors" "Persistent vectors"
 "A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time."
 $nl
 "The class of persistent vectors:"
 { $subsection persistent-vector }
-"Persistent vectors support the immutable sequence protocol, namely as " { $link length } " and " { $link nth } ", and so can be used with most sequence words (" { $link "sequences" } ")."
-$nl
-"In addition to standard sequence operations, persistent vectors implement efficient operations specific to them. They run in sub-linear time on persistent vectors, and degrate to linear-time algorithms on ordinary sequences:"
-{ $subsection new-nth }
-{ $subsection ppush }
-{ $subsection ppop }
 "Converting a sequence into a persistent vector:"
 { $subsection >persistent-vector }
 "Persistent vectors have a literal syntax:"
@@ -31,4 +25,4 @@ $nl
 $nl
 "This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ;
 
-ABOUT: "persistent-vectors"
+ABOUT: "persistent.vectors"

extra/24-game/24-game-docs.factor

@@ -0,0 +1,67 @@
+USING: help.markup help.syntax math kernel ;
+IN: 24-game
+
+HELP: play-game ( -- )
+{ $description "Starts the game!" }
+{ $examples
+    { $unchecked-example
+        "USE: 24-game"
+        "play-game"
+        "{ 8 2 1 2 }\n"
+        "Commands: { + - * / rot swap q }\n"
+        "swap\n"
+        "{ 8 2 2 1 }\n"
+        "Commands: { + - * / rot swap q }\n"
+        "-\n"
+        "{ 8 2 1 }\n"
+        "Commands: { + - * / rot swap q }\n"
+        "+\n"
+        "{ 8 3 }\n"
+        "Commands: { + - * / swap q }\n"
+        "*\n"
+        "You WON!"
+    }
+} ;
+
+HELP: 24-able ( -- vector )
+{ $values { "vector" "vector of 4 integers" } }
+{ $description
+    "Produces a vector with 4 integers. With the following condition: "
+    "If these integers were directly on the stack, one can process them into 24, "
+    "just using the provided commands and the 4 numbers. The Following are the "
+    "provided commands: "
+    { $link + } ", " { $link - } ", " { $link * } ", "
+    { $link / } ", and " { $link swap } "."
+}
+{ $examples
+    { $example
+        "USE: 24-game"
+        "24-able vector-24-able?"
+        "t"
+    }
+    { $notes { $link 24-able? } " is used in " { $link 24-able } "." }
+} ;
+
+HELP: 24-able? ( quad -- t/f )
+{ $values
+    { "quad" "vector of 4 integers" }
+    { "t/f" "a boolean" }
+}
+{ $description
+    "Tells if it is possible to win 24-game if it was initiated "
+    "with this sequence."
+} ;
+
+HELP: build-quad ( -- array )
+{ $values
+    { "vector" "an array of 4 numbers" }
+}
+{ $description "Builds an array of 4 random numbers." } ;
+ARTICLE: "24-game" "The Game of 24"
+"A classic math game, where one attempts to create 24, by applying "
+"arithmetical operations and some shuffle words to a stack of 4 numbers. "
+{ $subsection play-game }
+{ $subsection 24-able }
+{ $subsection 24-able? }
+{ $subsection build-quad } ;
+ABOUT: "24-game"

extra/24-game/24-game.factor

@@ -3,36 +3,60 @@
 
 USING: kernel random namespaces shuffle sequences
 parser io math prettyprint combinators continuations
-vectors words quotations accessors math.parser
+arrays words quotations accessors math.parser backtrack assocs ;
-backtrack math.ranges locals fry memoize macros assocs ;
 
 IN: 24-game
-
+SYMBOL: commands
 : nop ;
 : do-something ( a b -- c ) { + - * } amb-execute ;
 : maybe-swap ( a b -- a b ) { nop swap } amb-execute ;
 : some-rots ( a b c -- a b c )
     #! Try each permutation of 3 elements.
     { nop rot -rot swap spin swapd } amb-execute ;
-: makes-24? ( a b c d -- ? ) [ some-rots do-something some-rots do-something maybe-swap do-something 24 = ] [ 4drop ] if-amb ;
+: makes-24? ( a b c d -- ? )
-: vector-24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ;
+        [
+            2 [ some-rots do-something ] times
+            maybe-swap do-something
+            24 =
+        ]
+        [ 4drop ]
+    if-amb ;
 : q ( -- obj ) "quit" ;
-: show-commands ( -- ) "Commands: " write "commands" get unparse print ;
+: show-commands ( -- ) "Commands: " write commands get unparse print ;
 : report ( vector -- ) unparse print show-commands ;
 : give-help ( -- ) "Command not found..." print show-commands ;
 : find-word ( string choices -- word ) [ name>> = ] with find nip ;
-: obtain-word ( -- word ) readln "commands" get find-word dup [ drop give-help obtain-word ] unless ;
+: obtain-word ( -- word )
+    readln commands get find-word dup
+    [ drop give-help obtain-word ] unless ;
 : done? ( vector -- t/f ) 1 swap length = ;
-: victory? ( vector -- t/f ) V{ 24 } = ;
+: victory? ( vector -- t/f ) { 24 } = ;
-: apply-word ( vector word -- vector ) 1quotation with-datastack >vector ;
+: apply-word ( vector word -- array ) 1quotation with-datastack >array ;
-: update-commands ( vector -- ) length 3 < [ "commands" [ \ rot swap remove ] change ] [ ] if ;
+: update-commands ( vector -- )
+    length 3 <
+        [ commands [ \ rot swap remove ] change ]
+        [ ]
+    if ;
 DEFER: check-status
 : quit-game ( vector -- ) drop "you're a quitter" print ;
 : quit? ( vector -- t/f ) peek "quit" = ;
-: end-game ( vector -- ) dup victory? [ drop "You WON!" ] [ pop number>string " is not 24... You lose." append ] if print ;
+: end-game ( vector -- )
-: repeat ( vector -- ) dup report obtain-word apply-word dup update-commands check-status  ;
+    dup victory? 
-: check-status ( object -- ) dup done? [ end-game ] [ dup quit? [ quit-game ] [ repeat ] if ] if ;
+        [ drop "You WON!" ]
-: build-quad ( -- vector ) 4 [ 10 random ] replicate >vector ;
+        [ pop number>string " is not 24... You lose." append ]
-: 24-able ( -- vector ) build-quad dup vector-24-able? [ drop build-quad ] unless ;
+    if print ;
-: set-commands ( -- ) { + - * / rot swap q } "commands" set ;
+    
+! The following two words are mutually recursive,
+! providing the repl loop of the game
+: repeat ( vector -- )
+    dup report obtain-word apply-word dup update-commands check-status  ;
+: check-status ( object -- )
+    dup done?
+        [ end-game ] 
+        [ dup quit? [ quit-game ] [ repeat ] if ]
+    if ;
+: build-quad ( -- array ) 4 [ 10 random ] replicate >array ;
+: 24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ;
+: 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ;
+: set-commands ( -- ) { + - * / rot swap q } commands set ;
 : play-game ( -- ) set-commands 24-able repeat ;

extra/24-game/authors.txt

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

extra/24-game/tags.txt

@@ -1 +1,2 @@
 demos
+games

extra/boolean-expr/tags.txt

@@ -1 +1 @@
-demos
+

extra/cfdg/cfdg.factor

@@ -5,7 +5,7 @@ USING: kernel alien.c-types combinators namespaces arrays
        opengl.gl opengl.glu opengl ui ui.gadgets.slate
        vars colors self self.slots
        random-weighted colors.hsv cfdg.gl accessors
-       ui.gadgets.handler ui.gestures assocs ui.gadgets ;
+       ui.gadgets.handler ui.gestures assocs ui.gadgets macros ;
 
 IN: cfdg
 
@@ -137,6 +137,25 @@ VAR: threshold
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: [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 ;

extra/cfdg/models/chiaroscuro/chiaroscuro.factor

@@ -5,34 +5,32 @@ 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 ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : init ( -- )
   [ -0.5 b ]      >background
   { -3 6 -2 6 }   >viewport
-  0.01            >threshold
+  0.03            >threshold  
   [ chiaroscuro ] >start-shape ;
 
 : run ( -- ) [ init ] cfdg-window. ;

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

@@ -6,29 +6,35 @@ IN: cfdg.models.game1-turn6
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: f-triangles ( -- ) iterate? [
+: f-triangles ( -- )
-[ 0.1 x 0.1 y -0.33 alpha 20 hue 0.7 sat 0.8 b triangle ] do
+  {
-[ 10 hue 0.9 sat 0.33 b triangle ] do
+    [ 0.1 x 0.1 y -0.33 alpha 20 hue 0.7 sat 0.80 b triangle ]
-[ 0.9 s 10 hue 0.5 sat 1 b triangle ] do
+    [                         10 hue 0.9 sat 0.33 b triangle ]
-[ 0.8 s 5 r f-triangles ] do
+    [ 0.9 s                   10 hue 0.5 sat 1.00 b triangle ]
-] when ;
+    [ 0.8 s 5 r f-triangles ]
+  }
+  rule ;
 
-: f-squares ( -- ) iterate? [
+: f-squares ( -- )
-[ 0.1 x 0.1 y -0.33 alpha 250 hue 0.7 sat 0.8 b square ] do
+  {
-[ 220 hue 0.9 sat 0.33 b square ] do
+    [ 0.1 x 0.1 y -0.33 alpha 250 hue 0.70 sat 0.80 b square ]
-[ 0.9 s 220 hue 0.25 sat 1 b square ] do
+    [                         220 hue 0.90 sat 0.33 b square ]
-[ 0.8 s 5 r f-squares ] do
+    [ 0.9 s                   220 hue 0.25 sat 1.00 b square ]
-] when ;
+    [ 0.8 s 5 r f-squares ]
+  }
+  rule ;
 
 DEFER: start
 
-: spiral ( -- ) iterate? [
+: spiral ( -- )
-  { { 1 [ f-squares
+  {
-          [ 0.5 x 0.5 y 45 r f-triangles ] do
+    { 1 [ f-squares ]
-          [ 1 y 25 r 0.9 s spiral ] do ] }
+        [ 0.5 x 0.5 y 45 r f-triangles ]
-    { 0.022 [ [ 90 flip 50 hue start ] do ] } }
+        [ 1 y 25 r 0.9 s spiral ] }
-  call-random-weighted
+            
-] when ;
+    { 0.022 [ 90 flip 50 hue start ] }
+  }
+  rules ;
 
 : start ( -- )
   [       spiral ] do

extra/cfdg/models/rules08/rules08.factor

@@ -17,37 +17,21 @@ DEFER: line
 
 : ligne ( -- )
   {
-    { 1   [ 4.5 y 1.15 0.8 size* -0.3 b line ] do }
+    { 1   [ 4.5 y 1.15 0.8 size* -0.3 b line ] }
     { 0.5 [ ] }
   }
-  call-random-weighted ;
+  rules ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: line ( -- ) { [ insct ligne ] } rule ;
-
-: line ( -- ) [ insct ligne ] recursive ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : sole ( -- )
-  [
+  {
-    {
+    { 1    [ 1 brightness 0.5 saturation ligne ] [ 140 r 1 hue sole ] }
-      {
+    { 0.01 [ ] }
-        1 [
+  }
-            [ 1 brightness 0.5 saturation ligne ] do
+  rules ;
-            [ 140 r 1 hue                 sole  ] do
-          ]
-      }
-      { 0.01 [ ] }
-    }
-    call-random-weighted
-  ]
-  recursive ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: centre ( -- ) { [ 1 b 5 s circle ] [ sole ] } rule ;
-
-: centre ( -- )
-  [ 1 b 5 s circle ] do
-  [ sole ] do ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/cfdg/models/spirales/spirales.factor

@@ -7,33 +7,19 @@ DEFER: line
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: block ( -- )
+: block ( -- ) { [ circle ] [ 0.3 s 60 flip line ] } rule ;
-  [
-    [ circle ] do
-    [ 0.3 s 60 flip line ] do
-  ]
-  recursive ;
 
-: a1 ( -- )
+: a1 ( -- ) { [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] [ block ] } rule ;
-  [
-    [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] do
-    [ block ] do
-  ]
-  recursive ;
 
-: line ( -- )
+: line ( -- ) -0.3 a { [ 0 r a1 ] [ 120 r a1 ] [ 240 r a1 ] } rule ;
-  -0.3 a
-  [   0 rotate a1 ] do
-  [ 120 rotate a1 ] do
-  [ 240 rotate a1 ] do ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : init ( -- )
-  [ -1 b ] >background
+  [ -1 b ]          >background
-  { -20 40 -20 40 } viewport set
+  { -20 40 -20 40 } >viewport
-  [ line ] >start-shape
+  [ line ]          >start-shape
-  0.03 >threshold ;
+  0.04              >threshold ;
 
 : run ( -- ) [ init ] cfdg-window. ;
 

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,4 +1,4 @@
-USING: multiline system parser combinators ;
+USING: eval multiline system combinators ;
 IN: game-input.backend
 
 STRING: set-backend-for-macosx

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/derivatives/authors.txt

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

extra/math/function-tools/authors.txt

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

extra/math/newtons-method/authors.txt

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

extra/math/secant-method/authors.txt

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

extra/morse/tags.txt

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

extra/msxml-to-csv/tags.txt

@@ -1 +1 @@
-demos
+

extra/roman/tags.txt

@@ -1 +1 @@
-demos
+

extra/taxes/tags.txt

@@ -1 +1 @@
-demos
+

extra/turing/tags.txt

@@ -1 +1 @@
-demos
+

extra/ui/gadgets/buttons/buttons.factor

@@ -199,14 +199,11 @@ M: radio-control model-changed
 : <radio-button> ( value model label -- gadget )
     <radio-knob> label-on-right radio-button-theme <radio-control> ;
 
-: radio-buttons-theme ( gadget -- )
-    { 5 5 } >>gap drop ;
-
 : <radio-buttons> ( model assoc -- gadget )
   <filled-pile>
     -rot
     [ <radio-button> ] <radio-controls>
-  dup radio-buttons-theme ;
+  { 5 5 } >>gap ;
 
 : <toggle-button> ( value model label -- gadget )
     <radio-control> bevel-button-theme ;

extra/ui/gadgets/theme/theme.factor

@@ -18,41 +18,41 @@ IN: ui.gadgets.theme
 
 : plain-gradient
     T{ gradient f {
-        T{ rgba f 0.94 0.94 0.94 1.0 }
+        T{ gray f 0.94 1.0 }
-        T{ rgba f 0.83 0.83 0.83 1.0 }
+        T{ gray f 0.83 1.0 }
-        T{ rgba f 0.83 0.83 0.83 1.0 }
+        T{ gray f 0.83 1.0 }
-        T{ rgba f 0.62 0.62 0.62 1.0 }
+        T{ gray f 0.62 1.0 }
     } } ;
 
 : rollover-gradient
     T{ gradient f {
-        T{ rgba f 1.0 1.0 1.0 1.0 }
+        T{ gray f 1.0  1.0 }
-        T{ rgba f 0.9 0.9 0.9 1.0 }
+        T{ gray f 0.9  1.0 }
-        T{ rgba f 0.9 0.9 0.9 1.0 }
+        T{ gray f 0.9  1.0 }
-        T{ rgba f 0.75 0.75 0.75 1.0 }
+        T{ gray f 0.75 1.0 }
     } } ;
 
 : pressed-gradient
     T{ gradient f {
-        T{ rgba f 0.75 0.75 0.75 1.0 }
+        T{ gray f 0.75 1.0 }
-        T{ rgba f 0.9 0.9 0.9 1.0 }
+        T{ gray f 0.9  1.0 }
-        T{ rgba f 0.9 0.9 0.9 1.0 }
+        T{ gray f 0.9  1.0 }
-        T{ rgba f 1.0 1.0 1.0 1.0 }
+        T{ gray f 1.0  1.0 }
     } } ;
 
 : selected-gradient
     T{ gradient f {
-        T{ rgba f 0.65 0.65 0.65 1.0 }
+        T{ gray f 0.65 1.0 }
-        T{ rgba f 0.8 0.8 0.8 1.0 }
+        T{ gray f 0.8  1.0 }
-        T{ rgba f 0.8 0.8 0.8 1.0 }
+        T{ gray f 0.8  1.0 }
-        T{ rgba f 1.0 1.0 1.0 1.0 }
+        T{ gray f 1.0  1.0 }
     } } ;
 
 : lowered-gradient
     T{ gradient f {
-        T{ rgba f 0.37 0.37 0.37 1.0 }
+        T{ gray f 0.37 1.0 }
-        T{ rgba f 0.43 0.43 0.43 1.0 }
+        T{ gray f 0.43 1.0 }
-        T{ rgba f 0.5 0.5 0.5 1.0 }
+        T{ gray f 0.5  1.0 }
     } } ;
 
 : sans-serif-font { "sans-serif" plain 12 } ;

extra/yahoo/tags.txt

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

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

@@ -9,12 +9,11 @@ compiler.tree
 compiler.tree.combinators
 compiler.tree.cleanup
 compiler.tree.builder
-compiler.tree.copy-equiv
 compiler.tree.normalization
 compiler.tree.propagation ;
 
 : cleaned-up-tree ( quot -- nodes )
-    build-tree normalize compute-copy-equiv propagate cleanup ;
+    build-tree normalize propagate cleanup ;
 
 [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
 

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

@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs namespaces sequences kernel math
-combinators sets disjoint-sets fry stack-checker.state
+combinators sets disjoint-sets fry stack-checker.state ;
-compiler.tree.copy-equiv ;
 IN: compiler.tree.escape-analysis.allocations
 
 ! A map from values to one of the following:
@@ -18,7 +17,7 @@ TUPLE: slot-access slot# value ;
 C: <slot-access> slot-access
 
 : (allocation) ( value -- value' allocations )
-    resolve-copy allocations get ; inline
+    allocations get ; inline
 
 : allocation ( value -- allocation )
     (allocation) at dup slot-access? [
@@ -26,16 +25,12 @@ C: <slot-access> slot-access
         allocation
     ] when ;
 
-: record-allocation ( allocation value -- ) (allocation) set-at ;
+: record-allocation ( allocation value -- )
-
+    (allocation) set-at ;
-: unknown-allocation ( value -- ) t swap record-allocation ;
 
 : record-allocations ( allocations values -- )
     [ record-allocation ] 2each ;
 
-: unknown-allocations ( values -- )
-    [ unknown-allocation ] each ;
-
 ! We track escaping values with a disjoint set.
 SYMBOL: escaping-values
 
@@ -45,15 +40,16 @@ SYMBOL: +escaping+
     <disjoint-set> +escaping+ over add-atom ;
 
 : init-escaping-values ( -- )
-    copies get assoc>disjoint-set +escaping+ over add-atom
+    <escaping-values> escaping-values set ;
-    escaping-values set ;
+
+: introduce-value ( values -- )
+    escaping-values get add-atom ;
+
+: introduce-values ( values -- )
+    escaping-values get add-atoms ;
 
 : <slot-value> ( -- value )
-    <value>
+    <value> dup escaping-values get add-atom ;
-    [ introduce-value ]
-    [ escaping-values get add-atom ]
-    [ ]
-    tri ;
 
 : record-slot-access ( out slot# in -- )
     over zero? [ 3drop ] [
@@ -66,13 +62,41 @@ SYMBOL: +escaping+
 : merge-slots ( values -- value )
     <slot-value> [ merge-values ] keep ;
 
+: equate-values ( value1 value2 -- )
+    escaping-values get equate ;
+
+: add-escaping-value ( value -- )
+    +escaping+ equate-values ;
+
 : add-escaping-values ( values -- )
     escaping-values get
     '[ +escaping+ , equate ] each ;
 
+: unknown-allocation ( value -- )
+    [ add-escaping-value ]
+    [ t swap record-allocation ]
+    bi ;
+
+: unknown-allocations ( values -- )
+    [ unknown-allocation ] each ;
+
 : escaping-value? ( value -- ? )
     +escaping+ escaping-values get equiv? ;
 
+DEFER: copy-value
+
+: copy-allocation ( allocation -- allocation' )
+    {
+        { [ dup not ] [ ] }
+        { [ dup t eq? ] [ ] }
+        [ [ <value> [ introduce-value ] [ copy-value ] [ ] tri ] map ]
+    } cond ;
+
+: copy-value ( from to -- )
+    [ equate-values ]
+    [ [ allocation copy-allocation ] dip record-allocation ]
+    2bi ;
+
 SYMBOL: escaping-allocations
 
 : compute-escaping-allocations ( -- )
@@ -82,3 +106,11 @@ SYMBOL: escaping-allocations
 
 : escaping-allocation? ( value -- ? )
     escaping-allocations get key? ;
+
+: unboxed-allocation ( value -- allocation/f )
+    dup escaping-allocation? [ drop f ] [ allocation ] if ;
+
+: unboxed-slot-access? ( value -- ? )
+    (allocation) at dup slot-access?
+    [ value>> unboxed-allocation >boolean ] [ drop f ] if ;
+

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

@@ -1,9 +1,9 @@
 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.normalization math.functions
 compiler.tree.propagation compiler.tree.cleanup
-compiler.tree.combinators compiler.tree sequences math
+compiler.tree.combinators compiler.tree sequences math math.private
 kernel tools.test accessors slots.private quotations.private
 prettyprint classes.tuple.private classes classes.tuple ;
 
@@ -15,7 +15,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
     out-d>> first escaping-allocation? [ 1+ ] unless ;
 
 M: #call count-unboxed-allocations*
-    dup word>> \ <tuple-boa> =
+    dup word>> { <tuple-boa> <complex> } memq?
     [ (count-unboxed-allocations) ] [ drop ] if ;
 
 M: #push count-unboxed-allocations*
@@ -27,10 +27,8 @@ 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 ;
 
@@ -187,3 +185,101 @@ TUPLE: cons { car read-only } { cdr read-only } ;
         1 2 cons boa infinite-cons-loop
     ] count-unboxed-allocations
 ] unit-test
+
+TUPLE: rw-box i ;
+
+C: <rw-box> rw-box
+
+[ 0 ] [ [ <rw-box> i>> ] count-unboxed-allocations ] unit-test
+
+: fake-fib ( m -- n )
+    dup i>> 1 <= [ drop 1 <rw-box> ] when ; inline recursive
+
+[ 0 ] [ [ <rw-box> fake-fib i>> ] count-unboxed-allocations ] unit-test
+
+TUPLE: ro-box { i read-only } ;
+
+C: <ro-box> ro-box
+
+: tuple-fib ( m -- n )
+    dup i>> 1 <= [
+        drop 1 <ro-box>
+    ] [
+        i>> 1- <ro-box>
+        dup tuple-fib
+        swap
+        i>> 1- <ro-box>
+        tuple-fib
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 5 ] [ [ <ro-box> tuple-fib i>> ] count-unboxed-allocations ] unit-test
+
+[ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
+
+: bad-tuple-fib-1 ( m -- n )
+    dup i>> 1 <= [
+        drop 1 <ro-box>
+    ] [
+        i>> 1- <ro-box>
+        dup bad-tuple-fib-1
+        swap
+        i>> 1- <ro-box>
+        bad-tuple-fib-1 dup .
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 3 ] [ [ <ro-box> bad-tuple-fib-1 i>> ] count-unboxed-allocations ] unit-test
+
+: bad-tuple-fib-2 ( m -- n )
+    dup .
+    dup i>> 1 <= [
+        drop 1 <ro-box>
+    ] [
+        i>> 1- <ro-box>
+        dup bad-tuple-fib-2
+        swap
+        i>> 1- <ro-box>
+        bad-tuple-fib-2
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 2 ] [ [ <ro-box> bad-tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test
+
+: tuple-fib-2 ( m -- n )
+    dup 1 <= [
+        drop 1 <ro-box>
+    ] [
+        1- dup tuple-fib-2
+        swap
+        1- tuple-fib-2
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 2 ] [ [ tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test
+
+: tuple-fib-3 ( m -- n )
+    dup 1 <= [
+        drop 1 <ro-box>
+    ] [
+        1- dup tuple-fib-3
+        swap
+        1- tuple-fib-3 dup .
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 0 ] [ [ tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
+
+: bad-tuple-fib-3 ( m -- n )
+    dup 1 <= [
+        drop 1 <ro-box>
+    ] [
+        1- dup bad-tuple-fib-3
+        swap
+        1- bad-tuple-fib-3
+        2drop f
+    ] if ; inline recursive
+
+[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test

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

@@ -4,7 +4,6 @@ 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
@@ -12,6 +11,8 @@ compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.simple ;
 IN: compiler.tree.escape-analysis
 
+! This pass must run after propagation
+
 : escape-analysis ( node -- node )
     init-escaping-values
     H{ } clone allocations set

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

@@ -1,10 +1,16 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences compiler.tree ;
+USING: kernel sequences
+compiler.tree
+compiler.tree.def-use
+compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.nodes
 
 GENERIC: escape-analysis* ( node -- )
 
-M: node escape-analysis* drop ;
+: (escape-analysis) ( node -- )
-
+    [
-: (escape-analysis) ( node -- ) [ escape-analysis* ] each ;
+        [ node-defs-values introduce-values ]
+        [ escape-analysis* ]
+        bi
+    ] each ;

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

@@ -1,6 +1,5 @@
 IN: compiler.tree.escape-analysis.recursive.tests
 USING: kernel tools.test namespaces sequences
-compiler.tree.copy-equiv
 compiler.tree.escape-analysis.recursive
 compiler.tree.escape-analysis.allocations ;
 

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

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences math combinators accessors namespaces
+fry disjoint-sets
 compiler.tree
-compiler.tree.copy-equiv
 compiler.tree.combinators
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.branches
@@ -17,9 +17,10 @@ IN: compiler.tree.escape-analysis.recursive
         [ [ [ allocation ] bi@ congruent? ] 2all? ]
     } cond ;
 
-: check-fixed-point ( node alloc1 alloc2 -- node )
+: check-fixed-point ( node alloc1 alloc2 -- )
-    [ congruent? ] 2all?
+    [ congruent? ] 2all? [ drop ] [
-    [ dup label>> f >>fixed-point drop ] unless ; inline
+        label>> f >>fixed-point drop
+    ] if ;
 
 : node-input-allocations ( node -- allocations )
     in-d>> [ allocation ] map ;
@@ -35,31 +36,26 @@ IN: compiler.tree.escape-analysis.recursive
     [ [ merge-values ] 2each ]
     [
         [ (merge-allocations) ] dip
-        [ [ allocation ] map check-fixed-point drop ]
+        [ [ allocation ] map check-fixed-point ]
         [ record-allocations ]
         2bi
     ] 2bi ;
 
 M: #recursive escape-analysis* ( #recursive -- )
     [
-        ! copies [ clone ] change
-
         child>>
         [ first analyze-recursive-phi ]
         [ (escape-analysis) ]
         bi
     ] until-fixed-point ;
 
-M: #call-recursive escape-analysis* ( #call-label -- )
+: return-allocations ( node -- allocations )
-    dup
+    label>> return>> node-input-allocations ;
-    [ node-output-allocations ]
-    [ label>> return>> node-input-allocations ] bi
-    [ check-fixed-point ] keep
-    swap out-d>> record-allocations ;
 
-! M: #return-recursive escape-analysis* ( #return-recursive -- )
+M: #call-recursive escape-analysis* ( #call-label -- )
-!     dup dup label>> calls>> dup empty? [ 3drop ] [
+    [ ] [ return-allocations ] [ node-output-allocations ] tri
-!         [ node-input-allocations ]
+    [ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ;
-!         [ first node-output-allocations ] bi*
+
-!         check-fixed-point drop
+M: #return-recursive escape-analysis* ( #return-recursive -- )
-!     ] if ;
+    [ in-d>> ] [ label>> calls>> ] bi
+    [ out-d>> escaping-values get '[ , equate ] 2each ] with each ;

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

@@ -1,26 +1,43 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences classes.tuple
-classes.tuple.private math math.private slots.private
+classes.tuple.private arrays math math.private slots.private
 combinators dequeues search-dequeues namespaces fry classes
-stack-checker.state
+classes.algebra stack-checker.state
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.simple
 
-M: #introduce escape-analysis*
+M: #declare escape-analysis* drop ;
-    value>> unknown-allocation ;
+
+M: #terminate escape-analysis* drop ;
+
+M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ;
+
+M: #introduce escape-analysis* value>> unknown-allocation ;
+
+DEFER: record-literal-allocation
+
+: make-literal-slots ( seq -- values )
+    [ <slot-value> [ swap record-literal-allocation ] keep ] map ;
+
+: record-literal-tuple-allocation ( value object -- )
+    tuple-slots rest-slice
+    make-literal-slots
+    swap record-allocation ;
+
+: record-literal-complex-allocation ( value object -- )
+    [ real-part ] [ imaginary-part ] bi 2array make-literal-slots
+    swap record-allocation ;
 
 : record-literal-allocation ( value object -- )
-    dup class immutable-tuple-class? [
+    {
-        tuple-slots rest-slice
+        { [ dup class immutable-tuple-class? ] [ record-literal-tuple-allocation ] }
-        [ <slot-value> [ swap record-literal-allocation ] keep ] map
+        { [ dup complex? ] [ record-literal-complex-allocation ] }
-        swap record-allocation
+        [ drop unknown-allocation ]
-    ] [
+    } cond ;
-        drop unknown-allocation
-    ] if ;
 
 M: #push escape-analysis*
     #! Delegation.
@@ -34,19 +51,29 @@ M: #push escape-analysis*
         record-allocation
     ] [ out-d>> unknown-allocations ] if ;
 
+: record-complex-allocation ( #call -- )
+    [ in-d>> ] [ out-d>> first ] bi record-allocation ;
+
+: slot-offset ( #call -- n/f )
+    dup in-d>>
+    [ first node-value-info class>> ]
+    [ second node-value-info literal>> ] 2bi
+    dup fixnum? [
+        {
+            { [ over tuple class<= ] [ 3 - ] }
+            { [ over complex class<= ] [ 1 - ] }
+            [ drop f ]
+        } cond nip
+    ] [ 2drop f ] if ;
+
 : record-slot-call ( #call -- )
-    [ out-d>> first ]
+    [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
-    [ dup in-d>> second node-value-info literal>> ]
+    over [ record-slot-access ] [ 2drop unknown-allocation ] if ;
-    [ in-d>> first ] tri
-    over fixnum? [
-        [ 3 - ] dip record-slot-access
-    ] [
-        2drop unknown-allocation
-    ] if ;
 
 M: #call escape-analysis*
     dup word>> {
         { \ <tuple-boa> [ record-tuple-allocation ] }
+        { \ <complex> [ record-complex-allocation ] }
         { \ slot [ record-slot-call ] }
         [
             drop

unfinished/compiler/tree/normalization/normalization.factor

@@ -128,6 +128,10 @@ M: #recursive normalize*
     dup dup label>> introductions>>
     eliminate-recursive-introductions ;
 
+M: #enter-recursive normalize*
+    dup [ label>> ] keep >>enter-recursive drop
+    dup [ label>> ] [ out-d>> ] bi >>enter-out drop ;
+
 : unchanged-underneath ( #call-recursive -- n )
     [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
 

unfinished/compiler/tree/optimizer/optimizer.factor

@@ -1,18 +1,22 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.tree.normalization compiler.tree.copy-equiv
+USING: compiler.tree.normalization
-compiler.tree.propagation compiler.tree.cleanup
+compiler.tree.propagation
-compiler.tree.def-use compiler.tree.untupling
+compiler.tree.cleanup
-compiler.tree.dead-code compiler.tree.strength-reduction
+compiler.tree.escape-analysis
-compiler.tree.loop-detection compiler.tree.branch-fusion ;
+compiler.tree.tuple-unboxing
+compiler.tree.def-use
+compiler.tree.dead-code
+compiler.tree.strength-reduction
+compiler.tree.loop-detection
+compiler.tree.branch-fusion ;
 IN: compiler.tree.optimizer
 
 : optimize-tree ( nodes -- nodes' )
     normalize
-    compute-copy-equiv
     propagate
     cleanup
-    compute-def-use
+    escape-analysis
     unbox-tuples
     compute-def-use
     remove-dead-code

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

@@ -90,7 +90,7 @@ M: #phi propagate-before ( #phi -- )
             [
                 drop condition-value get
                 [ [ =t ] [ =t ] bi* <--> ]
-                [ [ =f ] [ =f ] bi* <--> ] 2bi /\ assume
+                [ [ =f ] [ =f ] bi* <--> ] 2bi /\
             ]
         }
         {
@@ -98,19 +98,43 @@ M: #phi propagate-before ( #phi -- )
             [
                 drop condition-value get
                 [ [ =t ] [ =f ] bi* <--> ]
-                [ [ =f ] [ =t ] bi* <--> ] 2bi /\ assume
+                [ [ =f ] [ =t ] bi* <--> ] 2bi /\
             ]
         }
         {
             { { t f } { f } }
-            [ first =t condition-value get =t /\ swap t--> assume ]
+            [
+                first =t
+                condition-value get =t /\
+                swap t-->
+            ]
         }
         {
             { { f } { t f } }
-            [ second =t condition-value get =f /\ swap t--> assume ]
+            [
+                second =t
+                condition-value get =f /\
+                swap t-->
+            ]
         }
-        [ 3drop ]
+        ! {
-    } case ;
+        !     { { t f } { } }
+        !     [ B
+        !         first
+        !         [ [ =t ] bi@ <--> ]
+        !         [ [ =f ] bi@ <--> ] 2bi /\
+        !     ]
+        ! }
+        ! {
+        !     { { } { t f } }
+        !     [
+        !         second
+        !         [ [ =t ] bi@ <--> ]
+        !         [ [ =f ] bi@ <--> ] 2bi /\
+        !     ]
+        ! }
+        [ 3drop f ]
+    } case assume ;
 
 M: #phi propagate-after ( #phi -- )
     condition-value get [

unfinished/compiler/tree/propagation/constraints/constraints.factor

@@ -3,8 +3,9 @@
 USING: arrays assocs math math.intervals kernel accessors
 sequences namespaces classes classes.algebra
 combinators words
-compiler.tree compiler.tree.propagation.info
+compiler.tree
-compiler.tree.copy-equiv ;
+compiler.tree.propagation.info
+compiler.tree.propagation.copy ;
 IN: compiler.tree.propagation.constraints
 
 ! A constraint is a statement about a value.

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

@@ -1,5 +1,5 @@
-IN: compiler.tree.copy-equiv.tests
+IN: compiler.tree.propagation.copy.tests
-USING: compiler.tree.copy-equiv tools.test namespaces kernel
+USING: compiler.tree.propagation.copy tools.test namespaces kernel
 assocs ;
 
 H{ } clone copies set

unfinished/compiler/tree/propagation/copy/copy.factor

@@ -5,7 +5,7 @@ combinators sets locals
 compiler.tree
 compiler.tree.def-use
 compiler.tree.combinators ;
-IN: compiler.tree.copy-equiv
+IN: compiler.tree.propagation.copy
 
 ! Two values are copy-equivalent if they are always identical
 ! at run-time ("DS" relation). This is just a weak form of
@@ -26,8 +26,7 @@ SYMBOL: copies
         ] if
     ] ;
 
-: resolve-copy ( copy -- val )
+: resolve-copy ( copy -- val ) copies get compress-path ;
-    copies get compress-path [ "Unknown value" throw ] unless* ;
 
 : is-copy-of ( val copy -- ) copies get set-at ;
 
@@ -37,21 +36,7 @@ SYMBOL: copies
 
 GENERIC: compute-copy-equiv* ( node -- )
 
-M: #shuffle compute-copy-equiv*
+M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
-    [ out-d>> dup ] [ mapping>> ] bi
-    '[ , at ] map swap are-copies-of ;
-
-M: #>r compute-copy-equiv*
-    [ in-d>> ] [ out-r>> ] bi are-copies-of ;
-
-M: #r> compute-copy-equiv*
-    [ in-r>> ] [ out-d>> ] bi are-copies-of ;
-
-M: #copy compute-copy-equiv*
-    [ in-d>> ] [ out-d>> ] bi are-copies-of ;
-
-M: #return-recursive compute-copy-equiv*
-    [ in-d>> ] [ out-d>> ] bi are-copies-of ;
 
 : compute-phi-equiv ( inputs outputs -- )
     #! An output is a copy of every input if all inputs are
@@ -68,13 +53,7 @@ M: #phi compute-copy-equiv*
 
 M: node compute-copy-equiv* drop ;
 
-: amend-copy-equiv ( node -- )
+: compute-copy-equiv ( node -- )
-    [
+    [ node-defs-values [ introduce-value ] each ]
-        [ node-defs-values [ introduce-value ] each ]
+    [ compute-copy-equiv* ]
-        [ compute-copy-equiv* ]
+    bi ;
-        bi
-    ] each-node ;
-
-: compute-copy-equiv ( node -- node )
-    H{ } clone copies set
-    dup amend-copy-equiv ;

unfinished/compiler/tree/propagation/info/info.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs classes classes.algebra kernel
 accessors math math.intervals namespaces sequences words
-combinators arrays compiler.tree.copy-equiv ;
+combinators combinators.short-circuit arrays
+compiler.tree.propagation.copy ;
 IN: compiler.tree.propagation.info
 
 : false-class? ( class -- ? ) \ f class<= ;
@@ -218,6 +219,28 @@ DEFER: (value-info-union)
     [ drop null-info ]
     [ dup first [ value-info-union ] reduce ] if ;
 
+: literals<= ( info1 info2 -- ? )
+    {
+        { [ dup literal?>> not ] [ 2drop t ] }
+        { [ over literal?>> not ] [ 2drop f ] }
+        [ [ literal>> ] bi@ eql? ]
+    } cond ;
+
+: value-info<= ( info1 info2 -- ? )
+    {
+        { [ dup not ] [ 2drop t ] }
+        { [ over not ] [ 2drop f ] }
+        [
+            {
+                [ [ class>> ] bi@ class<= ]
+                [ [ interval>> ] bi@ interval-subset? ]
+                [ literals<= ]
+                [ [ length>> ] bi@ value-info<= ]
+                [ [ slots>> ] bi@ [ value-info<= ] 2all? ]
+            } 2&&
+        ]
+    } cond ;
+
 ! Current value --> info mapping
 SYMBOL: value-infos
 

unfinished/compiler/tree/propagation/inlining/inlining.factor

@@ -6,7 +6,6 @@ classes.union sets quotations assocs combinators words
 namespaces
 compiler.tree
 compiler.tree.builder
-compiler.tree.copy-equiv
 compiler.tree.normalization
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes ;
@@ -25,7 +24,7 @@ M: quotation splicing-nodes
     normalize ;
 
 : propagate-body ( #call -- )
-    body>> [ amend-copy-equiv ] [ (propagate) ] bi ;
+    body>> (propagate) ;
 
 ! Dispatch elimination
 : eliminate-dispatch ( #call word/quot/f -- ? )

unfinished/compiler/tree/propagation/nodes/nodes.factor

@@ -3,6 +3,7 @@
 USING: sequences accessors kernel assocs sequences
 compiler.tree
 compiler.tree.def-use
+compiler.tree.propagation.copy
 compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.nodes
 
@@ -15,7 +16,8 @@ GENERIC: propagate-after ( node -- )
 
 GENERIC: propagate-around ( node -- )
 
-: (propagate) ( node -- ) [ propagate-around ] each ;
+: (propagate) ( node -- )
+    [ [ compute-copy-equiv ] [ propagate-around ] bi ] each ;
 
 : extract-value-info ( values -- assoc )
     [ dup value-info ] H{ } map>assoc ;

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

@@ -1,5 +1,5 @@
 USING: kernel compiler.tree.builder compiler.tree
-compiler.tree.propagation compiler.tree.copy-equiv
+compiler.tree.propagation
 compiler.tree.normalization tools.test math math.order
 accessors sequences arrays kernel.private vectors
 alien.accessors alien.c-types sequences.private
@@ -14,7 +14,6 @@ IN: compiler.tree.propagation.tests
 : final-info ( quot -- seq )
     build-tree
     normalize
-    compute-copy-equiv
     propagate
     peek node-input-infos ;
 
@@ -145,6 +144,8 @@ IN: compiler.tree.propagation.tests
     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ] unit-test
 
+[ f ] [ [ t xor ] final-classes first null-class? ] unit-test
+
 [ t ] [ [ t or ] final-classes first true-class? ] unit-test
 
 [ t ] [ [ t swap or ] final-classes first true-class? ] unit-test
@@ -155,12 +156,20 @@ IN: compiler.tree.propagation.tests
 
 [ t ] [ [ dup not or ] final-classes first true-class? ] unit-test
 
+[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
+
 [ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test
 
+[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
+
 [ t ] [ [ dup not and ] final-classes first false-class? ] unit-test
 
+[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
+
 [ t ] [ [ dup not swap and ] final-classes first false-class? ] unit-test
 
+[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
+
 [ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
 
 [ V{ fixnum } ] [

unfinished/compiler/tree/propagation/propagation.factor

@@ -3,6 +3,7 @@
 USING: accessors kernel sequences namespaces hashtables
 compiler.tree
 compiler.tree.def-use
+compiler.tree.propagation.copy
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
@@ -12,9 +13,10 @@ compiler.tree.propagation.constraints
 compiler.tree.propagation.known-words ;
 IN: compiler.tree.propagation
 
+! This pass must run after normalization
+
 : propagate ( node -- node )
-    [
+    H{ } clone copies set
-        H{ } clone constraints set
+    H{ } clone constraints set
-        H{ } clone value-infos set
+    H{ } clone value-infos set
-        dup (propagate)
+    dup (propagate) ;
-    ] with-scope ;

unfinished/compiler/tree/propagation/recursive/recursive.factor

@@ -4,8 +4,8 @@ USING: kernel sequences accessors arrays fry math.intervals
 combinators namespaces
 stack-checker.inlining
 compiler.tree
-compiler.tree.copy-equiv
 compiler.tree.combinators
+compiler.tree.propagation.copy
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
@@ -13,8 +13,9 @@ compiler.tree.propagation.branches
 compiler.tree.propagation.constraints ;
 IN: compiler.tree.propagation.recursive
 
-: check-fixed-point ( node infos1 infos2 -- node )
+: check-fixed-point ( node infos1 infos2 -- )
-    sequence= [ dup label>> f >>fixed-point drop ] unless ; inline
+    [ value-info<= ] 2all?
+    [ drop ] [ label>> f >>fixed-point drop ] if ;
 
 : recursive-stacks ( #enter-recursive -- stacks initial )
     [ label>> calls>> [ node-input-infos ] map flip ]
@@ -46,19 +47,21 @@ IN: compiler.tree.propagation.recursive
 
 : propagate-recursive-phi ( #enter-recursive -- )
     [ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
-    [ node-output-infos check-fixed-point drop ] 2keep
+    [ node-output-infos check-fixed-point ]
-    out-d>> set-value-infos ;
+    [ out-d>> set-value-infos drop ]
+    3bi ;
 
 M: #recursive propagate-around ( #recursive -- )
-    [
+    { 0 } clone [ USE: math
-        copies [ clone ] change
+        dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
         constraints [ clone ] change
 
         child>>
+        [ first compute-copy-equiv ]
         [ first propagate-recursive-phi ]
         [ (propagate) ]
-        bi
+        tri
-    ] until-fixed-point ;
+    ] curry until-fixed-point ;
 
 : generalize-return-interval ( info -- info' )
     dup [ literal?>> ] [ class>> null-class? ] bi or
@@ -67,11 +70,9 @@ M: #recursive propagate-around ( #recursive -- )
 : generalize-return ( infos -- infos' )
     [ generalize-return-interval ] map ;
 
-M: #call-recursive propagate-before ( #call-label -- )
+: return-infos ( node -- infos )
-    dup [ node-output-infos ] [ label>> return>> node-input-infos ] bi
+    label>> return>> node-input-infos generalize-return ;
-    [ check-fixed-point ] keep
-    generalize-return swap out-d>> set-value-infos ;
 
-M: #return-recursive propagate-before ( #return-recursive -- )
+M: #call-recursive propagate-before ( #call-label -- )
-    dup [ node-input-infos ] [ in-d>> [ value-info ] map ] bi
+    [ ] [ return-infos ] [ node-output-infos ] tri
-    check-fixed-point drop ;
+    [ check-fixed-point ] [ drop swap out-d>> set-value-infos ] 3bi ;

unfinished/compiler/tree/tree.factor

@@ -39,7 +39,9 @@ TUPLE: #push < node literal out-d ;
         swap 1array >>out-d
         swap >>literal ;
 
-TUPLE: #shuffle < node mapping in-d out-d ;
+TUPLE: #renaming < node ;
+
+TUPLE: #shuffle < #renaming mapping in-d out-d ;
 
 : #shuffle ( inputs outputs mapping -- node )
     \ #shuffle new
@@ -50,14 +52,14 @@ TUPLE: #shuffle < node mapping in-d out-d ;
 : #drop ( inputs -- node )
     { } { } #shuffle ;
 
-TUPLE: #>r < node in-d out-r ;
+TUPLE: #>r < #renaming in-d out-r ;
 
 : #>r ( inputs outputs -- node )
     \ #>r new
         swap >>out-r
         swap >>in-d ;
 
-TUPLE: #r> < node in-r out-d ;
+TUPLE: #r> < #renaming in-r out-d ;
 
 : #r> ( inputs outputs -- node )
     \ #r> new
@@ -126,7 +128,7 @@ TUPLE: #enter-recursive < node in-d out-d label ;
         swap >>in-d
         swap >>label ;
 
-TUPLE: #return-recursive < node in-d out-d label ;
+TUPLE: #return-recursive < #renaming in-d out-d label ;
 
 : #return-recursive ( label inputs outputs -- node )
     \ #return-recursive new
@@ -134,7 +136,7 @@ TUPLE: #return-recursive < node in-d out-d label ;
         swap >>in-d
         swap >>label ;
 
-TUPLE: #copy < node in-d out-d ;
+TUPLE: #copy < #renaming in-d out-d ;
 
 : #copy ( inputs outputs -- node )
     \ #copy new
@@ -143,6 +145,14 @@ TUPLE: #copy < node in-d out-d ;
 
 : node, ( node -- ) stack-visitor get push ;
 
+GENERIC: inputs/outputs ( #renaming -- inputs outputs )
+
+M: #shuffle inputs/outputs mapping>> unzip swap ;
+M: #>r inputs/outputs [ in-d>> ] [ out-r>> ] bi ;
+M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
+M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
+M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
+
 M: vector child-visitor V{ } clone ;
 M: vector #introduce, #introduce node, ;
 M: vector #call, #call node, ;

unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor

@@ -0,0 +1,109 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.tuple-unboxing
+
+! This pass must run after escape analysis
+
+! Mapping from values to sequences of values
+SYMBOL: unboxed-tuples
+
+: unboxed-tuple ( value -- unboxed-tuple )
+    unboxed-tuples get at ;
+
+GENERIC: unbox-tuples* ( node -- )
+
+: value-info-slots ( info -- slots )
+    #! Delegation.
+    [ info>> ] [ class>> ] bi {
+        { [ dup tuple class<= ] [ drop 2 tail ] }
+        { [ dup complex class<= ] [ drop ] }
+    } cond ;
+
+: prepare-unboxed-values ( #push -- values )
+    out-d>> first unboxed-allocation ;
+
+: prepare-unboxed-info ( #push -- infos values )
+    dup prepare-unboxed-values dup
+    [ [ node-output-infos first value-info-slots ] dip ]
+    [ 2drop f f ]
+    if ;
+
+: expand-#push ( #push infos values -- )
+    [ [ literal>> ] dip #push ] 2map >>body drop ;
+
+M: #push unbox-tuples* ( #push -- )
+    dup prepare-unboxed-info dup [ expand-#push ] [ 3drop ] if ;
+
+: expand-<tuple-boa> ( #call values -- quot )
+    [ drop in-d>> peek #drop ]
+    [ [ in-d>> but-last ] dip #copy ]
+    2bi 2array ;
+
+: expand-<complex> ( #call values -- quot )
+    [ in-d>> ] dip #copy 1array ;
+
+: expand-constructor ( #call values -- )
+    [ drop ] [ ] [ drop word>> ] 2tri {
+        { <tuple-boa> [ expand-<tuple-boa> ] }
+        { <complex> [ expand-<complex> ] }
+    } case unbox-tuples >>body ;
+
+: unbox-constructor ( #call -- )
+    dup prepare-unboxed-values dup
+    [ expand-constructor ] [ 2drop ] if ;
+
+: (flatten-values) ( values -- values' )
+    [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
+
+: flatten-values ( values -- values' )
+    (flatten-values) flatten ;
+
+: flatten-value ( values -- values )
+    1array flatten-values ;
+
+: prepare-slot-access ( #call -- tuple-values slot-values outputs )
+    [ in-d>> first flatten-value ]
+    [
+        [ dup in-d>> second node-value-info literal>> ]
+        [ out-d>> first unboxed-allocation ]
+        bi nth flatten-value
+    ]
+    [ out-d>> flatten-values ]
+    tri ;
+
+: slot-access-shuffle ( tuple-values slot-values outputs -- #shuffle )
+    [ nip ] [ zip ] 2bi #shuffle ;
+
+: unbox-slot-access ( #call -- )
+    dup unboxed-slot-access? [
+        dup
+        [ in-d>> second 1array #drop ]
+        [ prepare-slot-access slot-access-shuffle ]
+        bi 2array unbox-tuples >>body
+    ] when drop ;
+
+M: #call unbox-tuples* ( #call -- )
+    dup word>> {
+        { \ <tuple-boa> [ unbox-<tuple-boa> ] }
+        { \ <complex> [ unbox-<complex> ] }
+        { \ slot [ unbox-slot-access ] }
+        [ 2drop ]
+    } case ;
+
+M: #copy ... ;
+
+M: #>r ... ;
+
+M: #r> ... ;
+
+M: #shuffle ... ;
+
+M: #terrible ... ;
+
+! These nodes never participate in unboxing
+M: #return drop ;
+
+M: #introduce drop ;
+
+: unbox-tuples ( nodes -- nodes )
+    dup [ unbox-tuples* ] each-node ;

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

@@ -1,50 +0,0 @@
-IN: compiler.tree.untupling.tests
-USING: assocs math kernel quotations.private slots.private
-compiler.tree.builder
-compiler.tree.def-use
-compiler.tree.copy-equiv
-compiler.tree.untupling
-tools.test ;
-
-: check-untupling ( quot -- sizes )
-    build-tree
-    compute-copy-equiv
-    compute-def-use
-    compute-untupling
-    values ;
-
-[ { } ] [ [ 1 [ + ] curry ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry drop ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry 3 slot ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry 3 slot drop ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry uncurry ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
-
-[ { } ] [ [ [ 1 [ + ] curry ] [ [ ] ] if ] check-untupling ] unit-test
-
-[ { 2 2 } ] [
-    [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if uncurry ] check-untupling
-] unit-test
-
-[ { } ] [
-    [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if ] check-untupling
-] unit-test
-
-[ { 2 2 2 } ] [
-    [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if uncurry ] check-untupling
-] unit-test
-
-[ { 2 2 } ] [
-    [ [ 1 [ + ] curry 4 ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if uncurry ] if ] check-untupling
-] unit-test
-
-[ { } ] [
-    [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if ] check-untupling
-] unit-test

unfinished/compiler/tree/untupling/untupling.factor

@@ -1,59 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors slots.private kernel namespaces disjoint-sets
-math sequences assocs classes.tuple.private combinators fry sets
-compiler.tree compiler.tree.combinators compiler.tree.copy-equiv
-compiler.tree.dataflow-analysis
-compiler.tree.dataflow-analysis.backward ;
-IN: compiler.tree.untupling
-
-SYMBOL: escaping-values
-
-: mark-escaping-values ( node -- )
-    in-d>> escaping-values get '[ resolve-copy , conjoin ] each ;
-
-SYMBOL: untupling-candidates
-
-: untupling-candidate ( #call class -- )
-    #! 1- for delegate
-    size>> 1- swap out-d>> first resolve-copy
-    untupling-candidates get set-at ;
-
-GENERIC: compute-untupling* ( node -- )
-
-M: #call compute-untupling*
-    dup word>> {
-        { \ <tuple-boa> [ dup in-d>> peek untupling-candidate ] }
-        { \ curry [ \ curry tuple-layout untupling-candidate ] }
-        { \ compose [ \ compose tuple-layout untupling-candidate ] }
-        { \ slot [ drop ] }
-        [ drop mark-escaping-values ]
-    } case ;
-
-M: #return compute-untupling* mark-escaping-values ;
-
-M: node compute-untupling* drop ;
-
-GENERIC: check-consistency* ( node -- )
-
-: check-value-consistency ( out-value in-values -- )
-    swap escaping-values get key? [
-        escaping-values get '[ , conjoin ] each
-    ] [
-        untupling-candidates get 2dup '[ , at ] map all-equal?
-        [ 2drop ] [ '[ , delete-at ] each ] if
-    ] if ;
-
-M: #phi check-consistency*
-    [ [ out-d>> ] [ phi-in-d>> ] bi [ check-value-consistency ] 2each ]
-    [ [ out-r>> ] [ phi-in-r>> ] bi [ check-value-consistency ] 2each ]
-    bi ;
-
-M: node check-consistency* drop ;
-
-: compute-untupling ( node -- assoc )
-    H{ } clone escaping-values set
-    H{ } clone untupling-candidates set
-    [ [ compute-untupling* ] each-node ]
-    [ [ check-consistency* ] each-node ] bi
-    untupling-candidates get escaping-values get assoc-diff ;

unfinished/stack-checker/inlining/inlining.factor

@@ -17,7 +17,12 @@ IN: stack-checker.inlining
 : (inline-word) ( word label -- )
     [ [ def>> ] keep ] dip infer-quot-recursive ;
 
-TUPLE: inline-recursive word enter-out return calls fixed-point introductions ;
+TUPLE: inline-recursive
+word
+enter-out enter-recursive
+return calls
+fixed-point
+introductions ;
 
 : <inline-recursive> ( word -- label )
     inline-recursive new swap >>word ;