common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Don't rely on output-object to reenter pprint-logical-block.

Browse source 
Call the body twice, it may be printing something not related to the
object.
This commit is contained in:
Stas Boukarev 2025-04-04 20:10:17 +03:00
parent d86e11a1ee
commit 82aac49d63
3 changed files with 17 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/code/pprint.lisp
View file

@ -1463,7 +1463,7 @@ line break."
(output-object object stream)
(dx-let ((state (cons 0 stream)))
(if obj-supplied-p
(with-circularity-detection (object stream)
(with-circularity-detection (object stream state)
(descend-into (stream)
(start-logical-block stream prefix per-line-p suffix)
(funcall proc object state stream)

17
src/code/print.lisp
View file

@ -440,20 +440,20 @@ variable: an unreadable object representing the error is printed instead.")
(write-char #\= stream)
t)))))
(defmacro with-circularity-detection ((object stream) &body body)
(defmacro with-circularity-detection ((object stream state) &body body)
(with-unique-names (marker body-name)
`(labels ((,body-name ()
`(labels ((,body-name (stream ,state)
,@body))
(cond ((or (not *print-circle*)
(uniquely-identified-by-print-p ,object))
(,body-name))
(,body-name stream ,state))
(*circularity-hash-table*
(let ((,marker (check-for-circularity ,object t :logical-block)))
(cond (,marker
(when (handle-circularity ,marker ,stream)
(,body-name)))
(,body-name stream ,state)))
(t
(,body-name)
(,body-name stream ,state)
(when (and *print-circle-not-shared*
(eql (gethash ,object *circularity-hash-table*) :logical-block))
(if (listp ,object)
@ -466,13 +466,16 @@ variable: an unreadable object representing the error is printed instead.")
(remhash ,object *circularity-hash-table*)))))))
(t
(let ((*circularity-hash-table* (make-hash-table :test 'eq)))
(output-object ,object *null-broadcast-stream*)
(let ((stream (sb-pretty::make-pretty-stream *null-broadcast-stream*)))
(,body-name stream (cons 0 stream)))
(let ((*circularity-counter* 0))
(let ((,marker (check-for-circularity ,object t
:logical-block)))
(when ,marker
(handle-circularity ,marker ,stream)))
(,body-name))))))))
(,body-name stream ,state))))))))
;;;; level and length abbreviations

6
tests/pprint.pure.lisp
View file

@ -38,3 +38,9 @@
(vread (read-from-string vstring)))
(assert (equal list lread))
(assert (equalp vector vread)))))
(with-test (:name :logical-block-unrelated-object)
(assert (equal (with-output-to-string (s)
(let ((*print-circle* t))
(pprint-logical-block (s nil) (princ '(#1=(1) #1#) s))))
"(#1=(1) #1#)")))