+
+;; A refactoring 1.0.12.18 caused lossy computation of primitive
+;; types for member types.
+(with-test (:name :member-type-primitive-type)
+ (let ((fun (compile nil `(lambda (p1 p2 p3)
+ (if p1
+ (the (member #c(1.2d0 1d0)) p2)
+ (the (eql #c(1.0 1.0)) p3))))))
+ (assert (eql (funcall fun 1 #c(1.2d0 1d0) #c(1.0 1.0))
+ #c(1.2d0 1.0d0)))))
+
+;; Fall-through jump elimination made control flow fall through to trampolines.
+;; Reported by Eric Marsden on sbcl-devel@ 2011.10.26, with a test case
+;; reproduced below (triggered a corruption warning and a memory fault).
+(with-test (:name :bug-883500)
+ (funcall (compile nil `(lambda (a)
+ (declare (type (integer -50 50) a))
+ (declare (optimize (speed 0)))
+ (mod (mod a (min -5 a)) 5)))
+ 1))
+
+;; Test for literals too large for the ISA (e.g. (SIGNED-BYTE 13) on SPARC).
+#+sb-unicode
+(with-test (:name :bug-883519)
+ (compile nil `(lambda (x)
+ (declare (type character x))
+ (eql x #\U0010FFFF))))
+
+;; Wide fixnum platforms had buggy address computation in atomic-incf/aref
+(with-test (:name :bug-887220)
+ (let ((incfer (compile
+ nil
+ `(lambda (vector index)
+ (declare (type (simple-array sb-ext:word (4))
+ vector)
+ (type (mod 4) index))
+ (sb-ext:atomic-incf (aref vector index) 1)
+ vector))))
+ (assert (equalp (funcall incfer
+ (make-array 4 :element-type 'sb-ext:word
+ :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))))