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

core/bootstrap/stage1.factor

@@ -19,8 +19,13 @@ load-help? off
 [
     [
         ! Rehash hashtables, since bootstrap.image creates them
-        ! using the host image's hashing algorithms
+        ! using the host image's hashing algorithms. We don't
-        [ hashtable? ] instances [ rehash ] each
+        ! use each-object here since the catch stack isn't yet
+        ! set up.
+        begin-scan
+        [ hashtable? ] pusher [ (each-object) ] dip
+        end-scan
+        [ rehash ] each
         boot
     ] %
 

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/cpu/ppc/bootstrap.factor

@@ -14,13 +14,13 @@ big-endian on
 : ds-reg 14 ;
 : rs-reg 15 ;
 
-: factor-area-size 4 bootstrap-cells ;
+: factor-area-size ( -- n ) 4 bootstrap-cells ;
 
-: stack-frame
+: stack-frame ( -- n )
     factor-area-size c-area-size + 4 bootstrap-cells align ;
 
-: next-save stack-frame bootstrap-cell - ;
+: next-save ( -- n ) stack-frame bootstrap-cell - ;
-: xt-save stack-frame 2 bootstrap-cells - ;
+: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
 
 [
     0 6 LOAD32

core/cpu/ppc/linux/bootstrap.factor

@@ -3,8 +3,8 @@
 USING: parser layouts system kernel ;
 IN: bootstrap.ppc
 
-: c-area-size 10 bootstrap-cells ;
+: c-area-size ( -- n ) 10 bootstrap-cells ;
-: lr-save bootstrap-cell ;
+: lr-save ( -- n ) bootstrap-cell ;
 
 << "resource:core/cpu/ppc/bootstrap.factor" parse-file parsed >>
 call

core/cpu/ppc/macosx/bootstrap.factor

@@ -3,8 +3,8 @@
 USING: parser layouts system kernel ;
 IN: bootstrap.ppc
 
-: c-area-size 14 bootstrap-cells ;
+: c-area-size ( -- n ) 14 bootstrap-cells ;
-: lr-save 2 bootstrap-cells ;
+: lr-save ( -- n ) 2 bootstrap-cells ;
 
 << "resource:core/cpu/ppc/bootstrap.factor" parse-file parsed >>
 call

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

@@ -23,3 +23,6 @@ TUPLE: testing x y z ;
         ] when*
     ] each
 ] unit-test
+
+! Erg's bug
+2 [ [ [ 3 throw ] instances ] must-fail ] times

core/memory/memory.factor

@@ -1,17 +1,15 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations sequences arrays system ;
 IN: memory
-USING: arrays kernel sequences vectors system hashtables
-kernel.private sbufs growable assocs namespaces quotations
-math strings combinators ;
 
 : (each-object) ( quot: ( obj -- ) -- )
     [ next-object dup ] swap [ drop ] while ; inline
 
 : each-object ( quot -- )
-    begin-scan (each-object) end-scan ; inline
+    begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
 
 : instances ( quot -- seq )
-    pusher >r each-object r> >array ; inline
+    pusher [ each-object ] dip >array ; inline
 
 : save ( -- ) image save-image ;

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

@@ -72,13 +72,13 @@ DEFER: automata-window
       "5 - Random Rule" [ random-rule     ] view-button add-gadget
       "n - New"         [ automata-window ] view-button add-gadget
 
-    @top grid-add*
+    @top grid-add
 
     C[ display ] <slate>
       { 400 400 } >>pdim
     dup >slate
 
-    @center grid-add*
+    @center grid-add
 
   <handler>
 

extra/boids/ui/ui.factor

@@ -100,72 +100,68 @@ VARS: population-label cohesion-label alignment-label separation-label ;
 : boids-window* ( -- )
   init-variables init-world-size init-boids loop on
 
-  C[ display ] <slate> >slate
-    t                      slate> set-gadget-clipped?
-    { 600 400 }            slate> set-slate-pdim
-    C[ [ run ] in-thread ] slate> set-slate-graft
-    C[ loop off ]          slate> set-slate-ungraft
-
   "" <label> reverse-video-theme >population-label update-population-label
-
   "" <label> reverse-video-theme >cohesion-label   update-cohesion-label
   "" <label> reverse-video-theme >alignment-label  update-alignment-label
   "" <label> reverse-video-theme >separation-label update-separation-label
 
   <frame>
 
-  <shelf>
+    <shelf>
 
-  {
+       1 >>fill
-    [ "ESC - Pause" [ drop toggle-loop ] button* ]
 
-    [ "1 - Randomize" [ drop randomize ] button* ]
+      "ESC - Pause" [ drop toggle-loop ] button* add-gadget
     
-    [ <pile> 1 over set-pack-fill
+      "1 - Randomize" [ drop randomize ] button* add-gadget
-      population-label> add-gadget
-      "3 - Add 10" [ drop add-10-boids ] button* add-gadget
-      "2 - Sub 10" [ drop sub-10-boids ] button* add-gadget ]
     
-    [ <pile> 1 over set-pack-fill
+      <pile> 1 over set-pack-fill
-      cohesion-label> add-gadget
+        population-label> add-gadget
-      "q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget
+        "3 - Add 10" [ drop add-10-boids ] button* add-gadget
-      "a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget ]
+        "2 - Sub 10" [ drop sub-10-boids ] button* add-gadget
+      add-gadget
     
-    [ <pile> 1 over set-pack-fill
+      <pile> 1 over set-pack-fill
-      alignment-label> add-gadget
+        cohesion-label> add-gadget
-      "w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
+        "q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget
-      "s - -0.1" [ drop dec-alignment-weight ] button* add-gadget ]
+        "a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget
+      add-gadget
 
-    [ <pile> 1 over set-pack-fill
+      <pile> 1 over set-pack-fill
-      separation-label> add-gadget
+        alignment-label> add-gadget
-      "e - +0.1" [ drop inc-separation-weight ] button* add-gadget
+        "w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
-      "d - -0.1" [ drop dec-separation-weight ] button* add-gadget ]
+        "s - -0.1" [ drop dec-alignment-weight ] button* add-gadget
+      add-gadget
 
-  } [ call ] map [ add-gadget ] each
+      <pile> 1 over set-pack-fill
-    1 over set-pack-fill
+        separation-label> add-gadget
-    @top grid-add*
+        "e - +0.1" [ drop inc-separation-weight ] button* add-gadget
+        "d - -0.1" [ drop dec-separation-weight ] button* add-gadget
+      add-gadget
 
-  slate> @center grid-add*
+    @top grid-add
+
+    C[ display ] <slate>
+      dup                    >slate
+      t                      >>clipped?
+      { 600 400 }            >>pdim
+      C[ [ run ] in-thread ] >>graft
+      C[ loop off ]          >>ungraft
+    @center grid-add
 
   <handler> 
-
+    H{ } clone
-  H{ } clone
+      T{ key-down f f "1"   } C[ drop randomize             ] is
-    T{ key-down f f "1" } C[ drop randomize    ] is
+      T{ key-down f f "2"   } C[ drop sub-10-boids          ] is
-    T{ key-down f f "2" } C[ drop sub-10-boids ] is
+      T{ key-down f f "3"   } C[ drop add-10-boids          ] is
-    T{ key-down f f "3" } C[ drop add-10-boids ] is
+      T{ key-down f f "q"   } C[ drop inc-cohesion-weight   ] is
-
+      T{ key-down f f "a"   } C[ drop dec-cohesion-weight   ] is
-    T{ key-down f f "q" } C[ drop inc-cohesion-weight ] is
+      T{ key-down f f "w"   } C[ drop inc-alignment-weight  ] is
-    T{ key-down f f "a" } C[ drop dec-cohesion-weight ] is
+      T{ key-down f f "s"   } C[ drop dec-alignment-weight  ] is
-
+      T{ key-down f f "e"   } C[ drop inc-separation-weight ] is
-    T{ key-down f f "w" } C[ drop inc-alignment-weight ] is
+      T{ key-down f f "d"   } C[ drop dec-separation-weight ] is
-    T{ key-down f f "s" } C[ drop dec-alignment-weight ] is
+      T{ key-down f f "ESC" } C[ drop toggle-loop           ] is
-
+    >>table
-    T{ key-down f f "e" } C[ drop inc-separation-weight ] is
-    T{ key-down f f "d" } C[ drop dec-separation-weight ] is
-
-    T{ key-down f f "ESC" } C[ drop toggle-loop ] is
-
-  >>table
 
   "Boids" open-window ;
 

extra/color-picker/color-picker.factor

@@ -37,11 +37,11 @@ M: color-preview model-changed
   <frame>
     <color-sliders>
       swap dup
-      [                               @top    grid-add* ]
+      [                               @top    grid-add ]
-      [ <color-model> <color-preview> @center grid-add* ]
+      [ <color-model> <color-preview> @center grid-add ]
       [
         [ [ truncate number>string ] map " " join ] <filter> <label-control>
-        @bottom grid-add*
+        @bottom grid-add
       ]
       tri* ;
 

extra/csv/csv-docs.factor

@@ -2,20 +2,27 @@ USING: help.syntax help.markup kernel prettyprint sequences ;
 IN: csv
 
 HELP: csv
-{ $values { "stream" "a stream" }
+{ $values { "stream" "an input stream" }
           { "rows" "an array of arrays of fields" } } 
 { $description "parses a csv stream into an array of row arrays"
 } ;
 
 HELP: csv-row
-{ $values { "stream" "a stream" }
+{ $values { "stream" "an input stream" }
           { "row" "an array of fields" } } 
 { $description "parses a row from a csv stream"
 } ;
 
+HELP: write-csv
+{ $values { "rows" "an sequence of sequences of strings" }
+          { "stream" "an output stream" } } 
+{ $description "writes csv to the output stream, escaping where necessary"
+} ;
+
 
 HELP: with-delimiter
 { $values { "char" "field delimiter (e.g. CHAR: \t)" }
           { "quot" "a quotation" } }
 { $description "Sets the field delimiter for csv or csv-row words "
 } ;
+

extra/csv/csv-tests.factor

@@ -1,5 +1,5 @@
-USING: io.streams.string csv tools.test shuffle ;
 IN: csv.tests
+USING: io.streams.string csv tools.test shuffle kernel strings ;
 
 ! I like to name my unit tests
 : named-unit-test ( name output input -- ) 
@@ -68,3 +68,11 @@ IN: csv.tests
 [ { { "foo" "bar" }
     { "1"   "2" } } ]
 [ "foo,\"bar\"\n1,2" <string-reader> csv ] named-unit-test
+
+"can write csv too!"
+[ "foo1,bar1\nfoo2,bar2\n" ]
+[ { { "foo1" "bar1" } { "foo2" "bar2" } } <string-writer> tuck write-csv >string ] named-unit-test
+
+"escapes quotes commas and newlines when writing"
+[ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ]
+[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } <string-writer> tuck write-csv >string ] named-unit-test ! "

extra/csv/csv.factor

@@ -69,3 +69,24 @@ VAR: delimiter
 
 : with-delimiter ( char quot -- )
   delimiter swap with-variable ; inline
+
+
+    
+: needs-escaping? ( cell -- ? )
+  [ "\n\"" delimiter> suffix member? ] contains? ; inline ! "
+
+: escape-quotes ( cell -- cell' )
+  [ [ dup , CHAR: " = [ CHAR: " , ] when ] each ] "" make ; inline
+
+: enclose-in-quotes ( cell -- cell' )
+  CHAR: " [ prefix ] [ suffix ] bi ; inline ! "
+    
+: escape-if-required ( cell -- cell' )
+  dup needs-escaping? [ escape-quotes enclose-in-quotes ] when ; inline
+    
+: write-row ( row -- )
+  [ delimiter> write1 ] [ escape-if-required write ] interleave nl ; inline
+    
+: write-csv ( rows outstream -- )
+  init-vars
+  [ [ write-row ] each ] with-output-stream ;

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

@@ -155,12 +155,12 @@ irc-editor "general" f {
 : <irc-tab> ( listener client -- irc-tab )
     irc-tab new-frame
     swap client>> >>client swap >>listener
-    <irc-pane> [ <scroller> @center grid-add* ] keep
+    <irc-pane> [ <scroller> @center grid-add ] keep
-    <irc-editor> <scroller> @bottom grid-add* ;
+    <irc-editor> <scroller> @bottom grid-add ;
 
 : <irc-channel-tab> ( listener client -- irc-tab )
     <irc-tab>
-    <irc-list> [ <scroller> @right grid-add* ] dip >>listmodel
+    <irc-list> [ <scroller> @right grid-add ] dip >>listmodel
     [ update-participants ] keep ;
 
 : <irc-server-tab> ( listener client -- irc-tab )

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

@@ -7,7 +7,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
 { $subsection frame }
 "Creating empty frames:"
 { $subsection <frame> }
-"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add* } ":"
+"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } ":"
 { $subsection @center }
 { $subsection @left }
 { $subsection @right }
@@ -20,7 +20,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
 
 : $ui-frame-constant ( element -- )
     drop
-    { $description "Symbolic constant for a common input to " { $link grid-add* } "." } print-element ;
+    { $description "Symbolic constant for a common input to " { $link grid-add } "." } print-element ;
 
 HELP: @center $ui-frame-constant ;
 HELP: @left $ui-frame-constant ;
@@ -35,7 +35,7 @@ HELP: @bottom-right $ui-frame-constant ;
 HELP: frame
 { $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
 $nl
-"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add* } " and " { $link grid-remove } "." } ;
+"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
 
 HELP: <frame>
 { $values { "frame" frame } }

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

@@ -7,7 +7,7 @@ ARTICLE: "ui-grid-layout" "Grid layouts"
 "Creating grids from a fixed set of gadgets:"
 { $subsection <grid> }
 "Managing chidren:"
-{ $subsection grid-add* }
+{ $subsection grid-add }
 { $subsection grid-remove }
 { $subsection grid-child } ;
 
@@ -18,7 +18,7 @@ $nl
 $nl
 "The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
 $nl
-"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add* } " and " { $link grid-remove } "."
+"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
 $nl
 "The " { $link add-gadget } ", " { $link unparent } " and " { $link clear-gadget } " words should not be used to manage child gadgets of grids." } ;
 
@@ -31,7 +31,7 @@ HELP: grid-child
 { $description "Outputs the child gadget at the " { $snippet "i" } "," { $snippet "j" } "th position of the grid." }
 { $errors "Throws an error if the indices are out of bounds." } ;
 
-HELP: grid-add*
+HELP: grid-add
 { $values { "gadget" gadget } { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
 { $description "Adds a child gadget at the specified location." }
 { $side-effects "grid" } ;

extra/ui/gadgets/grids/grids.factor

@@ -20,12 +20,12 @@ grid
 
 : grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
 
-: grid-add* ( grid child i j -- grid )
+: grid-add ( grid child i j -- grid )
   >r >r dupd swap r> r>
   >r >r 2dup swap add-gadget drop r> r>
   3dup grid-child unparent rot grid>> nth set-nth ;
 
-: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add* ;
+: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add ;
 
 : pref-dim-grid ( grid -- dims )
     grid>> [ [ pref-dim ] map ] map ;

extra/ui/gadgets/labelled/labelled.factor

@@ -39,8 +39,8 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
 
 : <title-bar> ( title quot -- gadget )
   <frame>
-    swap dup [ <close-box> @left grid-add* ] [ drop ] if
+    swap dup [ <close-box> @left grid-add ] [ drop ] if
-    swap <title-label> @center grid-add* ;
+    swap <title-label> @center grid-add ;
 
 TUPLE: closable-gadget < frame content ;
 
@@ -49,8 +49,8 @@ TUPLE: closable-gadget < frame content ;
 
 : <closable-gadget> ( gadget title quot -- gadget )
   closable-gadget new-frame
-    -rot <title-bar> @top grid-add*
+    -rot <title-bar> @top grid-add
     swap >>content
-    dup content>> @center grid-add* ;
+    dup content>> @center grid-add ;
     
 M: closable-gadget focusable-child* closable-gadget-content ;

extra/ui/gadgets/scrollers/scrollers.factor

@@ -38,11 +38,11 @@ scroller H{
     <scroller-model> >>model
     faint-boundary
 
-    dup model>> dependencies>> first  <x-slider> >>x dup x>> @bottom grid-add*
+    dup model>> dependencies>> first  <x-slider> >>x dup x>> @bottom grid-add
-    dup model>> dependencies>> second <y-slider> >>y dup y>> @right  grid-add*
+    dup model>> dependencies>> second <y-slider> >>y dup y>> @right  grid-add
 
     swap over model>> <viewport> >>viewport
-    dup viewport>> @center grid-add* ;
+    dup viewport>> @center grid-add ;
     
 : <scroller> ( gadget -- scroller ) scroller new-scroller ;
 

extra/ui/gadgets/sliders/sliders.factor

@@ -130,7 +130,7 @@ M: elevator layout*
   tuck <elevator> >>elevator
   swap <thumb>    >>thumb
   dup elevator>> over thumb>> add-gadget
-  @center grid-add* ;
+  @center grid-add ;
 
 : <left-button>  ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
 : <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
@@ -145,15 +145,15 @@ M: elevator layout*
 
 : <x-slider> ( range -- slider )
   { 1 0 } <slider>
-    <left-button> @left grid-add*
+    <left-button> @left grid-add
     { 0 1 } elevator,
-    <right-button> @right grid-add* ;
+    <right-button> @right grid-add ;
 
 : <y-slider> ( range -- slider )
   { 0 1 } <slider>
-    <up-button> @top grid-add*
+    <up-button> @top grid-add
     { 1 0 } elevator,
-    <down-button> @bottom grid-add* ;
+    <down-button> @bottom grid-add ;
 
 M: slider pref-dim*
     dup call-next-method

extra/ui/gadgets/tabs/tabs.factor

@@ -15,8 +15,8 @@ DEFER: (del-page)
 :: add-toggle ( model n name toggler -- )
   <frame>
     n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>
-      @right grid-add*
+      @right grid-add
-    n model name <toggle-button> @center grid-add*
+    n model name <toggle-button> @center grid-add
   toggler swap add-gadget drop ;
 
 : redo-toggler ( tabbed -- )
@@ -52,10 +52,10 @@ DEFER: (del-page)
   tabbed new-frame
     0 <model> >>model
     <pile> 1 >>fill >>toggler
-    dup toggler>> @left grid-add*
+    dup toggler>> @left grid-add
     swap
       [ keys >vector >>names ]
-      [ values over model>> <book> >>content dup content>> @center grid-add* ]
+      [ values over model>> <book> >>content dup content>> @center grid-add ]
     bi
     dup redo-toggler ;
     

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,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 }
+class
-{ interval initial: empty-interval }
+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 ;

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

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

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
+        { [ 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 ]

vm/errors.c

@@ -1,5 +1,12 @@
 #include "master.h"
 
+void out_of_memory(void)
+{
+	fprintf(stderr,"Out of memory\n\n");
+	dump_generations();
+	exit(1);
+}
+
 void fatal_error(char* msg, CELL tagged)
 {
 	fprintf(stderr,"fatal_error: %s %lx\n",msg,tagged);

vm/errors.h

@@ -19,6 +19,7 @@ typedef enum
 	ERROR_MEMORY,
 } F_ERRORTYPE;
 
+void out_of_memory(void);
 void fatal_error(char* msg, CELL tagged);
 void critical_error(char* msg, CELL tagged);
 DECLARE_PRIMITIVE(die);

vm/os-unix.c

@@ -174,7 +174,7 @@ F_SEGMENT *alloc_segment(CELL size)
 		MAP_ANON | MAP_PRIVATE,-1,0);
 
 	if(array == (char*)-1)
-		fatal_error("Out of memory in alloc_segment",0);
+		out_of_memory();
 
 	if(mprotect(array,pagesize,PROT_NONE) == -1)
 		fatal_error("Cannot protect low guard page",(CELL)array);

vm/os-windows.c

@@ -171,7 +171,7 @@ F_SEGMENT *alloc_segment(CELL size)
 
 	if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size,
 		MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
-		fatal_error("Out of memory in alloc_segment",0);
+		out_of_memory();
 
 	if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore))
 		fatal_error("Cannot allocate low guard page", (CELL)mem);