Working on slot inheritance

core/bootstrap/primitives.factor

@@ -324,14 +324,20 @@ define-builtin
     }
 } define-builtin
 
-"tuple" "kernel" create {
+"tuple" "kernel" create { } define-builtin
+
+"tuple" "kernel" lookup
 {
-        { "tuple-layout" "tuples.private" }
+    {
-        "layout"
+        { "object" "kernel" }
-        { "tuple-layout" "tuples.private" }
+        "delegate"
-        f
+        { "delegate" "kernel" }
+        { "set-delegate" "kernel" }
     }
-} define-builtin
+}
+define-tuple-slots
+
+"tuple" "kernel" lookup define-tuple-layout
 
 ! Define general-t type, which is any object that is not f.
 "general-t" "kernel" create

core/classes/classes.factor

@@ -57,6 +57,9 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
     #! Output f for non-classes to work with algebra code
     dup class? [ "superclass" word-prop ] [ drop f ] if ;
 
+: superclasses ( class -- supers )
+    [ dup ] [ dup superclass swap ] [ ] unfold reverse nip ;
+
 : members ( class -- seq )
     #! Output f for non-classes to work with algebra code
     dup class? [ "members" word-prop ] [ drop f ] if ;

core/mirrors/mirrors.factor

@@ -10,7 +10,7 @@ GENERIC: object-slots ( obj -- seq )
 M: object object-slots class "slots" word-prop ;
 
 M: tuple object-slots
-    dup class "slots" word-prop
+    dup class superclasses [ "slots" word-prop ] map concat
     swap delegate [ 1 tail-slice ] unless ;
 
 TUPLE: mirror object slots ;

core/tuples/tuples-tests.factor

@@ -246,6 +246,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
 
 ! Inheritance
 TUPLE: computer cpu ram ;
+C: <computer> computer
 
 [ "TUPLE: computer cpu ram ;" ] [
     [ \ computer see ] with-string-writer string-lines second
@@ -264,11 +265,23 @@ C: <laptop> laptop
 [ t ] [ "laptop" get computer? ] unit-test
 [ t ] [ "laptop" get tuple? ] unit-test
 
+[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
+[ 128 ] [ "laptop" get ram>> ] unit-test
+[ t ] [ "laptop" get battery>> 3 hours = ] unit-test
+
+[ laptop ] [
+    "laptop" get tuple-layout
+    dup layout-echelon swap
+    layout-superclasses nth
+] unit-test
+
 [ "TUPLE: laptop < computer battery ;" ] [
     [ \ laptop see ] with-string-writer string-lines second
 ] unit-test
 
-TUPLE: server < computer rackmount? ;
+[ { tuple computer laptop } ] [ laptop superclasses ] unit-test
+
+TUPLE: server < computer rackmount ;
 C: <server> server
 
 [ t ] [ server tuple-class? ] unit-test
@@ -276,11 +289,15 @@ C: <server> server
 [ t ] [ server computer class< ] unit-test
 [ t ] [ server computer classes-intersect? ] unit-test
 
-[ ] [ "Pentium" 128 "1U" <server> "server" set ] unit-test
+[ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
 [ t ] [ "server" get server? ] unit-test
 [ t ] [ "server" get computer? ] unit-test
 [ t ] [ "server" get tuple? ] unit-test
 
+[ "PowerPC" ] [ "server" get cpu>> ] unit-test
+[ 64 ] [ "server" get ram>> ] unit-test
+[ "1U" ] [ "server" get rackmount>> ] unit-test
+
 [ f ] [ "server" get laptop? ] unit-test
 [ f ] [ "laptop" get server? ] unit-test
 
@@ -288,7 +305,10 @@ C: <server> server
 [ f ] [ laptop server class< ] unit-test
 [ f ] [ laptop server classes-intersect? ] unit-test
 
-[ "TUPLE: server < computer rackmount? ;" ] [
+[ f ] [ 1 2 <computer> laptop? ] unit-test
+[ f ] [ \ + server? ] unit-test
+
+[ "TUPLE: server < computer rackmount ;" ] [
     [ \ server see ] with-string-writer string-lines second
 ] unit-test
 

core/tuples/tuples.factor

@@ -4,7 +4,7 @@ USING: arrays definitions hashtables kernel
 kernel.private math namespaces sequences sequences.private
 strings vectors words quotations memory combinators generic
 classes classes.private slots.deprecated slots.private slots
-compiler.units ;
+compiler.units math.private ;
 IN: tuples
 
 M: tuple delegate 2 slot ;
@@ -17,6 +17,12 @@ ERROR: no-tuple-class class ;
 
 <PRIVATE
 
+GENERIC: tuple-layout ( object -- layout )
+
+M: class tuple-layout "layout" word-prop ;
+
+M: tuple tuple-layout 1 slot ;
+
 : tuple-size tuple-layout layout-size ; inline
 
 PRIVATE>
@@ -49,33 +55,56 @@ PRIVATE>
         2drop f
     ] if ;
 
-M: tuple-class tuple-layout "layout" word-prop ;
+! Predicate generation. We optimize at the expense of simplicity
+
+: (tuple-predicate-quot) ( class -- quot )
+    #! 4 slot == layout-superclasses
+    #! 5 slot == layout-echelon
+    [
+        [ 1 slot dup 5 slot ] %
+        dup tuple-layout layout-echelon ,
+        [ fixnum>= ] %
+        [
+            dup tuple-layout layout-echelon ,
+            [ swap 4 slot array-nth ] %
+            literalize ,
+            [ eq? ] %
+        ] [ ] make ,
+        [ drop f ] ,
+        \ if ,
+    ] [ ] make ;
+
+: tuple-predicate-quot ( class -- quot )
+    [
+        [ dup tuple? ] %
+        (tuple-predicate-quot) ,
+        [ drop f ] ,
+        \ if ,
+    ] [ ] make ;
 
 : define-tuple-predicate ( class -- )
-    dup tuple-layout
+    dup tuple-predicate-quot define-predicate ;
-    [ over tuple? [ swap 1 slot eq? ] [ 2drop f ] if ] curry
-    define-predicate ;
 
-: delegate-slot-spec
+: superclass-size ( class -- n )
-    T{ slot-spec f
+    superclasses 1 head-slice*
-        object
+    [ "slot-names" word-prop length ] map sum ;
-        "delegate"
+
-        2
+: generate-tuple-slots ( class slots -- slot-specs slot-names )
-        delegate
+    over superclass-size 2 + simple-slots
-        set-delegate
+    dup [ slot-spec-name ] map ;
-    } ;
 
 : define-tuple-slots ( class slots -- )
-    dupd 3 simple-slots
+    dupd generate-tuple-slots
-    2dup [ slot-spec-name ] map "slot-names" set-word-prop
+    >r dupd "slots" set-word-prop
-    2dup delegate-slot-spec add* "slots" set-word-prop
+    r> dupd "slot-names" set-word-prop
-    2dup define-slots
+    dup "slots" word-prop 2dup define-slots define-accessors ;
-    define-accessors ;
+
+: make-tuple-layout ( class -- layout )
+    dup superclass-size over "slot-names" word-prop length +
+    over superclasses dup length 1- <tuple-layout> ;
 
 : define-tuple-layout ( class -- )
-    dup
+    dup make-tuple-layout "layout" set-word-prop ;
-    dup "slot-names" word-prop length 1+ { } 0 <tuple-layout>
-    "layout" set-word-prop ;
 
 : removed-slots ( class newslots -- seq )
     swap "slot-names" word-prop seq-diff ;