clean up metaclasses

library/generic/builtin.factor

@@ -10,10 +10,6 @@ SYMBOL: builtin
 ! Global vector mapping type numbers to builtin class objects.
 SYMBOL: builtins
 
-builtin [
-    "builtin-type" word-prop unit
-] "builtin-supertypes" set-word-prop
-
 builtin [
     ( generic vtable definition class -- )
     rot set-vtable drop
@@ -21,23 +17,23 @@ builtin [
 
 : builtin-predicate ( class predicate -- )
     [
-        \ type , over "builtin-type" word-prop , \ eq? ,
+        \ type , over types first , \ eq? ,
     ] make-list define-predicate ;
 
 : register-builtin ( class -- )
-    dup "builtin-type" word-prop builtins get set-nth ;
+    dup types first builtins get set-nth ;
 
 : define-builtin ( symbol type# predicate slotspec -- )
     >r >r >r
     dup intern-symbol
-    dup r> "builtin-type" set-word-prop
+    dup r> 1vector "types" set-word-prop
     dup builtin define-class
     dup r> builtin-predicate
     dup r> intern-slots 2dup "slots" set-word-prop
     define-slots
     register-builtin ;
 
-: builtin-type ( n -- symbol ) builtins get nth ;
+: type>class ( n -- symbol ) builtins get nth ;
 
 PREDICATE: word builtin metaclass builtin = ;
 

library/generic/complement.factor

@@ -8,28 +8,24 @@ sequences vectors words ;
 ! Complement metaclass, contains all objects not in a certain class.
 SYMBOL: complement
 
-complement [
-    "complement" word-prop builtin-supertypes
-    num-types >list
-    seq-diff
-] "builtin-supertypes" set-word-prop
-
 complement [
     ( generic vtable definition class -- )
     drop num-types [
-        >r 3dup r> builtin-type
+        >r 3dup r> type>class
         dup [ add-method ] [ 2drop 2drop ] ifte
     ] each 3drop
 ] "add-method" set-word-prop
 
-complement [ (class<) ] "class<" set-word-prop
-
 : complement-predicate ( complement -- list )
     "predicate" word-prop [ not ] append ;
 
+: complement-types ( class -- types )
+    "complement" word-prop types object types seq-diff ;
+
 : define-complement ( class complement -- )
     2dup "complement" set-word-prop
     dupd complement-predicate "predicate" set-word-prop
+    dup complement-types "types" set-word-prop
     complement define-class ;
 
 PREDICATE: word complement metaclass complement = ;

library/generic/generic.factor

@@ -15,26 +15,19 @@ math-internals ;
     2dup unit "predicate" set-word-prop
     swap "predicating" set-word-prop ;
 
-DEFER: delegate
-
-! Metaclasses have priority -- this induces an order in which
-! methods are added to the vtable.
-
 : metaclass ( class -- metaclass )
     "metaclass" word-prop ;
 
-: builtin-supertypes ( class -- list )
-    #! A list of builtin supertypes of the class.
-    dup metaclass "builtin-supertypes" word-prop call ;
+: types ( class -- types )
+    dup "types" word-prop [ ] [
+        "superclass" word-prop [ types ] [ [ ] ] ifte*
+    ] ?ifte ;
 
 : set-vtable ( definition class vtable -- )
-    >r "builtin-type" word-prop r> set-nth ;
+    >r types first r> set-nth ;
 
 : 2types ( class class -- seq seq )
-    swap builtin-supertypes swap builtin-supertypes ;
-
-: (class<) ( class class -- ? )
-    2types contained? ;
+    swap types swap types ;
 
 : class< ( cls1 cls2 -- ? )
     #! Test if class1 is a subclass of class2.
@@ -44,7 +37,7 @@ DEFER: delegate
         2dup "superclass" word-prop dup [
             swap class< not 2nip
         ] [
-            2drop (class<)
+            2drop 2types contained?
         ] ifte
     ] ifte ;
 
@@ -198,7 +191,6 @@ SYMBOL: object
 
 : define-class ( class metaclass -- )
     dupd "metaclass" set-word-prop
-    dup builtin-supertypes [ - ] sort
-    typemap get set-hash ;
+    dup types [ - ] sort typemap get set-hash ;
 
 typemap get [ <namespace> typemap set ] unless

library/generic/null.factor

@@ -5,7 +5,8 @@ USING: kernel words ;
 
 ! Null metaclass with no instances.
 SYMBOL: null
-null [ drop [ ] ] "builtin-supertypes" set-word-prop
+
+null { } "types" set-word-prop
 
 null [ 2drop 2drop ] "add-method" set-word-prop
 

library/generic/object.factor

@@ -6,9 +6,7 @@ USING: kernel lists math sequences vectors words ;
 ! Catch-all metaclass for providing a default method.
 SYMBOL: object
 
-object [
-    drop num-types >list
-] "builtin-supertypes" set-word-prop
+object num-types >vector "types" set-word-prop
 
 object [
     ( generic vtable definition class -- )

library/generic/predicate.factor

@@ -19,30 +19,14 @@ SYMBOL: predicate
         -rot predicate-dispatch
     ] 2keep set-nth ;
 
-predicate [
-    "superclass" word-prop builtin-supertypes
-] "builtin-supertypes" set-word-prop
-
 predicate [
     ( generic vtable definition class -- )
-    dup builtin-supertypes [
+    dup types [
         ( vtable definition class type# )
         >r 3dup r> predicate-method
     ] each 2drop 2drop
 ] "add-method" set-word-prop
 
-predicate [
-    2dup metaclass= [
-        over "superclass" word-prop dup [
-            swap class< nip
-        ] [
-            drop (class<)
-        ] ifte
-    ] [
-        (class<)
-    ] ifte
-] "class<" set-word-prop
-
 : define-predicate-class ( class predicate definition -- )
     3dup nip "definition" set-word-prop
     pick predicate "metaclass" set-word-prop

library/generic/tuple.factor

@@ -22,7 +22,7 @@ BUILTIN: tuple 18 tuple? ;
     dup tuple? [ 3 set-slot ] [ 2drop ] ifte ; inline
 
 : class ( object -- class )
-    dup tuple? [ 2 slot ] [ type builtin-type ] ifte ; inline
+    dup tuple? [ 2 slot ] [ type type>class ] ifte ; inline
 
 : class-tuple ( object -- class )
     dup tuple? [ 2 slot ] [ drop f ] ifte ; inline
@@ -185,10 +185,6 @@ tuple [
     2drop add-tuple-dispatch
 ] "add-method" set-word-prop
 
-tuple [
-    drop tuple "builtin-type" word-prop unit
-] "builtin-supertypes" set-word-prop
-
 PREDICATE: word tuple-class metaclass tuple = ;
 
 : is? ( obj pred -- ? | pred: obj -- ? )

library/generic/union.factor

@@ -7,10 +7,6 @@ sequences strings words vectors ;
 ! Union metaclass for dispatch on multiple classes.
 SYMBOL: union
 
-union [
-    "members" word-prop [ builtin-supertypes ] map concat
-] "builtin-supertypes" set-word-prop
-
 union [
     ( generic vtable definition class -- )
     "members" word-prop [ >r 3dup r> add-method ] each 3drop
@@ -29,10 +25,13 @@ union [
         [ drop f ]
     ] ifte* ;
 
+: set-members ( class members -- )
+    2dup [ types ] map concat "types" set-word-prop
+    "members" set-word-prop ;
+
 : define-union ( class predicate members -- )
     #! We have to turn the f object into the f word, same for t.
-    3dup nip "members" set-word-prop
-    pick union define-class
+    3dup nip set-members pick union define-class
     union-predicate define-predicate ;
 
 PREDICATE: word union metaclass union = ;

library/inference/class-infer.factor

@@ -75,7 +75,7 @@ M: node child-ties ( node -- seq )
     [ [ value-class class-and ] 2map ] keep assume-classes ;
 
 \ type [
-    dup node-in-d first num-types [ builtin-type <class-tie> ] map-with
+    dup node-in-d first num-types [ type>class <class-tie> ] map-with
     swap node-out-d first num-types [ <literal-tie> ] map-with
     [ ties get set-hash ] 2each
 ] "create-ties" set-word-prop

library/syntax/see.factor

@@ -104,7 +104,7 @@ M: complement class.
 M: builtin class.
     \ BUILTIN: unparse. bl
     dup unparse. bl
-    dup "builtin-type" word-prop unparse write bl
+    dup types first unparse write bl
     0 swap "slots" word-prop prettyprint-elements drop
     prettyprint-; ;
 

library/test/generic.factor

@@ -105,6 +105,9 @@ M: very-funny gooey sq ;
 [ t ] [ \ generic \ compound class< ] unit-test
 [ f ] [ \ compound \ generic class< ] unit-test
 
+[ f ] [ \ cons \ list class< ] unit-test
+[ f ] [ \ list \ cons class< ] unit-test
+
 DEFER: bah
 FORGET: bah
 UNION: bah fixnum alien ;

library/test/memory.factor

@@ -8,7 +8,7 @@ TUPLE: testing x y z ;
 
 [ ] [
     num-types [
-        builtin-type [
+        type>class [
             dup \ cons = [
                 ! too many conses!
                 drop

library/tools/debugger.factor

@@ -18,7 +18,7 @@ vectors words ;
     "Type check error" print
     uncons car dup "Object: " write .
     "Object type: " write class unparse. terpri
-    "Expected type: " write builtin-type unparse. terpri ;
+    "Expected type: " write type>class unparse. terpri ;
 
 : float-format-error. ( list -- )
     "Invalid floating point literal format: " write . ;

library/tools/memory.factor

@@ -86,7 +86,7 @@ M: object each-slot ( obj quot -- )
     dup 0 = [
         3drop
     ] [
-        rot builtin-type word-name write ": " write
+        rot type>class word-name write ": " write
         unparse write " bytes, " write
         unparse write " instances" print
     ] ifte ;