From b25647f2c4e042c3505d4806b3c70da2a4a05f21 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 19 Apr 2018 06:42:13 -0700
Subject: new macros: hlet, hlet*.

* lisplib.c (yield_set_entries): Add hlet and hlet* to
autoload list.

* share/txr/stdlib/yield.tl (hlet-expand): New function
(hlet, hlet*): New macros.

* txr.1: Documented.
---
 lisplib.c                 |  2 +-
 share/txr/stdlib/yield.tl | 28 ++++++++++++++++++++++++++++
 txr.1                     | 22 ++++++++++++++++++++++
 3 files changed, 51 insertions(+), 1 deletion(-)

diff --git a/lisplib.c b/lisplib.c
index a486abe1..1008912f 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -299,7 +299,7 @@ static val yield_set_entries(val dlt, val fun)
   val name[] = {
     lit("obtain"), lit("obtain-block"), lit("yield-from"), lit("yield"),
     lit("obtain*"), lit("obtain*-block"),
-    lit("suspend"),
+    lit("suspend"), lit("hlet"), lit("hlet*"),
     nil
   };
   set_dlt_entries(dlt, name, fun);
diff --git a/share/txr/stdlib/yield.tl b/share/txr/stdlib/yield.tl
index 3ab74745..f8b5783d 100644
--- a/share/txr/stdlib/yield.tl
+++ b/share/txr/stdlib/yield.tl
@@ -88,3 +88,31 @@
   ^(sys:capture-cont ',name (lambda (,sym)
                               (sys:abscond-from ,name (progn ,*body)))
                      ',form))
+
+(defun hlet-expand (op raw-vis body)
+  (let* ((vis (mapcar [iffi atom list] raw-vis))
+         (nvars (len vis))
+         (syms [mapcar car vis])
+         (inits [mapcar cadr vis])
+         (letop (if (eq op 'hlet*) 'let* 'let))
+         (gens (mapcar (ret (gensym)) vis))
+         (vec (gensym))
+         (macs (mapcar (ret ^(,@1 (vecref ,vec ,@2)))
+                       syms (range 0)))
+         (inits (mapcar (ret ^(set (vecref ,vec ,@1) ,@2))
+                        (range 0) inits)))
+    (if (eq op 'hlet*)
+      ^(let* ((,vec (vector ,nvars)))
+         (symacrolet ,macs
+           ,*inits
+           ,*body))
+      ^(let* ((,vec (vector ,nvars)))
+         ,*inits
+         (symacrolet ,macs
+           ,*body)))))
+
+(defmacro hlet (var-inits . body)
+  (hlet-expand 'hlet var-inits body))
+
+(defmacro hlet* (var-inits . body)
+  (hlet-expand 'hlet* var-inits body))
diff --git a/txr.1 b/txr.1
index fd1a6b76..bf05c548 100644
--- a/txr.1
+++ b/txr.1
@@ -38563,6 +38563,28 @@ non-deterministically:
   -> (2 4)
 .cble
 
+.coNP Macros @ hlet and @ hlet*
+.synb
+.mets (hlet >> ({ sym | >> ( sym << init-form )}*) << body-form *)
+.mets (hlet* >> ({ sym | >> ( sym << init-form )}*) << body-form *)
+.syne
+.desc
+The
+.code hlet
+and
+.code hlet*
+macros behave exactly like
+.code let
+and
+.codn let* ,
+respectively except that they guarantee that the variable bindings are
+allocated in storage which isn't captured by delimited continuations.
+
+The
+.code h
+in the names stands for "heap", serving as a mnemonic based on the
+implementation concept of these bindings being "heap allocated".
+
 .SS* Regular Expression Library
 
 \*(TX provides a "pure" regular expression implementation based on automata
-- 
cgit v1.2.3