X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Finit.lisp;h=47b89887ccd6ac5a52a082a74bc4cba9136464ed;hb=a260738d7a71680079d972b102b4e4db4e8dc3ae;hp=9d84f315afa46db4a78d9802e556a5f160f1e4e9;hpb=bcbcc0d0660b3b3741203b3dfdd3443b201bf690;p=sbcl.git diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 9d84f31..47b8988 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -48,34 +48,11 @@ (apply #'initialize-instance instance initargs) instance)) -(defvar *default-initargs-flag* (list nil)) - (defmethod default-initargs ((class slot-class) supplied-initargs) (call-initialize-function (initialize-info-default-initargs-function (initialize-info class supplied-initargs)) - nil supplied-initargs) - #|| - ;; This implementation of default initargs is critically dependent - ;; on all-default-initargs not having any duplicate initargs in it. - (let ((all-default (class-default-initargs class)) - (miss *default-initargs-flag*)) - (flet ((getf* (plist key) - (do () - ((null plist) miss) - (if (eq (car plist) key) - (return (cadr plist)) - (setq plist (cddr plist)))))) - (labels ((default-1 (tail) - (if (null tail) - nil - (if (eq (getf* supplied-initargs (caar tail)) miss) - (list* (caar tail) - (funcall (cadar tail)) - (default-1 (cdr tail))) - (default-1 (cdr tail)))))) - (append supplied-initargs (default-1 all-default))))) - ||#) + nil supplied-initargs)) (defmethod initialize-instance ((instance slot-object) &rest initargs) (apply #'shared-initialize instance t initargs)) @@ -109,7 +86,7 @@ (class-slots (class-of previous))))) (dolist (slotd current-slotds) (if (and (not (memq (slot-definition-name slotd) previous-slot-names)) - (eq (slot-definition-allocation slotd) ':instance)) + (eq (slot-definition-allocation slotd) :instance)) (push (slot-definition-name slotd) added-slots))) (check-initargs-1 (class-of current) initargs @@ -131,61 +108,55 @@ (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs) - (when (eq slot-names t) - (return-from shared-initialize - (call-initialize-function - (initialize-info-shared-initialize-t-fun - (initialize-info (class-of instance) initargs)) - instance initargs))) - (when (eq slot-names nil) - (return-from shared-initialize - (call-initialize-function - (initialize-info-shared-initialize-nil-fun - (initialize-info (class-of instance) initargs)) - instance initargs))) - ;; Initialize the instance's slots in a two step process: - ;; (1) A slot for which one of the initargs in initargs can set - ;; the slot, should be set by that initarg. If more than - ;; one initarg in initargs can set the slot, the leftmost - ;; one should set it. - ;; (2) Any slot not set by step 1, may be set from its initform - ;; by step 2. Only those slots specified by the slot-names - ;; argument are set. If slot-names is: - ;; T - ;; then any slot not set in step 1 is set from its - ;; initform. - ;; - ;; then any slot in the list, and not set in step 1 - ;; is set from its initform. - ;; () - ;; then no slots are set from initforms. - (let* ((class (class-of instance)) - (slotds (class-slots class)) - (std-p (pcl-instance-p instance))) - (dolist (slotd slotds) - (let ((slot-name (slot-definition-name slotd)) - (slot-initargs (slot-definition-initargs slotd))) - (unless (progn - ;; Try to initialize the slot from one of the initargs. - ;; If we succeed return T, otherwise return nil. - (doplist (initarg val) initargs - (when (memq initarg slot-initargs) - (setf (slot-value-using-class class - instance - slotd) - val) - (return t)))) - ;; Try to initialize the slot from its initform. - (if (and slot-names - (or (eq slot-names t) - (memq slot-name slot-names)) - (or (and (not std-p) (eq slot-names t)) - (not (slot-boundp-using-class class instance slotd)))) - (let ((initfunction (slot-definition-initfunction slotd))) - (when initfunction - (setf (slot-value-using-class class instance slotd) - (funcall initfunction)))))))) - instance)) + (cond + ((eq slot-names t) + (call-initialize-function + (initialize-info-shared-initialize-t-fun + (initialize-info (class-of instance) initargs)) + instance initargs)) + ((eq slot-names nil) + (call-initialize-function + (initialize-info-shared-initialize-nil-fun + (initialize-info (class-of instance) initargs)) + instance initargs)) + (t + ;; Initialize the instance's slots in a two step process: + ;; (1) A slot for which one of the initargs in initargs can set + ;; the slot, should be set by that initarg. If more than + ;; one initarg in initargs can set the slot, the leftmost + ;; one should set it. + ;; (2) Any slot not set by step 1, may be set from its initform + ;; by step 2. Only those slots specified by the slot-names + ;; argument are set. If slot-names is: + ;; T + ;; then any slot not set in step 1 is set from its + ;; initform. + ;; + ;; then any slot in the list, and not set in step 1 + ;; is set from its initform. + ;; () + ;; then no slots are set from initforms. + (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))))) + (initialize-slot-from-initfunction (class instance slotd) + (unless (or (slot-boundp-using-class class instance slotd) + (null (slot-definition-initfunction slotd))) + (setf (slot-value-using-class class instance slotd) + (funcall (slot-definition-initfunction slotd))))) + (class-slot-p (slotd) + (eq :class (slot-definition-allocation slotd)))) + (loop with class = (class-of instance) + for slotd in (class-slots class) + unless (or (class-slot-p slotd) + (initialize-slot-from-initarg class instance slotd)) + when (memq (slot-definition-name slotd) slot-names) do + (initialize-slot-from-initfunction class instance slotd)) + instance)))) ;;; If initargs are valid return nil, otherwise signal an error. (defun check-initargs-1 (class initargs call-list