From 147a90a0b69abe17fd4a868ee26db3aebc00881e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 24 Jul 2008 15:34:25 -0500
Subject: [PATCH 01/11] Fix load error
---
extra/24-game/24-game.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor
index 86940dfa95..569cef8302 100644
--- a/extra/24-game/24-game.factor
+++ b/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 ;
From 1ec4f750474d450ed86895ebd13393037690a755 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 24 Jul 2008 16:14:59 -0500
Subject: [PATCH 02/11] ui.gadgets.tracks: Add 'track-add' in preperation for
'track-add*' removal
---
extra/ui/gadgets/tracks/tracks.factor | 3 +++
1 file changed, 3 insertions(+)
diff --git a/extra/ui/gadgets/tracks/tracks.factor b/extra/ui/gadgets/tracks/tracks.factor
index 4aba8f45ef..55c22e3519 100644
--- a/extra/ui/gadgets/tracks/tracks.factor
+++ b/extra/ui/gadgets/tracks/tracks.factor
@@ -53,6 +53,9 @@ M: track pref-dim* ( gadget -- dim )
: track-add* ( track gadget constraint -- track )
pick sizes>> push add-gadget ;
+: track-add ( track gadget constraint -- track )
+ pick sizes>> push add-gadget ;
+
: track-remove ( track gadget -- track )
dupd dup
[
From 3d9607bda0e849b9d46728a956d8aaf2aa5858b1 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 24 Jul 2008 16:15:40 -0500
Subject: [PATCH 03/11] ui.gadgets.tracks-docs: Help for 'track-add'
---
extra/ui/gadgets/tracks/tracks-docs.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/ui/gadgets/tracks/tracks-docs.factor b/extra/ui/gadgets/tracks/tracks-docs.factor
index 2c2ebac15d..7fbbd1a330 100755
--- a/extra/ui/gadgets/tracks/tracks-docs.factor
+++ b/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." } ;
From a81969b26806cb7c56e088872e0a45ff03475deb Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 24 Jul 2008 16:16:13 -0500
Subject: [PATCH 04/11] Replace usages of 'track-add*' with 'track-add'
---
extra/ui/gadgets/labelled/labelled.factor | 4 ++--
extra/ui/gadgets/labels/labels.factor | 8 ++++----
extra/ui/gadgets/slots/slots.factor | 10 +++++-----
extra/ui/gadgets/status-bar/status-bar.factor | 2 +-
extra/ui/gadgets/worlds/worlds.factor | 2 +-
extra/ui/tools/browser/browser.factor | 4 ++--
extra/ui/tools/debugger/debugger.factor | 4 ++--
extra/ui/tools/inspector/inspector.factor | 4 ++--
extra/ui/tools/listener/listener.factor | 8 ++++----
extra/ui/tools/profiler/profiler.factor | 4 ++--
extra/ui/tools/search/search.factor | 4 ++--
extra/ui/tools/tools.factor | 8 ++++----
extra/ui/tools/traceback/traceback.factor | 10 +++++-----
extra/ui/tools/walker/walker.factor | 6 +++---
extra/ui/tools/workspace/workspace.factor | 2 +-
15 files changed, 40 insertions(+), 40 deletions(-)
diff --git a/extra/ui/gadgets/labelled/labelled.factor b/extra/ui/gadgets/labelled/labelled.factor
index 686e940ae6..831ac1b1d8 100755
--- a/extra/ui/gadgets/labelled/labelled.factor
+++ b/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 ;
diff --git a/extra/ui/gadgets/labels/labels.factor b/extra/ui/gadgets/labels/labels.factor
index e965d6b2b8..a3a5c1a0a6 100755
--- a/extra/ui/gadgets/labels/labels.factor
+++ b/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 1 track-add* ;
+ swap >label f track-add
+ swap 1 track-add ;
: label-on-right ( label gadget -- button )
{ 1 0 } <track>
- swap f track-add*
- swap >label 1 track-add* ;
+ swap f track-add
+ swap >label 1 track-add ;
diff --git a/extra/ui/gadgets/slots/slots.factor b/extra/ui/gadgets/slots/slots.factor
index 2ce4a1fa8c..0102876136 100755
--- a/extra/ui/gadgets/slots/slots.factor
+++ b/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*
- <edit-button> f track-add*
+ swap 1 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 ;
diff --git a/extra/ui/gadgets/status-bar/status-bar.factor b/extra/ui/gadgets/status-bar/status-bar.factor
index 9c709c2f78..431804f4ca 100755
--- a/extra/ui/gadgets/status-bar/status-bar.factor
+++ b/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 -- )
diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor
index 69bb8a13c0..88ba99201b 100755
--- a/extra/ui/gadgets/worlds/worlds.factor
+++ b/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*
diff --git a/extra/ui/tools/browser/browser.factor b/extra/ui/tools/browser/browser.factor
index ee427625f5..8f180714c8 100755
--- a/extra/ui/tools/browser/browser.factor
+++ b/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 ;
diff --git a/extra/ui/tools/debugger/debugger.factor b/extra/ui/tools/debugger/debugger.factor
index 6ed98f4964..203406c6cb 100644
--- a/extra/ui/tools/debugger/debugger.factor
+++ b/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 ;
diff --git a/extra/ui/tools/inspector/inspector.factor b/extra/ui/tools/inspector/inspector.factor
index 8c92567fe5..bb0f02ec7e 100644
--- a/extra/ui/tools/inspector/inspector.factor
+++ b/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 ;
diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor
index baad793e3b..9890c21491 100755
--- a/extra/ui/tools/listener/listener.factor
+++ b/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 ;
diff --git a/extra/ui/tools/profiler/profiler.factor b/extra/ui/tools/profiler/profiler.factor
index 9d25361e5e..f440bd8766 100755
--- a/extra/ui/tools/profiler/profiler.factor
+++ b/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 ;
diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor
index 0a8fe92762..2475ecc691 100755
--- a/extra/ui/tools/search/search.factor
+++ b/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
diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor
index c73e9bc5b1..4bfb209e3a 100755
--- a/extra/ui/tools/tools.factor
+++ b/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 book>> 1/5 track-add*
- dup listener>> 4/5 track-add*
- dup <toolbar> f track-add* ;
+ dup <workspace-tabs> f track-add
+ dup book>> 1/5 track-add
+ dup listener>> 4/5 track-add
+ dup <toolbar> f track-add ;
: resize-workspace ( workspace -- )
dup track-sizes over control-value zero? [
diff --git a/extra/ui/tools/traceback/traceback.factor b/extra/ui/tools/traceback/traceback.factor
index ffea857429..6438bc0ebb 100755
--- a/extra/ui/tools/traceback/traceback.factor
+++ b/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*
- swap <retainstack-display> 1/2 track-add*
- 1/3 track-add*
+ over <datastack-display> 1/2 track-add
+ swap <retainstack-display> 1/2 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* ]
diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor
index e5141fb844..c667e6918d 100755
--- a/extra/ui/tools/walker/walker.factor
+++ b/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 status>> self <thread-status> f track-add*
- dup traceback>> 1 track-add* ;
+ dup <toolbar> f track-add
+ dup status>> self <thread-status> f track-add
+ dup traceback>> 1 track-add ;
: walker-help ( -- ) "ui-walker" help-window ;
diff --git a/extra/ui/tools/workspace/workspace.factor b/extra/ui/tools/workspace/workspace.factor
index 86cfdb02c7..0780103415 100755
--- a/extra/ui/tools/workspace/workspace.factor
+++ b/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 -- )
From ab6694ad4c75dabc5a3b30a3c5e7412caee7a9aa Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 24 Jul 2008 16:18:39 -0500
Subject: [PATCH 05/11] ui.gadgets.tiling: use 'track-add'
---
extra/ui/gadgets/tiling/tiling.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/ui/gadgets/tiling/tiling.factor b/extra/ui/gadgets/tiling/tiling.factor
index 22b473e44b..2d096966af 100644
--- a/extra/ui/gadgets/tiling/tiling.factor
+++ b/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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From 05a506e94500c439a6b2e2f31ca6d00d0e498c12 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 24 Jul 2008 16:20:45 -0500
Subject: [PATCH 06/11] ui.gadgets.tracks-tests: use 'track-add' instead of
'track-add*'
---
extra/ui/gadgets/tracks/tracks-tests.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/extra/ui/gadgets/tracks/tracks-tests.factor b/extra/ui/gadgets/tracks/tracks-tests.factor
index 210a7c5771..6feaf52b47 100644
--- a/extra/ui/gadgets/tracks/tracks-tests.factor
+++ b/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> { 100 100 } >>dim 1 track-add*
+ <gadget> { 10 10 } >>dim f track-add
+ <gadget> { 100 100 } >>dim 1 track-add
pref-dim
] unit-test
From 7c1e4fcaaeaaa2fa8eddb380945288db316356a4 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 24 Jul 2008 16:32:47 -0500
Subject: [PATCH 07/11] ui.gadgets.tracks: remove 'track-add*'
---
extra/ui/gadgets/tracks/tracks.factor | 3 ---
1 file changed, 3 deletions(-)
diff --git a/extra/ui/gadgets/tracks/tracks.factor b/extra/ui/gadgets/tracks/tracks.factor
index 55c22e3519..cf679424e0 100644
--- a/extra/ui/gadgets/tracks/tracks.factor
+++ b/extra/ui/gadgets/tracks/tracks.factor
@@ -50,9 +50,6 @@ M: track pref-dim* ( gadget -- dim )
tri
set-axis ;
-: track-add* ( track gadget constraint -- track )
- pick sizes>> push add-gadget ;
-
: track-add ( track gadget constraint -- track )
pick sizes>> push add-gadget ;
From a5efaa49a0eda2165dfadb2cf4c91a042b19da0a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 24 Jul 2008 17:34:08 -0500
Subject: [PATCH 08/11] Array length propagation
---
.../constraints/constraints.factor | 6 +-
.../tree/propagation/info/info.factor | 98 ++++++++++++++-----
.../tree/propagation/propagation-tests.factor | 9 +-
.../tree/propagation/simple/simple.factor | 25 ++++-
4 files changed, 106 insertions(+), 32 deletions(-)
diff --git a/unfinished/compiler/tree/propagation/constraints/constraints.factor b/unfinished/compiler/tree/propagation/constraints/constraints.factor
index e49e478ec4..42c094db5a 100644
--- a/unfinished/compiler/tree/propagation/constraints/constraints.factor
+++ b/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?
- value>> value-info class>> \ f class-not class<= ;
+M: true-constraint satisfied? value>> \ f class-not value-is? ;
-M: true-constraint satisfiable?
- value>> value-info class>> \ f class-not classes-intersect? ;
+M: true-constraint satisfiable? value>> \ f class-not value-is? ;
TUPLE: false-constraint value ;
diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor
index 90ef41754a..2572e167a1 100644
--- a/unfinished/compiler/tree/propagation/info/info.factor
+++ b/unfinished/compiler/tree/propagation/info/info.factor
@@ -22,7 +22,8 @@ TUPLE: value-info
{ class initial: null }
{ interval initial: empty-interval }
literal
-literal? ;
+literal?
+length ;
: class-interval ( class -- interval )
dup real class<=
@@ -45,36 +46,54 @@ literal? ;
} cond
] if ;
-: <value-info> ( class interval literal literal? -- info )
- [
- 2nip
- [ class ] [ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ] [ ] tri
- t
+: <value-info> ( -- info ) \ value-info new ;
+
+: init-value-info ( info -- info )
+ dup literal?>> [
+ dup literal>> class >>class
+ dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
] [
- drop
- 2dup [ null class<= ] [ empty-interval eq? ] bi* or [
- 2drop null empty-interval f f
+ dup [ class>> null class<= ] [ interval>> empty-interval eq? ] bi or [
+ null >>class
+ empty-interval >>interval
] [
- over integer class<= [ integral-closure ] when
- 2dup interval>literal
+ dup class>> integer class<= [ [ integral-closure ] change-interval ] when
+ dup [ class>> ] [ interval>> ] bi interval>literal
+ [ >>literal ] [ >>literal? ] bi*
] if
- ] if
- \ value-info boa ; foldable
+ ] if ;
: <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
+ [-inf,inf] >>interval
+ swap value-info >>length
+ init-value-info ; foldable
+
+: >literal< ( info -- literal literal? )
+ [ literal>> ] [ literal?>> ] bi ;
: intersect-literals ( info1 info2 -- literal literal? )
{
@@ -84,11 +103,24 @@ 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 ;
+
: (value-info-intersect) ( info1 info2 -- info )
- [ [ class>> ] bi@ class-and ]
- [ [ interval>> ] bi@ interval-intersect ]
- [ intersect-literals ]
- 2tri <value-info> ;
+ [ <value-info> ] 2dip
+ {
+ [ [ class>> ] bi@ class-and >>class ]
+ [ [ interval>> ] bi@ interval-intersect >>interval ]
+ [ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
+ [ intersect-lengths >>length ]
+ } 2cleave
+ init-value-info ;
: value-info-intersect ( info1 info2 -- info )
{
@@ -102,11 +134,24 @@ 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 ;
+
: (value-info-union) ( info1 info2 -- info )
- [ [ class>> ] bi@ class-or ]
- [ [ interval>> ] bi@ interval-union ]
- [ union-literals ]
- 2tri <value-info> ;
+ [ <value-info> ] 2dip
+ {
+ [ [ class>> ] bi@ class-or >>class ]
+ [ [ interval>> ] bi@ interval-union >>interval ]
+ [ union-literals [ >>literal ] [ >>literal? ] bi* ]
+ [ union-lengths >>length ]
+ } 2cleave
+ init-value-info ;
: value-info-union ( info1 info2 -- info )
{
@@ -144,3 +189,6 @@ SYMBOL: value-infos
[ { t f } ]
} cond nip
] if ;
+
+: value-is? ( value class -- ? )
+ [ value-info class>> ] dip class<= ;
diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor
index 9fcfbdefff..5d278b27b0 100644
--- a/unfinished/compiler/tree/propagation/propagation-tests.factor
+++ b/unfinished/compiler/tree/propagation/propagation-tests.factor
@@ -2,7 +2,8 @@ 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 ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
@@ -232,3 +233,9 @@ IN: compiler.tree.propagation.tests
[ V{ 2 } ] [
[ [ 1 ] [ 1 ] if 1 + ] final-literals
] unit-test
+
+[ 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
diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor
index b02f7700a6..6b8efd77e9 100644
--- a/unfinished/compiler/tree/propagation/simple/simple.factor
+++ b/unfinished/compiler/tree/propagation/simple/simple.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors kernel sequences assocs words namespaces
-classes.algebra combinators classes continuations
+USING: fry accessors kernel sequences sequences.private assocs
+words namespaces classes.algebra combinators classes
+continuations arrays byte-arrays strings
compiler.tree
compiler.tree.def-use
compiler.tree.propagation.info
@@ -72,9 +73,29 @@ M: #declare propagate-before
out-d>> length object <class-info> <repetition>
] ?if ;
+UNION: fixed-length-sequence array byte-array string ;
+
+: sequence-constructor? ( node -- ? )
+ word>> { <array> <byte-array> <string> } memq? ;
+
+: propagate-sequence-constructor ( node -- infos )
+ [ default-output-value-infos first ]
+ [ 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 ;
+
: output-value-infos ( node -- infos )
{
{ [ dup foldable-call? ] [ fold-call ] }
+ { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
+ { [ dup length-accessor? ] [ propagate-length ] }
{ [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
[ default-output-value-infos ]
} cond ;
From 7b9d3d844db701c6ad21429df6de923fb24a77c3 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 24 Jul 2008 18:13:27 -0500
Subject: [PATCH 09/11] shell: Remove calls to 'ast>>'
---
extra/shell/shell.factor | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/extra/shell/shell.factor b/extra/shell/shell.factor
index 45c6f1fb4d..e694b36007 100644
--- a/extra/shell/shell.factor
+++ b/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 ;
From 0fd34b4a4b8050a9f0d62ecf7c89205a3d6ceed4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 24 Jul 2008 21:47:09 -0500
Subject: [PATCH 10/11] Fix <process-writer> and <process-stream>
---
extra/io/launcher/launcher.factor | 4 ++--
extra/io/unix/launcher/launcher-tests.factor | 13 +++++++++++--
2 files changed, 13 insertions(+), 4 deletions(-)
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index f556bac35c..09f240c53a 100755
--- a/extra/io/launcher/launcher.factor
+++ b/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* ]
diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor
index 6d1f7f1796..33988c273b 100755
--- a/extra/io/unix/launcher/launcher-tests.factor
+++ b/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
From c6915b10231f6291dcf388c86d34106f9e1c3d50 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 25 Jul 2008 02:07:45 -0500
Subject: [PATCH 11/11] Working on tuple slot propagation
---
core/classes/tuple/tuple.factor | 4 +
core/kernel/kernel.factor | 8 +-
core/math/intervals/intervals.factor | 3 +
core/slots/slots.factor | 26 +++-
core/words/words.factor | 1 +
.../tree/propagation/info/info.factor | 39 ++++--
.../known-words/known-words.factor | 21 ++++
.../tree/propagation/propagation-tests.factor | 95 ++++++++++++++-
.../tree/propagation/simple/simple.factor | 49 ++++----
.../tree/propagation/slots/slots.factor | 111 ++++++++++++++++++
.../stack-checker/branches/branches.factor | 6 +-
11 files changed, 314 insertions(+), 49 deletions(-)
create mode 100644 unfinished/compiler/tree/propagation/slots/slots.factor
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 4216a5dc3d..42b5826e95 100755
--- a/core/classes/tuple/tuple.factor
+++ b/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 )
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 68feb7a94a..e8d3de4b11 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -165,13 +165,9 @@ GENERIC: boa ( ... class -- tuple )
compose compose ; inline
! Booleans
-: not ( obj -- ? )
- #! Not inline because its special-cased by compiler.
- f eq? ;
+: not ( obj -- ? ) f t ? ; inline
-: and ( obj1 obj2 -- ? )
- #! Not inline because its special-cased by compiler.
- over ? ;
+: and ( obj1 obj2 -- ? ) over ? ; inline
: >boolean ( obj -- ? ) t f ? ; inline
diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor
index 1896943a71..8afbee3478 100755
--- a/core/math/intervals/intervals.factor
+++ b/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 ] }
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 73d674782d..8754444ce0 100755
--- a/core/slots/slots.factor
+++ b/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 )
- read-only>> { "foldable" "flushable" } { "flushable" } ? ;
+: reader-props ( slot-spec -- assoc )
+ [
+ [ "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 ;
diff --git a/core/words/words.factor b/core/words/words.factor
index 5cf15abfa4..535295007e 100755
--- a/core/words/words.factor
+++ b/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 ;
diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor
index 2572e167a1..dc24b58bce 100644
--- a/unfinished/compiler/tree/propagation/info/info.factor
+++ b/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
-math.intervals namespaces sequences words combinators arrays
-compiler.tree.copy-equiv ;
+USING: assocs classes classes.algebra kernel
+accessors math math.intervals namespaces sequences words
+combinators arrays compiler.tree.copy-equiv ;
IN: compiler.tree.propagation.info
SYMBOL: +interval+
@@ -17,13 +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 }
-{ interval initial: empty-interval }
+class
+interval
literal
literal?
-length ;
+length
+slots ;
: class-interval ( class -- interval )
dup real class<=
@@ -57,6 +59,7 @@ length ;
null >>class
empty-interval >>interval
] [
+ [ [-inf,inf] or ] change-interval
dup class>> integer class<= [ [ integral-closure ] change-interval ] when
dup [ class>> ] [ interval>> ] bi interval>literal
[ >>literal ] [ >>literal? ] bi*
@@ -88,10 +91,15 @@ length ;
: <sequence-info> ( value -- info )
<value-info>
object >>class
- [-inf,inf] >>interval
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 ;
@@ -112,6 +120,11 @@ DEFER: value-info-intersect
[ 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 )
[ <value-info> ] 2dip
{
@@ -119,6 +132,7 @@ DEFER: value-info-intersect
[ [ interval>> ] bi@ interval-intersect >>interval ]
[ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
[ intersect-lengths >>length ]
+ [ intersect-slots >>slots ]
} 2cleave
init-value-info ;
@@ -143,6 +157,11 @@ DEFER: value-info-union
[ 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 )
[ <value-info> ] 2dip
{
@@ -150,6 +169,7 @@ DEFER: value-info-union
[ [ interval>> ] bi@ interval-union >>interval ]
[ union-literals [ >>literal ] [ >>literal? ] bi* ]
[ union-lengths >>length ]
+ [ union-slots >>slots ]
} 2cleave
init-value-info ;
@@ -167,7 +187,8 @@ DEFER: value-info-union
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 ;
diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor
index e358dd5be1..bfdcff51c5 100644
--- a/unfinished/compiler/tree/propagation/known-words/known-words.factor
+++ b/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 }
diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor
index 5d278b27b0..82f8ce1e4d 100644
--- a/unfinished/compiler/tree/propagation/propagation-tests.factor
+++ b/unfinished/compiler/tree/propagation/propagation-tests.factor
@@ -3,7 +3,8 @@ 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
-byte-arrays ;
+byte-arrays classes.algebra math.functions math.private
+strings ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
@@ -234,8 +235,100 @@ IN: compiler.tree.propagation.tests
[ [ 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
diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor
index 6b8efd77e9..10beb6f6e0 100644
--- a/unfinished/compiler/tree/propagation/simple/simple.factor
+++ b/unfinished/compiler/tree/propagation/simple/simple.factor
@@ -2,11 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences sequences.private assocs
words namespaces classes.algebra combinators classes
-continuations arrays byte-arrays strings
+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
@@ -53,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?
@@ -73,27 +86,11 @@ M: #declare propagate-before
out-d>> length object <class-info> <repetition>
] ?if ;
-UNION: fixed-length-sequence array byte-array string ;
-
-: sequence-constructor? ( node -- ? )
- word>> { <array> <byte-array> <string> } memq? ;
-
-: propagate-sequence-constructor ( node -- infos )
- [ default-output-value-infos first ]
- [ 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 ;
-
: 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 ] }
@@ -107,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
- ] [
- 2drop
- ] if ;
+ {
+ { [ dup reader? ] [ reader-word-inputs ] }
+ { [ dup word>> "input-classes" word-prop ] [ propagate-input-classes ] }
+ [ drop ]
+ } cond ;
M: node propagate-after drop ;
diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor
new file mode 100644
index 0000000000..df10626967
--- /dev/null
+++ b/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 ;
diff --git a/unfinished/stack-checker/branches/branches.factor b/unfinished/stack-checker/branches/branches.factor
index 613cf31161..711fb3f151 100644
--- a/unfinished/stack-checker/branches/branches.factor
+++ b/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 ]