* 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
: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))
(: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))
(*print-length* 12))
(wexercise-0-8-7-interpreted "~@W")
(wexercise-0-8-7-compiled-with-atsign))
+\f
+;;; 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)