X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=21adaf5066ca99464073dc4e6ab40312b501fc88;hb=062283b901155792f65775491aea51481c56faaa;hp=16b6e4fa61193ccce5a0e6f092f7fa2729537dc7;hpb=36717964ebcff8353035062789c08f223feccf1a;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 16b6e4f..21adaf5 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1775,7 +1775,7 @@ (error "bad RANDOM event")))) ;;; 0.8.17.28-sma.1 lost derived type information. -(with-test (:name "0.8.17.28-sma.1" :fails-on :sparc) +(with-test (:name :0.8.17.28-sma.1 :fails-on :sparc) (handler-bind ((sb-ext:compiler-note (lambda (c) (error "~A" c)))) (compile nil '(lambda (x y v) @@ -2986,8 +2986,8 @@ (compile nil `(lambda (x) (declare (character x) (optimize speed)) (,name x)))) - (dolist (name '(char= char/= char< char> char<= char>= char-equal - char-not-equal char-lessp char-greaterp char-not-greaterp + (dolist (name '(char= char/= char< char> char<= char>= + char-lessp char-greaterp char-not-greaterp char-not-lessp)) (setf current name) (compile nil `(lambda (x y) @@ -3091,7 +3091,7 @@ (array-in-bounds-p a 5 2)))))) ;;; optimizing (EXPT -1 INTEGER) -(with-test (:name (expt minus-one integer)) +(with-test (:name (expt -1 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))) @@ -4479,7 +4479,7 @@ (setf hash (logand most-positive-word (ash hash 5))))))) -(with-test (:name (local-&optional-recursive-inline :bug-1180992)) +(with-test (:name (:local-&optional-recursive-inline :bug-1180992)) (compile nil `(lambda () (labels ((called (&optional a)) @@ -4501,7 +4501,7 @@ ;; be reported as mismatches with the value NIL. Make sure we get ;; a warning, but that it doesn't complain about a constant NIL ... ;; of type FIXNUM. -(with-test (:name (:multiple-use-lvar-interpreted-as-NIL cast)) +(with-test (:name (:multiple-use-lvar-interpreted-as-NIL :cast)) (block nil (handler-bind ((sb-int:type-warning (lambda (c) @@ -4723,7 +4723,7 @@ ;; win32 is very specific about the order in which catch blocks ;; must be allocated on the stack -(with-test (:name :bug-121581169) +(with-test (:name :bug-1072739) (let ((f (compile nil `(lambda () (STRING= @@ -4771,11 +4771,7 @@ "23a%b%"))))) (assert (funcall f)))) -(defvar *global-equal-function* #'equal - "Global reference to the EQUAL function. This reference is funcalled -in order to prevent the compiler from inlining the call.") - -(defmacro equal-reduction-macro () +(with-test (:name :equal-equalp-transforms) (let* ((s "foo") (bit-vector #*11001100) (values `(nil 1 2 "test" @@ -4784,19 +4780,120 @@ in order to prevent the compiler from inlining the call.") (read-from-string "1.1") (read-from-string "1.2d0") 1.1 1.2d0 '("foo" "bar" "test") #(1 2 3 4) #*101010 (make-broadcast-stream) #p"/tmp/file" - ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector)))) + ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector) + ,(make-hash-table) #\a #\b #\A #\C + ,(make-random-state) 1/2 2/3))) ;; Test all permutations of different types - `(progn - ,@(loop - for x in values - append (loop - for y in values - collect (let ((result1-sym (gensym "RESULT1-")) - (result2-sym (gensym "RESULT2-"))) - `(let ((,result1-sym (equal ,x ,y)) - (,result2-sym (funcall *global-equal-function* ,x ,y))) - (assert (or (and ,result1-sym ,result2-sym) - (and (not ,result1-sym) (not ,result2-sym))))))))))) - -(with-test (:name :equal-reduction) - (equal-reduction-macro)) + (assert + (loop + for x in values + always (loop + for y in values + always + (and (eq (funcall (compile nil `(lambda (x y) + (equal (the ,(type-of x) x) + (the ,(type-of y) y)))) + x y) + (equal x y)) + (eq (funcall (compile nil `(lambda (x y) + (equalp (the ,(type-of x) x) + (the ,(type-of y) y)))) + x y) + (equalp x y)))))) + (assert + (funcall (compile + nil + `(lambda (x y) + (equal (the (cons (or simple-bit-vector simple-base-string)) + x) + (the (cons (or (and bit-vector (not simple-array)) + (simple-array character (*)))) + y)))) + (list (string 'list)) + (list "LIST"))) + (assert + (funcall (compile + nil + `(lambda (x y) + (equalp (the (cons (or simple-bit-vector simple-base-string)) + x) + (the (cons (or (and bit-vector (not simple-array)) + (simple-array character (*)))) + y)))) + (list (string 'list)) + (list "lisT"))))) + +(with-test (:name (restart-case optimize speed compiler-note)) + (handler-bind ((compiler-note #'error)) + (compile nil '(lambda () + (declare (optimize speed)) + (restart-case () (c ())))) + (compile nil '(lambda () + (declare (optimize speed)) + (let (x) + (restart-case (setf x (car (compute-restarts))) + (c ())) + x))))) + +(with-test (:name :copy-more-arg + :fails-on '(not (or :x86 :x86-64))) + ;; copy-more-arg might not copy in the right direction + ;; when there are more fixed args than stack frame slots, + ;; and thus end up splatting a single argument everywhere. + ;; Fixed on x86oids only, but other platforms still start + ;; their stack frames at 8 slots, so this is less likely + ;; to happen. + (let ((limit 33)) + (labels ((iota (n) + (loop for i below n collect i)) + (test-function (function skip) + ;; function should just be (subseq x skip) + (loop for i from skip below (+ skip limit) do + (let* ((values (iota i)) + (f (apply function values)) + (subseq (subseq values skip))) + (assert (equal f subseq))))) + (make-function (n) + (let ((gensyms (loop for i below n collect (gensym)))) + (compile nil `(lambda (,@gensyms &rest rest) + (declare (ignore ,@gensyms)) + rest))))) + (dotimes (i limit) + (test-function (make-function i) i))))) + +(with-test (:name :apply-aref) + (flet ((test (form) + (let (warning) + (handler-bind ((warning (lambda (c) (setf warning c)))) + (compile nil `(lambda (x y) (setf (apply #'sbit x y) 10)))) + (assert (not warning))))) + (test `(lambda (x y) (setf (apply #'aref x y) 21))) + (test `(lambda (x y) (setf (apply #'bit x y) 1))) + (test `(lambda (x y) (setf (apply #'sbit x y) 0))))) + +(with-test (:name :warn-on-the-values-constant) + (multiple-value-bind (fun warnings-p failure-p) + (compile nil + ;; The compiler used to elide this test without + ;; noting that the type demands multiple values. + '(lambda () (the (values fixnum fixnum) 1))) + (declare (ignore warnings-p)) + (assert (functionp fun)) + (assert failure-p))) + +;; quantifiers shouldn't cons themselves. +(with-test (:name :quantifiers-no-consing) + (let ((constantly-t (lambda (x) x t)) + (constantly-nil (lambda (x) x nil)) + (list (make-list 1000 :initial-element nil)) + (vector (make-array 1000 :initial-element nil))) + (macrolet ((test (quantifier) + (let ((function (make-symbol (format nil "TEST-~A" quantifier)))) + `(flet ((,function (function sequence) + (,quantifier function sequence))) + (ctu:assert-no-consing (,function constantly-t list)) + (ctu:assert-no-consing (,function constantly-nil vector)))))) + (test some) + (test every) + (test notany) + (test notevery))))