[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2013-02-20-g0084409
Raymond Toy
rtoy at common-lisp.net
Sun Feb 24 02:14:40 UTC 2013
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 at 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 , at 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
More information about the cmucl-cvs
mailing list