- (let* ((classoid (layout-classoid layout))
- (classoid-layout (classoid-layout classoid))
- (subclasses (classoid-subclasses classoid)))
-
- ;; Attempting to register ourselves with a temporary undefined
- ;; class placeholder is almost certainly a programmer error. (I
- ;; should know, I did it.) -- WHN 19990927
- (aver (not (undefined-classoid-p classoid)))
-
- ;; This assertion dates from classic CMU CL. The rationale is
- ;; probably that calling REGISTER-LAYOUT more than once for the
- ;; same LAYOUT is almost certainly a programmer error.
- (aver (not (eq classoid-layout layout)))
-
- ;; Figure out what classes are affected by the change, and issue
- ;; appropriate warnings and invalidations.
- (when classoid-layout
- (modify-classoid classoid)
- (when subclasses
- (dohash ((subclass subclass-layout) subclasses :locked t)
- (modify-classoid subclass)
- (when invalidate
- (invalidate-layout subclass-layout))))
- (when invalidate
- (invalidate-layout classoid-layout)
- (setf (classoid-subclasses classoid) nil)))
-
- (if destruct-layout
- (setf (layout-invalid destruct-layout) nil
- (layout-inherits destruct-layout) (layout-inherits layout)
- (layout-depthoid destruct-layout)(layout-depthoid layout)
- (layout-length destruct-layout) (layout-length layout)
- (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout)
- (layout-info destruct-layout) (layout-info layout)
- (classoid-layout classoid) destruct-layout)
- (setf (layout-invalid layout) nil
- (classoid-layout classoid) layout))
-
- (dovector (super-layout (layout-inherits layout))
- (let* ((super (layout-classoid super-layout))
- (subclasses (or (classoid-subclasses super)
- (setf (classoid-subclasses super)
- (make-hash-table :test 'eq
- #-sb-xc-host #-sb-xc-host
- :synchronized t)))))
- (when (and (eq (classoid-state super) :sealed)
- (not (gethash classoid subclasses)))
- (warn "unsealing sealed class ~S in order to subclass it"
- (classoid-name super))
- (setf (classoid-state super) :read-only))
- (setf (gethash classoid subclasses)
- (or destruct-layout layout)))))
+ (with-world-lock ()
+ (let* ((classoid (layout-classoid layout))
+ (classoid-layout (classoid-layout classoid))
+ (subclasses (classoid-subclasses classoid)))
+
+ ;; Attempting to register ourselves with a temporary undefined
+ ;; class placeholder is almost certainly a programmer error. (I
+ ;; should know, I did it.) -- WHN 19990927
+ (aver (not (undefined-classoid-p classoid)))
+
+ ;; This assertion dates from classic CMU CL. The rationale is
+ ;; probably that calling REGISTER-LAYOUT more than once for the
+ ;; same LAYOUT is almost certainly a programmer error.
+ (aver (not (eq classoid-layout layout)))
+
+ ;; Figure out what classes are affected by the change, and issue
+ ;; appropriate warnings and invalidations.
+ (when classoid-layout
+ (%modify-classoid classoid)
+ (when subclasses
+ (dohash ((subclass subclass-layout) subclasses :locked t)
+ (%modify-classoid subclass)
+ (when invalidate
+ (%invalidate-layout subclass-layout))))
+ (when invalidate
+ (%invalidate-layout classoid-layout)
+ (setf (classoid-subclasses classoid) nil)))
+
+ (if destruct-layout
+ (setf (layout-invalid destruct-layout) nil
+ (layout-inherits destruct-layout) (layout-inherits layout)
+ (layout-depthoid destruct-layout)(layout-depthoid layout)
+ (layout-length destruct-layout) (layout-length layout)
+ (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout)
+ (layout-info destruct-layout) (layout-info layout)
+ (classoid-layout classoid) destruct-layout)
+ (setf (layout-invalid layout) nil
+ (classoid-layout classoid) layout))
+
+ (dovector (super-layout (layout-inherits layout))
+ (let* ((super (layout-classoid super-layout))
+ (subclasses (or (classoid-subclasses super)
+ (setf (classoid-subclasses super)
+ (make-hash-table :test 'eq
+ #-sb-xc-host #-sb-xc-host
+ :synchronized t)))))
+ (when (and (eq (classoid-state super) :sealed)
+ (not (gethash classoid subclasses)))
+ (warn "unsealing sealed class ~S in order to subclass it"
+ (classoid-name super))
+ (setf (classoid-state super) :read-only))
+ (setf (gethash classoid subclasses)
+ (or destruct-layout layout))))))