X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Finit.lisp;h=a73f35326cd4027de5b8134971bed38175dabc3c;hb=2dfaffe8bdce30dac9b5baa4d2645d074a176b4f;hp=4306079af2c6b237abcff22cb560934af04bd33b;hpb=1a405defbd26ca767e71494b67127fcc00a8af12;p=sbcl.git

diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 4306079..a73f353 100644
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -29,29 +29,21 @@
   (apply #'make-instance (find-class class) initargs))
 
 (defmethod make-instance ((class class) &rest initargs)
+  (let ((instance-or-nil (maybe-call-ctor class initargs)))
+    (when instance-or-nil
+      (return-from make-instance instance-or-nil)))
   (unless (class-finalized-p class) (finalize-inheritance class))
   (let ((class-default-initargs (class-default-initargs class)))
     (when class-default-initargs
-      (setf initargs (default-initargs class initargs class-default-initargs)))
+      (setf initargs (default-initargs initargs class-default-initargs)))
     (when initargs
-      (when (and (eq *boot-state* 'complete)
-                 (not (getf initargs :allow-other-keys)))
-        (let ((class-proto (class-prototype class)))
-          (check-initargs-1
-           class initargs
-           (append (compute-applicable-methods
-                    #'allocate-instance (list class))
-                   (compute-applicable-methods
-                    #'initialize-instance (list class-proto))
-                   (compute-applicable-methods
-                    #'shared-initialize (list class-proto t)))))))
+      (when (eq **boot-state** 'complete)
+        (check-mi-initargs class initargs)))
     (let ((instance (apply #'allocate-instance class initargs)))
       (apply #'initialize-instance instance initargs)
       instance)))
 
-(defmethod default-initargs ((class slot-class)
-                             supplied-initargs
-                             class-default-initargs)
+(defun default-initargs (supplied-initargs class-default-initargs)
   (loop for (key nil fun) in class-default-initargs
         when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
           append (list key (funcall fun)) into default-initargs
@@ -101,43 +93,35 @@
   (flet ((initialize-slot-from-initarg (class instance slotd)
            (let ((slot-initargs (slot-definition-initargs slotd)))
              (doplist (initarg value) initargs
-                      (when (memq initarg slot-initargs)
-                        (setf (slot-value-using-class class instance slotd)
-                              value)
-                        (return t)))))
+               (when (memq initarg slot-initargs)
+                 (setf (slot-value-using-class class instance slotd)
+                       value)
+                 (return t)))))
          (initialize-slot-from-initfunction (class instance slotd)
            ;; CLHS: If a before method stores something in a slot,
            ;; that slot won't be initialized from its :INITFORM, if any.
-           (if (typep instance 'structure-object)
-               (when (eq (funcall
-                          ;; not SLOT-VALUE-USING-CLASS, as that
-                          ;; throws an error if the value is the
-                          ;; unbound marker.
-                          (slot-definition-internal-reader-function slotd)
-                          instance)
-                         +slot-unbound+)
-                 (setf (slot-value-using-class class instance slotd)
-                       (let ((initfn (slot-definition-initfunction slotd)))
-                         (when initfn
-                           (funcall initfn)))))
-               (unless (or (null (slot-definition-initfunction slotd))
-                           (slot-boundp-using-class class instance slotd))
-                 (setf (slot-value-using-class class instance slotd)
-                       (funcall (slot-definition-initfunction slotd)))))))
+           (let ((initfun (slot-definition-initfunction slotd)))
+             (if (typep instance 'structure-object)
+                 ;; We don't have a consistent unbound marker for structure
+                 ;; object slots, and structure object redefinition is not
+                 ;; really supported anyways -- so unconditionally
+                 ;; initializing the slot should be fine.
+                 (when initfun
+                   (setf (slot-value-using-class class instance slotd)
+                         (funcall initfun)))
+                 (unless (or (not initfun)
+                             (slot-boundp-using-class class instance slotd))
+                   (setf (slot-value-using-class class instance slotd)
+                         (funcall initfun)))))))
     (let* ((class (class-of instance))
            (initfn-slotds
             (loop for slotd in (class-slots class)
                   unless (initialize-slot-from-initarg class instance slotd)
-                    collect slotd)))
+                  collect slotd)))
       (dolist (slotd initfn-slotds)
-        (if (eq (slot-definition-allocation slotd) :class)
-            (when (or (eq t slot-names)
-                      (memq (slot-definition-name slotd) slot-names))
-              (unless (slot-boundp-using-class class instance slotd)
-                (initialize-slot-from-initfunction class instance slotd)))
-            (when (or (eq t slot-names)
-                      (memq (slot-definition-name slotd) slot-names))
-              (initialize-slot-from-initfunction class instance slotd)))))
+        (when (or (eq t slot-names)
+                  (memq (slot-definition-name slotd) slot-names))
+          (initialize-slot-from-initfunction class instance slotd))))
     instance))
 
 ;;; If initargs are valid return nil, otherwise signal an error.