X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=fa098af264129cab9fbc17b1d4ce356b3c3f3b58;hb=b76dac3d5f89700f3a076403157eae3c52e4c118;hp=f91feb35d8d28e1f289d97ebb2df781d31063c61;hpb=57d7dd0f59b9df89feb1175b0efc449bb0b8d400;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index f91feb3..fa098af 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1462,4 +1462,59 @@
 (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)))
+
 ;;; success