Faster call-next-method
parent
1cf1d967ea
commit
34952ff5c4
|
@ -417,7 +417,7 @@ M: quotation '
|
||||||
} [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
|
} [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
|
||||||
{
|
{
|
||||||
class<=-cache class-not-cache classes-intersect-cache
|
class<=-cache class-not-cache classes-intersect-cache
|
||||||
class-and-cache class-or-cache
|
class-and-cache class-or-cache next-method-quot-cache
|
||||||
} [ H{ } clone ] H{ } map>assoc assoc-union
|
} [ H{ } clone ] H{ } map>assoc assoc-union
|
||||||
bootstrap-global set
|
bootstrap-global set
|
||||||
bootstrap-global emit-userenv ;
|
bootstrap-global emit-userenv ;
|
||||||
|
|
|
@ -10,20 +10,23 @@ SYMBOL: class-not-cache
|
||||||
SYMBOL: classes-intersect-cache
|
SYMBOL: classes-intersect-cache
|
||||||
SYMBOL: class-and-cache
|
SYMBOL: class-and-cache
|
||||||
SYMBOL: class-or-cache
|
SYMBOL: class-or-cache
|
||||||
|
SYMBOL: next-method-quot-cache
|
||||||
|
|
||||||
: init-caches ( -- )
|
: init-caches ( -- )
|
||||||
H{ } clone class<=-cache set
|
H{ } clone class<=-cache set
|
||||||
H{ } clone class-not-cache set
|
H{ } clone class-not-cache set
|
||||||
H{ } clone classes-intersect-cache set
|
H{ } clone classes-intersect-cache set
|
||||||
H{ } clone class-and-cache set
|
H{ } clone class-and-cache set
|
||||||
H{ } clone class-or-cache set ;
|
H{ } clone class-or-cache set
|
||||||
|
H{ } clone next-method-quot-cache set ;
|
||||||
|
|
||||||
: reset-caches ( -- )
|
: reset-caches ( -- )
|
||||||
class<=-cache get clear-assoc
|
class<=-cache get clear-assoc
|
||||||
class-not-cache get clear-assoc
|
class-not-cache get clear-assoc
|
||||||
classes-intersect-cache get clear-assoc
|
classes-intersect-cache get clear-assoc
|
||||||
class-and-cache get clear-assoc
|
class-and-cache get clear-assoc
|
||||||
class-or-cache get clear-assoc ;
|
class-or-cache get clear-assoc
|
||||||
|
next-method-quot-cache get clear-assoc ;
|
||||||
|
|
||||||
SYMBOL: update-map
|
SYMBOL: update-map
|
||||||
|
|
||||||
|
|
|
@ -45,7 +45,9 @@ GENERIC: effective-method ( generic -- method )
|
||||||
GENERIC: next-method-quot* ( class generic combination -- quot )
|
GENERIC: next-method-quot* ( class generic combination -- quot )
|
||||||
|
|
||||||
: next-method-quot ( class generic -- quot )
|
: next-method-quot ( class generic -- quot )
|
||||||
dup "combination" word-prop next-method-quot* ;
|
next-method-quot-cache get [
|
||||||
|
dup "combination" word-prop next-method-quot*
|
||||||
|
] 2cache ;
|
||||||
|
|
||||||
: (call-next-method) ( class generic -- )
|
: (call-next-method) ( class generic -- )
|
||||||
next-method-quot call ;
|
next-method-quot call ;
|
||||||
|
@ -99,10 +101,11 @@ M: method-body crossref?
|
||||||
2bi ;
|
2bi ;
|
||||||
|
|
||||||
: create-method ( class generic -- method )
|
: create-method ( class generic -- method )
|
||||||
2dup method dup [
|
2dup method dup [ 2nip ] [
|
||||||
2nip
|
drop
|
||||||
] [
|
[ <method> dup ] 2keep
|
||||||
drop [ <method> dup ] 2keep reveal-method
|
reveal-method
|
||||||
|
reset-caches
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
PREDICATE: default-method < word "default" word-prop ;
|
PREDICATE: default-method < word "default" word-prop ;
|
||||||
|
|
Loading…
Reference in New Issue