startup, not time since first call to GET-INTERNAL-REAL-TIME.
* improvement: SAVE-LISP-AND-DIE explicitly checks that multiple
threads are not running after *SAVE-HOOKS* have run.
+ * improvement: writes to CLOS instance slots are type-checked in code
+ compiled with (SAFETY 3)
* improvement: floating-point exception handling should work on all
- POSIX platforms (thanks to NIIMI Satoshi)
+ POSIX platforms (thanks to NIIMI Satoshi)
* bug fix: compiler bug triggered by a (non-standard) VALUES
declaration in a LET* was fixed. (reported by Kaersten Poeck)
* bug fix: file compiler no longer confuses validated and already
(set-slot-value #'optimize-set-slot-value)
(slot-boundp #'optimize-slot-boundp))))
(funcall fun slots parameter form))))
- ((and (eq (car form) 'apply)
- (consp (cadr form))
- (eq (car (cadr form)) 'function)
- (generic-function-name-p (cadr (cadr form))))
- (optimize-generic-function-call
- form required-parameters env slots calls))
- ((generic-function-name-p (car form))
- (optimize-generic-function-call
- form required-parameters env slots calls))
(t form))))
(let ((walked-lambda (walk-form method-lambda env #'walk-function)))
(set-slot 'name name)
(set-slot 'finalized-p t)
(set-slot 'source source)
+ (set-slot 'safe-p nil)
(set-slot '%type (if (eq class (find-class t))
t
;; FIXME: Could this just be CLASS instead
(set-val 'writers (get-val :writers))
(set-val 'allocation :instance)
(set-val '%type (or (get-val :type) t))
+ (set-val '%type-check-function (get-val 'type-check-function))
(set-val '%documentation (or (get-val :documentation) ""))
(set-val '%class class)
(when effective-p
;;; funcallable instance is set to it.
;;;
(!defstruct-with-alternate-metaclass ctor
- :slot-names (function-name class-name class initargs)
+ :slot-names (function-name class-name class initargs safe-p)
:boa-constructor %make-ctor
:superclass-name function
:metaclass-name static-classoid
(setf (%funcallable-instance-info ctor 1)
(ctor-function-name ctor))))
-(defun make-ctor-function-name (class-name initargs)
- (list* 'ctor class-name initargs))
+(defun make-ctor-function-name (class-name initargs safe-code-p)
+ (list* 'ctor class-name safe-code-p initargs))
;;; Keep this a separate function for testing.
-(defun ensure-ctor (function-name class-name initargs)
+(defun ensure-ctor (function-name class-name initargs safe-code-p)
(unless (fboundp function-name)
- (make-ctor function-name class-name initargs)))
+ (make-ctor function-name class-name initargs safe-code-p)))
;;; Keep this a separate function for testing.
-(defun make-ctor (function-name class-name initargs)
+(defun make-ctor (function-name class-name initargs safe-p)
(without-package-locks ; for (setf symbol-function)
- (let ((ctor (%make-ctor function-name class-name nil initargs)))
+ (let ((ctor (%make-ctor function-name class-name nil initargs safe-p)))
(push ctor *all-ctors*)
(setf (fdefinition function-name) ctor)
(install-initial-constructor ctor :force-p t)
;;; Compile-Time Expansion of MAKE-INSTANCE *******
;;; ***********************************************
-(define-compiler-macro make-instance (&whole form &rest args)
+(define-compiler-macro make-instance (&whole form &rest args &environment env)
(declare (ignore args))
- (or (make-instance->constructor-call form)
+ (or (make-instance->constructor-call form (safe-code-p env))
form))
-(defun make-instance->constructor-call (form)
+(defun make-instance->constructor-call (form safe-code-p)
(destructuring-bind (fn class-name &rest args) form
(declare (ignore fn))
(flet (;;
finally
(return (values initargs value-forms)))
(let* ((class-name (constant-form-value class-name))
- (function-name (make-ctor-function-name class-name initargs)))
+ (function-name (make-ctor-function-name class-name initargs
+ safe-code-p)))
;; Prevent compiler warnings for calling the ctor.
(proclaim-as-fun-name function-name)
(note-name-defined function-name :function)
`(locally
(declare (disable-package-locks ,function-name))
(let ((.x. (load-time-value
- (ensure-ctor ',function-name ',class-name ',initargs))))
+ (ensure-ctor ',function-name ',class-name ',initargs
+ ',safe-code-p))))
(declare (ignore .x.))
;; ??? check if this is worth it.
(declare
finally
(return (values around before (first primary) (reverse after)))))
+(defmacro with-type-checked ((type safe-p) &body body)
+ (if safe-p
+ ;; To handle FUNCTION types reasonable, we use SAFETY 3 and
+ ;; THE instead of e.g. CHECK-TYPE.
+ `(locally
+ (declare (optimize (safety 3)))
+ (the ,type (progn ,@body)))
+ `(progn ,@body)))
+
;;; Return as multiple values bindings for default initialization
;;; arguments, variable names, defaulting initargs and a body for
;;; initializing instance and class slots of an object costructed by
(let* ((class (ctor-class ctor))
(initargs (ctor-initargs ctor))
(initkeys (plist-keys initargs))
+ (safe-p (ctor-safe-p ctor))
(slot-vector
(make-array (layout-length (class-wrapper class))
:initial-element nil))
((integerp location)
(not (null (aref slot-vector location))))
(t (bug "Weird location in ~S" 'slot-init-forms))))
- (class-init (location type val)
+ (class-init (location kind val type)
(aver (consp location))
(unless (initializedp location)
- (push (list location type val) class-inits)))
- (instance-init (location type val)
+ (push (list location kind val type) class-inits)))
+ (instance-init (location kind val type)
(aver (integerp location))
(unless (initializedp location)
- (setf (aref slot-vector location) (list type val))))
+ (setf (aref slot-vector location) (list kind val type))))
(default-init-var-name (i)
(let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.)))
(if (array-in-bounds-p ps i)
;; Loop over supplied initargs and values and record which
;; instance and class slots they initialize.
(loop for (key value) on initargs by #'cddr
- as locations = (initarg-locations key) do
- (if (constantp value)
- (dolist (location locations)
- (if (consp location)
- (class-init location 'constant value)
- (instance-init location 'constant value)))
- (dolist (location locations)
- (if (consp location)
- (class-init location 'param value)
- (instance-init location 'param value)))))
+ as kind = (if (constantp value) 'constant 'param)
+ as locations = (initarg-locations key)
+ do (loop for (location . type) in locations
+ do (if (consp location)
+ (class-init location kind value type)
+ (instance-init location kind value type))))
;; Loop over default initargs of the class, recording
;; initializations of slots that have not been initialized
;; above. Default initargs which are not in the supplied
;; if not actually used for initializing a slot.
(loop for (key initform initfn) in default-initargs and i from 0
unless (member key initkeys :test #'eq) do
- (let* ((type (if (constantp initform) 'constant 'var))
- (init (if (eq type 'var) initfn initform)))
- (ecase type
+ (let* ((kind (if (constantp initform) 'constant 'var))
+ (init (if (eq kind 'var) initfn initform)))
+ (ecase kind
(constant
(push key defaulting-initargs)
(push initform defaulting-initargs))
(var
(push key defaulting-initargs)
(push (default-init-var-name i) defaulting-initargs)))
- (when (eq type 'var)
+ (when (eq kind 'var)
(let ((init-var (default-init-var-name i)))
(setq init init-var)
(push (cons init-var initfn) default-inits)))
- (dolist (location (initarg-locations key))
- (if (consp location)
- (class-init location type init)
- (instance-init location type init)))))
+ (loop for (location . type) in (initarg-locations key)
+ do (if (consp location)
+ (class-init location kind init type)
+ (instance-init location kind init type)))))
;; Loop over all slots of the class, filling in the rest from
;; slot initforms.
(loop for slotd in (class-slots class)
as location = (slot-definition-location slotd)
+ as type = (slot-definition-type slotd)
as allocation = (slot-definition-allocation slotd)
as initfn = (slot-definition-initfunction slotd)
as initform = (slot-definition-initform slotd) do
(null initfn)
(initializedp location))
(if (constantp initform)
- (instance-init location 'initform initform)
- (instance-init location 'initform/initfn initfn))))
+ (instance-init location 'initform initform type)
+ (instance-init location 'initform/initfn initfn type))))
;; Generate the forms for initializing instance and class slots.
(let ((instance-init-forms
(loop for slot-entry across slot-vector and i from 0
- as (type value) = slot-entry collect
- (ecase type
+ as (kind value type) = slot-entry collect
+ (ecase kind
((nil)
(unless before-method-p
`(setf (clos-slots-ref .slots. ,i) +slot-unbound+)))
((param var)
- `(setf (clos-slots-ref .slots. ,i) ,value))
+ `(setf (clos-slots-ref .slots. ,i)
+ (with-type-checked (,type ,safe-p)
+ ,value)))
(initfn
- `(setf (clos-slots-ref .slots. ,i) (funcall ,value)))
+ `(setf (clos-slots-ref .slots. ,i)
+ (with-type-checked (,type ,safe-p)
+ (funcall ,value))))
(initform/initfn
(if before-method-p
`(when (eq (clos-slots-ref .slots. ,i)
+slot-unbound+)
(setf (clos-slots-ref .slots. ,i)
- (funcall ,value)))
+ (with-type-checked (,type ,safe-p)
+ (funcall ,value))))
`(setf (clos-slots-ref .slots. ,i)
- (funcall ,value))))
+ (with-type-checked (,type ,safe-p)
+ (funcall ,value)))))
(initform
(if before-method-p
`(when (eq (clos-slots-ref .slots. ,i)
+slot-unbound+)
(setf (clos-slots-ref .slots. ,i)
- ',(constant-form-value value)))
+ (with-type-checked (,type ,safe-p)
+ ',(constant-form-value value))))
`(setf (clos-slots-ref .slots. ,i)
- ',(constant-form-value value))))
+ (with-type-checked (,type ,safe-p)
+ ',(constant-form-value value)))))
(constant
`(setf (clos-slots-ref .slots. ,i)
- ',(constant-form-value value)))))))
+ (with-type-checked (,type ,safe-p)
+ ',(constant-form-value value))))))))
;; we are not allowed to modify QUOTEd locations, so we can't
;; generate code like (setf (cdr ',location) arg). Instead,
;; we have to do (setf (cdr .L0.) arg) and arrange for .L0. to
;; be bound to the location.
(multiple-value-bind (names locations class-init-forms)
- (loop for (location type value) in class-inits
+ (loop for (location kind value type) in class-inits
for i upfrom 0
for name = (location-var-name i)
collect name into names
collect location into locations
collect `(setf (cdr ,name)
- ,(case type
- (constant `',(constant-form-value value))
- ((param var) `,value)
- (initfn `(funcall ,value))))
+ (with-type-checked (,type ,safe-p)
+ ,(case kind
+ (constant `',(constant-form-value value))
+ ((param var) `,value)
+ (initfn `(funcall ,value)))))
into class-init-forms
finally (return (values names locations class-init-forms)))
(multiple-value-bind (vars bindings)
`(,@(delete nil instance-init-forms)
,@class-init-forms))))))))
-;;; Return an alist of lists (KEY LOCATION ...) telling, for each
-;;; key in INITKEYS, which locations the initarg initializes.
-;;; CLASS is the class of the instance being initialized.
+;;; Return an alist of lists (KEY (LOCATION . TYPE-SPECIFIER) ...)
+;;; telling, for each key in INITKEYS, which locations the initarg
+;;; initializes and the associated type with the location. CLASS is
+;;; the class of the instance being initialized.
(defun compute-initarg-locations (class initkeys)
(loop with slots = (class-slots class)
for key in initkeys collect
(loop for slot in slots
if (memq key (slot-definition-initargs slot))
- collect (slot-definition-location slot) into locations
+ collect (cons (slot-definition-location slot)
+ (slot-definition-type slot))
+ into locations
else
collect slot into remaining-slots
finally
',*readers-for-this-defclass*
',*writers-for-this-defclass*
',*slot-names-for-this-defclass*
- (sb-c:source-location)))))
+ (sb-c:source-location)
+ ',(safe-code-p env)))))
(if defstruct-p
(progn
;; FIXME: (YUK!) Why do we do this? Because in order
(initargs ())
(others ())
(unsupplied (list nil))
+ (type t)
(initform unsupplied))
(check-slot-name-for-defclass name class-name env)
(push name *slot-names-for-this-defclass*)
(when (member key '(:initform :allocation :type :documentation))
(when (eq key :initform)
(setf initform val))
+ (when (eq key :type)
+ (setf type val))
(when (get-properties others (list key))
(error 'simple-program-error
:format-control "Duplicate slot option ~S for slot ~
((null head))
(unless (cdr (second head))
(setf (second head) (car (second head)))))
- (let ((canon `(:name ',name :readers ',readers :writers ',writers
- :initargs ',initargs ',others)))
+ (let* ((type-check-function
+ (if (eq type t)
+ nil
+ `('type-check-function (lambda (value)
+ (declare (type ,type value))
+ value))))
+ (canon `(:name ',name :readers ',readers :writers ',writers
+ :initargs ',initargs
+ ,@type-check-function
+ ',others)))
(push (if (eq initform unsupplied)
`(list* ,@canon)
`(list* :initfunction ,(make-initfunction initform)
(declaim (notinline load-defclass))
(defun load-defclass (name metaclass supers canonical-slots canonical-options
- readers writers slot-names source-location)
+ readers writers slot-names source-location safe-p)
+ ;; SAFE-P is used by REAL-LOAD-DEFCLASS, but can be ignored here, since
+ ;; during the bootstrap we won't have (SAFETY 3).
+ (declare (ignore safe-p))
(%compiler-defclass name readers writers slot-names)
(setq supers (copy-tree supers)
canonical-slots (copy-tree canonical-slots)
canonical-options (copy-tree canonical-options))
(let ((ecd
- (make-early-class-definition name
- source-location
- metaclass
- supers
- canonical-slots
- canonical-options))
+ (make-early-class-definition name
+ source-location
+ metaclass
+ supers
+ canonical-slots
+ canonical-options))
(existing
- (find name *early-class-definitions* :key #'ecd-class-name)))
+ (find name *early-class-definitions* :key #'ecd-class-name)))
(setq *early-class-definitions*
(cons ecd (remove existing *early-class-definitions*)))
ecd))
:initarg :initargs
:accessor slot-definition-initargs)
(%type :initform t :initarg :type :accessor slot-definition-type)
+ (%type-check-function :initform nil
+ :initarg type-check-function
+ :accessor slot-definition-type-check-function)
(%documentation
:initform nil :initarg :documentation
;; KLUDGE: we need a reader for bootstrapping purposes, in
(%documentation
:initform nil
:initarg :documentation)
+ ;; True if the class definition was compiled with a (SAFETY 3)
+ ;; optimization policy.
+ (safe-p
+ :initform nil
+ :initarg safe-p
+ :accessor safe-p)
(finalized-p
:initform nil
:reader class-finalized-p)))
(let ((class (early-method-class method)))
(or (eq class *the-class-standard-writer-method*)
(eq class *the-class-global-writer-method*)))
- (or (standard-writer-method-p method)
- (global-writer-method-p method))))
+ (and
+ (or (standard-writer-method-p method)
+ (global-writer-method-p method))
+ (not (safe-p
+ (slot-definition-class
+ (accessor-method-slot-definition method)))))))
methods)
'writer))))
(find-slot-definition accessor-class slot-name)))))
(when (and slotd
(or early-p
- (slot-accessor-std-p slotd accessor-type)))
+ (slot-accessor-std-p slotd accessor-type))
+ (or early-p
+ (not (safe-p accessor-class))))
(values (if early-p
(early-slot-definition-location slotd)
(slot-definition-location slotd))
(defmethod make-reader-method-function ((class funcallable-standard-class)
slot-name)
- (make-std-reader-method-function (class-name class) slot-name))
+ (make-std-reader-method-function class slot-name))
(defmethod make-writer-method-function ((class funcallable-standard-class)
slot-name)
- (make-std-writer-method-function (class-name class) slot-name))
+ (make-std-writer-method-function class slot-name))
;;;; See the comment about reader-function--std and writer-function--sdt.
;;;;
(defun make-optimized-std-writer-method-function
(fsc-p slotd slot-name location)
(declare #.*optimize-speed*)
- (set-fun-name
- (etypecase location
- (fixnum (if fsc-p
- (lambda (nv instance)
- (check-obsolete-instance instance)
- (setf (clos-slots-ref (fsc-instance-slots instance)
- location)
- nv))
- (lambda (nv instance)
- (check-obsolete-instance instance)
- (setf (clos-slots-ref (std-instance-slots instance)
- location)
- nv))))
- (cons (lambda (nv instance)
- (check-obsolete-instance instance)
- (setf (cdr location) nv)))
- (null
- (lambda (nv instance)
- (declare (ignore nv))
- (instance-structure-protocol-error slotd
- '(setf slot-value-using-class)))))
- `(writer ,slot-name)))
+ (let* ((safe-p (and slotd
+ (slot-definition-class slotd)
+ (safe-p (slot-definition-class slotd))))
+ (writer-fun (etypecase location
+ (fixnum (if fsc-p
+ (lambda (nv instance)
+ (check-obsolete-instance instance)
+ (setf (clos-slots-ref (fsc-instance-slots instance)
+ location)
+ nv))
+ (lambda (nv instance)
+ (check-obsolete-instance instance)
+ (setf (clos-slots-ref (std-instance-slots instance)
+ location)
+ nv))))
+ (cons (lambda (nv instance)
+ (check-obsolete-instance instance)
+ (setf (cdr location) nv)))
+ (null
+ (lambda (nv instance)
+ (declare (ignore nv instance))
+ (instance-structure-protocol-error
+ slotd
+ '(setf slot-value-using-class))))))
+ (checking-fun (lambda (new-value instance)
+ (check-obsolete-instance instance)
+ ;; If the SLOTD had a TYPE-CHECK-FUNCTION, call it.
+ (let* (;; Note that this CLASS is not neccessarily
+ ;; the SLOT-DEFINITION-CLASS of the
+ ;; SLOTD passed to M-O-S-W-M-F, since it's
+ ;; e.g. possible for a subclass to define
+ ;; a slot of the same name but with no
+ ;; accessors. So we need to fetch the SLOTD
+ ;; when CHECKING-FUN is called, instead of
+ ;; just closing over it.
+ (class (class-of instance))
+ (slotd (find-slot-definition class slot-name))
+ (type-check-function
+ (when slotd
+ (slot-definition-type-check-function slotd))))
+ (when type-check-function
+ (funcall type-check-function new-value)))
+ ;; Then call the real writer.
+ (funcall writer-fun new-value instance))))
+ (set-fun-name (if safe-p
+ checking-fun
+ writer-fun)
+ `(writer ,slot-name))))
(defun make-optimized-std-boundp-method-function
(fsc-p slotd slot-name location)
(defun make-optimized-std-setf-slot-value-using-class-method-function
(fsc-p slotd)
(declare #.*optimize-speed*)
- (let ((location (slot-definition-location slotd)))
- (etypecase location
- (fixnum
- (if fsc-p
- (lambda (nv class instance slotd)
- (declare (ignore class slotd))
- (check-obsolete-instance instance)
- (setf (clos-slots-ref (fsc-instance-slots instance) location)
- nv))
- (lambda (nv class instance slotd)
- (declare (ignore class slotd))
- (check-obsolete-instance instance)
- (setf (clos-slots-ref (std-instance-slots instance) location)
- nv))))
- (cons (lambda (nv class instance slotd)
- (declare (ignore class slotd))
- (check-obsolete-instance instance)
- (setf (cdr location) nv)))
- (null (lambda (nv class instance slotd)
- (declare (ignore nv class instance))
- (instance-structure-protocol-error
- slotd '(setf slot-value-using-class)))))))
+ (let ((location (slot-definition-location slotd))
+ (type-check-function
+ (when (and slotd
+ (slot-definition-class slotd)
+ (safe-p (slot-definition-class slotd)))
+ (slot-definition-type-check-function slotd))))
+ (macrolet ((make-mf-lambda (&body body)
+ `(lambda (nv class instance slotd)
+ (declare (ignore class slotd))
+ (check-obsolete-instance instance)
+ ,@body))
+ (make-mf-lambdas (&body body)
+ ;; Having separate lambdas for the NULL / not-NULL cases of
+ ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
+ ;; for CLOS typechecking when it's not in use.
+ `(if type-check-function
+ (make-mf-lambda
+ (funcall (the function type-check-function) nv)
+ ,@body)
+ (make-mf-lambda
+ ,@body))))
+ (etypecase location
+ (fixnum
+ (if fsc-p
+ (make-mf-lambdas
+ (setf (clos-slots-ref (fsc-instance-slots instance) location)
+ nv))
+ (make-mf-lambdas
+ (setf (clos-slots-ref (std-instance-slots instance) location)
+ nv))))
+ (cons
+ (make-mf-lambdas (setf (cdr location) nv)))
+ (null (lambda (nv class instance slotd)
+ (declare (ignore nv class instance))
+ (instance-structure-protocol-error
+ slotd '(setf slot-value-using-class))))))))
(defun make-optimized-std-slot-boundp-using-class-method-function
(fsc-p slotd)
(emf-funcall sdfun class instance slotd))))
`(,name ,(class-name class) ,(slot-definition-name slotd)))))
\f
-(defun make-std-reader-method-function (class-name slot-name)
+(defun make-std-reader-method-function (class-or-name slot-name)
+ (declare (ignore class-or-name))
(let* ((initargs (copy-tree
(make-method-function
(lambda (instance)
(list (list nil slot-name)))
initargs))
-(defun make-std-writer-method-function (class-name slot-name)
- (let* ((initargs (copy-tree
- (make-method-function
- (lambda (nv instance)
- (pv-binding1 (.pv. .calls.
- (bug "Please report this")
- (instance) (instance-slots))
- (instance-write-internal
- .pv. instance-slots 0 nv
- (setf (slot-value instance slot-name) nv))))))))
+(defun make-std-writer-method-function (class-or-name slot-name)
+ (let* ((class (when (eq *boot-state* 'complete)
+ (if (typep class-or-name 'class)
+ class-or-name
+ (find-class class-or-name nil))))
+ (safe-p (and class
+ (safe-p class)))
+ (check-fun (lambda (new-value instance)
+ (let* ((class (class-of instance))
+ (slotd (find-slot-definition class slot-name))
+ (type-check-function
+ (when slotd
+ (slot-definition-type-check-function slotd))))
+ (when type-check-function
+ (funcall type-check-function new-value)))))
+ (initargs (copy-tree
+ (if safe-p
+ (make-method-function
+ (lambda (nv instance)
+ (funcall check-fun nv instance)
+ (pv-binding1 (.pv. .calls.
+ (bug "Please report this")
+ (instance) (instance-slots))
+ (instance-write-internal
+ .pv. instance-slots 0 nv
+ (setf (slot-value instance slot-name) nv)))))
+ (make-method-function
+ (lambda (nv instance)
+ (pv-binding1 (.pv. .calls.
+ (bug "Please report this")
+ (instance) (instance-slots))
+ (instance-write-internal
+ .pv. instance-slots 0 nv
+ (setf (slot-value instance slot-name) nv)))))))))
(setf (getf (getf initargs 'plist) :slot-name-lists)
(list nil (list nil slot-name)))
initargs))
-(defun make-std-boundp-method-function (class-name slot-name)
+(defun make-std-boundp-method-function (class-or-name slot-name)
+ (declare (ignore class-or-name))
(let* ((initargs (copy-tree
(make-method-function
(lambda (instance)
(setf (slot-value-using-class class object slot-definition)
new-value))))
-(define-compiler-macro set-slot-value (&whole form object slot-name new-value)
+;;; A version of SET-SLOT-VALUE for use in safe code, where we want to
+;;; check types when writing to slots:
+;;; * Doesn't have an optimizing compiler-macro
+;;; * Isn't special-cased in WALK-METHOD-LAMBDA
+(defun safe-set-slot-value (object slot-name new-value)
+ (set-slot-value object slot-name new-value))
+
+(define-compiler-macro set-slot-value (&whole form object slot-name new-value
+ &environment env)
(if (and (constantp slot-name)
- (interned-symbol-p (constant-form-value slot-name)))
+ (interned-symbol-p (constant-form-value slot-name))
+ ;; We can't use the ACCESSOR-SET-SLOT-VALUE path in safe
+ ;; code, since it'll use the global automatically generated
+ ;; accessor, which won't do typechecking. (SLOT-OBJECT
+ ;; won't have been compiled with SAFETY 3, so SAFE-P will
+ ;; be NIL in MAKE-STD-WRITER-METHOD-FUNCTION).
+ (not (safe-code-p env)))
`(accessor-set-slot-value ,object ,slot-name ,new-value)
form))
(object standard-object)
(slotd standard-effective-slot-definition))
(check-obsolete-instance object)
- (let ((location (slot-definition-location slotd)))
- (typecase location
- (fixnum
- (cond ((std-instance-p object)
- (setf (clos-slots-ref (std-instance-slots object) location)
- new-value))
- ((fsc-instance-p object)
- (setf (clos-slots-ref (fsc-instance-slots object) location)
- new-value))
- (t (bug "unrecognized instance type in ~S"
- '(setf slot-value-using-class)))))
- (cons
- (setf (cdr location) new-value))
- (t
- (instance-structure-protocol-error slotd
- '(setf slot-value-using-class))))))
+ (let ((location (slot-definition-location slotd))
+ (type-check-function
+ (when (safe-p class)
+ (slot-definition-type-check-function slotd))))
+ (flet ((check (new-value)
+ (when type-check-function
+ (funcall (the function type-check-function) new-value))
+ new-value))
+ (typecase location
+ (fixnum
+ (cond ((std-instance-p object)
+ (setf (clos-slots-ref (std-instance-slots object) location)
+ (check new-value)))
+ ((fsc-instance-p object)
+ (setf (clos-slots-ref (fsc-instance-slots object) location)
+ (check new-value)))
+ (t (bug "unrecognized instance type in ~S"
+ '(setf slot-value-using-class)))))
+ (cons
+ (setf (cdr location) (check new-value)))
+ (t
+ (instance-structure-protocol-error
+ slotd '(setf slot-value-using-class)))))))
(defmethod slot-boundp-using-class
((class std-class)
(constantly (make-member-type :members (list (specializer-object specl))))))
(defun real-load-defclass (name metaclass-name supers slots other
- readers writers slot-names source-location)
+ readers writers slot-names source-location safe-p)
(with-single-package-locked-error (:symbol name "defining ~S as a class")
(%compiler-defclass name readers writers slot-names)
(let ((res (apply #'ensure-class name :metaclass metaclass-name
:direct-superclasses supers
:direct-slots slots
:definition-source source-location
+ 'safe-p safe-p
other)))
res)))
(allocation nil)
(allocation-class nil)
(type t)
+ (type-check-function nil)
(documentation nil)
(documentationp nil)
(namep nil)
allocation-class (slot-definition-class slotd)
allocp t))
(setq initargs (append (slot-definition-initargs slotd) initargs))
+ (let ((fun (slot-definition-type-check-function slotd)))
+ (when fun
+ (setf type-check-function
+ (if type-check-function
+ (let ((old-function type-check-function))
+ (lambda (value)
+ (funcall old-function value)
+ (funcall fun value)))
+ fun))))
(let ((slotd-type (slot-definition-type slotd)))
(setq type (cond
((eq type t) slotd-type)
:allocation allocation
:allocation-class allocation-class
:type type
+ 'type-check-function type-check-function
:class class
:documentation documentation)))
(let ((method (get-method generic-function () (list class) nil)))
(when method (remove-method generic-function method))))
\f
-;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITE-METHOD function are NOT
-;;; part of the standard protocol. They are however useful, PCL makes
-;;; use of them internally and documents them for PCL users.
+;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION
+;;; function are NOT part of the standard protocol. They are however
+;;; useful; PCL makes use of them internally and documents them for
+;;; PCL users. (FIXME: but SBCL certainly doesn't)
;;;
;;; *** This needs work to make type testing by the writer functions which
;;; *** do type testing faster. The idea would be to have one constructor
;;; *** defined for this metaclass a chance to run.
(defmethod make-reader-method-function ((class slot-class) slot-name)
- (make-std-reader-method-function (class-name class) slot-name))
+ (make-std-reader-method-function class slot-name))
(defmethod make-writer-method-function ((class slot-class) slot-name)
- (make-std-writer-method-function (class-name class) slot-name))
+ (make-std-writer-method-function class slot-name))
(defmethod make-boundp-method-function ((class slot-class) slot-name)
- (make-std-boundp-method-function (class-name class) slot-name))
+ (make-std-boundp-method-function class slot-name))
\f
(defmethod compatible-meta-class-change-p (class proto-new-class)
(eq (class-of class) (class-of proto-new-class)))
(setf (pvref pv i) (cdr map))))))
(incf param))))))
\f
-(defun maybe-expand-accessor-form (form required-parameters slots env)
- (let* ((fname (car form))
- #||(len (length form))||#
- (gf (if (symbolp fname)
- (unencapsulated-fdefinition fname)
- (gdefinition fname))))
- (macrolet ((maybe-optimize-reader ()
- `(let ((parameter
- (can-optimize-access1 (cadr form)
- required-parameters env)))
- (when parameter
- (optimize-reader slots parameter gf-name form))))
- (maybe-optimize-writer ()
- `(let ((parameter
- (can-optimize-access1 (caddr form)
- required-parameters env)))
- (when parameter
- (optimize-writer slots parameter gf-name form)))))
- (unless (and (consp (cadr form))
- (eq 'instance-accessor-parameter (caadr form)))
- (when (and (eq *boot-state* 'complete)
- (generic-function-p gf))
- (let ((methods (generic-function-methods gf)))
- (when methods
- (let* ((gf-name (generic-function-name gf))
- (arg-info (gf-arg-info gf))
- (metatypes (arg-info-metatypes arg-info))
- (nreq (length metatypes))
- (applyp (arg-info-applyp arg-info)))
- (when (null applyp)
- (cond ((= nreq 1)
- (when (some #'standard-reader-method-p methods)
- (maybe-optimize-reader)))
- ((and (= nreq 2)
- (consp gf-name)
- (eq (car gf-name) 'setf))
- (when (some #'standard-writer-method-p methods)
- (maybe-optimize-writer)))))))))))))
-
-(defun optimize-generic-function-call (form
- required-parameters
- env
- slots
- calls)
- (declare (ignore required-parameters env slots calls))
- (or ; (optimize-reader ...)?
- form))
-\f
(defun can-optimize-access (form required-parameters env)
(let ((type (ecase (car form)
(slot-value 'reader)
(defmacro optimized-set-slot-value (form parameter-name optimized-form
&environment env)
- (if (parameter-modified-p parameter-name env)
- `(accessor-set-slot-value ,@(cdr form))
- optimized-form))
+ (cond ((safe-code-p env)
+ ;; Don't optimize slot value setting in safe code, since the
+ ;; optimized version will fail to catch some type errors
+ ;; (for example when a subclass declares a tighter type for
+ ;; the slot than a superclass).
+ `(safe-set-slot-value ,@(cdr form)))
+ ((parameter-modified-p parameter-name env)
+ `(accessor-set-slot-value ,@(cdr form)))
+ (t
+ optimized-form)))
(defun optimize-slot-boundp (slots sparameter form)
(if sparameter
`(accessor-slot-boundp ,@(cdr form))
optimized-form))
-(defun optimize-reader (slots sparameter gf-name form)
- (if sparameter
- (optimize-accessor-call slots :read sparameter gf-name nil)
- form))
-
-(defun optimize-writer (slots sparameter gf-name form)
- (if sparameter
- (destructuring-bind (ignore1 ignore2 new-value) form
- (declare (ignore ignore1 ignore2))
- (optimize-accessor-call slots :write sparameter gf-name new-value))
- form))
-
;;; The SLOTS argument is an alist, the CAR of each entry is the name
;;; of a required parameter to the function. The alist is in order, so
;;; the position of an entry in the alist corresponds to the
`(instance-boundp ,pv-offset-form ,parameter ,position
',slot-name ',class)))))))
-(defun optimize-accessor-call (slots read/write sparameter gf-name new-value)
- (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
- (parameter (if (consp sparameter) (car sparameter) sparameter))
- (parameter-entry (assq parameter slots))
- (name (case read/write
- (:read `(reader ,gf-name))
- (:write `(writer ,gf-name))))
- (slot-entry (assoc name (cdr parameter-entry) :test #'equal))
- (position (posq parameter-entry slots))
- (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
- (unless parameter-entry
- (error "slot optimization bewilderment: O-A-C"))
- (unless slot-entry
- (setq slot-entry (list name))
- (push slot-entry (cdr parameter-entry)))
- (push pv-offset-form (cdr slot-entry))
- (ecase read/write
- (:read
- `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class))
- (:write
- `(let ((.new-value. ,new-value))
- (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class
- .new-value.))))))
-
(defvar *unspecific-arg* '..unspecific-arg..)
(defun optimize-gf-call-internal (form slots env)
(eq *boot-state* 'complete)
(not (slot-accessor-std-p slotd type)))))
-(defmacro instance-read-internal (pv slots pv-offset default &optional type)
- (unless (member type '(nil :instance :class :default))
- (error "illegal type argument to ~S: ~S" 'instance-read-internal type))
- (if (eq type :default)
+(defmacro instance-read-internal (pv slots pv-offset default &optional kind)
+ (unless (member kind '(nil :instance :class :default))
+ (error "illegal kind argument to ~S: ~S" 'instance-read-internal kind))
+ (if (eq kind :default)
default
(let* ((index (gensym))
(value index))
;; to shut it up. (see also mail Rudi
;; Schlatte sbcl-devel 2003-09-21) -- CSR,
;; 2003-11-30
- ,@(when (or (null type) (eq type :instance))
+ ,@(when (or (null kind) (eq kind :instance))
`((fixnum
(and ,slots ; KLUDGE
(clos-slots-ref ,slots ,index)))))
- ,@(when (or (null type) (eq type :class))
+ ,@(when (or (null kind) (eq kind :class))
`((cons (cdr ,index))))
(t +slot-unbound+)))
(if (eq ,value +slot-unbound+)
,(if (generate-fast-class-slot-access-p class slot-name)
:class :instance))))
-(defmacro instance-reader (pv-offset parameter position gf-name class)
- (declare (ignore class))
- `(instance-read-internal .pv. ,(slot-vector-symbol position)
- ,pv-offset
- (,gf-name (instance-accessor-parameter ,parameter))
- :instance))
-
(defmacro instance-write-internal (pv slots pv-offset new-value default
- &optional type)
- (unless (member type '(nil :instance :class :default))
- (error "illegal type argument to ~S: ~S" 'instance-write-internal type))
- (if (eq type :default)
+ &optional kind)
+ (unless (member kind '(nil :instance :class :default))
+ (error "illegal kind argument to ~S: ~S" 'instance-write-internal kind))
+ (if (eq kind :default)
default
(let* ((index (gensym)))
`(locally (declare #.*optimize-speed*)
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
- ,@(when (or (null type) (eq type :instance))
+ ,@(when (or (null kind) (eq kind :instance))
`((fixnum (and ,slots
(setf (clos-slots-ref ,slots ,index)
,new-value)))))
- ,@(when (or (null type) (eq type :class))
+ ,@(when (or (null kind) (eq kind :class))
`((cons (setf (cdr ,index) ,new-value))))
(t ,default)))))))
,(if (generate-fast-class-slot-access-p class slot-name)
:class :instance))))
-(defmacro instance-writer (pv-offset
- parameter
- position
- gf-name
- class
- new-value)
- (declare (ignore class))
- `(instance-write-internal .pv. ,(slot-vector-symbol position)
- ,pv-offset ,new-value
- (,(if (consp gf-name)
- (get-setf-fun-name gf-name)
- gf-name)
- (instance-accessor-parameter ,parameter)
- ,new-value)
- :instance))
-
(defmacro instance-boundp-internal (pv slots pv-offset default
- &optional type)
- (unless (member type '(nil :instance :class :default))
- (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type))
- (if (eq type :default)
+ &optional kind)
+ (unless (member kind '(nil :instance :class :default))
+ (error "illegal kind argument to ~S: ~S" 'instance-boundp-internal kind))
+ (if (eq kind :default)
default
(let* ((index (gensym)))
`(locally (declare #.*optimize-speed*)
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
- ,@(when (or (null type) (eq type :instance))
+ ,@(when (or (null kind) (eq kind :instance))
`((fixnum (not (and ,slots
(eq (clos-slots-ref ,slots ,index)
+slot-unbound+))))))
- ,@(when (or (null type) (eq type :class))
+ ,@(when (or (null kind) (eq kind :class))
`((cons (not (eq (cdr ,index) +slot-unbound+)))))
(t ,default)))))))
when snl
collect w into result
finally (return (if (cdr result) result (car result)))))
+
(defun var-globally-special-p (symbol)
(eq (info :variable :kind symbol) :special))
+
\f
;;;; handling of special forms
(relist*
form let/let* walked-bindings walked-body))))
-(defun walk-locally (form context env)
+(defun walk-locally (form context old-env)
(declare (ignore context))
- (let* ((locally (car form))
- (body (cdr form))
- (walked-body
- (walk-declarations body #'walk-repeat-eval env)))
- (relist*
- form locally walked-body)))
+ (walker-environment-bind (new-env old-env)
+ (let* ((locally (car form))
+ (body (cdr form))
+ (walked-body
+ (walk-declarations body #'walk-repeat-eval new-env)))
+ (relist*
+ form locally walked-body))))
(defun walk-multiple-value-setq (form context env)
(let ((vars (cadr form)))
(walk-tagbody-1 (cdr form) context env))))
(defun walk-macrolet (form context old-env)
- (walker-environment-bind (macro-env
- nil
- :walk-function (env-walk-function old-env))
- (labels ((walk-definitions (definitions)
- (and definitions
- (let ((definition (car definitions)))
- (recons definitions
- (relist* definition
- (car definition)
- (walk-arglist (cadr definition)
- context
- macro-env
- t)
- (walk-declarations (cddr definition)
- #'walk-repeat-eval
- macro-env))
- (walk-definitions (cdr definitions)))))))
- (with-new-definition-in-environment (new-env old-env form)
- (relist* form
- (car form)
- (walk-definitions (cadr form))
- (walk-declarations (cddr form)
- #'walk-repeat-eval
- new-env))))))
+ (walker-environment-bind (old-env old-env)
+ (walker-environment-bind (macro-env
+ nil
+ :walk-function (env-walk-function old-env))
+ (labels ((walk-definitions (definitions)
+ (and definitions
+ (let ((definition (car definitions)))
+ (recons definitions
+ (relist* definition
+ (car definition)
+ (walk-arglist (cadr definition)
+ context
+ macro-env
+ t)
+ (walk-declarations (cddr definition)
+ #'walk-repeat-eval
+ macro-env))
+ (walk-definitions (cdr definitions)))))))
+ (with-new-definition-in-environment (new-env old-env form)
+ (relist* form
+ (car form)
+ (walk-definitions (cadr form))
+ (walk-declarations (cddr form)
+ #'walk-repeat-eval
+ new-env)))))))
(defun walk-flet (form context old-env)
- (labels ((walk-definitions (definitions)
- (if (null definitions)
- ()
- (recons definitions
- (walk-lambda (car definitions) context old-env)
- (walk-definitions (cdr definitions))))))
- (recons form
- (car form)
- (recons (cdr form)
- (walk-definitions (cadr form))
- (with-new-definition-in-environment (new-env old-env form)
- (walk-declarations (cddr form)
- #'walk-repeat-eval
- new-env))))))
-
-(defun walk-labels (form context old-env)
- (with-new-definition-in-environment (new-env old-env form)
+ (walker-environment-bind (old-env old-env)
(labels ((walk-definitions (definitions)
(if (null definitions)
()
(recons definitions
- (walk-lambda (car definitions) context new-env)
+ (walk-lambda (car definitions) context old-env)
(walk-definitions (cdr definitions))))))
(recons form
(car form)
(recons (cdr form)
(walk-definitions (cadr form))
- (walk-declarations (cddr form)
- #'walk-repeat-eval
- new-env))))))
+ (with-new-definition-in-environment (new-env old-env form)
+ (walk-declarations (cddr form)
+ #'walk-repeat-eval
+ new-env)))))))
+
+(defun walk-labels (form context old-env)
+ (walker-environment-bind (old-env old-env)
+ (with-new-definition-in-environment (new-env old-env form)
+ (labels ((walk-definitions (definitions)
+ (if (null definitions)
+ ()
+ (recons definitions
+ (walk-lambda (car definitions) context new-env)
+ (walk-definitions (cdr definitions))))))
+ (recons form
+ (car form)
+ (recons (cdr form)
+ (walk-definitions (cadr form))
+ (walk-declarations (cddr form)
+ #'walk-repeat-eval
+ new-env)))))))
(defun walk-if (form context env)
(destructuring-bind (if predicate arm1 &optional arm2) form
--- /dev/null
+;;;; This file is for testing typechecking of writes to CLOS object slots
+;;;; for code compiled with a (SAFETY 3) optimization policy.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(shadow 'slot)
+
+(declaim (optimize safety))
+
+(defclass foo ()
+ ((slot :initarg :slot :type fixnum :accessor slot)))
+(defclass foo/gf (sb-mop:standard-generic-function)
+ ((slot/gf :initarg :slot/gf :type fixnum :accessor slot/gf))
+ (:metaclass sb-mop:funcallable-standard-class))
+(defmethod succeed/sv ((x foo))
+ (setf (slot-value x 'slot) 1))
+(defmethod fail/sv ((x foo))
+ (setf (slot-value x 'slot) t))
+(defmethod succeed/acc ((x foo))
+ (setf (slot x) 1))
+(defmethod fail/acc ((x foo))
+ (setf (slot x) t))
+(defmethod succeed/sv/gf ((x foo/gf))
+ (setf (slot-value x 'slot/gf) 1))
+(defmethod fail/sv/gf ((x foo/gf))
+ (setf (slot-value x 'slot/gf) t))
+(defmethod succeed/acc/gf ((x foo/gf))
+ (setf (slot/gf x) 1))
+(defmethod fail/acc/gf ((x foo/gf))
+ (setf (slot/gf x) t))
+(defvar *t* t)
+(defvar *one* 1)
+
+;; evaluator
+(with-test (:name (:evaluator))
+ (eval '(setf (slot-value (make-instance 'foo) 'slot) 1))
+ (assert (raises-error? (eval '(setf (slot-value (make-instance 'foo) 'slot) t))
+ type-error))
+ (eval '(setf (slot (make-instance 'foo)) 1))
+ (assert (raises-error? (eval '(setf (slot (make-instance 'foo)) t))
+ type-error))
+ (eval '(succeed/sv (make-instance 'foo)))
+ (assert (raises-error? (eval '(fail/sv (make-instance 'foo)))
+ type-error))
+ (eval '(succeed/acc (make-instance 'foo)))
+ (assert (raises-error? (eval '(fail/acc (make-instance 'foo)))
+ type-error))
+ (eval '(make-instance 'foo :slot 1))
+ (assert (raises-error? (eval '(make-instance 'foo :slot t))
+ type-error))
+ (eval '(make-instance 'foo :slot *one*))
+ (assert (raises-error? (eval '(make-instance 'foo :slot *t*))
+ type-error)))
+;; evaluator/gf
+(with-test (:name (:evaluator/gf))
+ (eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1))
+ (assert (raises-error?
+ (eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) t))
+ type-error))
+ (eval '(setf (slot/gf (make-instance 'foo/gf)) 1))
+ (assert (raises-error? (eval '(setf (slot/gf (make-instance 'foo/gf)) t))
+ type-error))
+ (eval '(succeed/sv/gf (make-instance 'foo/gf)))
+ (assert (raises-error? (eval '(fail/sv/gf (make-instance 'foo/gf)))
+ type-error))
+ (eval '(succeed/acc/gf (make-instance 'foo/gf)))
+ (assert (raises-error? (eval '(fail/acc/gf (make-instance 'foo/gf)))
+ type-error))
+ (eval '(make-instance 'foo/gf :slot/gf 1))
+ (assert (raises-error? (eval '(make-instance 'foo/gf :slot/gf t))
+ type-error))
+ (eval '(make-instance 'foo/gf :slot/gf *one*))
+ (assert (raises-error? (eval '(make-instance 'foo/gf :slot/gf *t*))
+ type-error)))
+
+;; compiler
+(with-test (:name (:compiler))
+ (funcall (compile nil '(lambda ()
+ (setf (slot-value (make-instance 'foo) 'slot) 1))))
+ (funcall (compile nil '(lambda () (setf (slot (make-instance 'foo)) 1))))
+ (assert (raises-error?
+ (funcall
+ (compile nil '(lambda () (setf (slot (make-instance 'foo)) t))))
+ type-error))
+ (funcall (compile nil '(lambda () (succeed/sv (make-instance 'foo)))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda () (fail/sv (make-instance 'foo)))))
+ type-error))
+ (funcall (compile nil '(lambda () (succeed/acc (make-instance 'foo)))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda () (fail/acc (make-instance 'foo)))))
+ type-error))
+ (funcall (compile nil '(lambda () (make-instance 'foo :slot 1))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda () (make-instance 'foo :slot t))))
+ type-error))
+ (funcall (compile nil '(lambda () (make-instance 'foo :slot *one*))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda () (make-instance 'foo :slot *t*))))
+ type-error)))
+
+(with-test (:name (:compiler :setf :slot-value))
+ (assert (raises-error?
+ (funcall
+ (compile nil '(lambda ()
+ (setf (slot-value (make-instance 'foo) 'slot) t))))
+ type-error)))
+
+; compiler/gf
+(with-test (:name (:compiler/gf))
+ (funcall (compile nil
+ '(lambda ()
+ (setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1))))
+ (funcall (compile nil '(lambda () (setf (slot/gf (make-instance 'foo/gf)) 1))))
+ (assert (raises-error?
+ (funcall
+ (compile nil
+ '(lambda () (setf (slot/gf (make-instance 'foo/gf)) t))))
+ type-error))
+ (funcall (compile nil '(lambda () (succeed/sv/gf (make-instance 'foo/gf)))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda ()
+ (fail/sv/gf (make-instance 'foo/gf)))))
+ type-error))
+ (funcall (compile nil '(lambda () (succeed/acc/gf (make-instance 'foo/gf)))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda ()
+ (fail/acc/gf (make-instance 'foo/gf)))))
+ type-error))
+ (funcall (compile nil '(lambda () (make-instance 'foo/gf :slot/gf 1))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda ()
+ (make-instance 'foo/gf :slot/gf t))))
+ type-error))
+ (funcall (compile nil '(lambda () (make-instance 'foo/gf :slot/gf *one*))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda ()
+ (make-instance 'foo/gf :slot/gf *t*))))
+ type-error)))
+
+(with-test (:name (:compiler/gf :setf :slot-value))
+ (assert (raises-error?
+ (funcall
+ (compile nil
+ '(lambda ()
+ (setf (slot-value (make-instance 'foo/gf) 'slot/gf) t))))
+ type-error)))
+
+
+(with-test (:name (:slot-inheritance :slot-value :float/single-float))
+ (defclass a () ((slot1 :initform 0.0 :type float)))
+ (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
+ (defmethod inheritance-test ((a a)) (setf (slot-value a 'slot1) 1d0))
+ (inheritance-test (make-instance 'a))
+ (assert (raises-error? (inheritance-test (make-instance 'b)) type-error)))
+
+(with-test (:name (:slot-inheritance :slot-value :t/single-float))
+ (defclass a () ((slot1 :initform 0.0)))
+ (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
+ (defmethod inheritance-test ((a a)) (setf (slot-value a 'slot1) 1d0))
+ (inheritance-test (make-instance 'a))
+ (assert (raises-error? (inheritance-test (make-instance 'b)) type-error)))
+
+(with-test (:name (:slot-inheritance :writer :float/single-float))
+ (defclass a () ((slot1 :initform 0.0 :type float :accessor slot1-of)))
+ (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
+ (defmethod inheritance-test ((a a)) (setf (slot1-of a) 1d0))
+ (inheritance-test (make-instance 'a))
+ (assert (raises-error? (inheritance-test (make-instance 'b)) type-error)))
+
+(with-test (:name (:slot-inheritance :writer :float/single-float))
+ (defclass a () ((slot1 :initform 0.0 :accessor slot1-of)))
+ (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
+ (defmethod inheritance-test ((a a)) (setf (slot1-of a) 1d0))
+ (inheritance-test (make-instance 'a))
+ (assert (raises-error? (inheritance-test (make-instance 'b)) type-error)))
+
+(with-test (:name (:slot-inheritance :type-intersection))
+ (defclass a* ()
+ ((slot1 :initform 1
+ :initarg :slot1
+ :accessor slot1-of
+ :type fixnum)))
+ (defclass b* ()
+ ((slot1 :initform 1
+ :initarg :slot1
+ :accessor slot1-of
+ :type unsigned-byte)))
+ (defclass c* (a* b*)
+ ())
+ (setf (slot1-of (make-instance 'a*)) -1)
+ (setf (slot1-of (make-instance 'b*)) (1+ most-positive-fixnum))
+ (setf (slot1-of (make-instance 'c*)) 1)
+ (assert (raises-error? (setf (slot1-of (make-instance 'c*)) -1)
+ type-error))
+ (assert (raises-error? (setf (slot1-of (make-instance 'c*))
+ (1+ most-positive-fixnum))
+ type-error))
+ (assert (raises-error? (make-instance 'c* :slot1 -1)
+ type-error))
+ (assert (raises-error? (make-instance 'c* :slot1 (1+ most-positive-fixnum))
+ type-error)))
+
+(defclass a ()
+ ((slot1 :initform nil
+ :initarg :slot1
+ :accessor slot1-of
+ :type (or null function))))
+(defclass b (a)
+ ((slot1 :initform nil
+ :initarg :slot1
+ :accessor slot1-of
+ :type (or null (function (fixnum) fixnum)))))
+
+(with-test (:name (:type :function))
+ (setf (slot1-of (make-instance 'a)) (lambda () 1))
+ (setf (slot1-of (make-instance 'b)) (lambda () 1))
+ (assert (raises-error? (setf (slot1-of (make-instance 'a)) 1)
+ type-error))
+ (assert (raises-error? (setf (slot1-of (make-instance 'b)) 1)
+ type-error))
+ (make-instance 'a :slot1 (lambda () 1))
+ (make-instance 'b :slot1 (lambda () 1)))
+
+
;;; A distilled test case from cmucl-imp for Kevin Rosenberg's
;;; hyperobject. Fix from Gerd Moellmann.
(defclass hyperobject-class (standard-class)
- ((user-name :initarg :user-name :type string :initform nil
+ ((user-name :initarg :user-name :type (or null string) :initform nil
:accessor user-name
:documentation "User name for class")))
;;; confusing.
(with-test (:name (:ctor :typep-function))
(assert (eval '(typep (sb-pcl::ensure-ctor
- (list 'sb-pcl::ctor (gensym)) nil nil)
+ (list 'sb-pcl::ctor (gensym)) nil nil nil)
'function))))
(with-test (:name (:ctor :functionp))
(assert (functionp (sb-pcl::ensure-ctor
- (list 'sb-pcl::ctor (gensym)) nil nil))))
+ (list 'sb-pcl::ctor (gensym)) nil nil nil))))
\f
;;; from PFD ansi-tests
(let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.18.37"
+"0.9.18.38"
projects / sbcl.git / commitdiff