;; 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
(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*)
(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))))
\f
;;;; MAKE-CONDITION
;;; 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)
(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)
(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.)
(slot-name (first spec))
(allocation :instance)
(initform-p nil)
+ documentation
initform)
(collect ((initargs)
(readers)
(: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))))))
:readers ',(readers)
:writers ',(writers)
:initform-p ',initform-p
+ :documentation ',documentation
:initform
,(if (constantp initform)
`',(eval initform)
;;; 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
(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) ())
;;;; 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
+ "~@<The values set ~2I~:_[~{~S~^ ~}] ~I~_is not of type ~2I~_~S.~:>"
+ (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
(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
+ "~@<The constant ~S is being redefined (from ~S to ~S)~@:>"
+ (defconstant-uneql-name condition)
+ (defconstant-uneql-old-value condition)
+ (defconstant-uneql-new-value condition)))))
\f
;;;; special SBCL extension conditions
#!+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.
#!+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))
#!+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)
projects / sbcl.git / blobdiff