Remove delegation slot

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

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

@@ -67,15 +67,14 @@ MEMO: builtin-predicate-expansion ( word -- nodes )
 
 MEMO: (tuple-boa-expansion) ( n -- quot )
     [
-        1- [ 3 + ] map <reversed>
+       [ 2 + ] map <reversed>
         [ '[ [ , set-slot ] keep ] % ] each
-        [ f over 2 set-slot ] %
     ] [ ] make ;
 
 : tuple-boa-expansion ( layout -- quot )
     #! No memoization here since otherwise we'd hang on to
     #! tuple layout objects.
-    [ \ (tuple) , size>> (tuple-boa-expansion) % ] [ ] make splice-quot ;
+    size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
 
 : expand-tuple-boa ( #call -- node )
     last-literal tuple-boa-expansion ;

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 rest-slice
+    all-slots
     [ 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 rest-slice
-                    [ <literal-info> ] map
-                ] [ class ] bi read-only-slots >>slots
+                [ tuple-slots [ <literal-info> ] map ] [ class ] bi
+                read-only-slots >>slots
             ] }
             [ drop ]
         } cond

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? [
-        [ 2 tail-slice ] dip fold-<tuple-boa>
+    over rest-slice [ dup [ literal?>> ] when ] all? [
+        [ 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/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
 

core/bootstrap/primitives.factor

@@ -281,18 +281,12 @@ bi
 "tuple" "kernel" create
 [ { } define-builtin ]
 [ define-tuple-layout ]
-[
-    { "delegate" } make-slots
-    [ drop ] [ finalize-tuple-slots ] 2bi
-    [ "slots" set-word-prop ]
-    [ define-accessors ]
-    2bi
-] tri
+bi
 
 ! 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/bootstrap/stage1.factor

@@ -21,7 +21,7 @@ load-help? off
         ! using the host image's hashing algorithms. We don't
         ! use each-object here since the catch stack isn't yet
         ! set up.
-        begin-scan
+        begin-scan USE: accessors USE: kernel.private
         [ hashtable? ] pusher [ (each-object) ] dip
         end-scan
         [ rehash ] each

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.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 rest-slice [ read-only>> ] all? ;
+    all-slots [ read-only>> ] all? ;
 
 <PRIVATE
 
@@ -126,7 +125,7 @@ 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 ;

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

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));