From 0d2bb0b292731fbf12d89aad2d28ea98a335d82b Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 21 Jun 2009 14:57:37 +0000 Subject: [PATCH] 1.0.29.26: robustify GENTEMP against pretty-printer * Patch by Alex Plotnick. --- NEWS | 2 ++ src/code/symbol.lisp | 21 +++++++++------------ tests/symbol.pure.lisp | 6 ++++++ version.lisp-expr | 2 +- 4 files changed, 18 insertions(+), 13 deletions(-) diff --git a/NEWS b/NEWS index 15c33b4..deb4eb7 100644 --- 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 --- a/src/code/symbol.lisp +++ b/src/code/symbol.lisp @@ -246,6 +246,11 @@ distinct from the global value. Can also be SETF." ;;;; 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 --- 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 --- 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" -- 1.7.10.4