1.0.23.59: bug 3b has been fixed a while now

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

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index a508073..3a2ce24 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -935,6 +935,106 @@
 (declaim (cons *special-cons*))
 (assert (raises-error? (set '*special-cons* "nope") type-error))
 (assert (raises-error? (progv '(*special-cons*) '("no hope") (car *special-cons*)) type-error))
+
+;;; No bogus warnings for calls to functions with complex lambda-lists.
+(defun complex-function-signature (&optional x &rest y &key z1 z2)
+  (cons x y))
+(with-test (:name :complex-call-doesnt-warn)
+  (handler-bind ((warning #'error))
+    (compile nil '(lambda (x) (complex-function-signature x :z1 1 :z2 2)))))
+
+(with-test (:name :non-required-args-update-info)
+  (let ((name (gensym "NON-REQUIRE-ARGS-TEST"))
+        (*evaluator-mode* :compile))
+    (eval `(defun ,name (x) x))
+    (assert (equal '(function (t) (values t &optional))
+                   (sb-kernel:type-specifier (sb-int:info :function :type name))))
+    (eval `(defun ,name (x &optional y) (or x y)))
+    (assert (equal '(function (t &optional t) (values t &optional))
+                   (sb-kernel:type-specifier (sb-int:info :function :type name))))))
+
+;;;; inline & maybe inline nested calls
+
+(defun quux-marker (x) x)
+(declaim (inline foo-inline))
+(defun foo-inline (x) (quux-marker x))
+(declaim (maybe-inline foo-maybe-inline))
+(defun foo-maybe-inline (x) (quux-marker x))
+;; Pretty horrible, but does the job
+(defun count-full-calls (name function)
+  (let ((code (with-output-to-string (s)
+                (disassemble function :stream s)))
+        (n 0))
+    (with-input-from-string (s code)
+      (loop for line = (read-line s nil nil)
+            while line
+            when (search name line)
+            do (incf n)))
+    n))
+
+(with-test (:name :nested-inline-calls)
+  (let ((fun (compile nil `(lambda (x)
+                             (foo-inline (foo-inline (foo-inline x)))))))
+    (assert (= 0 (count-full-calls "FOO-INLINE" fun)))
+    (assert (= 3 (count-full-calls "QUUX-MARKER" fun)))))
+
+(with-test (:name :nested-maybe-inline-calls)
+  (let ((fun (compile nil `(lambda (x)
+                             (declare (optimize (space 0)))
+                             (foo-maybe-inline (foo-maybe-inline (foo-maybe-inline x)))))))
+    (assert (= 0 (count-full-calls "FOO-MAYBE-INLINE" fun)))
+    (assert (= 1 (count-full-calls "QUUX-MARKER" fun)))))
+
+(with-test (:name :inline-calls)
+  (let ((fun (compile nil `(lambda (x)
+                             (list (foo-inline x)
+                                   (foo-inline x)
+                                   (foo-inline x))))))
+    (assert (= 0 (count-full-calls "FOO-INLINE" fun)))
+    (assert (= 3 (count-full-calls "QUUX-MARKER" fun)))))
+
+(with-test (:name :maybe-inline-calls)
+  (let ((fun (compile nil `(lambda (x)
+                             (declare (optimize (space 0)))
+                             (list (foo-maybe-inline x)
+                                   (foo-maybe-inline x)
+                                   (foo-maybe-inline x))))))
+    (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))))))
+
 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
@@ -1279,20 +1379,21 @@
 
 ;;; FUNCALL forms in compiler macros, lambda-list parsing
 (define-compiler-macro test-cmacro-1
-    (&whole whole a &optional b &rest c &key d)
-  (list whole a b c d))
+    (&whole whole a (a2) &optional b &rest c &key d)
+  (list whole a a2 b c d))
 
-(macrolet ((test (form a b c d)
+(macrolet ((test (form a a2 b c d)
              `(let ((form ',form))
-                (destructuring-bind (whole a b c d)
+                (destructuring-bind (whole a a2 b c d)
                     (funcall (compiler-macro-function 'test-cmacro-1) form nil)
                   (assert (equal whole form))
                   (assert (eql a ,a))
+                  (assert (eql a2 ,a2))
                   (assert (eql b ,b))
                   (assert (equal c ,c))
                   (assert (eql d ,d))))) )
-  (test (funcall 'test-cmacro-1 1 2 :d 3) 1 2 '(:d 3) 3)
-  (test (test-cmacro-1 11 12 :d 13) 11 12 '(:d 13) 13))
+  (test (funcall 'test-cmacro-1 1 (x) 2 :d 3) 1 'x 2 '(:d 3) 3)
+  (test (test-cmacro-1 11 (y) 12 :d 13) 11 'y 12 '(:d 13) 13))
 
 ;;; FUNCALL forms in compiler macros, expansions
 (define-compiler-macro test-cmacro-2 () ''ok)