X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=9baa699923a8e59d867f348abcabbfa9c96f7d2d;hb=f24a665895283c52443ed45bb3e07530f760bbfa;hp=712c0efc99deb988f4c7956216a4573bae2f93eb;hpb=a41e7cf8667de9ae078a8e318e8c5c045cdee87d;p=sbcl.git

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 712c0ef..9baa699 100644
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -244,6 +244,13 @@
   (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))
     (setf (funcallable-instance-fun ctor)
@@ -359,12 +366,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
@@ -531,16 +543,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)