1.0.19.3: more careful PROGV and SET

[sbcl.git] / src / pcl / ctor.lisp

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 743a69c..0aae966 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -244,8 +244,15 @@
   (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))
+    (pushnew ctor (plist-value class 'ctors) :test #'eq)
     (setf (funcallable-instance-fun ctor)
           (multiple-value-bind (form locations names)
               (constructor-function-form ctor)
@@ -335,7 +342,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)
@@ -359,12 +368,17 @@
 (defun optimizing-generator (ctor ii-methods si-methods)
   (multiple-value-bind (locations names body before-method-p)
       (fake-initialization-emf ctor ii-methods si-methods)
-    (values
-     `(lambda ,(make-ctor-parameter-list ctor)
-       (declare #.*optimize-speed*)
-       ,(wrap-in-allocate-forms ctor body before-method-p))
-     locations
-     names)))
+    (let ((wrapper (class-wrapper (ctor-class ctor))))
+      (values
+       `(lambda ,(make-ctor-parameter-list ctor)
+         (declare #.*optimize-speed*)
+         (block nil
+           (when (layout-invalid ,wrapper)
+             (install-initial-constructor ,ctor)
+             (return (funcall ,ctor ,@(make-ctor-parameter-list ctor))))
+           ,(wrap-in-allocate-forms ctor body before-method-p)))
+       locations
+       names))))
 
 ;;; Return a form wrapped around BODY that allocates an instance
 ;;; constructed by CTOR.  BEFORE-METHOD-P set means we have to run
@@ -390,6 +404,7 @@
            .instance.)
         `(let* ((.instance. (,allocation-function ,wrapper))
                 (.slots. (,slots-fetcher .instance.)))
+           (declare (ignorable .slots.))
            ,body
            .instance.))))
 
@@ -443,7 +458,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))
@@ -530,16 +547,16 @@
       ;; initargs, that is, their values must be evaluated even
       ;; if not actually used for initializing a slot.
       (loop for (key initform initfn) in default-initargs and i from 0
-            unless (member key initkeys :test #'eq) do
-            (let* ((kind (if (constantp initform) 'constant 'var))
-                   (init (if (eq kind 'var) initfn initform)))
-              (ecase kind
-                (constant
-                 (push key defaulting-initargs)
-                 (push initform defaulting-initargs))
-                (var
-                 (push key defaulting-initargs)
-                 (push (default-init-var-name i) defaulting-initargs)))
+            unless (member key initkeys :test #'eq)
+            do (let* ((kind (if (constantp initform) 'constant 'var))
+                      (init (if (eq kind 'var) initfn initform)))
+                 (ecase kind
+                   (constant
+                    (push (list 'quote key) defaulting-initargs)
+                    (push initform defaulting-initargs))
+                   (var
+                    (push (list 'quote key) defaulting-initargs)
+                    (push (default-init-var-name i) defaulting-initargs)))
               (when (eq kind 'var)
                 (let ((init-var (default-init-var-name i)))
                   (setq init init-var)