X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=9b565beec764d81b3686151f2b72ecd62c437ffe;hb=8ee41eac134a552e07e966dd16d681e8216147fc;hp=743a69c807897b0882229fd0a7938e405cfeb604;hpb=4f8f4b25cb564509437d8fc26038143150077f14;p=sbcl.git diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 743a69c..9b565be 100644 --- 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) @@ -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 @@ -390,6 +402,7 @@ .instance.) `(let* ((.instance. (,allocation-function ,wrapper)) (.slots. (,slots-fetcher .instance.))) + (declare (ignorable .slots.)) ,body .instance.)))) @@ -530,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)