X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=8bd3d9e0533f7b706a01edcce37c49ebac77a4dc;hb=d984db0864aa7ba5155ec684462840ec1a49ca5b;hp=0f6da5eb74a6a7952f8533baafd4be3adf6cec0a;hpb=de1859fb0815446420c6e0d58adb266012134acc;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 0f6da5e..8bd3d9e 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1318,4 +1318,84 @@
                               (declare (inline test-cmacro-4))
                               (test-cmacro-4)))))
 
+;;; SETF function compiler macros
+(define-compiler-macro (setf test-cmacro-4) (&whole form value) ''ok)
+
+(assert (eq 'ok (funcall (lambda () (setf (test-cmacro-4) 'zot)))))
+(assert (eq 'ok (funcall (lambda () (funcall #'(setf test-cmacro-4) 'zot)))))
+
+;;; Step instrumentation breaking type-inference
+(handler-bind ((warning #'error))
+  (assert (= 42 (funcall (compile nil '(lambda (v x)
+                                        (declare (optimize sb-c:insert-step-conditions))
+                                        (if (typep (the function x) 'fixnum)
+                                            (svref v (the function x))
+                                            (funcall x))))
+                         nil (constantly 42)))))
+
+;;; bug 368: array type intersections in the compiler
+(defstruct e368)
+(defstruct i368)
+(defstruct g368
+  (i368s (make-array 0 :fill-pointer t) :type (or (vector i368) null)))
+(defstruct s368
+  (g368 (error "missing :G368") :type g368 :read-only t))
+(declaim (ftype (function (fixnum (vector i368) e368) t) r368))
+(declaim (ftype (function (fixnum (vector e368)) t) h368))
+(defparameter *h368-was-called-p* nil)
+(defun nsu (vertices e368)
+  (let ((i368s (g368-i368s (make-g368))))
+    (let ((fuis (r368 0 i368s e368)))
+      (format t "~&FUIS=~S~%" fuis)
+      (or fuis (h368 0 i368s)))))
+(defun r368 (w x y)
+  (declare (ignore w x y))
+  nil)
+(defun h368 (w x)
+  (declare (ignore w x))
+  (setf *h368-was-called-p* t)
+  (make-s368 :g368 (make-g368)))
+(let ((nsu (nsu #() (make-e368))))
+  (format t "~&NSU returned ~S~%" nsu)
+  (format t "~&*H368-WAS-CALLED-P*=~S~%" *h368-was-called-p*)
+  (assert (s368-p nsu))
+  (assert *h368-was-called-p*))
+
+;;; bug 367: array type intersections in the compiler
+(defstruct e367)
+(defstruct i367)
+(defstruct g367
+  (i367s (make-array 0 :fill-pointer t) :type (or (vector i367) null)))
+(defstruct s367
+  (g367 (error "missing :G367") :type g367 :read-only t))
+(declaim (ftype (function ((vector i367) e367) (or s367 null)) r367))
+(declaim (ftype (function ((vector e367)) (values)) h367))
+(defun frob-367 (v w)
+  (let ((x (g367-i367s (make-g367))))
+    (let* ((y (or (r367 x w)
+                  (h367 x)))
+           (z (s367-g367 y)))
+      (format t "~&Y=~S Z=~S~%" y z)
+      (g367-i367s z))))
+(defun r367 (x y) (declare (ignore x y)) nil)
+(defun h367 (x) (declare (ignore x)) (values))
+(multiple-value-bind (res err) (ignore-errors (frob-367 0 (make-e367)))
+  (assert (not res))
+  (assert (typep err 'type-error)))
+
+(handler-case
+    (delete-file (compile-file "circ-tree-test.lisp"))
+  (storage-condition (e)
+    (error e)))
+
+;;; warnings due to step-insturmentation
+(defclass debug-test-class () ())
+(handler-case
+    (compile nil '(lambda ()
+                   (declare (optimize (debug 3)))
+                   (defmethod print-object ((x debug-test-class) s)
+                     (call-next-method))))
+  ((and (not style-warning) warning) (e)
+    (error e)))
+
 ;;; success