(!defstruct-with-alternate-metaclass condition
:slot-names (actual-initargs assigned-slots)
:boa-constructor %make-condition-object
- :superclass-name instance
+ :superclass-name t
:metaclass-name condition-classoid
:metaclass-constructor make-condition-classoid
:dd-type structure)
(condition-writer-function condition new-value slot-name))))
(defun %define-condition (name parent-types layout slots documentation
- report default-initargs all-readers all-writers)
+ report default-initargs all-readers all-writers
+ source-location)
(with-single-package-locked-error
(:symbol name "defining ~A as a condition")
(%compiler-define-condition name parent-types layout all-readers all-writers)
+ (sb!c:with-source-location (source-location)
+ (setf (layout-source-location layout)
+ source-location))
(let ((class (find-classoid name)))
(setf (condition-classoid-slots class) slots)
(setf (condition-classoid-report class) report)
,report
(list ,@default-initargs)
',(all-readers)
- ',(all-writers)))))))
+ ',(all-writers)
+ (sb!c:source-location)))))))
\f
;;;; DESCRIBE on CONDITIONs
(format stream ", ")
(destructuring-bind (type data) (cdr reference)
(ecase type
+ (:initialization
+ (format stream "Initialization of ~:(~A~) Metaobjects"
+ (substitute #\ #\- (symbol-name data))))
(:generic-function (format stream "Generic Function ~S" data))
(:section (format stream "Section ~{~D~^.~}" data)))))
(:ansi-cl
(duplicate-definition-name c))))
(:default-initargs :references (list '(:ansi-cl :section (3 2 2 3)))))
+(define-condition constant-modified (reference-condition warning)
+ ((fun-name :initarg :fun-name :reader constant-modified-fun-name))
+ (:report (lambda (c s)
+ (format s "~@<Destructive function ~S called on ~
+ constant data.~@:>"
+ (constant-modified-fun-name c))))
+ (:default-initargs :references (list '(:ansi-cl :special-operator quote)
+ '(:ansi-cl :section (3 2 2 3)))))
+
(define-condition package-at-variance (reference-condition simple-warning)
()
(:default-initargs :references (list '(:ansi-cl :macro defpackage))))