[Sbcl-commits] CVS: sbcl/tests clos-typechecking.impure.lisp,NONE,1.1.2.1 mop.impure-cload.lisp,1.1,1.1.38.1

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12494/tests

Modified Files:
      Tag: clos-typechecking-branch
	mop.impure-cload.lisp 
Added Files:
      Tag: clos-typechecking-branch
	clos-typechecking.impure.lisp 
Log Message:
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.


--- NEW FILE: clos-typechecking.impure.lisp ---
(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)

Index: mop.impure-cload.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/mop.impure-cload.lisp,v
retrieving revision 1.1
retrieving revision 1.1.38.1
diff -u -d -r1.1 -r1.1.38.1
--- mop.impure-cload.lisp	28 Apr 2003 12:23:59 -0000	1.1
+++ mop.impure-cload.lisp	3 Jan 2005 15:49:34 -0000	1.1.38.1
@@ -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")))