1.0.27.30: minor octets.lisp cleanup

[sbcl.git] / tests / compiler.impure.lisp

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 1a0f385..87c2265 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1002,6 +1002,73 @@
     (assert (= 0 (count-full-calls "FOO-MAYBE-INLINE" fun)))
     (assert (= 1 (count-full-calls "QUUX-MARKER" fun)))))
 
+(defun file-compile (toplevel-forms &key load)
+  (let* ((lisp "compile-impure-tmp.lisp")
+         (fasl (compile-file-pathname lisp)))
+    (unwind-protect
+         (progn
+           (with-open-file (f lisp :direction :output)
+             (dolist (form toplevel-forms)
+               (prin1 form f)))
+           (multiple-value-bind (fasl warn fail) (compile-file lisp)
+             (when load
+               (load fasl))
+             (values warn fail)))
+      (ignore-errors (delete-file lisp))
+      (ignore-errors (delete-file fasl)))))
+
+(with-test (:name :bug-405)
+  ;; These used to break with a TYPE-ERROR
+  ;;     The value NIL is not of type SB-C::PHYSENV.
+  ;; in MERGE-LETS.
+  (file-compile
+   '((LET (outer-let-var)
+       (lambda ()
+         (print outer-let-var)
+         (MULTIPLE-VALUE-CALL 'some-function
+           (MULTIPLE-VALUE-CALL (LAMBDA (a) 'foo)
+             1))))))
+  (file-compile
+   '((declaim (optimize (debug 3)))
+     (defstruct bug-405-foo bar)
+     (let ()
+       (flet ((i (x) (frob x (bug-405-foo-bar foo))))
+         (i :five))))))
+
+;;; bug 235a
+(declaim (ftype (function (cons) number) bug-235a-aux))
+(declaim (inline bug-235a-aux))
+(defun bug-235a-aux (c)
+  (the number (car c)))
+(with-test (:name :bug-235a)
+  (let ((fun (compile nil
+                      `(lambda (x y)
+                         (values (locally (declare (optimize (safety 0)))
+                                   (bug-235a-aux x))
+                                 (locally (declare (optimize (safety 3)))
+                                   (bug-235a-aux y)))))))
+    (assert
+     (eq :error
+         (handler-case
+             (funcall fun '(:one) '(:two))
+           (type-error (e)
+             (assert (eq :two (type-error-datum e)))
+             (assert (eq 'number (type-error-expected-type e)))
+             :error))))))
+
+(with-test (:name :compiled-debug-funs-leak)
+  (sb-ext:gc :full t)
+  (let ((usage-before (sb-kernel::dynamic-usage)))
+    (dotimes (x 10000)
+      (let ((f (compile nil '(lambda ()
+                               (error "X")))))
+        (handler-case
+            (funcall f)
+          (error () nil))))
+    (sb-ext:gc :full t)
+    (let ((usage-after (sb-kernel::dynamic-usage)))
+      (when (< (+ usage-before 2000000) usage-after)
+        (error "Leak")))))
 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself