Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Fix interval iteration for empty intervals.

Browse source 
Closes #959.
This commit is contained in:
Alex Shinn 2024-05-24 22:29:44 +09:00
parent 0ce4614457
commit 89dd02d55e
2 changed files with 27 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
lib/srfi/231/base.scm
View file

@ -179,23 +179,27 @@
((>= j end1) acc)))) ((>= j end1) acc))))
((>= i end0) acc)))) ((>= i end0) acc))))
(else (else
(let ((ivc (interval-cursor iv))) (if (interval-empty? iv)
(let lp ((acc knil)) knil
(let ((acc (kons acc (apply f (interval-cursor-get ivc))))) (let ((ivc (interval-cursor iv)))
(if (interval-cursor-next! ivc) (let lp ((acc knil))
(lp acc) (let ((acc (kons acc (apply f (interval-cursor-get ivc)))))
acc))))))) (if (interval-cursor-next! ivc)
(lp acc)
acc))))))))
(define (interval-fold kons knil iv) (define (interval-fold kons knil iv)
(interval-fold-left list (lambda (acc idx) (apply kons acc idx)) knil iv)) (interval-fold-left list (lambda (acc idx) (apply kons acc idx)) knil iv))
(define (interval-fold-right f kons knil iv) (define (interval-fold-right f kons knil iv)
(let ((ivc (interval-cursor iv))) (if (interval-empty? iv)
(let lp () knil
(let ((item (apply f (interval-cursor-get ivc)))) (let ((ivc (interval-cursor iv)))
(if (interval-cursor-next! ivc) (let lp ()
(kons item (lp)) (let ((item (apply f (interval-cursor-get ivc))))
(kons item knil)))))) (if (interval-cursor-next! ivc)
(kons item (lp))
(kons item knil)))))))
(define (interval-for-each f iv) (define (interval-for-each f iv)
(interval-fold (lambda (acc . multi-index) (apply f multi-index)) #f iv) (interval-fold (lambda (acc . multi-index) (apply f multi-index)) #f iv)

11
lib/srfi/231/test.sld
View file

@ -1142,6 +1142,13 @@
(test-error (interval-for-each (lambda (x) x) 1)) (test-error (interval-for-each (lambda (x) x) 1))
(test-error (interval-for-each 1 (make-interval '#(3) '#(4)))) (test-error (interval-for-each 1 (make-interval '#(3) '#(4))))
(test '()
(let ((result '()))
(interval-for-each
(lambda i (set! result (cons i result)))
(make-interval '#(1 2 3) '#(2 2 4)))
result))
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((= i tests)) ((= i tests))
(let* ((lower (map (lambda (x) (random 10)) (let* ((lower (map (lambda (x) (random 10))
@ -1318,6 +1325,10 @@
(array-packed? (make-specialized-array (make-interval '#(1 2 3) (array-packed? (make-specialized-array (make-interval '#(1 2 3)
'#(1 2 3)) '#(1 2 3))
f32-storage-class))) f32-storage-class)))
(test-assert
(array-packed? (make-specialized-array (make-interval '#(1 2 3)
'#(2 2 4))
f32-storage-class)))
;; all these are true, we'll have to see how to screw it up later. ;; all these are true, we'll have to see how to screw it up later.
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))