Getting ready to drop in new dispatch code
parent
fa8b578370
commit
f96a43c42d
|
@ -96,7 +96,7 @@ UNION: z1 b1 c1 ;
|
||||||
|
|
||||||
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
|
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
|
||||||
|
|
||||||
[ f ] [ growable hi-tag classes-intersect? ] unit-test
|
[ f ] [ growable \ hi-tag classes-intersect? ] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
growable tuple sequence class-and class<
|
growable tuple sequence class-and class<
|
||||||
|
|
|
@ -13,7 +13,7 @@ TUPLE: hi-tag-dispatch-engine methods ;
|
||||||
C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
|
C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
|
||||||
|
|
||||||
: convert-hi-tag-methods ( assoc -- assoc' )
|
: convert-hi-tag-methods ( assoc -- assoc' )
|
||||||
hi-tag \ <hi-tag-dispatch-engine> convert-methods ;
|
\ hi-tag \ <hi-tag-dispatch-engine> convert-methods ;
|
||||||
|
|
||||||
: direct-dispatch-quot ( alist n -- quot )
|
: direct-dispatch-quot ( alist n -- quot )
|
||||||
default get <array>
|
default get <array>
|
||||||
|
|
|
@ -100,6 +100,9 @@ PREDICATE: simple-generic < standard-generic
|
||||||
: with-standard ( combination quot -- quot' )
|
: with-standard ( combination quot -- quot' )
|
||||||
>r #>> (dispatch#) r> with-variable ;
|
>r #>> (dispatch#) r> with-variable ;
|
||||||
|
|
||||||
|
M: standard-generic mangle-method
|
||||||
|
drop ;
|
||||||
|
|
||||||
M: standard-combination make-default-method
|
M: standard-combination make-default-method
|
||||||
[ empty-method ] with-standard ;
|
[ empty-method ] with-standard ;
|
||||||
|
|
||||||
|
@ -118,6 +121,9 @@ PREDICATE: hook-generic < generic
|
||||||
dip var>> [ get ] curry prepend
|
dip var>> [ get ] curry prepend
|
||||||
] with-variable ; inline
|
] with-variable ; inline
|
||||||
|
|
||||||
|
M: hook-generic mangle-method
|
||||||
|
drop [ drop ] prepend ;
|
||||||
|
|
||||||
M: hook-combination make-default-method
|
M: hook-combination make-default-method
|
||||||
[ error-method ] with-hook ;
|
[ error-method ] with-hook ;
|
||||||
|
|
||||||
|
|
|
@ -77,7 +77,7 @@ ERROR: no-method object generic ;
|
||||||
[ small-generic ] picker class-hash-dispatch-quot ;
|
[ small-generic ] picker class-hash-dispatch-quot ;
|
||||||
|
|
||||||
: vtable-class ( n -- class )
|
: vtable-class ( n -- class )
|
||||||
bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
|
bootstrap-type>class [ \ hi-tag bootstrap-word ] unless* ;
|
||||||
|
|
||||||
: group-methods ( assoc -- vtable )
|
: group-methods ( assoc -- vtable )
|
||||||
#! Input is a predicate -> method association.
|
#! Input is a predicate -> method association.
|
||||||
|
|
Loading…
Reference in New Issue