Allow naming thunks

macro-tools.lisp

@@ -100,7 +100,7 @@ From Lparallel."
 ;;;## `with-thunk'
 ;;; This is useful, but the name could and should be improved.
 
-(defmacro with-thunk ((var &rest args) &body body)
+(defmacro with-thunk ((spec &rest args) &body body)
   "A macro-writing macro for the `call-with-' style.
 
 In the `call-with-' style of writing macros, the macro is simply a
@@ -132,6 +132,10 @@ to be given a name (using `flet') so it can be declared
       (with-thunk (body)
         `(call-with-foo ,body)))
 
+You can give the thunk a name for easier debugging.
+
+    (with-thunk ((body :name foo)) ...)
+
 It is also possible to construct a \"thunk\" with arguments.
 
     (with-thunk (body foo)
@@ -142,22 +146,26 @@ It is also possible to construct a \"thunk\" with arguments.
         (call-with-foo #',thunk))
 
 Someday this may have a better name."
-  (let* ((stack-thunk-prefix (string 'stack-fn-))
-         (stack-thunk-name
-           (concatenate 'string
-                        stack-thunk-prefix
-                        (string var)))
-         (stack-thunk
-           (gensym stack-thunk-name)))
-    (with-gensyms (b gargs)
-      `(let ((,b ,var)
-             (,var ',stack-thunk)
-             (,gargs (list ,@args)))
-         `(flet ((,',stack-thunk ,,gargs
-                   ,@,b))
-            (declare (dynamic-extent (function ,',stack-thunk)))
-            (symbol-macrolet ((,',stack-thunk (function ,',stack-thunk)))
-              ,,@body))))))
+  ;; TODO Derive default name from &environment. Cf. log4cl.
+  (destructuring-bind (var &key name) (ensure-list spec)
+    (declare (type (and symbol (not null)) var)
+             (type symbol name))
+    (let* ((stack-fn-prefix (string 'stack-fn-))
+           (stack-fn-name
+             (or (concatenate 'string
+                              stack-fn-prefix
+                              (string (or name var)))))
+           (stack-fn
+             (gensym stack-fn-name)))
+      (with-gensyms (b gargs)
+        `(let ((,b ,var)
+               (,var ',stack-fn)
+               (,gargs (list ,@args)))
+           `(flet ((,',stack-fn ,,gargs
+                     ,@,b))
+              (declare (dynamic-extent (function ,',stack-fn)))
+              (symbol-macrolet ((,',stack-fn (function ,',stack-fn)))
+                ,,@body)))))))
 
 ;;;# Expanding macros
 ;;; Expanding macros, Swank-style. We use `labels' in these

reader.lisp

@@ -26,5 +26,5 @@ control the reader, not the printer.
 This may be preferable to using `with-standard-io-syntax' when loading
 data, as it will not effect how errors are printed, thus preserving
 debugging information."
-  (with-thunk (body)
+  (with-thunk ((body :name with-standard-input-syntax))
     `(call/standard-input-syntax ,body)))

sequences.lisp

@@ -116,7 +116,7 @@ part of the arguments to compare, and compares them using TEST."
 
 (define-do-macro do-each/map ((var seq &optional return) &body body)
   "The simple, out-of-line version."
-  (with-thunk (body var)
+  (with-thunk ((body :name do-each) var)
     `(map nil ,body ,seq)))
 
 (defmacro do-each ((var seq &optional return) &body body &environment env)
@@ -130,7 +130,7 @@ If SEQ is a list, this is equivalent to `dolist'."
   ;; SBCL from spamming us with code deletion notes. (It may also be
   ;; desirable in itself to avoid needless code duplication in Lisps
   ;; without type inference.)
-  (with-thunk (body var)
+  (with-thunk ((body :name do-each) var)
     (let ((iter-spec `(,var ,seq ,@(unsplice return))))
       `(locally (declare #+sbcl (sb-ext:muffle-conditions sb-ext:code-deletion-note))
          #+(or sbcl abcl)

strings.lisp

@@ -76,7 +76,7 @@ functions.
                                                `(:element-type ,element-type)))
                   ,@body))))))
 
-  (with-thunk (body var)
+  (with-thunk ((body :name with-string) var)
     `(call/string #',body ,stream)))
 
 (defsubst blankp (seq)