X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=b082c575456d046e594ea224afe72120af00f102;hb=68612b8227bdd1a9e70962201f54231c82affa17;hp=9923ac771c54860057852776e222bef0ae58273a;hpb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 9923ac7..b082c57 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 @@ -206,7 +208,6 @@ (when (eq (condition-slot-name cslot) name) (return-from condition-reader-function (car (condition-slot-cell cslot))))) - (let ((val (getf (condition-assigned-slots condition) name *empty-condition-slot*))) (if (eq val *empty-condition-slot*) @@ -214,17 +215,15 @@ (slot (find-condition-class-slot class name))) (unless slot (error "missing slot ~S of ~S" name condition)) - (dolist (initarg (condition-slot-initargs slot)) - (let ((val (getf actual-initargs - initarg - *empty-condition-slot*))) - (unless (eq val *empty-condition-slot*) - (return-from condition-reader-function - (setf (getf (condition-assigned-slots condition) - name) - val))))) - (setf (getf (condition-assigned-slots condition) name) - (find-slot-default class slot))) + (do ((initargs actual-initargs (cddr initargs))) + ((endp initargs) + (setf (getf (condition-assigned-slots condition) name) + (find-slot-default class slot))) + (when (member (car initargs) (condition-slot-initargs slot)) + (return-from condition-reader-function + (setf (getf (condition-assigned-slots condition) + name) + (cadr initargs)))))) val)))) ;;;; MAKE-CONDITION @@ -327,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) @@ -346,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) @@ -356,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.) @@ -430,6 +445,7 @@ (slot-name (first spec)) (allocation :instance) (initform-p nil) + documentation initform) (collect ((initargs) (readers) @@ -453,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)))))) @@ -465,6 +488,7 @@ :readers ',(readers) :writers ',(writers) :initform-p ',initform-p + :documentation ',documentation :initform ,(if (constantp initform) `',(eval initform) @@ -517,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 @@ -541,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) ()) @@ -663,6 +689,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 @@ -769,6 +804,20 @@ (reader-error-format-control condition) (reader-error-format-arguments condition) (reader-impossible-number-error-error condition)))))) + +(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 @@ -843,7 +892,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. @@ -853,7 +902,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)) @@ -861,8 +910,9 @@ #!+sb-doc ,doc ;; FIXME: Perhaps this shared logic should be pulled out into ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code.. - (when (find-restart ',name condition) - (invoke-restart ',name ,@args))))) + (let ((restart (find-restart ',name condition))) + (when restart + (invoke-restart restart ,@args)))))) (define-nil-returning-restart continue () "Transfer control to a restart named CONTINUE, or return NIL if none exists.") (define-nil-returning-restart store-value (value)