;; compile-times this is bound to be a bit brittle, but at least
;; here we try to establish a decent baseline.
(flet ((time-it (lambda want)
+ (gc :full t) ; let's keep GCs coming from other code out...
(let* ((start (get-internal-run-time))
(fun (compile nil lambda))
(end (get-internal-run-time))
:initial-element 0)
1)
#(0 1 0 0)))))
+
+(with-test (:name :catch-interferes-with-debug-names)
+ (let ((fun (funcall
+ (compile nil
+ `(lambda ()
+ (catch 'out
+ (flet ((foo ()
+ (throw 'out (lambda () t))))
+ (foo))))))))
+ (assert (equal '(lambda () :in foo) (sb-kernel:%fun-name fun)))))
+
+(with-test (:name :interval-div-signed-zero)
+ (let ((fun (compile nil
+ `(Lambda (a)
+ (declare (type (member 0 -272413371076) a))
+ (ffloor (the number a) -63243.127451934015d0)))))
+ (multiple-value-bind (q r) (funcall fun 0)
+ (assert (eql -0d0 q))
+ (assert (eql 0d0 r)))))
+
+(with-test (:name :non-constant-keyword-typecheck)
+ (let ((fun (compile nil
+ `(lambda (p1 p3 p4)
+ (declare (type keyword p3))
+ (tree-equal p1 (cons 1 2) (the (member :test) p3) p4)))))
+ (assert (funcall fun (cons 1.0 2.0) :test '=))))
+
+(with-test (:name :truncate-wild-values)
+ (multiple-value-bind (q r)
+ (handler-bind ((warning #'error))
+ (let ((sb-c::*check-consistency* t))
+ (funcall (compile nil
+ `(lambda (a)
+ (declare (type (member 1d0 2d0) a))
+ (block return-value-tag
+ (funcall
+ (the function
+ (catch 'debug-catch-tag
+ (return-from return-value-tag
+ (progn (truncate a)))))))))
+ 2d0)))
+ (assert (eql 2 q))
+ (assert (eql 0d0 r))))
+
+(with-test (:name :boxed-fp-constant-for-full-call)
+ (let ((fun (compile nil
+ `(lambda (x)
+ (declare (double-float x))
+ (unknown-fun 1.0d0 (+ 1.0d0 x))))))
+ (assert (equal '(1.0d0) (ctu:find-code-constants fun :type 'double-float)))))
+
+(with-test (:name :only-one-boxed-constant-for-multiple-uses)
+ (let* ((big (1+ most-positive-fixnum))
+ (fun (compile nil
+ `(lambda (x)
+ (unknown-fun ,big (+ ,big x))))))
+ (assert (= 1 (length (ctu:find-code-constants fun :type `(eql ,big)))))))
+
+(with-test (:name :fixnum+float-coerces-fixnum
+ :skipped-on :x86)
+ (let ((fun (compile nil
+ `(lambda (x y)
+ (declare (fixnum x)
+ (single-float y))
+ (+ x y)))))
+ (assert (not (ctu:find-named-callees fun)))
+ (assert (not (search "GENERIC"
+ (with-output-to-string (s)
+ (disassemble fun :stream s)))))))
+
+(with-test (:name :bug-803508)
+ (compile nil `(lambda ()
+ (print
+ (lambda (bar)
+ (declare (dynamic-extent bar))
+ (foo bar))))))
+
+(with-test (:name :bug-803508-b)
+ (compile nil `(lambda ()
+ (list
+ (lambda (bar)
+ (declare (dynamic-extent bar))
+ (foo bar))))))
+
+(with-test (:name :bug-803508-c)
+ (compile nil `(lambda ()
+ (list
+ (lambda (bar &optional quux)
+ (declare (dynamic-extent bar quux))
+ (foo bar quux))))))
+
+(with-test (:name :cprop-with-constant-but-assigned-to-closure-variable)
+ (compile nil `(lambda (b c d)
+ (declare (type (integer -20545789 207590862) c))
+ (declare (type (integer -1 -1) d))
+ (let ((i (unwind-protect 32 (shiftf d -1))))
+ (or (if (= d c) 2 (= 3 b)) 4)))))
+
+(with-test (:name :bug-913232)
+ (compile nil `(lambda (x)
+ (declare (optimize speed)
+ (type (or (and (or (integer -100 -50)
+ (integer 100 200)) (satisfies foo))
+ (and (or (integer 0 10) (integer 20 30)) a)) x))
+ x))
+ (compile nil `(lambda (x)
+ (declare (optimize speed)
+ (type (and fixnum a) x))
+ x)))
+
+(with-test (:name :bug-959687)
+ (multiple-value-bind (fun warn fail)
+ (compile nil `(lambda (x)
+ (case x
+ (t
+ :its-a-t)
+ (otherwise
+ :somethign-else))))
+ (assert (and warn fail))
+ (assert (not (ignore-errors (funcall fun t)))))
+ (multiple-value-bind (fun warn fail)
+ (compile nil `(lambda (x)
+ (case x
+ (otherwise
+ :its-an-otherwise)
+ (t
+ :somethign-else))))
+ (assert (and warn fail))
+ (assert (not (ignore-errors (funcall fun t))))))
+
+(with-test (:name :bug-924276)
+ (assert (eq :style-warning
+ (handler-case
+ (compile nil `(lambda (a)
+ (cons a (symbol-macrolet ((b 1))
+ (declare (ignorable a))
+ :c))))
+ (style-warning ()
+ :style-warning)))))
+
+(with-test (:name :bug-974406)
+ (let ((fun32 (compile nil `(lambda (x)
+ (declare (optimize speed (safety 0)))
+ (declare (type (integer 53 86) x))
+ (logand (+ x 1032791128) 11007078467))))
+ (fun64 (compile nil `(lambda (x)
+ (declare (optimize speed (safety 0)))
+ (declare (type (integer 53 86) x))
+ (logand (+ x 1152921504606846975)
+ 38046409652025950207)))))
+ (assert (= (funcall fun32 61) 268574721))
+ (assert (= (funcall fun64 61) 60)))
+ (let (result)
+ (do ((width 5 (1+ width)))
+ ((= width 130))
+ (dotimes (extra 4)
+ (let ((fun (compile nil `(lambda (x)
+ (declare (optimize speed (safety 0)))
+ (declare (type (integer 1 16) x))
+ (logand
+ (+ x ,(1- (ash 1 width)))
+ ,(logior (ash 1 (+ width 1 extra))
+ (1- (ash 1 width))))))))
+ (unless (= (funcall fun 16) (logand 15 (1- (ash 1 width))))
+ (push (cons width extra) result)))))
+ (assert (null result))))
+
+;; On x86-64 MOVE-IMMEDIATE of fixnum values into memory either directly
+;; uses a MOV into memory or goes through a temporary register if the
+;; value is larger than a certain number of bits. Check that it respects
+;; the limits of immediate arguments to the MOV instruction (if not, the
+;; assembler will fail an assertion) and doesn't have sign-extension
+;; problems. (The test passes fixnum constants through the MOVE VOP
+;; which calls MOVE-IMMEDIATE.)
+(with-test (:name :constant-fixnum-move)
+ (let ((f (compile nil `(lambda (g)
+ (funcall g
+ ;; The first three args are
+ ;; uninteresting as they are
+ ;; passed in registers.
+ 1 2 3
+ ,@(loop for i from 27 to 32
+ collect (expt 2 i)))))))
+ (assert (every #'plusp (funcall f #'list)))))
+
+(with-test (:name (:malformed-ignore :lp-1000239))
+ (raises-error?
+ (eval '(lambda () (declare (ignore (function . a)))))
+ sb-int:compiled-program-error)
+ (raises-error?
+ (eval '(lambda () (declare (ignore (function a b)))))
+ sb-int:compiled-program-error)
+ (raises-error?
+ (eval '(lambda () (declare (ignore (function)))))
+ sb-int:compiled-program-error)
+ (raises-error?
+ (eval '(lambda () (declare (ignore (a)))))
+ sb-int:compiled-program-error)
+ (raises-error?
+ (eval '(lambda () (declare (ignorable (a b)))))
+ sb-int:compiled-program-error))
+
+(with-test (:name :malformed-type-declaraions)
+ (compile nil '(lambda (a) (declare (type (integer 1 2 . 3) a)))))
+
+(with-test (:name :compiled-program-error-escaped-source)
+ (assert
+ (handler-case
+ (funcall (compile nil `(lambda () (lambda ("foo")))))
+ (sb-int:compiled-program-error (e)
+ (let ((source (read-from-string (sb-kernel::program-error-source e))))
+ (equal source '#'(lambda ("foo"))))))))
projects / sbcl.git / blobdiff