From 2a1df4bcc815f763fac346f32fbe535b39a0d2e1 Mon Sep 17 00:00:00 2001 From: trittweiler Date: Fri, 6 Nov 2009 22:07:57 +0000 Subject: [PATCH] 1.0.32.13: WITH-STANDARD-IO-SYNTAX must also bind *PRINT-PPRINT-DISPATCH*... ...'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 | 2 ++ package-data-list.lisp-expr | 1 + src/code/condition.lisp | 11 +++++++++++ src/code/globals.lisp | 1 + src/code/pprint.lisp | 29 +++++++++++++++++++++-------- src/code/print.lisp | 8 ++------ tests/pprint.impure.lisp | 9 +++++++++ tests/print.impure.lisp | 9 +++++++++ 8 files changed, 56 insertions(+), 14 deletions(-) diff --git a/NEWS b/NEWS index ff126ad..afdedd1 100644 --- a/NEWS +++ b/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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 4a457f5..01d4d37 100644 --- a/package-data-list.lisp-expr +++ b/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" diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 0e87f35..f9909cb 100644 --- a/src/code/condition.lisp +++ b/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) diff --git a/src/code/globals.lisp b/src/code/globals.lisp index 96183e0..261eea2 100644 --- a/src/code/globals.lisp +++ b/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* diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 9da5803..d0f7b57 100644 --- a/src/code/pprint.lisp +++ b/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,6 +950,11 @@ 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) @@ -956,6 +962,7 @@ line break." (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)) diff --git a/src/code/print.lisp b/src/code/print.lisp index 9e302d9..31b48ab 100644 --- a/src/code/print.lisp +++ b/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))) diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp index bf85bcf..2a98b0b 100644 --- a/tests/pprint.impure.lisp +++ b/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 diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp index 81cb0f3..7766b39 100644 --- a/tests/print.impure.lisp +++ b/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 -- 1.7.10.4