From 42702bd5e2af3e0042c9f27372c6f5d92335df12 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sun, 16 Sep 2007 12:05:16 +0000 Subject: [PATCH] 1.0.9.60: partial fix for bug in STREAM-ERROR :REPORT * added a new (partially #+NILed out) test case for a bug in STREAM-ERROR :REPORT, where it expects STREAM-ERROR to have SIMPLE-CONDITION-like properties * partial fix for bug in test case: ** Define SB-INT:SIMPLE-READER-ERROR which portably behaves the way that pre-ANSI code expected READER-ERROR to behave. ** Redo most internal references to READER-ERROR as references to SB-INT:SIMPLE-READER-ERROR. * (This is only a partial fix because PARSE-ERROR and STREAM-ERROR still have similar issues.) --- contrib/sb-cover/cover.lisp | 2 +- package-data-list.lisp-expr | 6 ++- src/code/backq.lisp | 14 ++--- src/code/condition.lisp | 120 +++++++++++++++++++++++++------------------ src/code/reader.lisp | 69 ++++++++++++++----------- src/code/sharpm.lisp | 111 +++++++++++++++++++++------------------ tests/condition.impure.lisp | 44 +++++++++++++++- version.lisp-expr | 2 +- 8 files changed, 226 insertions(+), 142 deletions(-) diff --git a/contrib/sb-cover/cover.lisp b/contrib/sb-cover/cover.lisp index 03ac9da..8a38551 100644 --- a/contrib/sb-cover/cover.lisp +++ b/contrib/sb-cover/cover.lisp @@ -473,7 +473,7 @@ The source locations are stored in SOURCE-MAP." (cond ((sb-impl::token-delimiterp nextchar) (cond ((eq listtail thelist) (unless *read-suppress* - (sb-impl::%reader-error + (sb-int:simple-reader-error stream "Nothing appears before . in list."))) ((sb-impl::whitespace[2]p nextchar) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 4d6c3c0..1db6a6f 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -827,7 +827,9 @@ possibly temporariliy, because it might be used internally." "INTERPRETED-PROGRAM-ERROR" "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR" "SIMPLE-PARSE-ERROR" "SIMPLE-PROGRAM-ERROR" - "SIMPLE-STREAM-ERROR" "SIMPLE-STORAGE-CONDITION" + "SIMPLE-READER-ERROR" "SIMPLE-READER-PACKAGE-ERROR" + "SIMPLE-STREAM-ERROR" + "SIMPLE-STORAGE-CONDITION" "SIMPLE-STYLE-WARNING" "SPECIAL-FORM-FUNCTION" @@ -1439,7 +1441,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "PUNT-PRINT-IF-TOO-LONG" "RAW-INSTANCE-SLOTS-EQUALP" "READER-IMPOSSIBLE-NUMBER-ERROR" - "READER-PACKAGE-ERROR" "READER-EOF-ERROR" + "READER-EOF-ERROR" "RESTART-DESIGNATOR" "RUN-PENDING-FINALIZERS" "SCALE-DOUBLE-FLOAT" diff --git a/src/code/backq.lisp b/src/code/backq.lisp index f194f45..5b3cd9c 100644 --- a/src/code/backq.lisp +++ b/src/code/backq.lisp @@ -56,9 +56,9 @@ (multiple-value-bind (flag thing) (backquotify stream (read stream t nil t)) (when (eq flag *bq-at-flag*) - (%reader-error stream ",@ after backquote in ~S" thing)) + (simple-reader-error stream ",@ after backquote in ~S" thing)) (when (eq flag *bq-dot-flag*) - (%reader-error stream ",. after backquote in ~S" thing)) + (simple-reader-error stream ",. after backquote in ~S" thing)) (backquotify-1 flag thing)))) (/show0 "backq.lisp 64") @@ -68,7 +68,7 @@ (unless (> *backquote-count* 0) (when *read-suppress* (return-from comma-macro nil)) - (%reader-error stream "comma not inside a backquote")) + (simple-reader-error stream "comma not inside a backquote")) (let ((c (read-char stream)) (*backquote-count* (1- *backquote-count*))) (cond ((char= c #\@) @@ -108,9 +108,9 @@ (multiple-value-bind (dflag d) (backquotify stream (cdr code)) (when (eq dflag *bq-at-flag*) ;; Get the errors later. - (%reader-error stream ",@ after dot in ~S" code)) + (simple-reader-error stream ",@ after dot in ~S" code)) (when (eq dflag *bq-dot-flag*) - (%reader-error stream ",. after dot in ~S" code)) + (simple-reader-error stream ",. after dot in ~S" code)) (cond ((eq aflag *bq-at-flag*) (if (null dflag) @@ -251,9 +251,9 @@ ;;; Since our backquote is installed on the host lisp, and since ;;; developers make mistakes with backquotes and commas too, let's ;;; ensure that we can report errors rather than get an undefined -;;; function condition on %READER-ERROR. +;;; function condition on SIMPLE-READER-ERROR. #+sb-xc-host ; proper definition happens for the target -(defun %reader-error (stream format-string &rest format-args) +(defun simple-reader-error (stream format-string &rest format-args) (bug "READER-ERROR on stream ~S: ~?" stream format-string format-args)) (/show0 "done with backq.lisp") diff --git a/src/code/condition.lisp b/src/code/condition.lisp index c17e2c3..6e04cda 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -718,51 +718,71 @@ (*print-array* nil)) (format stream "~S cannot be printed readably." obj))))) -(define-condition reader-error (parse-error stream-error) - ((format-control - :reader reader-error-format-control - :initarg :format-control) - (format-arguments - :reader reader-error-format-arguments - :initarg :format-arguments - :initform '())) - (:report - (lambda (condition stream) - (let* ((error-stream (stream-error-stream condition)) - (pos (file-position-or-nil-for-error error-stream))) - (let (lineno colno) - (when (and pos - (< pos sb!xc:array-dimension-limit) - ;; KLUDGE: lseek() (which is what FILE-POSITION - ;; reduces to on file-streams) is undefined on - ;; "some devices", which in practice means that it - ;; can claim to succeed on /dev/stdin on Darwin - ;; and Solaris. This is obviously bad news, - ;; because the READ-SEQUENCE below will then - ;; block, not complete, and the report will never - ;; be printed. As a workaround, we exclude - ;; interactive streams from this attempt to report - ;; positions. -- CSR, 2003-08-21 - (not (interactive-stream-p error-stream)) - (file-position error-stream :start)) - (let ((string - (make-string pos - :element-type (stream-element-type - error-stream)))) - (when (= pos (read-sequence string error-stream)) - (setq lineno (1+ (count #\Newline string)) - colno (- pos - (or (position #\Newline string :from-end t) -1) - 1)))) - (file-position-or-nil-for-error error-stream pos)) - (pprint-logical-block (stream nil) - (format stream - "READER-ERROR ~@[at ~W ~]~ +(define-condition reader-error (parse-error stream-error) () + (:report (lambda (condition stream) + (%report-reader-error condition stream)))) + +;;; a READER-ERROR whose REPORTing is controlled by FORMAT-CONTROL and +;;; FORMAT-ARGS (the usual case for READER-ERRORs signalled from +;;; within SBCL itself) +;;; +;;; (Inheriting CL:SIMPLE-CONDITION here isn't quite consistent with +;;; the letter of the ANSI spec: this is not a condition signalled by +;;; SIGNAL when a format-control is supplied by the function's first +;;; argument. It seems to me (WHN) to be basically in the spirit of +;;; the spec, but if not, it'd be straightforward to do our own +;;; DEFINE-CONDITION SB-INT:SIMPLISTIC-CONDITION with +;;; FORMAT-CONTROL and FORMAT-ARGS slots, and use that condition in +;;; place of CL:SIMPLE-CONDITION here.) +(define-condition simple-reader-error (reader-error simple-condition) + () + (:report (lambda (condition stream) + (%report-reader-error condition stream :simple t)))) + +;;; base REPORTing of a READER-ERROR +;;; +;;; When SIMPLE, we expect and use SIMPLE-CONDITION-ish FORMAT-CONTROL +;;; and FORMAT-ARGS slots. +(defun %report-reader-error (condition stream &key simple) + (let* ((error-stream (stream-error-stream condition)) + (pos (file-position-or-nil-for-error error-stream))) + (let (lineno colno) + (when (and pos + (< pos sb!xc:array-dimension-limit) + ;; KLUDGE: lseek() (which is what FILE-POSITION + ;; reduces to on file-streams) is undefined on + ;; "some devices", which in practice means that it + ;; can claim to succeed on /dev/stdin on Darwin + ;; and Solaris. This is obviously bad news, + ;; because the READ-SEQUENCE below will then + ;; block, not complete, and the report will never + ;; be printed. As a workaround, we exclude + ;; interactive streams from this attempt to report + ;; positions. -- CSR, 2003-08-21 + (not (interactive-stream-p error-stream)) + (file-position error-stream :start)) + (let ((string + (make-string pos + :element-type (stream-element-type + error-stream)))) + (when (= pos (read-sequence string error-stream)) + (setq lineno (1+ (count #\Newline string)) + colno (- pos + (or (position #\Newline string :from-end t) -1) + 1)))) + (file-position-or-nil-for-error error-stream pos)) + (pprint-logical-block (stream nil) + (format stream + "~S ~@[at ~W ~]~ ~@[(line ~W~]~@[, column ~W) ~]~ - on ~S:~2I~_~?" - pos lineno colno error-stream - (reader-error-format-control condition) - (reader-error-format-arguments condition)))))))) + on ~S" + (class-name (class-of condition)) + pos lineno colno error-stream) + (when simple + (format stream ":~2I~_") + (format stream + (simple-condition-format-control condition) + (simple-condition-format-arguments condition))))))) ;;;; special SBCL extension conditions @@ -819,7 +839,6 @@ ;;; unFBOUNDPness meant they were running on an system which didn't ;;; support the extension.) (define-condition unsupported-operator (simple-error) ()) - ;;; (:ansi-cl :function remove) ;;; (:ansi-cl :section (a b c)) @@ -1126,7 +1145,7 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (define-condition simple-package-error (simple-condition package-error) ()) -(define-condition reader-package-error (reader-error) ()) +(define-condition simple-reader-package-error (simple-reader-error) ()) (define-condition reader-eof-error (end-of-file) ((context :reader reader-eof-error-context :initarg :context)) @@ -1137,15 +1156,16 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (stream-error-stream condition) (reader-eof-error-context condition))))) -(define-condition reader-impossible-number-error (reader-error) +(define-condition reader-impossible-number-error (simple-reader-error) ((error :reader reader-impossible-number-error-error :initarg :error)) (:report (lambda (condition stream) (let ((error-stream (stream-error-stream condition))) - (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A" + (format stream + "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A" (file-position-or-nil-for-error error-stream) error-stream - (reader-error-format-control condition) - (reader-error-format-arguments condition) + (simple-condition-format-control condition) + (simple-condition-format-arguments condition) (reader-impossible-number-error-error condition)))))) (define-condition timeout (serious-condition) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 08d6ea3..3bcf878 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -49,8 +49,10 @@ :stream stream :context context)) -(defun %reader-error (stream control &rest args) - (error 'reader-error +;;; If The Gods didn't intend for us to use multiple namespaces, why +;;; did They specify them? +(defun simple-reader-error (stream control &rest args) + (error 'simple-reader-error :stream stream :format-control control :format-arguments args)) @@ -105,7 +107,7 @@ (defun undefined-macro-char (stream char) (unless *read-suppress* - (%reader-error stream "undefined read-macro character ~S" char))) + (simple-reader-error stream "undefined read-macro character ~S" char))) ;;; The character attribute table is a CHAR-CODE-LIMIT vector of integers. @@ -568,7 +570,7 @@ variables to allow for nested and thread safe reading." (cond ((token-delimiterp nextchar) (cond ((eq listtail thelist) (unless *read-suppress* - (%reader-error + (simple-reader-error stream "Nothing appears before . in list."))) ((whitespace[2]p nextchar) @@ -593,7 +595,7 @@ variables to allow for nested and thread safe reading." ((char= char #\) ) (if *read-suppress* (return-from read-after-dot nil) - (%reader-error stream "Nothing appears after . in list."))) + (simple-reader-error stream "Nothing appears after . in list."))) ;; See whether there's something there. (setq lastobj (read-maybe-nothing stream char)) (when lastobj (return t))) @@ -605,7 +607,8 @@ variables to allow for nested and thread safe reading." ;; Try reading virtual whitespace. (if (and (read-maybe-nothing stream lastchar) (not *read-suppress*)) - (%reader-error stream "More than one object follows . in list."))))) + (simple-reader-error stream + "More than one object follows . in list."))))) (defun read-string (stream closech) ;; This accumulates chars until it sees same char that invoked it. @@ -633,7 +636,7 @@ variables to allow for nested and thread safe reading." (defun read-right-paren (stream ignore) (declare (ignore ignore)) - (%reader-error stream "unmatched close parenthesis")) + (simple-reader-error stream "unmatched close parenthesis")) ;;; Read from the stream up to the next delimiter. Leave the resulting ;;; token in *READ-BUFFER*, and return two values: @@ -705,7 +708,7 @@ variables to allow for nested and thread safe reading." ((< att +char-attr-constituent+) att) (t (setf att (get-constituent-trait ,char)) (if (= att +char-attr-invalid+) - (%reader-error stream "invalid constituent") + (simple-reader-error stream "invalid constituent") att))))) ;;; Return the character class for CHAR, which might be part of a @@ -723,7 +726,7 @@ variables to allow for nested and thread safe reading." ((digit-char-p ,char *read-base*) +char-attr-constituent-digit+) ((= att +char-attr-constituent-digit+) +char-attr-constituent+) ((= att +char-attr-invalid+) - (%reader-error stream "invalid constituent")) + (simple-reader-error stream "invalid constituent")) (t att)))))) ;;; Return the character class for a char which might be part of a @@ -754,7 +757,7 @@ variables to allow for nested and thread safe reading." +char-attr-constituent-digit+) +char-attr-constituent-decimal-digit+)) ((= att +char-attr-invalid+) - (%reader-error stream "invalid constituent")) + (simple-reader-error stream "invalid constituent")) (t att)))))) ;;;; token fetching @@ -853,7 +856,8 @@ variables to allow for nested and thread safe reading." (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-invalid+ (%reader-error stream "invalid constituent")) + (#.+char-attr-invalid+ (simple-reader-error stream + "invalid constituent")) ;; can't have eof, whitespace, or terminating macro as first char! (t (go SYMBOL))) SIGN ; saw "sign" @@ -984,11 +988,12 @@ variables to allow for nested and thread safe reading." FRONTDOT ; saw "dot" (ouch-read-buffer char) (setq char (read-char stream nil nil)) - (unless char (%reader-error stream "dot context error")) + (unless char (simple-reader-error stream "dot context error")) (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) (#.+char-attr-constituent-dot+ (go DOTS)) - (#.+char-attr-delimiter+ (%reader-error stream "dot context error")) + (#.+char-attr-delimiter+ (simple-reader-error stream + "dot context error")) (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) @@ -1057,12 +1062,12 @@ variables to allow for nested and thread safe reading." DOTS ; saw "dot {dot}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) - (unless char (%reader-error stream "too many dots")) + (unless char (simple-reader-error stream "too many dots")) (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-constituent-dot+ (go DOTS)) (#.+char-attr-delimiter+ (unread-char char stream) - (%reader-error stream "too many dots")) + (simple-reader-error stream "too many dots")) (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) @@ -1134,8 +1139,9 @@ variables to allow for nested and thread safe reading." COLON (casify-read-buffer escapes) (unless (zerop colons) - (%reader-error stream "too many colons in ~S" - (read-buffer-to-string))) + (simple-reader-error stream + "too many colons in ~S" + (read-buffer-to-string))) (setq colons 1) (setq package-designator (if (plusp *ouch-ptr*) @@ -1155,9 +1161,9 @@ variables to allow for nested and thread safe reading." (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-delimiter+ (unread-char char stream) - (%reader-error stream - "illegal terminating character after a colon: ~S" - char)) + (simple-reader-error stream + "illegal terminating character after a colon: ~S" + char)) (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ (go INTERN)) @@ -1170,15 +1176,15 @@ variables to allow for nested and thread safe reading." (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-delimiter+ (unread-char char stream) - (%reader-error stream - "illegal terminating character after a colon: ~S" - char)) + (simple-reader-error stream + "illegal terminating character after a colon: ~S" + char)) (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ - (%reader-error stream - "too many colons after ~S name" - package-designator)) + (simple-reader-error stream + "too many colons after ~S name" + package-designator)) (t (go SYMBOL))) RETURN-SYMBOL (casify-read-buffer escapes) @@ -1186,7 +1192,7 @@ variables to allow for nested and thread safe reading." (find-package package-designator) (sane-package)))) (unless found - (error 'reader-package-error :stream stream + (error 'simple-reader-package-error :stream stream :format-arguments (list package-designator) :format-control "package ~S not found")) @@ -1197,7 +1203,7 @@ variables to allow for nested and thread safe reading." (when (eq test :external) (return symbol)) (let ((name (read-buffer-to-string))) (with-simple-restart (continue "Use symbol anyway.") - (error 'reader-package-error :stream stream + (error 'simple-reader-package-error :stream stream :format-arguments (list name (package-name found)) :format-control (if test @@ -1426,7 +1432,9 @@ variables to allow for nested and thread safe reading." (declare (ignore ignore)) (if *read-suppress* (values) - (%reader-error stream "no dispatch function defined for ~S" sub-char))) + (simple-reader-error stream + "no dispatch function defined for ~S" + sub-char))) (defun make-dispatch-macro-character (char &optional (non-terminating-p nil) @@ -1498,7 +1506,8 @@ variables to allow for nested and thread safe reading." (funcall (the function (gethash sub-char (cdr dpair) #'dispatch-char-error)) stream sub-char (if numargp numarg nil)) - (%reader-error stream "no dispatch table for dispatch char"))))) + (simple-reader-error stream + "no dispatch table for dispatch char"))))) ;;;; READ-FROM-STRING diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp index ca56de2..dfd32d2 100644 --- a/src/code/sharpm.lisp +++ b/src/code/sharpm.lisp @@ -25,15 +25,16 @@ (type-error (error) (declare (ignore error)) - (%reader-error stream "improper list in #(): ~S" - list))))) + (simple-reader-error stream + "improper list in #(): ~S" + list))))) (declare (list list) (fixnum listlength)) (cond (*read-suppress* nil) ((zerop *backquote-count*) (if length (cond ((> listlength (the fixnum length)) - (%reader-error + (simple-reader-error stream "vector longer than specified length: #~S~S" length list)) @@ -53,9 +54,10 @@ (declare (simple-string bstring)) (cond (*read-suppress* nil) (escape-appearedp - (%reader-error stream "An escape character appeared after #*")) + (simple-reader-error stream + "An escape character appeared after #*.")) ((and numarg (zerop (length bstring)) (not (zerop numarg))) - (%reader-error + (simple-reader-error stream "You have to give a little bit for non-zero #* bit-vectors.")) ((or (null numarg) (>= (the fixnum numarg) (length bstring))) @@ -74,31 +76,34 @@ (cond ((char= char #\0) 0) ((char= char #\1) 1) (t - (%reader-error + (simple-reader-error stream "illegal element given for bit-vector: ~S" char))))) bvec)) (t - (%reader-error stream - "Bit vector is longer than specified length #~A*~A" - numarg bstring))))) + (simple-reader-error + stream + "Bit vector is longer than specified length #~A*~A" + numarg + bstring))))) (defun sharp-A (stream ignore dimensions) (declare (ignore ignore)) (when *read-suppress* (read stream t nil t) (return-from sharp-A nil)) - (unless dimensions (%reader-error stream "no dimensions argument to #A")) + (unless dimensions (simple-reader-error stream + "no dimensions argument to #A")) (collect ((dims)) (let* ((contents (read stream t nil t)) (seq contents)) (dotimes (axis dimensions (make-array (dims) :initial-contents contents)) (unless (typep seq 'sequence) - (%reader-error stream - "#~WA axis ~W is not a sequence:~% ~S" - dimensions axis seq)) + (simple-reader-error stream + "#~WA axis ~W is not a sequence:~% ~S" + dimensions axis seq)) (let ((len (length seq))) (dims len) (unless (or (= axis (1- dimensions)) @@ -119,32 +124,34 @@ (return-from sharp-S nil)) (let ((body (if (char= (read-char stream t) #\( ) (read-list stream nil) - (%reader-error stream "non-list following #S")))) + (simple-reader-error stream "non-list following #S")))) (unless (listp body) - (%reader-error stream "non-list following #S: ~S" body)) + (simple-reader-error stream "non-list following #S: ~S" body)) (unless (symbolp (car body)) - (%reader-error stream "Structure type is not a symbol: ~S" (car body))) + (simple-reader-error stream + "Structure type is not a symbol: ~S" + (car body))) (let ((classoid (find-classoid (car body) nil))) (unless (typep classoid 'structure-classoid) - (%reader-error stream "~S is not a defined structure type." - (car body))) - (let ((def-con (dd-default-constructor - (layout-info - (classoid-layout classoid))))) - (unless def-con - (%reader-error - stream "The ~S structure does not have a default constructor." + (simple-reader-error stream + "~S is not a defined structure type." + (car body))) + (let ((default-constructor (dd-default-constructor + (layout-info (classoid-layout classoid))))) + (unless default-constructor + (simple-reader-error + stream + "The ~S structure does not have a default constructor." (car body))) (when (and (atom (rest body)) (not (null (rest body)))) - (%reader-error - stream "improper list for #S: ~S." body)) - (apply (fdefinition def-con) + (simple-reader-error stream "improper list for #S: ~S." body)) + (apply (fdefinition default-constructor) (loop for tail on (rest body) by #'cddr with slot-name = (and (consp tail) (car tail)) do (progn (when (null (cdr tail)) - (%reader-error + (simple-reader-error stream "the arglist for the ~S constructor in #S ~ has an odd length: ~S." @@ -152,13 +159,13 @@ (when (or (atom (cdr tail)) (and (atom (cddr tail)) (not (null (cddr tail))))) - (%reader-error + (simple-reader-error stream "the arglist for the ~S constructor in #S ~ is improper: ~S." (car body) (rest body))) (when (not (typep (car tail) 'string-designator)) - (%reader-error + (simple-reader-error stream "a slot name in #S is not a string ~ designator: ~S." @@ -186,7 +193,9 @@ (when *read-suppress* (return-from sharp-C nil)) (if (and (listp cnum) (= (length cnum) 2)) (complex (car cnum) (cadr cnum)) - (%reader-error stream "illegal complex number format: #C~S" cnum)))) + (simple-reader-error stream + "illegal complex number format: #C~S" + cnum)))) (defun sharp-O (stream sub-char numarg) (ignore-numarg sub-char numarg) @@ -197,18 +206,18 @@ (read-extended-token stream) nil) ((not radix) - (%reader-error stream "radix missing in #R")) + (simple-reader-error stream "radix missing in #R")) ((not (<= 2 radix 36)) - (%reader-error stream "illegal radix for #R: ~D." radix)) + (simple-reader-error stream "illegal radix for #R: ~D." radix)) (t (let ((res (let ((*read-base* radix)) (read stream t nil t)))) (unless (typep res 'rational) - (%reader-error stream - "#~A (base ~D.) value is not a rational: ~S." - sub-char - radix - res)) + (simple-reader-error stream + "#~A (base ~D.) value is not a rational: ~S." + sub-char + radix + res)) res)))) (defun sharp-X (stream sub-char numarg) @@ -286,15 +295,15 @@ (declare (ignore ignore)) (when *read-suppress* (return-from sharp-equal (values))) (unless label - (%reader-error stream "missing label for #=" label)) + (simple-reader-error stream "missing label for #=" label)) (when (or (assoc label *sharp-sharp-alist*) (assoc label *sharp-equal-alist*)) - (%reader-error stream "multiply defined label: #~D=" label)) + (simple-reader-error stream "multiply defined label: #~D=" label)) (let* ((tag (gensym)) (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*)) (obj (read stream t nil t))) (when (eq obj tag) - (%reader-error stream + (simple-reader-error stream "must tag something more than just #~D#" label)) (push (list label tag obj) *sharp-equal-alist*) @@ -305,7 +314,7 @@ (declare (ignore ignore)) (when *read-suppress* (return-from sharp-sharp nil)) (unless label - (%reader-error stream "missing label for ##" label)) + (simple-reader-error stream "missing label for ##" label)) (let ((entry (assoc label *sharp-equal-alist*))) (if entry @@ -317,7 +326,9 @@ ;; "2.4.8.16 Sharpsign Sharpsign".) (pair (assoc label *sharp-sharp-alist*))) (unless pair - (%reader-error stream "reference to undefined label #~D#" label)) + (simple-reader-error stream + "reference to undefined label #~D#" + label)) (cdr pair))))) ;;;; conditional compilation: the #+ and #- readmacros @@ -357,8 +368,9 @@ (char charstring 0)) ((name-char charstring)) (t - (%reader-error stream "unrecognized character name: ~S" - charstring))))) + (simple-reader-error stream + "unrecognized character name: ~S" + charstring))))) (defun sharp-vertical-bar (stream sub-char numarg) (ignore-numarg sub-char numarg) @@ -412,9 +424,8 @@ (cond (*read-suppress* nil) (colon - (%reader-error stream - "The symbol following #: contains a package marker: ~S" - token)) + (simple-reader-error + stream "The symbol following #: contains a package marker: ~S" token)) (t (make-symbol token))))) @@ -427,12 +438,12 @@ (let ((token (read stream t nil t))) (unless *read-suppress* (unless *read-eval* - (%reader-error stream "can't read #. while *READ-EVAL* is NIL")) + (simple-reader-error stream "can't read #. while *READ-EVAL* is NIL")) (eval token)))) (defun sharp-illegal (stream sub-char ignore) (declare (ignore ignore)) - (%reader-error stream "illegal sharp macro character: ~S" sub-char)) + (simple-reader-error stream "illegal sharp macro character: ~S" sub-char)) ;;; for cold init: Install SHARPM stuff in the current *READTABLE*. (defun !sharpm-cold-init () diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp index 4cb5abe..e21854c 100644 --- a/tests/condition.impure.lisp +++ b/tests/condition.impure.lisp @@ -69,4 +69,46 @@ :test (lambda (c) (typep c 'picky-condition)) 'it)))) -;;; success +;;; In sbcl-1.0.9, a condition derived from CL:STREAM-ERROR (or +;;; CL:READER-ERROR or or CL:PARSE-ERROR) didn't inherit a usable +;;; PRINT-OBJECT method --- the PRINT-OBJECT code implicitly assumed +;;; that CL:STREAM-ERROR was like a SIMPLE-CONDITION, with args and +;;; format control, which seems to be a preANSIism. +;;; +;;; (The spec for DEFINE-CONDITION says that if :REPORT is not +;;; supplied, "information about how to report this type of condition +;;; is inherited from the PARENT-TYPE." The spec doesn't explicitly +;;; forbid the inherited printer from trying to read slots which +;;; aren't portably specified for the condition, but it doesn't seem +;;; reasonable for the inherited printer to do so. It does seem +;;; reasonable for app code to derive a new condition from +;;; CL:READER-ERROR (perhaps for an error in a readmacro) or +;;; CL:PARSE-ERROR (perhaps for an error in an operator +;;; READ-MY-FAVORITE-DATA-STRUCTURE) or CL:STREAM-ERROR (dunno why +;;; offhand, but perhaps for some Gray-stream-ish reason), not define +;;; a :REPORT method for its new condition, and expect to inherit from +;;; the application's printer all the cruft required for describing +;;; the location of the error in the input.) +(define-condition my-stream-error-1-0-9 (stream-error) ()) +(define-condition parse-foo-error-1-0-9 (parse-error) ()) +(define-condition read-bar-error-1-0-9 (reader-error) ()) +(let (;; instances created initializing all the slots specified in + ;; ANSI CL + (parse-foo-error-1-0-9 (make-condition 'parse-foo-error-1-0-9 + :stream *standard-input*)) + (read-foo-error-1-0-9 (make-condition 'read-bar-error-1-0-9 + :stream *standard-input*)) + (my-stream-error-1-0-9 (make-condition 'my-stream-error-1-0-9 + :stream *standard-input*))) + ;; should be printable + (dolist (c (list + ;; but not yet, o lord (should be fixed soon by WHN, in + ;; one or more commits ca. 1.0.9.55+, #+NILed out 'til + ;; then) + #+nil my-stream-error-1-0-9 + #+nil parse-foo-error-1-0-9 + ;; fixed, hallelujah + read-foo-error-1-0-9)) + ;; escaped or not + (dolist (*print-escape* '(nil t)) + (write c :stream (make-string-output-stream))))) diff --git a/version.lisp-expr b/version.lisp-expr index 2774615..0569929 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.9.59" +"1.0.9.60" -- 1.7.10.4