#cs(module srfi-13-local mzscheme
(require "common.ss")
(require "myenv.ss")
(cond-expand
(bigloo
(define (string-xcopy! target tstart s sfrom sto)
(blit-string! s sfrom target tstart (- sto sfrom))))
(else
(define (string-xcopy! target tstart s sfrom sto)
(do ((i sfrom (inc i)) (j tstart (inc j)))
((>= i sto))
(string-set! target j (string-ref s i)))))
)
(define (string-concatenate-reverse strs final end)
(if (null? strs) (substring final 0 end)
(let*
((total-len
(let loop ((len end) (lst strs))
(if (null? lst) len
(loop (+ len (string-length (car lst))) (cdr lst)))))
(result (make-string total-len)))
(let loop ((len end) (j total-len) (str final) (lst strs))
(string-xcopy! result (- j len) str 0 len)
(if (null? lst) result
(loop (string-length (car lst)) (- j len)
(car lst) (cdr lst)))))))
(define (string-concatenate/shared strs)
(cond
((null? strs) "") ((null? (cdr strs)) (car strs))
(else
(let*
((total-len
(let loop ((len (string-length (car strs))) (lst (cdr strs)))
(if (null? lst) len
(loop (+ len (string-length (car lst))) (cdr lst)))))
(result (make-string total-len)))
(let loop ((j 0) (str (car strs)) (lst (cdr strs)))
(string-xcopy! result j str 0 (string-length str))
(if (null? lst) result
(loop (+ j (string-length str))
(car lst) (cdr lst))))))))
(define (string-concatenate-reverse/shared strs)
(cond
((null? strs) "") ((null? (cdr strs)) (car strs))
(else
(string-concatenate-reverse (cdr strs)
(car strs) (string-length (car strs))))))
(define (string-index str a-char)
(let loop ((pos 0))
(cond
((>= pos (string-length str)) #f) ((char=? a-char (string-ref str pos)) pos)
(else (loop (inc pos))))))
(define (string-index-right str a-char)
(let loop ((pos (dec (string-length str))))
(cond
((negative? pos) #f) ((char=? a-char (string-ref str pos)) pos)
(else (loop (dec pos))))))
(define (string-contains str pattern)
(let* ((pat-len (string-length pattern))
(search-span (- (string-length str) pat-len))
(c1 (if (zero? pat-len) #f (string-ref pattern 0)))
(c2 (if (<= pat-len 1) #f (string-ref pattern 1))))
(cond
((not c1) 0) ((not c2) (string-index str c1)) (else (let outer ((pos 0))
(cond
((> pos search-span) #f) ((not (char=? c1 (string-ref str pos)))
(outer (+ 1 pos))) ((not (char=? c2 (string-ref str (+ 1 pos))))
(outer (+ 1 pos))) (else (let inner ((i-pat 2) (i-str (+ 2 pos)))
(if (>= i-pat pat-len) pos (if (char=? (string-ref pattern i-pat)
(string-ref str i-str))
(inner (+ 1 i-pat) (+ 1 i-str))
(outer (+ 1 pos))))))))))))
(define (string-prefix? pattern str)
(let loop ((i 0))
(cond
((>= i (string-length pattern)) #t)
((>= i (string-length str)) #f)
((char=? (string-ref pattern i) (string-ref str i))
(loop (inc i)))
(else #f))))
(define (string-prefix-ci? pattern str)
(let loop ((i 0))
(cond
((>= i (string-length pattern)) #t)
((>= i (string-length str)) #f)
((char-ci=? (string-ref pattern i) (string-ref str i))
(loop (inc i)))
(else #f))))
(define (string-suffix? pattern str)
(let loop ((i (dec (string-length pattern))) (j (dec (string-length str))))
(cond
((negative? i) #t)
((negative? j) #f)
((char=? (string-ref pattern i) (string-ref str j))
(loop (dec i) (dec j)))
(else #f))))
(define (string-suffix-ci? pattern str)
(let loop ((i (dec (string-length pattern))) (j (dec (string-length str))))
(cond
((negative? i) #t)
((negative? j) #f)
((char-ci=? (string-ref pattern i) (string-ref str j))
(loop (dec i) (dec j)))
(else #f))))
(cond-expand
(bigloo #f) (else
(define (string-downcase str)
(do ((target-str (make-string (string-length str))) (i 0 (inc i)))
((>= i (string-length str)) target-str)
(string-set! target-str i (char-downcase (string-ref str i)))))
(define (string-upcase str)
(do ((target-str (make-string (string-length str))) (i 0 (inc i)))
((>= i (string-length str)) target-str)
(string-set! target-str i (char-upcase (string-ref str i)))))
(define (string-downcase! str)
(do ((i 0 (inc i))) ((>= i (string-length str)))
(string-set! str i (char-downcase (string-ref str i)))))
(define (string-upcase! str)
(do ((i 0 (inc i))) ((>= i (string-length str)))
(string-set! str i (char-upcase (string-ref str i)))))
))
(provide (all-defined)))