;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
-(cl:in-package :sb-c)
-
-(defknown compiler-derived-type (t) (values t t) (movable flushable unsafe))
-
-(deftransform compiler-derived-type ((x))
- `(values ',(type-specifier (lvar-type x)) t))
-
-(defun compiler-derived-type (x)
- (values t nil))
-
(cl:in-package :cl-user)
+(load "compiler-test-util.lisp")
+
;; The tests in this file assume that EVAL will use the compiler
(when (eq sb-ext:*evaluator-mode* :interpret)
(invoke-restart 'run-tests::skip-file))
(compiler-note () (throw :note nil)))
(error "Unreachable code undetected.")))
+(with-test (:name (:compiler :constraint-propagation :float-bounds-3
+ :LP-894498))
+ (catch :note
+ (handler-case
+ (compile nil '(lambda (x)
+ (declare (type (single-float 0.0) x))
+ (when (> x 0.0)
+ (when (zerop x)
+ (error "This is unreachable.")))))
+ (compiler-note () (throw :note nil)))
+ (error "Unreachable code undetected.")))
+
+(with-test (:name (:compiler :constraint-propagation :float-bounds-4
+ :LP-894498))
+ (catch :note
+ (handler-case
+ (compile nil '(lambda (x y)
+ (declare (type (single-float 0.0) x)
+ (type (single-float (0.0)) y))
+ (when (> x y)
+ (when (zerop x)
+ (error "This is unreachable.")))))
+ (compiler-note () (throw :note nil)))
+ (error "Unreachable code undetected.")))
+
(with-test (:name (:compiler :constraint-propagation :var-eql-to-var-1))
(catch :note
(handler-case
(logand most-positive-fixnum (* x most-positive-fixnum))))
;;; bug 256.b
-(assert (let (warned-p)
+(with-test (:name :propagate-type-through-error-and-binding)
+ (assert (let (warned-p)
(handler-bind ((warning (lambda (w) (setf warned-p t))))
(compile nil
- '(lambda (x)
- (list (let ((y (the real x)))
- (unless (floatp y) (error ""))
- y)
- (integer-length x)))))
- warned-p))
+ '(lambda (x)
+ (list (let ((y (the real x)))
+ (unless (floatp y) (error ""))
+ y)
+ (integer-length x)))))
+ warned-p)))
;; Dead / in safe code
(with-test (:name :safe-dead-/)
(assert (eq 'character
(funcall (compile nil
'(lambda (s)
- (sb-c::compiler-derived-type (aref (the string s) 0))))
+ (ctu:compiler-derived-type (aref (the string s) 0))))
"foo"))))
(with-test (:name :base-string-aref-type)
#-sb-unicode 'character
(funcall (compile nil
'(lambda (s)
- (sb-c::compiler-derived-type (aref (the base-string s) 0))))
+ (ctu:compiler-derived-type (aref (the base-string s) 0))))
(coerce "foo" 'base-string)))))
(with-test (:name :dolist-constant-type-derivation)
'(lambda (x)
(dolist (y '(1 2 3))
(when x
- (return (sb-c::compiler-derived-type y))))))
+ (return (ctu:compiler-derived-type y))))))
t))))
(with-test (:name :dolist-simple-list-type-derivation)
'(lambda (x)
(dolist (y (list 1 2 3))
(when x
- (return (sb-c::compiler-derived-type y))))))
+ (return (ctu:compiler-derived-type y))))))
t))))
(with-test (:name :dolist-dotted-constant-list-type-derivation)
'(lambda (x)
(dolist (y '(1 2 3 . 4) :foo)
(when x
- (return (sb-c::compiler-derived-type y)))))))))
+ (return (ctu:compiler-derived-type y)))))))))
(assert (equal '(integer 1 3) (funcall fun t)))
(assert (= 1 (length warned)))
(multiple-value-bind (res err) (ignore-errors (funcall fun nil))
(with-test (:name :rest-list-type-derivation)
(multiple-value-bind (type derivedp)
(funcall (compile nil `(lambda (&rest args)
- (sb-c::compiler-derived-type args)))
+ (ctu:compiler-derived-type args)))
nil)
(assert (eq 'list type))
(assert derivedp)))
+(with-test (:name :rest-list-type-derivation2)
+ (multiple-value-bind (type derivedp)
+ (funcall (funcall (compile nil `(lambda ()
+ (lambda (&rest args)
+ (ctu:compiler-derived-type args))))))
+ (assert (eq 'list type))
+ (assert derivedp)))
+
+(with-test (:name :rest-list-type-derivation3)
+ (multiple-value-bind (type derivedp)
+ (funcall (funcall (compile nil `(lambda ()
+ (lambda (&optional x &rest args)
+ (unless x (error "oops"))
+ (ctu:compiler-derived-type args)))))
+ t)
+ (assert (eq 'list type))
+ (assert derivedp)))
+
+(with-test (:name :rest-list-type-derivation4)
+ (multiple-value-bind (type derivedp)
+ (funcall (funcall (compile nil `(lambda ()
+ (lambda (&optional x &rest args)
+ (declare (type (or null integer) x))
+ (when x (setf args x))
+ (ctu:compiler-derived-type args)))))
+ 42)
+ (assert (equal '(or cons null integer) type))
+ (assert derivedp)))
+
(with-test (:name :base-char-typep-elimination)
- (assert (eq (funcall (lambda (ch)
- (declare (type base-char ch) (optimize (speed 3) (safety 0)))
- (typep ch 'base-char))
+ (assert (eq (funcall (compile nil
+ `(lambda (ch)
+ (declare (type base-char ch) (optimize (speed 3) (safety 0)))
+ (typep ch 'base-char)))
t)
t)))
(eval '(,lambda ,@args))))))))
(sb-vm::with-float-traps-masked
(:divide-by-zero :overflow :inexact :invalid)
- (let ((sb-ext:*evaluator-mode* :interpret))
+ (let (#+sb-eval (sb-ext:*evaluator-mode* :interpret))
(declare (sb-ext:muffle-conditions style-warning))
(test-comparison eql t t nil)
(test-comparison eql t t t)
(compile nil `(lambda (x y)
(declare (character x y) (optimize speed))
(,name x y)))))))
+
+;;; optimizing make-array
+(with-test (:name (make-array :open-code-initial-contents))
+ (assert (not (ctu:find-named-callees
+ (compile nil
+ `(lambda (x y z)
+ (make-array '(3) :initial-contents (list x y z)))))))
+ (assert (not (ctu:find-named-callees
+ (compile nil
+ `(lambda (x y z)
+ (make-array '3 :initial-contents (vector x y z)))))))
+ (assert (not (ctu:find-named-callees
+ (compile nil
+ `(lambda (x y z)
+ (make-array '3 :initial-contents `(,x ,y ,z))))))))
+
+;;; optimizing array-in-bounds-p
+(with-test (:name :optimize-array-in-bounds-p)
+ (locally
+ (macrolet ((find-callees (&body body)
+ `(ctu:find-named-callees
+ (compile nil
+ '(lambda ()
+ ,@body))
+ :name 'array-in-bounds-p))
+ (must-optimize (&body exprs)
+ `(progn
+ ,@(loop for expr in exprs
+ collect `(assert (not (find-callees
+ ,expr))))))
+ (must-not-optimize (&body exprs)
+ `(progn
+ ,@(loop for expr in exprs
+ collect `(assert (find-callees
+ ,expr))))))
+ (must-optimize
+ ;; in bounds
+ (let ((a (make-array '(1))))
+ (array-in-bounds-p a 0))
+ ;; exceeds upper bound (constant)
+ (let ((a (make-array '(1))))
+ (array-in-bounds-p a 1))
+ ;; exceeds upper bound (interval)
+ (let ((a (make-array '(1))))
+ (array-in-bounds-p a (+ 1 (random 2))))
+ ;; negative lower bound (constant)
+ (let ((a (make-array '(1))))
+ (array-in-bounds-p a -1))
+ ;; negative lower bound (interval)
+ (let ((a (make-array 3))
+ (i (- (random 1) 20)))
+ (array-in-bounds-p a i))
+ ;; multiple known dimensions
+ (let ((a (make-array '(1 1))))
+ (array-in-bounds-p a 0 0))
+ ;; union types
+ (let ((s (the (simple-string 10) (eval "0123456789"))))
+ (array-in-bounds-p s 9)))
+ (must-not-optimize
+ ;; don't trust non-simple array length in safety=1
+ (let ((a (the (array * (10)) (make-array 10 :adjustable t))))
+ (eval `(adjust-array ,a 0))
+ (array-in-bounds-p a 9))
+ ;; same for a union type
+ (let ((s (the (string 10) (make-array 10
+ :element-type 'character
+ :adjustable t))))
+ (eval `(adjust-array ,s 0))
+ (array-in-bounds-p s 9))
+ ;; single unknown dimension
+ (let ((a (make-array (random 20))))
+ (array-in-bounds-p a 10))
+ ;; multiple unknown dimensions
+ (let ((a (make-array (list (random 20) (random 5)))))
+ (array-in-bounds-p a 5 2))
+ ;; some other known dimensions
+ (let ((a (make-array (list 1 (random 5)))))
+ (array-in-bounds-p a 0 2))
+ ;; subscript might be negative
+ (let ((a (make-array 5)))
+ (array-in-bounds-p a (- (random 3) 2)))
+ ;; subscript might be too large
+ (let ((a (make-array 5)))
+ (array-in-bounds-p a (random 6)))
+ ;; unknown upper bound
+ (let ((a (make-array 5)))
+ (array-in-bounds-p a (get-universal-time)))
+ ;; unknown lower bound
+ (let ((a (make-array 5)))
+ (array-in-bounds-p a (- (get-universal-time))))
+ ;; in theory we should be able to optimize
+ ;; the following but the current implementation
+ ;; doesn't cut it because the array type's
+ ;; dimensions get reported as (* *).
+ (let ((a (make-array (list (random 20) 1))))
+ (array-in-bounds-p a 5 2))))))
+
+;;; optimizing (EXPT -1 INTEGER)
+(test-util:with-test (:name (expt minus-one integer))
+ (dolist (x '(-1 -1.0 -1.0d0))
+ (let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x))))))
+ (assert (not (ctu:find-named-callees fun)))
+ (dotimes (i 12)
+ (if (oddp i)
+ (assert (eql x (funcall fun i)))
+ (assert (eql (- x) (funcall fun i))))))))
+
+(with-test (:name :float-division-using-exact-reciprocal)
+ (flet ((test (lambda-form arg res &key (check-insts t))
+ (let* ((fun (compile nil lambda-form))
+ (disassembly (with-output-to-string (s)
+ (disassemble fun :stream s))))
+ ;; Let's make sure there is no division at runtime: for x86 and
+ ;; x86-64 that implies an FDIV, DIVSS, or DIVSD instruction, so
+ ;; look for DIV in the disassembly. It's a terrible KLUDGE, but
+ ;; it works.
+ #+(or x86 x86-64)
+ (when check-insts
+ (assert (not (search "DIV" disassembly))))
+ ;; No generic arithmetic!
+ (assert (not (search "GENERIC" disassembly)))
+ (assert (eql res (funcall fun arg))))))
+ (dolist (c '(128 64 32 16 8 4 2 1 1/2 1/4 1/8 1/16 1/32 1/64))
+ (dolist (type '(single-float double-float))
+ (let* ((cf (coerce c type))
+ (arg (- (random (* 2 cf)) cf))
+ (r1 (eval `(/ ,arg ,cf)))
+ (r2 (eval `(/ ,arg ,(- cf)))))
+ (test `(lambda (x) (declare (,type x)) (/ x ,cf)) arg r1)
+ (test `(lambda (x) (declare (,type x)) (/ x ,(- cf))) arg r2)
+ ;; rational args should get optimized as well
+ (test `(lambda (x) (declare (,type x)) (/ x ,c)) arg r1)
+ (test `(lambda (x) (declare (,type x)) (/ x ,(- c))) arg r2))))
+ ;; Also check that inexact reciprocals (1) are not used by default (2) are
+ ;; used with FLOAT-ACCURACY=0.
+ (dolist (type '(single-float double-float))
+ (let ((trey (coerce 3 type))
+ (one (coerce 1 type)))
+ (test `(lambda (x) (declare (,type x)) (/ x 3)) trey one
+ :check-insts nil)
+ (test `(lambda (x)
+ (declare (,type x)
+ (optimize (sb-c::float-accuracy 0)))
+ (/ x 3))
+ trey (eval `(* ,trey (/ ,trey))))))))
+
+(with-test (:name :float-multiplication-by-one)
+ (flet ((test (lambda-form arg &optional (result arg))
+ (let* ((fun1 (compile nil lambda-form))
+ (fun2 (funcall (compile nil `(lambda ()
+ (declare (optimize (sb-c::float-accuracy 0)))
+ ,lambda-form))))
+ (disassembly1 (with-output-to-string (s)
+ (disassemble fun1 :stream s)))
+ (disassembly2 (with-output-to-string (s)
+ (disassemble fun2 :stream s))))
+ ;; Multiplication at runtime should be eliminated only with
+ ;; FLOAT-ACCURACY=0. (To catch SNaNs.)
+ #+(or x86 x86-64)
+ (assert (and (search "MUL" disassembly1)
+ (not (search "MUL" disassembly2))))
+ ;; Not generic arithmetic, please!
+ (assert (and (not (search "GENERIC" disassembly1))
+ (not (search "GENERIC" disassembly2))))
+ (assert (eql result (funcall fun1 arg)))
+ (assert (eql result (funcall fun2 arg))))))
+ (dolist (type '(single-float double-float))
+ (let* ((one (coerce 1 type))
+ (arg (random (* 2 one)))
+ (-r (- arg)))
+ (test `(lambda (x) (declare (,type x)) (* x 1)) arg)
+ (test `(lambda (x) (declare (,type x)) (* x -1)) arg -r)
+ (test `(lambda (x) (declare (,type x)) (* x ,one)) arg)
+ (test `(lambda (x) (declare (,type x)) (* x ,(- one))) arg -r)))))
+
+(with-test (:name :float-addition-of-zero)
+ (flet ((test (lambda-form arg &optional (result arg))
+ (let* ((fun1 (compile nil lambda-form))
+ (fun2 (funcall (compile nil `(lambda ()
+ (declare (optimize (sb-c::float-accuracy 0)))
+ ,lambda-form))))
+ (disassembly1 (with-output-to-string (s)
+ (disassemble fun1 :stream s)))
+ (disassembly2 (with-output-to-string (s)
+ (disassemble fun2 :stream s))))
+ ;; Let's make sure there is no addition at runtime: for x86 and
+ ;; x86-64 that implies an FADD, ADDSS, or ADDSD instruction, so
+ ;; look for the ADDs in the disassembly. It's a terrible KLUDGE,
+ ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
+ ;; addition in to catch SNaNs.
+ #+x86
+ (assert (and (search "FADD" disassembly1)
+ (not (search "FADD" disassembly2))))
+ #+x86-64
+ (let ((inst (if (typep result 'double-float)
+ "ADDSD" "ADDSS")))
+ (assert (and (search inst disassembly1)
+ (not (search inst disassembly2)))))
+ (assert (eql result (funcall fun1 arg)))
+ (assert (eql result (funcall fun2 arg))))))
+ (test `(lambda (x) (declare (single-float x)) (+ x 0)) 123.45)
+ (test `(lambda (x) (declare (single-float x)) (+ x 0.0)) 543.21)
+ (test `(lambda (x) (declare (single-float x)) (+ x 0.0d0)) 42.00 42.d0)
+ (test `(lambda (x) (declare (double-float x)) (+ x 0)) 123.45d0)
+ (test `(lambda (x) (declare (double-float x)) (+ x 0.0)) 543.21d0)
+ (test `(lambda (x) (declare (double-float x)) (+ x 0.0d0)) 42.d0)))
+
+(with-test (:name :float-substraction-of-zero)
+ (flet ((test (lambda-form arg &optional (result arg))
+ (let* ((fun1 (compile nil lambda-form))
+ (fun2 (funcall (compile nil `(lambda ()
+ (declare (optimize (sb-c::float-accuracy 0)))
+ ,lambda-form))))
+ (disassembly1 (with-output-to-string (s)
+ (disassemble fun1 :stream s)))
+ (disassembly2 (with-output-to-string (s)
+ (disassemble fun2 :stream s))))
+ ;; Let's make sure there is no substraction at runtime: for x86
+ ;; and x86-64 that implies an FSUB, SUBSS, or SUBSD instruction,
+ ;; so look for SUB in the disassembly. It's a terrible KLUDGE,
+ ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
+ ;; substraction in in to catch SNaNs.
+ #+x86
+ (assert (and (search "FSUB" disassembly1)
+ (not (search "FSUB" disassembly2))))
+ #+x86-64
+ (let ((inst (if (typep result 'double-float)
+ "SUBSD" "SUBSS")))
+ (assert (and (search inst disassembly1)
+ (not (search inst disassembly2)))))
+ (assert (eql result (funcall fun1 arg)))
+ (assert (eql result (funcall fun2 arg))))))
+ (test `(lambda (x) (declare (single-float x)) (- x 0)) 123.45)
+ (test `(lambda (x) (declare (single-float x)) (- x 0.0)) 543.21)
+ (test `(lambda (x) (declare (single-float x)) (- x 0.0d0)) 42.00 42.d0)
+ (test `(lambda (x) (declare (double-float x)) (- x 0)) 123.45d0)
+ (test `(lambda (x) (declare (double-float x)) (- x 0.0)) 543.21d0)
+ (test `(lambda (x) (declare (double-float x)) (- x 0.0d0)) 42.d0)))
+
+(with-test (:name :float-multiplication-by-two)
+ (flet ((test (lambda-form arg &optional (result arg))
+ (let* ((fun1 (compile nil lambda-form))
+ (fun2 (funcall (compile nil `(lambda ()
+ (declare (optimize (sb-c::float-accuracy 0)))
+ ,lambda-form))))
+ (disassembly1 (with-output-to-string (s)
+ (disassemble fun1 :stream s)))
+ (disassembly2 (with-output-to-string (s)
+ (disassemble fun2 :stream s))))
+ ;; Let's make sure there is no multiplication at runtime: for x86
+ ;; and x86-64 that implies an FMUL, MULSS, or MULSD instruction,
+ ;; so look for MUL in the disassembly. It's a terrible KLUDGE,
+ ;; but it works.
+ #+(or x86 x86-64)
+ (assert (and (not (search "MUL" disassembly1))
+ (not (search "MUL" disassembly2))))
+ (assert (eql result (funcall fun1 arg)))
+ (assert (eql result (funcall fun2 arg))))))
+ (test `(lambda (x) (declare (single-float x)) (* x 2)) 123.45 246.9)
+ (test `(lambda (x) (declare (single-float x)) (* x 2.0)) 543.21 1086.42)
+ (test `(lambda (x) (declare (single-float x)) (* x 2.0d0)) 42.00 84.d0)
+ (test `(lambda (x) (declare (double-float x)) (* x 2)) 123.45d0 246.9d0)
+ (test `(lambda (x) (declare (double-float x)) (* x 2.0)) 543.21d0 1086.42d0)
+ (test `(lambda (x) (declare (double-float x)) (* x 2.0d0)) 42.0d0 84.0d0)))
+
+(with-test (:name :bug-392203)
+ ;; Used to hit an AVER in COMVERT-MV-CALL.
+ (assert (zerop
+ (funcall
+ (compile nil
+ `(lambda ()
+ (flet ((k (&rest x) (declare (ignore x)) 0))
+ (multiple-value-call #'k #'k))))))))
+
+(with-test (:name :allocate-closures-failing-aver)
+ (let ((f (compile nil `(lambda ()
+ (labels ((k (&optional x) #'k)))))))
+ (assert (null (funcall f)))))
+
+(with-test (:name :flush-vector-creation)
+ (let ((f (compile nil `(lambda ()
+ (dotimes (i 1024)
+ (vector i i i))
+ t))))
+ (ctu:assert-no-consing (funcall f))))
+
+(with-test (:name :array-type-predicates)
+ (dolist (et sb-kernel::*specialized-array-element-types*)
+ (when et
+ (let* ((v (make-array 3 :element-type et))
+ (fun (compile nil `(lambda ()
+ (list
+ (if (typep ,v '(simple-array ,et (*)))
+ :good
+ :bad)
+ (if (typep (elt ,v 0) '(simple-array ,et (*)))
+ :bad
+ :good))))))
+ (assert (equal '(:good :good) (funcall fun)))))))
+
+(with-test (:name :truncate-float)
+ (let ((s (compile nil `(lambda (x)
+ (declare (single-float x))
+ (truncate x))))
+ (d (compile nil `(lambda (x)
+ (declare (double-float x))
+ (truncate x))))
+ (s-inlined (compile nil '(lambda (x)
+ (declare (type (single-float 0.0s0 1.0s0) x))
+ (truncate x))))
+ (d-inlined (compile nil '(lambda (x)
+ (declare (type (double-float 0.0d0 1.0d0) x))
+ (truncate x)))))
+ ;; Check that there is no generic arithmetic
+ (assert (not (search "GENERIC"
+ (with-output-to-string (out)
+ (disassemble s :stream out)))))
+ (assert (not (search "GENERIC"
+ (with-output-to-string (out)
+ (disassemble d :stream out)))))
+ ;; Check that we actually inlined the call when we were supposed to.
+ (assert (not (search "UNARY-TRUNCATE"
+ (with-output-to-string (out)
+ (disassemble s-inlined :stream out)))))
+ (assert (not (search "UNARY-TRUNCATE"
+ (with-output-to-string (out)
+ (disassemble d-inlined :stream out)))))))
+
+(with-test (:name :make-array-unnamed-dimension-leaf)
+ (let ((fun (compile nil `(lambda (stuff)
+ (make-array (map 'list 'length stuff))))))
+ (assert (equalp #2A((0 0 0) (0 0 0))
+ (funcall fun '((1 2) (1 2 3)))))))
+
+(with-test (:name :fp-decoding-funs-not-flushable-in-safe-code)
+ (dolist (name '(float-sign float-radix float-digits float-precision decode-float
+ integer-decode-float))
+ (let ((fun (compile nil `(lambda (x)
+ (declare (optimize safety))
+ (,name x)
+ nil))))
+ (flet ((test (arg)
+ (unless (eq :error
+ (handler-case
+ (funcall fun arg)
+ (error () :error)))
+ (error "(~S ~S) did not error"
+ name arg))))
+ ;; No error
+ (funcall fun 1.0)
+ ;; Error
+ (test 'not-a-float)
+ (when (member name '(decode-float integer-decode-float))
+ (test sb-ext:single-float-positive-infinity))))))
+
+(with-test (:name :sap-ref-16)
+ (let* ((fun (compile nil `(lambda (x y)
+ (declare (type sb-sys:system-area-pointer x)
+ (type (integer 0 100) y))
+ (sb-sys:sap-ref-16 x (+ 4 y)))))
+ (vector (coerce '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
+ '(simple-array (unsigned-byte 8) (*))))
+ (sap (sb-sys:vector-sap vector))
+ (ret (funcall fun sap 0)))
+ ;; test for either endianness
+ (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5))))))
+
+(with-test (:name :coerce-type-warning)
+ (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)
+ (signed-byte 8) (signed-byte 16) (signed-byte 32)))
+ (multiple-value-bind (fun warningsp failurep)
+ (compile nil `(lambda (x)
+ (declare (type simple-vector x))
+ (coerce x '(vector ,type))))
+ (assert (null warningsp))
+ (assert (null failurep))
+ (assert (typep (funcall fun #(1)) `(simple-array ,type (*)))))))
+
+(with-test (:name :truncate-double-float)
+ (let ((fun (compile nil `(lambda (x)
+ (multiple-value-bind (q r)
+ (truncate (coerce x 'double-float))
+ (declare (type unsigned-byte q)
+ (type double-float r))
+ (list q r))))))
+ (assert (equal (funcall fun 1.0d0) '(1 0.0d0)))))
+
+(with-test (:name :set-slot-value-no-warning)
+ (let ((notes 0))
+ (handler-bind ((warning #'error)
+ (sb-ext:compiler-note (lambda (c)
+ (declare (ignore c))
+ (incf notes))))
+ (compile nil `(lambda (x y)
+ (declare (optimize speed safety))
+ (setf (slot-value x 'bar) y))))
+ (assert (= 1 notes))))
+
+(with-test (:name :concatenate-string-opt)
+ (flet ((test (type grep)
+ (let* ((fun (compile nil `(lambda (a b c d e)
+ (concatenate ',type a b c d e))))
+ (args '("foo" #(#\.) "bar" (#\-) "quux"))
+ (res (apply fun args)))
+ (assert (search grep (with-output-to-string (out)
+ (disassemble fun :stream out))))
+ (assert (equal (apply #'concatenate type args)
+ res))
+ (assert (typep res type)))))
+ (test 'string "%CONCATENATE-TO-STRING")
+ (test 'simple-string "%CONCATENATE-TO-STRING")
+ (test 'base-string "%CONCATENATE-TO-BASE-STRING")
+ (test 'simple-base-string "%CONCATENATE-TO-BASE-STRING")))
+
+(with-test (:name :satisfies-no-local-fun)
+ (let ((fun (compile nil `(lambda (arg)
+ (labels ((local-not-global-bug (x)
+ t)
+ (bar (x)
+ (typep x '(satisfies local-not-global-bug))))
+ (bar arg))))))
+ (assert (eq 'local-not-global-bug
+ (handler-case
+ (funcall fun 42)
+ (undefined-function (c)
+ (cell-error-name c)))))))
+
+;;; Prior to 1.0.32.x, dumping a fasl with a function with a default
+;;; argument that is a complex structure (needing make-load-form
+;;; processing) failed an AVER. The first attempt at a fix caused
+;;; doing the same in-core to break.
+(with-test (:name :bug-310132)
+ (compile nil '(lambda (&optional (foo #p"foo/bar")))))
+
+(with-test (:name :bug-309129)
+ (let* ((src '(lambda (v) (values (svref v 0) (vector-pop v))))
+ (warningp nil)
+ (fun (handler-bind ((warning (lambda (c)
+ (setf warningp t) (muffle-warning c))))
+ (compile nil src))))
+ (assert warningp)
+ (handler-case (funcall fun #(1))
+ (type-error (c)
+ ;; we used to put simply VECTOR into EXPECTED-TYPE, rather
+ ;; than explicitly (AND VECTOR (NOT SIMPLE-ARRAY))
+ (assert (not (typep (type-error-datum c) (type-error-expected-type c)))))
+ (:no-error (&rest values)
+ (declare (ignore values))
+ (error "no error")))))
+
+(with-test (:name :unary-round-type-derivation)
+ (let* ((src '(lambda (zone)
+ (multiple-value-bind (h m) (truncate (abs zone) 1.0)
+ (declare (ignore h))
+ (round (* 60.0 m)))))
+ (fun (compile nil src)))
+ (assert (= (funcall fun 0.5) 30))))
+
+(with-test (:name :bug-525949)
+ (let* ((src '(lambda ()
+ (labels ((always-one () 1)
+ (f (z)
+ (let ((n (funcall z)))
+ (declare (fixnum n))
+ (the double-float (expt n 1.0d0)))))
+ (f #'always-one))))
+ (warningp nil)
+ (fun (handler-bind ((warning (lambda (c)
+ (setf warningp t) (muffle-warning c))))
+ (compile nil src))))
+ (assert (not warningp))
+ (assert (= 1.0d0 (funcall fun)))))
+
+(with-test (:name :%array-data-vector-type-derivation)
+ (let* ((f (compile nil
+ `(lambda (ary)
+ (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
+ (setf (aref ary 0 0) 0))))
+ (text (with-output-to-string (s)
+ (disassemble f :stream s))))
+ (assert (not (search "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" text)))))
+
+(with-test (:name :array-storage-vector-type-derivation)
+ (let ((f (compile nil
+ `(lambda (ary)
+ (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
+ (ctu:compiler-derived-type (array-storage-vector ary))))))
+ (assert (equal '(simple-array (unsigned-byte 32) (9))
+ (funcall f (make-array '(3 3) :element-type '(unsigned-byte 32)))))))
+
+(with-test (:name :bug-523612)
+ (let ((fun
+ (compile nil
+ `(lambda (&key toff)
+ (make-array 3 :element-type 'double-float
+ :initial-contents
+ (if toff (list toff 0d0 0d0) (list 0d0 0d0 0d0)))))))
+ (assert (equalp (vector 0.0d0 0.0d0 0.0d0) (funcall fun :toff nil)))
+ (assert (equalp (vector 2.3d0 0.0d0 0.0d0) (funcall fun :toff 2.3d0)))))
+
+(with-test (:name :bug-309788)
+ (let ((fun
+ (compile nil
+ `(lambda (x)
+ (declare (optimize speed))
+ (let ((env nil))
+ (typep x 'fixnum env))))))
+ (assert (not (ctu:find-named-callees fun)))))
+
+(with-test (:name :bug-309124)
+ (let ((fun
+ (compile nil
+ `(lambda (x)
+ (declare (integer x))
+ (declare (optimize speed))
+ (cond ((typep x 'fixnum)
+ "hala")
+ ((typep x 'fixnum)
+ "buba")
+ ((typep x 'bignum)
+ "hip")
+ (t
+ "zuz"))))))
+ (assert (equal (list "hala" "hip")
+ (sort (ctu:find-code-constants fun :type 'string)
+ #'string<)))))
+
+(with-test (:name :bug-316078)
+ (let ((fun
+ (compile nil
+ `(lambda (x)
+ (declare (type (and simple-bit-vector (satisfies bar)) x)
+ (optimize speed))
+ (elt x 5)))))
+ (assert (not (ctu:find-named-callees fun)))
+ (assert (= 1 (funcall fun #*000001)))
+ (assert (= 0 (funcall fun #*000010)))))
+
+(with-test (:name :mult-by-one-in-float-acc-zero)
+ (assert (eql 1.0 (funcall (compile nil `(lambda (x)
+ (declare (optimize (sb-c::float-accuracy 0)))
+ (* x 1.0)))
+ 1)))
+ (assert (eql -1.0 (funcall (compile nil `(lambda (x)
+ (declare (optimize (sb-c::float-accuracy 0)))
+ (* x -1.0)))
+ 1)))
+ (assert (eql 1.0d0 (funcall (compile nil `(lambda (x)
+ (declare (optimize (sb-c::float-accuracy 0)))
+ (* x 1.0d0)))
+ 1)))
+ (assert (eql -1.0d0 (funcall (compile nil `(lambda (x)
+ (declare (optimize (sb-c::float-accuracy 0)))
+ (* x -1.0d0)))
+ 1))))
+
+(with-test (:name :dotimes-non-integer-counter-value)
+ (assert (raises-error? (dotimes (i 8.6)) type-error)))
+
+(with-test (:name :bug-454681)
+ ;; This used to break due to reference to a dead lambda-var during
+ ;; inline expansion.
+ (assert (compile nil
+ `(lambda ()
+ (multiple-value-bind (iterator+977 getter+978)
+ (does-not-exist-but-does-not-matter)
+ (flet ((iterator+976 ()
+ (funcall iterator+977)))
+ (declare (inline iterator+976))
+ (let ((iterator+976 #'iterator+976))
+ (funcall iterator+976))))))))
+
+(with-test (:name :complex-float-local-fun-args)
+ ;; As of 1.0.27.14, the lambda below failed to compile due to the
+ ;; compiler attempting to pass unboxed complex floats to Z and the
+ ;; MOVE-ARG method not expecting the register being used as a
+ ;; temporary frame pointer. Reported by sykopomp in #lispgames,
+ ;; reduced test case provided by _3b`.
+ (compile nil '(lambda (a)
+ (labels ((z (b c)
+ (declare ((complex double-float) b c))
+ (* b (z b c))))
+ (loop for i below 10 do
+ (setf a (z a a)))))))
+
+(with-test (:name :bug-309130)
+ (assert (eq :warning
+ (handler-case
+ (compile nil `(lambda () (svref (make-array 8 :adjustable t) 1)))
+ ((and warning (not style-warning)) ()
+ :warning))))
+ (assert (eq :warning
+ (handler-case
+ (compile nil `(lambda (x)
+ (declare (optimize (debug 0)))
+ (declare (type vector x))
+ (list (fill-pointer x) (svref x 1))))
+ ((and warning (not style-warning)) ()
+ :warning))))
+ (assert (eq :warning
+ (handler-case
+ (compile nil `(lambda (x)
+ (list (vector-push (svref x 0) x))))
+ ((and warning (not style-warning)) ()
+ :warning))))
+ (assert (eq :warning
+ (handler-case
+ (compile nil `(lambda (x)
+ (list (vector-push-extend (svref x 0) x))))
+ ((and warning (not style-warning)) ()
+ :warning)))))
+
+(with-test (:name :bug-646796)
+ (assert 42
+ (funcall
+ (compile nil
+ `(lambda ()
+ (load-time-value (the (values fixnum) 42)))))))
+
+(with-test (:name :bug-654289)
+ ;; Test that compile-times don't explode when quoted constants
+ ;; get big.
+ (labels ((time-n (n)
+ (gc :full t) ; Let's not confuse the issue with GC
+ (let* ((tree (make-tree (expt 10 n) nil))
+ (t0 (get-internal-run-time))
+ (f (compile nil `(lambda (x) (eq x (quote ,tree)))))
+ (t1 (get-internal-run-time)))
+ (assert (funcall f tree))
+ (- t1 t0)))
+ (make-tree (n acc)
+ (cond ((zerop n) acc)
+ (t (make-tree (1- n) (cons acc acc))))))
+ (let* ((times (loop for i from 0 upto 4
+ collect (time-n i)))
+ (max-small (reduce #'max times :end 3))
+ (max-big (reduce #'max times :start 3)))
+ ;; This way is hopefully fairly CPU-performance insensitive.
+ (unless (> (+ (truncate internal-time-units-per-second 10)
+ (* 2 max-small))
+ max-big)
+ (error "Bad scaling or test? ~S" times)))))
+
+(with-test (:name :bug-309063)
+ (let ((fun (compile nil `(lambda (x)
+ (declare (type (integer 0 0) x))
+ (ash x 100)))))
+ (assert (zerop (funcall fun 0)))))
+
+(with-test (:name :bug-655872)
+ (let ((f (compile nil `(lambda (x)
+ (declare (optimize (safety 3)))
+ (aref (locally (declare (optimize (safety 0)))
+ (coerce x '(simple-vector 128)))
+ 60))))
+ (long (make-array 100 :element-type 'fixnum)))
+ (dotimes (i 100)
+ (setf (aref long i) i))
+ ;; 1. COERCE doesn't check the length in unsafe code.
+ (assert (eql 60 (funcall f long)))
+ ;; 2. The compiler doesn't trust the length from COERCE
+ (assert (eq :caught
+ (handler-case
+ (funcall f (list 1 2 3))
+ (sb-int:invalid-array-index-error (e)
+ (assert (eql 60 (type-error-datum e)))
+ (assert (equal '(integer 0 (3)) (type-error-expected-type e)))
+ :caught))))))
+
+(with-test (:name :bug-655203-regression)
+ (let ((fun (compile nil
+ `(LAMBDA (VARIABLE)
+ (LET ((CONTINUATION
+ (LAMBDA
+ (&OPTIONAL DUMMY &REST OTHER)
+ (DECLARE (IGNORE OTHER))
+ (PRIN1 DUMMY)
+ (PRIN1 VARIABLE))))
+ (FUNCALL CONTINUATION (LIST 1 2)))))))
+ ;; This used to signal a bogus type-error.
+ (assert (equal (with-output-to-string (*standard-output*)
+ (funcall fun t))
+ "(1 2)T"))))
+
+(with-test (:name :constant-concatenate-compile-time)
+ (flet ((make-lambda (n)
+ `(lambda (x)
+ (declare (optimize (speed 3) (space 0)))
+ (concatenate 'string x ,(make-string n)))))
+ (let* ((l0 (make-lambda 1))
+ (l1 (make-lambda 10))
+ (l2 (make-lambda 100))
+ (l3 (make-lambda 1000))
+ (t0 (get-internal-run-time))
+ (f0 (compile nil l0))
+ (t1 (get-internal-run-time))
+ (f1 (compile nil l1))
+ (t2 (get-internal-run-time))
+ (f2 (compile nil l2))
+ (t3 (get-internal-run-time))
+ (f3 (compile nil l3))
+ (t4 (get-internal-run-time))
+ (d0 (- t1 t0))
+ (d1 (- t2 t1))
+ (d2 (- t3 t2))
+ (d3 (- t4 t3))
+ (short-avg (/ (+ d0 d1 d2) 3)))
+ (assert (and f1 f2 f3))
+ (assert (< d3 (* 10 short-avg))))))
+
+(with-test (:name :bug-384892)
+ (assert (equal
+ '(function (fixnum fixnum &key (:k1 (member nil t)))
+ (values (member t) &optional))
+ (sb-kernel:%simple-fun-type
+ (compile nil `(lambda (x y &key k1)
+ (declare (fixnum x y))
+ (declare (boolean k1))
+ (declare (ignore x y k1))
+ t))))))
+
+(with-test (:name :bug-309448)
+ ;; Like all tests trying to verify that something doesn't blow up
+ ;; 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))
+ (got (funcall fun)))
+ (unless (eql want got)
+ (error "wanted ~S, got ~S" want got))
+ (- end start))))
+ (let ((time-1/simple
+ ;; This is mostly identical as the next one, but doesn't create
+ ;; hairy unions of numeric types.
+ (time-it `(lambda ()
+ (labels ((bar (baz bim)
+ (let ((n (+ baz bim)))
+ (* n (+ n 1) bim))))
+ (let ((a (bar 1 1))
+ (b (bar 1 1))
+ (c (bar 1 1)))
+ (- (+ a b) c))))
+ 6))
+ (time-1/hairy
+ (time-it `(lambda ()
+ (labels ((bar (baz bim)
+ (let ((n (+ baz bim)))
+ (* n (+ n 1) bim))))
+ (let ((a (bar 1 1))
+ (b (bar 1 5))
+ (c (bar 1 15)))
+ (- (+ a b) c))))
+ -3864)))
+ (assert (>= (* 10 (1+ time-1/simple)) time-1/hairy)))
+ (let ((time-2/simple
+ ;; This is mostly identical as the next one, but doesn't create
+ ;; hairy unions of numeric types.
+ (time-it `(lambda ()
+ (labels ((sum-d (n)
+ (let ((m (truncate 999 n)))
+ (/ (* n m (1+ m)) 2))))
+ (- (+ (sum-d 3)
+ (sum-d 3))
+ (sum-d 3))))
+ 166833))
+ (time-2/hairy
+ (time-it `(lambda ()
+ (labels ((sum-d (n)
+ (let ((m (truncate 999 n)))
+ (/ (* n m (1+ m)) 2))))
+ (- (+ (sum-d 3)
+ (sum-d 5))
+ (sum-d 15))))
+ 233168)))
+ (assert (>= (* 10 (1+ time-2/simple)) time-2/hairy)))))
+
+(with-test (:name :regression-1.0.44.34)
+ (compile nil '(lambda (z &rest args)
+ (declare (dynamic-extent args))
+ (flet ((foo (w v) (list v w)))
+ (setq z 0)
+ (flet ((foo ()
+ (foo z args)))
+ (declare (sb-int:truly-dynamic-extent #'foo))
+ (call #'foo nil))))))
+
+(with-test (:name :bug-713626)
+ (let ((f (eval '(constantly 42))))
+ (handler-bind ((warning #'error))
+ (assert (= 42 (funcall (compile nil `(lambda () (funcall ,f 1 2 3)))))))))
+
+(with-test (:name :known-fun-allows-other-keys)
+ (handler-bind ((warning #'error))
+ (funcall (compile nil '(lambda () (directory "." :allow-other-keys t))))
+ (funcall (compile nil `(lambda () (directory "." :bar t :allow-other-keys t))))))
+
+(with-test (:name :bug-551227)
+ ;; This function causes constraint analysis to perform a
+ ;; ref-substitution that alters the A referred to in (G A) at in the
+ ;; consequent of the IF to refer to be NUMBER, from the
+ ;; LET-converted inline-expansion of MOD. This leads to attempting
+ ;; to CLOSE-OVER a variable that simply isn't in scope when it is
+ ;; referenced.
+ (compile nil '(lambda (a)
+ (if (let ((s a))
+ (block :block
+ (map nil
+ (lambda (e)
+ (return-from :block
+ (f (mod a e))))
+ s)))
+ (g a)))))
+
+(with-test (:name :funcall-lambda-inlined)
+ (assert (not
+ (ctu:find-code-constants
+ (compile nil
+ `(lambda (x y)
+ (+ x (funcall (lambda (z) z) y))))
+ :type 'function))))
+
+(with-test (:name :bug-720382)
+ (let ((w 0))
+ (let ((f
+ (handler-bind (((and warning (not style-warning))
+ (lambda (c) (incf w))))
+ (compile nil `(lambda (b) ((lambda () b) 1))))))
+ (assert (= w 1))
+ (assert (eq :error
+ (handler-case (funcall f 0)
+ (error () :error)))))))
+
+(with-test (:name :multiple-args-to-function)
+ (let ((form `(flet ((foo (&optional (x 13)) x))
+ (funcall (function foo 42))))
+ (*evaluator-mode* :interpret))
+ (assert (eq :error
+ (handler-case (eval form)
+ (error () :error))))
+ (multiple-value-bind (fun warn fail)
+ (compile nil `(lambda () ,form))
+ (assert (and warn fail))
+ (assert (eq :error
+ (handler-case (funcall fun)
+ (error () :error)))))))
+
+;;; This doesn't test LVAR-FUN-IS directly, but captures it
+;;; pretty accurately anyways.
+(with-test (:name :lvar-fun-is)
+ (dolist (fun (list
+ (lambda (x) (member x x :test #'eq))
+ (lambda (x) (member x x :test 'eq))
+ (lambda (x) (member x x :test #.#'eq))))
+ (assert (equal (list #'sb-kernel:%member-eq)
+ (ctu:find-named-callees fun))))
+ (dolist (fun (list
+ (lambda (x)
+ (declare (notinline eq))
+ (member x x :test #'eq))
+ (lambda (x)
+ (declare (notinline eq))
+ (member x x :test 'eq))
+ (lambda (x)
+ (declare (notinline eq))
+ (member x x :test #.#'eq))))
+ (assert (member #'sb-kernel:%member-test
+ (ctu:find-named-callees fun)))))
+
+(with-test (:name :delete-to-delq-opt)
+ (dolist (fun (list (lambda (x y)
+ (declare (list y))
+ (delete x y :test #'eq))
+ (lambda (x y)
+ (declare (fixnum x) (list y))
+ (delete x y))
+ (lambda (x y)
+ (declare (symbol x) (list y))
+ (delete x y :test #'eql))))
+ (assert (equal (list #'sb-int:delq)
+ (ctu:find-named-callees fun)))))
+
+(with-test (:name :bug-767959)
+ ;; This used to signal an error.
+ (compile nil `(lambda ()
+ (declare (optimize sb-c:store-coverage-data))
+ (assoc
+ nil
+ '((:ordinary . ordinary-lambda-list))))))
+
+(with-test (:name :member-on-long-constant-list)
+ ;; This used to blow stack with a sufficiently long list.
+ (let ((cycle (list t)))
+ (nconc cycle cycle)
+ (compile nil `(lambda (x)
+ (member x ',cycle)))))
+
+(with-test (:name :bug-722734)
+ (assert (raises-error?
+ (funcall (compile
+ nil
+ '(lambda ()
+ (eql (make-array 6)
+ (list unbound-variable-1 unbound-variable-2))))))))
+
+(with-test (:name :bug-771673)
+ (assert (equal `(the foo bar) (macroexpand `(truly-the foo bar))))
+ ;; Make sure the compiler doesn't use THE, and check that setf-expansions
+ ;; work.
+ (let ((f (compile nil `(lambda (x y)
+ (setf (truly-the fixnum (car x)) y)))))
+ (let* ((cell (cons t t)))
+ (funcall f cell :ok)
+ (assert (equal '(:ok . t) cell)))))
+
+(with-test (:name (:bug-793771 +))
+ (let ((f (compile nil `(lambda (x y)
+ (declare (type (single-float 2.0) x)
+ (type (single-float (0.0)) y))
+ (+ x y)))))
+ (assert (equal `(function ((single-float 2.0) (single-float (0.0)))
+ (values (single-float 2.0) &optional))
+ (sb-kernel:%simple-fun-type f)))))
+
+(with-test (:name (:bug-793771 -))
+ (let ((f (compile nil `(lambda (x y)
+ (declare (type (single-float * 2.0) x)
+ (type (single-float (0.0)) y))
+ (- x y)))))
+ (assert (equal `(function ((single-float * 2.0) (single-float (0.0)))
+ (values (single-float * 2.0) &optional))
+ (sb-kernel:%simple-fun-type f)))))
+
+(with-test (:name (:bug-793771 *))
+ (let ((f (compile nil `(lambda (x)
+ (declare (type (single-float (0.0)) x))
+ (* x 0.1)))))
+ (assert (equal `(function ((single-float (0.0)))
+ (values (or (member 0.0) (single-float (0.0))) &optional))
+ (sb-kernel:%simple-fun-type f)))))
+
+(with-test (:name (:bug-793771 /))
+ (let ((f (compile nil `(lambda (x)
+ (declare (type (single-float (0.0)) x))
+ (/ x 3.0)))))
+ (assert (equal `(function ((single-float (0.0)))
+ (values (or (member 0.0) (single-float (0.0))) &optional))
+ (sb-kernel:%simple-fun-type f)))))
+
+(with-test (:name (:bug-486812 single-float))
+ (compile nil `(lambda ()
+ (sb-kernel:make-single-float -1))))
+
+(with-test (:name (:bug-486812 double-float))
+ (compile nil `(lambda ()
+ (sb-kernel:make-double-float -1 0))))
+
+(with-test (:name :bug-729765)
+ (compile nil `(lambda (a b)
+ (declare ((integer 1 1) a)
+ ((integer 0 1) b)
+ (optimize debug))
+ (lambda () (< b a)))))
+
+;; Actually tests the assembly of RIP-relative operands to comparison
+;; functions (one of the few x86 instructions that have extra bytes
+;; *after* the mem operand's effective address, resulting in a wrong
+;; offset).
+(with-test (:name :cmpps)
+ (let ((foo (compile nil `(lambda (x)
+ (= #C(2.0 3.0) (the (complex single-float) x))))))
+ (assert (funcall foo #C(2.0 3.0)))
+ (assert (not (funcall foo #C(1.0 2.0))))))
+
+(with-test (:name :cmppd)
+ (let ((foo (compile nil `(lambda (x)
+ (= #C(2d0 3d0) (the (complex double-float) x))))))
+ (assert (funcall foo #C(2d0 3d0)))
+ (assert (not (funcall foo #C(1d0 2d0))))))
+
+(with-test (:name :lvar-externally-checkable-type-nil)
+ ;; Used to signal a BUG during compilation.
+ (let ((fun (compile nil `(lambda (a) (parse-integer "12321321" (the (member :start) a) 1)))))
+ (multiple-value-bind (i p) (funcall fun :start)
+ (assert (= 2321321 i))
+ (assert (= 8 p)))
+ (multiple-value-bind (i e) (ignore-errors (funcall fun :end))
+ (assert (not i))
+ (assert (typep e 'type-error)))))
+
+(with-test (:name :simple-type-error-in-bound-propagation-a)
+ (compile nil `(lambda (i)
+ (declare (unsigned-byte i))
+ (expt 10 (expt 7 (- 2 i))))))
+
+(with-test (:name :simple-type-error-in-bound-propagation-b)
+ (assert (equal `(FUNCTION (UNSIGNED-BYTE)
+ (VALUES (SINGLE-FLOAT -1F0 1F0) &OPTIONAL))
+ (sb-kernel:%simple-fun-type
+ (compile nil `(lambda (i)
+ (declare (unsigned-byte i))
+ (cos (expt 10 (+ 4096 i)))))))))
+
+(with-test (:name :fixed-%more-arg-values)
+ (let ((fun (compile nil `(lambda (&rest rest)
+ (declare (optimize (safety 0)))
+ (apply #'cons rest)))))
+ (assert (equal '(car . cdr) (funcall fun 'car 'cdr)))))
+
+(with-test (:name :bug-826970)
+ (let ((fun (compile nil `(lambda (a b c)
+ (declare (type (member -2 1) b))
+ (array-in-bounds-p a 4 b c)))))
+ (assert (funcall fun (make-array '(5 2 2)) 1 1))))
+
+(with-test (:name :bug-826971)
+ (let* ((foo "foo")
+ (fun (compile nil `(lambda (p1 p2)
+ (schar (the (eql ,foo) p1) p2)))))
+ (assert (eql #\f (funcall fun foo 0)))))
+
+(with-test (:name :bug-738464)
+ (multiple-value-bind (fun warn fail)
+ (compile nil `(lambda ()
+ (flet ((foo () 42))
+ (declare (ftype non-function-type foo))
+ (foo))))
+ (assert (eql 42 (funcall fun)))
+ (assert (and warn (not fail)))))
+
+(with-test (:name :bug-832005)
+ (let ((fun (compile nil `(lambda (x)
+ (declare (type (complex single-float) x))
+ (+ #C(0.0 1.0) x)))))
+ (assert (= (funcall fun #C(1.0 2.0))
+ #C(1.0 3.0)))))
+
+;; 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))))
projects / sbcl.git / blobdiff