- (multiple-value-bind (meta initargs)
- (ensure-class-values class args)
- (unless (eq (class-of class) meta)
- (apply #'change-class class meta initargs))
- (apply #'reinitialize-instance class initargs)
- (setf (find-class name) class)
- (set-class-type-translation class name)
- class))
-
-(defmethod class-predicate-name ((class t))
- 'constantly-nil)
-
-(defun fix-super (s)
- (cond ((classp s) s)
- ((not (legal-class-name-p s))
- (error "~S is not a class or a legal class name." s))
- (t
- (or (find-class s nil)
- (make-instance 'forward-referenced-class
- :name s)))))
-
-(defun ensure-class-values (class args)
- (let* ((initargs (copy-list args))
- (unsupplied (list 1))
- (supplied-meta (getf initargs :metaclass unsupplied))
- (supplied-supers (getf initargs :direct-superclasses unsupplied))
- (supplied-slots (getf initargs :direct-slots unsupplied))
- (meta
- (cond ((neq supplied-meta unsupplied)
- (find-class supplied-meta))
- ((or (null class)
- (forward-referenced-class-p class))
- *the-class-standard-class*)
- (t
- (class-of class)))))
- ;; KLUDGE: It seemed to me initially that there ought to be a way
- ;; of collecting all the erroneous problems in one go, rather than
- ;; this way of solving the problem of signalling the errors that
- ;; we are required to, which stops at the first bogus input.
- ;; However, after playing around a little, I couldn't find that
- ;; way, so I've left it as is, but if someone does come up with a
- ;; better way... -- CSR, 2002-09-08
- (do ((direct-slots (getf initargs :direct-slots) (cdr direct-slots)))
- ((endp direct-slots) nil)
- (destructuring-bind (slot &rest more) direct-slots
- (let ((slot-name (getf slot :name)))
- (when (some (lambda (s) (eq slot-name (getf s :name))) more)
- ;; FIXME: It's quite possible that we ought to define an
- ;; SB-INT:PROGRAM-ERROR function to signal these and other
- ;; errors throughout the codebase that are required to be
- ;; of type PROGRAM-ERROR.
- (error 'simple-program-error
- :format-control "~@<There is more than one direct slot ~
- with name ~S.~:>"
- :format-arguments (list slot-name)))
- (do ((stuff slot (cddr stuff)))
- ((endp stuff) nil)
- (destructuring-bind (option value &rest more) stuff
- (cond
- ((and (member option '(:allocation :type
- :initform :documentation))
- (not (eq unsupplied
- (getf more option unsupplied))))
- (error 'simple-program-error
- :format-control "~@<Duplicate slot option ~S for ~
- slot named ~S.~:>"
- :format-arguments (list option slot-name)))
- ((and (eq option :readers)
- (notevery #'symbolp value))
- (error 'simple-program-error
- :format-control "~@<Slot reader names for slot ~
- named ~S must be symbols.~:>"
- :format-arguments (list slot-name)))
- ((and (eq option :initargs)
- (notevery #'symbolp value))
- (error 'simple-program-error
- :format-control "~@<Slot initarg names for slot ~
- named ~S must be symbols.~:>"
- :format-arguments (list slot-name)))))))))
- (loop for (initarg . more) on (getf initargs :direct-default-initargs)
- for name = (car initarg)
- when (some (lambda (a) (eq (car a) name)) more)
- do (error 'simple-program-error
- :format-control "~@<Duplicate initialization argument ~
- name ~S in :DEFAULT-INITARGS.~:>"
- :format-arguments (list name class)))
- (let ((metaclass 0)
- (default-initargs 0))
- (do ((args initargs (cddr args)))
- ((endp args) nil)
- (case (car args)
- (:metaclass
- (when (> (incf metaclass) 1)
- (error 'simple-program-error
- :format-control "~@<More than one :METACLASS ~
- option specified.~:>")))
- (:direct-default-initargs
- (when (> (incf default-initargs) 1)
- (error 'simple-program-error
- :format-control "~@<More than one :DEFAULT-INITARGS ~
- option specified.~:>"))))))
- (remf initargs :metaclass)
- (loop (unless (remf initargs :direct-superclasses) (return)))
- (loop (unless (remf initargs :direct-slots) (return)))
- (values
- meta
- (nconc
- (when (neq supplied-supers unsupplied)
- (list :direct-superclasses (mapcar #'fix-super supplied-supers)))
- (when (neq supplied-slots unsupplied)
- (list :direct-slots supplied-slots))
- initargs))))
+ (with-world-lock ()
+ (multiple-value-bind (meta initargs)
+ (frob-ensure-class-args args)
+ (unless (eq (class-of class) meta)
+ (apply #'change-class class meta initargs))
+ (apply #'reinitialize-instance class initargs)
+ (without-package-locks
+ (setf (find-class name) class))))
+ ;; After boot (SETF FIND-CLASS) does this.
+ (unless (eq *boot-state* 'complete)
+ (%set-class-type-translation class name))
+ class)
+
+(defun frob-ensure-class-args (args)
+ (let (metaclass metaclassp reversed-plist)
+ (flet ((frob-superclass (s)
+ (cond
+ ((classp s) s)
+ ((legal-class-name-p s)
+ (or (find-class s nil)
+ (ensure-class s :metaclass 'forward-referenced-class)))
+ (t (error "Not a class or a legal class name: ~S." s)))))
+ (doplist (key val) args
+ (cond ((eq key :metaclass)
+ (unless metaclassp
+ (setf metaclass val metaclassp key)))
+ (t
+ (when (eq key :direct-superclasses)
+ (setf val (mapcar #'frob-superclass val)))
+ (setf reversed-plist (list* val key reversed-plist)))))
+ (values (cond (metaclassp
+ (if (classp metaclass)
+ metaclass
+ (find-class metaclass)))
+ (t *the-class-standard-class*))
+ (nreverse reversed-plist)))))
+
+(defun call-initfun (fun slotd safe)
+ (declare (function fun))
+ (let ((value (funcall fun)))
+ (when safe
+ (let ((typecheck (slot-definition-type-check-function slotd)))
+ (when typecheck
+ (funcall (the function typecheck) value))))
+ value))