Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-16 01:17:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

more srfi 130 tests and fixes

Browse source
This commit is contained in:
Alex Shinn 2016-05-12 00:14:50 +09:00
parent 5ab99635c5
commit 2165f19af5
2 changed files with 57 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

43
lib/srfi/130.scm
View file

@ -52,8 +52,10 @@
(if (null? str-ls)
(error "string-join 'strict-infix called on an empty list")
(%string-join str-ls sep)))
((prefix) (%string-join (cons "" str-ls) sep))
((suffix) (string-append (%string-join str-ls sep) sep))
((prefix)
(if (null? str-ls) "" (%string-join (cons "" str-ls) sep)))
((suffix)
(if (null? str-ls) "" (string-append (%string-join str-ls sep) sep)))
(else (error "unknown string-join grammar" grammar)))))
(define (string-ref/cursor str x)
@ -149,13 +151,16 @@
(apply string-find-right str pred (cursor-args str o)))
(define (string-contains s1 s2 . o)
(let ((start1 (if (pair? o) (car o) (string-cursor-start s1)))
(end1 (if (and (pair? o) (pair? (cdr o)))
(cadr o)
(string-cursor-end s1)))
(let ((start1 (cursor-arg s1 (if (pair? o) (car o) (string-cursor-start s1))))
(end1 (cursor-arg s1 (if (and (pair? o) (pair? (cdr o)))
(cadr o)
(string-cursor-end s1))))
(s2 (if (and (pair? o) (pair? (cdr o))) (string-arg s2 (cddr o)) s2)))
(let ((res (%string-contains s1 s2 start1)))
(and res (string-cursor<=? res end1) res))))
(and res
(string-cursor<=? (string-cursor-forward s1 res (string-length s2))
end1)
res))))
(define (string-contains-right s1 s2 . o)
(let* ((start1
@ -241,28 +246,26 @@
(let* ((delim-len (string-length delim))
(grammar (if (pair? o) (car o) 'infix))
(o (if (pair? o) (cdr o) '()))
(limit (and (pair? o) (cadr o)))
(limit (or (and (pair? o) (car o)) (string-length str)))
(o (if (pair? o) (cdr o) '()))
(start (if (pair? o) (car o) (string-cursor-start str)))
(end (if (and (pair? o) (pair? (cdr o)))
(cadr o)
(string-cursor-end str))))
(define (trim-for-grammar res for-grammer)
(if (and (eq? grammar for-grammer) (pair? res) (equal? "" (car res)))
(cdr res)
res))
(start (cursor-arg str
(if (pair? o) (car o) (string-cursor-start str))))
(end (cursor-arg str (if (and (pair? o) (pair? (cdr o)))
(cadr o)
(string-cursor-end str)))))
(if (and (eq? grammar 'strict-infix) (string-cursor>=? start end))
(error "string-split 'strict-infix called on an empty string"))
(let lp ((sc start) (res '()))
(let lp ((sc start) (i 0) (res '()))
(cond
((string-cursor>=? sc end)
(trim-for-grammar (reverse (trim-for-grammar res 'suffix)) 'prefix))
((string-contains str delim sc end)
(reverse res))
((and (< i limit) (string-contains str delim sc end))
=> (lambda (sc2)
(lp (string-cursor-forward str sc2 delim-len)
(+ i 1)
(cons (substring-cursor str sc sc2) res))))
(else
(lp end (cons (substring-cursor str sc end) res)))))))
(lp end i (cons (substring-cursor str sc end) res)))))))
(define (string-split-right str delim . o)
#f)

38
lib/srfi/130/test.sld
View file

@ -4,6 +4,8 @@
(chibi char-set) (chibi char-set full) (chibi test)
(srfi 130))
(begin
(define (sc str c)
(string-index->cursor str c))
(define (string-index->index str pred . o)
(string-cursor->index str (apply string-index str pred o)))
(define (string-index-right->index str pred . o)
@ -147,10 +149,17 @@
(string-count "abc def\tghi jkl" char-whitespace? 4))
(test "string-count #4" 1
(string-count "abc def\tghi jkl" char-whitespace? 4 9))
(test-assert "string-contains"
(string-contains "Ma mere l'oye" "mer"))
(test "string-contains" #f
(string-contains "Ma mere l'oye" "Mer"))
(let ((s "Ma mere l'oye"))
(test-assert "string-contains"
(string-contains s "mer"))
(test "string-contains" #f
(string-contains s "Mer"))
(test-assert "string-contains"
(string-contains s "mer" 1 8))
(test-not "string-contains"
(string-contains s "mer" 4 8))
(test-not "string-contains"
(string-contains s "mer" 1 5)))
(let ((s "eek -- it's a geek."))
(test 15 (string-cursor->index s (string-contains-right s "ee")))
(test 15 (string-cursor->index s (string-contains-right s "ee" 12 18)))
@ -332,6 +341,27 @@
(test "string-remove" ""
(string-remove (lambda (c) (char-lower-case? c)) ""))
(test "foo:bar:baz"
(string-join '("foo" "bar" "baz") ":"))
(test "foo:bar:baz:"
(string-join '("foo" "bar" "baz") ":" 'suffix))
(test "" (string-join '() ":"))
(test "" (string-join '("") ":"))
(test "" (string-join '() ":" 'suffix))
(test ":" (string-join '("") ":" 'suffix))
(test '("foo" "bar" "baz")
(string-split "foo:bar:baz" ":"))
(test '("foo" "bar" "baz")
(string-split "foo:bar:baz:" ":" 'suffix))
(test '("foo" "bar:baz:")
(string-split "foo:bar:baz:" ":" 'suffix 1))
(test '("foo" "bar" "baz:")
(string-split "foo:bar:baz:" ":" 'suffix 2))
(test '() (string-split "" ":"))
(test '() (string-split "" ":" 'suffix))
(test '("") (string-split ":" ":" 'suffix))
;;; Regression tests: check that reported bugs have been fixed
;; From: Matthias Radestock <matthias@sorted.org>