From 90d05e4ae39a451ce13a25f4467d0d280ff49593 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 4 Dec 2008 19:02:08 +0000 Subject: [PATCH] 1.0.23.20: check for standard readtable modification * CLHS says that frobbing the standard readtable is undefined. * Patch by Tobias Ritterweiler. --- NEWS | 2 + package-data-list.lisp-expr | 1 + src/code/cold-init.lisp | 10 +- src/code/condition.lisp | 8 ++ src/code/reader.lisp | 215 +++++++++++++++++++++++-------------------- src/code/readtable.lisp | 2 +- tests/reader.impure.lisp | 34 +++++-- version.lisp-expr | 2 +- 8 files changed, 165 insertions(+), 109 deletions(-) diff --git a/NEWS b/NEWS index 18ebf92..58c0a8c 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,8 @@ ;;;; -*- coding: utf-8; -*- * new feature: SIMPLE-ARRAY-VECTOR provides access to the underlying data vector of an multidimensional SIMPLE-ARRAY. + * new feature: the system now signals a continuable error if standard + readtable modification is attempted. * optimization: faster generic arithmetic dispatch on x86 and x86-64. * bug fix: lexical type declarations are now correctly reported by SB-CLTL2. (reported by Larry D'Anna) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 42eea42..6cadbf0 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -885,6 +885,7 @@ possibly temporariliy, because it might be used internally." "TRY-RESTART" ;; error-signalling facilities + "STANDARD-READTABLE-MODIFIED-ERROR" "ARRAY-BOUNDING-INDICES-BAD-ERROR" "SEQUENCE-BOUNDING-INDICES-BAD-ERROR" diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index ef011a2..63362b7 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -240,10 +240,14 @@ ;; The reader and printer are initialized very late, so that they ;; can do hairy things like invoking the compiler as part of their ;; initialization. - (show-and-call !reader-cold-init) - (let ((*readtable* *standard-readtable*)) + (let ((*readtable* (make-readtable))) + (show-and-call !reader-cold-init) (show-and-call !sharpm-cold-init) - (show-and-call !backq-cold-init)) + (show-and-call !backq-cold-init) + ;; The *STANDARD-READTABLE* is assigned at last because the above + ;; functions would operate on the standard readtable otherwise--- + ;; which would result in an error. + (setf *standard-readtable* *readtable*)) (setf *readtable* (copy-readtable *standard-readtable*)) (setf sb!debug:*debug-readtable* (copy-readtable *standard-readtable*)) (sb!pretty:!pprint-cold-init) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index d7b2e4d..2169ccd 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -1185,6 +1185,14 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (simple-condition-format-arguments condition) (reader-impossible-number-error-error condition)))))) +(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")))) + (define-condition timeout (serious-condition) ((seconds :initarg :seconds :initform nil :reader timeout-seconds)) (:report (lambda (condition stream) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 0e7b589..4dba26e 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -26,10 +26,10 @@ (setf (fdocumentation '*readtable* 'variable) "Variable bound to current readtable.") -;;; a standard Lisp readtable. This is for recovery from broken -;;; read-tables (and for WITH-STANDARD-IO-SYNTAX), and should not -;;; normally be user-visible. -(defvar *standard-readtable*) +;;; A standard Lisp readtable (once cold-init is through). This is for +;;; recovery from broken read-tables (and for +;;; WITH-STANDARD-IO-SYNTAX), and should not normally be user-visible. +(defvar *standard-readtable* nil) (defvar *old-package* nil #!+sb-doc @@ -192,13 +192,25 @@ (elt *constituent-trait-table* (char-code char)) +char-attr-constituent+)) -;;;; readtable operations +;;;; Readtable Operations + +(defun assert-not-standard-readtable (readtable operation) + (when (eq readtable *standard-readtable*) + (cerror "Frob it anyway!" 'standard-readtable-modified-error + :operation operation))) + +(defun readtable-case (readtable) + (%readtable-case readtable)) + +(defun (setf readtable-case) (case readtable) + (assert-not-standard-readtable readtable '(setf readtable-case)) + (setf (%readtable-case readtable) case)) (defun shallow-replace/eql-hash-table (to from) (maphash (lambda (k v) (setf (gethash k to) v)) from)) -(defun copy-readtable (&optional (from-readtable *readtable*) - to-readtable) +(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable) + (assert-not-standard-readtable to-readtable 'copy-readtable) (let ((really-from-readtable (or from-readtable *standard-readtable*)) (really-to-readtable (or to-readtable (make-readtable)))) (replace (character-attribute-array really-to-readtable) @@ -223,11 +235,12 @@ really-to-readtable)) (defun set-syntax-from-char (to-char from-char &optional - (to-readtable *readtable*) (from-readtable ())) + (to-readtable *readtable*) (from-readtable nil)) #!+sb-doc "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 to the standard Lisp readtable when NIL." + (assert-not-standard-readtable to-readtable 'set-syntax-from-char) (let ((really-from-readtable (or from-readtable *standard-readtable*))) (let ((att (get-cat-entry from-char really-from-readtable)) (mac (get-raw-cmt-entry from-char really-from-readtable)) @@ -252,12 +265,13 @@ standard Lisp readtable when NIL." (defun set-macro-character (char function &optional (non-terminatingp nil) - (readtable *readtable*)) + (rt-designator *readtable*)) #!+sb-doc "Causes CHAR to be a macro character which invokes FUNCTION when seen by the reader. The NON-TERMINATINGP flag can be used to make the macro character non-terminating, i.e. embeddable in a symbol name." - (let ((designated-readtable (or readtable *standard-readtable*))) + (let ((designated-readtable (or rt-designator *standard-readtable*))) + (assert-not-standard-readtable designated-readtable 'set-macro-character) (set-cat-entry char (if non-terminatingp +char-attr-constituent+ +char-attr-terminating-macro+) @@ -265,13 +279,13 @@ standard Lisp readtable when NIL." (set-cmt-entry char function designated-readtable) t)) ; (ANSI-specified return value) -(defun get-macro-character (char &optional (readtable *readtable*)) +(defun get-macro-character (char &optional (rt-designator *readtable*)) #!+sb-doc "Return the function associated with the specified CHAR which is a macro character, or NIL if there is no such function. As a second value, return T if CHAR is a macro character which is non-terminating, i.e. which can be embedded in a symbol name." - (let* ((designated-readtable (or readtable *standard-readtable*)) + (let* ((designated-readtable (or rt-designator *standard-readtable*)) ;; the first return value: a FUNCTION if CHAR is a macro ;; character, or NIL otherwise (fun-value (get-raw-cmt-entry char designated-readtable))) @@ -285,6 +299,61 @@ standard Lisp readtable when NIL." ;; I.e. this value means not just "non-terminating ;; character?" but "non-terminating macro character?". nil)))) + + +(defun make-char-dispatch-table () + (make-hash-table)) + +(defun make-dispatch-macro-character (char &optional + (non-terminating-p nil) + (rt *readtable*)) + #!+sb-doc + "Cause CHAR to become a dispatching macro character in readtable (which + defaults to the current readtable). If NON-TERMINATING-P, the char will + be non-terminating." + ;; Checks already for standard readtable modification. + (set-macro-character char #'read-dispatch-char non-terminating-p rt) + (let* ((dalist (dispatch-tables rt)) + (dtable (cdr (find char dalist :test #'char= :key #'car)))) + (cond (dtable + (error "The dispatch character ~S already exists." char)) + (t + (setf (dispatch-tables rt) + (push (cons char (make-char-dispatch-table)) dalist))))) + t) + +(defun set-dispatch-macro-character (disp-char sub-char function + &optional (rt-designator *readtable*)) + #!+sb-doc + "Cause FUNCTION to be called whenever the reader reads DISP-CHAR + followed by SUB-CHAR." + ;; Get the dispatch char for macro (error if not there), diddle + ;; entry for sub-char. + (let* ((sub-char (char-upcase sub-char)) + (readtable (or rt-designator *standard-readtable*))) + (assert-not-standard-readtable readtable 'set-dispatch-macro-character) + (when (digit-char-p sub-char) + (error "SUB-CHAR must not be a decimal digit: ~S" sub-char)) + (let ((dpair (find disp-char (dispatch-tables readtable) + :test #'char= :key #'car))) + (if dpair + (setf (gethash sub-char (cdr dpair)) (coerce function 'function)) + (error "~S is not a dispatch char." disp-char)))) + t) + +(defun get-dispatch-macro-character (disp-char sub-char + &optional (rt-designator *readtable*)) + #!+sb-doc + "Return the macro character function for SUB-CHAR under DISP-CHAR + or NIL if there is no associated function." + (let* ((sub-char (char-upcase sub-char)) + (readtable (or rt-designator *standard-readtable*)) + (dpair (find disp-char (dispatch-tables readtable) + :test #'char= :key #'car))) + (if dpair + (values (gethash sub-char (cdr dpair))) + (error "~S is not a dispatch char." disp-char)))) + ;;;; definitions to support internal programming conventions @@ -328,44 +397,45 @@ standard Lisp readtable when NIL." ;;;; temporary initialization hack +;; Install the (easy) standard macro-chars into *READTABLE*. (defun !cold-init-standard-readtable () - (setq *standard-readtable* (make-readtable)) + (/show0 "entering !cold-init-standard-readtable") ;; All characters get boring defaults in MAKE-READTABLE. Now we ;; override the boring defaults on characters which need more ;; interesting behavior. - (let ((*readtable* *standard-readtable*)) - - (flet ((whitespaceify (char) - (set-cmt-entry char nil) - (set-cat-entry char +char-attr-whitespace+))) - (whitespaceify (code-char tab-char-code)) - (whitespaceify #\Newline) - (whitespaceify #\Space) - (whitespaceify (code-char form-feed-char-code)) - (whitespaceify (code-char return-char-code))) - - (set-cat-entry #\\ +char-attr-single-escape+) - (set-cmt-entry #\\ nil) - - (set-cat-entry #\| +char-attr-multiple-escape+) - (set-cmt-entry #\| nil) - - ;; Easy macro-character definitions are in this source file. - (set-macro-character #\" #'read-string) - (set-macro-character #\' #'read-quote) - (set-macro-character #\( #'read-list) - (set-macro-character #\) #'read-right-paren) - (set-macro-character #\; #'read-comment) - ;; (The hairier macro-character definitions, for #\# and #\`, are - ;; defined elsewhere, in their own source files.) - - ;; all constituents - (do ((ichar 0 (1+ ichar)) - (char)) - ((= ichar base-char-code-limit)) - (setq char (code-char ichar)) - (when (constituentp char *standard-readtable*) - (set-cmt-entry char nil))))) + (flet ((whitespaceify (char) + (set-cmt-entry char nil) + (set-cat-entry char +char-attr-whitespace+))) + (whitespaceify (code-char tab-char-code)) + (whitespaceify #\Newline) + (whitespaceify #\Space) + (whitespaceify (code-char form-feed-char-code)) + (whitespaceify (code-char return-char-code))) + + (set-cat-entry #\\ +char-attr-single-escape+) + (set-cmt-entry #\\ nil) + + (set-cat-entry #\| +char-attr-multiple-escape+) + (set-cmt-entry #\| nil) + + ;; Easy macro-character definitions are in this source file. + (set-macro-character #\" #'read-string) + (set-macro-character #\' #'read-quote) + (set-macro-character #\( #'read-list) + (set-macro-character #\) #'read-right-paren) + (set-macro-character #\; #'read-comment) + ;; (The hairier macro-character definitions, for #\# and #\`, are + ;; defined elsewhere, in their own source files.) + + ;; all constituents + (do ((ichar 0 (1+ ichar)) + (char)) + ((= ichar base-char-code-limit)) + (setq char (code-char ichar)) + (when (constituentp char) + (set-cmt-entry char nil))) + + (/show0 "leaving !cold-init-standard-readtable")) ;;;; implementation of the read buffer @@ -1416,10 +1486,7 @@ variables to allow for nested and thread safe reading." :format-control "failed to build ratio"))))) (if negative-number (- num) num)))) -;;;; cruft for dispatch macros - -(defun make-char-dispatch-table () - (make-hash-table)) +;;;; General reader for dispatch macros (defun dispatch-char-error (stream sub-char ignore) (declare (ignore ignore)) @@ -1429,54 +1496,6 @@ variables to allow for nested and thread safe reading." "no dispatch function defined for ~S" sub-char))) -(defun make-dispatch-macro-character (char &optional - (non-terminating-p nil) - (rt *readtable*)) - #!+sb-doc - "Cause CHAR to become a dispatching macro character in readtable (which - defaults to the current readtable). If NON-TERMINATING-P, the char will - be non-terminating." - (set-macro-character char #'read-dispatch-char non-terminating-p rt) - (let* ((dalist (dispatch-tables rt)) - (dtable (cdr (find char dalist :test #'char= :key #'car)))) - (cond (dtable - (error "The dispatch character ~S already exists." char)) - (t - (setf (dispatch-tables rt) - (push (cons char (make-char-dispatch-table)) dalist))))) - t) - -(defun set-dispatch-macro-character (disp-char sub-char function - &optional (rt *readtable*)) - #!+sb-doc - "Cause FUNCTION to be called whenever the reader reads DISP-CHAR - followed by SUB-CHAR." - ;; Get the dispatch char for macro (error if not there), diddle - ;; entry for sub-char. - (when (digit-char-p sub-char) - (error "SUB-CHAR must not be a decimal digit: ~S" sub-char)) - (let* ((sub-char (char-upcase sub-char)) - (rt (or rt *standard-readtable*)) - (dpair (find disp-char (dispatch-tables rt) - :test #'char= :key #'car))) - (if dpair - (setf (gethash sub-char (cdr dpair)) (coerce function 'function)) - (error "~S is not a dispatch char." disp-char)) - t)) - -(defun get-dispatch-macro-character (disp-char sub-char - &optional (rt *readtable*)) - #!+sb-doc - "Return the macro character function for SUB-CHAR under DISP-CHAR - or NIL if there is no associated function." - (let* ((sub-char (char-upcase sub-char)) - (rt (or rt *standard-readtable*)) - (dpair (find disp-char (dispatch-tables rt) - :test #'char= :key #'car))) - (if dpair - (values (gethash sub-char (cdr dpair))) - (error "~S is not a dispatch char." disp-char)))) - (defun read-dispatch-char (stream char) ;; Read some digits. (let ((numargp nil) diff --git a/src/code/readtable.lisp b/src/code/readtable.lisp index df09521..a033074 100644 --- a/src/code/readtable.lisp +++ b/src/code/readtable.lisp @@ -83,4 +83,4 @@ ;; an alist from dispatch characters to hash-tables akin to ;; CHARACTER-MACRO-HASH-TABLE. (dispatch-tables () :type list) - (readtable-case :upcase :type (member :upcase :downcase :preserve :invert))) + (%readtable-case :upcase :type (member :upcase :downcase :preserve :invert))) diff --git a/tests/reader.impure.lisp b/tests/reader.impure.lisp index 02f202d..e3782b8 100644 --- a/tests/reader.impure.lisp +++ b/tests/reader.impure.lisp @@ -125,13 +125,35 @@ (funcall fun) (assert (equal '(:ok) (read-from-string "{:ok)")))) +(with-test (:name standard-readtable-modified) + (macrolet ((test (form &optional op) + `(assert + (eq :error + (handler-case + (progn ,form t) + (sb-int:standard-readtable-modified-error (e) + ,@(when op + `((assert + (equal ,op (sb-kernel::standard-readtable-modified-operation e))))) + :error)))))) + (let ((rt *readtable*)) + (with-standard-io-syntax + (let ((srt *readtable*)) + (test (setf (readtable-case srt) :preserve) '(setf readtable-case)) + (test (copy-readtable rt srt) 'copy-readtable) + (test (set-syntax-from-char #\a #\a srt rt) 'set-syntax-from-char) + (test (set-macro-character #\a (constantly t) t srt) 'set-macro-character) + (test (make-dispatch-macro-character #\! t srt)) + (test (set-dispatch-macro-character #\# #\a (constantly t) srt) 'set-dispatch-macro-character)))))) + ;;; THIS SHOULD BE LAST as it frobs the standard readtable (with-test (:name set-macro-character-nil) - (let ((fun (lambda (&rest args) 'ok))) - ;; NIL means the standard readtable. - (assert (eq t (set-macro-character #\~ fun nil nil))) - (assert (eq fun (get-macro-character #\~ nil))) - (assert (eq t (set-dispatch-macro-character #\# #\~ fun nil))) - (assert (eq fun (get-dispatch-macro-character #\# #\~ nil))))) + (handler-bind ((sb-int:standard-readtable-modified-error #'continue)) + (let ((fun (lambda (&rest args) 'ok))) + ;; NIL means the standard readtable. + (assert (eq t (set-macro-character #\~ fun nil nil))) + (assert (eq fun (get-macro-character #\~ nil))) + (assert (eq t (set-dispatch-macro-character #\# #\~ fun nil))) + (assert (eq fun (get-dispatch-macro-character #\# #\~ nil)))))) ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 947390a..9e69c58 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.23.19" +"1.0.23.20" -- 1.7.10.4