This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 00844093cfc536936a1797bfbfa910ab1e4db7fe (commit) from f5250810f8507020e2479dd1ecb600a6fe710f78 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 00844093cfc536936a1797bfbfa910ab1e4db7fe Author: Raymond Toy <toy.raymond@gmail.com> Date: Sat Feb 23 18:14:18 2013 -0800 Fix ticket:73 error.lisp:: * Create two new conditions, one for modifying the readtable and one for the pprint dispatch table. exports.lisp:: * Export the two new conditions. pprint.lisp:: * Add check to SET-PPRINT-DISPATCH to disallow modifying the standard pprint dispatch table. * Allow PPRINT-INIT to modify the standard pprint dispatch table. print.lisp:: * In WITH-STANDARD-IO-SYNTAX, don't copy a new dispatch table; bind *print-pprint-dispatch* to the standard table. reader.lisp:: * Add check to disallow modifying the standard readtable. * Allow INIT-STD-LISP-READTABLE to modify the standard readtable. diff --git a/src/code/error.lisp b/src/code/error.lisp index 2678d22..5b72100 100644 --- a/src/code/error.lisp +++ b/src/code/error.lisp @@ -1203,6 +1203,27 @@ `(handler-case (progn ,@forms) (error (condition) (values nil condition)))) + +;;;; Reader + +(define-condition standard-readtable-modified-error (reference-condition error) + ((operation :initarg :operation + :reader standard-readtable-modified-operation)) + (:report (lambda (condition stream) + (format stream "~S would modify the standard readtable." + (standard-readtable-modified-operation condition)))) + (:default-initargs :references `((:ansi-cl :section (2 1 1 2)) + (:ansi-cl :glossary "standard readtable")))) + +;;;; Pprint dispatch + +(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"))))  ;;;; Restart definitions. @@ -1249,3 +1270,4 @@ (define-nil-returning-restart use-value (value) "Transfer control and value to a restart named use-value, returning nil if none exists.") + diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 3e9631b..2c3e0ff 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -2321,7 +2321,9 @@ "%COMPLEX-SINGLE-FLOAT" "%COMPLEX-DOUBLE-FLOAT" - "%COMPLEX-DOUBLE-DOUBLE-FLOAT") + "%COMPLEX-DOUBLE-DOUBLE-FLOAT" + "STANDARD-READTABLE-MODIFIED-ERROR" + "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR") #+heap-overflow-check (:export "DYNAMIC-SPACE-OVERFLOW-WARNING-HIT" "DYNAMIC-SPACE-OVERFLOW-ERROR-HIT" diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index d1f570f..15eafc0 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -1223,11 +1223,17 @@ When annotations are present, invoke them at the right positions." (output-ugly-object object stream)) nil)))) +(defun assert-not-standard-pprint-dispatch-table (pprint-dispatch operation) + (when (eq pprint-dispatch *initial-pprint-dispatch*) + (cerror "Modify 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 symbol function) function) (type real priority) (type pprint-dispatch-table table)) + (assert-not-standard-pprint-dispatch-table table 'set-pprint-dispatch) (if function (if (cons-type-specifier-p type) (setf (gethash (second (second type)) @@ -1952,18 +1958,25 @@ When annotations are present, invoke them at the right positions." (setf *initial-pprint-dispatch* (make-pprint-dispatch-table)) (let ((*print-pprint-dispatch* *initial-pprint-dispatch*) (*building-initial-table* t)) - ;; Printers for regular types. - (set-pprint-dispatch 'array #'pprint-array) - (set-pprint-dispatch '(cons (and symbol (satisfies fboundp))) - #'pprint-function-call -1) - (set-pprint-dispatch 'cons #'pprint-fill -2) - ;; Cons cells with interesting things for the car. - (dolist (magic-form *magic-forms*) - (set-pprint-dispatch `(cons (eql ,(first magic-form))) - (symbol-function (second magic-form)))) - ;; Other pretty-print init forms. - (lisp::backq-pp-init) - (loop-pp-init)) + (handler-bind + ((standard-pprint-dispatch-table-modified-error + (lambda (c) + (declare (ignore c)) + ;; Of course, we want to be able to modify the standard + ;; pprint dispatch table here! + (invoke-restart 'kernel::continue)))) + ;; Printers for regular types. + (set-pprint-dispatch 'array #'pprint-array) + (set-pprint-dispatch '(cons (and symbol (satisfies fboundp))) + #'pprint-function-call -1) + (set-pprint-dispatch 'cons #'pprint-fill -2) + ;; Cons cells with interesting things for the car. + (dolist (magic-form *magic-forms*) + (set-pprint-dispatch `(cons (eql ,(first magic-form))) + (symbol-function (second magic-form)))) + ;; Other pretty-print init forms. + (lisp::backq-pp-init) + (loop-pp-init))) (setf *print-pprint-dispatch* (copy-pprint-dispatch nil)) (setf *pretty-printer* #'output-pretty-object) diff --git a/src/code/print.lisp b/src/code/print.lisp index 3f162d7..aae2e0b 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -115,7 +115,7 @@ (*print-level* nil) (*print-lines* nil) (*print-miser-width* nil) - (*print-pprint-dispatch* (copy-pprint-dispatch nil)) + (*print-pprint-dispatch* pp::*initial-pprint-dispatch*) (*print-pretty* nil) (*print-radix* nil) (*print-readably* t) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index de666d1..3b4d06b 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -461,8 +461,14 @@  ;;;; Readtable operations. +(defun assert-not-standard-readtable (readtable operation) + (when (eq readtable std-lisp-readtable) + (cerror "Modify it anyway." 'kernel:standard-readtable-modified-error + :operation operation))) + (defun copy-readtable (&optional (from-readtable *readtable*) to-readtable) "A copy is made of from-readtable and place into to-readtable." + (assert-not-standard-readtable to-readtable 'copy-readtable) (let ((from-readtable (or from-readtable std-lisp-readtable)) (to-readtable (or to-readtable (make-readtable)))) (flet ((copy-hash-table (to from) @@ -495,6 +501,7 @@ "Causes the syntax of to-char to be the same as from-char in the optional readtable (defaults to the current readtable). The from-table defaults the standard lisp readtable by being nil." + (assert-not-standard-readtable to-readtable 'set-syntax-from-char) (let ((from-readtable (or from-readtable std-lisp-readtable))) ;;copy from-char entries to to-char entries, but make sure that if ;;from char is a constituent you don't copy non-movable secondary @@ -538,10 +545,12 @@ make the macro character non-terminating. The optional readtable argument defaults to the current readtable. Set-macro-character returns T." - (if non-terminatingp - (set-cat-entry char (get-secondary-attribute char) rt) - (set-cat-entry char #.terminating-macro rt)) - (set-cmt-entry char function rt) + (let ((designated-readtable (or rt std-lisp-readtable))) + (assert-not-standard-readtable designated-readtable 'set-macro-character) + (if non-terminatingp + (set-cat-entry char (get-secondary-attribute char) designated-readtable) + (set-cat-entry char #.terminating-macro designated-readtable)) + (set-cmt-entry char function designated-readtable)) T) (defun get-macro-character (char &optional (rt *readtable*)) @@ -595,46 +604,54 @@ (setq std-lisp-readtable (make-readtable)) ;;all characters default to "constituent" in make-readtable ;;*** un-constituent-ize some of these *** - (let ((*readtable* std-lisp-readtable)) - (set-cat-entry #\tab #.whitespace) - (set-cat-entry #\linefeed #.whitespace) - (set-cat-entry #\space #.whitespace) - (set-cat-entry #\page #.whitespace) - (set-cat-entry #\return #.whitespace) - (set-cat-entry #\\ #.escape) - (set-cat-entry #\| #.multiple-escape) - (set-cmt-entry #\\ #'read-token) - (set-cmt-entry #\: #'read-token) - (set-cmt-entry #\| #'read-token) - ;;macro definitions - (set-macro-character #\" #'read-string) - ;;* # macro - (set-macro-character #\' #'read-quote) - (set-macro-character #\( #'read-list) - (set-macro-character #\) #'read-right-paren) - (set-macro-character #\; #'read-comment) - ;;* backquote - ;;all constituents - (do ((ichar 0 (1+ ichar)) - (len #+unicode-bootstrap #o200 - #-unicode-bootstrap char-code-limit)) - ((= ichar len)) - (let ((char (code-char ichar))) - #-unicode - (when (constituentp char std-lisp-readtable) - (set-cat-entry char (get-secondary-attribute char)) - (set-cmt-entry char #'read-token)) - #+unicode - (cond ((constituentp char std-lisp-readtable) - (set-cat-entry char (get-secondary-attribute char)) - (when (< ichar attribute-table-limit) - ;; The hashtable default in get-cmt-entry returns - ;; #'read-token, so don't need to set it here. - (set-cmt-entry char #'read-token))) - ((>= ichar attribute-table-limit) - ;; A non-constituent character that would be stored in - ;; the hash table gets #'undefined-macro-char. - (set-cmt-entry char #'undefined-macro-char))))))) + (handler-bind + ((standard-readtable-modified-error + (lambda (c) + (declare (ignore c)) + ;; Of course, we want to be able to modify the standard + ;; readtable here! + (invoke-restart 'kernel::continue)))) + (let ((*readtable* std-lisp-readtable) + (*assert-not-standard-readtable* nil)) + (set-cat-entry #\tab #.whitespace) + (set-cat-entry #\linefeed #.whitespace) + (set-cat-entry #\space #.whitespace) + (set-cat-entry #\page #.whitespace) + (set-cat-entry #\return #.whitespace) + (set-cat-entry #\\ #.escape) + (set-cat-entry #\| #.multiple-escape) + (set-cmt-entry #\\ #'read-token) + (set-cmt-entry #\: #'read-token) + (set-cmt-entry #\| #'read-token) + ;;macro definitions + (set-macro-character #\" #'read-string) + ;;* # macro + (set-macro-character #\' #'read-quote) + (set-macro-character #\( #'read-list) + (set-macro-character #\) #'read-right-paren) + (set-macro-character #\; #'read-comment) + ;;* backquote + ;;all constituents + (do ((ichar 0 (1+ ichar)) + (len #+unicode-bootstrap #o200 + #-unicode-bootstrap char-code-limit)) + ((= ichar len)) + (let ((char (code-char ichar))) + #-unicode + (when (constituentp char std-lisp-readtable) + (set-cat-entry char (get-secondary-attribute char)) + (set-cmt-entry char #'read-token)) + #+unicode + (cond ((constituentp char std-lisp-readtable) + (set-cat-entry char (get-secondary-attribute char)) + (when (< ichar attribute-table-limit) + ;; The hashtable default in get-cmt-entry returns + ;; #'read-token, so don't need to set it here. + (set-cmt-entry char #'read-token))) + ((>= ichar attribute-table-limit) + ;; A non-constituent character that would be stored in + ;; the hash table gets #'undefined-macro-char. + (set-cmt-entry char #'undefined-macro-char))))))))  ----------------------------------------------------------------------- Summary of changes: src/code/error.lisp | 22 ++++++++++ src/code/exports.lisp | 4 +- src/code/pprint.lisp | 37 ++++++++++++------ src/code/print.lisp | 2 +- src/code/reader.lisp | 105 ++++++++++++++++++++++++++++-------------------- 5 files changed, 112 insertions(+), 58 deletions(-) hooks/post-receive -- CMU Common Lisp