From: Joe Groff Date: Tue, 23 Mar 2010 05:32:00 +0000 (-0700) Subject: delegate: add BROADCAST: syntax, delegate generic with no outputs to an array of... X-Git-Tag: 0.97~4723^2~55^2~42^2 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=f6561f3c03036670cabfd92a827e9ba1faab903c delegate: add BROADCAST: syntax, delegate generic with no outputs to an array of multiple delegates --- diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor index d4867714d3..451016cc6c 100644 --- a/basis/delegate/delegate-docs.factor +++ b/basis/delegate/delegate-docs.factor @@ -18,9 +18,16 @@ HELP: define-consult { $notes "Usually, " { $link POSTPONE: CONSULT: } " should be used instead. This is only for runtime use." } ; HELP: CONSULT: -{ $syntax "CONSULT: group class getter... ;" } -{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "getter" "code to get where the method should be forwarded" } } -{ $description "Defines a class to consult, using the given code, on the generic words contained in the group. This means that, when one of the words in the group is called on an object of this class, the quotation will be called, and then the generic word called again. If the getter is empty, this will cause an infinite loop. Consultation overwrites the existing methods, but others can be defined afterwards." } ; +{ $syntax """CONSULT: group class + code ;""" } +{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "code" "code to get the object to which the method should be forwarded" } } +{ $description "Declares that objects of " { $snippet "class" } " will delegate the generic words contained in " { $snippet "group" } " to the object returned by executing " { $snippet "code" } " with the original object as an input." { $snippet "CONSULT:" } " will overwrite any existing methods on " { $snippet "class" } " for the members of " { $snippet "group" } ", but new methods can be added after the " { $snippet "CONSULT:" } " to override the delegation." } ; + +HELP: BROADCAST: +{ $syntax """BROADCAST: group class + code ;""" } +{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "code" "code to get the object to which the method should be forwarded" } } +{ $description "Declares that objects of " { $snippet "class" } " will delegate the generic words contained in " { $snippet "group" } " to every object in the sequence returned by executing " { $snippet "code" } " with the original object as an input." { $snippet "BROADCAST:" } " will overwrite any existing methods on " { $snippet "class" } " for the members of " { $snippet "group" } ", but new methods can be added after the " { $snippet "BROADCAST:" } " to override the delegation. Every generic word in " { $snippet "group" } " must return no outputs; otherwise, a " { $link broadcast-words-must-have-no-outputs } " error will be raised." } ; HELP: SLOT-PROTOCOL: { $syntax "SLOT-PROTOCOL: protocol-name slots... ;" } @@ -28,7 +35,7 @@ HELP: SLOT-PROTOCOL: { define-protocol POSTPONE: PROTOCOL: } related-words -{ define-consult POSTPONE: CONSULT: } related-words +{ define-consult POSTPONE: BROADCAST: POSTPONE: CONSULT: } related-words HELP: group-words { $values { "group" "a group" } { "words" "an array of words" } } @@ -52,6 +59,7 @@ $nl { $subsections POSTPONE: SLOT-PROTOCOL: } "Defining consultation:" { $subsections + POSTPONE: BROADCAST: POSTPONE: CONSULT: define-consult } diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index 17f81708c5..4a280ef584 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -1,7 +1,7 @@ USING: delegate kernel arrays tools.test words math definitions compiler.units parser generic prettyprint io.streams.string accessors eval multiline generic.single delegate.protocols -delegate.private assocs see ; +delegate.private assocs see make ; IN: delegate.tests TUPLE: hello this that ; @@ -197,3 +197,18 @@ DEFER: seq-delegate sequence-protocol \ protocol-consult word-prop key? ] unit-test + +GENERIC: broadcastable ( x -- ) +GENERIC: nonbroadcastable ( x -- y ) + +TUPLE: broadcaster targets ; + +BROADCAST: broadcastable broadcaster targets>> ; + +M: integer broadcastable 1 + , ; + +[ "USING: accessors delegate ; IN: delegate.tests BROADCAST: nonbroadcastable broadcaster targets>> ;" eval( -- ) ] +[ error>> broadcast-words-must-have-no-outputs? ] must-fail-with + +[ { 2 3 4 } ] +[ { 1 2 3 } broadcaster boa [ broadcastable ] { } make ] unit-test diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index dc3024b55f..5c8703116d 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -1,12 +1,14 @@ ! Copyright (C) 2007, 2008 Daniel Ehrenberg -! Portions copyright (C) 2009 Slava Pestov +! Portions copyright (C) 2009, 2010 Slava Pestov, Joe Groff ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs classes.tuple definitions generic +USING: accessors arrays assocs classes.tuple definitions effects generic generic.standard hashtables kernel lexer math parser generic.parser sequences sets slots words words.symbol fry compiler.units ; IN: delegate +ERROR: broadcast-words-must-have-no-outputs group ; + > empty? ] all? + [ broadcast-words-must-have-no-outputs ] unless ; + ! Consultation TUPLE: consultation group class quot loc ; +TUPLE: broadcast < consultation ; : ( group class quot -- consultation ) f consultation boa ; +: ( group class quot -- consultation ) + [ check-broadcast-group ] 2dip f broadcast boa ; : create-consult-method ( word consultation -- method ) [ class>> swap first create-method dup fake-definition ] keep @@ -44,13 +53,21 @@ PREDICATE: consult-method < method "consultation" word-prop ; M: consult-method reset-word [ call-next-method ] [ f "consultation" set-word-prop ] bi ; -: consult-method-quot ( quot word -- object ) +GENERIC# (consult-method-quot) 2 ( consultation quot word -- object ) + +M: consultation (consult-method-quot) + '[ _ call _ execute ] nip ; +M: broadcast (consult-method-quot) + '[ _ call [ _ execute ] each ] nip ; + +: consult-method-quot ( consultation word -- object ) + [ dup quot>> ] dip [ second [ [ dip ] curry ] times ] [ first ] bi - '[ _ call _ execute ] ; + (consult-method-quot) ; : consult-method ( word consultation -- ) [ create-consult-method ] - [ quot>> swap consult-method-quot ] 2bi + [ swap consult-method-quot ] 2bi define ; : change-word-prop ( word prop quot -- ) @@ -89,6 +106,10 @@ SYNTAX: CONSULT: scan-word scan-word parse-definition [ save-location ] [ define-consult ] bi ; +SYNTAX: BROADCAST: + scan-word scan-word parse-definition + [ save-location ] [ define-consult ] bi ; + M: consultation where loc>> ; M: consultation set-where (>>loc) ;