Getting ready to drop in new dispatch code

db4
Slava Pestov 2008-04-02 00:45:30 -05:00
parent fa8b578370
commit f96a43c42d
4 changed files with 9 additions and 3 deletions

View File

@ -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<

View File

@ -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>

View File

@ -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 ;

View File

@ -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.