X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Finit.lisp;h=14475ea1bdd8da639698e4a548f359cb96de962b;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=40a922a15d482c21d5c0953159b83adae2135883;hpb=157e71ec49058247ee490f654072c04231c99486;p=sbcl.git diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 40a922a..14475ea 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) +(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 + 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,245 @@ (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 :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)))))))) + +(define-condition slotd-initialization-error (reference-condition error) + ((initarg :initarg :initarg :reader slotd-initialization-error-initarg) + (kind :initarg :kind :reader slotd-initialization-error-kind) + (value :initarg :value :initform nil :reader slotd-initialization-error-value)) + (:default-initargs :references (list '(:amop :initialization slot-definition))) + (:report (lambda (condition stream) + (let ((initarg (slotd-initialization-error-initarg condition)) + (kind (slotd-initialization-error-kind condition)) + (value (slotd-initialization-error-value condition))) + (format stream + "~@" + 'slot-definition initarg + (getf '(:missing 0 :symbol 1 :constant 2) kind) + value))))) + +(define-condition slotd-initialization-type-error (slotd-initialization-error type-error) + ((value :initarg :datum)) + (:report (lambda (condition stream) + (let ((initarg (slotd-initialization-error-initarg condition)) + (datum (type-error-datum condition)) + (expected-type (type-error-expected-type condition))) + (format stream + "~@" + 'slot-definition initarg + datum expected-type))))) + +(defmethod initialize-instance :before ((slotd slot-definition) + &key (name nil namep) + (initform nil initformp) + (initfunction nil initfunp) + (type nil typep) + (allocation nil allocationp) + (initargs nil initargsp) + (documentation nil docp)) + (unless namep + (error 'slotd-initialization-error :initarg :name :kind :missing)) + (unless (symbolp name) + (error 'slotd-initialization-type-error :initarg :name :datum name :expected-type 'symbol)) + (when (and (constantp name) + ;; KLUDGE: names of structure slots are weird, and their + ;; weird behaviour gets grandfathered in this way. (The + ;; negative constraint is hard to express in normal + ;; CLOS method terms). + (not (typep slotd 'structure-slot-definition))) + (error 'slotd-initialization-error :initarg :name :kind :constant :value name)) + (when (and initformp (not initfunp)) + (error 'slotd-initialization-error :initarg :initfunction :kind :missing)) + (when (and initfunp (not initformp)) + (error 'slotd-initialization-error :initarg :initform :kind :missing)) + (when (and typep (not t)) + ;; FIXME: do something. Need SYNTACTICALLY-VALID-TYPE-SPECIFIER-P + ) + (when (and allocationp (not (symbolp allocation))) + (error 'slotd-initialization-type-error :initarg :allocation :datum allocation :expected-type 'symbol)) + (when initargsp + (unless (typep initargs 'list) + (error 'slotd-initialization-type-error :initarg :initarg :datum initargs :expected-type 'list)) + (do ((is initargs (cdr is))) + ((atom is) + (unless (null is) + (error 'slotd-initialization-type-error :initarg :initarg :datum initargs :expected-type '(satisfies proper-list-p)))) + (unless (symbolp (car is)) + (error 'slotd-initialization-type-error :initarg :initarg :datum is :expected-type '(or null (cons symbol)))))) + (when docp + (unless (typep documentation '(or null string)) + (error 'slotd-initialization-type-error :initarg :documentation :datum documentation :expected-type '(or null string))))) + +(defmethod initialize-instance :before ((dslotd direct-slot-definition) + &key + (readers nil readersp) + (writers nil writersp)) + (macrolet ((check (arg argp) + `(when ,argp + (unless (typep ,arg 'list) + (error 'slotd-initialization-type-error + :initarg ,(keywordicate arg) + :datum ,arg :expected-type 'list)) + (do ((as ,arg (cdr as))) + ((atom as) + (unless (null as) + (error 'slotd-initialization-type-error + :initarg ,(keywordicate arg) + :datum ,arg :expected-type '(satisfies proper-list-p)))) + (unless (valid-function-name-p (car as)) + (error 'slotd-initialization-type-error + :initarg ,(keywordicate arg) + :datum ,arg :expected-type '(or null (cons (satisfies valid-function-name-p))))))))) + (check readers readersp) + (check writers writersp))) + +(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 ;; 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 (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. (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 +306,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 +318,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 +332,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))