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

basis/bootstrap/image/image.factor

@@ -358,7 +358,7 @@ M: byte-array '
 
 ! Tuples
 : (emit-tuple) ( tuple -- pointer )
-    [ tuple>array rest-slice ]
+    [ tuple-slots ]
     [ class transfer-word tuple-layout ] bi prefix [ ' ] map
     tuple type-number dup [ emit-seq ] emit-object ;
 
@@ -384,9 +384,9 @@ M: tuple-layout '
     ] cache-object ;
 
 M: tombstone '
-    delegate
+    state>> "((tombstone))" "((empty))" ?
-    "((tombstone))" "((empty))" ? "hashtables.private" lookup
+    "hashtables.private" lookup def>> first
-    def>> first [ emit-tuple ] cache-object ;
+    [ emit-tuple ] cache-object ;
 
 ! Arrays
 M: array '

basis/compiler/intrinsics/intrinsics.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel classes.tuple classes.tuple.private math arrays 
 byte-arrays words stack-checker.known-words ;
-IN: compiler.tree.intrinsics
+IN: compiler.intrinsics
 
 : (tuple) ( layout -- tuple )
     "BUG: missing (tuple) intrinsic" throw ;

basis/compiler/tree/cleanup/cleanup.factor

@@ -4,8 +4,9 @@ USING: kernel accessors sequences sequences.deep combinators fry
 classes.algebra namespaces assocs words math math.private
 math.partial-dispatch math.intervals classes classes.tuple
 classes.tuple.private layouts definitions stack-checker.state
-stack-checker.branches compiler.tree
+stack-checker.branches
-compiler.tree.intrinsics
+compiler.intrinsics
+compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.tree.propagation.branches ;

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

@@ -6,7 +6,7 @@ compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.combinators compiler.tree sequences math math.private
 kernel tools.test accessors slots.private quotations.private
 prettyprint classes.tuple.private classes classes.tuple
-compiler.tree.intrinsics namespaces compiler.tree.propagation.info
+compiler.intrinsics namespaces compiler.tree.propagation.info
 stack-checker.errors kernel.private ;
 
 \ escape-analysis must-infer

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

@@ -4,8 +4,8 @@ USING: kernel accessors sequences classes.tuple
 classes.tuple.private arrays math math.private slots.private
 combinators deques search-deques namespaces fry classes
 classes.algebra stack-checker.state
+compiler.intrinsics
 compiler.tree
-compiler.tree.intrinsics
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;
@@ -23,9 +23,8 @@ DEFER: record-literal-allocation
     [ <slot-value> [ swap record-literal-allocation ] keep ] map ;
 
 : object-slots ( object -- slots/f )
-    #! Delegation
     {
-        { [ dup class immutable-tuple-class? ] [ tuple-slots rest-slice ] }
+        { [ dup class immutable-tuple-class? ] [ tuple-slots ] }
         { [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] }
         [ drop f ]
     } cond ;
@@ -37,7 +36,6 @@ DEFER: record-literal-allocation
     if* ;
 
 M: #push escape-analysis*
-    #! Delegation.
     [ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
 
 : record-unknown-allocation ( #call -- )
@@ -59,7 +57,7 @@ M: #push escape-analysis*
     [ second node-value-info literal>> ] 2bi
     dup fixnum? [
         {
-            { [ over tuple class<= ] [ 3 - ] }
+            { [ over tuple class<= ] [ 2 - ] }
             { [ over complex class<= ] [ 1 - ] }
             [ drop f ]
         } cond nip

basis/compiler/tree/finalization/finalization.factor

@@ -1,17 +1,32 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences words namespaces
+USING: kernel arrays accessors sequences sequences.private words
-classes.builtin
+fry namespaces math math.order memoize classes.builtin
+classes.tuple.private slots.private combinators layouts
+byte-arrays alien.accessors
+compiler.intrinsics
 compiler.tree
 compiler.tree.builder
 compiler.tree.normalization
 compiler.tree.propagation
+compiler.tree.propagation.info
 compiler.tree.cleanup
 compiler.tree.def-use
 compiler.tree.dead-code
 compiler.tree.combinators ;
 IN: compiler.tree.finalization
 
+! This pass runs after propagation, so that it can expand
+! built-in type predicates and memory allocation; these cannot
+! be expanded before propagation since we need to see 'fixnum?'
+! instead of 'tag 0 eq?' and so on, for semantic reasoning.
+! We also delete empty stack shuffles and copies to facilitate
+! tail call optimization in the code generator. After this pass
+! runs, stack flow information is no longer accurate, since we
+! punt in 'splice-quot' and don't update everything that we
+! should; this simplifies the code, improves performance, and we
+! don't need the stack flow information after this pass anyway.
+
 GENERIC: finalize* ( node -- nodes )
 
 M: #copy finalize* drop f ;
@@ -21,9 +36,6 @@ M: #shuffle finalize*
     [ in>> ] [ out>> ] bi sequence=
     [ drop f ] when ;
 
-: builtin-predicate? ( word -- ? )
-    "predicating" word-prop builtin-class? ;
-
 : splice-quot ( quot -- nodes )
     [
         build-tree
@@ -35,10 +47,80 @@ M: #shuffle finalize*
         but-last
     ] with-scope ;
 
+: builtin-predicate? ( #call -- ? )
+    word>> "predicating" word-prop builtin-class? ;
+
+MEMO: builtin-predicate-expansion ( word -- nodes )
+    def>> splice-quot ;
+
+: expand-builtin-predicate ( #call -- nodes )
+    word>> builtin-predicate-expansion ;
+
+: first-literal ( #call -- obj ) node-input-infos first literal>> ;
+
+: last-literal ( #call -- obj ) node-input-infos peek literal>> ;
+
+: expand-tuple-boa? ( #call -- ? )
+    dup word>> \ <tuple-boa> eq? [
+        last-literal tuple-layout?
+    ] [ drop f ] if ;
+
+MEMO: (tuple-boa-expansion) ( n -- quot )
+    [
+        [ 2 + ] map <reversed>
+        [ '[ [ , set-slot ] keep ] % ] each
+    ] [ ] make ;
+
+: tuple-boa-expansion ( layout -- quot )
+    #! No memoization here since otherwise we'd hang on to
+    #! tuple layout objects.
+    size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
+
+: expand-tuple-boa ( #call -- node )
+    last-literal tuple-boa-expansion ;
+
+MEMO: <array>-expansion ( n -- quot )
+    [
+        [ swap (array) ] %
+        [ \ 2dup , , [ swap set-array-nth ] % ] each
+        \ nip ,
+    ] [ ] make splice-quot ;
+
+: expand-<array>? ( #call -- ? )
+    dup word>> \ <array> eq? [
+        first-literal dup integer?
+        [ 0 32 between? ] [ drop f ] if
+    ] [ drop f ] if ;
+
+: expand-<array> ( #call -- node )
+    first-literal <array>-expansion ;
+
+: bytes>cells ( m -- n ) cell align cell /i ;
+
+MEMO: <byte-array>-expansion ( n -- quot )
+    [
+        [ (byte-array) ] %
+        bytes>cells [ cell * ] map
+        [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
+    ] [ ] make splice-quot ;
+
+: expand-<byte-array>? ( #call -- ? )
+    dup word>> \ <byte-array> eq? [
+        first-literal dup integer?
+        [ 0 128 between? ] [ drop f ] if
+    ] [ drop f ] if ;
+
+: expand-<byte-array> ( #call -- nodes )
+    first-literal <byte-array>-expansion ;
+
 M: #call finalize*
-    dup word>> builtin-predicate? [
+    {
-        word>> def>> splice-quot
+        { [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
-    ] when ;
+        { [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
+        { [ dup expand-<array>? ] [ expand-<array> ] }
+        { [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
+        [ ]
+    } cond ;
 
 M: node finalize* ;
 

basis/compiler/tree/propagation/info/info.factor

@@ -60,15 +60,13 @@ slots ;
 : <value-info> ( -- info ) \ value-info new ;
 
 : read-only-slots ( values class -- slots )
-    #! Delegation.
+    all-slots
-    all-slots rest-slice
     [ read-only>> [ drop f ] unless ] 2map
-    { f f } prepend ;
+    f prefix ;
 
 DEFER: <literal-info>
 
 : init-literal-info ( info -- info )
-    #! Delegation.
     dup literal>> class >>class
     dup literal>> dup real? [ [a,a] >>interval ] [
         [ [-inf,inf] >>interval ] dip
@@ -79,10 +77,8 @@ DEFER: <literal-info>
                 2array >>slots
             ] }
             { [ dup tuple? ] [
-                [
+                [ tuple-slots [ <literal-info> ] map ] [ class ] bi
-                    tuple-slots rest-slice
+                read-only-slots >>slots
-                    [ <literal-info> ] map
-                ] [ class ] bi read-only-slots >>slots
             ] }
             [ drop ]
         } cond

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

@@ -7,6 +7,7 @@ classes.algebra combinators generic.math splitting fry locals
 classes.tuple alien.accessors classes.tuple.private slots.private
 definitions
 stack-checker.state
+compiler.intrinsics
 compiler.tree.comparisons
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
@@ -253,7 +254,7 @@ generic-comparison-ops [
     [ 2nip ] curry "outputs" set-word-prop
 ] each
 
-{ <tuple> <tuple-boa> } [
+{ <tuple> <tuple-boa> (tuple) } [
     [
         literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
         [ clear ] dip

basis/compiler/tree/propagation/slots/slots.factor

@@ -32,19 +32,18 @@ UNION: fixed-length-sequence array byte-array string ;
     { <tuple-boa> <complex> } memq? ;
 
 : fold-<tuple-boa> ( values class -- info )
-    [ , f , [ literal>> ] map % ] { } make >tuple
+    [ [ literal>> ] map ] dip prefix >tuple
     <literal-info> ;
 
 : (propagate-tuple-constructor) ( values class -- info )
     [ [ value-info ] map ] dip [ read-only-slots ] keep
-    over 2 tail-slice [ dup [ literal?>> ] when ] all? [
+    over rest-slice [ dup [ literal?>> ] when ] all? [
-        [ 2 tail-slice ] dip fold-<tuple-boa>
+        [ rest-slice ] dip fold-<tuple-boa>
     ] [
         <tuple-info>
     ] if ;
 
 : propagate-<tuple-boa> ( #call -- info )
-    #! Delegation
     in-d>> unclip-last
     value-info literal>> class>> (propagate-tuple-constructor) ;
 
@@ -69,7 +68,6 @@ UNION: fixed-length-sequence array byte-array string ;
     [ 1 = ] [ length>> ] bi* and ;
 
 : value-info-slot ( slot info -- info' )
-    #! Delegation.
     {
         { [ over 0 = ] [ 2drop fixnum <class-info> ] }
         { [ 2dup length-accessor? ] [ nip length>> ] }

basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

@@ -30,7 +30,7 @@ TUPLE: empty-tuple ;
     [ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
     [ 2 cons boa { [ ] [ ] } dispatch ]
     [ dup [ drop f ] [ "A" throw ] if ]
-    [ [ ] [ ] curry curry dup 3 slot swap 4 slot dup 3 slot swap 4 slot drop ]
+    [ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ]
     [ [ ] [ ] curry curry call ]
     [ <complex> <complex> dup 1 slot drop 2 slot drop ]
     [ 1 cons boa over [ "A" throw ] when car>> ]

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

@@ -4,8 +4,8 @@ USING: namespaces assocs accessors kernel combinators
 classes.algebra sequences sequences.deep slots.private
 classes.tuple.private math math.private arrays
 stack-checker.branches
+compiler.intrinsics
 compiler.tree
-compiler.tree.intrinsics
 compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.simple

basis/cpu/ppc/intrinsics/intrinsics.factor

@@ -4,11 +4,15 @@ USING: accessors alien alien.accessors alien.c-types arrays
 cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
 cpu.architecture kernel kernel.private math math.private
 namespaces sequences words generic quotations byte-arrays
-hashtables hashtables.private compiler.generator
+hashtables hashtables.private
-compiler.generator.registers compiler.generator.fixup
 sequences.private sbufs vectors system layouts
-math.floats.private classes slots.private combinators
+math.floats.private classes slots.private
-compiler.constants ;
+combinators
+compiler.constants
+compiler.intrinsics
+compiler.generator
+compiler.generator.fixup
+compiler.generator.registers ;
 IN: cpu.ppc.intrinsics
 
 : %slot-literal-known-tag ( -- out value offset )
@@ -437,44 +441,44 @@ IN: cpu.ppc.intrinsics
     { +clobber+ { "n" } }
 } define-intrinsic
 
-! \ (tuple) [
+\ (tuple) [
-!     tuple "layout" get size>> 2 + cells %allot
+    tuple "layout" get size>> 2 + cells %allot
-!     ! Store layout
+    ! Store layout
-!     "layout" get 12 load-indirect
+    "layout" get 12 load-indirect
-!     12 11 cell STW
+    12 11 cell STW
-!     ! Store tagged ptr in reg
+    ! Store tagged ptr in reg
-!     "tuple" get tuple %store-tagged
+    "tuple" get tuple %store-tagged
-! ] H{
+] H{
-!     { +input+ { { [ ] "layout" } } }
+    { +input+ { { [ ] "layout" } } }
-!     { +scratch+ { { f "tuple" } } }
+    { +scratch+ { { f "tuple" } } }
-!     { +output+ { "tuple" } }
+    { +output+ { "tuple" } }
-! } define-intrinsic
+} define-intrinsic
-! 
+
-! \ (array) [
+\ (array) [
-!     array "n" get 2 + cells %allot
+    array "n" get 2 + cells %allot
-!     ! Store length
+    ! Store length
-!     "n" operand 12 LI
+    "n" operand 12 LI
-!     12 11 cell STW
+    12 11 cell STW
-!     ! Store tagged ptr in reg
+    ! Store tagged ptr in reg
-!     "array" get object %store-tagged
+    "array" get object %store-tagged
-! ] H{
+] H{
-!     { +input+ { { [ ] "n" } } }
+    { +input+ { { [ ] "n" } } }
-!     { +scratch+ { { f "array" } } }
+    { +scratch+ { { f "array" } } }
-!     { +output+ { "array" } }
+    { +output+ { "array" } }
-! } define-intrinsic
+} define-intrinsic
-! 
+
-! \ (byte-array) [
+\ (byte-array) [
-!     byte-array "n" get 2 cells + %allot
+    byte-array "n" get 2 cells + %allot
-!     ! Store length
+    ! Store length
-!     "n" operand 12 LI
+    "n" operand 12 LI
-!     12 11 cell STW
+    12 11 cell STW
-!     ! Store tagged ptr in reg
+    ! Store tagged ptr in reg
-!     "array" get object %store-tagged
+    "array" get object %store-tagged
-! ] H{
+] H{
-!     { +input+ { { [ ] "n" } } }
+    { +input+ { { [ ] "n" } } }
-!     { +scratch+ { { f "array" } } }
+    { +scratch+ { { f "array" } } }
-!     { +output+ { "array" } }
+    { +output+ { "array" } }
-! } define-intrinsic
+} define-intrinsic
 
 \ <ratio> [
     ratio 3 cells %allot
@@ -523,7 +527,7 @@ IN: cpu.ppc.intrinsics
             { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
-        { +scratch+ { { f "value" } } }
+        { +scratch+ { { f "value" } { f "scratch" } } }
         { +output+ { "value" } }
         { +clobber+ { "offset" } }
     } ;
@@ -580,7 +584,7 @@ define-alien-integer-intrinsics
         { unboxed-c-ptr "alien" c-ptr }
         { f "offset" fixnum }
     } }
-    { +scratch+ { { unboxed-alien "value" } } }
+    { +scratch+ { { unboxed-alien "value" } { f "scratch" } } }
     { +output+ { "value" } }
     { +clobber+ { "offset" } }
 } define-intrinsic
@@ -593,6 +597,7 @@ define-alien-integer-intrinsics
         { unboxed-c-ptr "alien" c-ptr }
         { f "offset" fixnum }
     } }
+    { +scratch+ { { f "scratch" } } }
     { +clobber+ { "offset" } }
 } define-intrinsic
 
@@ -602,7 +607,7 @@ define-alien-integer-intrinsics
             { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
-        { +scratch+ { { float "value" } } }
+        { +scratch+ { { float "value" } { f "scratch" } } }
         { +output+ { "value" } }
         { +clobber+ { "offset" } }
     } ;
@@ -614,6 +619,7 @@ define-alien-integer-intrinsics
             { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
+        { +scratch+ { { f "scratch" } } }
         { +clobber+ { "offset" } }
     } ;
 

basis/cpu/x86/intrinsics/intrinsics.factor

@@ -4,10 +4,14 @@ USING: accessors alien alien.accessors arrays cpu.x86.assembler
 cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
 kernel.private math math.private namespaces quotations sequences
 words generic byte-arrays hashtables hashtables.private
-compiler.generator compiler.generator.registers
+sequences.private sbufs sbufs.private
-compiler.generator.fixup sequences.private sbufs sbufs.private
 vectors vectors.private layouts system strings.private
-slots.private compiler.constants ;
+slots.private 
+compiler.constants
+compiler.intrinsics
+compiler.generator
+compiler.generator.fixup
+compiler.generator.registers ;
 IN: cpu.x86.intrinsics
 
 ! Type checks
@@ -289,45 +293,45 @@ IN: cpu.x86.intrinsics
     { +clobber+ { "n" } }
 } define-intrinsic
 
-! \ (tuple) [
+\ (tuple) [
-!     tuple "layout" get size>> 2 + cells [
+    tuple "layout" get size>> 2 + cells [
-!         ! Store layout
+        ! Store layout
-!         "layout" get "scratch" get load-literal
+        "layout" get "scratch" get load-literal
-!         1 object@ "scratch" operand MOV
+        1 object@ "scratch" operand MOV
-!         ! Store tagged ptr in reg
+        ! Store tagged ptr in reg
-!         "tuple" get tuple %store-tagged
+        "tuple" get tuple %store-tagged
-!     ] %allot
+    ] %allot
-! ] H{
+] H{
-!     { +input+ { { [ ] "layout" } } }
+    { +input+ { { [ ] "layout" } } }
-!     { +scratch+ { { f "tuple" } { f "scratch" } } }
+    { +scratch+ { { f "tuple" } { f "scratch" } } }
-!     { +output+ { "tuple" } }
+    { +output+ { "tuple" } }
-! } define-intrinsic
+} define-intrinsic
-! 
+
-! \ (array) [
+\ (array) [
-!     array "n" get 2 + cells [
+    array "n" get 2 + cells [
-!         ! Store length
+        ! Store length
-!         1 object@ "n" operand MOV
+        1 object@ "n" operand MOV
-!         ! Store tagged ptr in reg
+        ! Store tagged ptr in reg
-!         "array" get object %store-tagged
+        "array" get object %store-tagged
-!     ] %allot
+    ] %allot
-! ] H{
+] H{
-!     { +input+ { { [ ] "n" } } }
+    { +input+ { { [ ] "n" } } }
-!     { +scratch+ { { f "array" } } }
+    { +scratch+ { { f "array" } } }
-!     { +output+ { "array" } }
+    { +output+ { "array" } }
-! } define-intrinsic
+} define-intrinsic
-! 
+
-! \ (byte-array) [
+\ (byte-array) [
-!     byte-array "n" get 2 cells + [
+    byte-array "n" get 2 cells + [
-!         ! Store length
+        ! Store length
-!         1 object@ "n" operand MOV
+        1 object@ "n" operand MOV
-!         ! Store tagged ptr in reg
+        ! Store tagged ptr in reg
-!         "array" get object %store-tagged
+        "array" get object %store-tagged
-!     ] %allot
+    ] %allot
-! ] H{
+] H{
-!     { +input+ { { [ ] "n" } } }
+    { +input+ { { [ ] "n" } } }
-!     { +scratch+ { { f "array" } } }
+    { +scratch+ { { f "array" } } }
-!     { +output+ { "array" } }
+    { +output+ { "array" } }
-! } define-intrinsic
+} define-intrinsic
 
 \ <ratio> [
     ratio 3 cells [

basis/io/servers/connection/connection-tests.factor

@@ -13,7 +13,7 @@ concurrency.promises io.encodings.ascii io threads calendar ;
 ] unit-test
 
 [ t ] [
-    T{ inet4 "1.2.3.4" 1234 } T{ inet4 "1.2.3.5" 1235 }
+    T{ inet4 f "1.2.3.4" 1234 } T{ inet4 f "1.2.3.5" 1235 }
     [ log-connection ] 2keep
     [ remote-address get = ] [ local-address get = ] bi*
     and

basis/mirrors/mirrors-tests.factor

@@ -6,9 +6,9 @@ TUPLE: foo bar baz ;
 
 C: <foo> foo
 
-[ 3 ] [ 1 2 <foo> <mirror> assoc-size ] unit-test
+[ 2 ] [ 1 2 <foo> <mirror> assoc-size ] unit-test
 
-[ { "delegate" "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
+[ { "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
 
 [ 1 t ] [ "bar" 1 2 <foo> <mirror> at* ] unit-test
 

basis/prettyprint/backend/backend.factor

@@ -163,10 +163,12 @@ M: byte-vector >pprint-sequence ;
 M: curry >pprint-sequence ;
 M: compose >pprint-sequence ;
 M: hashtable >pprint-sequence >alist ;
-M: tuple >pprint-sequence tuple>array ;
 M: wrapper >pprint-sequence wrapped>> 1array ;
 M: callstack >pprint-sequence callstack>array ;
 
+M: tuple >pprint-sequence
+    [ class f 2array ] [ tuple-slots ] bi append ;
+
 GENERIC: pprint-narrow? ( obj -- ? )
 
 M: object pprint-narrow? drop f ;

basis/stack-checker/known-words/known-words.factor

@@ -108,7 +108,7 @@ M: object infer-call*
 
 : infer-<tuple-boa> ( -- )
     \ <tuple-boa>
-    peek-d literal value>> size>> { tuple } <effect>
+    peek-d literal value>> size>> 1+ { tuple } <effect>
     apply-word/effect ;
 
 : infer-(throw) ( -- )

basis/stack-checker/transforms/transforms.factor

@@ -105,8 +105,11 @@ IN: stack-checker.transforms
 \ new [
     dup tuple-class? [
         dup inlined-dependency depends-on
-        dup all-slots rest-slice ! delegate slot
+        [
-        [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make
+            [ all-slots [ initial>> literalize , ] each ]
+            [ literalize , ] bi
+            \ boa ,
+        ] [ ] make
     ] [ drop f ] if
 ] 1 define-transform
 

basis/tuple-arrays/tuple-arrays-tests.factor

@@ -7,14 +7,14 @@ TUPLE: foo bar ;
 C: <foo> foo
 [ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
 [ T{ foo } ] [ mat get first ] unit-test
-[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
+[ T{ foo f 2 } ] [ T{ foo f 2 } 0 mat get [ set-nth ] keep first ] unit-test
 [ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
 [ T{ foo f 3 } t ] 
 [ mat get [ bar>> 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
 
 [ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
 [ T{ foo } ] [ mat get first ] unit-test
-[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
+[ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test
 
 TUPLE: baz { bing integer } bong ;
 [ 0 ] [ 1 baz <tuple-array> first bing>> ] unit-test

basis/ui/gadgets/panes/panes-tests.factor

@@ -12,7 +12,7 @@ IN: ui.gadgets.panes.tests
 [ ] [ #children "num-children" set ] unit-test
 
 [ ] [
-    "pane" get <pane-stream> [ 10000 [ . ] each ] with-output-stream*
+    "pane" get <pane-stream> [ 100 [ . ] each ] with-output-stream*
 ] unit-test
 
 [ t ] [ #children "num-children" get = ] unit-test

basis/ui/gadgets/worlds/worlds.factor

@@ -16,7 +16,9 @@ window-loc ;
 : find-world ( gadget -- world/f ) [ world? ] find-parent ;
 
 : show-status ( string/f gadget -- )
-    find-world dup [ status>> set-model ] [ 2drop ] if ;
+    find-world dup [
+        status>> dup [ set-model ] [ 2drop ] if
+    ] [ 2drop ] if ;
 
 : hide-status ( gadget -- ) f swap show-status ;
 

core/bootstrap/primitives.factor

@@ -281,18 +281,12 @@ bi
 "tuple" "kernel" create
 [ { } define-builtin ]
 [ define-tuple-layout ]
-[
+bi
-    { "delegate" } make-slots
-    [ drop ] [ finalize-tuple-slots ] 2bi
-    [ "slots" set-word-prop ]
-    [ define-accessors ]
-    2bi
-] tri
 
 ! Create special tombstone values
 "tombstone" "hashtables.private" create
 tuple
-{ } define-tuple-class
+{ "state" } define-tuple-class
 
 "((empty))" "hashtables.private" create
 "tombstone" "hashtables.private" lookup f

core/classes/tuple/parser/parser.factor

@@ -58,3 +58,10 @@ ERROR: invalid-slot-name name ;
     } case
     dup check-duplicate-slots
     3dup check-slot-shadowing ;
+
+: literal>tuple ( seq -- tuple )
+    {
+        { [ dup length 1 = ] [ first new ] }
+        { [ dup second not ] [ [ 2 tail ] [ first ] bi slots>tuple ] }
+        [ "Not implemented" throw ]
+    } cond ;

core/classes/tuple/tuple-tests.factor

@@ -46,13 +46,13 @@ C: <point> point
 
 [ ] [ "p" get 300 ">>z" "accessors" lookup execute drop ] unit-test
 
-[ 4 ] [ "p" get tuple-size ] unit-test
+[ 3 ] [ "p" get tuple-size ] unit-test
 
 [ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
 
 [ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test
 
-[ 3 ] [ "p" get tuple-size ] unit-test
+[ 2 ] [ "p" get tuple-size ] unit-test
 
 [ "p" get x>> ] must-fail
 [ 200 ] [ "p" get y>> ] unit-test
@@ -425,7 +425,7 @@ C: <constructor-update-2> constructor-update-2
 
 { 5 1 } [ <constructor-update-2> ] must-infer-as
 
-[ { f 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
+[ { 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
 
 ! Redefinition problem
 TUPLE: redefinition-problem ;
@@ -478,7 +478,7 @@ USE: vocabs
 ] unit-test
 
 [ "USE: words T{ word }" eval ]
-[ error>> T{ no-method f word slots>tuple } = ]
+[ error>> T{ no-method f word new } = ]
 must-fail-with
 
 ! Accessors not being forgotten...
@@ -592,10 +592,10 @@ GENERIC: break-me ( obj -- )
 TUPLE: declared-types { n fixnum } { m string } ;
 
 [ T{ declared-types f 0 "hi" } ]
-[ { declared-types f 0 "hi" } >tuple ]
+[ { declared-types 0 "hi" } >tuple ]
 unit-test
 
-[ { declared-types f "hi" 0 } >tuple ]
+[ { declared-types "hi" 0 } >tuple ]
 [ T{ bad-slot-value f "hi" fixnum } = ]
 must-fail-with
 
@@ -708,4 +708,4 @@ TUPLE: bogus-hashcode-2 x ;
 
 M: bogus-hashcode-1 hashcode* 2drop 0 >bignum ;
 
-[ ] [ T{ bogus-hashcode-2 T{ bogus-hashcode-1 } } hashcode drop ] unit-test
+[ ] [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test

core/classes/tuple/tuple.factor

@@ -21,8 +21,7 @@ ERROR: not-a-tuple object ;
     superclasses [ "slots" word-prop ] map concat ;
 
 PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
-    #! Delegation
+    all-slots [ read-only>> ] all? ;
-    all-slots rest-slice [ read-only>> ] all? ;
 
 <PRIVATE
 
@@ -126,14 +125,14 @@ ERROR: bad-superclass class ;
     } cond ;
 
 : boa-check-quot ( class -- quot )
-    all-slots 1 tail [ class>> instance-check-quot ] map spread>quot ;
+    all-slots [ class>> instance-check-quot ] map spread>quot ;
 
 : define-boa-check ( class -- )
     dup boa-check-quot "boa-check" set-word-prop ;
 
 : tuple-prototype ( class -- prototype )
     [ initial-values ] keep
-    over [ ] all? [ 2drop f ] [ slots>tuple ] if ;
+    over [ ] contains? [ slots>tuple ] [ 2drop f ] if ;
 
 : define-tuple-prototype ( class -- )
     dup tuple-prototype "prototype" set-word-prop ;

core/kernel/kernel.factor

@@ -199,10 +199,3 @@ ERROR: assert got expect ;
 : do-primitive ( number -- ) "Improper primitive call" throw ;
 
 PRIVATE>
-
-! Deprecated
-GENERIC: delegate ( obj -- delegate )
-
-M: tuple delegate 2 slot ;
-
-M: object delegate drop f ;

core/quotations/quotations.factor

@@ -7,9 +7,9 @@ IN: quotations
 
 <PRIVATE
 
-: uncurry dup 3 slot swap 4 slot ; inline
+: uncurry dup 2 slot swap 3 slot ; inline
 
-: uncompose dup 3 slot swap 4 slot ; inline
+: uncompose dup 2 slot swap 3 slot ; inline
 
 PRIVATE>
 

core/slots/slots-docs.factor

@@ -131,7 +131,7 @@ HELP: define-typecheck
         "GENERIC: generic"
         "M: class generic quot ;"
     }
-    "It checks if the top of the stack is an instance of " { $snippet "class" } ", and if so, executes the quotation. Delegation is respected."
+    "It checks if the top of the stack is an instance of " { $snippet "class" } ", and if so, executes the quotation."
 }
 { $notes "This word is used internally to wrap unsafe low-level code in a type-checking stub." } ;
 

core/syntax/syntax.factor

@@ -83,7 +83,7 @@ IN: bootstrap.syntax
     "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
     "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
     "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
-    "T{" [ \ } [ >tuple ] parse-literal ] define-syntax
+    "T{" [ \ } [ literal>tuple ] parse-literal ] define-syntax
     "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
 
     "POSTPONE:" [ scan-word parsed ] define-syntax

extra/benchmark/binary-trees/binary-trees.factor

@@ -14,7 +14,7 @@ C: <tree-node> tree-node
         [ >r 2 *     r> bottom-up-tree ] 2tri
     ] [
         drop f f
-    ] if <tree-node> ;
+    ] if <tree-node> ; inline recursive
 
 GENERIC: item-check ( node -- n )
 
@@ -28,7 +28,7 @@ M: f item-check drop 0 ;
 : stretch-tree ( max-depth -- )
     1 + 0 over bottom-up-tree item-check
     [ "stretch tree of depth " write pprint ]
-    [ "\t check: " write . ] bi* ;
+    [ "\t check: " write . ] bi* ; inline
 
 :: long-lived-tree ( max-depth -- )
     0 max-depth bottom-up-tree
@@ -46,10 +46,10 @@ M: f item-check drop 0 ;
     ] each
 
     "long lived tree of depth " write max-depth pprint
-    "\t check: " write item-check . ;
+    "\t check: " write item-check . ; inline
 
 : binary-trees ( n -- )
-    min-depth 2 + max [ stretch-tree ] [ long-lived-tree ] bi ;
+    min-depth 2 + max [ stretch-tree ] [ long-lived-tree ] bi ; inline
 
 : binary-trees-main ( -- )
     16 binary-trees ;

extra/benchmark/ui-panes/ui-panes.factor

@@ -0,0 +1,7 @@
+USING: ui.gadgets.panes prettyprint io sequences ;
+IN: benchmark.ui-panes
+
+: ui-pane-benchmark ( -- )
+    <pane> <pane-stream> [ 10000 [ . ] each ] with-output-stream* ;
+
+MAIN: ui-pane-benchmark

extra/cfdg/cfdg.factor

@@ -5,8 +5,9 @@ USING: kernel alien.c-types combinators namespaces arrays
        opengl.gl opengl.glu opengl ui ui.gadgets.slate
        vars colors self self.slots
        random-weighted colors.hsv cfdg.gl accessors
-       ui.gadgets.handler ui.gestures assocs ui.gadgets macros ;
+       ui.gadgets.handler ui.gestures assocs ui.gadgets macros
-
+       qualified ;
+QUALIFIED: syntax
 IN: cfdg
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -158,7 +159,7 @@ MACRO: rule ( seq -- quot ) [rule] ;
 
 VAR: background
 
-: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;
+: set-initial-background ( -- ) T{ hsva syntax:f 0 0 1 1 } clone >self ;
 
 : set-background ( -- )
   set-initial-background
@@ -173,7 +174,7 @@ VAR: viewport ! { left width bottom height }
 
 VAR: start-shape
 
-: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;
+: set-initial-color ( -- ) T{ hsva syntax:f 0 0 0 1 } clone >self ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -244,7 +245,7 @@ SYMBOL: the-slate
     C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft
   <handler>
     H{ } clone
-      T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at
+      T{ key-down syntax:f syntax:f "ENTER" } C[ drop rebuild ] swap pick set-at
       T{ button-down } C[ drop rebuild ] swap pick set-at
     >>table ;
 

extra/furnace/furnace.factor

@@ -199,7 +199,7 @@ STRING: button-tag-markup
     attrs>> swap update ;
 
 CHLOE: button
-    button-tag-markup string>xml delegate
+    button-tag-markup string>xml body>>
     {
         [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
         [ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]

extra/tuple-syntax/tuple-syntax-tests.factor

@@ -4,5 +4,5 @@ IN: tuple-syntax.tests
 TUPLE: foo bar baz ;
 
 [ T{ foo } ] [ TUPLE{ foo } ] unit-test
-[ T{ foo 1 { 2 3 } { 4 { 5 } } } ]
+[ T{ foo f { 2 3 } { 4 { 5 } } } ]
-[ TUPLE{ foo bar: { 2 3 } delegate: 1 baz: { 4 { 5 } } } ] unit-test
+[ TUPLE{ foo bar: { 2 3 } baz: { 4 { 5 } } } ] unit-test

vm/types.c

@@ -345,11 +345,8 @@ DEFINE_PRIMITIVE(tuple_boa)
 	F_TUPLE *tuple = allot_tuple(layout);
 	UNREGISTER_UNTAGGED(layout);
 
-	/* set delegate slot */
-	put(AREF(tuple,0),F);
-
 	F_FIXNUM i;
-	for(i = size - 1; i >= 1; i--)
+	for(i = size - 1; i >= 0; i--)
 		put(AREF(tuple,i),dpop());
 
 	dpush(tag_tuple(tuple));