mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-14 16:37:33 +02:00
adding initial chibi version of SRFI 130
This commit is contained in:
Alex Shinn
parent
757ff7733e
commit
1621d481f3
3 changed files with 680 additions and 0 deletions
268
lib/srfi/130.scm
Normal file
268
lib/srfi/130.scm
Normal file
|
|
@ -0,0 +1,268 @@
|
||||||
|
|
||||||
|
(define (string-cursor-diff str start end)
|
||||||
|
(if (string-cursor? start)
|
||||||
|
(- (string-cursor->index str end) (string-cursor->index str start))
|
||||||
|
(- end start)))
|
||||||
|
|
||||||
|
(define (string-unfold/aux k stop? mapper successor seed . o)
|
||||||
|
(let ((base (if (pair? o) (car o) ""))
|
||||||
|
(make-final (if (and (pair? o) (pair? (cdr o))) (cadr o) (lambda (x) ""))))
|
||||||
|
(do ((acc seed (successor acc))
|
||||||
|
(ls '() (cons (mapper acc) ls)))
|
||||||
|
((stop? acc) (k base ls (make-final acc))))))
|
||||||
|
|
||||||
|
(define (string-unfold . o)
|
||||||
|
(apply string-unfold/aux
|
||||||
|
(lambda (base ls final)
|
||||||
|
(string-append base (reverse-list->string ls) final))
|
||||||
|
o))
|
||||||
|
|
||||||
|
(define (string-unfold-right . o)
|
||||||
|
(apply string-unfold/aux
|
||||||
|
(lambda (base ls final)
|
||||||
|
(string-append final (list->string ls) base))
|
||||||
|
o))
|
||||||
|
|
||||||
|
(define (string-tabulate proc len)
|
||||||
|
(string-unfold (lambda (i) (= i len)) proc (lambda (i) (+ i 1)) 0))
|
||||||
|
|
||||||
|
(define (string->list/cursors str . o)
|
||||||
|
(let ((start (if (pair? o) (car o) (string-cursor-start str)))
|
||||||
|
(end (if (and (pair? o) (pair? (cdr o)))
|
||||||
|
(cadr o)
|
||||||
|
(string-cursor-end str))))
|
||||||
|
(let lp ((i end) (res '()))
|
||||||
|
(if (string-cursor<=? i start)
|
||||||
|
res
|
||||||
|
(let ((i (string-cursor-prev str i)))
|
||||||
|
(lp i (cons (string-cursor-ref str i) res)))))))
|
||||||
|
|
||||||
|
(define (string->vector/cursors str . o)
|
||||||
|
(list->vector (apply string->list/cursors str o)))
|
||||||
|
|
||||||
|
(define (reverse-list->string ls)
|
||||||
|
(list->string (reverse ls)))
|
||||||
|
|
||||||
|
(define (string-join str-ls . o)
|
||||||
|
(let ((sep (if (pair? o) (car o) ""))
|
||||||
|
(grammar (if (and (pair? o) (pair? (cdr o))) (cadr o) 'infix)))
|
||||||
|
(case grammar
|
||||||
|
((infix) (%string-join str-ls sep))
|
||||||
|
((strict-infix)
|
||||||
|
(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))
|
||||||
|
(else (error "unknown string-join grammar" grammar)))))
|
||||||
|
|
||||||
|
(define (string-ref/cursor str x)
|
||||||
|
(if (string-cursor? x)
|
||||||
|
(string-cursor-ref str x)
|
||||||
|
(string-ref str x)))
|
||||||
|
|
||||||
|
(define (substring/cursors str start end)
|
||||||
|
(if (string-cursor? start)
|
||||||
|
(substring-cursor str start end)
|
||||||
|
(substring str start end)))
|
||||||
|
|
||||||
|
(define (string-copy/cursors str . o)
|
||||||
|
(cond ((null? o) (substring-cursor str (string-cursor-start str)))
|
||||||
|
((string-cursor? (car o)) (apply substring-cursor str o))
|
||||||
|
(else (apply substring str o))))
|
||||||
|
|
||||||
|
(define (string-arg str o)
|
||||||
|
(if (pair? o) (apply string-copy/cursors str o) str))
|
||||||
|
|
||||||
|
(define (cursor-arg str x)
|
||||||
|
(if (string-cursor? x) x (string-index->cursor str x)))
|
||||||
|
|
||||||
|
(define (cursor-args str o)
|
||||||
|
(if (pair? o)
|
||||||
|
(cons (cursor-arg str (car o)) (cursor-args str (cdr o)))
|
||||||
|
'()))
|
||||||
|
|
||||||
|
(define (string-take str n)
|
||||||
|
(substring str 0 n))
|
||||||
|
(define (string-take-right str n)
|
||||||
|
(let ((start (string-cursor-backward str (string-cursor-end str) n)))
|
||||||
|
(substring-cursor str start)))
|
||||||
|
(define (string-drop str n)
|
||||||
|
(substring str n))
|
||||||
|
(define (string-drop-right str n)
|
||||||
|
(let ((end (string-cursor-backward str (string-cursor-end str) n)))
|
||||||
|
(substring-cursor str (string-cursor-start str) end)))
|
||||||
|
|
||||||
|
(define (string-pad str len . o)
|
||||||
|
(let* ((pad-char (if (pair? o) (car o) #\space))
|
||||||
|
(str (if (and (pair? o) (pair? (cdr o))) (string-arg str (cdr o)) str))
|
||||||
|
(str-len (string-length str)))
|
||||||
|
(cond
|
||||||
|
((> str-len len) (string-take-right str len))
|
||||||
|
((< str-len len)
|
||||||
|
(string-append (make-string (- len str-len) pad-char) str))
|
||||||
|
(else str))))
|
||||||
|
|
||||||
|
(define (string-pad-right str len . o)
|
||||||
|
(let* ((pad-char (if (pair? o) (car o) #\space))
|
||||||
|
(str (if (and (pair? o) (pair? (cdr o))) (string-arg str (cdr o)) str))
|
||||||
|
(str-len (string-length str)))
|
||||||
|
(cond
|
||||||
|
((> str-len len) (string-take str len))
|
||||||
|
((< str-len len)
|
||||||
|
(string-append str (make-string (- len str-len) pad-char)))
|
||||||
|
(else str))))
|
||||||
|
|
||||||
|
(define (string-trim str . o)
|
||||||
|
(let ((pred (if (pair? o) (car o) char-whitespace?))
|
||||||
|
(str (if (and (pair? o) (pair? (cdr o))) (string-arg str (cdr o)) str)))
|
||||||
|
(substring-cursor str (string-skip str pred))))
|
||||||
|
(define (string-trim-right str . o)
|
||||||
|
(let ((pred (if (pair? o) (car o) char-whitespace?))
|
||||||
|
(str (if (and (pair? o) (pair? (cdr o))) (string-arg str (cdr o)) str)))
|
||||||
|
(substring-cursor str (string-cursor-start str) (string-skip-right str pred))))
|
||||||
|
(define (string-trim-both str . o)
|
||||||
|
(let ((pred (if (pair? o) (car o) char-whitespace?))
|
||||||
|
(str (if (and (pair? o) (pair? (cdr o))) (string-arg str (cdr o)) str)))
|
||||||
|
(string-trim-right (string-trim str pred) pred)))
|
||||||
|
|
||||||
|
(define (string-prefix-length s1 s2 . o)
|
||||||
|
(let ((s1 (string-arg s1 o))
|
||||||
|
(s2 (if (and (pair? o) (pair? (cdr o))) (string-arg s2 (cddr o)) s2)))
|
||||||
|
(string-cursor->index s1 (string-mismatch s1 s2))))
|
||||||
|
(define (string-suffix-length s1 s2 . o)
|
||||||
|
(let* ((s1 (string-arg s1 o))
|
||||||
|
(s2 (if (and (pair? o) (pair? (cdr o))) (string-arg s2 (cddr o)) s2))
|
||||||
|
(mismatch (string-mismatch-right s2 s1)))
|
||||||
|
(string-cursor-diff s1
|
||||||
|
(string-cursor-next s1 mismatch)
|
||||||
|
(string-cursor-end s1))))
|
||||||
|
|
||||||
|
(define (string-prefix? s1 s2 . o)
|
||||||
|
(equal? (string-length s1) (apply string-prefix-length s1 s2 o)))
|
||||||
|
(define (string-suffix? s1 s2 . o)
|
||||||
|
(equal? (string-length s1) (apply string-suffix-length s1 s2 o)))
|
||||||
|
|
||||||
|
(define (string-index str pred . o)
|
||||||
|
(apply string-find str pred (cursor-args str o)))
|
||||||
|
(define (string-index-right str pred . o)
|
||||||
|
(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)))
|
||||||
|
(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))))
|
||||||
|
|
||||||
|
(define (string-contains-right s1 s2 . o)
|
||||||
|
(let* ((s1 (string-arg s1 o))
|
||||||
|
(s2 (if (and (pair? o) (pair? (cdr o))) (string-arg s2 (cddr o)) s2))
|
||||||
|
(start1 (string-cursor-start s1))
|
||||||
|
(start2 (string-cursor-start s2)))
|
||||||
|
(let lp ((c1 (string-cursor-end s1))
|
||||||
|
(c2 (string-cursor-end s2))
|
||||||
|
(c3 (string-cursor-end s2)))
|
||||||
|
(cond
|
||||||
|
((string-cursor=? c3 start2)
|
||||||
|
c1)
|
||||||
|
((string-cursor=? c1 start1)
|
||||||
|
#f)
|
||||||
|
((eqv? (string-cursor-ref s1 c1) (string-cursor-ref s2 c3))
|
||||||
|
(lp (string-cursor-prev s1 c2) c2 (string-cursor-prev s2 c3)))
|
||||||
|
(else
|
||||||
|
(lp (string-cursor-prev s1 c2) c2 c2))))))
|
||||||
|
|
||||||
|
(define (string-reverse str . o)
|
||||||
|
(list->string (reverse (string->list/cursors (string-arg str o)))))
|
||||||
|
|
||||||
|
(define string-concatenate %string-join)
|
||||||
|
|
||||||
|
(define (string-concatenate-reverse str-ls . o)
|
||||||
|
(let ((str-ls
|
||||||
|
(if (pair? o)
|
||||||
|
(cons (apply string-copy/cursors (car o) 0 (cdr o)) str-ls)
|
||||||
|
str-ls)))
|
||||||
|
(string-concatenate (reverse str-ls))))
|
||||||
|
|
||||||
|
(define (string-fold kons knil str . o)
|
||||||
|
(%string-fold kons knil (string-arg str o)))
|
||||||
|
|
||||||
|
(define (string-fold-right kons knil str . o)
|
||||||
|
(%string-fold-right kons knil (string-arg str o)))
|
||||||
|
|
||||||
|
(define (string-for-each-cursor proc str . o)
|
||||||
|
(let ((end (cursor-arg str
|
||||||
|
(if (and (pair? o) (pair? (cdr o)))
|
||||||
|
(cadr o)
|
||||||
|
(string-cursor-end str)))))
|
||||||
|
(let lp ((i (cursor-arg str
|
||||||
|
(if (pair? o) (car o) (string-cursor-start str)))))
|
||||||
|
(when (string-cursor<? i end)
|
||||||
|
(proc i)
|
||||||
|
(lp (string-cursor-next str i))))))
|
||||||
|
|
||||||
|
(define (string-replicate str from to . o)
|
||||||
|
(let* ((str (string-arg str o))
|
||||||
|
(start (string-cursor-start str))
|
||||||
|
(end (string-cursor-end str))
|
||||||
|
(out (open-output-string)))
|
||||||
|
(let lp ((i from)
|
||||||
|
(sc (string-cursor-forward str
|
||||||
|
start
|
||||||
|
(modulo from (string-length str)))))
|
||||||
|
(cond
|
||||||
|
((= i to)
|
||||||
|
(get-output-string out))
|
||||||
|
(else
|
||||||
|
(write-char (string-cursor-ref str sc) out)
|
||||||
|
(let ((sc (string-cursor-next str sc)))
|
||||||
|
(lp (+ i 1) (if (string-cursor=? sc end) start sc))))))))
|
||||||
|
|
||||||
|
(define (string-count str pred . o)
|
||||||
|
(apply string-fold (lambda (ch n) (if (pred ch) (+ n 1) n)) 0 str o))
|
||||||
|
|
||||||
|
(define (string-replace s1 s2 start1 end1 . o)
|
||||||
|
(string-append (substring/cursors s1 0 start1)
|
||||||
|
(string-arg s2 o)
|
||||||
|
(substring/cursors s1 end1 (string-cursor-end s1))))
|
||||||
|
|
||||||
|
(define (string-split str delim . o)
|
||||||
|
(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)))
|
||||||
|
(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))
|
||||||
|
(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 '()))
|
||||||
|
(cond
|
||||||
|
((string-cursor>=? sc end)
|
||||||
|
(trim-for-grammar (reverse (trim-for-grammar res 'suffix)) 'prefix))
|
||||||
|
((string-contains str delim sc end)
|
||||||
|
=> (lambda (sc2)
|
||||||
|
(lp (string-cursor-forward str sc2 delim-len)
|
||||||
|
(cons (substring-cursor str sc sc2) res))))
|
||||||
|
(else
|
||||||
|
(lp end (cons (substring-cursor str sc end) res)))))))
|
||||||
|
|
||||||
|
(define (string-split-right str delim . o)
|
||||||
|
#f)
|
||||||
|
|
||||||
|
(define (string-filter pred str . o)
|
||||||
|
(let ((out (open-output-string)))
|
||||||
|
(apply string-fold (lambda (ch acc) (if (pred ch) (write-char ch out))) #f str o)
|
||||||
|
(get-output-string out)))
|
||||||
|
|
||||||
|
(define (string-remove pred str . o)
|
||||||
|
(apply string-filter (lambda (ch) (not (pred ch))) str o))
|
||||||
51
lib/srfi/130.sld
Normal file
51
lib/srfi/130.sld
Normal file
|
|
@ -0,0 +1,51 @@
|
||||||
|
(define-library (srfi 130)
|
||||||
|
(export
|
||||||
|
;; Cursor operations
|
||||||
|
string-cursor?
|
||||||
|
string-cursor-start string-cursor-end
|
||||||
|
string-cursor-next string-cursor-prev
|
||||||
|
string-cursor-forward string-cursor-backward
|
||||||
|
string-cursor=?
|
||||||
|
string-cursor<? string-cursor>?
|
||||||
|
string-cursor<=? string-cursor>=?
|
||||||
|
string-cursor-diff
|
||||||
|
string-cursor->index string-index->cursor
|
||||||
|
;; Predicates
|
||||||
|
string-null? string-every string-any
|
||||||
|
;; Constructors
|
||||||
|
string-tabulate string-unfold string-unfold-right
|
||||||
|
;; Conversion
|
||||||
|
string->list/cursors string->vector/cursors
|
||||||
|
reverse-list->string string-join
|
||||||
|
;; Selection
|
||||||
|
string-ref/cursor
|
||||||
|
substring/cursors string-copy/cursors
|
||||||
|
string-take string-take-right
|
||||||
|
string-drop string-drop-right
|
||||||
|
string-pad string-pad-right
|
||||||
|
string-trim string-trim-right string-trim-both
|
||||||
|
;; Prefixes & suffixes
|
||||||
|
string-prefix-length string-suffix-length
|
||||||
|
string-prefix? string-suffix?
|
||||||
|
;; Searching
|
||||||
|
string-index string-index-right
|
||||||
|
string-skip string-skip-right
|
||||||
|
string-contains string-contains-right
|
||||||
|
;; The whole string
|
||||||
|
string-reverse
|
||||||
|
string-concatenate string-concatenate-reverse
|
||||||
|
string-fold string-fold-right
|
||||||
|
string-for-each-cursor
|
||||||
|
string-replicate string-count
|
||||||
|
string-replace string-split string-split-right
|
||||||
|
string-filter string-remove)
|
||||||
|
(import (scheme base)
|
||||||
|
(scheme char) (scheme write)
|
||||||
|
(rename (chibi string)
|
||||||
|
(string-fold %string-fold)
|
||||||
|
(string-fold-right %string-fold-right)
|
||||||
|
(string-contains %string-contains)
|
||||||
|
(string-join %string-join)
|
||||||
|
(string-prefix? %string-prefix?)
|
||||||
|
(string-suffix? %string-suffix?)))
|
||||||
|
(include "130.scm"))
|
||||||
361
lib/srfi/130/test.sld
Normal file
361
lib/srfi/130/test.sld
Normal file
|
|
@ -0,0 +1,361 @@
|
||||||
|
(define-library (srfi 130 test)
|
||||||
|
(export run-tests)
|
||||||
|
(import (scheme base) (scheme char)
|
||||||
|
(chibi char-set) (chibi char-set full) (chibi test)
|
||||||
|
(srfi 130))
|
||||||
|
(begin
|
||||||
|
(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)
|
||||||
|
(string-cursor->index str (apply string-index-right str pred o)))
|
||||||
|
(define (run-tests)
|
||||||
|
(test-begin "srfi-130: cursor-based string library")
|
||||||
|
|
||||||
|
;; tests adapted from Gauche's SRFI 13 tests, via Chicken
|
||||||
|
|
||||||
|
(test "string-null?" #f (string-null? "abc"))
|
||||||
|
(test "string-null?" #t (string-null? ""))
|
||||||
|
(test "string-every" #t (string-every #\a ""))
|
||||||
|
(test "string-every" #t (string-every #\a "aaaa"))
|
||||||
|
(test "string-every" #f (string-every #\a "aaba"))
|
||||||
|
(test "string-every" #t (string-every char-set:lower-case "aaba"))
|
||||||
|
(test "string-every" #f (string-every char-set:lower-case "aAba"))
|
||||||
|
(test "string-every" #t (string-every char-set:lower-case ""))
|
||||||
|
(test "string-every" #t (string-every (lambda (x) (char->integer x)) "aAbA"))
|
||||||
|
(test "string-every" #t (string-every (lambda (x) (error "hoge")) ""))
|
||||||
|
(test "string-any" #t (string-any #\a "aaaa"))
|
||||||
|
(test "string-any" #f (string-any #\a "Abcd"))
|
||||||
|
(test "string-any" #f (string-any #\a ""))
|
||||||
|
(test "string-any" #t (string-any char-set:lower-case "ABcD"))
|
||||||
|
(test "string-any" #f (string-any char-set:lower-case "ABCD"))
|
||||||
|
(test "string-any" #f (string-any char-set:lower-case ""))
|
||||||
|
(test "string-any" (char->integer #\a)
|
||||||
|
(string-any (lambda (x) (char->integer x)) "aAbA"))
|
||||||
|
|
||||||
|
(test "string-tabulate" "0123456789"
|
||||||
|
(string-tabulate (lambda (code)
|
||||||
|
(integer->char (+ code (char->integer #\0))))
|
||||||
|
10))
|
||||||
|
(test "string-tabulate" ""
|
||||||
|
(string-tabulate (lambda (code)
|
||||||
|
(integer->char (+ code (char->integer #\0))))
|
||||||
|
0))
|
||||||
|
|
||||||
|
(test "reverse-list->string" "cBa"
|
||||||
|
(reverse-list->string '(#\a #\B #\c)))
|
||||||
|
(test "reverse-list->string" ""
|
||||||
|
(reverse-list->string '()))
|
||||||
|
|
||||||
|
(test "substring/cursors" "cde" (substring/cursors "abcde" 2 5))
|
||||||
|
(test "substring/cursors" "cd" (substring/cursors "abcde" 2 4))
|
||||||
|
|
||||||
|
(test "string-copy!" "abCDEfg"
|
||||||
|
(let ((x (string-copy "abcdefg")))
|
||||||
|
(string-copy! x 2 "CDE")
|
||||||
|
x))
|
||||||
|
(test "string-copy!" "abCDEfg"
|
||||||
|
(let ((x (string-copy "abcdefg")))
|
||||||
|
(string-copy! x 2 "ZABCDE" 3)
|
||||||
|
x))
|
||||||
|
(test "string-copy!" "abCDEfg"
|
||||||
|
(let ((x (string-copy "abcdefg")))
|
||||||
|
(string-copy! x 2 "ZABCDEFG" 3 6)
|
||||||
|
x))
|
||||||
|
|
||||||
|
(test "string-take" "Pete S" (string-take "Pete Szilagyi" 6))
|
||||||
|
(test "string-take" "" (string-take "Pete Szilagyi" 0))
|
||||||
|
(test "string-take" "Pete Szilagyi" (string-take "Pete Szilagyi" 13))
|
||||||
|
(test "string-drop" "zilagyi" (string-drop "Pete Szilagyi" 6))
|
||||||
|
(test "string-drop" "Pete Szilagyi" (string-drop "Pete Szilagyi" 0))
|
||||||
|
(test "string-drop" "" (string-drop "Pete Szilagyi" 13))
|
||||||
|
|
||||||
|
(test "string-take-right" "rules" (string-take-right "Beta rules" 5))
|
||||||
|
(test "string-take-right" "" (string-take-right "Beta rules" 0))
|
||||||
|
(test "string-take-right" "Beta rules" (string-take-right "Beta rules" 10))
|
||||||
|
(test "string-drop-right" "Beta " (string-drop-right "Beta rules" 5))
|
||||||
|
(test "string-drop-right" "Beta rules" (string-drop-right "Beta rules" 0))
|
||||||
|
(test "string-drop-right" "" (string-drop-right "Beta rules" 10))
|
||||||
|
|
||||||
|
(test "string-pad" " 325" (string-pad "325" 5))
|
||||||
|
(test "string-pad" "71325" (string-pad "71325" 5))
|
||||||
|
(test "string-pad" "71325" (string-pad "8871325" 5))
|
||||||
|
(test "string-pad" "~~325" (string-pad "325" 5 #\~))
|
||||||
|
(test "string-pad" "~~~25" (string-pad "325" 5 #\~ 1))
|
||||||
|
(test "string-pad" "~~~~2" (string-pad "325" 5 #\~ 1 2))
|
||||||
|
(test "string-pad-right" "325 " (string-pad-right "325" 5))
|
||||||
|
(test "string-pad-right" "71325" (string-pad-right "71325" 5))
|
||||||
|
(test "string-pad-right" "88713" (string-pad-right "8871325" 5))
|
||||||
|
(test "string-pad-right" "325~~" (string-pad-right "325" 5 #\~))
|
||||||
|
(test "string-pad-right" "25~~~" (string-pad-right "325" 5 #\~ 1))
|
||||||
|
(test "string-pad-right" "2~~~~" (string-pad-right "325" 5 #\~ 1 2))
|
||||||
|
|
||||||
|
(test "string-trim" "a b c d \n"
|
||||||
|
(string-trim " \t a b c d \n"))
|
||||||
|
(test "string-trim" "\t a b c d \n"
|
||||||
|
(string-trim " \t a b c d \n" #\space))
|
||||||
|
(test "string-trim" "a b c d \n"
|
||||||
|
(string-trim "4358948a b c d \n" char-numeric?))
|
||||||
|
|
||||||
|
(test "string-trim-right" " \t a b c d"
|
||||||
|
(string-trim-right " \t a b c d \n"))
|
||||||
|
(test "string-trim-right" " \t a b c d "
|
||||||
|
(string-trim-right " \t a b c d \n" (lambda (ch) (eqv? ch #\newline))))
|
||||||
|
(test "string-trim-right" "349853a b c d"
|
||||||
|
(string-trim-right "349853a b c d03490" char-numeric?))
|
||||||
|
|
||||||
|
(test "string-trim-both" "a b c d"
|
||||||
|
(string-trim-both " \t a b c d \n"))
|
||||||
|
(test "string-trim-both" " \t a b c d "
|
||||||
|
(string-trim-both " \t a b c d \n" (lambda (ch) (eqv? ch #\newline))))
|
||||||
|
(test "string-trim-both" "a b c d"
|
||||||
|
(string-trim-both "349853a b c d03490" char-numeric?))
|
||||||
|
|
||||||
|
;; TODO: bunch of string= families
|
||||||
|
|
||||||
|
(test "string-prefix-length" 5
|
||||||
|
(string-prefix-length "cancaNCAM" "cancancan"))
|
||||||
|
(test "string-suffix-length" 2
|
||||||
|
(string-suffix-length "CanCan" "cankancan"))
|
||||||
|
|
||||||
|
(test "string-prefix?" #t (string-prefix? "abcd" "abcdefg"))
|
||||||
|
(test "string-prefix?" #f (string-prefix? "abcf" "abcdefg"))
|
||||||
|
(test "string-suffix?" #t (string-suffix? "defg" "abcdefg"))
|
||||||
|
(test "string-suffix?" #f (string-suffix? "aefg" "abcdefg"))
|
||||||
|
|
||||||
|
(test "string-index #1" 4
|
||||||
|
(string-index->index "abcd:efgh:ijkl" (lambda (ch) (eqv? ch #\:))))
|
||||||
|
;; (test "string-index #2" 4
|
||||||
|
;; (string-index "abcd:efgh;ijkl" (char-set-complement char-set:letter)))
|
||||||
|
(test "string-index #3" 14
|
||||||
|
(string-index->index "abcd:efgh;ijkl" (lambda (ch) (char-set-contains? char-set:digit ch))))
|
||||||
|
(test "string-index #4" 9
|
||||||
|
(string-index->index "abcd:efgh:ijkl" (lambda (ch) (eqv? ch #\:)) 5))
|
||||||
|
(test "string-index-right #1" 5
|
||||||
|
(string-index-right->index "abcd:efgh;ijkl" (lambda (ch) (eqv? ch #\:))))
|
||||||
|
;; (test "string-index-right #2" 9
|
||||||
|
;; (string-index-right "abcd:efgh;ijkl" (char-set-complement char-set:letter)))
|
||||||
|
(test "string-index-right #3" 14
|
||||||
|
(string-index-right->index "abcd:efgh;ijkl" char-alphabetic?))
|
||||||
|
;; (test "string-index-right #4" 4
|
||||||
|
;; (string-index-right "abcd:efgh;ijkl" (char-set-complement char-set:letter) 2 5))
|
||||||
|
|
||||||
|
;; (test "string-count #1" 2
|
||||||
|
;; (string-count "abc def\tghi jkl" #\space))
|
||||||
|
(test "string-count #2" 3
|
||||||
|
(string-count "abc def\tghi jkl" char-whitespace?))
|
||||||
|
(test "string-count #3" 2
|
||||||
|
(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"))
|
||||||
|
|
||||||
|
(test "string-reverse" "nomel on nolem on"
|
||||||
|
(string-reverse "no melon no lemon"))
|
||||||
|
(test "string-reverse" "nomel on"
|
||||||
|
(string-reverse "no melon no lemon" 9))
|
||||||
|
(test "string-reverse" "on"
|
||||||
|
(string-reverse "no melon no lemon" 9 11))
|
||||||
|
|
||||||
|
(test "string-append" #f
|
||||||
|
(let ((s "test")) (eq? s (string-append s))))
|
||||||
|
(test "string-concatenate" #f
|
||||||
|
(let ((s "test")) (eq? s (string-concatenate (list s)))))
|
||||||
|
(test "string-concatenate" "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
|
||||||
|
(string-concatenate
|
||||||
|
'("A" "B" "C" "D" "E" "F" "G" "H"
|
||||||
|
"I" "J" "K" "L" "M" "N" "O" "P"
|
||||||
|
"Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
|
||||||
|
"a" "b" "c" "d" "e" "f" "g" "h"
|
||||||
|
"i" "j" "k" "l" "m" "n" "o" "p"
|
||||||
|
"q" "r" "s" "t" "u" "v" "w" "x" "y" "z")))
|
||||||
|
(test "string-concatenate-reverse" "zyxwvutsrqponmlkjihgfedcbaZYXWVUTSRQPONMLKJIHGFEDCBA"
|
||||||
|
(string-concatenate-reverse
|
||||||
|
'("A" "B" "C" "D" "E" "F" "G" "H"
|
||||||
|
"I" "J" "K" "L" "M" "N" "O" "P"
|
||||||
|
"Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
|
||||||
|
"a" "b" "c" "d" "e" "f" "g" "h"
|
||||||
|
"i" "j" "k" "l" "m" "n" "o" "p"
|
||||||
|
"q" "r" "s" "t" "u" "v" "w" "x" "y" "z")))
|
||||||
|
(test "string-concatenate-reverse" #f
|
||||||
|
(let ((s "test"))
|
||||||
|
(eq? s (string-concatenate-reverse (list s)))))
|
||||||
|
|
||||||
|
(test "string-map" "svool"
|
||||||
|
(string-map (lambda (c)
|
||||||
|
(integer->char (- 219 (char->integer c))))
|
||||||
|
"hello"))
|
||||||
|
;; (test "string-map" "vool"
|
||||||
|
;; (string-map (lambda (c)
|
||||||
|
;; (integer->char (- 219 (char->integer c))))
|
||||||
|
;; "hello" 1))
|
||||||
|
;; (test "string-map" "vo"
|
||||||
|
;; (string-map (lambda (c)
|
||||||
|
;; (integer->char (- 219 (char->integer c))))
|
||||||
|
;; "hello" 1 3))
|
||||||
|
|
||||||
|
(test "string-fold" '(#\o #\l #\l #\e #\h . #t)
|
||||||
|
(string-fold cons #t "hello"))
|
||||||
|
(test "string-fold" '(#\l #\e . #t)
|
||||||
|
(string-fold cons #t "hello" 1 3))
|
||||||
|
(test "string-fold-right" '(#\h #\e #\l #\l #\o . #t)
|
||||||
|
(string-fold-right cons #t "hello"))
|
||||||
|
(test "string-fold-right" '(#\e #\l . #t)
|
||||||
|
(string-fold-right cons #t "hello" 1 3))
|
||||||
|
|
||||||
|
(test "string-unfold" "hello"
|
||||||
|
(string-unfold null? car cdr '(#\h #\e #\l #\l #\o)))
|
||||||
|
(test "string-unfold" "hi hello"
|
||||||
|
(string-unfold null? car cdr '(#\h #\e #\l #\l #\o) "hi "))
|
||||||
|
(test "string-unfold" "hi hello ho"
|
||||||
|
(string-unfold null? car cdr
|
||||||
|
'(#\h #\e #\l #\l #\o) "hi "
|
||||||
|
(lambda (x) " ho")))
|
||||||
|
|
||||||
|
(test "string-unfold-right" "olleh"
|
||||||
|
(string-unfold-right null? car cdr '(#\h #\e #\l #\l #\o)))
|
||||||
|
(test "string-unfold-right" "olleh hi"
|
||||||
|
(string-unfold-right null? car cdr '(#\h #\e #\l #\l #\o) " hi"))
|
||||||
|
(test "string-unfold-right" "ho olleh hi"
|
||||||
|
(string-unfold-right null? car cdr
|
||||||
|
'(#\h #\e #\l #\l #\o) " hi"
|
||||||
|
(lambda (x) "ho ")))
|
||||||
|
|
||||||
|
(test "string-for-each" "CLtL"
|
||||||
|
(let ((out (open-output-string))
|
||||||
|
(prev #f))
|
||||||
|
(string-for-each (lambda (c)
|
||||||
|
(if (or (not prev)
|
||||||
|
(char-whitespace? prev))
|
||||||
|
(write-char c out))
|
||||||
|
(set! prev c))
|
||||||
|
"Common Lisp, the Language")
|
||||||
|
|
||||||
|
(get-output-string out)))
|
||||||
|
;; (test "string-for-each" "oLtL"
|
||||||
|
;; (let ((out (open-output-string))
|
||||||
|
;; (prev #f))
|
||||||
|
;; (string-for-each (lambda (c)
|
||||||
|
;; (if (or (not prev)
|
||||||
|
;; (char-whitespace? prev))
|
||||||
|
;; (write-char c out))
|
||||||
|
;; (set! prev c))
|
||||||
|
;; "Common Lisp, the Language" 1)
|
||||||
|
;; (get-output-string out)))
|
||||||
|
;; (test "string-for-each" "oL"
|
||||||
|
;; (let ((out (open-output-string))
|
||||||
|
;; (prev #f))
|
||||||
|
;; (string-for-each (lambda (c)
|
||||||
|
;; (if (or (not prev)
|
||||||
|
;; (char-whitespace? prev))
|
||||||
|
;; (write-char c out))
|
||||||
|
;; (set! prev c))
|
||||||
|
;; "Common Lisp, the Language" 1 10)
|
||||||
|
;; (get-output-string out)))
|
||||||
|
|
||||||
|
(test "string-for-each-cursor" '(4 3 2 1 0)
|
||||||
|
(let ((r '()))
|
||||||
|
(string-for-each-cursor (lambda (i) (set! r (cons i r))) "hello")
|
||||||
|
(map (lambda (sc) (string-cursor->index "hello" sc)) r)))
|
||||||
|
(test "string-for-each-cursor" '(4 3 2 1)
|
||||||
|
(let ((r '()))
|
||||||
|
(string-for-each-cursor (lambda (i) (set! r (cons i r))) "hello" 1)
|
||||||
|
(map (lambda (sc) (string-cursor->index "hello" sc)) r)))
|
||||||
|
(test "string-for-each-cursor" '(2 1)
|
||||||
|
(let ((r '()))
|
||||||
|
(string-for-each-cursor (lambda (i) (set! r (cons i r))) "hello" 1 3)
|
||||||
|
(map (lambda (sc) (string-cursor->index "hello" sc)) r)))
|
||||||
|
|
||||||
|
(test "string-replicate" "cdefab"
|
||||||
|
(string-replicate "abcdef" 2 8))
|
||||||
|
(test "string-replicate" "efabcd"
|
||||||
|
(string-replicate "abcdef" -2 4))
|
||||||
|
(test "string-replicate" "abcabca"
|
||||||
|
(string-replicate "abc" 0 7))
|
||||||
|
(test "string-replicate" "defdefd"
|
||||||
|
(string-replicate "abcdefg" 0 7 3 6))
|
||||||
|
(test "string-replicate" ""
|
||||||
|
(string-replicate "abcdefg" 9 9 3 6))
|
||||||
|
|
||||||
|
(test "string-replace" "abcdXYZghi"
|
||||||
|
(string-replace "abcdefghi" "XYZ" 4 6))
|
||||||
|
(test "string-replace" "abcdZghi"
|
||||||
|
(string-replace "abcdefghi" "XYZ" 4 6 2))
|
||||||
|
(test "string-replace" "abcdZefghi"
|
||||||
|
(string-replace "abcdefghi" "XYZ" 4 4 2))
|
||||||
|
(test "string-replace" "abcdefghi"
|
||||||
|
(string-replace "abcdefghi" "XYZ" 4 4 1 1))
|
||||||
|
(test "string-replace" "abcdhi"
|
||||||
|
(string-replace "abcdefghi" "" 4 7))
|
||||||
|
|
||||||
|
;; (test "string-tokenize" '("Help" "make" "programs" "run," "run," "RUN!")
|
||||||
|
;; (string-tokenize "Help make programs run, run, RUN!"))
|
||||||
|
;; (test "string-tokenize" '("Help" "make" "programs" "run" "run" "RUN")
|
||||||
|
;; (string-tokenize "Help make programs run, run, RUN!"
|
||||||
|
;; char-set:letter))
|
||||||
|
;; (test "string-tokenize" '("programs" "run" "run" "RUN")
|
||||||
|
;; (string-tokenize "Help make programs run, run, RUN!"
|
||||||
|
;; char-set:letter 10))
|
||||||
|
;; (test "string-tokenize" '("elp" "make" "programs" "run" "run")
|
||||||
|
;; (string-tokenize "Help make programs run, run, RUN!"
|
||||||
|
;; char-set:lower-case))
|
||||||
|
|
||||||
|
(test "string-filter" "rrrr"
|
||||||
|
(string-filter (lambda (ch) (eqv? ch #\r))
|
||||||
|
"Help make programs run, run, RUN!"))
|
||||||
|
(test "string-filter" "HelpmakeprogramsrunrunRUN"
|
||||||
|
(string-filter char-alphabetic? "Help make programs run, run, RUN!"))
|
||||||
|
|
||||||
|
(test "string-filter" "programsrunrun"
|
||||||
|
(string-filter (lambda (c) (char-lower-case? c))
|
||||||
|
"Help make programs run, run, RUN!"
|
||||||
|
10))
|
||||||
|
(test "string-filter" ""
|
||||||
|
(string-filter (lambda (c) (char-lower-case? c)) ""))
|
||||||
|
(test "string-remove" "Help make pogams un, un, RUN!"
|
||||||
|
(string-remove (lambda (ch) (eqv? ch #\r))
|
||||||
|
"Help make programs run, run, RUN!"))
|
||||||
|
(test "string-remove" " , , !"
|
||||||
|
(string-remove char-alphabetic? "Help make programs run, run, RUN!"))
|
||||||
|
(test "string-remove" " , , RUN!"
|
||||||
|
(string-remove (lambda (c) (char-lower-case? c))
|
||||||
|
"Help make programs run, run, RUN!"
|
||||||
|
10))
|
||||||
|
(test "string-remove" ""
|
||||||
|
(string-remove (lambda (c) (char-lower-case? c)) ""))
|
||||||
|
|
||||||
|
;;; Regression tests: check that reported bugs have been fixed
|
||||||
|
|
||||||
|
;; From: Matthias Radestock <matthias@sorted.org>
|
||||||
|
;; Date: Wed, 10 Dec 2003 21:05:22 +0100
|
||||||
|
;
|
||||||
|
;; Chris Double has found the following bug in the reference implementation:
|
||||||
|
;
|
||||||
|
;; (string-contains "xabc" "ab") => 1 ;good
|
||||||
|
;; (string-contains "aabc" "ab") => #f ;bad
|
||||||
|
;
|
||||||
|
;; Matthias.
|
||||||
|
|
||||||
|
(test "string-contains" 1
|
||||||
|
(string-cursor->index "aabc" (string-contains "aabc" "ab")))
|
||||||
|
|
||||||
|
(test "string-contains" 5
|
||||||
|
(string-cursor->index "ababdabdabxxas" (string-contains "ababdabdabxxas" "abdabx")))
|
||||||
|
|
||||||
|
;; (message continues)
|
||||||
|
;;
|
||||||
|
;; PS: There is also an off-by-one error in the bounds check of the
|
||||||
|
;; unoptimized version of string-contains that is included as commented out
|
||||||
|
;; code in the reference implementation. This breaks things like
|
||||||
|
;; (string-contains "xab" "ab") and (string-contains "ab" "ab").
|
||||||
|
|
||||||
|
;; This off-by-one bug has been fixed in the comments of the version
|
||||||
|
;; of SRFI-13 shipped with Larceny. In a version of the code without
|
||||||
|
;; the fix the following test will catch the bug:
|
||||||
|
|
||||||
|
(test "string-contains" 0
|
||||||
|
(string-cursor->index "ab" (string-contains "ab" "ab")))
|
||||||
|
|
||||||
|
(test-end))))
|
||||||
Loading…
Add table
Reference in a new issue