blob: 1e9da832083e8b8f5ebef1485200ccd1dda3bbb1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
commit 8582c68d127b0127f15e1a7f74265e3c0e9f3d87
Author: Shiro Kawai <shiro@acm.org>
Date: Tue Dec 22 10:34:09 2020 -1000
Incorporate upstream fixes
https://github.com/scheme-requests-for-implementation/srfi-134/commit/2bfd4b585c8140c25f4fdd9adef84ab3ceca67b3
diff --git a/lib/data/ideque.scm b/lib/data/ideque.scm
index 484ca52b4..e4894e2d0 100644
--- a/lib/data/ideque.scm
+++ b/lib/data/ideque.scm
@@ -231,12 +231,12 @@
(define (%ideque-drop dq n) ; n is within the range
(match-let1 ($ <ideque> lenf f lenr r) dq
(if (<= n lenf)
- (check n (drop f n) lenr r)
+ (check (- lenf n) (drop f n) lenr r)
(let1 lenr. (- lenr (- n lenf))
(check 0 '() lenr. (take r lenr.))))))
(define (%check-length dq n)
- (unless (<= 0 n (- (ideque-length dq) 1))
+ (unless (<= 0 n (ideque-length dq))
(error "argument is out of range:" n)))
;; API [srfi-134]
diff --git a/test/include/ideque-tests.scm b/test/include/ideque-tests.scm
index 63f3f73a0..5e4c9e023 100644
--- a/test/include/ideque-tests.scm
+++ b/test/include/ideque-tests.scm
@@ -50,6 +50,12 @@
(test-assert (ideque-empty? (ideque-remove-back (ideque 1))))
(test 0 (ideque-front (ideque-add-front (ideque 1 2 3) 0)))
(test 0 (ideque-back (ideque-add-back (ideque 1 2 3) 0)))
+ ;; loss of front ideque
+ (let ((id (ideque #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)))
+ (set! id (ideque-remove-front (ideque-add-back id 1)))
+ (set! id (ideque-remove-front (ideque-add-back id 1)))
+ (set! id (ideque-remove-front (ideque-add-back id 1)))
+ (test #f (ideque-front (ideque-take-right id 12))))
)
(test-group "ideque/other-accessors"
@@ -63,7 +69,11 @@
(map ideque->list xs))))
lis)))
(check 'ideque-take ideque-take take 7)
+ (test '(1 2 3 4) (ideque->list (ideque-take (ideque 1 2 3 4) 4)))
+ (test '(1 2 3 4) (ideque->list (ideque-take-right (ideque 1 2 3 4) 4)))
(check 'ideque-drop ideque-drop drop 6)
+ (test '() (ideque->list (ideque-drop (ideque 1 2 3 4) 4)))
+ (test '() (ideque->list (ideque-drop-right (ideque 1 2 3 4) 4)))
(check 'ideque-split-at ideque-split-at split-at 8)
;; out-of-range conditions
(test-error (ideque->list (ideque-take (ideque 1 2 3 4 5 6 7) 10)))
|
GitWeb
