diff --git a/lib/srfi/130.scm b/lib/srfi/130.scm index 1000c5d6..5d82fded 100644 --- a/lib/srfi/130.scm +++ b/lib/srfi/130.scm @@ -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) diff --git a/lib/srfi/130/test.sld b/lib/srfi/130/test.sld index 02eeb113..f423faba 100644 --- a/lib/srfi/130/test.sld +++ b/lib/srfi/130/test.sld @@ -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