-(defun ensure-class (name &rest all)
- (apply #'ensure-class-using-class name (find-class name nil) all))
-
-(defmethod ensure-class-using-class (name (class null) &rest args &key)
- (multiple-value-bind (meta initargs)
- (ensure-class-values class args)
- (setf class (apply #'make-instance meta :name name initargs)
- (find-class name) class)
- class))
-
-(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
- (multiple-value-bind (meta initargs)
- (ensure-class-values class args)
- (unless (eq (class-of class) meta) (change-class class meta))
- (apply #'reinitialize-instance class initargs)
- (setf (find-class name) class)
- 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)
- (setf (find-class s)
- (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
- (loop for (slot . more) on (getf initargs :direct-slots)
- for slot-name = (getf slot :name)
- if (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 code base that are required to be
- ;; of type PROGRAM-ERROR.
- do (error 'simple-program-error
- :format-control "More than one direct slot with name ~S."
- :format-arguments (list slot-name))
- else
- do (loop for (option value . more) on slot by #'cddr
- when (and (member option
- '(:allocation :type
- :initform :documentation))
- (not (eq unsupplied
- (getf more option unsupplied))))
- do (error 'simple-program-error
- :format-control "Duplicate slot option ~S for slot ~S."
- :format-arguments (list option 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 of class ~A."
- :format-arguments (list name class)))
- (loop (unless (remf initargs :metaclass) (return)))
- (loop (unless (remf initargs :direct-superclasses) (return)))
- (loop (unless (remf initargs :direct-slots) (return)))
- (values meta
- (list* :direct-superclasses
- (and (neq supplied-supers unsupplied)
- (mapcar #'fix-super supplied-supers))
- :direct-slots
- (and (neq supplied-slots unsupplied) supplied-slots)
- initargs))))
+(defun ensure-class (name &rest args)
+ (with-world-lock ()
+ (apply #'ensure-class-using-class
+ (let ((class (find-class name nil)))
+ (when (and class (eq name (class-name class)))
+ ;; NAME is the proper name of CLASS, so redefine it
+ class))
+ name
+ args)))
+
+(defmethod ensure-class-using-class ((class null) name &rest args &key)
+ (with-world-lock ()
+ (multiple-value-bind (meta initargs)
+ (frob-ensure-class-args args)
+ (setf class (apply #'make-instance meta :name name 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)
+
+(defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
+ (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))