More inheritance debugging

core/bootstrap/image/image.factor

@@ -444,6 +444,7 @@ PRIVATE>
         "resource:/core/bootstrap/stage1.factor" run-file
         build-image
         write-image
+        \ word-props target-word
     ] with-scope ;
 
 : make-images ( -- )

core/bootstrap/primitives.factor

@@ -31,6 +31,7 @@ crossref off
 "syntax" vocab vocab-words bootstrap-syntax set
 H{ } clone dictionary set
 H{ } clone changed-words set
+H{ } clone forgotten-definitions set
 H{ } clone root-cache set
 H{ } clone source-files set
 H{ } clone update-map set
@@ -126,27 +127,49 @@ num-types get f <array> builtins set
 : register-builtin ( class -- )
     [ dup lookup-type-number "type" set-word-prop ]
     [ dup "type" word-prop builtins get set-nth ]
-    bi ;
+    [ f f builtin-class define-class ]
+    tri ;
 
 : define-builtin-slots ( symbol slotspec -- )
     [ drop ] [ 1 simple-slots ] 2bi
     [ "slots" set-word-prop ] [ define-slots ] 2bi ;
 
 : define-builtin ( symbol slotspec -- )
-    >r
+    >r [ define-builtin-predicate ] keep
-    {
-        [ register-builtin ]
-        [ f f builtin-class define-class ]
-        [ define-builtin-predicate ]
-        [ ]
-    } cleave
     r> define-builtin-slots ;
 
-! Forward definitions
+"fixnum" "math" create register-builtin
-"object" "kernel" create t "class" set-word-prop
+"bignum" "math" create register-builtin
-"object" "kernel" create union-class "metaclass" set-word-prop
+"tuple" "kernel" create register-builtin
+"ratio" "math" create register-builtin
+"float" "math" create register-builtin
+"complex" "math" create register-builtin
+"f" "syntax" lookup register-builtin
+"array" "arrays" create register-builtin
+"wrapper" "kernel" create register-builtin
+"float-array" "float-arrays" create register-builtin
+"callstack" "kernel" create register-builtin
+"string" "strings" create register-builtin
+"bit-array" "bit-arrays" create register-builtin
+"quotation" "quotations" create register-builtin
+"dll" "alien" create register-builtin
+"alien" "alien" create register-builtin
+"word" "words" create register-builtin
+"byte-array" "byte-arrays" create register-builtin
+"tuple-layout" "classes.tuple.private" create register-builtin
 
-"null" "kernel" create drop
+! Catch-all class for providing a default method.
+"object" "kernel" create [ drop t ] "predicate" set-word-prop
+"object" "kernel" create
+f builtins get [ ] subset union-class define-class
+
+! Class of objects with object tag
+"hi-tag" "kernel.private" create
+f builtins get num-tags get tail union-class define-class
+
+! Empty class with no instances
+"null" "kernel" create [ drop f ] "predicate" set-word-prop
+"null" "kernel" create f { } union-class define-class
 
 "fixnum" "math" create { } define-builtin
 "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
@@ -335,9 +358,11 @@ define-builtin
     }
 } define-builtin
 
-"tuple" "kernel" create { } define-builtin
+"tuple" "kernel" create {
-
+    [ { } define-builtin ]
-"tuple" "kernel" lookup
+    [ { "delegate" } "slot-names" set-word-prop ]
+    [ define-tuple-layout ]
+    [
         {
             {
                 { "object" "kernel" }
@@ -347,11 +372,11 @@ define-builtin
             }
         }
         [ drop ] [ generate-tuple-slots ] 2bi
-[ [ name>> ] map "slot-names" set-word-prop ]
         [ "slots" set-word-prop ]
-[ define-slots ] 2tri
+        [ define-slots ]
-
+        2bi
-"tuple" "kernel" lookup define-tuple-layout
+    ]
+} cleave
 
 ! Define general-t type, which is any object that is not f.
 "general-t" "kernel" create
@@ -359,23 +384,10 @@ f "f" "syntax" lookup builtins get remove [ ] subset union-class
 define-class
 
 "f" "syntax" create [ not ] "predicate" set-word-prop
-"f?" "syntax" create "syntax" vocab-words delete-at
+"f?" "syntax" vocab-words delete-at
 
 "general-t" "kernel" create [ ] "predicate" set-word-prop
-"general-t?" "kernel" create "syntax" vocab-words delete-at
+"general-t?" "kernel" vocab-words delete-at
-
-! Catch-all class for providing a default method.
-"object" "kernel" create [ drop t ] "predicate" set-word-prop
-"object" "kernel" create
-f builtins get [ ] subset union-class define-class
-
-! Class of objects with object tag
-"hi-tag" "kernel.private" create
-f builtins get num-tags get tail union-class define-class
-
-! Null class with no instances.
-"null" "kernel" create [ drop f ] "predicate" set-word-prop
-"null" "kernel" create f { } union-class define-class
 
 ! Create special tombstone values
 "tombstone" "hashtables.private" create

core/bootstrap/stage1.factor

@@ -19,7 +19,6 @@ vocabs.loader system debugger continuations ;
         ! Rehash hashtables, since bootstrap.image creates them
         ! using the host image's hashing algorithms
         [ hashtable? ] instances [ rehash ] each
-
         boot
     ] %
 

core/classes/algebra/algebra.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel classes combinators accessors sequences arrays
 vectors assocs namespaces words sorting layouts math hashtables
-;
+kernel.private ;
 IN: classes.algebra
 
 : 2cache ( key1 key2 assoc quot -- value )
@@ -211,12 +211,6 @@ C: <anonymous-complement> anonymous-complement
 : flatten-class ( class -- assoc )
     [ (flatten-class) ] H{ } make-assoc ;
 
-: class-hashes ( class -- seq )
-    flatten-class keys [
-        dup builtin-class?
-        [ "type" word-prop ] [ hashcode ] if
-    ] map ;
-
 : flatten-builtin-class ( class -- assoc )
     flatten-class [
         dup tuple class< [ 2drop tuple tuple ] when
@@ -229,5 +223,5 @@ C: <anonymous-complement> anonymous-complement
 : class-tags ( class -- tag/f )
     class-types [
         dup num-tags get >=
-        [ drop object tag-number ] when
+        [ drop \ hi-tag tag-number ] when
     ] map prune ;

core/classes/classes.factor

@@ -25,9 +25,11 @@ SYMBOL: class-or-cache
     class-and-cache get clear-assoc
     class-or-cache get clear-assoc ;
 
-PREDICATE: class < word ( obj -- ? ) "class" word-prop ;
-
 SYMBOL: update-map
+
+PREDICATE: class < word
+    "class" word-prop ;
+
 SYMBOL: builtins
 
 PREDICATE: builtin-class < class
@@ -58,7 +60,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
     dup class? [ "superclass" word-prop ] [ drop f ] if ;
 
 : superclasses ( class -- supers )
-    [ dup ] [ dup superclass swap ] [ ] unfold reverse nip ;
+    [ dup ] [ [ superclass ] keep ] [ ] unfold nip reverse ;
 
 : members ( class -- seq )
     #! Output f for non-classes to work with algebra code
@@ -72,7 +74,7 @@ M: word reset-class drop ;
 
 ! update-map
 : class-uses ( class -- seq )
-    dup members swap superclass [ suffix ] when* ;
+    [ members ] [ superclass ] bi [ suffix ] when* ;
 
 : class-usages ( class -- assoc )
     [ update-map get at ] closure ;

core/classes/tuple/tuple-tests.factor

@@ -394,7 +394,9 @@ test-server-slot-values
 ! Reshape crash
 TUPLE: test1 a ; TUPLE: test2 < test1 b ;
 
-T{ test2 f "a" "b" } "test" set
+C: <test2> test2
+
+"a" "b" <test2> "test" set
 
 : test-a/b
     [ "a" ] [ "test" get a>> ] unit-test

core/generic/generic-docs.factor

@@ -37,7 +37,6 @@ $nl
 { $subsection create-method }
 "Method definitions can be looked up:"
 { $subsection method }
-{ $subsection methods }
 "A generic word contains methods; the list of methods specializing on a class can also be obtained:"
 { $subsection implementors }
 "Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
@@ -120,10 +119,6 @@ HELP: <method>
 { $values { "class" class } { "generic" generic } { "method" "a new method definition" } }
 { $description "Creates a new method." } ;
 
-HELP: methods
-{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
-{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
-
 HELP: order
 { $values { "generic" generic } { "seq" "a sequence of classes" } }
 { $description "Outputs a sequence of classes for which methods have been defined on this generic word. The sequence is sorted in method dispatch order." } ;
@@ -151,4 +146,4 @@ HELP: forget-methods
 { $values { "class" class } }
 { $description "Remove all method definitions which specialize on the class." } ;
 
-{ sort-classes methods order } related-words
+{ sort-classes order } related-words

core/generic/generic-tests.factor

@@ -171,37 +171,6 @@ M: f tag-and-f 4 ;
 
 [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
 
-! define-class hashing issue
-TUPLE: debug-combination ;
-
-M: debug-combination make-default-method
-    2drop [ "Oops" throw ] ;
-
-M: debug-combination perform-combination
-    drop
-    order [ dup class-hashes ] { } map>assoc sort-keys
-    1quotation ;
-
-SYMBOL: redefinition-test-generic
-
-[
-    redefinition-test-generic
-    T{ debug-combination }
-    define-generic
-] with-compilation-unit
-
-TUPLE: redefinition-test-tuple ;
-
-"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval
-
-[ t ] [
-    [
-        redefinition-test-generic ,
-        "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval
-        redefinition-test-generic ,
-    ] { } make all-equal?
-] unit-test
-
 ! Issues with forget
 GENERIC: generic-forget-test-1
 

core/generic/generic.factor

@@ -25,8 +25,9 @@ PREDICATE: generic < word
 M: generic definition drop f ;
 
 : make-generic ( word -- )
-    dup { "unannotated-def" } reset-props
+    [ { "unannotated-def" } reset-props ]
-    dup dup "combination" word-prop perform-combination define ;
+    [ dup "combination" word-prop perform-combination ]
+    bi ;
 
 : method ( class generic -- method/f )
     "methods" word-prop at ;
@@ -37,13 +38,6 @@ PREDICATE: method-spec < pair
 : order ( generic -- seq )
     "methods" word-prop keys sort-classes ;
 
-: sort-methods ( assoc -- assoc' )
-    [ keys sort-classes ]
-    [ [ dupd at ] curry ] bi { } map>assoc ;
-
-: methods ( word -- assoc )
-    "methods" word-prop sort-methods ;
-
 TUPLE: check-method class generic ;
 
 : check-method ( class generic -- class generic )
@@ -64,6 +58,9 @@ PREDICATE: method-body < word
 M: method-body stack-effect
     "method-generic" word-prop stack-effect ;
 
+M: method-body crossref?
+    drop t ;
+
 : method-word-props ( class generic -- assoc )
     [
         "method-generic" set
@@ -122,9 +119,12 @@ M: method-body definer
 
 M: method-body forget*
     dup "forgotten" word-prop [ drop ] [
-        dup "method-class" word-prop
+        [
-        over "method-generic" word-prop forget-method
+            [  "method-class" word-prop ]
-        t "forgotten" set-word-prop
+            [ "method-generic" word-prop ] bi
+            forget-method
+        ]
+        [ t "forgotten" set-word-prop ] bi
     ] if ;
 
 : implementors* ( classes -- words )
@@ -137,12 +137,13 @@ M: method-body forget*
     dup associate implementors* ;
 
 : forget-methods ( class -- )
-    [ implementors ] keep [ swap 2array ] curry map forget-all ;
+    [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
 
 M: class forget* ( class -- )
-    dup forget-methods
+    [ forget-methods ]
-    dup update-map-
+    [ update-map- ]
-    forget-word ;
+    [ forget-word ]
+    tri ;
 
 M: assoc update-methods ( assoc -- )
     implementors* [ make-generic ] each ;
@@ -158,11 +159,15 @@ M: assoc update-methods ( assoc -- )
     ] if ;
 
 M: generic subwords
-    dup "methods" word-prop values
+    [
-    swap "default-method" word-prop suffix ;
+        [ "default-method" word-prop , ]
+        [ "methods" word-prop values % ]
+        [ "engines" word-prop % ]
+        tri
+    ] { } make ;
 
 M: generic forget-word
-    dup subwords [ forget ] each (forget-word) ;
+    [ subwords forget-all ] [ (forget-word) ] bi ;
 
 : xref-generics ( -- )
     all-words [ subwords [ xref ] each ] each ;

core/generic/math/math.factor

@@ -71,13 +71,15 @@ M: math-combination make-default-method
 
 M: math-combination perform-combination
     drop
+    dup
     \ over [
         dup math-class? [
             \ dup [ >r 2dup r> math-method ] math-vtable
         ] [
             over object-method
         ] if nip
-    ] math-vtable nip ;
+    ] math-vtable nip
+    define ;
 
 PREDICATE: math-generic < generic ( word -- ? )
     "combination" word-prop math-combination? ;

core/generic/standard/engines/predicate/predicate.factor

@@ -21,6 +21,10 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
         { [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
     } cond ;
 
+: sort-methods ( assoc -- assoc' )
+    [ keys sort-classes ]
+    [ [ dupd at ] curry ] bi { } map>assoc ;
+
 M: predicate-dispatch-engine engine>quot
     methods>> clone
     default get object bootstrap-word pick set-at engines>quots

core/generic/standard/engines/tag/tag.factor

@@ -1,26 +1,27 @@
 USING: classes.private generic.standard.engines namespaces
 arrays assocs sequences.private quotations kernel.private
-layouts math slots.private math.private kernel accessors ;
+math slots.private math.private kernel accessors words
+layouts ;
 IN: generic.standard.engines.tag
 
 TUPLE: lo-tag-dispatch-engine methods ;
 
 C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
 
-TUPLE: hi-tag-dispatch-engine methods ;
-
-C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
-
-: convert-hi-tag-methods ( assoc -- assoc' )
-    \ hi-tag \ <hi-tag-dispatch-engine> convert-methods ;
-
 : direct-dispatch-quot ( alist n -- quot )
     default get <array>
     [ <enum> swap update ] keep
     [ dispatch ] curry >quotation ;
 
+: lo-tag-number ( class -- n )
+     dup \ hi-tag bootstrap-word eq? [
+        drop \ hi-tag tag-number
+    ] [
+        "type" word-prop
+    ] if ;
+
 M: lo-tag-dispatch-engine engine>quot
-    methods>> engines>quots* [ >r tag-number r> ] assoc-map
+    methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map
     [
         picker % [ tag ] % [
             linear-dispatch-quot
@@ -29,12 +30,21 @@ M: lo-tag-dispatch-engine engine>quot
         ] if-small? %
     ] [ ] make ;
 
+TUPLE: hi-tag-dispatch-engine methods ;
+
+C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
+
+: convert-hi-tag-methods ( assoc -- assoc' )
+    \ hi-tag bootstrap-word
+    \ <hi-tag-dispatch-engine> convert-methods ;
+
 : num-hi-tags num-types get num-tags get - ;
 
-: hi-tag-number type-number num-tags get - ;
+: hi-tag-number ( class -- n )
+    "type" word-prop num-tags get - ;
 
 : hi-tag-quot ( -- quot )
-    [ 0 slot ] num-tags get [ fixnum- ] curry compose ;
+    [ hi-tag ] num-tags get [ fixnum-fast ] curry compose ;
 
 M: hi-tag-dispatch-engine engine>quot
     methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map

core/generic/standard/engines/tuple/tuple.factor

@@ -2,7 +2,7 @@ IN: generic.standard.engines.tuple
 USING: kernel classes.tuple.private hashtables assocs sorting
 accessors combinators sequences slots.private math.parser words
 effects namespaces generic generic.standard.engines
-classes.algebra math math.private quotations ;
+classes.algebra math math.private quotations arrays ;
 
 TUPLE: echelon-dispatch-engine n methods ;
 
@@ -27,17 +27,25 @@ TUPLE: tuple-dispatch-engine echelons ;
 
 : <tuple-dispatch-engine> ( methods -- engine )
     echelon-sort
-    [ dupd <echelon-dispatch-engine> ] assoc-map
+    [
+        over zero? [
+            dup assoc-empty?
+            [ drop f ] [ values first ] if
+        ] [
+            dupd <echelon-dispatch-engine>
+        ] if
+    ] assoc-map [ nip ] assoc-subset
     \ tuple-dispatch-engine construct-boa ;
 
 : convert-tuple-methods ( assoc -- assoc' )
-    tuple \ <tuple-dispatch-engine> convert-methods ;
+    tuple bootstrap-word
+    \ <tuple-dispatch-engine> convert-methods ;
 
 M: trivial-tuple-dispatch-engine engine>quot
     methods>> engines>quots* linear-dispatch-quot ;
 
 : hash-methods ( methods -- buckets )
-    >alist V{ } clone [ class-hashes ] distribute-buckets
+    >alist V{ } clone [ hashcode 1array ] distribute-buckets
     [ <trivial-tuple-dispatch-engine> ] map ;
 
 : class-hash-dispatch-quot ( methods -- quot )
@@ -60,12 +68,20 @@ PREDICATE: tuple-dispatch-engine-word < word
 M: tuple-dispatch-engine-word stack-effect
     "tuple-dispatch-generic" word-prop stack-effect ;
 
+M: tuple-dispatch-engine-word crossref?
+    drop t ;
+
+: remember-engine ( word -- )
+    generic get "engines" word-prop push ;
+
 : <tuple-dispatch-engine-word> ( engine -- word )
     tuple-dispatch-engine-word-name f <word>
+    {
         [ t "tuple-dispatch-engine" set-word-prop ]
         [ generic get "tuple-dispatch-generic" set-word-prop ]
+        [ remember-engine ]
         [ ]
-    tri ;
+    } cleave ;
 
 : define-tuple-dispatch-engine-word ( engine quot -- word )
     >r <tuple-dispatch-engine-word> dup r> define ;
@@ -104,6 +120,9 @@ M: tuple-dispatch-engine engine>quot
         picker %
         [ 1 slot 5 slot ] %
         echelons>>
-        [ [ engine>quot dup default set ] assoc-map ] with-scope
+        [
+            tuple assumed set
+            [ engine>quot dup default set ] assoc-map
+        ] with-scope
         >=-case-quot %
     ] [ ] make ;

core/generic/standard/standard.factor

@@ -59,16 +59,18 @@ ERROR: no-method object generic ;
 
 : find-default ( methods -- quot )
     #! Side-effects methods.
-    object swap delete-at* [
+    object bootstrap-word swap delete-at* [
         drop generic get "default-method" word-prop 1quotation
     ] unless ;
 
 GENERIC: mangle-method ( method generic -- quot )
 
-: single-combination ( words -- quot )
+: single-combination ( word -- quot )
     [
-        object bootstrap-word assumed set
+        object bootstrap-word assumed set {
             [ generic set ]
+            [ "engines" word-prop forget-all ]
+            [ V{ } clone "engines" set-word-prop ]
             [
                 "methods" word-prop
                 [ generic get mangle-method ] assoc-map
@@ -81,7 +83,8 @@ GENERIC: mangle-method ( method generic -- quot )
                     ] if
                 ] bi
                 engine>quot
-        ] bi
+            ]
+        } cleave
     ] with-scope ;
 
 TUPLE: standard-combination # ;
@@ -107,7 +110,7 @@ M: standard-combination make-default-method
     [ empty-method ] with-standard ;
 
 M: standard-combination perform-combination
-    [ single-combination ] with-standard ;
+    [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
 
 TUPLE: hook-combination var ;
 
@@ -128,7 +131,7 @@ M: hook-combination make-default-method
     [ error-method ] with-hook ;
 
 M: hook-combination perform-combination
-    [ single-combination ] with-hook ;
+    [ drop ] [ [ single-combination ] with-hook ] 2bi define ;
 
 GENERIC: dispatch# ( word -- n )
 

core/kernel/kernel.factor

@@ -194,7 +194,7 @@ GENERIC: construct-boa ( ... class -- tuple )
 
 <PRIVATE
 
-: hi-tag ( obj -- n ) 0 slot ;
+: hi-tag ( obj -- n ) 0 slot ; inline
 
 : declare ( spec -- ) drop ;
 

core/words/words.factor

@@ -63,10 +63,11 @@ SYMBOL: bootstrapping?
 : bootstrap-word ( word -- target )
     [ target-word ] [ ] if-bootstrapping ;
 
-: crossref? ( word -- ? )
+GENERIC: crossref? ( word -- ? )
+
+M: word crossref?
     {
         { [ dup "forgotten" word-prop ] [ f ] }
-        { [ dup "method-generic" word-prop ] [ t ] }
         { [ dup word-vocabulary ] [ t ] }
         { [ t ] [ f ] }
     } cond nip ;