mclass
*the-class-structure-class*))))))
(let ((defclass-form
- `(progn
- ,@(mapcar (lambda (x)
- `(declaim (ftype (function (t) t) ,x)))
- *readers-for-this-defclass*)
- ,@(mapcar (lambda (x)
- `(declaim (ftype (function (t t) t) ,x)))
- *writers-for-this-defclass*)
- ,@(mapcar (lambda (x)
- `(declaim (ftype (function (t) t)
- ,(slot-reader-name x)
- ,(slot-boundp-name x))
- (ftype (function (t t) t)
- ,(slot-writer-name x))))
- *slot-names-for-this-defclass*)
- (let ,(mapcar #'cdr *initfunctions-for-this-defclass*)
- (load-defclass ',name
- ',metaclass
- ',supers
- (list ,@canonical-slots)
- (list ,@(apply #'append
- (when defstruct-p
- '(:from-defclass-p t))
- other-initargs)))))))
+ `(progn
+ (let ,(mapcar #'cdr *initfunctions-for-this-defclass*)
+ (%compiler-defclass ',name
+ ',*readers-for-this-defclass*
+ ',*writers-for-this-defclass*
+ ',*slot-names-for-this-defclass*)
+ (load-defclass ',name
+ ',metaclass
+ ',supers
+ (list ,@canonical-slots)
+ (list ,@(apply #'append
+ (when defstruct-p
+ '(:from-defclass-p t))
+ other-initargs)))))))
(if defstruct-p
(progn
;; FIXME: (YUK!) Why do we do this? Because in order
(and (not (eq name 'structure-object))
*the-class-structure-object*)))
(defstruct-form (make-structure-class-defstruct-form
- name (class-direct-slots (find-class name)) include)))
+ name (class-direct-slots (find-class name))
+ include)))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
,defstruct-form) ; really compile the defstruct-form
;; full-blown class, so the "a class of this name is
;; coming" note we write here would be irrelevant.
(eval-when (:compile-toplevel)
- (preinform-compiler-about-class-type ',name))
- ,defclass-form))))))))
+ (%compiler-defclass ',name
+ ',*readers-for-this-defclass*
+ ',*writers-for-this-defclass*
+ ',*slot-names-for-this-defclass*))
+ (eval-when (:load-toplevel :execute)
+ ,defclass-form)))))))))
+
+(defun %compiler-defclass (name readers writers slot-names)
+ (with-single-package-locked-error (:symbol name "defining ~A as a class")
+ (preinform-compiler-about-class-type name)
+ (proclaim `(ftype (function (t) t)
+ ,@readers
+ ,@(mapcar #'slot-reader-name slot-names)
+ ,@(mapcar #'slot-boundp-name slot-names)))
+ (proclaim `(ftype (function (t t) t)
+ ,@writers ,@(mapcar #'slot-writer-name slot-names)))))
(defun make-initfunction (initform)
(cond ((or (eq initform t)
:format-control
"~@<in DEFCLASS ~S, the slot specification ~S is invalid; ~
the probable intended meaning may be achieved by ~
- specifiying ~S instead."
+ specifiying ~S instead.~>"
:format-arguments
(list class-name spec
`(,(car spec) :initform ,(cadr spec)))))