mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
0.8.18.11.clos-typechecking.1:
Initial checkin of typechecking code in PCL.
There are still some cases #+niled out in the
clos-typechecking.impure.lisp test file which fail, for reasons
moderately unknown;
No sanity-checking is done on the types at defclass type; this
is particularly bad for compound function types;
My recollection is a bit hazy but I think I only implemented
typechecking in those cases where there wouldn't be a full
call to typep at runtime. This should be checked (as well as
other performance implications). Ideally untyped slots would
have no performance impact at all.
Teaching the compiler to infer types might be tricky, because of
the natural dynamicity of CLOS.
This commit is contained in:
Christophe Rhodes
parent
3820ea37e9
commit
ea1220d507
|
|
@ -493,14 +493,14 @@
|
|||
((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)
|
||||
|
|
@ -509,16 +509,12 @@
|
|||
;; 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
|
||||
|
|
@ -527,27 +523,28 @@
|
|||
;; if not actually used for initializing a slot.
|
||||
(loop for (key initfn initform) 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
|
||||
|
|
@ -555,45 +552,57 @@
|
|||
(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)
|
||||
(locally (declare (optimize (safety 3)))
|
||||
(the ,type ,value))))
|
||||
(initfn
|
||||
`(setf (clos-slots-ref .slots. ,i) (funcall ,value)))
|
||||
`(setf (clos-slots-ref .slots. ,i)
|
||||
(locally (declare (optimize (safety 3)))
|
||||
(the ,type (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)))
|
||||
(locally (declare (optimize (safety 3)))
|
||||
(the ,type (funcall ,value)))))
|
||||
`(setf (clos-slots-ref .slots. ,i)
|
||||
(funcall ,value))))
|
||||
(locally (declare (optimize (safety 3)))
|
||||
(the ,type (funcall ,value))))))
|
||||
(initform
|
||||
(if before-method-p
|
||||
`(when (eq (clos-slots-ref .slots. ,i)
|
||||
+slot-unbound+)
|
||||
(setf (clos-slots-ref .slots. ,i)
|
||||
',(eval value)))
|
||||
(locally (declare (optimize (safety 3)))
|
||||
(the ,type ',(eval value)))))
|
||||
`(setf (clos-slots-ref .slots. ,i)
|
||||
',(eval value))))
|
||||
(locally (declare (optimize (safety 3)))
|
||||
(the ,type ',(eval value))))))
|
||||
(constant
|
||||
`(setf (clos-slots-ref .slots. ,i) ',(eval value))))))
|
||||
`(setf (clos-slots-ref .slots. ,i)
|
||||
(locally (declare (optimize (safety 3)))
|
||||
(the ,type ',(eval value))))))))
|
||||
(class-init-forms
|
||||
(loop for (location type value) in class-inits collect
|
||||
(loop for (location kind value type) in class-inits collect
|
||||
`(setf (cdr ',location)
|
||||
,(ecase type
|
||||
(constant `',(eval value))
|
||||
((param var) `,value)
|
||||
(initfn `(funcall ,value)))))))
|
||||
(locally (declare (optimize (safety 3)))
|
||||
(the ,type
|
||||
,(ecase kind
|
||||
(constant `',(eval value))
|
||||
((param var) `,value)
|
||||
(initfn `(funcall ,value)))))))))
|
||||
(multiple-value-bind (vars bindings)
|
||||
(loop for (var . initfn) in (nreverse default-inits)
|
||||
collect var into vars
|
||||
|
|
@ -603,15 +612,18 @@
|
|||
`(,@(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
|
||||
|
|
|
|||
|
|
@ -906,7 +906,11 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28
|
|||
(if (consp method)
|
||||
(eq *the-class-standard-writer-method*
|
||||
(early-method-class method))
|
||||
(standard-writer-method-p method)))
|
||||
(and
|
||||
(standard-writer-method-p method)
|
||||
(eq (slot-definition-type
|
||||
(accessor-method-slot-definition method))
|
||||
t))))
|
||||
methods)
|
||||
'writer))))
|
||||
|
||||
|
|
@ -1282,7 +1286,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28
|
|||
(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
|
||||
(eq (slot-definition-type slotd) t)))
|
||||
(values (if early-p
|
||||
(early-slot-definition-location slotd)
|
||||
(slot-definition-location slotd))
|
||||
|
|
|
|||
|
|
@ -236,28 +236,51 @@
|
|||
(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
|
||||
(let ((type (or (not slotd) (slot-definition-type slotd))))
|
||||
(set-fun-name
|
||||
(etypecase location
|
||||
(fixnum (if fsc-p
|
||||
(if (eq type t)
|
||||
(lambda (nv instance)
|
||||
(check-obsolete-instance instance)
|
||||
(setf (clos-slots-ref (fsc-instance-slots instance)
|
||||
location)
|
||||
nv))
|
||||
(lambda (nv instance)
|
||||
(check-obsolete-instance instance)
|
||||
(unless (typep nv type)
|
||||
(error 'type-error :datum nv :expected-type type))
|
||||
(setf (clos-slots-ref (fsc-instance-slots instance)
|
||||
location)
|
||||
nv)))
|
||||
(if (eq type t)
|
||||
(lambda (nv instance)
|
||||
(check-obsolete-instance instance)
|
||||
(setf (clos-slots-ref (std-instance-slots instance)
|
||||
location)
|
||||
nv))
|
||||
(lambda (nv instance)
|
||||
(check-obsolete-instance instance)
|
||||
(unless (typep nv type)
|
||||
(error 'type-error :datum nv :expected-type type))
|
||||
(setf (clos-slots-ref (std-instance-slots instance)
|
||||
location)
|
||||
nv)))))
|
||||
(cons (if (eq type t)
|
||||
(lambda (nv instance)
|
||||
(check-obsolete-instance instance)
|
||||
(setf (clos-slots-ref (fsc-instance-slots instance)
|
||||
location)
|
||||
nv))
|
||||
(setf (cdr 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)))
|
||||
(unless (typep nv type)
|
||||
(error 'type-error :datum nv :expected-type type))
|
||||
(setf (cdr location) nv))))
|
||||
(null
|
||||
(lambda (nv instance)
|
||||
(declare (ignore nv))
|
||||
(instance-structure-protocol-error slotd
|
||||
'(setf slot-value-using-class)))))
|
||||
`(writer ,slot-name))))
|
||||
|
||||
(defun make-optimized-std-boundp-method-function
|
||||
(fsc-p slotd slot-name location)
|
||||
|
|
@ -385,24 +408,51 @@
|
|||
(defun make-optimized-std-setf-slot-value-using-class-method-function
|
||||
(fsc-p slotd)
|
||||
(declare #.*optimize-speed*)
|
||||
(let ((location (slot-definition-location slotd)))
|
||||
(let ((location (slot-definition-location slotd))
|
||||
(type (slot-definition-type 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)))
|
||||
(if (eq type t)
|
||||
(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)
|
||||
;; FIXME: this is going to make a mockery of the
|
||||
;; "optimized" bit. Full call to typep on every slot
|
||||
;; write? Still, let's see if it works...
|
||||
(unless (typep nv type)
|
||||
(error 'type-error :datum nv :expected-type type))
|
||||
(setf (clos-slots-ref (fsc-instance-slots instance) location)
|
||||
nv)))
|
||||
(if (eq type t)
|
||||
(lambda (nv class instance slotd)
|
||||
(declare (ignore class slotd))
|
||||
(check-obsolete-instance instance)
|
||||
(setf (clos-slots-ref (std-instance-slots instance) location)
|
||||
nv))
|
||||
(lambda (nv class instance slotd)
|
||||
(declare (ignore class slotd))
|
||||
(check-obsolete-instance instance)
|
||||
(unless (typep nv type)
|
||||
(error 'type-error :datum nv :expected-type type))
|
||||
(setf (clos-slots-ref (std-instance-slots instance) location)
|
||||
nv)))))
|
||||
(cons (if (eq type t)
|
||||
(lambda (nv class instance slotd)
|
||||
(declare (ignore class slotd))
|
||||
(check-obsolete-instance instance)
|
||||
(setf (cdr location) nv))
|
||||
(lambda (nv class instance slotd)
|
||||
(declare (ignore class slotd))
|
||||
(check-obsolete-instance instance)
|
||||
(unless (typep nv type)
|
||||
(error 'type-error :datum nv :expected-type type))
|
||||
(setf (cdr location) nv))))
|
||||
(null (lambda (nv class instance slotd)
|
||||
(declare (ignore nv class instance))
|
||||
(instance-structure-protocol-error
|
||||
|
|
@ -499,15 +549,32 @@
|
|||
|
||||
(defun make-std-writer-method-function (class-name slot-name)
|
||||
(let* ((pv-table-symbol (gensym))
|
||||
(type (or (not (eq *boot-state* 'complete))
|
||||
(let ((slotd (find-slot-definition (find-class class-name) slot-name)))
|
||||
(or (not slotd) (slot-definition-type slotd)))))
|
||||
;; FIXME: how expensive is this?
|
||||
(typecheckfun (lambda (nv) (unless (typep nv type)
|
||||
(error 'type-error
|
||||
:datum nv :expected-type type))))
|
||||
(initargs (copy-tree
|
||||
(make-method-function
|
||||
(lambda (nv instance)
|
||||
(pv-binding1 (.pv. .calls.
|
||||
(symbol-value pv-table-symbol)
|
||||
(instance) (instance-slots))
|
||||
(instance-write-internal
|
||||
.pv. instance-slots 1 nv
|
||||
(setf (slot-value instance slot-name) nv))))))))
|
||||
(if (eq type t)
|
||||
(make-method-function
|
||||
(lambda (nv instance)
|
||||
(pv-binding1 (.pv. .calls.
|
||||
(symbol-value pv-table-symbol)
|
||||
(instance) (instance-slots))
|
||||
(instance-write-internal
|
||||
.pv. instance-slots 1 nv
|
||||
(setf (slot-value instance slot-name) nv)))))
|
||||
(make-method-function
|
||||
(lambda (nv instance)
|
||||
(funcall typecheckfun nv)
|
||||
(pv-binding1 (.pv. .calls.
|
||||
(symbol-value pv-table-symbol)
|
||||
(instance) (instance-slots))
|
||||
(instance-write-internal
|
||||
.pv. instance-slots 1 nv
|
||||
(setf (slot-value instance slot-name) nv)))))))))
|
||||
(setf (getf (getf initargs :plist) :slot-name-lists)
|
||||
(list nil (list nil slot-name)))
|
||||
(setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
|
||||
|
|
|
|||
|
|
@ -179,22 +179,30 @@
|
|||
(object std-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 (slot-definition-type slotd)))
|
||||
(flet ((check (new-value type)
|
||||
(cond
|
||||
((eq type t) new-value)
|
||||
(t (if (typep new-value type)
|
||||
new-value
|
||||
(error 'type-error
|
||||
:datum new-value :expected-type type))))))
|
||||
(typecase location
|
||||
(fixnum
|
||||
(cond ((std-instance-p object)
|
||||
(setf (clos-slots-ref (std-instance-slots object) location)
|
||||
(check new-value type)))
|
||||
((fsc-instance-p object)
|
||||
(setf (clos-slots-ref (fsc-instance-slots object) location)
|
||||
(check new-value type)))
|
||||
(t (bug "unrecognized instance type in ~S"
|
||||
'(setf slot-value-using-class)))))
|
||||
(cons
|
||||
(setf (cdr location) (check new-value type)))
|
||||
(t
|
||||
(instance-structure-protocol-error
|
||||
slotd '(setf slot-value-using-class)))))))
|
||||
|
||||
(defmethod slot-boundp-using-class
|
||||
((class std-class)
|
||||
|
|
|
|||
|
|
@ -1184,9 +1184,10 @@
|
|||
(let ((method (get-method generic-function () (list class) nil)))
|
||||
(when method (remove-method generic-function method))))
|
||||
|
||||
;;; 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
|
||||
|
|
|
|||
|
|
@ -655,10 +655,10 @@
|
|||
(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))
|
||||
|
|
@ -676,11 +676,11 @@
|
|||
;; 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+)
|
||||
|
|
@ -703,21 +703,26 @@
|
|||
: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 (type t))
|
||||
(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))
|
||||
`((cons (setf (cdr ,index) ,new-value))))
|
||||
(locally
|
||||
(declare (optimize (safety 3)))
|
||||
(the ,type ,new-value)))))))
|
||||
,@(when (or (null kind) (eq kind :class))
|
||||
`((cons (setf (cdr ,index)
|
||||
(locally
|
||||
(declare (optimize (safety 3)))
|
||||
(the ,type ,new-value))))))
|
||||
(t ,default)))))))
|
||||
|
||||
(defmacro instance-write (pv-offset
|
||||
|
|
@ -732,7 +737,16 @@
|
|||
,pv-offset ,new-value
|
||||
(accessor-set-slot-value ,parameter ,slot-name ,new-value)
|
||||
,(if (generate-fast-class-slot-access-p class slot-name)
|
||||
:class :instance))))
|
||||
:class :instance)
|
||||
,(if (and (eq *boot-state* 'complete)
|
||||
(constantp class)
|
||||
(constantp slot-name)
|
||||
(standard-class-p (eval class))
|
||||
(not (eq (eval class) *the-class-t*)))
|
||||
(let ((slotd (find-slot-definition (eval class) (eval slot-name))))
|
||||
(or (not slotd)
|
||||
(slot-definition-type slotd)))
|
||||
t))))
|
||||
|
||||
(defmacro instance-writer (pv-offset
|
||||
parameter
|
||||
|
|
@ -751,20 +765,20 @@
|
|||
: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)))))))
|
||||
|
||||
|
|
|
|||
144
tests/clos-typechecking.impure.lisp
Normal file
144
tests/clos-typechecking.impure.lisp
Normal file
|
|
@ -0,0 +1,144 @@
|
|||
(load "assertoid.lisp")
|
||||
|
||||
(defpackage "FOO"
|
||||
(:use "CL" "ASSERTOID"))
|
||||
(in-package "FOO")
|
||||
|
||||
(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
|
||||
(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
|
||||
(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)))
|
||||
#+nil ; funcallable standard instance slot-value access go through
|
||||
; ACCESSOR-SLOT-VALUE because their classes are not
|
||||
; STANDARD-CLASS-P.
|
||||
(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
|
||||
(funcall (compile nil '(lambda ()
|
||||
(setf (slot-value (make-instance 'foo) 'slot) 1))))
|
||||
#+nil ; this one still fails goddamit.
|
||||
(assert (raises-error?
|
||||
(funcall
|
||||
(compile nil '(lambda ()
|
||||
(setf (slot-value (make-instance 'foo) 'slot) t))))
|
||||
type-error))
|
||||
(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))
|
||||
;; compiler/gf
|
||||
(funcall (compile nil
|
||||
'(lambda ()
|
||||
(setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1))))
|
||||
#+nil ; this one too
|
||||
(assert (raises-error?
|
||||
(funcall
|
||||
(compile nil
|
||||
'(lambda ()
|
||||
(setf (slot-value (make-instance 'foo/gf) 'slot/gf) t))))
|
||||
type-error))
|
||||
(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)))))
|
||||
#+nil ; see above
|
||||
(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))
|
||||
|
||||
;;;; success
|
||||
(sb-ext:quit :unix-status 104)
|
||||
|
|
@ -23,7 +23,7 @@
|
|||
;;; 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")))
|
||||
|
||||
|
|
|
|||
|
|
@ -17,4 +17,4 @@
|
|||
;;; 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.8.18.11"
|
||||
"0.8.18.11.clos-typechecking.1"
|
||||
|
|
|
|||
Loading…
Reference in a new issue