From 8fde3fb914f178fbe6c2e48077a947640e98a6dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 18:50:21 -0500 Subject: [PATCH] More inheritance debugging --- core/bootstrap/image/image.factor | 1 + core/bootstrap/primitives.factor | 100 ++++++++++-------- core/bootstrap/stage1.factor | 1 - core/classes/algebra/algebra.factor | 10 +- core/classes/classes.factor | 10 +- core/classes/tuple/tuple-tests.factor | 4 +- core/generic/generic-docs.factor | 7 +- core/generic/generic-tests.factor | 31 ------ core/generic/generic.factor | 43 ++++---- core/generic/math/math.factor | 4 +- .../engines/predicate/predicate.factor | 4 + core/generic/standard/engines/tag/tag.factor | 32 ++++-- .../standard/engines/tuple/tuple.factor | 37 +++++-- core/generic/standard/standard.factor | 39 +++---- core/kernel/kernel.factor | 2 +- core/words/words.factor | 5 +- 16 files changed, 174 insertions(+), 156 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index fc963683b6..f0d9b77981 100755 --- a/core/bootstrap/image/image.factor +++ b/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 ( -- ) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 48a1117574..6c4462ed98 100755 --- a/core/bootstrap/primitives.factor +++ b/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 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 - { - [ register-builtin ] - [ f f builtin-class define-class ] - [ define-builtin-predicate ] - [ ] - } cleave + >r [ define-builtin-predicate ] keep r> define-builtin-slots ; -! Forward definitions -"object" "kernel" create t "class" set-word-prop -"object" "kernel" create union-class "metaclass" set-word-prop +"fixnum" "math" create register-builtin +"bignum" "math" create register-builtin +"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,23 +358,25 @@ define-builtin } } define-builtin -"tuple" "kernel" create { } define-builtin - -"tuple" "kernel" lookup -{ - { - { "object" "kernel" } - "delegate" - { "delegate" "kernel" } - { "set-delegate" "kernel" } - } -} -[ drop ] [ generate-tuple-slots ] 2bi -[ [ name>> ] map "slot-names" set-word-prop ] -[ "slots" set-word-prop ] -[ define-slots ] 2tri - -"tuple" "kernel" lookup define-tuple-layout +"tuple" "kernel" create { + [ { } define-builtin ] + [ { "delegate" } "slot-names" set-word-prop ] + [ define-tuple-layout ] + [ + { + { + { "object" "kernel" } + "delegate" + { "delegate" "kernel" } + { "set-delegate" "kernel" } + } + } + [ drop ] [ generate-tuple-slots ] 2bi + [ "slots" set-word-prop ] + [ define-slots ] + 2bi + ] +} 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 - -! 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 +"general-t?" "kernel" vocab-words delete-at ! Create special tombstone values "tombstone" "hashtables.private" create diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 34f758c9df..f99c8eb82f 100755 --- a/core/bootstrap/stage1.factor +++ b/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 ] % diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 5d7c114cbc..97309dbea2 100755 --- a/core/classes/algebra/algebra.factor +++ b/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 : 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 : class-tags ( class -- tag/f ) class-types [ dup num-tags get >= - [ drop object tag-number ] when + [ drop \ hi-tag tag-number ] when ] map prune ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 914e070e03..0baf235edb 100755 --- a/core/classes/classes.factor +++ b/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 ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 228de8aabf..ff34c25416 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/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 + +"a" "b" "test" set : test-a/b [ "a" ] [ "test" get a>> ] unit-test diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 100475455a..04252b6b3b 100755 --- a/core/generic/generic-docs.factor +++ b/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: { $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 diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 6a7f8f29fc..fd313d8165 100755 --- a/core/generic/generic-tests.factor +++ b/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 diff --git a/core/generic/generic.factor b/core/generic/generic.factor index dc98883654..2ec285146e 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -25,8 +25,9 @@ PREDICATE: generic < word M: generic definition drop f ; : make-generic ( word -- ) - dup { "unannotated-def" } reset-props - dup dup "combination" word-prop perform-combination define ; + [ { "unannotated-def" } reset-props ] + [ 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 - t "forgotten" set-word-prop + [ + [ "method-class" 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 - dup update-map- - forget-word ; + [ forget-methods ] + [ update-map- ] + [ 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 ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 85bd736139..2fda2c9621 100755 --- a/core/generic/math/math.factor +++ b/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? ; diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor index 2d43a313f0..ce7d5c6c21 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -21,6 +21,10 @@ C: 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 diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index 3dd8b83579..6344bec536 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/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 -TUPLE: hi-tag-dispatch-engine methods ; - -C: hi-tag-dispatch-engine - -: convert-hi-tag-methods ( assoc -- assoc' ) - \ hi-tag \ convert-methods ; - : direct-dispatch-quot ( alist n -- quot ) default get [ 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 + +: convert-hi-tag-methods ( assoc -- assoc' ) + \ hi-tag bootstrap-word + \ 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 diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index ce0f50337d..510d5ef732 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/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 ; : ( methods -- engine ) echelon-sort - [ dupd ] assoc-map + [ + over zero? [ + dup assoc-empty? + [ drop f ] [ values first ] if + ] [ + dupd + ] if + ] assoc-map [ nip ] assoc-subset \ tuple-dispatch-engine construct-boa ; : convert-tuple-methods ( assoc -- assoc' ) - tuple \ convert-methods ; + tuple bootstrap-word + \ 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 [ ] 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 ; + : ( engine -- word ) tuple-dispatch-engine-word-name f - [ t "tuple-dispatch-engine" set-word-prop ] - [ generic get "tuple-dispatch-generic" set-word-prop ] - [ ] - tri ; + { + [ t "tuple-dispatch-engine" set-word-prop ] + [ generic get "tuple-dispatch-generic" set-word-prop ] + [ remember-engine ] + [ ] + } cleave ; : define-tuple-dispatch-engine-word ( engine quot -- word ) >r 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 ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 1de41f24ed..0d29bdecd5 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -59,29 +59,32 @@ 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 - [ generic set ] - [ - "methods" word-prop - [ generic get mangle-method ] assoc-map - [ find-default default set ] + object bootstrap-word assumed set { + [ generic set ] + [ "engines" word-prop forget-all ] + [ V{ } clone "engines" set-word-prop ] [ - generic get "inline" word-prop [ - - ] [ - - ] if - ] bi - engine>quot - ] bi + "methods" word-prop + [ generic get mangle-method ] assoc-map + [ find-default default set ] + [ + generic get "inline" word-prop [ + + ] [ + + ] if + ] bi + engine>quot + ] + } 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 ) diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index eed5b22e5f..ae775ec116 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -194,7 +194,7 @@ GENERIC: construct-boa ( ... class -- tuple )