mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
619 lines
20 KiB
Common Lisp
619 lines
20 KiB
Common Lisp
(enable-test-parallelism)
|
|
|
|
(with-test (:name (make-array :bad-initial-contents))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda () (make-array '(1) :initial-contents 'foo))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name (make-string-output-stream :bad-element-type))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(make-string-output-stream :element-type '((x))))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name (coerce :bad-type-specifier))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda () (coerce (list 2) 1))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :zombie-entry-point-reference)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda () (labels ((%f ())) (%f #'%f)))
|
|
:allow-warnings t))))
|
|
(with-test (:name :ir1-optimize-combination-dead-node)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(flet ((%f2 (x) x))
|
|
(list (%f2 1)
|
|
(multiple-value-call #'%f2 (values)))))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name (:bogus-block &key))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile `(lambda (&key (x (block 1 10))) x)
|
|
:allow-failure t))))
|
|
|
|
(with-test (:name :type-error-reporting)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile `(lambda ()
|
|
(lambda ()
|
|
(let ((v3 0))
|
|
(cdr (1- (block b5 (if nil v3 0)))))))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :dx-on-deleted-nodes)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile `(lambda ()
|
|
(restart-bind ((1 3))))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :transform-call-dfo-consistency)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(flet ((%f (&optional x) x))
|
|
(%f)
|
|
;; Two of the %f calls are erroneous, with an extra argument
|
|
(flet ((%f6 (&key (k (%f (%f -1 (%f -2 -3))))) 0))
|
|
5)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :&aux-check-variable-names)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda (&aux (nil 10))
|
|
nil)
|
|
:allow-failure t))))
|
|
|
|
(with-test (:name :mv-call-too-many-values)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda (a)
|
|
(flet ((%f1 (x) x))
|
|
(apply #'%f1 a 2 (list 0))))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :mv-call-too-many-values.closure)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda (a b)
|
|
(flet ((%f1 () b))
|
|
(apply #'%f1 a 2 (list 0))))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name (map :values-type))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(map '* #'+ #(1) #(2)))
|
|
:allow-warnings t))))
|
|
|
|
|
|
(with-test (:name :bad-type-specifier)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(make-array 10 :element-type '((x))))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name (make-array :bad-dimensions))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(make-array '(x)))
|
|
:allow-warnings t)))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(make-array '(-10)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name (make-array :bad-dimensions.2))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(make-array '(0 . 2)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name (make-array :bad-dimensions.3))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(make-array '(0 . 2)
|
|
:element-type 'fixnum
|
|
:adjustable t))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name (make-array :bad-dimensions.4))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(make-array (list 'x)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name (make-array :initial-contents :bad-macro))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(make-array '(10) :initial-contents (do)))
|
|
:allow-failure t))))
|
|
|
|
(with-test (:name (make-array :dimensions :bad-macro))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(make-array (do)))
|
|
:allow-failure t))))
|
|
|
|
(with-test (:name (make-array :dimensions :bad-propagated-value))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(let ((x '(("foo"))))
|
|
(make-array (list x) :fill-pointer 0)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name (make-array :dimensions :unraveling-list))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda (x)
|
|
(make-array (list (list 10)) :adjustable x))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :&rest-ref-bad-n)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda (&rest a) (lambda () (nth nil a)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :bad-type-specifier-handling)
|
|
(multiple-value-bind (fun failure warnings)
|
|
(checked-compile
|
|
`(lambda (v) (typep v '(unsigned-byte 8 x (error ~s v))))
|
|
:allow-warnings t)
|
|
(declare (ignore fun))
|
|
(assert failure)
|
|
(mapcar #'princ-to-string warnings)))
|
|
|
|
(with-test (:name :ldb-transform-macroexpand)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda () (ldb (do) 0))
|
|
:allow-failure t))))
|
|
|
|
(with-test (:name :bad-values-ftype)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda () (declare (values 0)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :bad-progv)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda (x) (progv x 1))
|
|
:allow-warnings t)))
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda (x) (progv 1 x))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :coerce-to-nil)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
'(lambda () (coerce (list t) nil))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :unknown-vector-type-conflict)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
'(lambda () (the (vector nonsense-type) nil))
|
|
:allow-warnings t
|
|
:allow-style-warnings t))))
|
|
|
|
(with-test (:name :subseq-unknown-vector-type)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
'(lambda () (subseq (the (vector nonsense-type) :x) 0 1))
|
|
:allow-warnings t
|
|
:allow-style-warnings t))))
|
|
(with-test (:name :derive-node-type-unknown-type)
|
|
(assert
|
|
(nth-value 3
|
|
(checked-compile
|
|
'(lambda (x)
|
|
(let ((k (make-array 8 :element-type '(unsigned-byte 8))))
|
|
(setf (aref k 0) (the unknown-type (the integer x)))
|
|
(setf k (subseq "y" 0))))
|
|
:allow-warnings t
|
|
:allow-style-warnings t))))
|
|
|
|
(with-test (:name :highly-nested-type-error)
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(macrolet ((macro ()
|
|
`((lambda (x)
|
|
(declare (number x))
|
|
',@ (loop repeat 10000
|
|
for cons = (list 1) then (list cons)
|
|
finally (return cons)))
|
|
t)))
|
|
(macro)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :complex-member-type)
|
|
(assert (= (length (nth-value 2
|
|
(checked-compile
|
|
`(lambda (x)
|
|
(typep x '(complex (eql t))))
|
|
:allow-warnings t)))
|
|
1)))
|
|
|
|
(with-test (:name :bad-optionals)
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
'(lambda (z)
|
|
(lambda (&optional (a nil x))
|
|
(declare (type integer x))
|
|
z))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :recursive-delete-lambda)
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
'(lambda ()
|
|
(flet ((%f ()
|
|
(lambda ())))
|
|
(%f :a)
|
|
(%f :b)))
|
|
:allow-warnings t)))
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
'(lambda ()
|
|
(flet ((%f ()
|
|
(lambda (&optional m) m)))
|
|
(%f :a)
|
|
(%f :b)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :complex-number)
|
|
(checked-compile-and-assert
|
|
()
|
|
'(lambda (x)
|
|
(typep 1 x))
|
|
(('(complex number)) (condition 'error))))
|
|
|
|
(with-test (:name :aref-type-mismatch)
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
`(lambda (x)
|
|
(svref x *break-on-signals*))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :unknown-keys-propagation-error-checking.1)
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
`(lambda (x)
|
|
(let ((a :tests))
|
|
(find 1 x a #'eql)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :unknown-keys-propagation-error-checking.2)
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
`(lambda ()
|
|
(apply 'find '(3 (1 2 3) :bad t)))
|
|
:allow-warnings t))))
|
|
|
|
|
|
(with-test (:name :sequence-lvar-dimensions-dotted-list)
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
'(lambda () (position 0 '(1 2 0 5 . 5)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :source-form-context-dotted-list)
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
'(lambda (y) `(defines ,@ (and x) . ,y))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :typep-transform-dotted-list)
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
'(lambda (x) (typep x (quote . z)))
|
|
:allow-failure t))))
|
|
|
|
(with-test (:name :member-transform-dotted-list)
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
'(lambda (x) (member x '(a . b)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :encode-universal-time)
|
|
(assert (nth-value 3
|
|
(checked-compile
|
|
'(lambda () (encode-universal-time 0 0 0 1 1 1900 -1))
|
|
:allow-style-warnings t))))
|
|
|
|
(with-test (:name :search-transform-bad-index)
|
|
(checked-compile
|
|
'(lambda (a)
|
|
(search '(0 1 0 2) a :start1 4 :end1 5))))
|
|
|
|
(with-test (:name :bound-mismatch-union-types)
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
'(lambda (x)
|
|
(declare ((or (simple-string 10) (simple-string 15)) x))
|
|
(aref x 100))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :uses-with-bad-types)
|
|
(assert (nth-value 3
|
|
(checked-compile
|
|
'(lambda (x)
|
|
(the integer (if x 10)))
|
|
:allow-style-warnings t))))
|
|
|
|
(with-test (:name :constant-modification-local-function)
|
|
(assert (= (length (nth-value 2
|
|
(checked-compile
|
|
'(lambda ()
|
|
(flet ((z (a)
|
|
(setf (aref a 0) 10)))
|
|
(z #(10))
|
|
(z #(a))))
|
|
:allow-warnings t)))
|
|
2)))
|
|
|
|
(with-test (:name :improper-list)
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
'(lambda (x) (concatenate 'string x '(#\a . #\b)))
|
|
:allow-warnings t)))
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
'(lambda (x) (concatenate 'list x '(1 2 . 3)))
|
|
:allow-warnings t)))
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
'(lambda (x) (concatenate 'vector x '(1 2 . 3)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :improper-list.2)
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
'(lambda ()
|
|
(member-if #'(lambda (x) (evenp x)) '(1 2 3 . 4)))
|
|
:allow-warnings t)))
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
'(lambda (x)
|
|
(search '(a . b) x))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :improper-list.3)
|
|
(assert (nth-value 1
|
|
(checked-compile
|
|
'(lambda ()
|
|
(let ((x '(1 2 . 3)))
|
|
(position c x)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :call-nil)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda ()
|
|
(funcall nil))
|
|
(() (condition 'undefined-function)))
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (x)
|
|
(if x
|
|
10
|
|
(funcall x)))
|
|
((nil) (condition 'undefined-function))))
|
|
|
|
(with-test (:name (:valid-callable-argument :toplevel-xep))
|
|
(assert (nth-value 2 (checked-compile `(lambda (l) (find-if (lambda ()) l))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name (:valid-callable-argument :handler-bind))
|
|
(assert (nth-value 2 (checked-compile
|
|
`(lambda (l) (handler-bind ((error (lambda ()))) (funcall l)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name (:valid-callable-argument :closure))
|
|
(assert (nth-value 2 (checked-compile
|
|
`(lambda (l) (the (function (t)) (lambda () l)))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :bad-macros)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda () (coerce 'integer (restart-bind foo)))
|
|
:allow-failure t))))
|
|
|
|
(with-test (:name :bad-funcall-macros)
|
|
(assert
|
|
(nth-value 1
|
|
(checked-compile
|
|
`(lambda () (funcall (lambda)))
|
|
:allow-failure t))))
|
|
|
|
(with-test (:name :inlining-bad-code)
|
|
(assert
|
|
(nth-value 2
|
|
(checked-compile
|
|
`(lambda (x &rest args)
|
|
(unless
|
|
(if (eq x :tud)
|
|
(zerop (first args))
|
|
(every #'identity args (every #'identity args)))
|
|
args))
|
|
:allow-style-warnings t
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :keyword-type-checking)
|
|
(assert
|
|
(nth-value 2
|
|
(checked-compile
|
|
`(lambda (x)
|
|
(make-array 10 (list x) x))
|
|
:allow-warnings t))))
|
|
|
|
(with-test (:name :unused-local-functions)
|
|
(labels ((find-note (x)
|
|
(loop for note in (nth-value 4 (checked-compile x))
|
|
thereis (and (typep note 'sb-ext:code-deletion-note)
|
|
(eql (search "deleting unused function"
|
|
(princ-to-string note))
|
|
0))))
|
|
(check (f)
|
|
(assert (find-note `(lambda () (flet (,f)))))
|
|
(assert (not (find-note `(lambda (x)
|
|
(flet (,f)
|
|
(and x (not x) (f)))))))))
|
|
(check '(f ()))
|
|
(check '(f (&key)))
|
|
(check '(f (&key k) k))
|
|
(check '(f (&rest args) args))
|
|
(check '(f (&optional o) o))
|
|
(check '(f (&optional)))))
|
|
|
|
(with-test (:name :calling-ignored-local)
|
|
(assert
|
|
(nth-value 3
|
|
(checked-compile
|
|
`(lambda ()
|
|
(flet ((f ()))
|
|
(declare (ignore #'f))
|
|
(f)))
|
|
:allow-style-warnings t))))
|
|
|
|
(with-test (:name :inappropriate-declare)
|
|
(assert
|
|
(nth-value 5
|
|
(checked-compile
|
|
`(lambda (x y) (print-unreadable-object (x y) (declare (optimize))))
|
|
:allow-failure t)))
|
|
(assert
|
|
(nth-value 5
|
|
(checked-compile
|
|
`(lambda () (restart-bind () (declare (optimize)) 42))
|
|
:allow-failure t)))
|
|
(assert
|
|
(nth-value 5
|
|
(checked-compile
|
|
`(lambda () (prog1 10 (declare (optimize))))
|
|
:allow-failure t))))
|
|
|
|
(with-test (:name :reduce-initial-value)
|
|
(assert
|
|
(nth-value 2
|
|
(checked-compile
|
|
`(lambda ()
|
|
(reduce (lambda (x y)
|
|
(declare (fixnum x))
|
|
(+ x (char-code y)))
|
|
"abc"))
|
|
:allow-warnings t)))
|
|
(assert
|
|
(nth-value 2
|
|
(checked-compile
|
|
`(lambda ()
|
|
(reduce (lambda (x y)
|
|
(declare (fixnum x))
|
|
(+ x (char-code y)))
|
|
"abc"
|
|
:initial-value #\a))
|
|
:allow-warnings t)))
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (s)
|
|
(declare (string s))
|
|
(reduce (lambda (x y)
|
|
(declare (fixnum x))
|
|
(+ x (char-code y)))
|
|
s
|
|
:initial-value 0))
|
|
(("abc") 294)))
|
|
|
|
(with-test (:name :get-defined-fun-lambda-list-error)
|
|
(assert (nth-value 1 (checked-compile '(lambda () (defun x 10)) :allow-failure t))))
|
|
|
|
(with-test (:name :dolist-mismatch)
|
|
(assert (nth-value 2
|
|
(checked-compile '(lambda (x)
|
|
(dolist (x (the integer x))))
|
|
:allow-warnings 'sb-int:type-warning))))
|
|
|
|
(with-test (:name :loop-list-mismatch)
|
|
(assert (nth-value 2
|
|
(checked-compile '(lambda (x)
|
|
(loop for y in (the integer x)))
|
|
:allow-warnings 'sb-int:type-warning)))
|
|
(assert (nth-value 2
|
|
(checked-compile '(lambda (x)
|
|
(loop for y on (the integer x)))
|
|
:allow-warnings 'sb-int:type-warning))))
|
|
|
|
(with-test (:name :mapcar-list-mismatch)
|
|
(assert (nth-value 2
|
|
(checked-compile '(lambda (z)
|
|
(mapl #'car (the integer z)))
|
|
:allow-warnings 'sb-int:type-warning)))
|
|
(assert (nth-value 2
|
|
(checked-compile '(lambda (f z x)
|
|
(mapcar f (the integer z) (the integer x)))
|
|
:allow-warnings 'sb-int:type-warning))))
|
|
|
|
(with-test (:name :aref-too-many-subscripts)
|
|
(assert (nth-value 2
|
|
(checked-compile `(lambda (a) (aref a ,@(loop repeat array-rank-limit collect 0)))
|
|
:allow-warnings 'warning))))
|
|
|
|
(with-test (:name :defclass-bad-type)
|
|
(assert (nth-value 2
|
|
(checked-compile
|
|
`(lambda () (defclass ,(gensym) () ((s :type (2)))))
|
|
:allow-warnings 'warning))))
|