diff --git a/library/generic/builtin.factor b/library/generic/builtin.factor index f71db1a6fe..005ee7550e 100644 --- a/library/generic/builtin.factor +++ b/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 = ; diff --git a/library/generic/complement.factor b/library/generic/complement.factor index 642153b268..46bc917abd 100644 --- a/library/generic/complement.factor +++ b/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 = ; diff --git a/library/generic/generic.factor b/library/generic/generic.factor index f910354e73..bdff0969f0 100644 --- a/library/generic/generic.factor +++ b/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 [ typemap set ] unless diff --git a/library/generic/null.factor b/library/generic/null.factor index b8026f7c3d..9f779d5b39 100644 --- a/library/generic/null.factor +++ b/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 diff --git a/library/generic/object.factor b/library/generic/object.factor index 5d67924268..40ebd41bd2 100644 --- a/library/generic/object.factor +++ b/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 -- ) diff --git a/library/generic/predicate.factor b/library/generic/predicate.factor index e328543a0c..b35127e4b4 100644 --- a/library/generic/predicate.factor +++ b/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 diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 149060816e..af5e8426af 100644 --- a/library/generic/tuple.factor +++ b/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 -- ? ) diff --git a/library/generic/union.factor b/library/generic/union.factor index 0a3fd2645d..ba231a479e 100644 --- a/library/generic/union.factor +++ b/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 = ; diff --git a/library/inference/class-infer.factor b/library/inference/class-infer.factor index d1e6eb27fb..1f333051f2 100644 --- a/library/inference/class-infer.factor +++ b/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 ] map-with + dup node-in-d first num-types [ type>class ] map-with swap node-out-d first num-types [ ] map-with [ ties get set-hash ] 2each ] "create-ties" set-word-prop diff --git a/library/syntax/see.factor b/library/syntax/see.factor index 018d9603e4..51b0a215f1 100644 --- a/library/syntax/see.factor +++ b/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-; ; diff --git a/library/test/generic.factor b/library/test/generic.factor index 5cfbbac45c..90088b82e3 100644 --- a/library/test/generic.factor +++ b/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 ; diff --git a/library/test/memory.factor b/library/test/memory.factor index 4e1710b0b4..bc173d3d6d 100644 --- a/library/test/memory.factor +++ b/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 diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 49bb88f7c6..7b90361275 100644 --- a/library/tools/debugger.factor +++ b/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 . ; diff --git a/library/tools/memory.factor b/library/tools/memory.factor index af0ffe0d81..4a99e9f2fe 100644 --- a/library/tools/memory.factor +++ b/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 ;