Have method combinations themselves make their consultation quotations.

kinda meta

diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor
index 0c9a0dd9d753783d1d830a49d929aea6fd6d3af0..0d8781ab8a1b190212da8120c9524ca0a2b05bc3 100644 (file)
--- a/basis/delegate/delegate-docs.factor
+++ b/basis/delegate/delegate-docs.factor
@@ -23,12 +23,6 @@ HELP: CONSULT:
 { $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: HOOK-CONSULT:
-{ $syntax "HOOK-CONSULT: group class var
-    code ;" }
-{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "var" "a variable" } { "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 the same word but with " { $snippet "var" } " re-bound to the value produced by" { $snippet "code" } ". It is your responsibility to ensure that the correct " { $snippet "var" } " is named, and that the code produces a value which can be stored in that " { $snippet "var" } "." } ;
-
 HELP: BROADCAST:
 { $syntax "BROADCAST: group class
     code ;" }

diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor
index ff9574c066feb26222b0d96cacade2430cf62ebb..5d5ac044a1a92311d5e402e0ae7625a257a2f744 100644 (file)
--- a/basis/delegate/delegate.factor
+++ b/basis/delegate/delegate.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2007, 2008 Daniel Ehrenberg
 ! Portions copyright (C) 2009, 2010 Slava Pestov, Joe Groff
 ! See https://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes classes.tuple
-compiler.units definitions effects fry generic generic.standard
-hashtables kernel lexer make math namespaces parser sequences
-sets slots words words.symbol ;
+USING: accessors arrays assocs classes classes.tuple combinators
+compiler.units definitions effects fry generic generic.hook generic.standard
+hashtables kernel lexer make math namespaces parser sequences sets slots
+words words.symbol ;
 IN: delegate
 
 ERROR: broadcast-words-must-have-no-outputs group ;
@@ -44,8 +44,6 @@ M: tuple-class group-words
 
 TUPLE: consultation group class quot loc ;
 
-TUPLE: hook-consultation < consultation ;
-
 TUPLE: broadcast < consultation ;
 
 : <consultation> ( group class quot -- consultation )
@@ -54,9 +52,6 @@ TUPLE: broadcast < consultation ;
 : <broadcast> ( group class quot -- consultation )
     [ check-broadcast-group ] 2dip f broadcast boa ;
 
-: <hook-consultation> ( group class quot -- hook-consultation )
-    f hook-consultation boa ;
-
 : create-consult-method ( word consultation -- method )
     [ class>> swap first create-method dup fake-definition ] keep
     [ drop ] [ "consultation" set-word-prop ] 2bi ;
@@ -70,17 +65,11 @@ M: consult-method reset-word
 GENERIC#: (consult-method-quot) 2 ( consultation quot word -- object )
 
 M: consultation (consult-method-quot)
-    '[ _ call _ execute ] nip ;
+    dup "combination" word-prop make-consult-quot ;
 
 M: broadcast (consult-method-quot)
     '[ _ call [ _ execute ] each ] nip ;
 
-M: hook-consultation (consult-method-quot) ( consultation quot word -- object )
-    [ drop ] 2dip ! consultation no longer necessary
-    dup "combination" word-prop var>> ! (quot word var)
-    -rot ! (var quot word)
-    '[ _ _ call swap [ _ execute ] with-variable ] ;
-
 : consult-method-quot ( consultation word -- object )
     [ dup quot>> ] dip
     [ second [ [ dip ] curry ] times ] [ first ] bi
@@ -124,10 +113,6 @@ SYNTAX: CONSULT:
     scan-word scan-word parse-definition <consultation>
     [ save-location ] [ define-consult ] bi ;
 
-SYNTAX: HOOK-CONSULT:
-    scan-word scan-word parse-definition <hook-consultation>
-    [ save-location ] [ define-consult ] bi ;
-
 SYNTAX: BROADCAST:
     scan-word scan-word parse-definition <broadcast>
     [ save-location ] [ define-consult ] bi ;

diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index e45997e265e4ca28d22fec42d12eaffe82552ce4..c3b8aa247be646a7ad32d59e435cd28ab11c2ea9 100644 (file)
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -216,3 +216,6 @@ M: generic subwords
 
 M: class forget-methods
     [ implementors ] [ [ swap ?lookup-method ] curry ] bi map forget-all ;
+
+! Consultation/delegation support
+GENERIC: make-consult-quot ( consultation word quot combination -- consult-quot )

diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor
index b5046e9a66ac00fb955db28137bb0ab0133374cb..b2926aa3687364e3b54a93180e75a4ef48367627 100644 (file)
--- a/core/generic/hook/hook.factor
+++ b/core/generic/hook/hook.factor
@@ -24,3 +24,10 @@ M: hook-generic definer drop \ HOOK: f ;
 
 M: hook-generic effective-method
     [ "combination" word-prop var>> get ] keep method-for-object ;
+
+M: hook-combination make-consult-quot
+    drop          ! combination no longer necessary
+    [ drop ] 2dip ! consultation no longer necessary
+    dup "combination" word-prop var>> ! (quot word var)
+    -rot ! (var quot word)
+    '[ _ _ call swap [ _ execute ] with-variable ] ;

diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index dda881a49eee56e20612d039e52b22a2a74475cb..c1266806a3fee311099b321df6a6127338411695 100644 (file)
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -66,3 +66,6 @@ M: standard-combination mega-cache-quot
 M: standard-generic definer drop \ GENERIC#: f ;
 
 M: simple-generic definer drop \ GENERIC: f ;
+
+M: standard-combination make-consult-quot
+    drop '[ _ call _ execute ] nip ;