X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Finit.lisp;h=14475ea1bdd8da639698e4a548f359cb96de962b;hb=HEAD;hp=62a342f5c2badb5a807c310fa59b3e3b5c034039;hpb=5b5853f5f58c84f89e2edfc90805e658e188cd31;p=sbcl.git diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 62a342f..14475ea 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,148 @@ (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)))))))) + +(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