X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=aebc88408ffc3e018e0e833a5eaec87a5dfa1afa;hb=d25e3478acccec70402ff32554669a982be8e281;hp=9b565beec764d81b3686151f2b72ecd62c437ffe;hpb=4ff2057326cb82db04380aae96493bd5fcb3c203;p=sbcl.git

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 9b565be..aebc884 100644
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -241,22 +241,23 @@
 (defvar *the-system-si-method* nil)
 
 (defun install-optimized-constructor (ctor)
-  (let ((class (find-class (ctor-class-name ctor))))
-    (unless (class-finalized-p class)
-      (finalize-inheritance class))
-    ;; We can have a class with an invalid layout here.  Such a class
-    ;; cannot have a LAYOUT-INVALID of (:FLUSH ...) or (:OBSOLETE
-    ;; ...), because part of the deal is that those only happen from
-    ;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the
-    ;; class.  An invalid layout of T needs to be flushed, however.
-    (when (eq (layout-invalid (class-wrapper class)) t)
-      (force-cache-flushes class))
-    (setf (ctor-class ctor) class)
-    (pushnew ctor (plist-value class 'ctors) :test #'eq)
-    (setf (funcallable-instance-fun ctor)
-          (multiple-value-bind (form locations names)
-              (constructor-function-form ctor)
-            (apply (compile nil `(lambda ,names ,form)) locations)))))
+  (with-world-lock ()
+    (let ((class (find-class (ctor-class-name ctor))))
+      (unless (class-finalized-p class)
+        (finalize-inheritance class))
+      ;; We can have a class with an invalid layout here.  Such a class
+      ;; cannot have a LAYOUT-INVALID of (:FLUSH ...) or (:OBSOLETE
+      ;; ...), because part of the deal is that those only happen from
+      ;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the
+      ;; class.  An invalid layout of T needs to be flushed, however.
+      (when (eq (layout-invalid (class-wrapper class)) t)
+        (%force-cache-flushes class))
+      (setf (ctor-class ctor) class)
+      (pushnew ctor (plist-value class 'ctors) :test #'eq)
+      (setf (funcallable-instance-fun ctor)
+            (multiple-value-bind (form locations names)
+                (constructor-function-form ctor)
+              (apply (compile nil `(lambda ,names ,form)) locations))))))
 
 (defun constructor-function-form (ctor)
   (let* ((class (ctor-class ctor))
@@ -342,7 +343,9 @@
     (methods &optional standard-method)
   (loop with primary-checked-p = nil
         for method in methods
-        as qualifiers = (method-qualifiers method)
+        as qualifiers = (if (consp method)
+                            (early-method-qualifiers method)
+                            (safe-method-qualifiers method))
         when (or (eq :around (car qualifiers))
                  (and (null qualifiers)
                       (not primary-checked-p)
@@ -456,7 +459,9 @@
 ;;; must be called.
 (defun standard-sort-methods (applicable-methods)
   (loop for method in applicable-methods
-        as qualifiers = (method-qualifiers method)
+        as qualifiers = (if (consp method)
+                            (early-method-qualifiers method)
+                            (safe-method-qualifiers method))
         if (null qualifiers)
           collect method into primary
         else if (eq :around (car qualifiers))