(lambda (new-value condition)
(condition-writer-function condition new-value slot-name))))
+(defvar *define-condition-hooks* nil)
+
(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)
(dolist (initarg (condition-slot-initargs slot) nil)
(when (functionp (getf e-def-initargs initarg))
(return t))))
- (push slot (condition-classoid-hairy-slots class))))))))
+ (push slot (condition-classoid-hairy-slots class)))))))
+ (when (boundp '*define-condition-hooks*)
+ (dolist (fun *define-condition-hooks*)
+ (funcall fun class))))
name))
(defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
:initform-p ',initform-p
:documentation ',documentation
:initform
- ,(if (constantp initform)
- `',(eval initform)
+ ,(if (sb!xc:constantp initform)
+ `',(constant-form-value initform)
`#'(lambda () ,initform)))))))
(dolist (option options)
(let ((val (second initargs)))
(setq default-initargs
(list* `',(first initargs)
- (if (constantp val)
- `',(eval val)
+ (if (sb!xc:constantp val)
+ `',(constant-form-value val)
`#'(lambda () ,val))
default-initargs)))))
(t
,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