standard-combination now takes a dispatch position not a picker
slava
parent
2691f48493
commit
e55a401791
|
|
@ -62,7 +62,7 @@ ARTICLE: "method-combination" "Method combination"
|
|||
"which methods out of the set of applicable methods are called"
|
||||
}
|
||||
"The " { $link POSTPONE: GENERIC: } " parsing word creates a generic word using the " { $emphasis "simple method combination" } ". Most generic words that come up in practice use this method combination:"
|
||||
{ $subsection simple-combination }
|
||||
{ $subsection standard-combination }
|
||||
"The " { $link POSTPONE: G: } " parsing word allows a different method combination to be specified:"
|
||||
{ $subsection POSTPONE: G: }
|
||||
"The simple method combination is a special case of the standard method combination:"
|
||||
|
|
@ -179,7 +179,7 @@ GLOSSARY: "delegate" "an object acting as a sink for unhandled method calls on b
|
|||
ARTICLE: "tuple-delegation" "Delegation"
|
||||
"Each tuple can have an optional delegate tuple. Most generic words called on the tuple that do not have a method for the tuple's class will be passed on to the delegate."
|
||||
$terpri
|
||||
"More precisely, any generic word using " { $link simple-combination } " delegates, and this includes all generic words defined via the " { $link POSTPONE: GENERIC: } " parsing word."
|
||||
"More precisely, any generic word using " { $link standard-combination } " delegates, and this includes all generic words defined via the " { $link POSTPONE: GENERIC: } " parsing word."
|
||||
$terpri
|
||||
"Factor uses delegation in place of implementation inheritance, but it is not a direct substitute; in particular, the semantics differ in that a delegated method call receives the delegate on the stack, not the original object."
|
||||
{ $warning "Delegation to objects that are not tuples is not fully supported. Generic words support delegation to arbitrary types, as do slot accessors which are built from generic words. However, type-specific primitives do not." }
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ vectors ;
|
|||
IN: sequences
|
||||
|
||||
G: each ( seq quot -- | quot: elt -- )
|
||||
[ over ] standard-combination ; inline
|
||||
1 standard-combination ; inline
|
||||
|
||||
M: object each ( seq quot -- )
|
||||
swap dup length [
|
||||
|
|
@ -54,12 +54,12 @@ M: object each ( seq quot -- )
|
|||
swapd each ; inline
|
||||
|
||||
G: find ( seq quot -- i elt | quot: elt -- ? )
|
||||
[ over ] standard-combination ; inline
|
||||
1 standard-combination ; inline
|
||||
|
||||
: find-with ( obj seq quot -- i elt | quot: elt -- ? )
|
||||
swap [ with rot ] find 2swap 2drop ; inline
|
||||
|
||||
G: map [ over ] standard-combination ; inline
|
||||
G: map 1 standard-combination ; inline
|
||||
|
||||
M: object map ( seq quot -- seq )
|
||||
swap [ dup length [ (map) ] collect ] keep like 2nip ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: sequences
|
|||
USING: generic kernel lists strings sequences-internals ;
|
||||
|
||||
G: tree-each* ( obj quot -- | quot: elt -- )
|
||||
[ over ] standard-combination ; inline
|
||||
1 standard-combination ; inline
|
||||
|
||||
: tree-each ( obj quot -- | quot: elt -- )
|
||||
[ call ] 2keep tree-each* ; inline
|
||||
|
|
|
|||
|
|
@ -158,7 +158,7 @@ USING: compiler errors generic kernel math memory words ;
|
|||
: STH d-form 44 insn ; : STHU d-form 45 insn ;
|
||||
: STW d-form 36 insn ; : STWU d-form 37 insn ;
|
||||
|
||||
G: (B) ( dest aa lk -- ) [ pick ] standard-combination ;
|
||||
G: (B) ( dest aa lk -- ) 2 standard-combination ;
|
||||
M: integer (B) i-form 18 insn ;
|
||||
M: word (B) 0 -rot (B) relative-3 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ USING: generic help ;
|
|||
HELP: define-typecheck "( class generic quot -- )"
|
||||
{ $values { "class" "a class word" } { "generic" "a generic word" } { "quot" "a quotation" } }
|
||||
{ $description
|
||||
"Defines a generic word with the " { $link simple-combination } " and having one method on " { $snippet "class" } "."
|
||||
"Defines a generic word with the " { $link standard-combination } " using dispatch position 0, and having one method on " { $snippet "class" } "."
|
||||
$terpri
|
||||
"This creates a definition analogous to the following code:"
|
||||
{ $code
|
||||
|
|
|
|||
|
|
@ -2,21 +2,26 @@ IN: generic
|
|||
USING: arrays errors hashtables kernel kernel-internals lists
|
||||
math namespaces sequences vectors words ;
|
||||
|
||||
: error-method ( picker word -- method )
|
||||
[ no-method ] curry append ;
|
||||
: picker ( dispatch# -- quot )
|
||||
{ [ dup ] [ over ] [ pick ] } nth ;
|
||||
|
||||
: empty-method ( picker word -- method )
|
||||
over [ dup ] = [
|
||||
[
|
||||
[ dup delegate ] % dup unit , error-method , \ ?if ,
|
||||
] [ ] make
|
||||
] [
|
||||
error-method
|
||||
] if ;
|
||||
: unpicker ( dispatch# -- quot )
|
||||
{ [ nip ] [ >r nip r> swap ] [ >r >r nip r> r> -rot ] } nth ;
|
||||
|
||||
: error-method ( dispatch# word -- method )
|
||||
>r picker r> [ no-method ] curry append ;
|
||||
|
||||
: empty-method ( dispatch# word -- method )
|
||||
[
|
||||
over picker % [ delegate dup ] %
|
||||
over unpicker over add ,
|
||||
[ drop ] -rot error-method append , \ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: class-predicates ( picker assoc -- assoc )
|
||||
[
|
||||
first2 >r "predicate" word-prop append r> 2array
|
||||
first2 >r >r picker r> "predicate" word-prop append
|
||||
r> 2array
|
||||
] map-with ;
|
||||
|
||||
: sort-methods ( assoc n -- vtable )
|
||||
|
|
@ -38,22 +43,22 @@ math namespaces sequences vectors words ;
|
|||
nip car second [ ]
|
||||
] if ;
|
||||
|
||||
: vtable-methods ( picker alist-seq -- alist-seq )
|
||||
: vtable-methods ( dispatch# alist-seq -- alist-seq )
|
||||
dup length [
|
||||
type>class [ swap simplify-alist ] [ car second [ ] ] if*
|
||||
>r over r> class-predicates alist>quot
|
||||
] 2map nip ;
|
||||
|
||||
: <vtable> ( picker word n -- vtable )
|
||||
: <vtable> ( dispatch# word n -- vtable )
|
||||
#! n is vtable size; either num-types or num-tags.
|
||||
>r 2dup empty-method \ object bootstrap-word swap 2array
|
||||
>r methods >list r> swons r> sort-methods vtable-methods ;
|
||||
|
||||
: small-generic ( picker word -- def )
|
||||
: small-generic ( dispatch# word -- def )
|
||||
2dup methods class-predicates >r empty-method r> alist>quot ;
|
||||
|
||||
: big-generic ( picker word n dispatcher -- def )
|
||||
[ >r pick % r> , <vtable> , \ dispatch , ] [ ] make ;
|
||||
: big-generic ( dispatch# word n dispatcher -- def )
|
||||
[ >r pick picker % r> , <vtable> , \ dispatch , ] [ ] make ;
|
||||
|
||||
: tag-generic? ( word -- ? )
|
||||
"methods" word-prop hash-keys [ types ] map concat
|
||||
|
|
@ -62,18 +67,16 @@ math namespaces sequences vectors words ;
|
|||
: small-generic? ( word -- ? )
|
||||
"methods" word-prop hash-size 3 <= ;
|
||||
|
||||
: standard-combination ( word picker -- quot )
|
||||
: standard-combination ( word dispatch# -- quot )
|
||||
swap {
|
||||
{ [ dup tag-generic? ] [ num-tags \ tag big-generic ] }
|
||||
{ [ dup small-generic? ] [ small-generic ] }
|
||||
{ [ t ] [ num-types \ type big-generic ] }
|
||||
} cond ;
|
||||
|
||||
: simple-combination ( word -- quot )
|
||||
[ dup ] standard-combination ;
|
||||
|
||||
: define-generic ( word -- )
|
||||
[ simple-combination ] define-generic* ;
|
||||
[ 0 standard-combination ] define-generic* ;
|
||||
|
||||
PREDICATE: generic simple-generic ( word -- ? )
|
||||
"combination" word-prop [ simple-combination ] = ;
|
||||
PREDICATE: generic standard-generic
|
||||
1 swap "combination" word-prop ?nth
|
||||
\ standard-combination eq? ;
|
||||
|
|
|
|||
|
|
@ -1,45 +1,24 @@
|
|||
USING: generic help ;
|
||||
USING: generic help sequences ;
|
||||
|
||||
HELP: standard-combination "( word picker -- quot )"
|
||||
{ $values { "word" "a generic word" } { "picker" "a quotation with stack effect " { $snippet "( -- obj )" } } { "quot" "a new quotation" } }
|
||||
HELP: standard-combination "( word dispatch# -- quot )"
|
||||
{ $values { "word" "a generic word" } { "dispatch#" "a dispatch position" } { "quot" "a new quotation" } }
|
||||
{ $description
|
||||
"Performs standard method combination:"
|
||||
{ $list
|
||||
"the word dispatches on the object produced by the picker,"
|
||||
"only the method with most specific class is invoked."
|
||||
}
|
||||
"There is an additional feature if the picker is " { $snippet "[ dup ]" } ":"
|
||||
{ $list
|
||||
"if no suitable method is found, the generic word is called on the object's delegate."
|
||||
}
|
||||
"Performs standard method combination."
|
||||
"Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. If no suitable method is defined on the class of the dispatch object, the generic word is called on the dispatch object's delegate. If the delegate is " { $link f } ", an exception is thrown."
|
||||
}
|
||||
{ $examples
|
||||
"A generic word for append strings and characters to a sequence, dispatching on the second stack element:"
|
||||
"A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:"
|
||||
{ $code
|
||||
"G: build-string [ over ] standard-combination ;"
|
||||
"G: build-string 1 standard-combination ;"
|
||||
"M: string build-string swap nappend ;"
|
||||
"M: integer build-string push ;"
|
||||
}
|
||||
}
|
||||
{ $see-also POSTPONE: G: define-generic* } ;
|
||||
|
||||
HELP: simple-combination "( word -- quot )"
|
||||
{ $values { "word" "a generic word" } { "quot" "a new quotation" } }
|
||||
{ $description
|
||||
"Performs standard method combination with " { $snippet "[ dup ]" } " as the picker quotation. That is,"
|
||||
{ $list
|
||||
"the word dispatches on the top of the stack,"
|
||||
"only the method with most specific class is invoked,"
|
||||
"if no suitable method is found, the generic word is called on the object's delegate."
|
||||
}
|
||||
}
|
||||
{ $examples "Most generic words in the standard library use this method combination." }
|
||||
{ $see-also POSTPONE: GENERIC: define-generic } ;
|
||||
{ $notes "The " { $link POSTPONE: GENERIC: } " parsing word defines generic words using the standard method combination with dispatch position 0." }
|
||||
{ $examples "Most generic words in the standard library use this method combination with a dispatch position of 0. A handful of combinators such as " { $link each } " dispatch on position 1, since position 0 (the top of the stack) is a quotation." }
|
||||
{ $see-also POSTPONE: GENERIC: define-generic POSTPONE: G: define-generic* } ;
|
||||
|
||||
HELP: define-generic "( word -- )"
|
||||
{ $values { "word" "a word" } }
|
||||
{ $description "Defines a generic word with the " { $link simple-combination } " method combination. If the word is already a generic word, existing methods are retained." }
|
||||
{ $description "Defines a generic word with the " { $link standard-combination } " method combination, and a dispatch position of 0." }
|
||||
{ $see-also POSTPONE: GENERIC: define-generic* } ;
|
||||
|
||||
HELP: simple-generic f
|
||||
{ $description "The class of generic words with the " { $link simple-combination } ". They are typically defined by the " { $link POSTPONE: GENERIC: } " parsing word." } ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ GENERIC: dispatching-values ( node word -- seq )
|
|||
|
||||
M: object dispatching-values 2drop { } ;
|
||||
|
||||
M: simple-generic dispatching-values drop node-in-d peek 1array ;
|
||||
! M: simple-generic dispatching-values drop node-in-d peek 1array ;
|
||||
|
||||
M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ M: object digit> not-a-number ;
|
|||
dup >r /mod >digit , dup 0 >
|
||||
[ r> integer, ] [ r> 2drop ] if ;
|
||||
|
||||
G: >base ( num radix -- string ) [ over ] standard-combination ;
|
||||
G: >base ( num radix -- string ) 1 standard-combination ;
|
||||
|
||||
M: integer >base ( num radix -- string )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -197,7 +197,7 @@ HELP: GENERIC: "word"
|
|||
"A " { $link "method-combination" } " facility exists for customizing method dispatch behavior."
|
||||
$terpri
|
||||
"This parsing word is equivalent to the following usage of the more general " { $link POSTPONE: G: } " word:"
|
||||
{ $code "G: word simple-combination ;" }
|
||||
{ $code "G: word 0 standard-combination ;" }
|
||||
}
|
||||
{ $see-also define-generic } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -165,7 +165,7 @@ M: number union-containment drop 2 ;
|
|||
[ "M: vocabularies unhappy ;" eval ] unit-test-fails
|
||||
[ ] [ "GENERIC: unhappy" eval ] unit-test
|
||||
|
||||
G: complex-combination [ over ] standard-combination ;
|
||||
G: complex-combination 1 standard-combination ;
|
||||
M: string complex-combination drop ;
|
||||
M: object complex-combination nip ;
|
||||
|
||||
|
|
@ -197,9 +197,6 @@ TUPLE: delegating ;
|
|||
[ T{ shit f } "shit" ] [ T{ shit f } big-generic-test ] unit-test
|
||||
[ T{ shit f } "shit" ] [ T{ delegating T{ shit f } } big-generic-test ] unit-test
|
||||
|
||||
[ t ] [ \ = simple-generic? ] unit-test
|
||||
[ f ] [ \ each simple-generic? ] unit-test
|
||||
[ f ] [ \ object simple-generic? ] unit-test
|
||||
[ t ] [ \ + 2generic? ] unit-test
|
||||
|
||||
[ "SYMBOL: not-a-class C: not-a-class ;" parse ] unit-test-fails
|
||||
|
|
|
|||
|
|
@ -62,7 +62,7 @@ sequences strings vectors words ;
|
|||
] each-object nip ; inline
|
||||
|
||||
G: each-slot ( obj quot -- )
|
||||
[ over ] standard-combination ; inline
|
||||
1 standard-combination ; inline
|
||||
|
||||
M: array each-slot ( array quot -- ) each ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue