;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
+(when (eq sb-ext:*evaluator-mode* :interpret)
+ (sb-ext:quit :unix-status 104))
+
(load "test-util.lisp")
(load "assertoid.lisp")
(use-package "TEST-UTIL")
(storage-condition (e)
(error e)))
+;;; warnings due to step-insturmentation
+(defclass debug-test-class () ())
+(handler-case
+ (compile nil '(lambda ()
+ (declare (optimize (debug 3)))
+ (defmethod print-object ((x debug-test-class) s)
+ (call-next-method))))
+ ((and (not style-warning) warning) (e)
+ (error e)))
+
+;;; program-error from bad lambda-list keyword
+(assert (eq :ok
+ (handler-case
+ (funcall (lambda (&whole x)
+ (list &whole x)))
+ (program-error ()
+ :ok))))
+(assert (eq :ok
+ (handler-case
+ (let ((*evaluator-mode* :interpret))
+ (funcall (eval '(lambda (&whole x)
+ (list &whole x)))))
+ (program-error ()
+ :ok))))
+
+;;; ignore &environment
+(handler-bind ((style-warning #'error))
+ (compile nil '(lambda ()
+ (defmacro macro-ignore-env (&environment env)
+ (declare (ignore env))
+ :foo)))
+ (compile nil '(lambda ()
+ (defmacro macro-no-env ()
+ :foo))))
+
+(dolist (*evaluator-mode* '(:interpret :compile))
+ (disassemble (eval '(defun disassemble-source-form-bug (x y z)
+ (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
projects / sbcl.git / blobdiff