(apply #'shared-initialize instance nil initargs)
instance)
-(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-system-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)))
+(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
+ "~@<Invalid ~S initialization: the initialization ~
+ argument ~S was ~
+ ~[missing~*~;not a symbol: ~S~;constant: ~S~].~@:>"
+ '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
+ "~@<Invalid ~S initialization: the initialization ~
+ argument ~S was ~S, which is not of type ~S.~@:>"
+ '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)
- (setf (slot-definition-info slotd)
- (multiple-value-bind (typecheck type) (generate-slotd-typecheck slotd)
- (make-slot-info :slotd slotd
- :typecheck typecheck))))
+ (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))
- (multiple-value-bind (typecheck type) (generate-slotd-typecheck slotd)
- (setf (slot-info-typecheck (slot-definition-info slotd)) typecheck)))
+ (generate-slotd-typecheck slotd (slot-definition-info slotd)))
(defmethod update-instance-for-different-class
((previous standard-object) (current standard-object) &rest initargs)
projects / sbcl.git / blobdiff