More inheritance debugging
Slava Pestov
parent
7a596ce004
commit
8fde3fb914
|
|
@ -444,6 +444,7 @@ PRIVATE>
|
|||
"resource:/core/bootstrap/stage1.factor" run-file
|
||||
build-image
|
||||
write-image
|
||||
\ word-props target-word
|
||||
] with-scope ;
|
||||
|
||||
: make-images ( -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
{
|
||||
[ 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
] %
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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? ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
[ ]
|
||||
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 <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 ;
|
||||
|
|
|
|||
|
|
@ -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 [
|
||||
<predicate-dispatch-engine>
|
||||
] [
|
||||
<big-dispatch-engine>
|
||||
] if
|
||||
] bi
|
||||
engine>quot
|
||||
] bi
|
||||
"methods" word-prop
|
||||
[ generic get mangle-method ] assoc-map
|
||||
[ find-default default set ]
|
||||
[
|
||||
generic get "inline" word-prop [
|
||||
<predicate-dispatch-engine>
|
||||
] [
|
||||
<big-dispatch-engine>
|
||||
] 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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue