mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
492 lines
18 KiB
Common Lisp
492 lines
18 KiB
Common Lisp
;;;; miscellaneous tests of LOOP-related stuff
|
|
|
|
;;;; This software is part of the SBCL system. See the README file for
|
|
;;;; more information.
|
|
;;;;
|
|
;;;; While most of SBCL is derived from the CMU CL system, the test
|
|
;;;; files (like this one) were written from scratch after the fork
|
|
;;;; from CMU CL.
|
|
;;;;
|
|
;;;; This software is in the public domain and is provided with
|
|
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
|
;;;; more information.
|
|
|
|
;;; The bug reported by Alexei Dejneka on sbcl-devel 2001-09-03
|
|
;;; is fixed now.
|
|
(assert (equal (let ((hash (make-hash-table)))
|
|
(setf (gethash 'key1 hash) 'val1)
|
|
(setf (gethash 'key2 hash) 'val2)
|
|
(sort (loop for key being each hash-key in hash
|
|
collect key)
|
|
#'string<))
|
|
'(key1 key2)))
|
|
|
|
;;; Bug 81, reported by Wolfhard Buss on cmucl-help 2001-02-14, was
|
|
;;; fixed by Alexey Dejneka's patch on sbcl-devel 2001-09-30.
|
|
(with-test (:name :loop-destructuring-bind)
|
|
;; FIXME: should this produce a warning? I don't see why.
|
|
;; caught STYLE-WARNING:
|
|
;; This is not a FLOAT:
|
|
;; NIL
|
|
(declare (muffle-conditions style-warning))
|
|
(assert (equal '(0.0 1.0 2.0 3.0)
|
|
(loop with (a . b) of-type float = '(0.0 . 1.0)
|
|
and (c . d) of-type float = '(2.0 . 3.0)
|
|
return (list a b c d)))))
|
|
|
|
;;; a bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-05:
|
|
;;; The type declarations should apply, hence under Python's
|
|
;;; declarations-are-assertions rule, the code should signal a type
|
|
;;; error. (Except when running interpreted code)
|
|
(with-test (:name :loop-type-decl :skipped-on :interpreter)
|
|
(declare (muffle-conditions style-warning))
|
|
(assert (typep (nth-value 1
|
|
(ignore-errors
|
|
(funcall (lambda ()
|
|
(loop with (a . b)
|
|
of-type float = '(5 . 5)
|
|
return (list a b))))))
|
|
'type-error)))
|
|
|
|
;;; bug 103, reported by Arthur Lemmens sbcl-devel 2001-05-05,
|
|
;;; fixed by Alexey Dejneka patch sbcl-devel 2001-10-05:
|
|
;;; LOOP syntax requires that forms after INITIALLY, FINALLY, and DO
|
|
;;; must be compound forms.
|
|
(with-test (:name :loop-syntax-err)
|
|
(multiple-value-bind (function warnings-p failure-p)
|
|
(compile nil
|
|
'(lambda ()
|
|
(loop while t do
|
|
*print-level*
|
|
(print t))))
|
|
(declare (ignore function warnings-p))
|
|
(assert failure-p)))
|
|
|
|
;;; a bug reported by Paul F. Dietz (in his ANSI test suite):
|
|
;;; duplicate bindings in LOOP must signal errors of type
|
|
;;; PROGRAM-ERROR.
|
|
(with-test (:name :loop-duplicate-binding)
|
|
(assert (typep (nth-value 1
|
|
(ignore-errors
|
|
(funcall (lambda ()
|
|
(loop for (a . a) in '((1 . 2) (3 . 4))
|
|
return a)))))
|
|
'program-error)))
|
|
|
|
;;; similar to gcl/ansi-test LOOP.1.27, and fixed at the same time:
|
|
(assert (equal (loop for x downto 7 by 2 from 13 collect x) '(13 11 9 7)))
|
|
|
|
;;; some more from gcl/ansi-test:
|
|
(let ((table (make-hash-table)))
|
|
(setf (gethash 'foo table) '(bar baz))
|
|
(assert (= (loop for nil being the hash-keys of table count t) 1))
|
|
(assert (equal (loop for nil being the hash-keys of table
|
|
using (hash-value (v1 . v2))
|
|
when v1
|
|
return v2)
|
|
'(baz))))
|
|
|
|
(assert (= (loop for nil being the external-symbols of :cl count t) 978))
|
|
(assert (= (loop for x being the external-symbols of :cl count x) 977))
|
|
|
|
(let ((cl:*package* (find-package :cl)))
|
|
(assert (= (loop for x being each external-symbol count t) 978)))
|
|
|
|
(assert (eq (loop for a = (return t) return nil) t))
|
|
|
|
(multiple-value-bind (result error)
|
|
(ignore-errors
|
|
(loop for nil being the external-symbols of :nonexistent-package
|
|
count t))
|
|
(assert (null result))
|
|
(assert (typep error 'package-error)))
|
|
|
|
(assert (equal (loop for i from 1 repeat (the (integer 7 7) 7) collect i)
|
|
'(1 2 3 4 5 6 7)))
|
|
|
|
(multiple-value-bind (result error)
|
|
(ignore-errors
|
|
(eval '(loop for i from 1 repeat 7 of-type fixnum collect i)))
|
|
(assert (null result))
|
|
(assert (typep error 'program-error)))
|
|
|
|
(assert (equal
|
|
(ignore-errors (loop for i from 1 repeat 6.5 collect i))
|
|
(ignore-errors (loop for i from 1 repeat (eval '6.5) collect i))))
|
|
|
|
(assert (eq (block nil
|
|
(loop named foo do (loop-finish) finally (return :good))
|
|
:bad)
|
|
:good))
|
|
|
|
(assert (= (loop with (a nil) = '(1 2) return a) 1))
|
|
(assert (= (loop with (nil a) = '(1 2) return a) 2))
|
|
(assert (= (loop with (a . nil) = '(1 2) return a) 1))
|
|
(assert (equal (loop with (nil . a) = '(1 2) return a) '(2)))
|
|
|
|
(with-test (:name :loop-invalid-collector-1)
|
|
(multiple-value-bind (result error)
|
|
(ignore-errors
|
|
(loop for i in '(1 2 3) collect i always (< i 4)))
|
|
(assert (null result))
|
|
(assert (typep error 'program-error))))
|
|
(with-test (:name :loop-invalid-collector-2)
|
|
(assert (equal
|
|
(loop for i in '(1 2 3) collect i into foo always (< i 4)
|
|
finally (return foo))
|
|
'(1 2 3))))
|
|
(with-test (:name :loop-invalid-collector-3)
|
|
(assert (equal
|
|
(loop for i in '(1 2 3) collect i into foo always (= i 4)
|
|
finally (return foo))
|
|
nil)))
|
|
(with-test (:name :loop-invalid-collector-4)
|
|
(multiple-value-bind (result error)
|
|
(ignore-errors
|
|
(loop for i in '(1 2 3) always (< i 4) collect i))
|
|
(assert (null result))
|
|
(assert (typep error 'program-error))))
|
|
(assert (equal
|
|
(loop for i in '(1 2 3) always (< i 4) collect i into foo
|
|
finally (return foo))
|
|
'(1 2 3)))
|
|
(assert (equal
|
|
(loop for i in '(1 2 3) always (= i 4) collect i into foo
|
|
finally (return foo))
|
|
nil))
|
|
(with-test (:name :loop-invalid-collector-5)
|
|
(multiple-value-bind (result error)
|
|
(ignore-errors
|
|
(loop for i in '(1 2 3) thereis (= i 3) collect i))
|
|
(assert (null result))
|
|
(assert (typep error 'program-error))))
|
|
|
|
(with-test (:name :loop-invalid-collector-6)
|
|
(multiple-value-bind (result error)
|
|
(ignore-errors
|
|
(loop with i = 1 for x from 1 to 3 collect x into i))
|
|
(assert (null result))
|
|
(assert (typep error 'program-error))))
|
|
(with-test (:name :loop-invalid-collector-7)
|
|
(multiple-value-bind (result error)
|
|
;; this one has a plausible interpretation in terms of LET*, but
|
|
;; ANSI seems specifically to disallow it
|
|
(ignore-errors
|
|
(loop with i = 1 with i = (1+ i)
|
|
for x from 1 to 3
|
|
collect (+ x i)))
|
|
(assert (null result))
|
|
(assert (typep error 'program-error))))
|
|
|
|
(let ((it 'z))
|
|
(assert (equal
|
|
;; this one just seems weird. Nevertheless...
|
|
(loop for i in '(a b c d)
|
|
when i
|
|
collect it
|
|
and collect it)
|
|
'(a z b z c z d z))))
|
|
|
|
(let ((ht (make-hash-table)))
|
|
(setf (gethash 1 ht) 3)
|
|
(setf (gethash 7 ht) 15)
|
|
(assert (= (loop for v fixnum being each hash-key in ht sum v) 8))
|
|
(assert (= (loop for v fixnum being each hash-value in ht sum v) 18))
|
|
#-interpreter
|
|
(assert-error (loop for v float being each hash-value in ht sum v)
|
|
type-error))
|
|
|
|
;; arithmetic indexes can be NIL or symbols.
|
|
(with-test (:name :loop-anonymous-arithmetic-index)
|
|
;; FIXME: these produce style-warnings. If they're acceptable, they should not warn.
|
|
(declare (muffle-conditions style-warning))
|
|
(assert (equal (loop for nil from 0 to 2 collect nil)
|
|
'(nil nil nil)))
|
|
(assert (equal (loop for nil to 2 collect nil)
|
|
'(nil nil nil))))
|
|
|
|
;; although allowed by the loop syntax definition in 6.2/LOOP,
|
|
;; 6.1.2.1.1 says: "The variable var is bound to the value of form1 in
|
|
;; the first iteration[...]"; since we can't bind (i j) to anything,
|
|
;; we give a program error.
|
|
(with-test (:name :statically-observable-destructuring-problem-1)
|
|
(multiple-value-bind (function warnings-p failure-p)
|
|
(compile nil
|
|
`(lambda ()
|
|
(loop for (i j) from 4 to 6 collect nil)))
|
|
(declare (ignore function warnings-p))
|
|
(assert failure-p)))
|
|
|
|
;; ...and another for indexes without FROM forms (these are treated
|
|
;; differently by the loop code right now
|
|
(with-test (:name :statically-observable-destructuring-problem-2)
|
|
(multiple-value-bind (function warnings-p failure-p)
|
|
(compile nil
|
|
`(lambda ()
|
|
(loop for (i j) to 6 collect nil)))
|
|
(declare (ignore function warnings-p))
|
|
(assert failure-p)))
|
|
|
|
(assert
|
|
(equal
|
|
(let ((x 2d0))
|
|
(loop for d of-type double-float from 0d0 to 10d0 by x collect d))
|
|
'(0d0 2d0 4d0 6d0 8d0 10d0)))
|
|
(assert
|
|
(equal
|
|
(let ((x 2d0))
|
|
(loop for d of-type double-float downfrom 10d0 to 0d0 by x collect d))
|
|
'(10d0 8d0 6d0 4d0 2d0 0d0)))
|
|
|
|
(let ((fn (handler-case
|
|
(compile nil '(lambda ()
|
|
(declare (special x y))
|
|
(loop thereis (pop x) thereis (pop y))))
|
|
(warning (c) (error "Warned: ~S" c)))))
|
|
(let ((x (list nil nil 1))
|
|
(y (list nil 2 nil)))
|
|
(declare (special x y))
|
|
(assert (= (funcall fn) 2))))
|
|
|
|
;;; Incorrect LIST type declaration, reported and patched by Teemu
|
|
;;; Kalvas: end testing is done "as if by atom" so this is supposed
|
|
;;; to work.
|
|
(assert (equal '(1 2) (loop for (a . b) on '(1 2 . 3) collect a)))
|
|
|
|
;;; Detection of duplicate bindings, reported by Bruno Haible for CMUCL.
|
|
(multiple-value-bind (_ condition)
|
|
(ignore-errors
|
|
(macroexpand '(LOOP WITH A = 0 FOR A DOWNFROM 10 TO 0 DO (PRINT A))))
|
|
(declare (ignore _))
|
|
(assert (typep condition 'program-error)))
|
|
|
|
;;; Loop variable with a range excluding 0, reported by Andras Simon.
|
|
;;; (Used to signal an error during macroexpansion.)
|
|
(with-test (:name :loop-var-range-excludes-zero)
|
|
(assert (not (loop with foo of-type (single-float 1.0 2.0) = 1.5
|
|
do (progn foo (return))))))
|
|
|
|
;;; 1.0.26.12 used to signal a bogus type error for this.
|
|
(loop with x of-type (simple-vector 1) = (make-array '(1))
|
|
repeat 1
|
|
return x)
|
|
|
|
(with-test (:name :bug-540186)
|
|
(let ((fun (compile nil `(lambda (x)
|
|
(loop for i from 0 below (length x)
|
|
for vec of-type vector = (aref x i)
|
|
collect vec)))))
|
|
(assert (equal '("foo" "bar")
|
|
(funcall fun
|
|
(vector "foo" "bar"))))))
|
|
|
|
(with-test (:name :bug-lp613871)
|
|
(multiple-value-bind (function warnings-p failure-p)
|
|
(compile nil '(lambda () (loop with nil = 1 repeat 2 collect t)))
|
|
(assert (null warnings-p))
|
|
(assert (null failure-p))
|
|
(assert (equal '(t t) (funcall function))))
|
|
(multiple-value-bind (function warnings-p failure-p)
|
|
(compile nil '(lambda () (loop with nil repeat 2 collect t)))
|
|
(assert (null warnings-p))
|
|
(assert (null failure-p))
|
|
(assert (equal '(t t) (funcall function)))))
|
|
|
|
(with-test (:name :bug-654220-regression)
|
|
(assert (= 32640 (loop for i to 255
|
|
sum i into sum of-type fixnum
|
|
finally (return sum)))))
|
|
|
|
(with-test (:name :of-type-character-init)
|
|
;; The intention here is to if we initialize C to NIL before iteration start
|
|
;; by looking for tell-tale types such as (OR NULL CHARACTER). ...not the
|
|
;; most robust test ever, no.
|
|
(let* ((fun (compile nil `(lambda (x)
|
|
(loop for c of-type character in x
|
|
collect (char-code c)))))
|
|
(consts (ctu:find-code-constants fun :type '(or symbol list))))
|
|
(assert (or (null consts) (equal 'character consts)))))
|
|
|
|
(with-test (:name :type-of-nilled-vars)
|
|
(assert (equal (loop for (a b) float = '(1.0 2.0)
|
|
return (list a b))
|
|
'(1.0 2.0)))
|
|
(assert (equal (loop for (a nil b) float = '(1.0 3.0 2.0)
|
|
return (list a b))
|
|
'(1.0 2.0))))
|
|
|
|
(with-test (:name :misplaced-declarations)
|
|
(assert-no-signal
|
|
(compile nil `(lambda ()
|
|
(loop with (a) = '(1.0)
|
|
and (nil f)
|
|
return (list a f))))
|
|
warning))
|
|
|
|
(with-test (:name :duplicate-bindings)
|
|
(assert-error
|
|
(funcall (compile nil `(lambda ()
|
|
(loop with (a b) = '(1.0 2.0)
|
|
and (c a) = '(3.0 4.0)
|
|
return (list a b c))))))
|
|
(assert-error
|
|
(funcall (compile nil `(lambda ()
|
|
(loop with a = 10
|
|
with ((a) b) = '((1.0) 2.0)
|
|
return (list a b))))))
|
|
(assert-error
|
|
(funcall (compile nil `(lambda ()
|
|
(loop with (b) = '(10)
|
|
with (a) = '(3)
|
|
for b to 10
|
|
collect a)))))
|
|
(assert-error
|
|
(funcall (compile nil `(lambda ()
|
|
(loop with (a) = '(3)
|
|
for b to 10
|
|
collect a into b))))))
|
|
|
|
(with-test (:name :multiple-maximize)
|
|
(assert-no-signal
|
|
(compile nil `(lambda ()
|
|
(loop for x to 10 maximize x minimize x)))
|
|
warning)
|
|
(assert-no-signal
|
|
(compile nil `(lambda ()
|
|
(loop for x to 10 minimize x minimize x)))
|
|
warning)
|
|
(assert-no-signal
|
|
(compile nil `(lambda ()
|
|
(loop for x to 10 minimize x into z minimize x into z finally (return z))))
|
|
warning))
|
|
|
|
(with-test (:name :destructuring-less)
|
|
(assert (equal (loop with (a b) = '() repeat 1 collect (list a b))
|
|
'((NIL NIL)))))
|
|
|
|
(with-test (:name :count-with-sum)
|
|
(assert (= (loop repeat 1 count 1 sum #c(1 2))
|
|
#c(2 2)))
|
|
(assert (= (loop repeat 1 sum 1 count 1)
|
|
2)))
|
|
|
|
(with-test (:name :iterate-over-complex)
|
|
(assert
|
|
(equal
|
|
(loop for c from #c(0 1) repeat 5 collect c)
|
|
'(#C(0 1) #C(1 1) #C(2 1) #C(3 1) #C(4 1)))))
|
|
|
|
(with-test (:name :side-effecting-start-form)
|
|
(assert (equal (let ((n 0))
|
|
(loop for x from (incf n) to (+ n 5) collect x))
|
|
'(1 2 3 4 5 6))))
|
|
|
|
(with-test (:name :summing-complex)
|
|
(assert (equal (loop for i from 1 to 4
|
|
sum (complex i (1+ i)) of-type complex)
|
|
#c(10 14))))
|
|
|
|
(with-test (:name :negative-repeat)
|
|
(assert (zerop (let ((z 0))
|
|
(loop repeat 0 do (incf z))
|
|
z)))
|
|
(assert (zerop (let ((z 0))
|
|
(loop repeat -1.5 do (incf z))
|
|
z)))
|
|
(assert (zerop (let ((z 0))
|
|
(loop repeat -1.5 do (incf z))
|
|
z)))
|
|
(assert (zerop (let ((z 0))
|
|
(loop repeat -1000000 do (incf z))
|
|
z))))
|
|
|
|
(with-test (:name :of-type-character)
|
|
(assert (null (loop with a t return a)))
|
|
#+sb-unicode
|
|
(assert (typep (loop with a of-type extended-char return a) 'extended-char))
|
|
(assert (typep (loop with a of-type character return a) 'character))
|
|
(assert (typep (loop with a of-type base-char return a) 'base-char))
|
|
(assert (typep (loop with a of-type standard-char return a) 'standard-char)))
|
|
|
|
(with-test (:name :empty-type)
|
|
(assert-signal
|
|
(compile nil `(lambda ()
|
|
(loop with a of-type (and fixnum string) return a)))
|
|
warning)
|
|
(assert-signal
|
|
(compile nil `(lambda ()
|
|
(loop for i to 10 sum i of-type (and fixnum string))))
|
|
warning))
|
|
|
|
(with-test (:name :loop-repeat-const)
|
|
;; without explicit constant-folding in LOOP-DO-REPEAT, the type of this loop's
|
|
;; counter is INTEGER which unfortunately resulted in generic math throughout,
|
|
;; since a FOR/THEN clause interacts badly with type inference.
|
|
;; [if there is no FOR/THEN, the compiler understands the code better,
|
|
;; and is able to infer a lower bound on decrementing from (+ 1 5)]
|
|
(assert-no-signal
|
|
(compile nil '(lambda ()
|
|
(declare (optimize speed))
|
|
(loop for baz = 'this then 'that repeat (+ 1 5)
|
|
do (print baz))))))
|
|
|
|
(with-test (:name :loop-default-init-type)
|
|
(assert-no-signal (compile nil
|
|
'(lambda (list)
|
|
(declare (optimize speed))
|
|
(loop for a of-type (simple-vector 4) in list
|
|
collect (aref a 2))))
|
|
sb-ext:compiler-note))
|
|
|
|
(with-test (:name :with-destructuring)
|
|
(declare (muffle-conditions style-warning)) ; why?
|
|
(assert (= (loop with ((a . b)) = '((1 . 2))
|
|
return (+ a b))
|
|
3))
|
|
(assert (= (loop with (((a) b)) = '(((1) 3))
|
|
return (+ a b))
|
|
4)))
|
|
|
|
(with-test (:name :destructuring-m-v-list :skipped-on :interpreter)
|
|
(flet ((f (n-iter)
|
|
(loop for i from 0 below n-iter
|
|
for (a b) = (multiple-value-list (floor i 5))
|
|
sum (+ a b))))
|
|
(ctu:assert-no-consing (f 1000))))
|
|
|
|
(with-test (:name :destructuring-m-v-list-with-nil)
|
|
(assert (equal-mod-gensyms
|
|
(macroexpand-1 '(sb-loop::loop-desetq (x nil z) (multiple-value-list (foo))))
|
|
'(multiple-value-bind (g1 g2 g3) (foo)
|
|
(declare (ignore g2))
|
|
(sb-loop::loop-desetq x g1)
|
|
(sb-loop::loop-desetq z g3)))))
|
|
|
|
(with-test (:name :collect-list-type)
|
|
(assert
|
|
(equal (third (sb-kernel:%simple-fun-type
|
|
(checked-compile
|
|
'(lambda (l)
|
|
(loop for x in l
|
|
collect x into m
|
|
finally (return m))))))
|
|
'(values list &optional)))
|
|
(assert
|
|
(equal (third (sb-kernel:%simple-fun-type
|
|
(checked-compile
|
|
'(lambda (l)
|
|
(loop for x in l
|
|
collect x)))))
|
|
'(values list &optional))))
|
|
|
|
|
|
(with-test (:name :loop-in-reverse-by-cddr)
|
|
(checked-compile-and-assert
|
|
(:optimize nil)
|
|
`(lambda (l)
|
|
(loop for x in (reverse l) by #'cddr collect x))
|
|
(('(1)) '(1) :test #'equal)
|
|
(('(1 2)) '(2) :test #'equal)
|
|
(('(1 2 3)) '(3 1) :test #'equal)
|
|
(('(1 2 3 4)) '(4 2) :test #'equal)))
|