common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

0.9.6.56.clos-typechecking2.2:

Browse source 
Propagate type information for funcallable-standard-class
	instances in instance-writer too.
	... fixes the fail/sv/gf case (compiled slot-value inside
		a generic function)
	... probably doesn't fix subclasses with hairy intersection
		types...
	... doesn't fix the compiled use of slot-value outside
		methods, which uses the (SLOT-ACCESSOR :GLOBAL ...
		WRITER) generic function.
This commit is contained in:
Christophe Rhodes 2005-11-24 17:09:40 +00:00
parent bd706ec62f
commit 7c850cd952
3 changed files with 55 additions and 58 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
src/pcl/vector.lisp
View file

@ -741,7 +741,8 @@
,(if (and (eq *boot-state* 'complete)
(constantp class)
(constantp slot-name)
(standard-class-p (eval class))
(or (standard-class-p (eval class))
(funcallable-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)

108
tests/clos-typechecking.impure.lisp
View file

@ -31,114 +31,110 @@
;; evaluator
(eval '(setf (slot-value (make-instance 'foo) 'slot) 1))
(assert (raises-error? (eval '(setf (slot-value (make-instance 'foo) 'slot) t))
type-error))
type-error))
(eval '(setf (slot (make-instance 'foo)) 1))
(assert (raises-error? (eval '(setf (slot (make-instance 'foo)) t))
type-error))
type-error))
(eval '(succeed/sv (make-instance 'foo)))
(assert (raises-error? (eval '(fail/sv (make-instance 'foo)))
type-error))
type-error))
(eval '(succeed/acc (make-instance 'foo)))
(assert (raises-error? (eval '(fail/acc (make-instance 'foo)))
type-error))
type-error))
(eval '(make-instance 'foo :slot 1))
(assert (raises-error? (eval '(make-instance 'foo :slot t))
type-error))
type-error))
(eval '(make-instance 'foo :slot *one*))
(assert (raises-error? (eval '(make-instance 'foo :slot *t*))
type-error))
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-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))
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))
type-error))
(eval '(succeed/acc/gf (make-instance 'foo/gf)))
(assert (raises-error? (eval '(fail/acc/gf (make-instance 'foo/gf)))
type-error))
type-error))
(eval '(make-instance 'foo/gf :slot/gf 1))
(assert (raises-error? (eval '(make-instance 'foo/gf :slot/gf t))
type-error))
type-error))
(eval '(make-instance 'foo/gf :slot/gf *one*))
(assert (raises-error? (eval '(make-instance 'foo/gf :slot/gf *t*))
type-error))
type-error))
;; compiler
(funcall (compile nil '(lambda ()
(setf (slot-value (make-instance 'foo) 'slot) 1))))
(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-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 () (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 () (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 () (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 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))
(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))))
'(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-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 () (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 ()
(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 ()
(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 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))
(funcall (compile nil '(lambda ()
(make-instance 'foo/gf :slot/gf *t*))))
type-error))
;;;; success
(sb-ext:quit :unix-status 104)

2
version.lisp-expr
View file

@ -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.9.6.56.clos-typechecking2.1"
"0.9.6.56.clos-typechecking2.2"