classes: If a tuple class with subclasses is redefined into something that's not a tuple class, subclasses are changed to inherit from 'tuple' instead of being forgotten. Also, changing the metaclass of a union or intersection member no longer removes it from the union or intersection. Finally, make some internal words private

basis/bootstrap/image/image.factor

@@ -5,12 +5,13 @@ hashtables.private io io.binary io.files io.encodings.binary
 io.pathnames kernel kernel.private math namespaces make parser
 prettyprint sequences strings sbufs vectors words quotations
 assocs system layouts splitting grouping growable classes
-classes.builtin classes.tuple classes.tuple.private vocabs
+classes.private classes.builtin classes.tuple
-vocabs.loader source-files definitions debugger
+classes.tuple.private vocabs vocabs.loader source-files
-quotations.private combinators combinators.short-circuit
+definitions debugger quotations.private combinators
-math.order math.private accessors slots.private
+combinators.short-circuit math.order math.private accessors
-generic.single.private compiler.units compiler.constants fry
+slots.private generic.single.private compiler.units
-locals bootstrap.image.syntax generalizations ;
+compiler.constants fry locals bootstrap.image.syntax
+generalizations ;
 IN: bootstrap.image
 
 : arch ( os cpu -- arch )
@@ -342,9 +343,7 @@ M: float '
 
 : t, ( -- ) t t-offset fixup ;
 
-M: f '
+M: f ' drop \ f type-number ;
-    #! f is #define F RETAG(0,F_TYPE)
-    drop \ f type-number ;
 
 :  0, ( -- )  0 >bignum '  0-offset fixup ;
 :  1, ( -- )  1 >bignum '  1-offset fixup ;

basis/classes/struct/struct.factor

@@ -1,12 +1,13 @@
 ! (c)Joe Groff, Daniel Ehrenberg bsd license
-USING: accessors alien alien.c-types alien.data alien.parser arrays
+USING: accessors alien alien.c-types alien.data alien.parser
-byte-arrays classes classes.parser classes.tuple classes.tuple.parser
+arrays byte-arrays classes classes.private classes.parser
-classes.tuple.private combinators combinators.short-circuit
+classes.tuple classes.tuple.parser classes.tuple.private
-combinators.smart cpu.architecture definitions functors.backend
+combinators combinators.short-circuit combinators.smart
-fry generalizations generic.parser kernel kernel.private lexer
+cpu.architecture definitions functors.backend fry
-libc locals macros make math math.order parser quotations
+generalizations generic.parser kernel kernel.private lexer libc
-sequences slots slots.private specialized-arrays vectors words
+locals macros make math math.order parser quotations sequences
-summary namespaces assocs vocabs.parser math.functions
+slots slots.private specialized-arrays vectors words summary
+namespaces assocs vocabs.parser math.functions
 classes.struct.bit-accessors bit-arrays ;
 QUALIFIED: math
 IN: classes.struct

core/bootstrap/primitives.factor

@@ -3,11 +3,12 @@
 USING: alien alien.strings arrays byte-arrays generic hashtables
 hashtables.private io io.encodings.ascii kernel math
 math.private math.order namespaces make parser sequences strings
-vectors words quotations assocs layouts classes classes.builtin
+vectors words quotations assocs layouts classes classes.private
-classes.tuple classes.tuple.private kernel.private vocabs
+classes.builtin classes.tuple classes.tuple.private
-vocabs.loader source-files definitions slots classes.union
+kernel.private vocabs vocabs.loader source-files definitions
-classes.intersection classes.predicate compiler.units
+slots classes.union classes.intersection classes.predicate
-bootstrap.image.private io.files accessors combinators ;
+compiler.units bootstrap.image.private io.files accessors
+combinators ;
 IN: bootstrap.primitives
 
 "Creating primitives and basic runtime structures..." print flush

core/classes/algebra/algebra-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax kernel classes words
+USING: help.markup help.syntax kernel classes classes.private words
 checksums checksums.crc32 sequences math ;
 IN: classes.algebra
 

core/classes/algebra/algebra.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel classes combinators accessors sequences arrays
+USING: kernel classes classes.private combinators accessors
-vectors assocs namespaces words sorting layouts math hashtables
+sequences arrays vectors assocs namespaces words sorting layouts
-kernel.private sets math.order ;
+math hashtables kernel.private sets math.order ;
 IN: classes.algebra
 
 <PRIVATE

core/classes/builtin/builtin.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes classes.algebra classes.algebra.private
+USING: accessors classes classes.private classes.algebra
-words kernel kernel.private namespaces sequences math
+classes.algebra.private words kernel kernel.private namespaces
-math.private combinators assocs quotations ;
+sequences math math.private combinators assocs quotations ;
 IN: classes.builtin
 
 SYMBOL: builtins

core/classes/classes.factor

@@ -8,6 +8,10 @@ IN: classes
 
 ERROR: bad-inheritance class superclass ;
 
+PREDICATE: class < word "class" word-prop ;
+
+<PRIVATE
+
 SYMBOL: class<=-cache
 SYMBOL: class-not-cache
 SYMBOL: classes-intersect-cache
@@ -35,7 +39,23 @@ SYMBOL: update-map
 
 SYMBOL: implementors-map
 
-PREDICATE: class < word "class" word-prop ;
+GENERIC: rank-class ( class -- n )
+
+GENERIC: reset-class ( class -- )
+
+M: class reset-class
+    {
+        "class"
+        "metaclass"
+        "superclass"
+        "members"
+        "participants"
+        "predicate"
+    } reset-props ;
+
+M: word reset-class drop ;
+
+PRIVATE>
 
 : classes ( -- seq ) implementors-map get keys ;
 
@@ -65,8 +85,11 @@ M: predicate reset-word
 : superclasses ( class -- supers )
     [ superclass ] follow reverse ;
 
+: superclass-of? ( class superclass -- ? )
+    superclasses member-eq? ;
+
 : subclass-of? ( class superclass -- ? )
-    swap superclasses member? ;
+    swap superclass-of? ;
 
 : members ( class -- seq )
     #! Output f for non-classes to work with algebra code
@@ -76,22 +99,6 @@ M: predicate reset-word
     #! Output f for non-classes to work with algebra code
     dup class? [ "participants" word-prop ] [ drop f ] if ;
 
-GENERIC: rank-class ( class -- n )
-
-GENERIC: reset-class ( class -- )
-
-M: class reset-class
-    {
-        "class"
-        "metaclass"
-        "superclass"
-        "members"
-        "participants"
-        "predicate"
-    } reset-props ;
-
-M: word reset-class drop ;
-
 GENERIC: implementors ( class/classes -- seq )
 
 ! update-map
@@ -107,6 +114,10 @@ GENERIC: implementors ( class/classes -- seq )
 
 : class-usages ( class -- seq ) [ class-usage ] closure keys ;
 
+M: class implementors implementors-map get at keys ;
+
+M: sequence implementors [ implementors ] gather ;
+
 <PRIVATE
 
 : update-map+ ( class -- )
@@ -115,12 +126,8 @@ GENERIC: implementors ( class/classes -- seq )
 : update-map- ( class -- )
     dup class-uses update-map get remove-vertex ;
 
-M: class implementors implementors-map get at keys ;
-
-M: sequence implementors [ implementors ] gather ;
-
 : implementors-map+ ( class -- )
-    H{ } clone swap implementors-map get set-at ;
+    [ H{ } clone ] dip implementors-map get set-at ;
 
 : implementors-map- ( class -- )
     implementors-map get delete-at ;
@@ -135,31 +142,39 @@ M: sequence implementors [ implementors ] gather ;
         } spread
     ] H{ } make-assoc ;
 
+GENERIC: metaclass-changed ( use class -- )
+
+: ?metaclass-changed ( class usages/f -- )
+    dup [ [ metaclass-changed ] with each ] [ 2drop ] if ;
+
+: check-metaclass ( class metaclass -- usages/f )
+    over class? [
+        over "metaclass" word-prop eq?
+        [ drop f ] [ class-usage keys ] if
+    ] [ 2drop f ] if ;
+
 : ?define-symbol ( word -- )
     dup deferred? [ define-symbol ] [ drop ] if ;
 
 : (define-class) ( word props -- )
     reset-caches
-    [ drop update-map- ]
+    2dup "metaclass" swap at check-metaclass
-    [
-        [
     {
-                [ dup class? [ drop ] [ implementors-map+ ] if ]
+        [ 2drop update-map- ]
-                [ reset-class ]
+        [ 2drop dup class? [ reset-class ] [ implementors-map+ ] if ]
-                [ ?define-symbol ]
+        [ 2drop ?define-symbol ]
-                [ ]
+        [ drop [ assoc-union ] curry change-props drop ]
-            } cleave
+        [
-        ] dip [ assoc-union ] curry change-props
+            2drop
             dup create-predicate-word
             [ 1quotation "predicate" set-word-prop ]
             [ swap "predicating" set-word-prop ]
-        [ drop t "class" set-word-prop ]
+            2bi
-        2tri
         ]
-    [ drop update-map+ ]
+        [ 2drop t "class" set-word-prop ]
-    2tri ;
+        [ 2drop update-map+ ]
-
+        [ nip ?metaclass-changed ]
-PRIVATE>
+    } 3cleave ;
 
 GENERIC: update-class ( class -- )
 
@@ -172,7 +187,7 @@ GENERIC: update-methods ( class seq -- )
     [ nip [ update-class ] each ] [ update-methods ] 2bi ;
 
 : check-inheritance ( subclass superclass -- )
-    2dup superclasses member-eq? [ bad-inheritance ] [ 2drop ] if ;
+    2dup superclass-of? [ bad-inheritance ] [ 2drop ] if ;
 
 : define-class ( word superclass members participants metaclass -- )
     [ 2dup check-inheritance ] 3dip
@@ -188,21 +203,21 @@ GENERIC: update-methods ( class seq -- )
 
 GENERIC: forget-methods ( class -- )
 
-GENERIC: class-forgotten ( use class -- )
+PRIVATE>
 
 : forget-class ( class -- )
-    {
+    dup f check-metaclass {
-        [ dup class-usage keys [ class-forgotten ] with each ]
+        [ drop forget-predicate ]
-        [ forget-predicate ]
+        [ drop forget-methods ]
-        [ forget-methods ]
+        [ drop implementors-map- ]
-        [ implementors-map- ]
+        [ drop update-map- ]
-        [ update-map- ]
+        [ drop reset-class ]
-        [ reset-class ]
+        [ 2drop reset-caches ]
-    } cleave
+        [ ?metaclass-changed ]
-    reset-caches ;
+    } 2cleave ;
 
-M: class class-forgotten
+M: class metaclass-changed
-    nip forget-class ;
+    swap class? [ drop ] [ forget-class ] if ;
 
 M: class forget* ( class -- )
     [ call-next-method ] [ forget-class ] bi ;

core/classes/intersection/intersection.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: words accessors sequences kernel assocs combinators classes
+USING: words accessors sequences kernel assocs combinators
-classes.algebra classes.algebra.private classes.builtin
+classes classes.private classes.algebra classes.algebra.private
-namespaces arrays math quotations ;
+classes.builtin namespaces arrays math quotations ;
 IN: classes.intersection
 
 PREDICATE: intersection-class < class

core/classes/mixin/mixin-tests.factor

@@ -128,3 +128,23 @@ SYMBOL: not-a-mixin
 TUPLE: a-class ;
 
 [ [ \ a-class \ not-a-mixin add-mixin-instance ] with-compilation-unit ] must-fail
+
+! Changing a mixin member's metaclass should not remove it from the mixin
+MIXIN: metaclass-change-mixin
+TUPLE: metaclass-change ;
+INSTANCE: metaclass-change metaclass-change-mixin
+
+GENERIC: metaclass-change-generic ( a -- b )
+
+M: metaclass-change-mixin metaclass-change-generic ;
+
+[ T{ metaclass-change } ] [ T{ metaclass-change } metaclass-change-generic ] unit-test
+
+[ ] [ "IN: classes.mixin.tests USE: math UNION: metaclass-change integer ;" eval( -- ) ] unit-test
+
+[ 0 ] [ 0 metaclass-change-generic ] unit-test
+
+! Forgetting a mixin member class should remove it from the mixin
+[ ] [ [ metaclass-change forget-class ] with-compilation-unit ] unit-test
+
+[ t ] [ metaclass-change-mixin members empty? ] unit-test

core/classes/mixin/mixin.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.algebra classes.algebra.private
+USING: classes classes.private classes.algebra
-classes.union classes.union.private words kernel sequences
+classes.algebra.private classes.union classes.union.private
-definitions combinators arrays assocs generic accessors ;
+words kernel sequences definitions combinators arrays assocs
+generic accessors ;
 IN: classes.mixin
 
 PREDICATE: mixin-class < union-class "mixin" word-prop ;
@@ -75,7 +76,8 @@ M: class add-mixin-instance
 : remove-mixin-instance ( class mixin -- )
     [ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
 
-M: mixin-class class-forgotten remove-mixin-instance ;
+M: mixin-class metaclass-changed
+    over class? [ 2drop ] [ remove-mixin-instance ] if ;
 
 : define-mixin-class ( class -- )
     dup mixin-class? [

core/classes/predicate/predicate-tests.factor

@@ -1,5 +1,6 @@
 USING: math tools.test classes.algebra words kernel sequences assocs
-accessors eval definitions compiler.units generic strings classes ;
+accessors eval definitions compiler.units generic strings classes
+generic.single ;
 IN: classes.predicate.tests
 
 PREDICATE: negative < integer 0 < ;
@@ -59,3 +60,30 @@ PREDICATE: tup < string ;
 UNION: u tup ;
 
 [ ] [ "IN: classes.predicate.tests PREDICATE: u < tup ;" eval( -- ) ] unit-test
+
+! Changing the metaclass of the predicate superclass should work
+GENERIC: change-meta-test ( a -- b )
+
+TUPLE: change-meta-test-class length ;
+
+PREDICATE: change-meta-test-predicate < change-meta-test-class length>> 2 > ;
+
+M: change-meta-test-predicate change-meta-test length>> ;
+
+[ f ] [ \ change-meta-test "methods" word-prop assoc-empty? ] unit-test
+
+[ T{ change-meta-test-class f 0 } change-meta-test ] [ no-method? ] must-fail-with
+[ 7 ] [ T{ change-meta-test-class f 7 } change-meta-test ] unit-test
+
+[ ] [ "IN: classes.predicate.tests USE: arrays UNION: change-meta-test-class array ;" eval( -- ) ] unit-test
+
+! Should not have changed
+[ change-meta-test-class ] [ change-meta-test-predicate superclass ] unit-test
+[ { } change-meta-test ] [ no-method? ] must-fail-with
+[ 4 ] [ { 1 2 3 4 } change-meta-test ] unit-test
+
+[ ] [ [ \ change-meta-test-class forget-class ] with-compilation-unit ] unit-test
+
+[ f ] [ change-meta-test-predicate class? ] unit-test
+
+[ t ] [ \ change-meta-test "methods" word-prop assoc-empty? ] unit-test

core/classes/predicate/predicate.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.algebra classes.algebra.private kernel
+USING: classes classes.private classes.algebra
-namespaces make words sequences quotations arrays kernel.private
+classes.algebra.private kernel namespaces make words sequences
-assocs combinators ;
+quotations arrays kernel.private assocs combinators ;
 IN: classes.predicate
 
 PREDICATE: predicate-class < class

core/classes/tuple/tuple-tests.factor

@@ -511,58 +511,6 @@ TUPLE: another-forget-accessors-test ;
 ! Missing error check
 [ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval( -- ) ] must-fail
 
-! Class forget messyness
-TUPLE: subclass-forget-test ;
-
-TUPLE: subclass-forget-test-1 < subclass-forget-test ;
-TUPLE: subclass-forget-test-2 < subclass-forget-test ;
-TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
-
-[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval( -- ) ] unit-test
-
-[ { subclass-forget-test-2 } ]
-[ subclass-forget-test-2 class-usages ]
-unit-test
-
-[ { subclass-forget-test-3 } ]
-[ subclass-forget-test-3 class-usages ]
-unit-test
-
-[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
-[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
-[ subclass-forget-test-3 new ] must-fail
-
-[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval( -- ) ] must-fail
-
-! More
-DEFER: subclass-reset-test
-DEFER: subclass-reset-test-1
-DEFER: subclass-reset-test-2
-DEFER: subclass-reset-test-3
-
-GENERIC: break-me ( obj -- )
-
-[ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test
-
-[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval( -- ) ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval( -- ) ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval( -- ) ] unit-test
-
-[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval( -- ) ] unit-test
-
-[ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
-
-[ f ] [ subclass-reset-test-1 tuple-class? ] unit-test
-[ f ] [ subclass-reset-test-2 tuple-class? ] unit-test
-[ subclass-forget-test-3 new ] must-fail
-
-[ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
-
-[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval( -- ) ] unit-test
-
-[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
-
 ! Insufficient type checking
 [ \ vocab tuple>array drop ] must-fail
 
@@ -784,3 +732,25 @@ TUPLE: code-heap-ref ;
 ! Data heap reference
 [ t ] [ \ code-heap-ref' def>> first code-heap-ref? ] unit-test
 [ 5 ] [ \ code-heap-ref' def>> first x>> ] unit-test
+
+! If the metaclass of a superclass changes into something other
+! than a tuple class, the tuple needs to have its superclass reset
+TUPLE: metaclass-change ;
+TUPLE: metaclass-change-subclass < metaclass-change ;
+
+[ metaclass-change ] [ metaclass-change-subclass superclass ] unit-test
+
+[ ] [ "IN: classes.tuple.tests MIXIN: metaclass-change" eval( -- ) ] unit-test
+
+[ t ] [ metaclass-change-subclass tuple-class? ] unit-test
+[ tuple ] [ metaclass-change-subclass superclass ] unit-test
+
+! Reshaping bug related to the above
+TUPLE: a-g ;
+TUPLE: g < a-g ;
+
+[ ] [ g new "g" set ] unit-test
+
+[ ] [ "IN: classes.tuple.tests MIXIN: a-g TUPLE: g ;" eval( -- ) ] unit-test
+
+[ t ] [ g new layout-of "g" get layout-of eq? ] unit-test

core/classes/tuple/tuple.factor

@@ -13,9 +13,6 @@ PREDICATE: tuple-class < class
 
 ERROR: not-a-tuple object ;
 
-: check-tuple ( object -- tuple )
-    dup tuple? [ not-a-tuple ] unless ; inline
-
 : all-slots ( class -- slots )
     superclasses [ "slots" word-prop ] map concat ;
 
@@ -35,6 +32,9 @@ M: tuple class layout-of 2 slot { word } declare ; inline
 : tuple-size ( tuple -- size )
     layout-of 3 slot { fixnum } declare ; inline
 
+: check-tuple ( object -- tuple )
+    dup tuple? [ not-a-tuple ] unless ; inline
+
 : prepare-tuple>array ( tuple -- n tuple layout )
     check-tuple [ tuple-size iota ] [ ] [ layout-of ] tri ;
 
@@ -49,14 +49,14 @@ M: tuple class layout-of 2 slot { word } declare ; inline
         ] 2each
     ] if-bootstrapping ; inline
 
-PRIVATE>
-
 : initial-values ( class -- slots )
     all-slots [ initial>> ] map ;
 
 : pad-slots ( slots class -- slots' class )
     [ initial-values over length tail append ] keep ; inline
 
+PRIVATE>
+
 : tuple>array ( tuple -- array )
     prepare-tuple>array
     [ copy-tuple-slots ] dip
@@ -247,6 +247,9 @@ M: class valid-superclass? drop f ;
 
 GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
 
+: thrower-effect ( slots -- effect )
+    [ name>> ] map { "*" } <effect> ;
+
 PRIVATE>
 
 : define-tuple-class ( class superclass slots -- )
@@ -261,9 +264,6 @@ M: tuple-class (define-tuple-class)
     3dup tuple-class-unchanged?
     [ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
 
-: thrower-effect ( slots -- effect )
-    [ name>> ] map { "*" } <effect> ;
-
 : define-error-class ( class superclass slots -- )
     [ define-tuple-class ]
     [ 2drop reset-generic ]
@@ -293,6 +293,11 @@ M: tuple-class reset-class
         bi
     ] bi ;
 
+M: tuple-class metaclass-changed
+    ! Our superclass is no longer a tuple class, redefine with
+    ! default superclass
+    nip tuple over "slots" word-prop define-tuple-class ;
+
 M: tuple-class rank-class drop 0 ;
 
 M: tuple-class instance?

core/compiler/units/units.factor

@@ -1,10 +1,9 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel continuations assocs namespaces
-sequences words vocabs definitions hashtables init sets
+sequences words vocabs definitions hashtables init sets math
-math math.order classes classes.algebra classes.tuple
+math.order classes classes.private classes.algebra classes.tuple
-classes.tuple.private generic source-files.errors
+classes.tuple.private generic source-files.errors kernel.private ;
-kernel.private ;
 IN: compiler.units
 
 SYMBOL: old-definitions

core/generic/generic-docs.factor

@@ -163,10 +163,6 @@ HELP: create-method
 { $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." }
 { $notes "To define a method, pass the output value to " { $link define } "." } ;
 
-HELP: forget-methods
-{ $values { "class" class } }
-{ $description "Remove all method definitions which specialize on the class." } ;
-
 { sort-classes order } related-words
 
 HELP: (call-next-method)