X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos-typechecking.impure.lisp;h=a8bc8d4877ddf553a7587f0063db34f5a7430b8c;hb=f44f6d1adbaaa7057f1948369299c0b2a08bcd6e;hp=87b760221d64b4bee62afb2bcae51f122845f8e4;hpb=b7de68f093163fc29296afd9b3089ae11a5d5132;p=sbcl.git

diff --git a/tests/clos-typechecking.impure.lisp b/tests/clos-typechecking.impure.lisp
index 87b7602..a8bc8d4 100644
--- a/tests/clos-typechecking.impure.lisp
+++ b/tests/clos-typechecking.impure.lisp
@@ -242,3 +242,49 @@
     (make-instance class :slot :not-a-fixnum))
   (assert (raises-error? (make-my-instance 'my-alt-metaclass-instance-class)
                          type-error)))
+
+(with-test (:name :typecheck-class-allocation)
+    ;; :CLASS slot :INITFORMs are executed at class definition time
+  (assert (raises-error?
+           (eval `(locally (declare (optimize safety))
+                    (defclass class-allocation-test-bad ()
+                      ((slot :initform "slot"
+                             :initarg :slot
+                             :type fixnum
+                             :allocation :class)))))
+           type-error))
+  (let ((name (gensym "CLASS-ALLOCATION-TEST-GOOD")))
+    (eval `(locally (declare (optimize safety))
+             (defclass ,name ()
+               ((slot :initarg :slot
+                      :type (integer 100 200)
+                      :allocation :class)))))
+    (eval
+     `(macrolet ((check (form)
+                   `(assert (multiple-value-bind (ok err)
+                                (ignore-errors ,form)
+                              (and (not ok)
+                                   (typep err 'type-error)
+                                   (equal '(integer 100 200)
+                                          (type-error-expected-type err)))))))
+        (macrolet ((test (form)
+                     `(progn
+                        (check (eval '(locally (declare (optimize safety))
+                                       ,form)))
+                        (check (funcall (compile nil '(lambda ()
+                                                       (declare (optimize safety))
+                                                       ,form))))))
+                   (test-slot (value form)
+                     `(progn
+                        (assert (eql ,value (slot-value (eval ',form) 'slot)))
+                        (assert (eql ,value (slot-value (funcall (compile nil '(lambda () ,form)))
+                                                        'slot))))))
+          (test (make-instance ',name :slot :bad))
+          (assert (not (slot-boundp (make-instance ',name) 'slot)))
+          (let ((* (make-instance ',name :slot 101)))
+            (test-slot 101 *)
+            (test (setf (slot-value * 'slot) (list 1 2 3)))
+            (setf (slot-value * 'slot) 110)
+            (test-slot 110 *))
+          (test-slot 110 (make-instance ',name))
+          (test-slot 111 (make-instance ',name :slot 111)))))))