1.0.17.33: fix PRINT-OBJECT cache

	We mustn't compute the cached cache too early, otherwise we'll
	cache effective methods before the actual methods (on RESTART
	and the two storage-condition classes) are defined.

diff --git a/src/code/error.lisp b/src/code/error.lisp
index 0e663cf..9078873 100644 (file)
--- a/src/code/error.lisp
+++ b/src/code/error.lisp
@@ -148,22 +148,35 @@
     (lambda (condition stream)
       (declare (ignore condition))
       (format stream
-             "Control stack exhausted (no more space for function call frames).  This is probably due to heavily nested or infinitely recursive function calls, or a tail call that SBCL cannot or has not optimized away."))))
+              ;; no pretty-printing, because that would use a lot of stack.
+              "Control stack exhausted (no more space for function call frames).
+This is probably due to heavily nested or infinitely recursive function
+calls, or a tail call that SBCL cannot or has not optimized away.
+
+PROCEED WITH CAUTION."))))
 
 (define-condition heap-exhausted-error (storage-condition)
   ()
   (:report
    (lambda (condition stream)
+     (declare (ignore condition))
      (declare (special *heap-exhausted-error-available-bytes*
                        *heap-exhausted-error-requested-bytes*))
      ;; See comments in interr.lisp -- there is a method to this madness.
      (if (and (boundp '*heap-exhausted-error-available-bytes*)
               (boundp '*heap-exhausted-error-requested-bytes*))
          (format stream
-                 "Heap exhausted: ~D bytes available, ~D requested. PROCEED WITH CAUTION!"
+                 ;; no pretty-printing, because that will use a lot of heap.
+                 "Heap exhausted (no more space for allocation).
+There are still ~D bytes available; the request was for ~D bytes.
+
+PROCEED WITH CAUTION."
                  *heap-exhausted-error-available-bytes*
                  *heap-exhausted-error-requested-bytes*)
-         (print-unreadable-object (condition stream))))))
+         (format stream
+                 "A ~S condition without bindings for heap statistics.  (If
+you did not expect to see this message, please report it."
+                 'heap-exhausted-error)))))
 
 (define-condition system-condition (condition)
   ((address :initarg :address :reader system-condition-address :initform nil)

diff --git a/src/code/interr.lisp b/src/code/interr.lisp
index 3f2a45d..7a48c43 100644 (file)
--- a/src/code/interr.lisp
+++ b/src/code/interr.lisp
@@ -474,9 +474,10 @@
      (error 'control-stack-exhausted))))
 
 ;;; KLUDGE: we keep a single HEAP-EXHAUSTED-ERROR object around, so
-;;; that we don't need to allocate it when running out of memory. Similarly
-;;; we pass the amounts in special variables as there may be multiple threads
-;;; running into trouble at the same time. The condition is created by GC-REINIT.
+;;; that we don't need to allocate it when running out of
+;;; memory. Similarly we pass the amounts in special variables as
+;;; there may be multiple threads running into trouble at the same
+;;; time. The condition is created by GC-REINIT.
 (defvar *heap-exhausted-error-condition*)
 (defvar *heap-exhausted-error-available-bytes*)
 (defvar *heap-exhausted-error-requested-bytes*)

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index b9515ed..3dc38cc 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -1567,11 +1567,19 @@
               (cond ((/= nkeys 1)
                      ;; KLUDGE: someone has defined a method
                      ;; specialized on the second argument: punt.
+                     (setf po-cache nil)
                      (make-initial-dfun gf))
                     (po-cache
                      (multiple-value-bind (dfun cache info)
                          (make-caching-dfun gf po-cache)
                        (set-dfun gf dfun cache info)))
+                    ;; the relevant PRINT-OBJECT methods get defined
+                    ;; late, by delayed DEF!METHOD.  We mustn't cache
+                    ;; the effective method for our classes earlier
+                    ;; than the relevant PRINT-OBJECT methods are
+                    ;; defined...
+                    ((boundp 'sb-impl::*delayed-def!method-args*)
+                     (make-initial-dfun gf))
                     (t (multiple-value-bind (dfun cache info)
                            (make-final-dfun-internal
                             gf

diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp
index 4f1b3f5..d1ccc01 100644 (file)
--- a/tests/print.impure.lisp
+++ b/tests/print.impure.lisp
@@ -433,4 +433,17 @@
 (assert (string= (format nil "~R" (expt 10 63)) "one vigintillion"))
 (assert (string= (format nil "~:R" (expt 10 63)) "one vigintillionth"))
 
+;;; too-clever cacheing for PRINT-OBJECT resulted in a bogus method
+;;; for printing RESTART objects.  Check also CONTROL-STACK-EXHAUSTED
+;;; and HEAP-EXHAUSTED-ERROR.
+(let ((result (with-output-to-string (*standard-output*)
+                (princ (find-restart 'abort)))))
+  (assert (string/= result "#<" :end1 2)))
+(let ((result (with-output-to-string (*standard-output*)
+                (princ (make-condition 'sb-kernel::control-stack-exhausted)))))
+  (assert (string/= result "#<" :end1 2)))
+(let ((result (with-output-to-string (*standard-output*)
+                (princ (make-condition 'sb-kernel::heap-exhausted-error)))))
+  (assert (string/= result "#<" :end1 2)))
+
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 5ae4f8e..ce46f54 100644 (file)
--- 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.17.32"
+"1.0.17.33"