X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Finit.lisp;h=249e2acc2d6628cb41eac24e345c1d097d32585c;hb=963d8df14dd061d55ed0447acc9c2621a53e5237;hp=9614439248c3a5bfb8ad1884ac8f940372868541;hpb=24bc431a3403af05c5df601d09c0d0c27cb500b2;p=sbcl.git diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 9614439..249e2ac 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -30,219 +30,183 @@ (defmethod make-instance ((class class) &rest initargs) (unless (class-finalized-p class) (finalize-inheritance class)) - (setq initargs (default-initargs class initargs)) - #|| - (check-initargs-1 - class initargs - (list (list* 'allocate-instance class initargs) - (list* 'initialize-instance (class-prototype class) initargs) - (list* 'shared-initialize (class-prototype class) t initargs))) - ||# - (let* ((info (initialize-info class initargs)) - (valid-p (initialize-info-valid-p info))) - (when (and (consp valid-p) (eq (car valid-p) :invalid)) - (error "Invalid initialization argument ~S for class ~S" - (cdr valid-p) (class-name class)))) - (let ((instance (apply #'allocate-instance class initargs))) - (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))))) - ||#) + (let ((class-default-initargs (class-default-initargs class))) + (when class-default-initargs + (setf initargs (default-initargs class 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))))))) + (let ((instance (apply #'allocate-instance class initargs))) + (apply #'initialize-instance instance initargs) + instance))) + +(defmethod default-initargs ((class slot-class) + 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 + finally + (return (append supplied-initargs default-initargs)))) (defmethod initialize-instance ((instance slot-object) &rest initargs) (apply #'shared-initialize instance t initargs)) (defmethod reinitialize-instance ((instance slot-object) &rest initargs) - #|| - (check-initargs-1 - (class-of instance) initargs - (list (list* 'reinitialize-instance instance initargs) - (list* 'shared-initialize instance nil initargs))) - ||# - (let* ((class (class-of instance)) - (info (initialize-info class initargs)) - (valid-p (initialize-info-ri-valid-p info))) - (when (and (consp valid-p) (eq (car valid-p) :invalid)) - (error "Invalid initialization argument ~S for class ~S" - (cdr valid-p) (class-name class)))) + ;; the ctor machinery allows us to track when memoization of + ;; validity of initargs should be cleared. + (check-ri-initargs instance initargs) (apply #'shared-initialize instance nil initargs) instance) -(defmethod update-instance-for-different-class ((previous std-object) - (current std-object) - &rest initargs) +(defmethod update-instance-for-different-class + ((previous standard-object) (current standard-object) &rest initargs) ;; First we must compute the newly added slots. The spec defines ;; newly added slots as "those local slots for which no slot of ;; the same name exists in the previous class." (let ((added-slots '()) - (current-slotds (class-slots (class-of current))) - (previous-slot-names (mapcar #'slot-definition-name - (class-slots (class-of previous))))) + (current-slotds (class-slots (class-of current))) + (previous-slot-names (mapcar #'slot-definition-name + (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)) - (push (slot-definition-name slotd) added-slots))) + (eq (slot-definition-allocation slotd) :instance)) + (push (slot-definition-name slotd) added-slots))) (check-initargs-1 (class-of current) initargs (list (list* 'update-instance-for-different-class previous current initargs) - (list* 'shared-initialize current added-slots initargs))) + (list* 'shared-initialize current added-slots initargs))) (apply #'shared-initialize current added-slots initargs))) -(defmethod update-instance-for-redefined-class ((instance std-object) - added-slots - discarded-slots - property-list - &rest initargs) +(defmethod update-instance-for-redefined-class + ((instance standard-object) added-slots discarded-slots property-list + &rest initargs) (check-initargs-1 (class-of instance) initargs (list (list* 'update-instance-for-redefined-class - instance added-slots discarded-slots property-list initargs) - (list* 'shared-initialize instance added-slots initargs))) + instance added-slots discarded-slots property-list initargs) + (list* 'shared-initialize instance added-slots initargs))) (apply #'shared-initialize instance added-slots initargs)) -(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)))))))) +(defmethod shared-initialize ((instance slot-object) slot-names &rest initargs) + (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) + ;; CLHS: If a before method stores something in a slot, + ;; that slot won't be initialized from its :INITFORM, if any. + (let ((initfun (slot-definition-initfunction slotd))) + (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) + (when initfun + (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))) + (dolist (slotd initfn-slotds) + (unless (eq (slot-definition-allocation slotd) :class) + ;; :ALLOCATION :CLASS slots use the :INITFORM when class is defined + ;; or redefined, not when instances are allocated. + (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. (defun check-initargs-1 (class initargs call-list - &optional (plist-p t) (error-p t)) + &optional (plist-p t) (error-p t)) (multiple-value-bind (legal allow-other-keys) (check-initargs-values class call-list) (unless allow-other-keys (if plist-p - (check-initargs-2-plist initargs class legal error-p) - (check-initargs-2-list initargs class legal error-p))))) + (check-initargs-2-plist initargs class legal error-p) + (check-initargs-2-list initargs class legal error-p))))) (defun check-initargs-values (class call-list) (let ((methods (mapcan (lambda (call) - (if (consp call) - (copy-list (compute-applicable-methods - (gdefinition (car call)) - (cdr call))) - (list call))) - call-list)) - (legal (apply #'append (mapcar #'slot-definition-initargs - (class-slots class))))) + (if (consp call) + (copy-list (compute-applicable-methods + (gdefinition (car call)) + (cdr call))) + (list call))) + call-list)) + (legal (apply #'append (mapcar #'slot-definition-initargs + (class-slots class))))) ;; Add to the set of slot-filling initargs the set of ;; initargs that are accepted by the methods. If at ;; any point we come across &allow-other-keys, we can ;; just quit. (dolist (method methods) (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys) - (analyze-lambda-list (if (consp method) - (early-method-lambda-list method) - (method-lambda-list method))) - (declare (ignore nreq nopt keysp restp)) - (when allow-other-keys - (return-from check-initargs-values (values nil t))) - (setq legal (append keys legal)))) + (analyze-lambda-list (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method))) + (declare (ignore nreq nopt keysp restp)) + (when allow-other-keys + (return-from check-initargs-values (values nil t))) + (setq legal (append keys legal)))) (values legal nil))) +(define-condition initarg-error (reference-condition program-error) + ((class :reader initarg-error-class :initarg :class) + (initargs :reader initarg-error-initargs :initarg :initargs)) + (:default-initargs :references (list '(:ansi-cl :section (7 1 2)))) + (:report (lambda (condition stream) + (format stream "~@~I~_in call for class ~S.~:>" + (length (initarg-error-initargs condition)) + (list (initarg-error-initargs condition)) + (initarg-error-class condition))))) + (defun check-initargs-2-plist (initargs class legal &optional (error-p t)) - (unless (getf initargs :allow-other-keys) - ;; Now check the supplied-initarg-names and the default initargs - ;; against the total set that we know are legal. - (doplist (key val) initargs - (unless (memq key legal) - (if error-p - (error "Invalid initialization argument ~S for class ~S" - key - (class-name class)) - (return-from check-initargs-2-plist nil))))) - t) + (let ((invalid-keys ())) + (unless (getf initargs :allow-other-keys) + ;; Now check the supplied-initarg-names and the default initargs + ;; against the total set that we know are legal. + (doplist (key val) initargs + (unless (or (memq key legal) + ;; :ALLOW-OTHER-KEYS NIL gets here + (eq key :allow-other-keys)) + (push key invalid-keys))) + (when (and invalid-keys error-p) + (error 'initarg-error :class class :initargs invalid-keys))) + invalid-keys)) (defun check-initargs-2-list (initkeys class legal &optional (error-p t)) - (unless (memq :allow-other-keys initkeys) - ;; Now check the supplied-initarg-names and the default initargs - ;; against the total set that we know are legal. - (dolist (key initkeys) - (unless (memq key legal) - (if error-p - (error "Invalid initialization argument ~S for class ~S" - key - (class-name class)) - (return-from check-initargs-2-list nil))))) - t) + (let ((invalid-keys ())) + (unless (memq :allow-other-keys initkeys) + ;; Now check the supplied-initarg-names and the default initargs + ;; against the total set that we know are legal. + (dolist (key initkeys) + (unless (memq key legal) + (push key invalid-keys))) + (when (and invalid-keys error-p) + (error 'initarg-error :class class :initargs invalid-keys))) + invalid-keys))