From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Mon, 3 May 2004 10:27:40 +0000 (+0000)
Subject: 0.8.10.8:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f7662559d03e5076f5e3cbc236f1cf82467a4b60;p=sbcl.git

0.8.10.8:
	Fix WRITE-TO-STRING bugs (e.g. lisppaste 747)
	... not FOLDABLE, oh no.
---

diff --git a/NEWS b/NEWS
index 1ea3f0e..c88b78e 100644
--- a/NEWS
+++ b/NEWS
@@ -2408,6 +2408,8 @@ changes in sbcl-0.8.11 relative to sbcl-0.8.10:
   * added a new restart to *BREAK-ON-SIGNALS* handling to make it
     easier to resume long computations after using *BREAK-ON-SIGNALS*
     to diagnose and fix failures.  (thanks to Nikodemus Siivola)
+  * fixed bug reported by PFD in lisppaste #747 (and Bruno Haible from
+    CLISP test suite): WRITE-TO-STRING is not constant-foldable.
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 671ba33..a4a2661 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1058,7 +1058,8 @@
   :derive-type #'result-type-first-arg)
 
 ;;; xxx-TO-STRING functions are not foldable because they depend on
-;;; the dynamic environment.
+;;; the dynamic environment, the state of the pretty printer dispatch
+;;; table, and probably other run-time factors.
 (defknown write-to-string
   (t &key (:escape t) (:radix t) (:base (integer 2 36)) (:readably t)
      (:circle t) (:pretty t) (:level (or unsigned-byte null))
@@ -1066,7 +1067,7 @@
      (:lines (or unsigned-byte null)) (:right-margin (or unsigned-byte null))
      (:miser-width (or unsigned-byte null)) (:pprint-dispatch t))
   simple-string
-  (foldable flushable explicit-check))
+  (flushable explicit-check))
 
 (defknown (prin1-to-string princ-to-string) (t) simple-string (flushable))
 
diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp
index 8de1bc5..946c1a5 100644
--- a/tests/print.impure.lisp
+++ b/tests/print.impure.lisp
@@ -168,6 +168,43 @@
       (*print-length* 12))
   (wexercise-0-8-7-interpreted "~@W")
   (wexercise-0-8-7-compiled-with-atsign))
+
+;;; WRITE-TO-STRING was erroneously DEFKNOWNed as FOLDABLE
+;;;
+;;; This bug from PFD
+(defpackage "SCRATCH-WRITE-TO-STRING" (:use))
+(with-standard-io-syntax
+  (let* ((*package* (find-package "SCRATCH-WRITE-TO-STRING"))
+	 (answer (write-to-string 'scratch-write-to-string::x :readably nil)))
+    (assert (string= answer "X"))))
+;;; and a couple from Bruno Haible
+(defun my-pprint-reverse (out list)
+  (write-char #\( out)
+  (when (setq list (reverse list))
+    (loop
+     (write (pop list) :stream out)
+     (when (endp list) (return))
+     (write-char #\Space out)))
+  (write-char #\) out))
+(with-standard-io-syntax
+  (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
+    (set-pprint-dispatch '(cons (member foo)) 'my-pprint-reverse 0)
+    (let ((answer (write-to-string '(foo bar :boo 1) :pretty t :escape t)))
+      (assert (string= answer "(1 :BOO BAR FOO)")))))
+(defun my-pprint-logical (out list)
+  (pprint-logical-block (out list :prefix "(" :suffix ")")
+    (when list
+      (loop
+       (write-char #\? out)
+       (write (pprint-pop) :stream out)
+       (write-char #\? out)
+       (pprint-exit-if-list-exhausted)
+       (write-char #\Space out)))))
+(with-standard-io-syntax
+  (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
+    (set-pprint-dispatch '(cons (member bar)) 'my-pprint-logical 0)
+    (let ((answer (write-to-string '(bar foo :boo 1) :pretty t :escape t)))
+      (assert (string= answer "(?BAR? ?FOO? ?:BOO? ?1?)")))))
 
 ;;; success
 (quit :unix-status 104)
diff --git a/version.lisp-expr b/version.lisp-expr
index e8e648a..4759316 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".)
-"0.8.10.7"
+"0.8.10.8"