1.0.21.35: fix build / SAVE-LISP-AND-DIE on non-GENCGC platforms

[sbcl.git] / src / code / primordial-extensions.lisp

diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp
index f9293be..e28cb0e 100644 (file)
--- a/src/code/primordial-extensions.lisp
+++ b/src/code/primordial-extensions.lisp
@@ -124,6 +124,30 @@
 \f
 ;;;; GENSYM tricks
 
+;;; GENSYM variant for easier debugging and better backtraces: append
+;;; the closest enclosing non-nil block name to the provided stem.
+(defun block-gensym (&optional (name "G") (env (when (boundp 'sb!c::*lexenv*)
+                                             (symbol-value 'sb!c::*lexenv*))))
+  (let ((block-name (when env
+                      (car (find-if #'car (sb!c::lexenv-blocks env))))))
+    (if block-name
+        (gensym (format nil "~A[~A]" name block-name))
+        (gensym name))))
+
+
+;;; Compile a version of BODY for all TYPES, and dispatch to the
+;;; correct one based on the value of VAR. This was originally used
+;;; only for strings, hence the name. Renaming it to something more
+;;; generic might not be a bad idea.
+(defmacro string-dispatch ((&rest types) var &body body)
+  (let ((fun (gensym "STRING-DISPATCH-FUN-")))
+    `(flet ((,fun (,var)
+              ,@body))
+       (declare (inline ,fun))
+       (etypecase ,var
+         ,@(loop for type in types
+                 collect `(,type (,fun (the ,type ,var))))))))
+
 ;;; Automate an idiom often found in macros:
 ;;;   (LET ((FOO (GENSYM "FOO"))
 ;;;         (MAX-INDEX (GENSYM "MAX-INDEX-")))
@@ -139,7 +163,7 @@
                           (stem (if (every #'alpha-char-p symbol-name)
                                     symbol-name
                                     (concatenate 'string symbol-name "-"))))
-                     `(,symbol (gensym ,stem))))
+                     `(,symbol (block-gensym ,stem))))
                  symbols)
      ,@body))
 
@@ -147,7 +171,7 @@
 ;;; macros and other code-manipulating code.)
 (declaim (ftype (function (index) list) make-gensym-list))
 (defun make-gensym-list (n)
-  (loop repeat n collect (gensym)))
+  (loop repeat n collect (block-gensym)))
 \f
 ;;;; miscellany