diff --git a/doc/handbook/objects.facts b/doc/handbook/objects.facts index e9149b67ad..6fe1baebf4 100644 --- a/doc/handbook/objects.facts +++ b/doc/handbook/objects.facts @@ -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." } diff --git a/library/collections/sequence-combinators.factor b/library/collections/sequence-combinators.factor index 97cb463b1f..c9e0676d8e 100644 --- a/library/collections/sequence-combinators.factor +++ b/library/collections/sequence-combinators.factor @@ -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 ; diff --git a/library/collections/tree-each.factor b/library/collections/tree-each.factor index 64cf913bf2..631102cc62 100644 --- a/library/collections/tree-each.factor +++ b/library/collections/tree-each.factor @@ -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 diff --git a/library/compiler/ppc/assembler.factor b/library/compiler/ppc/assembler.factor index e552793c88..2c64e2b6c8 100644 --- a/library/compiler/ppc/assembler.factor +++ b/library/compiler/ppc/assembler.factor @@ -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 ; diff --git a/library/generic/slots.facts b/library/generic/slots.facts index a4d91e0ebb..318c9b154c 100644 --- a/library/generic/slots.facts +++ b/library/generic/slots.facts @@ -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 diff --git a/library/generic/standard-combination.factor b/library/generic/standard-combination.factor index c5d7a54e2e..74ef58d165 100644 --- a/library/generic/standard-combination.factor +++ b/library/generic/standard-combination.factor @@ -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 ; -: ( picker word n -- 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> , , \ dispatch , ] [ ] make ; +: big-generic ( dispatch# word n dispatcher -- def ) + [ >r pick picker % r> , , \ 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? ; diff --git a/library/generic/standard-combination.facts b/library/generic/standard-combination.facts index d44ff78390..2d883c3251 100644 --- a/library/generic/standard-combination.facts +++ b/library/generic/standard-combination.facts @@ -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." } ; diff --git a/library/inference/inline-methods.factor b/library/inference/inline-methods.factor index f83dd0ce7b..63ac33ebe7 100644 --- a/library/inference/inline-methods.factor +++ b/library/inference/inline-methods.factor @@ -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* ; diff --git a/library/math/parse-numbers.factor b/library/math/parse-numbers.factor index e13b7f6c39..870d9b86bd 100644 --- a/library/math/parse-numbers.factor +++ b/library/math/parse-numbers.factor @@ -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 ) [ diff --git a/library/syntax/parse-syntax.facts b/library/syntax/parse-syntax.facts index e15e966896..90b45ecce8 100644 --- a/library/syntax/parse-syntax.facts +++ b/library/syntax/parse-syntax.facts @@ -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 } ; diff --git a/library/test/generic.factor b/library/test/generic.factor index 1c490f87e6..84f044a2e4 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -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 diff --git a/library/tools/memory.factor b/library/tools/memory.factor index e67b75f182..0750b7c932 100644 --- a/library/tools/memory.factor +++ b/library/tools/memory.factor @@ -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 ;