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 (file)
--- a/src/code/error.lisp
+++ b/src/code/error.lisp
@@ -1203,6 +1203,27 @@
   `(handler-case (progn ,@forms)
      (error (condition) (values nil condition))))
 
+\f
+;;;; 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"))))
 
 \f
 ;;;; 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -461,8 +461,14 @@
 \f
 ;;;; 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))))))))
 
 
 \f