(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)
"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"
"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"
(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")
(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 #\@)
(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)
;;; 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")
(*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)))))))
\f
;;;; special SBCL extension conditions
;;; unFBOUNDPness meant they were running on an system which didn't
;;; support the extension.)
(define-condition unsupported-operator (simple-error) ())
-
\f
;;; (:ansi-cl :function remove)
;;; (:ansi-cl :section (a b c))
(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))
(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)
: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))
(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.
(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)
((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)))
;; 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.
(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:
((< 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
((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
+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))))))
\f
;;;; token fetching
(#.+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"
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))
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))
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*)
(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))
(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)
(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"))
(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
(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)
(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")))))
\f
;;;; READ-FROM-STRING
(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))
(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)))
(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))
(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."
(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."
(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)
(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)
(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*)
(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
;; "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)))))
\f
;;;; conditional compilation: the #+ and #- readmacros
(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)
(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)))))
(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))))
\f
(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 ()
: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)))))
;;; 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"
projects / sbcl.git / commitdiff