X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=a44131081a6d1e6712f67f4dd4bcd5827626b041;hb=f9aaac53a4a43ebae198f53079857acb2d628eb0;hp=5feeb73552baca34c4716a4ec0fe782ab2a6368f;hpb=840832c6ca7fae0af981d721bdbb38e567d575cf;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 5feeb73..a441310 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -72,7 +72,9 @@ ;; allocation of this slot, or NIL until defaulted (allocation nil :type (member :instance :class nil)) ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value. - (cell nil :type (or cons null))) + (cell nil :type (or cons null)) + ;; slot documentation + (documentation nil :type (or string null))) ;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed ;;; in its CPL, while other classes derived from CONDITION-CLASS don't @@ -324,9 +326,10 @@ ;;; ANSI-compliant, fixing it would also be good.:-) (defun compute-effective-slots (class) (collect ((res (copy-list (condition-classoid-slots class)))) - (dolist (sclass (condition-classoid-cpl class)) + (dolist (sclass (cdr (condition-classoid-cpl class))) (dolist (sslot (condition-classoid-slots sclass)) - (let ((found (find (condition-slot-name sslot) (res)))) + (let ((found (find (condition-slot-name sslot) (res) + :key #'condition-slot-name))) (cond (found (setf (condition-slot-initargs found) (union (condition-slot-initargs found) @@ -343,6 +346,25 @@ (res (copy-structure sslot))))))) (res))) +;;; Early definitions of slot accessor creators. +;;; +;;; Slot accessors must be generic functions, but ANSI does not seem +;;; to specify any of them, and we cannot support it before end of +;;; warm init. So we use ordinary functions inside SBCL, and switch to +;;; GFs only at the end of building. +(declaim (notinline install-condition-slot-reader + install-condition-slot-writer)) +(defun install-condition-slot-reader (name condition slot-name) + (declare (ignore condition)) + (setf (fdefinition name) + (lambda (condition) + (condition-reader-function condition slot-name)))) +(defun install-condition-slot-writer (name condition slot-name) + (declare (ignore condition)) + (setf (fdefinition name) + (lambda (new-value condition) + (condition-writer-function condition new-value slot-name)))) + (defun %define-condition (name slots documentation report default-initargs) (let ((class (find-classoid name))) (setf (condition-classoid-slots class) slots) @@ -353,15 +375,11 @@ (dolist (slot slots) ;; Set up reader and writer functions. - (let ((name (condition-slot-name slot))) + (let ((slot-name (condition-slot-name slot))) (dolist (reader (condition-slot-readers slot)) - (setf (fdefinition reader) - (lambda (condition) - (condition-reader-function condition name)))) + (install-condition-slot-reader reader name slot-name)) (dolist (writer (condition-slot-writers slot)) - (setf (fdefinition writer) - (lambda (new-value condition) - (condition-writer-function condition new-value name)))))) + (install-condition-slot-writer writer name slot-name)))) ;; Compute effective slots and set up the class and hairy slots ;; (subsets of the effective slots.) @@ -427,6 +445,7 @@ (slot-name (first spec)) (allocation :instance) (initform-p nil) + documentation initform) (collect ((initargs) (readers) @@ -450,6 +469,13 @@ (:initarg (initargs arg)) (:allocation (setq allocation arg)) + (:documentation + (when documentation + (error "more than one :DOCUMENTATION in ~S" spec)) + (unless (stringp arg) + (error "slot :DOCUMENTATION argument is not a string: ~S" + arg)) + (setq documentation arg)) (:type) (t (error "unknown slot option:~% ~S" (first options)))))) @@ -462,6 +488,7 @@ :readers ',(readers) :writers ',(writers) :initform-p ',initform-p + :documentation ',documentation :initform ,(if (constantp initform) `',(eval initform) @@ -514,7 +541,7 @@ ;;; methods) (defun describe-condition (condition stream) (format stream - "~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>" + "~&~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>~%" condition (type-of condition) (concatenate 'list @@ -538,10 +565,12 @@ (define-condition simple-condition () ((format-control :reader simple-condition-format-control - :initarg :format-control) + :initarg :format-control + :type format-control) (format-arguments :reader simple-condition-format-arguments :initarg :format-arguments - :initform '())) + :initform '() + :type list)) (:report simple-condition-printer)) (define-condition simple-warning (simple-condition warning) ()) @@ -648,11 +677,39 @@ :initform '())) (:report (lambda (condition stream) - (let ((error-stream (stream-error-stream condition))) - (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?" - (file-position error-stream) error-stream - (reader-error-format-control condition) - (reader-error-format-arguments condition)))))) + (let* ((error-stream (stream-error-stream condition)) + (pos (file-position 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 error-stream pos)) + (format stream + "READER-ERROR ~@[at ~W ~]~ + ~@[(line ~W~]~@[, column ~W) ~]~ + on ~S:~%~?" + pos lineno colno error-stream + (reader-error-format-control condition) + (reader-error-format-arguments condition))))))) ;;;; various other (not specified by ANSI) CONDITIONs ;;;; @@ -660,6 +717,15 @@ ;;;; setup of CONDITION machinery, only because that makes it easier to ;;;; get cold init to work. +(define-condition values-type-error (type-error) + () + (:report + (lambda (condition stream) + (format stream + "~@" + (type-error-datum condition) + (type-error-expected-type condition))))) + ;;; KLUDGE: a condition for floating point errors when we can't or ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably @@ -767,10 +833,19 @@ (reader-error-format-arguments condition) (reader-impossible-number-error-error condition)))))) -;;; should this inherit from error? good question -(define-condition timeout (error) ()) - +(define-condition sb!ext::timeout (serious-condition) ()) +(define-condition defconstant-uneql (error) + ((name :initarg :name :reader defconstant-uneql-name) + (old-value :initarg :old-value :reader defconstant-uneql-old-value) + (new-value :initarg :new-value :reader defconstant-uneql-new-value)) + (:report + (lambda (condition stream) + (format stream + "~@" + (defconstant-uneql-name condition) + (defconstant-uneql-old-value condition) + (defconstant-uneql-new-value condition))))) ;;;; special SBCL extension conditions @@ -845,7 +920,7 @@ #!+sb-doc "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if none exists." - (invoke-restart (find-restart 'abort condition)) + (invoke-restart (find-restart-or-control-error 'abort condition)) ;; ABORT signals an error in case there was a restart named ABORT ;; that did not transfer control dynamically. This could happen with ;; RESTART-BIND. @@ -855,7 +930,7 @@ #!+sb-doc "Transfer control to a restart named MUFFLE-WARNING, signalling a CONTROL-ERROR if none exists." - (invoke-restart (find-restart 'muffle-warning condition))) + (invoke-restart (find-restart-or-control-error 'muffle-warning condition))) (macrolet ((define-nil-returning-restart (name args doc) #!-sb-doc (declare (ignore doc))