X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Finit.lisp;h=5d3a325500c2e0539d1575b4f32412b3528302e9;hb=d7cbe5c40e93796d326937f3fb962fa4d7b1fa85;hp=249e2acc2d6628cb41eac24e345c1d097d32585c;hpb=963d8df14dd061d55ed0447acc9c2621a53e5237;p=sbcl.git diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 249e2ac..5d3a325 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 @@ -68,6 +60,55 @@ (apply #'shared-initialize instance nil initargs) instance) +(defglobal **typecheck-cache** (make-hash-table :test #'equal :synchronized t)) +(defvar *typecheck-stack* nil) + +(defun generate-slotd-typecheck (slotd info) + (let* ((type (slot-definition-type slotd)) + (class (slot-definition-class slotd)) + (cookie (cons class (slot-definition-name slotd)))) + (declare (dynamic-extent cookie)) + (when (and (neq t type) (safe-p class)) + (or + ;; Have one already! + (awhen (gethash type **typecheck-cache**) + (setf (slot-info-typecheck info) it)) + ;; It is possible for compilation of a typecheck to trigger class + ;; finalization, which in turn may trigger compilation of a + ;; slot-typechecking function -- detects and break those cycles. + ;; + ;; We use the slow function here, but the outer call will replace it + ;; with the fast one. + (when (member cookie *typecheck-stack* :test #'equal) + (setf (slot-info-typecheck info) + (named-lambda slow-slot-typecheck (value) + (if (typep value type) + value + (error 'type-error + :datum value + :expected-type type))))) + ;; The normal, good case: compile an efficient typecheck function. + (let ((*typecheck-stack* (cons cookie *typecheck-stack*))) + (handler-bind (((or style-warning compiler-note) #'muffle-warning)) + (let ((fun (compile + nil + `(named-lambda (slot-typecheck ,type) (value) + (declare (optimize (sb-c:store-coverage-data 0) + (sb-c::type-check 3) + (sb-c::verify-arg-count 0))) + (the ,type value))))) + (setf (gethash type **typecheck-cache**) fun + (slot-info-typecheck info) fun)))))))) + +(defmethod initialize-instance :after ((slotd effective-slot-definition) &key) + (let ((info (make-slot-info :slotd slotd))) + (generate-slotd-typecheck slotd info) + (setf (slot-definition-info slotd) info))) + +;;; FIXME: Do we need (SETF SLOT-DEFINITION-TYPE) at all? +(defmethod (setf slot-definition-type) :after (new-type (slotd effective-slot-definition)) + (generate-slotd-typecheck slotd (slot-definition-info slotd))) + (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 @@ -101,41 +142,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. (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+) + ;; 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) - (when initfun - (funcall initfun)))) + (funcall initfun))) (unless (or (not initfun) (slot-boundp-using-class class instance slotd)) - (setf (slot-value-using-class class instance slotd) - (funcall initfun))))))) + (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))))) + (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.