Fixup fewer complaints about hairy lexical environments

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

diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp
index e25ed15..0ca98ac 100644 (file)
--- a/src/code/primordial-extensions.lisp
+++ b/src/code/primordial-extensions.lisp
@@ -124,16 +124,6 @@
 \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
-        (sb!xc:gensym (format nil "~A[~A]" name block-name))
-        (sb!xc: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
@@ -145,7 +135,9 @@
        (declare (inline ,fun))
        (etypecase ,var
          ,@(loop for type in types
-                 collect `(,type (,fun (the ,type ,var))))))))
+                 ;; TRULY-THE allows transforms to take advantage of the type
+                 ;; information without need for constraint propagation.
+                 collect `(,type (,fun (truly-the ,type ,var))))))))
 
 ;;; Automate an idiom often found in macros:
 ;;;   (LET ((FOO (GENSYM "FOO"))
@@ -162,15 +154,20 @@
                           (stem (if (every #'alpha-char-p symbol-name)
                                     symbol-name
                                     (concatenate 'string symbol-name "-"))))
-                     `(,symbol (block-gensym ,stem))))
+                     `(,symbol (gensym ,stem))))
                  symbols)
      ,@body))
 
 ;;; Return a list of N gensyms. (This is a common suboperation in
 ;;; macros and other code-manipulating code.)
-(declaim (ftype (function (index) list) make-gensym-list))
-(defun make-gensym-list (n)
-  (loop repeat n collect (block-gensym)))
+(declaim (ftype (function (index &optional t) (values list &optional))
+                make-gensym-list))
+(defun make-gensym-list (n &optional name)
+  (when (eq t name)
+    (break))
+  (if name
+      (loop repeat n collect (gensym (string name)))
+      (loop repeat n collect (gensym))))
 \f
 ;;;; miscellany
 
@@ -200,6 +197,11 @@
             (replace name x :start1 index)
             (incf index len)))))))
 
+(defun gensymify (x)
+  (if (symbolp x)
+      (sb!xc:gensym (symbol-name x))
+      (sb!xc:gensym)))
+
 ;;; like SYMBOLICATE, but producing keywords
 (defun keywordicate (&rest things)
   (let ((*package* *keyword-package*))