- (without-package-locks
- (unless (class-finalized-p class)
- (let ((name (class-name class)))
- (setf (find-class name) class)
- ;; KLUDGE: This is fairly horrible. We need to make a
- ;; full-fledged CLASSOID here, not just tell the compiler that
- ;; some class is forthcoming, because there are legitimate
- ;; questions one can ask of the type system, implemented in
- ;; terms of CLASSOIDs, involving forward-referenced classes. So.
- (when (and (eq *boot-state* 'complete)
- (null (find-classoid name nil)))
- (setf (find-classoid name)
- (make-standard-classoid :name name)))
- (set-class-type-translation class name)
- (let ((layout (make-wrapper 0 class))
- (classoid (find-classoid name)))
- (setf (layout-classoid layout) classoid)
- (setf (classoid-pcl-class classoid) class)
- (setf (slot-value class 'wrapper) layout)
- (let ((cpl (compute-preliminary-cpl class)))
- (setf (layout-inherits layout)
- (order-layout-inherits
- (map 'simple-vector #'class-wrapper
- (reverse (rest cpl))))))
- (register-layout layout :invalidate t)
- (setf (classoid-layout classoid) layout)
- (mapc #'make-preliminary-layout (class-direct-subclasses class))))))))
+ (with-world-lock ()
+ (without-package-locks
+ (unless (class-finalized-p class)
+ (let ((name (class-name class)))
+ ;; KLUDGE: This is fairly horrible. We need to make a
+ ;; full-fledged CLASSOID here, not just tell the compiler that
+ ;; some class is forthcoming, because there are legitimate
+ ;; questions one can ask of the type system, implemented in
+ ;; terms of CLASSOIDs, involving forward-referenced classes. So.
+ (let ((layout (make-wrapper 0 class)))
+ (setf (slot-value class 'wrapper) layout)
+ (let ((cpl (compute-preliminary-cpl class)))
+ (setf (layout-inherits layout)
+ (order-layout-inherits
+ (map 'simple-vector #'class-wrapper
+ (reverse (rest cpl))))))
+ (register-layout layout :invalidate t)
+ (%set-class-type-translation class (layout-classoid layout)))))
+ (mapc #'make-preliminary-layout (class-direct-subclasses class))))))