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

core/classes/tuple/tuple.factor

@@ -20,6 +20,10 @@ ERROR: not-a-tuple object ;
 : all-slots ( class -- slots )
     superclasses [ "slots" word-prop ] map concat ;
 
+PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
+    #! Delegation
+    all-slots rest-slice [ read-only>> ] all? ;
+
 <PRIVATE
 
 : tuple-layout ( class -- layout )

core/kernel/kernel.factor

@@ -165,13 +165,9 @@ GENERIC: boa ( ... class -- tuple )
     compose compose ; inline
 
 ! Booleans
-: not ( obj -- ? )
+: not ( obj -- ? ) f t ? ; inline
-    #! Not inline because its special-cased by compiler.
-    f eq? ;
 
-: and ( obj1 obj2 -- ? )
+: and ( obj1 obj2 -- ? ) over ? ; inline
-    #! Not inline because its special-cased by compiler.
-    over ? ;
 
 : >boolean ( obj -- ? ) t f ? ; inline
 

core/math/intervals/intervals.factor

@@ -135,6 +135,9 @@ TUPLE: interval { from read-only } { to read-only } ;
         ]
     } cond ;
 
+: intervals-intersect? ( i1 i2 -- ? )
+    interval-intersect empty-interval eq? not ;
+
 : interval-union ( i1 i2 -- i3 )
     {
         { [ dup empty-interval eq? ] [ drop ] }

core/slots/slots.factor

@@ -8,13 +8,17 @@ IN: slots
 
 TUPLE: slot-spec name offset class initial read-only reader writer ;
 
+PREDICATE: reader < word "reader" word-prop ;
+
+PREDICATE: writer < word "writer" word-prop ;
+
 : <slot-spec> ( -- slot-spec )
     slot-spec new
         object bootstrap-word >>class ;
 
 : define-typecheck ( class generic quot props -- )
     [ dup define-simple-generic create-method ] 2dip
-    [ [ props>> ] [ drop ] [ [ t ] H{ } map>assoc ] tri* update ]
+    [ [ props>> ] [ drop ] [ ] tri* update ]
     [ drop define ]
     3bi ;
 
@@ -31,17 +35,23 @@ TUPLE: slot-spec name offset class initial read-only reader writer ;
     ] [ ] make ;
 
 : reader-word ( name -- word )
-    ">>" append (( object -- value )) create-accessor ;
+    ">>" append (( object -- value )) create-accessor
+    dup t "reader" set-word-prop ;
 
-: reader-props ( slot-spec -- seq )
+: reader-props ( slot-spec -- assoc )
-    read-only>> { "foldable" "flushable" } { "flushable" } ? ;
+    [
+        [ "reading" set ]
+        [ read-only>> [ t "foldable" set ] when ] bi
+        t "flushable" set
+    ] H{ } make-assoc ;
 
 : define-reader ( class slot-spec -- )
     [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
     define-typecheck ;
 
 : writer-word ( name -- word )
-    "(>>" swap ")" 3append (( value object -- )) create-accessor ;
+    "(>>" swap ")" 3append (( value object -- )) create-accessor
+    dup t "writer" set-word-prop ;
 
 ERROR: bad-slot-value value class ;
 
@@ -77,8 +87,12 @@ ERROR: bad-slot-value value class ;
         } cond
     ] [ ] make ;
 
+: writer-props ( slot-spec -- assoc )
+    [ "writing" set ] H{ } make-assoc ;
+
 : define-writer ( class slot-spec -- )
-    [ name>> writer-word ] [ writer-quot ] bi { } define-typecheck ;
+    [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
+    define-typecheck ;
 
 : setter-word ( name -- word )
     ">>" prepend (( object value -- object )) create-accessor ;

core/words/words.factor

@@ -187,6 +187,7 @@ M: word reset-word
         "parsing" "inline" "recursive" "foldable" "flushable"
         "predicating"
         "reading" "writing"
+        "reader" "writer"
         "constructing"
         "declared-effect" "constructor-quot" "delimiter"
     } reset-props ;

extra/24-game/24-game.factor

@@ -2,7 +2,7 @@
 ! 24, the Factor game!
 
 USING: kernel random namespaces shuffle sequences
-parser io math prettyprint combinators
+parser io math prettyprint combinators continuations
 vectors words quotations accessors math.parser
 backtrack math.ranges locals fry memoize macros assocs ;
 

extra/io/launcher/launcher.factor

@@ -183,7 +183,7 @@ M: object run-pipeline-element
             [ |dispose drop ]
             [
                 swap >process
-                    [ swap in>> or ] change-stdout
+                    [ swap in>> or ] change-stdin
                 run-detached
             ]
             [ in>> dispose ]
@@ -200,8 +200,8 @@ M: object run-pipeline-element
             [ [ |dispose drop ] bi@ ]
             [
                 rot >process
-                    [ swap out>> or ] change-stdout
                     [ swap in>> or ] change-stdin
+                    [ swap out>> or ] change-stdout
                 run-detached
             ]
             [ [ out>> dispose ] [ in>> dispose ] bi* ]

extra/io/unix/launcher/launcher-tests.factor

@@ -1,7 +1,8 @@
 IN: io.unix.launcher.tests
 USING: io.files tools.test io.launcher arrays io namespaces
 continuations math io.encodings.binary io.encodings.ascii
-accessors kernel sequences io.encodings.utf8 destructors ;
+accessors kernel sequences io.encodings.utf8 destructors
+io.streams.duplex ;
 
 [ ] [
     [ "launcher-test-1" temp-file delete-file ] ignore-errors
@@ -111,4 +112,12 @@ accessors kernel sequences io.encodings.utf8 destructors ;
     "append-test" temp-file utf8 file-contents
 ] unit-test
 
-[ ] [ "ls" utf8 <process-stream> contents drop ] unit-test
+[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test
+
+[ "Hello world.\n" ] [
+    "cat" utf8 <process-stream> [
+        "Hello world.\n" write
+        output-stream get dispose
+        input-stream get contents
+    ] with-stream
+] unit-test

extra/shell/shell.factor

@@ -50,7 +50,6 @@ DEFER: expansion
 METHOD: expand { back-quoted-expr }
   expr>>
   expr
-  ast>>
   command>>
   expansion
   utf8 <process-stream>
@@ -122,7 +121,7 @@ DEFER: shell
     { [ dup f = ]      [ drop ] }
     { [ dup "exit" = ] [ drop ] }
     { [ dup "" = ]     [ drop shell ] }
-    { [ dup expr ]     [ expr ast>> chant shell ] }
+    { [ dup expr ]     [ expr chant shell ] }
     { [ t ]            [ drop "ix: ignoring input" print shell ] }
   }
     cond ;

extra/ui/gadgets/labelled/labelled.factor

@@ -12,9 +12,9 @@ TUPLE: labelled-gadget < track content ;
 
 : <labelled-gadget> ( gadget title -- newgadget )
   { 0 1 } labelled-gadget new-track
-    swap <label> reverse-video-theme f track-add*
+    swap <label> reverse-video-theme f track-add
     swap >>content
-    dup content>> 1 track-add* ;
+    dup content>> 1 track-add ;
 
 M: labelled-gadget focusable-child* labelled-gadget-content ;
 

extra/ui/gadgets/labels/labels.factor

@@ -65,10 +65,10 @@ M: f >label drop <gadget> ;
 
 : label-on-left ( gadget label -- button )
   { 1 0 } <track>
-    swap >label f track-add*
+    swap >label f track-add
-    swap        1 track-add* ;
+    swap        1 track-add ;
     
 : label-on-right ( label gadget -- button )
   { 1 0 } <track>
-    swap        f track-add*
+    swap        f track-add
-    swap >label 1 track-add* ;
+    swap >label 1 track-add ;

extra/ui/gadgets/slots/slots.factor

@@ -71,9 +71,9 @@ M: value-ref finish-editing
 : <slot-editor> ( ref -- gadget )
   { 0 1 } slot-editor new-track
     swap >>ref
-    dup <toolbar> f track-add*
+    dup <toolbar> f track-add
     <source-editor> >>text
-    dup text>> <scroller> 1 track-add*
+    dup text>> <scroller> 1 track-add
     dup revert ;
     
 M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
@@ -97,8 +97,8 @@ TUPLE: editable-slot < track printer ref ;
 
 : display-slot ( gadget editable-slot -- )
   dup clear-track
-    swap          1 track-add*
+    swap          1 track-add
-    <edit-button> f track-add*
+    <edit-button> f track-add
   drop ;
 
 : update-slot ( editable-slot -- )
@@ -109,7 +109,7 @@ TUPLE: editable-slot < track printer ref ;
     [ clear-track ]
     [
         dup ref>> <slot-editor>
-        [ 1 track-add* drop ]
+        [ 1 track-add drop ]
         [ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
     ] bi ;
 

extra/ui/gadgets/status-bar/status-bar.factor

@@ -12,7 +12,7 @@ IN: ui.gadgets.status-bar
 
 : open-status-window ( gadget title -- )
     f <model> [ <world> ] keep
-    <status-bar> f track-add*
+    <status-bar> f track-add
     open-world-window ;
 
 : show-summary ( object gadget -- )

extra/ui/gadgets/tiling/tiling.factor

@@ -38,7 +38,7 @@ TUPLE: tiling < track gadgets tiles first focused ;
 
 : tiling-map-gadgets ( tiling -- tiling )
   dup clear-track
-  dup tiling-gadgets-to-map [ 1 track-add* ] each ;
+  dup tiling-gadgets-to-map [ 1 track-add ] each ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/ui/gadgets/tracks/tracks-docs.factor

@@ -8,7 +8,7 @@ ARTICLE: "ui-track-layout" "Track layouts"
 "Creating empty tracks:"
 { $subsection <track> }
 "Adding children:"
-{ $subsection track-add* } ;
+{ $subsection track-add } ;
 
 HELP: track
 { $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
@@ -17,7 +17,7 @@ HELP: <track>
 { $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
 { $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ; 
 
-HELP: track-add*
+HELP: track-add
 { $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
 { $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;
 

extra/ui/gadgets/tracks/tracks-tests.factor

@@ -4,13 +4,13 @@ IN: ui.gadgets.tracks.tests
 
 [ { 100 100 } ] [
   { 0 1 } <track>
-    <gadget> { 100 100 } >>dim 1 track-add*
+    <gadget> { 100 100 } >>dim 1 track-add
   pref-dim
 ] unit-test
 
 [ { 100 110 } ] [
   { 0 1 } <track>
-    <gadget> { 10 10 }   >>dim f track-add*
+    <gadget> { 10 10 }   >>dim f track-add
-    <gadget> { 100 100 } >>dim 1 track-add*
+    <gadget> { 100 100 } >>dim 1 track-add
   pref-dim
 ] unit-test

extra/ui/gadgets/tracks/tracks.factor

@@ -50,7 +50,7 @@ M: track pref-dim* ( gadget -- dim )
    tri
    set-axis ;
 
-: track-add* ( track gadget constraint -- track )
+: track-add ( track gadget constraint -- track )
   pick sizes>> push add-gadget ;
 
 : track-remove ( track gadget -- track )

extra/ui/gadgets/worlds/worlds.factor

@@ -40,7 +40,7 @@ M: world request-focus-on ( child gadget -- )
         { 0 0 } >>window-loc
         swap >>status
         swap >>title
-        swap 1 track-add*
+        swap 1 track-add
     dup request-focus ;
 
 M: world layout*

extra/ui/tools/browser/browser.factor

@@ -22,9 +22,9 @@ TUPLE: browser-gadget < track pane history ;
 : <browser-gadget> ( -- gadget )
   { 0 1 } browser-gadget new-track
     dup init-history
-    dup <toolbar> f track-add*
+    dup <toolbar> f track-add
     dup <help-pane> >>pane
-    dup pane>> <scroller> 1 track-add* ;
+    dup pane>> <scroller> 1 track-add ;
 
 M: browser-gadget call-tool* show-help ;
 

extra/ui/tools/debugger/debugger.factor

@@ -25,9 +25,9 @@ TUPLE: debugger < track restarts ;
 
 : <debugger> ( error restarts restart-hook -- gadget )
     { 0 1 } debugger new-track
-        dup <toolbar> f track-add*
+        dup <toolbar> f track-add
         -rot <restart-list> >>restarts
-        dup restarts>> rot <debugger-display> <scroller> 1 track-add* ;
+        dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
 
 M: debugger focusable-child* debugger-restarts ;
 

extra/ui/tools/inspector/inspector.factor

@@ -17,9 +17,9 @@ TUPLE: inspector-gadget < track object pane ;
 
 : <inspector-gadget> ( -- gadget )
   { 0 1 } inspector-gadget new-track
-    dup <toolbar> f track-add*
+    dup <toolbar> f track-add
     <pane> >>pane
-    dup pane>> <scroller> 1 track-add* ;
+    dup pane>> <scroller> 1 track-add ;
     
 : inspect-object ( obj mirror keys inspector -- )
     2nip swap >>object refresh ;

extra/ui/tools/listener/listener.factor

@@ -14,7 +14,7 @@ TUPLE: listener-gadget < track input output stack ;
 
 : listener-output, ( listener -- listener )
   <scrolling-pane> >>output
-  dup output>> <scroller> "Output" <labelled-gadget> 1 track-add* ;
+  dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
 
 : listener-streams ( listener -- input output )
     [ input>> ] [ output>> <pane-stream> ] bi ;
@@ -27,7 +27,7 @@ TUPLE: listener-gadget < track input output stack ;
   dup input>>
     { 0 100 } <limited-scroller>
     "Input" <labelled-gadget>
-  f track-add* ;
+  f track-add ;
 
 : welcome. ( -- )
    "If this is your first time with Factor, please read the " print
@@ -125,10 +125,10 @@ TUPLE: stack-display < track ;
 : <stack-display> ( workspace -- gadget )
   listener>>
   { 0 1 } stack-display new-track
-    over <toolbar> f track-add*
+    over <toolbar> f track-add
     swap
       stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
-    1 track-add* ;
+    1 track-add ;
 
 M: stack-display tool-scroller
     find-workspace workspace-listener tool-scroller ;

extra/ui/tools/profiler/profiler.factor

@@ -9,9 +9,9 @@ TUPLE: profiler-gadget < track pane ;
 
 : <profiler-gadget> ( -- gadget )
   { 0 1 } profiler-gadget new-track
-    dup <toolbar> f track-add*
+    dup <toolbar> f track-add
     <pane> >>pane
-    dup pane>> <scroller> 1 track-add* ;
+    dup pane>> <scroller> 1 track-add ;
     
 : with-profiler-pane ( gadget quot -- )
     >r profiler-gadget-pane r> with-pane ;

extra/ui/tools/search/search.factor

@@ -62,9 +62,9 @@ search-field H{
 : <live-search> ( string seq limited? presenter -- gadget )
   { 0 1 } live-search new-track
     <search-field> >>field
-    dup field>> f track-add*
+    dup field>> f track-add
     -roll <search-list> >>list
-    dup list>> <scroller> 1 track-add*
+    dup list>> <scroller> 1 track-add
 
   swap                         
     over field>> set-editor-string

extra/ui/tools/tools.factor

@@ -38,10 +38,10 @@ IN: ui.tools
     <listener-gadget>    >>listener
     dup <workspace-book> >>book
     
-    dup <workspace-tabs> f   track-add*
+    dup <workspace-tabs> f   track-add
-    dup book>>           1/5 track-add*
+    dup book>>           1/5 track-add
-    dup listener>>       4/5 track-add*
+    dup listener>>       4/5 track-add
-    dup <toolbar>        f   track-add* ;
+    dup <toolbar>        f   track-add ;
 
 : resize-workspace ( workspace -- )
     dup track-sizes over control-value zero? [

extra/ui/tools/traceback/traceback.factor

@@ -30,13 +30,13 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
 
     dup model>>
       { 1 0 } <track>
-        over <datastack-display>   1/2 track-add*
+        over <datastack-display>   1/2 track-add
-        swap <retainstack-display> 1/2 track-add*
+        swap <retainstack-display> 1/2 track-add
-      1/3 track-add*
+      1/3 track-add
 
-    dup model>> <callstack-display> 2/3 track-add*
+    dup model>> <callstack-display> 2/3 track-add
 
-    dup <toolbar> f track-add* ;
+    dup <toolbar> f track-add ;
 
 : <namestack-display> ( model -- gadget )
     [ [ continuation-name namestack. ] when* ]

extra/ui/tools/walker/walker.factor

@@ -62,9 +62,9 @@ M: walker-gadget focusable-child*
         swap >>status
         dup continuation>> <traceback-gadget> >>traceback
 
-        dup <toolbar>                     f track-add*
+        dup <toolbar>                     f track-add
-        dup status>> self <thread-status> f track-add*
+        dup status>> self <thread-status> f track-add
-        dup traceback>>                   1 track-add* ;
+        dup traceback>>                   1 track-add ;
     
 : walker-help ( -- ) "ui-walker" help-window ;
 

extra/ui/tools/workspace/workspace.factor

@@ -62,7 +62,7 @@ M: gadget tool-scroller drop f ;
 : show-popup ( gadget workspace -- )
   dup hide-popup
   over >>popup
-  over f track-add* drop
+  over f track-add drop
   request-focus ;
 
 : show-titled-popup ( workspace gadget title -- )

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

@@ -26,11 +26,9 @@ M: true-constraint assume
     [ \ f class-not <class-info> swap value>> refine-value-info ]
     bi ;
 
-M: true-constraint satisfied?
+M: true-constraint satisfied? value>> \ f class-not value-is? ;
-    value>> value-info class>> \ f class-not class<= ;
 
-M: true-constraint satisfiable?
+M: true-constraint satisfiable? value>> \ f class-not value-is? ;
-    value>> value-info class>> \ f class-not classes-intersect? ;
 
 TUPLE: false-constraint value ;
 

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

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs classes classes.algebra kernel accessors math
+USING: assocs classes classes.algebra kernel
-math.intervals namespaces sequences words combinators arrays
+accessors math math.intervals namespaces sequences words
-compiler.tree.copy-equiv ;
+combinators arrays compiler.tree.copy-equiv ;
 IN: compiler.tree.propagation.info
 
 SYMBOL: +interval+
@@ -17,12 +17,15 @@ M: complex eql? over complex? [ = ] [ 2drop f ] if ;
 
 ! Value info represents a set of objects. Don't mutate value infos
 ! you receive, always construct new ones. We don't declare the
-! slots read-only to allow cloning followed by writing.
+! slots read-only to allow cloning followed by writing, and to
+! simplify constructors.
 TUPLE: value-info
-{ class initial: null }
+class
-{ interval initial: empty-interval }
+interval
 literal
-literal? ;
+literal?
+length
+slots ;
 
 : class-interval ( class -- interval )
     dup real class<=
@@ -45,36 +48,60 @@ literal? ;
         } cond
     ] if ;
 
-: <value-info> ( class interval literal literal? -- info )
+: <value-info> ( -- info ) \ value-info new ;
-    [
+
-        2nip
+: init-value-info ( info -- info )
-        [ class ] [ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ] [ ] tri
+    dup literal?>> [
-        t
+        dup literal>> class >>class
+        dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
     ] [
-        drop
+        dup [ class>> null class<= ] [ interval>> empty-interval eq? ] bi or [
-        2dup [ null class<= ] [ empty-interval eq? ] bi* or [
+            null >>class
-            2drop null empty-interval f f
+            empty-interval >>interval
         ] [
-            over integer class<= [ integral-closure ] when
+            [ [-inf,inf] or ] change-interval
-            2dup interval>literal
+            dup class>> integer class<= [ [ integral-closure ] change-interval ] when
+            dup [ class>> ] [ interval>> ] bi interval>literal
+            [ >>literal ] [ >>literal? ] bi*
         ] if
-    ] if
+    ] if ;
-    \ value-info boa ; foldable
 
 : <class/interval-info> ( class interval -- info )
-    f f <value-info> ; foldable
+    <value-info>
+        swap >>interval
+        swap >>class
+    init-value-info ; foldable
 
 : <class-info> ( class -- info )
     dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or
     <class/interval-info> ; foldable
 
 : <interval-info> ( interval -- info )
-    real swap <class/interval-info> ; foldable
+    <value-info>
+        real >>class
+        swap >>interval
+    init-value-info ; foldable
 
 : <literal-info> ( literal -- info )
-    f f rot t <value-info> ; foldable
+    <value-info>
+        swap >>literal
+        t >>literal?
+    init-value-info ; foldable
 
-: >literal< ( info -- literal literal? ) [ literal>> ] [ literal?>> ] bi ;
+: <sequence-info> ( value -- info )
+    <value-info>
+        object >>class
+        swap value-info >>length
+    init-value-info ; foldable
+
+: <tuple-info> ( slots class -- info )
+    <value-info>
+        swap >>class
+        swap >>slots
+    init-value-info ;
+
+: >literal< ( info -- literal literal? )
+    [ literal>> ] [ literal?>> ] bi ;
 
 : intersect-literals ( info1 info2 -- literal literal? )
     {
@@ -84,11 +111,30 @@ literal? ;
         [ drop >literal< ]
     } cond ;
 
+DEFER: value-info-intersect
+
+: intersect-lengths ( info1 info2 -- length )
+    [ length>> ] bi@ {
+        { [ dup not ] [ drop ] }
+        { [ over not ] [ nip ] }
+        [ value-info-intersect ]
+    } cond ;
+
+: intersect-slots ( info1 info2 -- slots )
+    [ slots>> ] bi@
+    2dup [ length ] bi@ =
+    [ [ value-info-intersect ] 2map ] [ 2drop f ] if ;
+
 : (value-info-intersect) ( info1 info2 -- info )
-    [ [ class>> ] bi@ class-and ]
+    [ <value-info> ] 2dip
-    [ [ interval>> ] bi@ interval-intersect ]
+    {
-    [ intersect-literals ]
+        [ [ class>> ] bi@ class-and >>class ]
-    2tri <value-info> ;
+        [ [ interval>> ] bi@ interval-intersect >>interval ]
+        [ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
+        [ intersect-lengths >>length ]
+        [ intersect-slots >>slots ]
+    } 2cleave
+    init-value-info ;
 
 : value-info-intersect ( info1 info2 -- info )
     {
@@ -102,11 +148,30 @@ literal? ;
         [ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
     ] [ 2drop f f ] if ;
 
+DEFER: value-info-union
+
+: union-lengths ( info1 info2 -- length )
+    [ length>> ] bi@ {
+        { [ dup not ] [ nip ] }
+        { [ over not ] [ drop ] }
+        [ value-info-union ]
+    } cond ;
+
+: union-slots ( info1 info2 -- slots )
+    [ slots>> ] bi@
+    2dup [ length ] bi@ =
+    [ [ value-info-union ] 2map ] [ 2drop f ] if ;
+
 : (value-info-union) ( info1 info2 -- info )
-    [ [ class>> ] bi@ class-or ]
+    [ <value-info> ] 2dip
-    [ [ interval>> ] bi@ interval-union ]
+    {
-    [ union-literals ]
+        [ [ class>> ] bi@ class-or >>class ]
-    2tri <value-info> ;
+        [ [ interval>> ] bi@ interval-union >>interval ]
+        [ union-literals [ >>literal ] [ >>literal? ] bi* ]
+        [ union-lengths >>length ]
+        [ union-slots >>slots ]
+    } 2cleave
+    init-value-info ;
 
 : value-info-union ( info1 info2 -- info )
     {
@@ -122,7 +187,8 @@ literal? ;
 SYMBOL: value-infos
 
 : value-info ( value -- info )
-    resolve-copy value-infos get at T{ value-info } or ;
+    resolve-copy value-infos get at
+    T{ value-info f null empty-interval } or ;
 
 : set-value-info ( info value -- )
     resolve-copy value-infos get set-at ;
@@ -144,3 +210,6 @@ SYMBOL: value-infos
             [ { t f } ]
         } cond nip
     ] if ;
+
+: value-is? ( value class -- ? )
+    [ value-info class>> ] dip class<= ;

unfinished/compiler/tree/propagation/known-words/known-words.factor

@@ -185,6 +185,27 @@ generic-comparison-ops [
     '[ , fold-comparison ] +outputs+ set-word-prop
 ] each
 
+: maybe-or-never ( ? -- info )
+    [ object <class-info> ] [ \ f <class-info> ] if ;
+
+: info-intervals-intersect? ( info1 info2 -- ? )
+    [ interval>> ] bi@ intervals-intersect? ;
+
+{ number= bignum= float= } [
+    [
+        info-intervals-intersect? maybe-or-never
+    ] +outputs+ set-word-prop
+] each
+
+: info-classes-intersect? ( info1 info2 -- ? )
+    [ class>> ] bi@ classes-intersect? ;
+
+\ eq? [
+    [ info-intervals-intersect? ]
+    [ info-classes-intersect? ]
+    bi or maybe-or-never
+] +outputs+ set-word-prop
+
 {
     { >fixnum fixnum }
     { >bignum bignum }

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

@@ -2,7 +2,9 @@ USING: kernel compiler.tree.builder compiler.tree
 compiler.tree.propagation compiler.tree.copy-equiv
 compiler.tree.def-use tools.test math math.order
 accessors sequences arrays kernel.private vectors
-alien.accessors alien.c-types sequences.private ;
+alien.accessors alien.c-types sequences.private
+byte-arrays classes.algebra math.functions math.private
+strings ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -232,3 +234,101 @@ IN: compiler.tree.propagation.tests
 [ V{ 2 } ] [
     [ [ 1 ] [ 1 ] if 1 + ] final-literals
 ] unit-test
+
+[ V{ string string } ] [
+    [
+        2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
+    ] final-classes
+] unit-test
+
+! Array length propagation
+[ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
+
+[ V{ t } ] [ [ [ 10 f <array> ] [ 10 <byte-array> ] if length 10 = ] final-literals ] unit-test
+
+[ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test
+
+! Slot propagation
+TUPLE: prop-test-tuple { x integer } ;
+
+[ V{ integer } ] [ [ { prop-test-tuple } declare x>> ] final-classes ] unit-test
+
+TUPLE: another-prop-test-tuple { x ratio initial: 1/2 } ;
+
+UNION: prop-test-union prop-test-tuple another-prop-test-tuple ;
+
+[ t ] [
+    [ { prop-test-union } declare x>> ] final-classes first
+    rational class=
+] unit-test
+
+TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ;
+
+[ V{ T{ fold-boa-test-tuple f 1 2 3 } } ]
+[ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ]
+unit-test
+
+TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
+
+[ V{ T{ immutable-prop-test-tuple f "hey" } } ] [
+    [ "hey" immutable-prop-test-tuple boa ] final-literals
+] unit-test
+
+[ V{ { 1 2 } } ] [
+    [ { 1 2 } immutable-prop-test-tuple boa x>> ] final-literals
+] unit-test
+
+[ V{ array } ] [
+    [ { array } declare immutable-prop-test-tuple boa x>> ] final-classes
+] unit-test
+
+[ V{ complex } ] [
+    [ <complex> ] final-classes
+] unit-test
+
+[ V{ complex } ] [
+    [ { float float } declare dup 0.0 <= [ "Oops" throw ] [ rect> ] if ] final-classes
+] unit-test
+
+[ V{ float float } ] [
+    [
+        { float float } declare
+        dup 0.0 <= [ "Oops" throw ] when rect>
+        [ real>> ] [ imaginary>> ] bi
+    ] final-classes
+] unit-test
+
+[ V{ complex } ] [
+    [
+        { float float object } declare
+        [ "Oops" throw ] [ <complex> ] if
+    ] final-classes
+] unit-test
+
+[ V{ number } ] [ [ [ "Oops" throw ] [ 2 + ] if ] final-classes ] unit-test
+[ V{ number } ] [ [ [ 2 + ] [ "Oops" throw ] if ] final-classes ] unit-test
+
+[ V{ POSTPONE: f } ] [
+    [ dup 1.0 <= [ drop f ] [ 0 number= ] if ] final-classes
+] unit-test
+
+! Don't fold this
+TUPLE: mutable-tuple-test { x sequence } ;
+
+[ V{ sequence } ] [
+    [ "hey" mutable-tuple-test boa x>> ] final-classes
+] unit-test
+
+[ V{ sequence } ] [
+    [ T{ mutable-tuple-test f "hey" } x>> ] final-classes
+] unit-test
+
+! Mixed mutable and immutable slots
+TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
+
+[ V{ integer array } ] [
+    [
+        3 { 2 1 } mixed-mutable-immutable boa
+        [ x>> ] [ y>> ] bi
+    ] final-classes
+] unit-test

unfinished/compiler/tree/propagation/simple/simple.factor

@@ -1,11 +1,14 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors kernel sequences assocs words namespaces
+USING: fry accessors kernel sequences sequences.private assocs
-classes.algebra combinators classes continuations
+words namespaces classes.algebra combinators classes
+classes.tuple classes.tuple.private continuations arrays
+byte-arrays strings math math.private slots
 compiler.tree
 compiler.tree.def-use
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
+compiler.tree.propagation.slots
 compiler.tree.propagation.constraints ;
 IN: compiler.tree.propagation.simple
 
@@ -52,6 +55,17 @@ M: #declare propagate-before
     [ word>> +outputs+ word-prop ]
     bi with-datastack ;
 
+: foldable-word? ( #call -- ? )
+    dup word>> "foldable" word-prop [
+        drop t
+    ] [
+        dup word>> \ <tuple-boa> eq? [
+            in-d>> peek value-info literal>> immutable-tuple-class?
+        ] [
+            drop f
+        ] if
+    ] if ;
+
 : foldable-call? ( #call -- ? )
     dup word>> "foldable" word-prop [
         in-d>> [ value-info literal?>> ] all?
@@ -75,6 +89,10 @@ M: #declare propagate-before
 : output-value-infos ( node -- infos )
     {
         { [ dup foldable-call? ] [ fold-call ] }
+        { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
+        { [ dup word>> reader? ] [ reader-word-outputs ] }
+        { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
+        { [ dup length-accessor? ] [ propagate-length ] }
         { [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
         [ default-output-value-infos ]
     } cond ;
@@ -86,12 +104,16 @@ M: #call propagate-before
 
 M: node propagate-before drop ;
 
+: propagate-input-classes ( node -- )
+    [ word>> "input-classes" word-prop class-infos ] [ in-d>> ] bi
+    refine-value-infos ;
+
 M: #call propagate-after
-    dup word>> "input-classes" word-prop dup [
+    {
-        class-infos swap in-d>> refine-value-infos
+        { [ dup reader? ] [ reader-word-inputs ] }
-    ] [
+        { [ dup word>> "input-classes" word-prop ] [ propagate-input-classes ] }
-        2drop
+        [ drop ]
-    ] if ;
+    } cond ;
 
 M: node propagate-after drop ;
 

unfinished/compiler/tree/propagation/slots/slots.factor

@@ -0,0 +1,111 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry assocs arrays byte-arrays strings accessors sequences
+kernel slots classes.algebra classes.tuple classes.tuple.private
+words math math.private combinators sequences.private namespaces
+compiler.tree.propagation.info ;
+IN: compiler.tree.propagation.slots
+
+! Propagation of immutable slots and array lengths
+
+! Revisit this code when delegation is removed and when complex
+! numbers become tuples.
+
+UNION: fixed-length-sequence array byte-array string ;
+
+: sequence-constructor? ( node -- ? )
+    word>> { <array> <byte-array> <string> } memq? ;
+
+: constructor-output-class ( word -- class )
+    {
+        { <array> array }
+        { <byte-array> byte-array }
+        { <string> string }
+    } at ;
+
+: propagate-sequence-constructor ( node -- infos )
+    [ word>> constructor-output-class <class-info> ]
+    [ in-d>> first <sequence-info> ]
+    bi value-info-intersect 1array ;
+
+: length-accessor? ( node -- ? )
+    dup in-d>> first fixed-length-sequence value-is?
+    [ word>> \ length eq? ] [ drop f ] if ;
+
+: propagate-length ( node -- infos )
+    in-d>> first value-info length>>
+    [ array-capacity <class-info> ] unless* 1array ;
+
+: tuple-constructor? ( node -- ? )
+    word>> { <tuple-boa> <complex> } memq? ;
+
+: propagate-<tuple-boa> ( node -- info )
+    #! Delegation
+    in-d>> [ value-info ] map unclip-last
+    literal>> class>> dup immutable-tuple-class? [
+        over [ literal?>> ] all?
+        [ [ , f , [ literal>> ] map % ] { } make >tuple <literal-info> ]
+        [ <tuple-info> ]
+        if
+    ] [ nip <class-info> ] if ;
+
+: propagate-<complex> ( node -- info )
+    in-d>> [ value-info ] map complex <tuple-info> ;
+
+: propagate-tuple-constructor ( node -- infos )
+    dup word>> {
+        { \ <tuple-boa> [ propagate-<tuple-boa> ] }
+        { \ <complex> [ propagate-<complex> ] }
+    } case 1array ;
+
+: relevant-methods ( node -- methods )
+    [ word>> "methods" word-prop ]
+    [ in-d>> first value-info class>> ] bi
+    '[ drop , classes-intersect? ] assoc-filter ;
+
+: relevant-slots ( node -- slots )
+    relevant-methods [ nip "reading" word-prop ] { } assoc>map ;
+
+: no-reader-methods ( input slots -- info )
+    2drop null <class-info> ;
+
+: same-offset ( slots -- slot/f )
+    dup [ dup [ read-only>> ] when ] all? [
+        [ offset>> ] map dup all-equal? [ first ] [ drop f ] if
+    ] [ drop f ] if ;
+
+: (reader-word-outputs) ( reader -- info )
+    null
+    [ [ class>> ] [ object ] if* class-or ] reduce
+    <class-info> ;
+
+: value-info-slot ( slot info -- info' )
+    #! Delegation.
+    [ class>> complex class<= 1 3 ? - ] keep
+    dup literal?>> [
+        literal>> {
+            { [ dup tuple? ] [
+                tuple-slots 1 tail-slice nth <literal-info>
+            ] }
+            { [ dup complex? ] [
+                [ real-part ] [ imaginary-part ] bi
+                2array nth <literal-info>
+            ] }
+        } cond
+    ] [ slots>> ?nth ] if ;
+
+: reader-word-outputs ( node -- infos )
+    [ relevant-slots ] [ in-d>> first ] bi
+    over empty? [ no-reader-methods ] [
+        over same-offset dup
+        [ swap value-info value-info-slot ] [ 2drop f ] if
+        [ ] [ (reader-word-outputs) ] ?if
+    ] if 1array ;
+
+: reader-word-inputs ( node -- )
+    [ in-d>> first ] [
+        relevant-slots keys
+        object [ class>> [ class-and ] when* ] reduce
+        <class-info>
+    ] bi
+    refine-value-info ;

unfinished/stack-checker/branches/branches.factor

@@ -7,7 +7,7 @@ stack-checker.backend stack-checker.errors stack-checker.visitor
 IN: stack-checker.branches
 
 : balanced? ( seq -- ? )
-    [ first2 length - ] map all-equal? ;
+    [ second ] filter [ first2 length - ] map all-equal? ;
 
 : phi-inputs ( seq -- newseq )
     dup empty? [
@@ -16,7 +16,7 @@ IN: stack-checker.branches
     ] unless ;
 
 : unify-values ( values -- phi-out )
-    dup [ known ] map dup all-eq?
+    dup sift [ known ] map dup all-eq?
     [ nip first make-known ] [ 2drop <value> ] if ;
 
 : phi-outputs ( phi-in -- stack )
@@ -25,7 +25,7 @@ IN: stack-checker.branches
 SYMBOL: quotations
 
 : unify-branches ( ins stacks -- in phi-in phi-out )
-    zip [ second ] filter dup empty? [ drop 0 { } { } ] [
+    zip dup empty? [ drop 0 { } { } ] [
         dup balanced?
         [ [ keys supremum ] [ values phi-inputs dup phi-outputs ] bi ]
         [ quotations get unbalanced-branches-error ]