New function: expand-hook-combine.

This function provides a functional combinator that takes
the responsibility of combining expand hooks.

* eval.c (expand_hook_combine_fun, expand_hook_combine):
New static functions.
(eval_init): Register expand-hook-combine intrinsic.

* tests/011/exphook.tl: New file.

* txr.1: Documented.

3 files changed, 128 insertions, 0 deletions

diff --git a/eval.c b/eval.c
index 4489025f..51d562ef 100644
--- a/eval.c
+++ b/eval.c
@@ -5558,6 +5558,30 @@ val expand(val form, val menv)
   return ret;
 }
 
+static val expand_hook_combine_fun(val env, val form, val menv, val type)
+{
+  cons_bind (first, next, env);
+
+  if (first) {
+    val nform = funcall3(first, form, menv, type);
+    if (nform)
+      return nform;
+  }
+
+  if (next) {
+    val nform = funcall3(next, form, menv, type);
+    if (nform)
+      return nform;
+  }
+
+  return form;
+}
+
+static val expand_hook_combine(val first, val next)
+{
+  return func_f3(cons(first, next), expand_hook_combine_fun);
+}
+
 static val muffle_unbound_warning(val exc, varg args)
 {
   (void) exc;
@@ -7623,6 +7647,7 @@ void eval_init(void)
   reg_var(load_hooks_s, nil);
   reg_fun(intern(lit("expand"), user_package), func_n2o(no_warn_expand, 1));
   reg_fun(intern(lit("expand*"), user_package), func_n2o(expand, 1));
+  reg_fun(intern(lit("expand-hook-combine"), user_package), func_n2(expand_hook_combine));
   reg_fun(intern(lit("expand-with-free-refs"), user_package),
           func_n3o(expand_with_free_refs, 1));
   reg_fun(intern(lit("macro-form-p"), user_package), func_n2o(macro_form_p, 1));
diff --git a/tests/011/exphook.tl b/tests/011/exphook.tl
new file mode 100644
index 00000000..8439ac56
--- /dev/null
+++ b/tests/011/exphook.tl
@@ -0,0 +1,17 @@
+(load "../common")
+
+(defun-match pico-style-expand-hook
+  ((@(as form (@obj . @rest)) @nil nil)
+   (if (constantp obj)
+     ^(quote ,form)
+      form))
+  ((@form @nil @nil) form))
+
+(defmacro pico-style (:env env . body)
+  (let ((*expand-hook* [expand-hook-combine *expand-hook*
+                                            pico-style-expand-hook]))
+    (expand ^(progn ,*body) env)))
+
+(mtest
+  (pico-style (1 2 3)) (1 2 3)
+  (pico-style (let ((a 0)) (cons a (1 2 3)))) (0 1 2 3))
diff --git a/txr.1 b/txr.1
index 55b9594a..daace25b 100644
--- a/txr.1
+++ b/txr.1
@@ -43947,6 +43947,58 @@ shorthand:
     ^(,x ,y ,z))
 .brev
 
+.coNP Function @ expand-hook-combine
+.synb
+.mets (expand-hook-combine < first-hook << next-hook)
+.syne
+.desc
+The purpose of the
+.code expand-hook-combine
+is to simplify the installation of a dynamic expansion hook via the
+.code *expand-hook*
+variable, such that the previously installed hooks are called.
+
+The arguments of
+.meta expand-hook-combine
+must be functions. Either one may also be
+.codn nil .
+If either argument is a function, rather than
+.codn nil ,
+it must be a function individually suitable as a value of
+.metn *expand-hook* .
+
+The
+.code expand-hook-combine
+function returns a combination of the two argument functions,
+suitable for use as a value for
+.metn *expand-hook* .
+
+The returned combined function works as follows. If the
+.meta next
+argument is a function, the combined function passes its expand hook arguments
+.metn form ,
+.meta env
+and
+.meta type-symbol
+to the
+.meta first
+function.  If that function returns an object other than
+.metn form ,
+then the combined function returns that object.
+Otherwise, the combined function tries the
+.meta next
+function in the same way: if that function isn't
+.codn nil ,
+it is called with the three expand hook arguments. If
+.meta next
+returns a value other than
+.metn form ,
+then the combined function returns that value.
+Otherwise, if a replacement object for
+.meta form
+is not obtained and returned, then the combined function returns
+.metn form .
+
 .coNP Special Variable @ *expand-hook*
 .desc
 The
@@ -44042,6 +44094,40 @@ and call that function before performing any transformation of
 If that function performs a transformation, indicated by
 returning a different form, then return that form, only
 performing local processing when that function has declined.
+The function
+.code expand-hook-combine
+is provided which encapsulates this logic.
+
+.TP* Example
+
+.verb
+  ;; Simulate a PicoLisp feature: when a form begins with a
+  ;; self-evaluating object, it denotes a quoted list.
+
+  (defun-match pico-style-expand-hook
+    ((@(as form (@obj . @rest)) @nil nil)
+     (if (constantp obj)
+       ^(quote ,form)
+        form))
+    ((@form @nil @nil) form))
+
+  ;; Macro demonstrating use of expand-hook-combine to
+  ;; install pico-style-expand-hook such that existing
+  ;; hooks are tried first.
+
+  (defmacro pico-style (:env env . body)
+    (let ((*expand-hook* [expand-hook-combine *expand-hook*
+                                              pico-style-expand-hook]))
+      (expand ^(progn ,*body) env)))
+
+  ;; Under pico-style, (1 2 3) converts to '(1 2 3)
+  (pico-style (1 2 3)) -> (1 2 3)
+
+  ;; Because this is done via *expand-hook*, it works
+  ;; reliably throughout the interior.
+  (pico-style
+     (let ((a 0)) (cons a (1 2 3)))) -> (0 1 2 3)
+.brev
 
 .SS* Parameter List Macros