1.0.32.13: WITH-STANDARD-IO-SYNTAX must also bind *PRINT-PPRINT-DISPA…

…TCH*...

...'cuz CLHS says so. We bind it to the standard pprint dispatch
table, and guard against its modification in SET-PPRINT-DISPATCH,
mimicking the guard against modification of the standard readtable
introduced in 1.0.24.

NEWS

@@ -21,6 +21,8 @@ changes relative to sbcl-1.0.32:
   * bug fix: inspecting closures is less likely to fail with a type error.
   * bug fix: no timer starvation when setting the system clock back.
     (launchpad bug #460283)
+  * bug fix: WITH-STANDARD-IO-SYNTAX now binds *PRINT-PPRINT-DISPATCH* to the
+    standard pprint dispatch table as specified by CLHS.
 
 changes in sbcl-1.0.32 relative to sbcl-1.0.31:
   * optimization: faster FIND and POSITION on strings of unknown element type

package-data-list.lisp-expr

@@ -904,6 +904,7 @@ possibly temporariliy, because it might be used internally."
 
                ;; error-signalling facilities
                "STANDARD-READTABLE-MODIFIED-ERROR"
+               "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR"
                "ARRAY-BOUNDING-INDICES-BAD-ERROR"
                "SEQUENCE-BOUNDING-INDICES-BAD-ERROR"
                "SPECIAL-FORM-FUNCTION"

src/code/condition.lisp

@@ -1203,6 +1203,17 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
   (:default-initargs :references `((:ansi-cl :section (2 1 1 2))
                                    (:ansi-cl :glossary "standard readtable"))))
 
+(define-condition standard-pprint-dispatch-table-modified-error
+    (reference-condition error)
+  ((operation :initarg :operation
+              :reader standard-pprint-dispatch-table-modified-operation))
+  (:report (lambda (condition stream)
+             (format stream "~S would modify the standard pprint dispatch table."
+                     (standard-pprint-dispatch-table-modified-operation
+                      condition))))
+  (:default-initargs
+      :references `((:ansi-cl :glossary "standard pprint dispatch table"))))
+
 (define-condition timeout (serious-condition)
   ((seconds :initarg :seconds :initform nil :reader timeout-seconds))
   (:report (lambda (condition stream)

src/code/globals.lisp

@@ -18,6 +18,7 @@
 (declaim (special *keyword-package* *cl-package*
                   original-lisp-environment
                   *standard-readtable*
+                  sb!pretty::*standard-pprint-dispatch-table*
                   sb!debug:*in-the-debugger*
                   sb!debug:*stack-top-hint*
                   *handler-clusters*

src/code/pprint.lisp

@@ -813,7 +813,8 @@ line break."
 
 ;;;; pprint-dispatch tables
 
-(defvar *initial-pprint-dispatch*)
+(defvar *standard-pprint-dispatch-table*)
+(defvar *initial-pprint-dispatch-table*)
 (defvar *building-initial-table* nil)
 
 (defstruct (pprint-dispatch-entry (:copier nil))
@@ -868,7 +869,7 @@ line break."
                             ,x))))
   (defvar *precompiled-pprint-dispatch-funs*
     (list (frob array (typep object 'array))
-          (frob sharp-function (and (consp object)
+          (frob function-call (and (consp object)
                                     (symbolp (car object))
                                     (fboundp (car object))))
           (frob cons (typep object 'cons)))))
@@ -920,7 +921,7 @@ line break."
 
 (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
   (declare (type (or pprint-dispatch-table null) table))
-  (let* ((orig (or table *initial-pprint-dispatch*))
+  (let* ((orig (or table *initial-pprint-dispatch-table*))
          (new (make-pprint-dispatch-table
                :entries (copy-list (pprint-dispatch-table-entries orig))))
          (new-cons-entries (pprint-dispatch-table-cons-entries new)))
@@ -931,7 +932,7 @@ line break."
 
 (defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
   (declare (type (or pprint-dispatch-table null) table))
-  (let* ((table (or table *initial-pprint-dispatch*))
+  (let* ((table (or table *initial-pprint-dispatch-table*))
          (cons-entry
           (and (consp object)
                (gethash (car object)
@@ -949,13 +950,19 @@ line break."
                   (output-ugly-object object stream))
                 nil))))
 
+(defun assert-not-standard-pprint-dispatch-table (pprint-dispatch operation)
+  (when (eq pprint-dispatch *standard-pprint-dispatch-table*)
+    (cerror "Frob it anyway!" 'standard-pprint-dispatch-table-modified-error
+            :operation operation)))
+
 (defun set-pprint-dispatch (type function &optional
                             (priority 0) (table *print-pprint-dispatch*))
   (declare (type (or null callable) function)
            (type real priority)
            (type pprint-dispatch-table table))
   (/show0 "entering SET-PPRINT-DISPATCH, TYPE=...")
   (/hexstr type)
+  (assert-not-standard-pprint-dispatch-table table 'set-pprint-dispatch)
   (if function
       (if (cons-type-specifier-p type)
           (setf (gethash (second (second type))
@@ -1455,10 +1462,14 @@ line break."
 
 (defun !pprint-cold-init ()
   (/show0 "entering !PPRINT-COLD-INIT")
-  (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
-  (let ((*print-pprint-dispatch* *initial-pprint-dispatch*)
+  ;; Kludge: We set *STANDARD-PP-D-TABLE* to a new table even though
+  ;; it's going to be set to a copy of *INITIAL-PP-D-T* below because
+  ;; it's used in WITH-STANDARD-IO-SYNTAX, and condition reportery
+  ;; possibly performed in the following extent may use W-S-IO-SYNTAX.
+  (setf *standard-pprint-dispatch-table* (make-pprint-dispatch-table))
+  (setf *initial-pprint-dispatch-table*  (make-pprint-dispatch-table))
+  (let ((*print-pprint-dispatch* *initial-pprint-dispatch-table*)
         (*building-initial-table* t))
-    ;; printers for regular types
     (/show0 "doing SET-PPRINT-DISPATCH for regular types")
     (set-pprint-dispatch 'array #'pprint-array)
     (set-pprint-dispatch '(cons (and symbol (satisfies mboundp)))
@@ -1568,5 +1579,7 @@ line break."
     (sb!impl::!backq-pp-cold-init)
     (/show0 "leaving !PPRINT-COLD-INIT"))
 
-  (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
+  (setf *standard-pprint-dispatch-table*
+        (copy-pprint-dispatch *initial-pprint-dispatch-table*))
+  (setf *print-pprint-dispatch* *initial-pprint-dispatch-table*)
   (setf *print-pretty* t))

src/code/print.lisp

@@ -86,6 +86,7 @@
        *PRINT-LEVEL*                    NIL
        *PRINT-LINES*                    NIL
        *PRINT-MISER-WIDTH*              NIL
+       *PRINT-PPRINT-DISPATCH*          the standard pprint dispatch table
        *PRINT-PRETTY*                   NIL
        *PRINT-RADIX*                    NIL
        *PRINT-READABLY*                 T
@@ -110,6 +111,7 @@
         (*print-level* nil)
         (*print-lines* nil)
         (*print-miser-width* nil)
+        (*print-pprint-dispatch* sb!pretty::*standard-pprint-dispatch-table*)
         (*print-pretty* nil)
         (*print-radix* nil)
         (*print-readably* t)
@@ -118,12 +120,6 @@
         (*read-default-float-format* 'single-float)
         (*read-eval* t)
         (*read-suppress* nil)
-        ;; FIXME: It doesn't seem like a good idea to expose our
-        ;; disaster-recovery *STANDARD-READTABLE* here. What if some
-        ;; enterprising user corrupts the disaster-recovery readtable
-        ;; by doing destructive readtable operations within
-        ;; WITH-STANDARD-IO-SYNTAX? Perhaps we should do a
-        ;; COPY-READTABLE? The consing would be unfortunate, though.
         (*readtable* *standard-readtable*))
     (funcall function)))
 

tests/pprint.impure.lisp

@@ -206,5 +206,14 @@
   (with-open-stream (null (make-broadcast-stream))
     (pprint '(defpackage :foo nil))
     (pprint '(defpackage :foo 42))))
+
+(with-test (:name :standard-pprint-dispatch-modified)
+  (assert
+   (eq :error
+       (handler-case (with-standard-io-syntax
+                       (set-pprint-dispatch 'symbol (constantly nil))
+                       :no-error)
+         (sb-int:standard-pprint-dispatch-table-modified-error ()
+           :error)))))
 
 ;;; success

tests/print.impure.lisp

@@ -447,4 +447,13 @@
                 (princ (make-condition 'sb-kernel::heap-exhausted-error)))))
   (assert (string/= result "#<" :end1 2)))
 
+(with-test (:name (:with-standard-io-syntax :bind-print-pprint-dispatch))
+  (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)))
+    (set-pprint-dispatch 'symbol #'(lambda (stream obj)
+                                     (declare (ignore obj))
+                                     (write-string "FOO" stream)))
+    (with-standard-io-syntax
+      (let ((*print-pretty* t))
+        (assert (string= (princ-to-string 'bar) "BAR"))))))
+
 ;;; success