X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=8e78f57c5eada528467356b4a8655d39ba4b04d3;hb=1ab8bfcc2145a100795401de5941c373bb6318eb;hp=2d952613e44096fe1539f8ccab7dab7971c74e95;hpb=6483924c30758e2393428c7fa3f63c9faf924600;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 2d95261..8e78f57 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1431,4 +1431,137 @@
                        (declare (optimize debug))
                        (list x y z)))))
 
+;;; long-standing bug in defaulting unknown values on the x86-64,
+;;; since changing the calling convention (test case by Christopher
+;;; Laux sbcl-help 30-06-2007)
+
+(defun default-values-bug-demo-sub ()
+  (format t "test")
+  nil)
+(compile 'default-values-bug-demo-sub)
+
+(defun default-values-bug-demo-main ()
+  (multiple-value-bind (a b c d e f g h)
+      (default-values-bug-demo-sub)
+    (if a (+ a b c d e f g h) t)))
+(compile 'default-values-bug-demo-main)
+
+(assert (default-values-bug-demo-main))
+
+;;; copy propagation bug reported by Paul Khuong
+
+(defun local-copy-prop-bug-with-move-arg (x)
+  (labels ((inner ()
+             (values 1 0)))
+    (if x
+        (inner)
+        (multiple-value-bind (a b)
+            (inner)
+          (values b a)))))
+
+(assert (equal '(0 1) (multiple-value-list (local-copy-prop-bug-with-move-arg nil))))
+(assert (equal '(1 0) (multiple-value-list (local-copy-prop-bug-with-move-arg t))))
+
+;;;; with-pinned-objects & unwind-protect, using all non-tail conventions
+
+(defun wpo-quux () (list 1 2 3))
+(defvar *wpo-quux* #'wpo-quux)
+
+(defun wpo-call ()
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (values (funcall *wpo-quux*)))))
+(assert (equal '(1 2 3) (wpo-call)))
+
+(defun wpo-multiple-call ()
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (funcall *wpo-quux*))))
+(assert (equal '(1 2 3) (wpo-multiple-call)))
+
+(defun wpo-call-named ()
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (values (wpo-quux)))))
+(assert (equal '(1 2 3) (wpo-call-named)))
+
+(defun wpo-multiple-call-named ()
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (wpo-quux))))
+(assert (equal '(1 2 3) (wpo-multiple-call-named)))
+
+(defun wpo-call-variable (&rest args)
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (values (apply *wpo-quux* args)))))
+(assert (equal '(1 2 3) (wpo-call-variable)))
+
+(defun wpo-multiple-call-variable (&rest args)
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (apply #'wpo-quux args))))
+(assert (equal '(1 2 3) (wpo-multiple-call-named)))
+
+(defun wpo-multiple-call-local ()
+  (flet ((quux ()
+           (wpo-quux)))
+    (unwind-protect
+         (sb-sys:with-pinned-objects (*wpo-quux*)
+           (quux)))))
+(assert (equal '(1 2 3) (wpo-multiple-call-local)))
+
+;;; bug 417: toplevel NIL confusing source path logic
+(handler-case
+    (delete-file (compile-file "bug-417.lisp"))
+  (sb-ext:code-deletion-note (e)
+    (error e)))
+
+;;; unknown values return convention getting disproportionate
+;;; amounts of values.
+(declaim (notinline one-value two-values))
+(defun one-value (x)
+  (not x))
+(defun two-values (x y)
+  (values y x))
+(defun wants-many-values (x y)
+  (multiple-value-bind (a b c d e f)
+      (one-value y)
+    (assert (and (eql (not y) a)
+                 (not (or b c d e f)))))
+  (multiple-value-bind (a b c d e f)
+      (two-values y x)
+    (assert (and (eql a x) (eql b y)
+                 (not (or c d e f)))))
+  (multiple-value-bind (a b c d e f g h i)
+      (one-value y)
+    (assert (and (eql (not y) a)
+                 (not (or b c d e f g h i)))))
+  (multiple-value-bind (a b c d e f g h i)
+      (two-values y x)
+    (assert (and (eql a x) (eql b y)
+                 (not (or c d e f g h i)))))
+  (multiple-value-bind (a b c d e f g h i j k l m n o p q r s)
+      (one-value y)
+    (assert (and (eql (not y) a)
+                 (not (or b c d e f g h i j k l m n o p q r s)))))
+  (multiple-value-bind (a b c d e f g h i j k l m n o p q r s)
+      (two-values y x)
+    (assert (and (eql a x) (eql b y)
+                 (not (or c d e f g h i j k l m n o p q r s))))))
+(wants-many-values 1 42)
+
+;;; constant coalescing (named and unnamed)
+(defconstant +born-to-coalesce+ '.born-to-coalesce.)
+(let* ((f (compile nil '(lambda ()
+                         (let ((x (cons +born-to-coalesce+ nil))
+                               (y (cons '.born-to-coalesce. nil)))
+                           (list x y)))))
+       (b-t-c 0)
+       (code (sb-kernel:fun-code-header f)))
+  (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
+        do (when (eq '.born-to-coalesce. (sb-kernel:code-header-ref code i))
+             (incf b-t-c)))
+  (assert (= 1 b-t-c)))
+
 ;;; success