X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Finit.lisp;h=8a7b1237ac813fb2c73705dc8139d72ef7553343;hb=0223f43d5f199914ebceff12b6f4c60448369edd;hp=ee7e2e397872eca36099b35252937e2b18ce797d;hpb=b305d276b905654e4877cc49d03a2d3c9187cdff;p=sbcl.git diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index ee7e2e3..8a7b123 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -29,34 +29,26 @@ (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) - (loop for (key fn) in 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 fn)) into default-initargs + append (list key (funcall fun)) into default-initargs finally - (return (append supplied-initargs default-initargs)))) + (return (append supplied-initargs default-initargs)))) (defmethod initialize-instance ((instance slot-object) &rest initargs) (apply #'shared-initialize instance t initargs)) @@ -68,114 +60,135 @@ (apply #'shared-initialize instance nil initargs) instance) -(defmethod update-instance-for-different-class ((previous std-object) - (current std-object) - &rest initargs) +(defglobal **typecheck-cache** (make-hash-table :test #'equal)) + +(defun generate-slotd-typecheck (slotd) + (let ((type (slot-definition-type slotd))) + (values + (when (and (neq t type) (safe-p (slot-definition-class slotd))) + (with-locked-hash-table (**typecheck-cache**) + (or (gethash type **typecheck-cache**) + (setf (gethash type **typecheck-cache**) + (handler-bind (((or style-warning compiler-note) + #'muffle-warning)) + (funcall (compile + nil + `(lambda () + (declare (optimize (sb-c:store-coverage-data 0) + (sb-c::type-check 3) + (sb-c::verify-arg-count 0))) + (named-lambda (slot-typecheck ,type) (value) + (the ,type value)))))))))) + type))) + +(defmethod initialize-instance :after ((slotd effective-slot-definition) &key) + (setf (slot-definition-info slotd) + (multiple-value-bind (typecheck type) (generate-slotd-typecheck slotd) + (make-slot-info :slotd slotd + :typecheck typecheck)))) + +;;; FIXME: Do we need (SETF SLOT-DEFINITION-TYPE) at all? +(defmethod (setf slot-definition-type) :after (new-type (slotd effective-slot-definition)) + (multiple-value-bind (typecheck type) (generate-slotd-typecheck slotd) + (setf (slot-info-typecheck (slot-definition-info slotd)) typecheck))) + +(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) (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 (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))))))) + (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. (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) @@ -183,11 +196,11 @@ (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))))) + (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)) (let ((invalid-keys ())) @@ -195,12 +208,12 @@ ;; 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))) + (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))) + (error 'initarg-error :class class :initargs invalid-keys))) invalid-keys)) (defun check-initargs-2-list (initkeys class legal &optional (error-p t)) @@ -209,9 +222,9 @@ ;; 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))) + (unless (memq key legal) + (push key invalid-keys))) (when (and invalid-keys error-p) - (error 'initarg-error :class class :initargs invalid-keys))) + (error 'initarg-error :class class :initargs invalid-keys))) invalid-keys))