From 7717fef2d28f273185838304a20bafe660a1fde2 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 11 Feb 2011 17:15:26 +0000 Subject: [PATCH] 1.0.45.15: make waitqueue printing prettier Fixes lp#673630: just print the name, if any. The token is an implementation detail, and can blow the stack if *print-circle* is not set. --- NEWS | 2 ++ src/code/target-thread.lisp | 4 ++++ tests/threads.pure.lisp | 11 +++++++++++ version.lisp-expr | 2 +- 4 files changed, 18 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 85c2bf7..052b422 100644 --- a/NEWS +++ b/NEWS @@ -4,6 +4,8 @@ changes relative to sbcl-1.0.45: lifetime analysis to overwrite closed-over variables (lp#681092). * bug fix: encoding errors from some multibyte external formats such as EUC-JP were not handled correctly (lp#713063). + * bug fix: printing waitqueue objects without setting *PRINT-CIRCLE* to T is now + safe (lp#673630). changes in sbcl-1.0.45 relative to sbcl-1.0.44: * enhancement: ~/ and ~user/ are treated specially in pathnames. diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 111f92b..1d8cdcd 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -527,6 +527,10 @@ IF-NOT-OWNER is :FORCE)." #!-sb-lutex (token nil)) +(def!method print-object ((waitqueue waitqueue) stream) + (print-unreadable-object (waitqueue stream :type t :identity t) + (format stream "~@[~A~]" (waitqueue-name waitqueue)))) + (defun make-waitqueue (&key name) #!+sb-doc "Create a waitqueue." diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp index bc2b94c..539d5de 100644 --- a/tests/threads.pure.lisp +++ b/tests/threads.pure.lisp @@ -157,6 +157,17 @@ (sb-ext:timeout () :timeout))))))) +;;;; Printing waitqueues + +(with-test (:name :waitqueue-circle-print) + (let* ((*print-circle* nil) + (lock (sb-thread:make-mutex)) + (wq (sb-thread:make-waitqueue))) + (sb-thread:with-recursive-lock (lock) + (sb-thread:condition-notify wq)) + ;; Used to blow stack due to recursive structure. + (assert (princ-to-string wq)))) + ;;;; SYMBOL-VALUE-IN-THREAD (with-test (:name symbol-value-in-thread.1) diff --git a/version.lisp-expr b/version.lisp-expr index cc5e097..fd17851 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -20,4 +20,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.45.14" +"1.0.45.15" -- 1.7.10.4