1.0.29.26: robustify GENTEMP against pretty-printer

* Patch by Alex Plotnick.

diff --git a/NEWS b/NEWS
index 15c33b4..deb4eb7 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -34,6 +34,8 @@
     FC6 as well. (reported by Tomasz Skutnik and obias Rautenkranz)
   * bug fix: SETF compiler macro documentation strings are not discarded
     anymore.
+  * bug fix: GENTEMP is now unaffected by pretty printer dispatch table.
+    (thanks to Alex Plotnick)
 
 changes in sbcl-1.0.29 relative to 1.0.28:
   * IMPORTANT: bug database has moved from the BUGS file to Launchpad

diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp
index 30e629e..fe29dd6 100644 (file)
--- a/src/code/symbol.lisp
+++ b/src/code/symbol.lisp
@@ -246,6 +246,11 @@ distinct from the global value. Can also be SETF."
 \f
 ;;;; GENSYM and friends
 
+(defun %make-symbol-name (prefix counter)
+  (with-output-to-string (s)
+    (write-string prefix s)
+    (%output-integer-in-base counter 10 s)))
+
 (defvar *gensym-counter* 0
   #!+sb-doc
   "counter for generating unique GENSYM symbols")
@@ -272,10 +277,7 @@ distinct from the global value. Can also be SETF."
           (fixnum (values "G" thing))
           (string (values (coerce thing 'simple-string) old)))
       (declare (simple-string prefix))
-      (make-symbol
-       (with-output-to-string (s)
-         (write-string prefix s)
-         (%output-integer-in-base int 10 s))))))
+      (make-symbol (%make-symbol-name prefix int)))))
 
 (defvar *gentemp-counter* 0)
 (declaim (type unsigned-byte *gentemp-counter*))
@@ -284,11 +286,6 @@ distinct from the global value. Can also be SETF."
   #!+sb-doc
   "Creates a new symbol interned in package PACKAGE with the given PREFIX."
   (declare (type string prefix))
-  (loop
-    (let ((*print-base* 10)
-          (*print-radix* nil)
-          (*print-pretty* nil)
-          (new-pname (format nil "~A~D" prefix (incf *gentemp-counter*))))
-      (multiple-value-bind (symbol existsp) (find-symbol new-pname package)
-        (declare (ignore symbol))
-        (unless existsp (return (values (intern new-pname package))))))))
+  (loop for name = (%make-symbol-name prefix (incf *gentemp-counter*))
+        while (nth-value 1 (find-symbol name package))
+        finally (return (values (intern name package)))))

diff --git a/tests/symbol.pure.lisp b/tests/symbol.pure.lisp
index b7f3f26..ac30c8a 100644 (file)
--- a/tests/symbol.pure.lisp
+++ b/tests/symbol.pure.lisp
@@ -19,3 +19,9 @@
                                       :adjustable t :initial-contents "X"))))
     (assert (simple-string-p (symbol-name sym)))
     (print sym (make-broadcast-stream))))
+
+(with-test (:name (gentemp pprinter))
+  (let* ((*print-pprint-dispatch* (copy-pprint-dispatch)))
+    (set-pprint-dispatch 'string
+                         (lambda (stream obj) (write-string "BAR-" stream)))
+    (assert (string= "FOO-" (gentemp "FOO-") :end2 4))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 2aaf4e3..66e56d6 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.29.25"
+"1.0.29.26"