X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=46a36a8ba82e094a6645a9cd53e972e986680fab;hb=c553e4be6da2d18f0827f190589c88e837b8b8a6;hp=d548cffceff945be14b47ebc0dd474afce77004d;hpb=b3fc19fd2ee925f1a16e301012094b58c2cfd68a;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index d548cff..46a36a8 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1639,5 +1639,142 @@
   (handler-bind ((compiler-note #'error))
     (stream-fd sb-sys:*stdin* :output)
     (stream-fd sb-sys:*stdin* :output)))
+
+(with-test (:name :bug-380)
+  (defclass bug-380 ()
+    ((slot :accessor bug380-slot)))
+  (fmakunbound 'foo-slot)
+  (defgeneric foo-slot (x y z))
+  (defclass foo ()
+    ((slot :accessor foo-slot-value))))
+
+;;; SET and (SETF SYMBOL-VALUE) used to confuse permuation vector
+;;; optimizations
+(defclass fih ()
+  ((x :initform :fih)))
+(defclass fah ()
+  ((x :initform :fah)))
+(declaim (special *fih*))
+(defmethod fihfah ((*fih* fih))
+  (set '*fih* (make-instance 'fah))
+  (list (slot-value *fih* 'x)
+        (eval '(slot-value *fih* 'x))))
+(defmethod fihfah ((fah fah))
+  (declare (special fah))
+  (set 'fah (make-instance 'fih))
+  (list (slot-value fah 'x)
+        (eval '(slot-value fah 'x))))
+(with-test (:name :set-of-a-method-specializer)
+  (assert (equal '(:fah :fah) (fihfah (make-instance 'fih))))
+  (assert (equal '(:fih :fih) (fihfah (make-instance 'fah)))))
+
+(defmethod no-implicit-declarations-for-local-specials ((faax double-float))
+  (declare (special faax))
+  (set 'faax (when (< faax 0) (- faax)))
+  faax)
+(with-test (:name :no-implicit-declarations-for-local-specials)
+  (assert (not (no-implicit-declarations-for-local-specials 1.0d0))))
+
+(defstruct bug-357-a
+  slot1
+  (slot2 t)
+  (slot3 (coerce pi 'single-float) :type single-float))
+(defclass bug-357-b (bug-357-a)
+  ((slot2 :initform 't2)
+   (slot4 :initform -44)
+   (slot5)
+   (slot6 :initform t)
+   (slot7 :initform (floor (* pi pi)))
+   (slot8 :initform 88))
+  (:metaclass structure-class))
+(defstruct (bug-357-c (:include bug-357-b (slot8 -88) (slot5 :ok)))
+  slot9
+  (slot10 t)
+  (slot11 (floor (exp 3))))
+(with-test (:name :bug-357)
+  (flet ((slots (x)
+           (list (bug-357-c-slot1 x)
+                 (bug-357-c-slot2 x)
+                 (bug-357-c-slot3 x)
+                 (bug-357-c-slot4 x)
+                 (bug-357-c-slot5 x)
+                 (bug-357-c-slot6 x)
+                 (bug-357-c-slot7 x)
+                 (bug-357-c-slot8 x)
+                 (bug-357-c-slot9 x)
+                 (bug-357-c-slot10 x)
+                 (bug-357-c-slot11 x))))
+    (let ((base (slots (make-bug-357-c))))
+      (assert (equal base (slots (make-instance 'bug-357-c))))
+      (assert (equal base '(nil t2 3.1415927 -44 :ok t 9 -88 nil t 20))))))
+
+(defclass class-slot-shared-initialize ()
+  ((a :allocation :class :initform :ok)))
+(with-test (:name :class-slot-shared-initialize)
+  (let ((x (make-instance 'class-slot-shared-initialize)))
+    (assert (eq :ok (slot-value x 'a)))
+    (slot-makunbound x 'a)
+    (assert (not (slot-boundp x 'a)))
+    (shared-initialize x '(a))
+    (assert (slot-boundp x 'a))
+    (assert (eq :ok (slot-value x 'a)))))
+
+(declaim (ftype (function (t t t) (values single-float &optional))
+                i-dont-want-to-be-clobbered-1
+                i-dont-want-to-be-clobbered-2))
+(defgeneric i-dont-want-to-be-clobbered-1 (t t t))
+(defmethod i-dont-want-to-be-clobbered-2 ((x cons) y z)
+  y)
+(defun i-cause-an-gf-info-update ()
+  (i-dont-want-to-be-clobbered-2 t t t))
+(with-test (:name :defgeneric-should-clobber-ftype)
+  ;; (because it doesn't check the argument or result types)
+  (assert (equal '(function (t t t) *)
+                 (sb-kernel:type-specifier
+                  (sb-int:info :function
+                               :type 'i-dont-want-to-be-clobbered-1))))
+  (assert (equal '(function (t t t) *)
+                 (sb-kernel:type-specifier
+                  (sb-int:info :function
+                               :type 'i-dont-want-to-be-clobbered-2))))
+  (assert (eq :defined-method
+              (sb-int:info :function
+                           :where-from 'i-dont-want-to-be-clobbered-1)))
+  (assert (eq :defined-method
+              (sb-int:info :function
+                           :where-from 'i-dont-want-to-be-clobbered-2))))
+
+(with-test (:name :bogus-parameter-specializer-name-error)
+  (assert (eq :ok
+              (handler-case
+                  (eval `(defmethod #:fii ((x "a string")) 'string))
+                (sb-int:reference-condition (c)
+                  (when (member '(:ansi-cl :macro defmethod)
+                                (sb-int:reference-condition-references c)
+                                :test #'equal)
+                    :ok))))))
+
+(defclass remove-default-initargs-test ()
+  ((x :initarg :x :initform 42)))
+(defclass remove-default-initatgs-test ()
+  ((x :initarg :x :initform 42))
+  (:default-initargs :x 0))
+(defclass remove-default-initargs-test ()
+  ((x :initarg :x :initform 42)))
+(with-test (:name :remove-default-initargs)
+  (assert (= 42 (slot-value (make-instance 'remove-default-initargs-test)
+                            'x))))
 
+(with-test (:name :bug-485019)
+  ;; there was a bug in WALK-SETQ, used in method body walking, in the
+  ;; presence of declarations on symbol macros.
+  (defclass bug-485019 ()
+    ((array :initarg :array)))
+  (defmethod bug-485019 ((bug-485019 bug-485019))
+    (with-slots (array) bug-485019
+      (declare (type (or null simple-array) array))
+      (setf array (make-array 4)))
+    bug-485019)
+  (bug-485019 (make-instance 'bug-485019)))
+
 ;;;; success