0.7.10.30:

[sbcl.git] / tests / compiler-1.impure-cload.lisp

diff --git a/tests/compiler-1.impure-cload.lisp b/tests/compiler-1.impure-cload.lisp
index a873e69..4d5b104 100644 (file)
--- a/tests/compiler-1.impure-cload.lisp
+++ b/tests/compiler-1.impure-cload.lisp
@@ -14,6 +14,10 @@
 
 (cl:in-package :cl-user)
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (load "assertoid")
+  (use-package "ASSERTOID"))
+
 (declaim (optimize (debug 3) (speed 2) (space 1)))
 
 ;;; Until version 0.6.9 or so, SBCL's version of Python couldn't do
@@ -115,5 +119,77 @@
                  nil)
                '(13 nil)))
 
-(sb-ext:quit :unix-status 104) ; success
+;;; bug 221: sbcl 0.7.9.13 failed to compile the following function
+(declaim (ftype (function (fixnum) (values package boolean)) bug221-f1))
+(declaim (ftype (function (t) (values package boolean)) bug221-f2))
+(defun bug221 (b x)
+  (funcall (if b #'bug221-f1 #'bug221-f2) x))
+
+;;; bug 166: compiler failure
+(defstruct bug166s)
+(defmethod permanentize ((uustk bug166s))
+  (flet ((frob (hash-table test-for-deletion)
+           )
+         (obj-entry.stale? (oe)
+           (destructuring-bind (key . datum) oe
+             (declare (type simple-vector key))
+             (deny0 (void? datum))
+             (some #'stale? key))))
+    (declare (inline frob obj-entry.stale?))
+    (frob (uustk.args-hash->obj-alist uustk)
+          #'obj-entry.stale?)
+    (frob (uustk.hash->memoized-objs-list uustk)
+          #'objs.stale?))
+  (call-next-method))
+
+;;; bugs 115, 226: compiler failure in lifetime analysis
+(defun bug115-1 ()
+  (declare (optimize (speed 2) (debug 3)))
+  (flet ((m1 ()
+           (unwind-protect nil)))
+    (if (catch nil)
+        (m1)
+        (m1))))
+
+(defun bug115-2 ()
+  (declare (optimize (speed 2) (debug 3)))
+  (flet ((m1 ()
+           (bar (if (foo) 1 2))
+           (let ((x (foo)))
+             (bar x (list x)))))
+    (if (catch nil)
+        (m1)
+        (m1))))
 
+(defun bug226 ()
+  (declare (optimize (speed 0) (safety 3) (debug 3)))
+  (flet ((safe-format (stream string &rest r)
+           (unless (ignore-errors (progn
+                                    (apply #'format stream string r)
+                                    t))
+             (format stream "~&foo ~S" string))))
+    (cond
+      ((eq my-result :ERROR)
+       (cond
+         ((ignore-errors (typep condition result))
+          (safe-format t "~&bar ~S" result))
+         (t
+          (safe-format t "~&baz ~S (~A) ~S" condition condition result)))))))
+
+;;; bug 231: SETQ did not check the type of the variable being set
+(defun bug231-1 (x)
+  (declare (optimize safety) (type (integer 0 8) x))
+  (incf x))
+(assert (raises-error? (bug231-1 8) type-error))
+
+(defun bug231-2 (x)
+  (declare (optimize safety) (type (integer 0 8) x))
+  (list (lambda (y) (setq x y))
+        (lambda () x)))
+(destructuring-bind (set get) (bug231-2 0)
+  (funcall set 8)
+  (assert (eql (funcall get) 8))
+  (assert (raises-error? (funcall set 9) type-error))
+  (assert (eql (funcall get) 8)))
+
+(sb-ext:quit :unix-status 104) ; success