Code sample pair: SRFI-13 David A. Wheeler 18 Mar 2013 03:18 UTC

Here is a code sample pair from SRFI-13.  This is MUCH larger than previous code samples.
SRFI-13 is one of the more popular SRFIs according to:
  https://spreadsheets.google.com/pub?key=tRCHK6jWXuKMABKAfoOwWqw&output=html

As with the others, I translated the s-expressions
using "sweeten" and then tweaked the results.  I've also added to the "readable" git repository
("develop" branch) a new tool, "diff-s-sweet", that can compare an s-expression and sweet-expression
to report semantic differences.  I used that new tool to get more confidence that my tweaks were correct.

I list the sweet-expressions first.... then the s-expressions.  If you want the files, please go to the
sourceforge readable.sourceforge.net "git" repository, "develop" branch.

 --- David A. Wheeler

; sweet-expressions

; Sample SRFI-13 implementation, from:
; http://srfi.schemers.org/srfi-13/srfi-13.scm

;;; SRFI 13 string library reference implementation		-*- Scheme -*-
;;; Olin Shivers 7/2000
;;;
;;; Copyright (c) 1988-1994 Massachusetts Institute of Technology.
;;; Copyright (c) 1998, 1999, 2000 Olin Shivers. All rights reserved.
;;;   The details of the copyrights appear at the end of the file. Short
;;;   summary: BSD-style open source.

; Since we only care about the *format*, nearly all ;-comments have been
; removed from this version, to shorten it (see the original file for them).

define-syntax let-string-start+end
! syntax-rules ()
!   let-string-start+end(start(end) proc s-exp args-exp body ...)
!     receive
!       start end
!       string-parse-final-start+end proc s-exp args-exp
!       body
!       ...
!   let-string-start+end(start(end rest) proc s-exp args-exp body ...)
!     receive
!       rest start end
!       string-parse-start+end proc s-exp args-exp
!       body
!       ...

define-syntax let-string-start+end2
! syntax-rules ()
!   l-s-s+e2(start1(end1 start2 end2) proc s1 s2 args body ...)
!     let <* procv proc *>
!       let-string-start+end
!         start1 end1 rest
!         procv
!         s1
!         args
!         let-string-start+end start2(end2) procv s2 rest body ...

define string-parse-start+end(proc s args)
! if not(string?(s)) error("Non-string value" proc s)
! let <* slen $ string-length s *>
!   if pair?(args)
!     let <* start $ car args \\ args $ cdr args *>
!       if {integer?(start) and exact?(start) and {start >= 0}}
!       ! receive
!       !   end args
!       !   if pair?(args)
!       !   ! let <* end $ car args \\ args $ cdr args *>
!       !   !   if {integer?(end) and exact?(end) and {end <= slen}}
!       !   !     values end args
!       !   !     error "Illegal substring END spec" proc end s
!       !   ! values slen args
!       !   if {start <= end}
!       !   ! values args start end
!       !   ! error "Illegal substring START/END spec" proc start end s
!       ! error "Illegal substring START spec" proc start s
!     values '() 0 slen

define string-parse-final-start+end(proc s args)
! receive
!   rest start end
!   string-parse-start+end proc s args
!   if pair?(rest)
!     error "Extra arguments to procedure" proc rest
!     values start end

define substring-spec-ok?(s start end)
! and
!   string? s
!   integer? start
!   exact? start
!   integer? end
!   exact? end
!   {0 <= start}
!   {start <= end}
!   {end <= string-length(s)}

define check-substring-spec(proc s start end)
! if not(substring-spec-ok?(s start end))
!   error "Illegal substring spec." proc s start end

define substring/shared(s start . maybe-end)
! check-arg string? s substring/shared
! let <* slen $ string-length s *>
!   check-arg
!     lambda start()
!       {integer?(start) and exact?(start) and {0 <= start}}
!     start
!     substring/shared
!   %substring/shared
!     s
!     start
!     :optional
!       maybe-end
!       slen
!       lambda end()
!         and
!           integer? end
!           exact? end
!           {start <= end}
!           {end <= slen}

define %substring/shared(s start end)
! if {zero?(start) and {end = string-length(s)}}
!   s
!   substring s start end

define string-copy(s . maybe-start+end)
! let-string-start+end
!   start end
!   string-copy
!   s
!   maybe-start+end
!   substring s start end

define string-map(proc s . maybe-start+end)
! check-arg procedure? proc string-map
! let-string-start+end
!   start end
!   string-map
!   s
!   maybe-start+end
!   %string-map proc s start end

define %string-map(proc s start end)
! let* <* len {end - start} \\ ans $ make-string len *>
!   do <* i {end - 1} {i - 1} \\ j {len - 1} {j - 1} *>
!     $ {j < 0}
!     string-set! ans j proc(string-ref(s i))
!   ans

define string-map!(proc s . maybe-start+end)
! check-arg procedure? proc string-map!
! let-string-start+end
!   start end
!   string-map!
!   s
!   maybe-start+end
!   %string-map! proc s start end

define %string-map!(proc s start end)
! do <* i {end - 1} {i - 1} *>
!   $ {i < start}
!   string-set! s i proc(string-ref(s i))

define string-fold(kons knil s . maybe-start+end)
! check-arg procedure? kons string-fold
! let-string-start+end
!   start end
!   string-fold
!   s
!   maybe-start+end
!   let lp <* v knil \\ i start *>
!     if {i < end}
!       lp kons(string-ref(s i) v) {i + 1}
!       v

define string-fold-right(kons knil s . maybe-start+end)
! check-arg procedure? kons string-fold-right
! let-string-start+end
!   start end
!   string-fold-right
!   s
!   maybe-start+end
!   let lp <* v knil \\ i {end - 1} *>
!     if {i >= start}
!       lp kons(string-ref(s i) v) {i - 1}
!       v

define string-unfold(p f g seed . base+make-final)
! check-arg procedure? p string-unfold
! check-arg procedure? f string-unfold
! check-arg procedure? g string-unfold
! let-optionals*
!   base+make-final
!   base("" string?(base))
!     make-final lambda(x() "") procedure?(make-final)
!   let lp
!     chunks('())
!       nchars 0
!       chunk make-string(40)
!       chunk-len 40
!       i 0
!       seed seed
!     let lp2 <* i i \\ seed seed *>
!       if not(p(seed))
!       ! let <* c $ f seed \\ seed $ g seed *>
!       !   if {i < chunk-len}
!       !   ! begin string-set!(chunk i c) lp2({i + 1} seed)
!       !   ! let*
!       !   !   \\
!       !   !     nchars2 {chunk-len + nchars}
!       !   !     chunk-len2 min(4096 nchars2)
!       !   !     new-chunk make-string(chunk-len2)
!       !   !   string-set! new-chunk 0 c
!       !   !   lp
!       !   !     cons chunk chunks
!       !   !     {nchars + chunk-len}
!       !   !     new-chunk
!       !   !     chunk-len2
!       !   !     1
!       !   !     seed
!       ! let*
!       !   \\
!       !     final make-final(seed)
!       !     flen string-length(final)
!       !     base-len string-length(base)
!       !     j {base-len + nchars + i}
!       !     ans make-string{j + flen}
!       !   %string-copy! ans j final 0 flen
!       !   let <* j {j - i} *>
!       !   ! %string-copy! ans j chunk 0 i
!       !   ! let lp <* j j \\ chunks chunks *>
!       !   !   if pair?(chunks)
!       !   !   ! let*
!       !   !   !   \\
!       !   !   !     chunk car(chunks)
!       !   !   !     chunks cdr(chunks)
!       !   !   !     chunk-len string-length(chunk)
!       !   !   !     j {j - chunk-len}
!       !   !   !   %string-copy! ans j chunk 0 chunk-len
!       !   !   !   lp j chunks
!       !   %string-copy! ans 0 base 0 base-len
!       !   ans

define string-unfold-right(p f g seed . base+make-final)
! let-optionals*
!   base+make-final
!   base("" string?(base))
!     make-final lambda(x() "") procedure?(make-final)
!   let lp
!     chunks('())
!       nchars 0
!       chunk make-string(40)
!       chunk-len 40
!       i 40
!       seed seed
!     let lp2
!       i(i) seed(seed)
!       if not(p(seed))
!       ! let <* c $ f seed \\ seed $ g seed *>
!       !   if {i > 0}
!       !   ! let <* i {i - 1} *>
!       !   !   string-set! chunk i c
!       !   !   lp2 i seed
!       !   ! let*
!       !   !   \\
!       !   !     nchars2 {chunk-len + nchars}
!       !   !     chunk-len2 min(4096 nchars2)
!       !   !     new-chunk make-string(chunk-len2)
!       !   !     i {chunk-len2 - 1}
!       !   !   string-set! new-chunk i c
!       !   !   lp
!       !   !     cons chunk chunks
!       !   !     {nchars + chunk-len}
!       !   !     new-chunk
!       !   !     chunk-len2
!       !   !     i
!       !   !     seed
!       ! let*
!       !   \\
!       !     final make-final(seed)
!       !     flen string-length(final)
!       !     base-len string-length(base)
!       !     chunk-used {chunk-len - i}
!       !     j {base-len + nchars + chunk-used}
!       !     ans make-string{j + flen}
!       !   %string-copy! ans 0 final 0 flen
!       !   %string-copy! ans flen chunk i chunk-len
!       !   let lp <* j {flen + chunk-used} \\ chunks chunks *>
!       !   ! if pair?(chunks)
!       !   !   let*
!       !   !     \\
!       !   !       chunk car(chunks)
!       !   !       chunks cdr(chunks)
!       !   !       chunk-len string-length(chunk)
!       !   !     %string-copy! ans j chunk 0 chunk-len
!       !   !     lp {j + chunk-len} chunks
!       !   !   %string-copy! ans j base 0 base-len
!       !   ans

define string-for-each(proc s . maybe-start+end)
! check-arg procedure? proc string-for-each
! let-string-start+end
!   start end
!   string-for-each
!   s
!   maybe-start+end
!   let lp <* i start *>
!     if {i < end}
!       begin proc(string-ref(s i)) lp{i + 1}

define string-for-each-index(proc s . maybe-start+end)
! check-arg procedure? proc string-for-each-index
! let-string-start+end
!   start end
!   string-for-each-index
!   s
!   maybe-start+end
!   let lp <* i start *>
!     if {i < end}
!       begin proc(i) lp{i + 1}

define string-every(criterion s . maybe-start+end)
! let-string-start+end
!   start end
!   string-every
!   s
!   maybe-start+end
!   cond
!     char?(criterion)
!       let lp <* i start *>
!       ! or
!       !   {i >= end}
!       !   {char=?(criterion string-ref(s i)) and lp{i + 1}}
!     char-set?(criterion)
!       let lp <* i start *>
!       ! or
!       !   {i >= end}
!       !   and
!       !     char-set-contains? criterion string-ref(s i)
!       !     lp {i + 1}
!     procedure?(criterion)
!       or
!         {start = end}
!         let lp <* i start *>
!         ! let <* c $ string-ref s i \\ i1 {i + 1} *>
!         !   if {i1 = end}
!         !   ! criterion c
!         !   ! {criterion(c) and lp(i1)}
!     else
!       error
!         "Second param is neither char-set, char, or predicate procedure."
!         string-every
!         criterion

define string-any(criterion s . maybe-start+end)
! let-string-start+end
!   start end
!   string-any
!   s
!   maybe-start+end
!   cond
!     char?(criterion)
!       let lp <* i start *>
!       ! and
!       !   {i < end}
!       !   {char=?(criterion string-ref(s i)) or lp{i + 1}}
!     char-set?(criterion)
!       let lp <* i start *>
!       ! and
!       !   {i < end}
!       !   or
!       !     char-set-contains? criterion string-ref(s i)
!       !     lp {i + 1}
!     procedure?(criterion)
!       and
!         {start < end}
!         let lp <* i start *>
!         ! let <* c $ string-ref s i \\ i1 {i + 1} *>
!         !   if {i1 = end}
!         !   ! criterion c
!         !   ! {criterion(c) or lp(i1)}
!     else
!       error
!         "Second param is neither char-set, char, or predicate procedure."
!         string-any
!         criterion

define string-tabulate(proc len)
! check-arg procedure? proc string-tabulate
! check-arg
!   lambda val()
!     {integer?(val) and exact?(val) and {0 <= val}}
!   len
!   string-tabulate
! let <* s $ make-string len *>
!   do <* i {len - 1} {i - 1} *>
!     $ {i < 0}
!     string-set! s i proc(i)
!   s

define %string-prefix-length(s1 start1 end1 s2 start2 end2)
! let*
!   \\
!     delta min({end1 - start1} {end2 - start2})
!     end1 {start1 + delta}
!   if {eq?(s1 s2) and {start1 = start2}}
!     delta
!     let lp <* i start1 \\ j start2 *>
!       if {{i >= end1} or not(char=?(string-ref(s1 i) string-ref(s2 j)))}
!       ! {i - start1}
!       ! lp {i + 1} {j + 1}

define %string-suffix-length(s1 start1 end1 s2 start2 end2)
! let*
!   \\
!     delta min({end1 - start1} {end2 - start2})
!     start1 {end1 - delta}
!   if {eq?(s1 s2) and {end1 = end2}}
!     delta
!     let lp <* i {end1 - 1} \\ j {end2 - 1} *>
!       if {{i < start1} or not(char=?(string-ref(s1 i) string-ref(s2 j)))}
!       ! {{end1 - i} - 1}
!       ! lp {i - 1} {j - 1}

define %string-prefix-length-ci(s1 start1 end1 s2 start2 end2)
! let*
!   \\
!     delta min({end1 - start1} {end2 - start2})
!     end1 {start1 + delta}
!   if {eq?(s1 s2) and {start1 = start2}}
!     delta
!     let lp <* i start1 \\ j start2 *>
!       if {{i >= end1} or not(char-ci=?(string-ref(s1 i) string-ref(s2 j)))}
!       ! {i - start1}
!       ! lp {i + 1} {j + 1}

define %string-suffix-length-ci(s1 start1 end1 s2 start2 end2)
! let*
!   \\
!     delta min({end1 - start1} {end2 - start2})
!     start1 {end1 - delta}
!   if {eq?(s1 s2) and {end1 = end2}}
!     delta
!     let lp <* i {end1 - 1} \\ j {end2 - 1} *>
!       if
!         or
!           {i < start1}
!           not char-ci=?(string-ref(s1 i) string-ref(s2 j))
!         {{end1 - i} - 1}
!         lp {i - 1} {j - 1}

define string-prefix-length(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string-prefix-length
!   s1
!   s2
!   maybe-starts+ends
!   %string-prefix-length s1 start1 end1 s2 start2 end2

define string-suffix-length(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string-suffix-length
!   s1
!   s2
!   maybe-starts+ends
!   %string-suffix-length s1 start1 end1 s2 start2 end2

define string-prefix-length-ci(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string-prefix-length-ci
!   s1
!   s2
!   maybe-starts+ends
!   %string-prefix-length-ci s1 start1 end1 s2 start2 end2

define string-suffix-length-ci(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string-suffix-length-ci
!   s1
!   s2
!   maybe-starts+ends
!   %string-suffix-length-ci s1 start1 end1 s2 start2 end2

define string-prefix?(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string-prefix?
!   s1
!   s2
!   maybe-starts+ends
!   %string-prefix? s1 start1 end1 s2 start2 end2

define string-suffix?(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string-suffix?
!   s1
!   s2
!   maybe-starts+ends
!   %string-suffix? s1 start1 end1 s2 start2 end2

define string-prefix-ci?(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string-prefix-ci?
!   s1
!   s2
!   maybe-starts+ends
!   %string-prefix-ci? s1 start1 end1 s2 start2 end2

define string-suffix-ci?(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string-suffix-ci?
!   s1
!   s2
!   maybe-starts+ends
!   %string-suffix-ci? s1 start1 end1 s2 start2 end2

;;; Here are the internal routines that do the real work.

define %string-prefix?(s1 start1 end1 s2 start2 end2)
! let <* len1 {end1 - start1} *>
!   and
!     {len1 <= {end2 - start2}}
!     {%string-prefix-length(s1 start1 end1 s2 start2 end2) = len1}

define %string-suffix?(s1 start1 end1 s2 start2 end2)
! let <* len1 {end1 - start1} *>
!   and
!     {len1 <= {end2 - start2}}
!     {len1 = %string-suffix-length(s1 start1 end1 s2 start2 end2)}

define %string-prefix-ci?(s1 start1 end1 s2 start2 end2)
! let <* len1 {end1 - start1} *>
!   and
!     {len1 <= {end2 - start2}}
!     {len1 = %string-prefix-length-ci(s1 start1 end1 s2 start2 end2)}

define %string-suffix-ci?(s1 start1 end1 s2 start2 end2)
! let <* len1 {end1 - start1} *>
!   and
!     {len1 <= {end2 - start2}}
!     {len1 = %string-suffix-length-ci(s1 start1 end1 s2 start2 end2)}

define %string-compare(s1 start1 end1 s2 start2 end2 proc< proc= proc>)
! let <* size1 {end1 - start1} \\ size2 {end2 - start2} *>
!   let <* match $ %string-prefix-length s1 start1 end1 s2 start2 end2 *>
!     if {match = size1}
!       if({match = size2} proc= proc<) end1
!       \\
!         if {match = size2}
!         ! proc>
!         ! if
!         !   char<?
!         !     string-ref s1 {start1 + match}
!         !     string-ref s2 {start2 + match}
!         !   proc<
!         !   proc>
!         {match + start1}

define %string-compare-ci(s1 start1 end1 s2 start2 end2 proc< proc= proc>)
! let <* size1 {end1 - start1} \\ size2 {end2 - start2} *>
!   let <* match $ %string-prefix-length-ci s1 start1 end1 s2 start2 end2 *>
!     if {match = size1}
!       if({match = size2} proc= proc<) end1
!       \\
!         if {match = size2}
!         ! proc>
!         ! if
!         !   char-ci<?
!         !     string-ref s1 {start1 + match}
!         !     string-ref s2 {start2 + match}
!         !   proc<
!         !   proc>
!         {start1 + match}

define string-compare(s1 s2 proc< proc= proc> . maybe-starts+ends)
! check-arg procedure? proc< string-compare
! check-arg procedure? proc= string-compare
! check-arg procedure? proc> string-compare
! let-string-start+end2
!   start1 end1 start2 end2
!   string-compare
!   s1
!   s2
!   maybe-starts+ends
!   %string-compare
!     s1
!     start1
!     end1
!     s2
!     start2
!     end2
!     proc<
!     proc=
!     proc>

define string-compare-ci(s1 s2 proc< proc= proc> . maybe-starts+ends)
! check-arg procedure? proc< string-compare-ci
! check-arg procedure? proc= string-compare-ci
! check-arg procedure? proc> string-compare-ci
! let-string-start+end2
!   start1 end1 start2 end2
!   string-compare-ci
!   s1
!   s2
!   maybe-starts+ends
!   %string-compare-ci
!     s1
!     start1
!     end1
!     s2
!     start2
!     end2
!     proc<
!     proc=
!     proc>

define string=(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string=
!   s1
!   s2
!   maybe-starts+ends
!   and
!     {{end1 - start1} = {end2 - start2}}
!     or
!       {eq?(s1 s2) and {start1 = start2}}
!       %string-compare
!         s1
!         start1
!         end1
!         s2
!         start2
!         end2
!         lambda i() #f
!         values
!         lambda i() #f

define string<>(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string<>
!   s1
!   s2
!   maybe-starts+ends
!   or
!     not {{end1 - start1} = {end2 - start2}}
!     and
!       not {eq?(s1 s2) and {start1 = start2}}
!       %string-compare
!         s1
!         start1
!         end1
!         s2
!         start2
!         end2
!         values
!         lambda i() #f
!         values

define string<(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string<
!   s1
!   s2
!   maybe-starts+ends
!   if {eq?(s1 s2) and {start1 = start2}}
!     {end1 < end2}
!     %string-compare
!       s1
!       start1
!       end1
!       s2
!       start2
!       end2
!       values
!       lambda i() #f
!       lambda i() #f

define string>(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string>
!   s1
!   s2
!   maybe-starts+ends
!   if {eq?(s1 s2) and {start1 = start2}}
!     {end1 > end2}
!     %string-compare
!       s1
!       start1
!       end1
!       s2
!       start2
!       end2
!       lambda i() #f
!       lambda i() #f
!       values

define string<=(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string<=
!   s1
!   s2
!   maybe-starts+ends
!   if {eq?(s1 s2) and {start1 = start2}}
!     {end1 <= end2}
!     %string-compare
!       s1
!       start1
!       end1
!       s2
!       start2
!       end2
!       values
!       values
!       lambda i() #f

define string>=(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string>=
!   s1
!   s2
!   maybe-starts+ends
!   if {eq?(s1 s2) and {start1 = start2}}
!     {end1 >= end2}
!     %string-compare
!       s1
!       start1
!       end1
!       s2
!       start2
!       end2
!       lambda i() #f
!       values
!       values

define string-ci=(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string-ci=
!   s1
!   s2
!   maybe-starts+ends
!   and
!     {{end1 - start1} = {end2 - start2}}
!     or
!       {eq?(s1 s2) and {start1 = start2}}
!       %string-compare-ci
!         s1
!         start1
!         end1
!         s2
!         start2
!         end2
!         lambda i() #f
!         values
!         lambda i() #f

define string-ci<>(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string-ci<>
!   s1
!   s2
!   maybe-starts+ends
!   or
!     not {{end1 - start1} = {end2 - start2}}
!     and
!       not {eq?(s1 s2) and {start1 = start2}}
!       %string-compare-ci
!         s1
!         start1
!         end1
!         s2
!         start2
!         end2
!         values
!         lambda i() #f
!         values

define string-ci<(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string-ci<
!   s1
!   s2
!   maybe-starts+ends
!   if {eq?(s1 s2) and {start1 = start2}}
!     {end1 < end2}
!     %string-compare-ci
!       s1
!       start1
!       end1
!       s2
!       start2
!       end2
!       values
!       lambda i() #f
!       lambda i() #f

define string-ci>(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string-ci>
!   s1
!   s2
!   maybe-starts+ends
!   if {eq?(s1 s2) and {start1 = start2}}
!     {end1 > end2}
!     %string-compare-ci
!       s1
!       start1
!       end1
!       s2
!       start2
!       end2
!       lambda i() #f
!       lambda i() #f
!       values

define string-ci<=(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string-ci<=
!   s1
!   s2
!   maybe-starts+ends
!   if {eq?(s1 s2) and {start1 = start2}}
!     {end1 <= end2}
!     %string-compare-ci
!       s1
!       start1
!       end1
!       s2
!       start2
!       end2
!       values
!       values
!       lambda i() #f

define string-ci>=(s1 s2 . maybe-starts+ends)
! let-string-start+end2
!   start1 end1 start2 end2
!   string-ci>=
!   s1
!   s2
!   maybe-starts+ends
!   if {eq?(s1 s2) and {start1 = start2}}
!     {end1 >= end2}
!     %string-compare-ci
!       s1
!       start1
!       end1
!       s2
!       start2
!       end2
!       lambda i() #f
!       values
!       values

define %string-hash(s char->int bound start end)
! let
!   \\
!     iref $ lambda s(i) char->int(string-ref(s i))
!     mask let(lp (i(65536)) if({i >= bound} {i - 1} lp{i + i}))
!   let lp <* i start \\ ans 0 *>
!     if {i >= end}
!       modulo ans bound
!       lp {i + 1} bitwise-and(mask {{37 * ans} + iref(s i)})

define string-hash(s . maybe-bound+start+end)
! let-optionals*
!   maybe-bound+start+end
!   bound(4194304 {integer?(bound) and exact?(bound) and {0 <= bound}})
!     rest
!   let <* bound $ if zero?(bound) 4194304 bound *>
!     let-string-start+end
!       start end
!       string-hash
!       s
!       rest
!       %string-hash s char->integer bound start end

define string-hash-ci(s . maybe-bound+start+end)
! let-optionals*
!   maybe-bound+start+end
!   bound(4194304 {integer?(bound) and exact?(bound) and {0 <= bound}})
!     rest
!   let <* bound $ if zero?(bound) 4194304 bound *>
!     let-string-start+end
!       start end
!       string-hash-ci
!       s
!       rest
!       %string-hash
!         s
!         lambda c() char->integer(char-downcase(c))
!         bound
!         start
!         end

define string-upcase(s . maybe-start+end)
! let-string-start+end
!   start end
!   string-upcase
!   s
!   maybe-start+end
!   %string-map char-upcase s start end

define string-upcase!(s . maybe-start+end)
! let-string-start+end
!   start end
!   string-upcase!
!   s
!   maybe-start+end
!   %string-map! char-upcase s start end

define string-downcase(s . maybe-start+end)
! let-string-start+end
!   start end
!   string-downcase
!   s
!   maybe-start+end
!   %string-map char-downcase s start end

define string-downcase!(s . maybe-start+end)
! let-string-start+end
!   start end
!   string-downcase!
!   s
!   maybe-start+end
!   %string-map! char-downcase s start end

define %string-titlecase!(s start end)
! let lp <* i start *>
!   cond
!     string-index(s char-cased? i end)
!       =>
!       lambda i()
!       ! string-set! s i char-titlecase(string-ref(s i))
!       ! let <* i1 {i + 1} *>
!       !   cond
!       !     string-skip(s char-cased? i1 end)
!       !       =>
!       !       lambda j()
!       !       ! string-downcase! s i1 j
!       !       ! lp {j + 1}
!       !     else string-downcase!(s i1 end)

define string-titlecase!(s . maybe-start+end)
! let-string-start+end
!   start end
!   string-titlecase!
!   s
!   maybe-start+end
!   %string-titlecase! s start end

define string-titlecase(s . maybe-start+end)
! let-string-start+end
!   start end
!   string-titlecase!
!   s
!   maybe-start+end
!   let <* ans $ substring s start end *>
!     %string-titlecase! ans 0 {end - start}
!     ans

define string-take(s n)
! check-arg string? s string-take
! check-arg
!   lambda val()
!     and
!       integer? n
!       exact? n
!       {0 <= n <= string-length(s)}
!   n
!   string-take
! %substring/shared s 0 n

define string-take-right(s n)
! check-arg string? s string-take-right
! let <* len $ string-length s *>
!   check-arg
!     lambda val()
!       {integer?(n) and exact?(n) and {0 <= n <= len}}
!     n
!     string-take-right
!   %substring/shared s {len - n} len

define string-drop(s n)
! check-arg string? s string-drop
! let <* len $ string-length s *>
!   check-arg
!     lambda val()
!       {integer?(n) and exact?(n) and {0 <= n <= len}}
!     n
!     string-drop
!   %substring/shared s n len

define string-drop-right(s n)
! check-arg string? s string-drop-right
! let <* len $ string-length s *>
!   check-arg
!     lambda val()
!       {integer?(n) and exact?(n) and {0 <= n <= len}}
!     n
!     string-drop-right
!   %substring/shared s 0 {len - n}

define string-trim(s . criterion+start+end)
! let-optionals*
!   criterion+start+end
!   criterion(char-set:whitespace) rest
!   let-string-start+end
!     start end
!     string-trim
!     s
!     rest
!     cond
!       string-skip(s criterion start end)
!         =>
!         lambda i() %substring/shared(s i end)
!       else ""

define string-trim-right(s . criterion+start+end)
! let-optionals*
!   criterion+start+end
!   criterion(char-set:whitespace) rest
!   let-string-start+end
!     start end
!     string-trim-right
!     s
!     rest
!     cond
!       string-skip-right(s criterion start end)
!         =>
!         lambda i() %substring/shared(s 0 {1 + i})
!       else ""

define string-trim-both(s . criterion+start+end)
! let-optionals*
!   criterion+start+end
!   criterion(char-set:whitespace) rest
!   let-string-start+end
!     start end
!     string-trim-both
!     s
!     rest
!     cond
!       string-skip(s criterion start end)
!         =>
!         lambda i()
!         ! %substring/shared
!         !   s
!         !   i
!         !   {1 + string-skip-right(s criterion i end)}
!       else ""

define string-pad-right(s n . char+start+end)
! let-optionals*
!   char+start+end
!   char(#\space char?(char)) rest
!   let-string-start+end
!     start end
!     string-pad-right
!     s
!     rest
!     check-arg
!       lambda n()
!       ! {integer?(n) and exact?(n) and {0 <= n}}
!       n
!       string-pad-right
!     let <* len {end - start} *>
!       if {n <= len}
!       ! %substring/shared s start {start + n}
!       ! let <* ans $ make-string n char *>
!       !   %string-copy! ans 0 s start end
!       !   ans

define string-pad(s n . char+start+end)
! let-optionals*
!   char+start+end
!   char(#\space char?(char)) rest
!   let-string-start+end
!     start end
!     string-pad
!     s
!     rest
!     check-arg
!       lambda n()
!       ! {integer?(n) and exact?(n) and {0 <= n}}
!       n
!       string-pad
!     let <* len {end - start} *>
!       if {n <= len}
!       ! %substring/shared s {end - n} end
!       ! let <* ans $ make-string n char *>
!       !   %string-copy! ans {n - len} s start end
!       !   ans

define string-delete(criterion s . maybe-start+end)
! let-string-start+end
!   start end
!   string-delete
!   s
!   maybe-start+end
!   if procedure?(criterion)
!     let*
!       \\
!         slen {end - start}
!         temp make-string(slen)
!         ans-len
!           string-fold
!             lambda c(i)
!             ! if criterion(c)
!             !   i
!             !   begin string-set!(temp i c) {i + 1}
!             0
!             s
!             start
!             end
!       if {ans-len = slen} temp substring(temp 0 ans-len)
!     let*
!       \\
!         cset
!           cond
!             char-set?(criterion) criterion
!             char?(criterion) char-set(criterion)
!             else
!               error
!                 "string-delete criterion not predicate, char or char-set"
!                 criterion
!         len
!           string-fold
!             lambda c(i)
!             ! if char-set-contains?(cset c) i {i + 1}
!             0
!             s
!             start
!             end
!         ans make-string(len)
!       string-fold
!         lambda c(i)
!         ! if char-set-contains?(cset c)
!         !   i
!         !   begin string-set!(ans i c) {i + 1}
!         0
!         s
!         start
!         end
!       ans

define string-filter(criterion s . maybe-start+end)
! let-string-start+end
!   start end
!   string-filter
!   s
!   maybe-start+end
!   if procedure?(criterion)
!     let*
!       \\
!         slen {end - start}
!         temp make-string(slen)
!         ans-len
!           string-fold
!             lambda c(i)
!             ! if criterion(c)
!             !   begin string-set!(temp i c) {i + 1}
!             !   i
!             0
!             s
!             start
!             end
!       if {ans-len = slen} temp substring(temp 0 ans-len)
!     let*
!       \\
!         cset
!           cond
!             char-set?(criterion) criterion
!             char?(criterion) char-set(criterion)
!             else
!               error
!                 "string-delete criterion not predicate, char or char-set"
!                 criterion
!         len
!           string-fold
!             lambda c(i)
!             ! if char-set-contains?(cset c) {i + 1} i
!             0
!             s
!             start
!             end
!         ans make-string(len)
!       string-fold
!         lambda c(i)
!         ! if char-set-contains?(cset c)
!         !   begin string-set!(ans i c) {i + 1}
!         !   i
!         0
!         s
!         start
!         end
!       ans

define string-index(str criterion . maybe-start+end)
! let-string-start+end
!   start end
!   string-index
!   str
!   maybe-start+end
!   cond
!     char?(criterion)
!       let lp <* i start *>
!       ! and
!       !   {i < end}
!       !   if char=?(criterion string-ref(str i)) i lp{i + 1}
!     char-set?(criterion)
!       let lp <* i start *>
!       ! and
!       !   {i < end}
!       !   if char-set-contains?(criterion string-ref(str i))
!       !   ! i
!       !   ! lp {i + 1}
!     procedure?(criterion)
!       let lp <* i start *>
!       ! and
!       !   {i < end}
!       !   if criterion(string-ref(str i)) i lp{i + 1}
!     else
!       error
!         "Second param is neither char-set, char, or predicate procedure."
!         string-index
!         criterion

define string-index-right(str criterion . maybe-start+end)
! let-string-start+end
!   start end
!   string-index-right
!   str
!   maybe-start+end
!   cond
!     char?(criterion)
!       let lp <* i {end - 1} *>
!       ! and
!       !   {i >= start}
!       !   if char=?(criterion string-ref(str i)) i lp{i - 1}
!     char-set?(criterion)
!       let lp <* i {end - 1} *>
!       ! and
!       !   {i >= start}
!       !   if char-set-contains?(criterion string-ref(str i))
!       !   ! i
!       !   ! lp {i - 1}
!     procedure?(criterion)
!       let lp <* i {end - 1} *>
!       ! and
!       !   {i >= start}
!       !   if criterion(string-ref(str i)) i lp{i - 1}
!     else
!       error
!         "Second param is neither char-set, char, or predicate procedure."
!         string-index-right
!         criterion

define string-skip(str criterion . maybe-start+end)
! let-string-start+end
!   start end
!   string-skip
!   str
!   maybe-start+end
!   cond
!     char?(criterion)
!       let lp <* i start *>
!       ! and
!       !   {i < end}
!       !   if char=?(criterion string-ref(str i)) lp{i + 1} i
!     char-set?(criterion)
!       let lp <* i start *>
!       ! and
!       !   {i < end}
!       !   if char-set-contains?(criterion string-ref(str i))
!       !   ! lp {i + 1}
!       !   ! i
!     procedure?(criterion)
!       let lp <* i start *>
!       ! and
!       !   {i < end}
!       !   if criterion(string-ref(str i)) lp{i + 1} i
!     else
!       error
!         "Second param is neither char-set, char, or predicate procedure."
!         string-skip
!         criterion

define string-skip-right(str criterion . maybe-start+end)
! let-string-start+end
!   start end
!   string-skip-right
!   str
!   maybe-start+end
!   cond
!     char?(criterion)
!       let lp <* i {end - 1} *>
!       ! and
!       !   {i >= start}
!       !   if char=?(criterion string-ref(str i)) lp{i - 1} i
!     char-set?(criterion)
!       let lp <* i {end - 1} *>
!       ! and
!       !   {i >= start}
!       !   if char-set-contains?(criterion string-ref(str i))
!       !   ! lp {i - 1}
!       !   ! i
!     procedure?(criterion)
!       let lp <* i {end - 1} *>
!       ! and
!       !   {i >= start}
!       !   if criterion(string-ref(str i)) lp{i - 1} i
!     else
!       error
!         "CRITERION param is neither char-set or char."
!         string-skip-right
!         criterion

define string-count(s criterion . maybe-start+end)
! let-string-start+end
!   start end
!   string-count
!   s
!   maybe-start+end
!   cond
!     char?(criterion)
!       do
!         i(start {i + 1})
!           count
!             0
!             if char=?(criterion string-ref(s i)) {count + 1} count
!         {i >= end} count
!     char-set?(criterion)
!       do
!         i(start {i + 1})
!           count
!             0
!             if char-set-contains?(criterion string-ref(s i))
!             ! {count + 1}
!             ! count
!         {i >= end} count
!     procedure?(criterion)
!       do
!         i(start {i + 1})
!           count 0 if(criterion(string-ref(s i)) {count + 1} count)
!         {i >= end} count
!     else
!       error
!         "CRITERION param is neither char-set or char."
!         string-count
!         criterion

define string-fill!(s char . maybe-start+end)
! check-arg char? char string-fill!
! let-string-start+end
!   start end
!   string-fill!
!   s
!   maybe-start+end
!   do <* i {end - 1} {i - 1} *>
!     $ {i < start}
!     string-set! s i char

define string-copy!(to tstart from . maybe-fstart+fend)
! let-string-start+end
!   fstart fend
!   string-copy!
!   from
!   maybe-fstart+fend
!   check-arg integer? tstart string-copy!
!   check-substring-spec
!     string-copy!
!     to
!     tstart
!     {tstart + {fend - fstart}}
!   %string-copy! to tstart from fstart fend

;;; Library-internal routine
define %string-copy!(to tstart from fstart fend)
! if {fstart > tstart}
!   do <* i fstart {i + 1} \\ j tstart {j + 1} *>
!     $ {i >= fend}
!     string-set! to j string-ref(from i)
!   do
!     \\
!       i {fend - 1} {i - 1}
!       j {-1 + tstart + {fend - fstart}} {j - 1}
!     $ {i < fstart}
!     string-set! to j string-ref(from i)

define string-contains(text pattern . maybe-starts+ends)
! let-string-start+end2
!   t-start t-end p-start p-end
!   string-contains
!   text
!   pattern
!   maybe-starts+ends
!   %kmp-search
!     pattern
!     text
!     char=?
!     p-start
!     p-end
!     t-start
!     t-end

define string-contains-ci(text pattern . maybe-starts+ends)
! let-string-start+end2
!   t-start t-end p-start p-end
!   string-contains-ci
!   text
!   pattern
!   maybe-starts+ends
!   %kmp-search
!     pattern
!     text
!     char-ci=?
!     p-start
!     p-end
!     t-start
!     t-end

;;; Knuth-Morris-Pratt string searching

define %kmp-search(pattern text c= p-start p-end t-start t-end)
! let
!   \\
!     plen {p-end - p-start}
!     rv make-kmp-restart-vector(pattern c= p-start p-end)
!   let lp
!     ti(t-start) pi(0) tj{t-end - t-start} pj(plen)
!     if {pi = plen}
!       {ti - plen}
!       and
!         {pj <= tj}
!         if c=(string-ref(text ti) string-ref(pattern {p-start + pi}))
!         ! lp {1 + ti} {1 + pi} {tj - 1} {pj - 1}
!         ! let <* pi $ vector-ref rv pi *>
!         !   if {pi = -1}
!         !   ! lp {ti + 1} 0 {tj - 1} plen
!         !   ! lp ti pi tj {plen - pi}

define make-kmp-restart-vector(pattern . maybe-c=+start+end)
! let-optionals*
!   maybe-c=+start+end
!   c=(char=? procedure?(c=))
!     start(end)
!       lambda args()
!       ! string-parse-start+end make-kmp-restart-vector pattern args
!   let* <* rvlen {end - start} \\ rv $ make-vector rvlen -1 *>
!     if {rvlen > 0}
!       let <* rvlen-1 {rvlen - 1} \\ c0 $ string-ref pattern start *>
!       ! let lp1
!       !   i(0) j(-1) k(start)
!       !   if {i < rvlen-1}
!       !   ! let lp2
!       !   !   (j(j))
!       !   !   cond
!       !   !     {j = -1}
!       !   !       let <* i1 {1 + i} *>
!       !   !       ! if not(c=(string-ref(pattern {k + 1}) c0))
!       !   !       !   vector-set! rv i1 0
!       !   !       ! lp1 i1 0 {k + 1}
!       !   !     c=(string-ref(pattern k) string-ref(pattern {j + start}))
!       !   !       let* <* i1 {1 + i} \\ j1 {1 + j} *>
!       !   !       ! vector-set! rv i1 j1
!       !   !       ! lp1 i1 j1 {k + 1}
!       !   !     else lp2(vector-ref(rv j))
!     rv

define kmp-step(pat rv c i c= p-start)
! let lp <* i i *>
!   if c=(c string-ref(pat {i + p-start}))
!     {i + 1}
!     let <* i $ vector-ref rv i *>
!       if {i = -1} 0 lp(i)

define string-kmp-partial-search(pat rv s i . c=+p-start+s-start+s-end)
! check-arg vector? rv string-kmp-partial-search
! let-optionals*
!   c=+p-start+s-start+s-end
!   c=(char=? procedure?(c=))
!     p-start
!       0
!       {integer?(p-start) and exact?(p-start) and {0 <= p-start}}
!     s-start(s-end)
!       lambda args()
!       ! string-parse-start+end string-kmp-partial-search s args
!   let <* patlen $ vector-length rv *>
!     check-arg
!       lambda i()
!       ! {integer?(i) and exact?(i) and {0 <= i} and {i < patlen}}
!       i
!       string-kmp-partial-search
!     let lp <* si s-start \\ vi i *>
!       cond
!         {vi = patlen} -(si)
!         {si = s-end} vi
!         else
!           let <* c $ string-ref s si *>
!           ! lp
!           !   {si + 1}
!           !   let lp2 <* vi vi *>
!           !   ! if c=(c string-ref(pat {vi + p-start}))
!           !   !   {vi + 1}
!           !   !   let <* vi $ vector-ref rv vi *>
!           !   !   ! if {vi = -1} 0 lp2(vi)

define string-null?(s) zero?(string-length(s))

define string-reverse(s . maybe-start+end)
! let-string-start+end
!   start end
!   string-reverse
!   s
!   maybe-start+end
!   let* <* len {end - start} \\ ans $ make-string len *>
!     do <* i start {i + 1} \\ j {len - 1} {j - 1} *>
!       $ {j < 0}
!       string-set! ans j string-ref(s i)
!     ans

define string-reverse!(s . maybe-start+end)
! let-string-start+end
!   start end
!   string-reverse!
!   s
!   maybe-start+end
!   do <* i {end - 1} {i - 1} \\ j start {j + 1} *>
!     $ {i <= j}
!     let <* ci $ string-ref s i *>
!       string-set! s i string-ref(s j)
!       string-set! s j ci

define reverse-list->string(clist)
! let* <* len $ length clist \\ s $ make-string len *>
!   do <* i {len - 1} {i - 1} \\ clist clist cdr(clist) *>
!     $ not(pair?(clist))
!     string-set! s i car(clist)
!   s

define string->list(s . maybe-start+end)
! let-string-start+end
!   start end
!   string->list
!   s
!   maybe-start+end
!   do <* i {end - 1} {i - 1} \\ ans '() cons(string-ref(s i) ans) *>
!     {i < start} ans

define string-append/shared(. strings)
! string-concatenate/shared strings

define string-concatenate/shared(strings)
! let lp <* strings strings \\ nchars 0 \\ first #f *>
!   cond
!     pair?(strings)
!       let*
!         \\
!           string car(strings)
!           tail cdr(strings)
!           slen string-length(string)
!         if zero?(slen)
!         ! lp tail nchars first
!         ! lp tail {nchars + slen} {first or strings}
!     zero?(nchars) ""
!     {nchars = string-length(car(first))} car(first)
!     else
!       let <* ans $ make-string nchars *>
!       ! let lp <* strings first \\ i 0 *>
!       !   if pair?(strings)
!       !   ! let* <* s $ car strings \\ slen $ string-length s *>
!       !   !   %string-copy! ans i s 0 slen
!       !   !   lp cdr(strings) {i + slen}
!       ! ans

define string-concatenate(strings)
! let*
!   \\
!     total
!       do
!         strings(strings cdr(strings))
!           i 0 {i + string-length(car(strings))}
!         not(pair?(strings)) i
!     ans make-string(total)
!   let lp <* i 0 \\ strings strings *>
!     if pair?(strings)
!       let* <* s $ car strings \\ slen $ string-length s *>
!       ! %string-copy! ans i s 0 slen
!       ! lp {i + slen} cdr(strings)
!   ans

define string-concatenate-reverse(string-list . maybe-final+end)
! let-optionals*
!   maybe-final+end
!   final("" string?(final))
!     end
!       string-length final
!       and
!         integer? end
!         exact? end
!         {0 <= end <= string-length(final)}
!   let
!     \\
!       len
!         let lp <* sum 0 \\ lis string-list *>
!         ! if pair?(lis)
!         !   lp {sum + string-length(car(lis))} cdr(lis)
!         !   sum
!     %finish-string-concatenate-reverse
!       len
!       string-list
!       final
!       end

define string-concatenate-reverse/shared(string-list . maybe-final+end)
! let-optionals*
!   maybe-final+end
!   final("" string?(final))
!     end
!       string-length final
!       and
!         integer? end
!         exact? end
!         {0 <= end <= string-length(final)}
!   let lp <* len 0 \\ nzlist #f \\ lis string-list *>
!     if pair?(lis)
!       let <* slen $ string-length car(lis) *>
!       ! lp
!       !   {len + slen}
!       !   if {nzlist or zero?(slen)} nzlist lis
!       !   cdr lis
!       cond
!         zero?(len) substring/shared(final 0 end)
!         {zero?(end) and {len = string-length(car(nzlist))}}
!           car nzlist
!         else
!           %finish-string-concatenate-reverse len nzlist final end

define %finish-string-concatenate-reverse(len string-list final end)
! let <* ans $ make-string {end + len} *>
!   %string-copy! ans len final 0 end
!   let lp <* i len \\ lis string-list *>
!     if pair?(lis)
!       let*
!       ! \\
!       !    s car(lis)
!       !    lis cdr(lis)
!       !    slen string-length(s)
!       !    i {i - slen}
!       ! %string-copy! ans i s 0 slen
!       ! lp i lis
!   ans

define string-replace(s1 s2 start1 end1 . maybe-start+end)
! check-substring-spec string-replace s1 start1 end1
! let-string-start+end
!   start2 end2
!   string-replace
!   s2
!   maybe-start+end
!   let*
!     \\
!       slen1 string-length(s1)
!       sublen2 {end2 - start2}
!       alen {{slen1 - {end1 - start1}} + sublen2}
!       ans make-string(alen)
!     %string-copy! ans 0 s1 0 start1
!     %string-copy! ans start1 s2 start2 end2
!     %string-copy! ans {start1 + sublen2} s1 end1 slen1
!     ans

define string-tokenize(s . token-chars+start+end)
! let-optionals*
!   token-chars+start+end
!   token-chars(char-set:graphic char-set?(token-chars)) rest
!   let-string-start+end
!     start end
!     string-tokenize
!     s
!     rest
!     let lp <* i end \\ ans '() *>
!       cond
!         {{start < i} and string-index-right(s token-chars start i)}
!           =>
!           lambda tend-1()
!           ! let <* tend {1 + tend-1} *>
!           !   cond
!           !     string-skip-right(s token-chars start tend-1)
!           !       =>
!           !       lambda tstart-1()
!           !       ! lp tstart-1 cons(substring(s {1 + tstart-1} tend) ans)
!           !     else cons(substring(s start tend) ans)
!         else ans

define xsubstring(s from . maybe-to+start+end)
! check-arg
!   lambda val() {integer?(val) and exact?(val)}
!   from
!   xsubstring
! receive
!   to start end
!   if pair?(maybe-to+start+end)
!     let-string-start+end
!       start end
!       xsubstring
!       s
!       cdr maybe-to+start+end
!       let <* to $ car maybe-to+start+end *>
!       ! check-arg
!       !   lambda val()
!       !   ! {integer?(val) and exact?(val) and {from <= val}}
!       !   to
!       !   xsubstring
!       ! values to start end
!     let <* slen $ string-length check-arg(string? s xsubstring) *>
!       values {from + slen} 0 slen
!   let <* slen {end - start} \\ anslen {to - from} *>
!     cond
!       zero?(anslen) ""
!       zero?(slen)
!         error
!           "Cannot replicate empty (sub)string"
!           xsubstring
!           s
!           from
!           to
!           start
!           end
!       {1 = slen} make-string(anslen string-ref(s start))
!       {floor{from / slen} = floor{to / slen}}
!         substring
!           s
!           {start + modulo(from slen)}
!           {start + modulo(to slen)}
!       else
!         let <* ans $ make-string anslen *>
!         ! %multispan-repcopy!
!         !   ans
!         !   0
!         !   s
!         !   from
!         !   to
!         !   start
!         !   end
!         ! ans

define string-xcopy!(target tstart s sfrom . maybe-sto+start+end)
! check-arg
!   lambda val() {integer?(val) and exact?(val)}
!   sfrom
!   string-xcopy!
! receive
!   sto start end
!   if pair?(maybe-sto+start+end)
!     let-string-start+end
!       start end
!       string-xcopy!
!       s
!       cdr maybe-sto+start+end
!       let <* sto $ car maybe-sto+start+end *>
!       ! check-arg
!       !   lambda val() {integer?(val) and exact?(val)}
!       !   sto
!       !   string-xcopy!
!       ! values sto start end
!     let <* slen $ string-length s *> values({sfrom + slen} 0 slen)
!   let*
!     \\
!        tocopy {sto - sfrom}
!        tend {tstart + tocopy}
!        slen {end - start}
!     check-substring-spec string-xcopy! target tstart tend
!     cond
!       (zero?(tocopy))
!       zero?(slen)
!         error
!           "Cannot replicate empty (sub)string"
!           string-xcopy!
!           target
!           tstart
!           s
!           sfrom
!           sto
!           start
!           end
!       {1 = slen}
!         string-fill! target string-ref(s start) tstart tend
!       {floor{sfrom / slen} = floor{sto / slen}}
!         %string-copy!
!           target
!           tstart
!           s
!           {start + modulo(sfrom slen)}
!           {start + modulo(sto slen)}
!       else
!         %multispan-repcopy!
!           target
!           tstart
!           s
!           sfrom
!           sto
!           start
!           end

define %multispan-repcopy!(target tstart s sfrom sto start end)
! let*
!   \\
!     slen {end - start}
!     i0 {start + modulo(sfrom slen)}
!     total-chars {sto - sfrom}
!   %string-copy! target tstart s i0 end
!   let*
!     \\
!       ncopied {end - i0}
!       nleft {total-chars - ncopied}
!       nspans quotient(nleft slen)
!     do <* i {tstart + ncopied} {i + slen} \\ nspans nspans {nspans - 1} *>
!       zero?(nspans)
!         %string-copy! target i s start
!           {start + {total-chars - {i - tstart}}}
!       %string-copy! target i s start end; Copy a whole span.

define string-join(strings . delim+grammar)
! let-optionals*
!   delim+grammar
!   delim(" " string?(delim)) grammar('infix)
!   let
!     \\
!       buildit
!         lambda lis(final)
!         ! let recur
!         !   (lis(lis))
!         !   if pair?(lis)
!         !   ! cons delim cons(car(lis) recur(cdr(lis)))
!         !   ! final
!     cond
!       pair?(strings)
!         string-concatenate
!           case grammar
!           ! infix(strict-infix)
!           !   cons car(strings) buildit(cdr(strings) '())
!           ! prefix() buildit(strings '())
!           ! suffix()
!           !   cons car(strings) buildit(cdr(strings) list(delim))
!           ! else error("Illegal join grammar" grammar string-join)
!       not(null?(strings))
!         error "STRINGS parameter not list." strings string-join
!       eq?(grammar 'strict-infix)
!         error
!           "Empty list cannot be joined with STRICT-INFIX grammar."
!           string-join
!       else ""; Special-cased for infix grammar.

;;; Copyright details
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The prefix/suffix and comparison routines in this code had (extremely
;;; distant) origins in MIT Scheme's string lib, and was substantially
;;; reworked by Olin Shivers (xxxxxx@ai.mit.edu) 9/98. As such, it is
;;; covered by MIT Scheme's open source copyright. See below for details.
;;;
;;; The KMP string-search code was influenced by implementations written
;;; by Stephen Bevan, Brian Dehneyer and Will Fitzgerald. However, this
;;; version was written from scratch by myself.
;;;
;;; The remainder of this code was written from scratch by myself for scsh.
;;; The scsh copyright is a BSD-style open source copyright. See below for
;;; details.
;;;     -Olin Shivers

;;; MIT Scheme copyright terms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This material was developed by the Scheme project at the Massachusetts
;;; Institute of Technology, Department of Electrical Engineering and
;;; Computer Science.  Permission to copy and modify this software, to
;;; redistribute either the original software or a modified version, and
;;; to use this software for any purpose is granted, subject to the
;;; following restrictions and understandings.
;;;
;;; 1. Any copy made of this software must include this copyright notice
;;; in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a) to
;;; return to the MIT Scheme project any improvements or extensions that
;;; they make, so that these may be included in future releases; and (b)
;;; to inform MIT of noteworthy uses of this software.
;;;
;;; 3. All materials developed as a consequence of the use of this
;;; software shall duly acknowledge such use, in accordance with the usual
;;; standards of acknowledging credit in academic research.
;;;
;;; 4. MIT has made no warrantee or representation that the operation of
;;; this software will be error-free, and MIT is under no obligation to
;;; provide any services, by way of maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this material,
;;; there shall be no use of the name of the Massachusetts Institute of
;;; Technology nor of any adaptation thereof in any advertising,
;;; promotional, or sales literature without prior written consent from
;;; MIT in each case.

;;; Scsh copyright terms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;;    notice, this list of conditions and the following disclaimer in the
;;;    documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;;    derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

; s-expressions

; Sample SRFI-13 implementation, from:
; http://srfi.schemers.org/srfi-13/srfi-13.scm

;;; SRFI 13 string library reference implementation		-*- Scheme -*-
;;; Olin Shivers 7/2000
;;;
;;; Copyright (c) 1988-1994 Massachusetts Institute of Technology.
;;; Copyright (c) 1998, 1999, 2000 Olin Shivers. All rights reserved.
;;;   The details of the copyrights appear at the end of the file. Short
;;;   summary: BSD-style open source.

; Since we only care about the *format*, nearly all ;-comments have been
; removed from this version, to shorten it (see the original file for them).

(define-syntax let-string-start+end
  (syntax-rules ()
    ((let-string-start+end (start end) proc s-exp args-exp body ...)
     (receive (start end) (string-parse-final-start+end proc s-exp args-exp)
       body ...))
    ((let-string-start+end (start end rest) proc s-exp args-exp body ...)
     (receive (rest start end) (string-parse-start+end proc s-exp args-exp)
       body ...))))

(define-syntax let-string-start+end2
  (syntax-rules ()
    ((l-s-s+e2 (start1 end1 start2 end2) proc s1 s2 args body ...)
     (let ((procv proc)) ; Make sure PROC is only evaluated once.
       (let-string-start+end (start1 end1 rest) procv s1 args
         (let-string-start+end (start2 end2) procv s2 rest
           body ...))))))

(define (string-parse-start+end proc s args)
  (if (not (string? s)) (error "Non-string value" proc s))
  (let ((slen (string-length s)))
    (if (pair? args)

	(let ((start (car args))
	      (args (cdr args)))
	  (if (and (integer? start) (exact? start) (>= start 0))
	      (receive (end args)
		  (if (pair? args)
		      (let ((end (car args))
			    (args (cdr args)))
			(if (and (integer? end) (exact? end) (<= end slen))
			    (values end args)
			    (error "Illegal substring END spec" proc end s)))
		      (values slen args))
		(if (<= start end) (values args start end)
		    (error "Illegal substring START/END spec"
			   proc start end s)))
	      (error "Illegal substring START spec" proc start s)))

	(values '() 0 slen))))

(define (string-parse-final-start+end proc s args)
  (receive (rest start end) (string-parse-start+end proc s args)
    (if (pair? rest) (error "Extra arguments to procedure" proc rest)
	(values start end))))

(define (substring-spec-ok? s start end)
  (and (string? s)
       (integer? start)
       (exact? start)
       (integer? end)
       (exact? end)
       (<= 0 start)
       (<= start end)
       (<= end (string-length s))))

(define (check-substring-spec proc s start end)
  (if (not (substring-spec-ok? s start end))
      (error "Illegal substring spec." proc s start end)))

(define (substring/shared s start . maybe-end)
  (check-arg string? s substring/shared)
  (let ((slen (string-length s)))
    (check-arg (lambda (start) (and (integer? start) (exact? start) (<= 0 start)))
	       start substring/shared)
    (%substring/shared s start
		       (:optional maybe-end slen
				  (lambda (end) (and (integer? end)
						     (exact? end)
						     (<= start end)
						     (<= end slen)))))))

(define (%substring/shared s start end)
  (if (and (zero? start) (= end (string-length s))) s
      (substring s start end)))

(define (string-copy s . maybe-start+end)
  (let-string-start+end (start end) string-copy s maybe-start+end
    (substring s start end)))

(define (string-map proc s . maybe-start+end)
  (check-arg procedure? proc string-map)
  (let-string-start+end (start end) string-map s maybe-start+end
    (%string-map proc s start end)))

(define (%string-map proc s start end)	; Internal utility
  (let* ((len (- end start))
	 (ans (make-string len)))
    (do ((i (- end 1) (- i 1))
	 (j (- len 1) (- j 1)))
	((< j 0))
      (string-set! ans j (proc (string-ref s i))))
    ans))

(define (string-map! proc s . maybe-start+end)
  (check-arg procedure? proc string-map!)
  (let-string-start+end (start end) string-map! s maybe-start+end
    (%string-map! proc s start end)))

(define (%string-map! proc s start end)
  (do ((i (- end 1) (- i 1)))
      ((< i start))
    (string-set! s i (proc (string-ref s i)))))

(define (string-fold kons knil s . maybe-start+end)
  (check-arg procedure? kons string-fold)
  (let-string-start+end (start end) string-fold s maybe-start+end
    (let lp ((v knil) (i start))
      (if (< i end) (lp (kons (string-ref s i) v) (+ i 1))
	  v))))

(define (string-fold-right kons knil s . maybe-start+end)
  (check-arg procedure? kons string-fold-right)
  (let-string-start+end (start end) string-fold-right s maybe-start+end
    (let lp ((v knil) (i (- end 1)))
      (if (>= i start) (lp (kons (string-ref s i) v) (- i 1))
	  v))))

(define (string-unfold p f g seed . base+make-final)
  (check-arg procedure? p string-unfold)
  (check-arg procedure? f string-unfold)
  (check-arg procedure? g string-unfold)
  (let-optionals* base+make-final
                  ((base       ""              (string? base))
		   (make-final (lambda (x) "") (procedure? make-final)))
    (let lp ((chunks '())		; Previously filled chunks
	     (nchars 0)			; Number of chars in CHUNKS
	     (chunk (make-string 40))	; Current chunk into which we write
	     (chunk-len 40)
	     (i 0)			; Number of chars written into CHUNK
	     (seed seed))
      (let lp2 ((i i) (seed seed))
	(if (not (p seed))
	    (let ((c (f seed))
		  (seed (g seed)))
	      (if (< i chunk-len)
		  (begin (string-set! chunk i c)
			 (lp2 (+ i 1) seed))

		  (let* ((nchars2 (+ chunk-len nchars))
			 (chunk-len2 (min 4096 nchars2))
			 (new-chunk (make-string chunk-len2)))
		    (string-set! new-chunk 0 c)
		    (lp (cons chunk chunks) (+ nchars chunk-len)
			new-chunk chunk-len2 1 seed))))

	    ;; We're done. Make the answer string & install the bits.
	    (let* ((final (make-final seed))
		   (flen (string-length final))
		   (base-len (string-length base))
		   (j (+ base-len nchars i))
		   (ans (make-string (+ j flen))))
	      (%string-copy! ans j final 0 flen)	; Install FINAL.
	      (let ((j (- j i)))
		(%string-copy! ans j chunk 0 i)		; Install CHUNK[0,I).
		(let lp ((j j) (chunks chunks))		; Install CHUNKS.
		  (if (pair? chunks)
		      (let* ((chunk  (car chunks))
			     (chunks (cdr chunks))
			     (chunk-len (string-length chunk))
			     (j (- j chunk-len)))
			(%string-copy! ans j chunk 0 chunk-len)
			(lp j chunks)))))
	      (%string-copy! ans 0 base 0 base-len)	; Install BASE.
	      ans))))))

(define (string-unfold-right p f g seed . base+make-final)
  (let-optionals* base+make-final
                  ((base       ""              (string? base))
		   (make-final (lambda (x) "") (procedure? make-final)))
    (let lp ((chunks '())		; Previously filled chunks
	     (nchars 0)			; Number of chars in CHUNKS
	     (chunk (make-string 40))	; Current chunk into which we write
	     (chunk-len 40)
	     (i 40)			; Number of chars available in CHUNK
	     (seed seed))
      (let lp2 ((i i) (seed seed))	; Fill up CHUNK from right
	(if (not (p seed))		; to left.
	    (let ((c (f seed))
		  (seed (g seed)))
	      (if (> i 0)
		  (let ((i (- i 1)))
		    (string-set! chunk i c)
		    (lp2 i seed))

		  (let* ((nchars2 (+ chunk-len nchars))
			 (chunk-len2 (min 4096 nchars2))
			 (new-chunk (make-string chunk-len2))
			 (i (- chunk-len2 1)))
		    (string-set! new-chunk i c)
		    (lp (cons chunk chunks) (+ nchars chunk-len)
			new-chunk chunk-len2 i seed))))

	    ;; We're done. Make the answer string & install the bits.
	    (let* ((final (make-final seed))
		   (flen (string-length final))
		   (base-len (string-length base))
		   (chunk-used (- chunk-len i))
		   (j (+ base-len nchars chunk-used))
		   (ans (make-string (+ j flen))))
	      (%string-copy! ans 0 final 0 flen)	; Install FINAL.
	      (%string-copy! ans flen chunk i chunk-len); Install CHUNK[I,).
	      (let lp ((j (+ flen chunk-used))		; Install CHUNKS.
		       (chunks chunks))
		  (if (pair? chunks)
		      (let* ((chunk  (car chunks))
			     (chunks (cdr chunks))
			     (chunk-len (string-length chunk)))
			(%string-copy! ans j chunk 0 chunk-len)
			(lp (+ j chunk-len) chunks))
		      (%string-copy! ans j base 0 base-len))); Install BASE.
	      ans))))))

(define (string-for-each proc s . maybe-start+end)
  (check-arg procedure? proc string-for-each)
  (let-string-start+end (start end) string-for-each s maybe-start+end
    (let lp ((i start))
      (if (< i end)
	  (begin (proc (string-ref s i))
		 (lp (+ i 1)))))))

(define (string-for-each-index proc s . maybe-start+end)
  (check-arg procedure? proc string-for-each-index)
  (let-string-start+end (start end) string-for-each-index s maybe-start+end
    (let lp ((i start))
      (if (< i end) (begin (proc i) (lp (+ i 1)))))))

(define (string-every criterion s . maybe-start+end)
  (let-string-start+end (start end) string-every s maybe-start+end
    (cond ((char? criterion)
	   (let lp ((i start))
	     (or (>= i end)
		 (and (char=? criterion (string-ref s i))
		      (lp (+ i 1))))))

	  ((char-set? criterion)
	   (let lp ((i start))
	     (or (>= i end)
		 (and (char-set-contains? criterion (string-ref s i))
		      (lp (+ i 1))))))

	  ((procedure? criterion)		; Slightly funky loop so that
	   (or (= start end)			; final (PRED S[END-1]) call
	       (let lp ((i start))		; is a tail call.
		 (let ((c (string-ref s i))
		       (i1 (+ i 1)))
		   (if (= i1 end) (criterion c)	; Tail call.
		       (and (criterion c) (lp i1)))))))

	  (else (error "Second param is neither char-set, char, or predicate procedure."
		       string-every criterion)))))

(define (string-any criterion s . maybe-start+end)
  (let-string-start+end (start end) string-any s maybe-start+end
    (cond ((char? criterion)
	   (let lp ((i start))
	     (and (< i end)
		  (or (char=? criterion (string-ref s i))
		      (lp (+ i 1))))))

	  ((char-set? criterion)
	   (let lp ((i start))
	     (and (< i end)
		  (or (char-set-contains? criterion (string-ref s i))
		      (lp (+ i 1))))))

	  ((procedure? criterion)		; Slightly funky loop so that
	   (and (< start end)			; final (PRED S[END-1]) call
		(let lp ((i start))		; is a tail call.
		  (let ((c (string-ref s i))
			(i1 (+ i 1)))
		    (if (= i1 end) (criterion c)	; Tail call
			(or (criterion c) (lp i1)))))))

	  (else (error "Second param is neither char-set, char, or predicate procedure."
		       string-any criterion)))))

(define (string-tabulate proc len)
  (check-arg procedure? proc string-tabulate)
  (check-arg (lambda (val) (and (integer? val) (exact? val) (<= 0 val)))
	     len string-tabulate)
  (let ((s (make-string len)))
    (do ((i (- len 1) (- i 1)))
	((< i 0))
      (string-set! s i (proc i)))
    s))

(define (%string-prefix-length s1 start1 end1 s2 start2 end2)
  (let* ((delta (min (- end1 start1) (- end2 start2)))
	 (end1 (+ start1 delta)))

    (if (and (eq? s1 s2) (= start1 start2))	; EQ fast path
	delta

	(let lp ((i start1) (j start2))		; Regular path
	  (if (or (>= i end1)
		  (not (char=? (string-ref s1 i)
			       (string-ref s2 j))))
	      (- i start1)
	      (lp (+ i 1) (+ j 1)))))))

(define (%string-suffix-length s1 start1 end1 s2 start2 end2)
  (let* ((delta (min (- end1 start1) (- end2 start2)))
	 (start1 (- end1 delta)))

    (if (and (eq? s1 s2) (= end1 end2))		; EQ fast path
	delta

	(let lp ((i (- end1 1)) (j (- end2 1)))	; Regular path
	  (if (or (< i start1)
		  (not (char=? (string-ref s1 i)
			       (string-ref s2 j))))
	      (- (- end1 i) 1)
	      (lp (- i 1) (- j 1)))))))

(define (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)
  (let* ((delta (min (- end1 start1) (- end2 start2)))
	 (end1 (+ start1 delta)))

    (if (and (eq? s1 s2) (= start1 start2))	; EQ fast path
	delta

	(let lp ((i start1) (j start2))		; Regular path
	  (if (or (>= i end1)
		  (not (char-ci=? (string-ref s1 i)
				  (string-ref s2 j))))
	      (- i start1)
	      (lp (+ i 1) (+ j 1)))))))

(define (%string-suffix-length-ci s1 start1 end1 s2 start2 end2)
  (let* ((delta (min (- end1 start1) (- end2 start2)))
	 (start1 (- end1 delta)))

    (if (and (eq? s1 s2) (= end1 end2))		; EQ fast path
	delta

	(let lp ((i (- end1 1)) (j (- end2 1)))	; Regular path
	  (if (or (< i start1)
		  (not (char-ci=? (string-ref s1 i)
				  (string-ref s2 j))))
	      (- (- end1 i) 1)
	      (lp (- i 1) (- j 1)))))))

(define (string-prefix-length s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-prefix-length s1 s2 maybe-starts+ends
    (%string-prefix-length s1 start1 end1 s2 start2 end2)))

(define (string-suffix-length s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-suffix-length s1 s2 maybe-starts+ends
    (%string-suffix-length s1 start1 end1 s2 start2 end2)))

(define (string-prefix-length-ci s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-prefix-length-ci s1 s2 maybe-starts+ends
    (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)))

(define (string-suffix-length-ci s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-suffix-length-ci s1 s2 maybe-starts+ends
    (%string-suffix-length-ci s1 start1 end1 s2 start2 end2)))

(define (string-prefix? s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-prefix? s1 s2 maybe-starts+ends
    (%string-prefix? s1 start1 end1 s2 start2 end2)))

(define (string-suffix? s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-suffix? s1 s2 maybe-starts+ends
    (%string-suffix? s1 start1 end1 s2 start2 end2)))

(define (string-prefix-ci? s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-prefix-ci? s1 s2 maybe-starts+ends
    (%string-prefix-ci? s1 start1 end1 s2 start2 end2)))

(define (string-suffix-ci? s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-suffix-ci? s1 s2 maybe-starts+ends
    (%string-suffix-ci? s1 start1 end1 s2 start2 end2)))

;;; Here are the internal routines that do the real work.

(define (%string-prefix? s1 start1 end1 s2 start2 end2)
  (let ((len1 (- end1 start1)))
    (and (<= len1 (- end2 start2))	; Quick check
	 (= (%string-prefix-length s1 start1 end1
				   s2 start2 end2)
	    len1))))

(define (%string-suffix? s1 start1 end1 s2 start2 end2)
  (let ((len1 (- end1 start1)))
    (and (<= len1 (- end2 start2))	; Quick check
	 (= len1 (%string-suffix-length s1 start1 end1
					s2 start2 end2)))))

(define (%string-prefix-ci? s1 start1 end1 s2 start2 end2)
  (let ((len1 (- end1 start1)))
    (and (<= len1 (- end2 start2))	; Quick check
	 (= len1 (%string-prefix-length-ci s1 start1 end1
					   s2 start2 end2)))))

(define (%string-suffix-ci? s1 start1 end1 s2 start2 end2)
  (let ((len1 (- end1 start1)))
    (and (<= len1 (- end2 start2))	; Quick check
	 (= len1 (%string-suffix-length-ci s1 start1 end1
					   s2 start2 end2)))))

(define (%string-compare s1 start1 end1 s2 start2 end2
			   proc< proc= proc>)
  (let ((size1 (- end1 start1))
	(size2 (- end2 start2)))
    (let ((match (%string-prefix-length s1 start1 end1 s2 start2 end2)))
      (if (= match size1)
	  ((if (= match size2) proc= proc<) end1)
	  ((if (= match size2)
	       proc>
	       (if (char<? (string-ref s1 (+ start1 match))
			   (string-ref s2 (+ start2 match)))
		   proc< proc>))
	   (+ match start1))))))

(define (%string-compare-ci s1 start1 end1 s2 start2 end2
			      proc< proc= proc>)
  (let ((size1 (- end1 start1))
	(size2 (- end2 start2)))
    (let ((match (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)))
      (if (= match size1)
	  ((if (= match size2) proc= proc<) end1)
	  ((if (= match size2) proc>
	       (if (char-ci<? (string-ref s1 (+ start1 match))
			      (string-ref s2 (+ start2 match)))
		   proc< proc>))
	   (+ start1 match))))))

(define (string-compare s1 s2 proc< proc= proc> . maybe-starts+ends)
  (check-arg procedure? proc< string-compare)
  (check-arg procedure? proc= string-compare)
  (check-arg procedure? proc> string-compare)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-compare s1 s2 maybe-starts+ends
    (%string-compare s1 start1 end1 s2 start2 end2 proc< proc= proc>)))

(define (string-compare-ci s1 s2 proc< proc= proc> . maybe-starts+ends)
  (check-arg procedure? proc< string-compare-ci)
  (check-arg procedure? proc= string-compare-ci)
  (check-arg procedure? proc> string-compare-ci)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-compare-ci s1 s2 maybe-starts+ends
    (%string-compare-ci s1 start1 end1 s2 start2 end2 proc< proc= proc>)))

(define (string= s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string= s1 s2 maybe-starts+ends
    (and (= (- end1 start1) (- end2 start2))			; Quick filter
	 (or (and (eq? s1 s2) (= start1 start2))		; Fast path
	     (%string-compare s1 start1 end1 s2 start2 end2	; Real test
			      (lambda (i) #f)
			      values
			      (lambda (i) #f))))))

(define (string<> s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string<> s1 s2 maybe-starts+ends
    (or (not (= (- end1 start1) (- end2 start2)))		; Fast path
	(and (not (and (eq? s1 s2) (= start1 start2)))		; Quick filter
	     (%string-compare s1 start1 end1 s2 start2 end2	; Real test
			      values
			      (lambda (i) #f)
			      values)))))

(define (string< s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string< s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(< end1 end2)

	(%string-compare s1 start1 end1 s2 start2 end2 		; Real test
			 values
			 (lambda (i) #f)
			 (lambda (i) #f)))))

(define (string> s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string> s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(> end1 end2)

	(%string-compare s1 start1 end1 s2 start2 end2 		; Real test
			 (lambda (i) #f)
			 (lambda (i) #f)
			 values))))

(define (string<= s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string<= s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(<= end1 end2)

	(%string-compare s1 start1 end1 s2 start2 end2 		; Real test
			 values
			 values
			 (lambda (i) #f)))))

(define (string>= s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string>= s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(>= end1 end2)

	(%string-compare s1 start1 end1 s2 start2 end2 		; Real test
			 (lambda (i) #f)
			 values
			 values))))

(define (string-ci= s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-ci= s1 s2 maybe-starts+ends
    (and (= (- end1 start1) (- end2 start2))			; Quick filter
	 (or (and (eq? s1 s2) (= start1 start2))		; Fast path
	     (%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
				 (lambda (i) #f)
				 values
				 (lambda (i) #f))))))

(define (string-ci<> s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-ci<> s1 s2 maybe-starts+ends
    (or (not (= (- end1 start1) (- end2 start2)))		; Fast path
	(and (not (and (eq? s1 s2) (= start1 start2)))		; Quick filter
	     (%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
				 values
				 (lambda (i) #f)
				 values)))))

(define (string-ci< s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-ci< s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(< end1 end2)

	(%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
			    values
			    (lambda (i) #f)
			    (lambda (i) #f)))))

(define (string-ci> s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-ci> s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(> end1 end2)

	(%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
			    (lambda (i) #f)
			    (lambda (i) #f)
			    values))))

(define (string-ci<= s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-ci<= s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(<= end1 end2)

	(%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
			    values
			    values
			    (lambda (i) #f)))))

(define (string-ci>= s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2)
			 string-ci>= s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(>= end1 end2)

	(%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
			    (lambda (i) #f)
			    values
			    values))))

(define (%string-hash s char->int bound start end)
  (let ((iref (lambda (s i) (char->int (string-ref s i))))
	;; Compute a 111...1 mask that will cover BOUND-1:
	(mask (let lp ((i #x10000)) ; Let's skip first 16 iterations, eh?
		(if (>= i bound) (- i 1) (lp (+ i i))))))
    (let lp ((i start) (ans 0))
      (if (>= i end) (modulo ans bound)
	  (lp (+ i 1) (bitwise-and mask (+ (* 37 ans) (iref s i))))))))

(define (string-hash s . maybe-bound+start+end)
  (let-optionals* maybe-bound+start+end ((bound 4194304 (and (integer? bound)
							     (exact? bound)
							     (<= 0 bound)))
					 rest)
    (let ((bound (if (zero? bound) 4194304 bound)))	; 0 means default.
      (let-string-start+end (start end) string-hash s rest
        (%string-hash s char->integer bound start end)))))

(define (string-hash-ci s . maybe-bound+start+end)
  (let-optionals* maybe-bound+start+end ((bound 4194304 (and (integer? bound)
							     (exact? bound)
							     (<= 0 bound)))
					 rest)
    (let ((bound (if (zero? bound) 4194304 bound)))	; 0 means default.
      (let-string-start+end (start end) string-hash-ci s rest
        (%string-hash s (lambda (c) (char->integer (char-downcase c)))
		      bound start end)))))

(define (string-upcase  s . maybe-start+end)
  (let-string-start+end (start end) string-upcase s maybe-start+end
    (%string-map char-upcase s start end)))

(define (string-upcase! s . maybe-start+end)
  (let-string-start+end (start end) string-upcase! s maybe-start+end
    (%string-map! char-upcase s start end)))

(define (string-downcase  s . maybe-start+end)
  (let-string-start+end (start end) string-downcase s maybe-start+end
    (%string-map char-downcase s start end)))

(define (string-downcase! s . maybe-start+end)
  (let-string-start+end (start end) string-downcase! s maybe-start+end
    (%string-map! char-downcase s start end)))

(define (%string-titlecase! s start end)
  (let lp ((i start))
    (cond ((string-index s char-cased? i end) =>
           (lambda (i)
	     (string-set! s i (char-titlecase (string-ref s i)))
	     (let ((i1 (+ i 1)))
	       (cond ((string-skip s char-cased? i1 end) =>
		      (lambda (j)
			(string-downcase! s i1 j)
			(lp (+ j 1))))
		     (else (string-downcase! s i1 end)))))))))

(define (string-titlecase! s . maybe-start+end)
  (let-string-start+end (start end) string-titlecase! s maybe-start+end
    (%string-titlecase! s start end)))

(define (string-titlecase s . maybe-start+end)
  (let-string-start+end (start end) string-titlecase! s maybe-start+end
    (let ((ans (substring s start end)))
      (%string-titlecase! ans 0 (- end start))
      ans)))

(define (string-take s n)
  (check-arg string? s string-take)
  (check-arg (lambda (val) (and (integer? n) (exact? n)
				(<= 0 n (string-length s))))
	     n string-take)
  (%substring/shared s 0 n))

(define (string-take-right s n)
  (check-arg string? s string-take-right)
  (let ((len (string-length s)))
    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
	       n string-take-right)
    (%substring/shared s (- len n) len)))

(define (string-drop s n)
  (check-arg string? s string-drop)
  (let ((len (string-length s)))
    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
	       n string-drop)
  (%substring/shared s n len)))

(define (string-drop-right s n)
  (check-arg string? s string-drop-right)
  (let ((len (string-length s)))
    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
	       n string-drop-right)
    (%substring/shared s 0 (- len n))))

(define (string-trim s . criterion+start+end)
  (let-optionals* criterion+start+end ((criterion char-set:whitespace) rest)
    (let-string-start+end (start end) string-trim s rest
      (cond ((string-skip s criterion start end) =>
	     (lambda (i) (%substring/shared s i end)))
	    (else "")))))

(define (string-trim-right s . criterion+start+end)
  (let-optionals* criterion+start+end ((criterion char-set:whitespace) rest)
    (let-string-start+end (start end) string-trim-right s rest
      (cond ((string-skip-right s criterion start end) =>
	     (lambda (i) (%substring/shared s 0 (+ 1 i))))
	    (else "")))))

(define (string-trim-both s . criterion+start+end)
  (let-optionals* criterion+start+end ((criterion char-set:whitespace) rest)
    (let-string-start+end (start end) string-trim-both s rest
      (cond ((string-skip s criterion start end) =>
	     (lambda (i)
	       (%substring/shared s i (+ 1 (string-skip-right s criterion i end)))))
	    (else "")))))

(define (string-pad-right s n . char+start+end)
  (let-optionals* char+start+end ((char #\space (char? char)) rest)
    (let-string-start+end (start end) string-pad-right s rest
      (check-arg (lambda (n) (and (integer? n) (exact? n) (<= 0 n)))
		 n string-pad-right)
      (let ((len (- end start)))
	(if (<= n len)
	    (%substring/shared s start (+ start n))
	    (let ((ans (make-string n char)))
	      (%string-copy! ans 0 s start end)
	      ans))))))

(define (string-pad s n . char+start+end)
  (let-optionals* char+start+end ((char #\space (char? char)) rest)
    (let-string-start+end (start end) string-pad s rest
      (check-arg (lambda (n) (and (integer? n) (exact? n) (<= 0 n)))
		 n string-pad)
      (let ((len (- end start)))
	(if (<= n len)
	    (%substring/shared s (- end n) end)
	    (let ((ans (make-string n char)))
	      (%string-copy! ans (- n len) s start end)
	      ans))))))

(define (string-delete criterion s . maybe-start+end)
  (let-string-start+end (start end) string-delete s maybe-start+end
    (if (procedure? criterion)
	(let* ((slen (- end start))
	       (temp (make-string slen))
	       (ans-len (string-fold (lambda (c i)
				       (if (criterion c) i
					   (begin (string-set! temp i c)
						  (+ i 1))))
				     0 s start end)))
	  (if (= ans-len slen) temp (substring temp 0 ans-len)))

	(let* ((cset (cond ((char-set? criterion) criterion)
			   ((char? criterion) (char-set criterion))
			   (else (error "string-delete criterion not predicate, char or char-set" criterion))))
	       (len (string-fold (lambda (c i) (if (char-set-contains? cset c)
						   i
						   (+ i 1)))
				 0 s start end))
	       (ans (make-string len)))
	  (string-fold (lambda (c i) (if (char-set-contains? cset c)
					 i
					 (begin (string-set! ans i c)
						(+ i 1))))
		       0 s start end)
	  ans))))

(define (string-filter criterion s . maybe-start+end)
  (let-string-start+end (start end) string-filter s maybe-start+end
    (if (procedure? criterion)
	(let* ((slen (- end start))
	       (temp (make-string slen))
	       (ans-len (string-fold (lambda (c i)
				       (if (criterion c)
					   (begin (string-set! temp i c)
						  (+ i 1))
					   i))
				     0 s start end)))
	  (if (= ans-len slen) temp (substring temp 0 ans-len)))

	(let* ((cset (cond ((char-set? criterion) criterion)
			   ((char? criterion) (char-set criterion))
			   (else (error "string-delete criterion not predicate, char or char-set" criterion))))

	       (len (string-fold (lambda (c i) (if (char-set-contains? cset c)
						   (+ i 1)
						   i))
				 0 s start end))
	       (ans (make-string len)))
	  (string-fold (lambda (c i) (if (char-set-contains? cset c)
					 (begin (string-set! ans i c)
						(+ i 1))
					 i))
		       0 s start end)
	  ans))))

(define (string-index str criterion . maybe-start+end)
  (let-string-start+end (start end) string-index str maybe-start+end
    (cond ((char? criterion)
	   (let lp ((i start))
	     (and (< i end)
		  (if (char=? criterion (string-ref str i)) i
		      (lp (+ i 1))))))
	  ((char-set? criterion)
	   (let lp ((i start))
	     (and (< i end)
		  (if (char-set-contains? criterion (string-ref str i)) i
		      (lp (+ i 1))))))
	  ((procedure? criterion)
	   (let lp ((i start))
	     (and (< i end)
		  (if (criterion (string-ref str i)) i
		      (lp (+ i 1))))))
	  (else (error "Second param is neither char-set, char, or predicate procedure."
		       string-index criterion)))))

(define (string-index-right str criterion . maybe-start+end)
  (let-string-start+end (start end) string-index-right str maybe-start+end
    (cond ((char? criterion)
	   (let lp ((i (- end 1)))
	     (and (>= i start)
		  (if (char=? criterion (string-ref str i)) i
		      (lp (- i 1))))))
	  ((char-set? criterion)
	   (let lp ((i (- end 1)))
	     (and (>= i start)
		  (if (char-set-contains? criterion (string-ref str i)) i
		      (lp (- i 1))))))
	  ((procedure? criterion)
	   (let lp ((i (- end 1)))
	     (and (>= i start)
		  (if (criterion (string-ref str i)) i
		      (lp (- i 1))))))
	  (else (error "Second param is neither char-set, char, or predicate procedure."
		       string-index-right criterion)))))

(define (string-skip str criterion . maybe-start+end)
  (let-string-start+end (start end) string-skip str maybe-start+end
    (cond ((char? criterion)
	   (let lp ((i start))
	     (and (< i end)
		  (if (char=? criterion (string-ref str i))
		      (lp (+ i 1))
		      i))))
	  ((char-set? criterion)
	   (let lp ((i start))
	     (and (< i end)
		  (if (char-set-contains? criterion (string-ref str i))
		      (lp (+ i 1))
		      i))))
	  ((procedure? criterion)
	   (let lp ((i start))
	     (and (< i end)
		  (if (criterion (string-ref str i)) (lp (+ i 1))
		      i))))
	  (else (error "Second param is neither char-set, char, or predicate procedure."
		       string-skip criterion)))))

(define (string-skip-right str criterion . maybe-start+end)
  (let-string-start+end (start end) string-skip-right str maybe-start+end
    (cond ((char? criterion)
	   (let lp ((i (- end 1)))
	     (and (>= i start)
		  (if (char=? criterion (string-ref str i))
		      (lp (- i 1))
		      i))))
	  ((char-set? criterion)
	   (let lp ((i (- end 1)))
	     (and (>= i start)
		  (if (char-set-contains? criterion (string-ref str i))
		      (lp (- i 1))
		      i))))
	  ((procedure? criterion)
	   (let lp ((i (- end 1)))
	     (and (>= i start)
		  (if (criterion (string-ref str i)) (lp (- i 1))
		      i))))
	  (else (error "CRITERION param is neither char-set or char."
		       string-skip-right criterion)))))

(define (string-count s criterion . maybe-start+end)
  (let-string-start+end (start end) string-count s maybe-start+end
    (cond ((char? criterion)
	   (do ((i start (+ i 1))
		(count 0 (if (char=? criterion (string-ref s i))
			     (+ count 1)
			     count)))
	       ((>= i end) count)))

	  ((char-set? criterion)
	   (do ((i start (+ i 1))
		(count 0 (if (char-set-contains? criterion (string-ref s i))
			     (+ count 1)
			     count)))
	       ((>= i end) count)))

	  ((procedure? criterion)
	   (do ((i start (+ i 1))
		(count 0 (if (criterion (string-ref s i)) (+ count 1) count)))
	       ((>= i end) count)))

	  (else (error "CRITERION param is neither char-set or char."
		       string-count criterion)))))

(define (string-fill! s char . maybe-start+end)
  (check-arg char? char string-fill!)
  (let-string-start+end (start end) string-fill! s maybe-start+end
    (do ((i (- end 1) (- i 1)))
	((< i start))
      (string-set! s i char))))

(define (string-copy! to tstart from . maybe-fstart+fend)
  (let-string-start+end (fstart fend) string-copy! from maybe-fstart+fend
    (check-arg integer? tstart string-copy!)
    (check-substring-spec string-copy! to tstart (+ tstart (- fend fstart)))
    (%string-copy! to tstart from fstart fend)))

;;; Library-internal routine
(define (%string-copy! to tstart from fstart fend)
  (if (> fstart tstart)
      (do ((i fstart (+ i 1))
	   (j tstart (+ j 1)))
	  ((>= i fend))
	(string-set! to j (string-ref from i)))

      (do ((i (- fend 1)                    (- i 1))
	   (j (+ -1 tstart (- fend fstart)) (- j 1)))
	  ((< i fstart))
	(string-set! to j (string-ref from i)))))

(define (string-contains text pattern . maybe-starts+ends)
  (let-string-start+end2 (t-start t-end p-start p-end)
                         string-contains text pattern maybe-starts+ends
    (%kmp-search pattern text char=? p-start p-end t-start t-end)))

(define (string-contains-ci text pattern . maybe-starts+ends)
  (let-string-start+end2 (t-start t-end p-start p-end)
                         string-contains-ci text pattern maybe-starts+ends
    (%kmp-search pattern text char-ci=? p-start p-end t-start t-end)))

;;; Knuth-Morris-Pratt string searching

(define (%kmp-search pattern text c= p-start p-end t-start t-end)
  (let ((plen (- p-end p-start))
	(rv (make-kmp-restart-vector pattern c= p-start p-end)))

    ;; The search loop. TJ & PJ are redundant state.
    (let lp ((ti t-start) (pi 0)
	     (tj (- t-end t-start)) ; (- tlen ti) -- how many chars left.
	     (pj plen))		 ; (- plen pi) -- how many chars left.

      (if (= pi plen)
	  (- ti plen)			; Win.
	  (and (<= pj tj)		; Lose.
	       (if (c= (string-ref text ti) ; Search.
		       (string-ref pattern (+ p-start pi)))
		   (lp (+ 1 ti) (+ 1 pi) (- tj 1) (- pj 1)) ; Advance.

		   (let ((pi (vector-ref rv pi))) ; Retreat.
		     (if (= pi -1)
			 (lp (+ ti 1) 0  (- tj 1) plen) ; Punt.
			 (lp ti       pi tj       (- plen pi))))))))))

(define (make-kmp-restart-vector pattern . maybe-c=+start+end)
  (let-optionals* maybe-c=+start+end
                  ((c= char=? (procedure? c=))
		   ((start end) (lambda (args)
				  (string-parse-start+end make-kmp-restart-vector
							  pattern args))))
    (let* ((rvlen (- end start))
	   (rv (make-vector rvlen -1)))
      (if (> rvlen 0)
	  (let ((rvlen-1 (- rvlen 1))
		(c0 (string-ref pattern start)))

	    ;; Here's the main loop. We have set rv[0] ... rv[i].
	    ;; K = I + START -- it is the corresponding index into PATTERN.
	    (let lp1 ((i 0) (j -1) (k start))
	      (if (< i rvlen-1)
		  ;; lp2 invariant:
		  ;;   pat[(k-j) .. k-1] matches pat[start .. start+j-1]
		  ;;   or j = -1.
		  (let lp2 ((j j))
		    (cond ((= j -1)
			   (let ((i1 (+ 1 i)))
			     (if (not (c= (string-ref pattern (+ k 1)) c0))
				 (vector-set! rv i1 0))
			     (lp1 i1 0 (+ k 1))))
			  ;; pat[(k-j) .. k] matches pat[start..start+j].
			  ((c= (string-ref pattern k) (string-ref pattern (+ j start)))
			   (let* ((i1 (+ 1 i))
				  (j1 (+ 1 j)))
			     (vector-set! rv i1 j1)
			     (lp1 i1 j1 (+ k 1))))

			  (else (lp2 (vector-ref rv j)))))))))
      rv)))

(define (kmp-step pat rv c i c= p-start)
  (let lp ((i i))
    (if (c= c (string-ref pat (+ i p-start)))	; Match =>
	(+ i 1)					;   Done.
	(let ((i (vector-ref rv i)))		; Back up in PAT.
	  (if (= i -1) 0			; Can't back up further.
	      (lp i))))))			; Keep trying for match.

(define (string-kmp-partial-search pat rv s i . c=+p-start+s-start+s-end)
  (check-arg vector? rv string-kmp-partial-search)
  (let-optionals* c=+p-start+s-start+s-end
		  ((c=      char=? (procedure? c=))
		   (p-start 0 (and (integer? p-start) (exact? p-start) (<= 0 p-start)))
		   ((s-start s-end) (lambda (args)
				      (string-parse-start+end string-kmp-partial-search
							      s args))))
    (let ((patlen (vector-length rv)))
      (check-arg (lambda (i) (and (integer? i) (exact? i) (<= 0 i) (< i patlen)))
		 i string-kmp-partial-search)

      ;; Enough prelude. Here's the actual code.
      (let lp ((si s-start)		; An index into S.
	       (vi i))			; An index into RV.
	(cond ((= vi patlen) (- si))	; Win.
	      ((= si s-end) vi)		; Ran off the end.
	      (else			; Match s[si] & loop.
	       (let ((c (string-ref s si)))
		 (lp (+ si 1)
		     (let lp2 ((vi vi))	; This is just KMP-STEP.
		       (if (c= c (string-ref pat (+ vi p-start)))
			   (+ vi 1)
			   (let ((vi (vector-ref rv vi)))
			     (if (= vi -1) 0
				 (lp2 vi)))))))))))))

(define (string-null? s) (zero? (string-length s)))

(define (string-reverse s . maybe-start+end)
  (let-string-start+end (start end) string-reverse s maybe-start+end
    (let* ((len (- end start))
	   (ans (make-string len)))
      (do ((i start (+ i 1))
	   (j (- len 1) (- j 1)))
	  ((< j 0))
	(string-set! ans j (string-ref s i)))
      ans)))

(define (string-reverse! s . maybe-start+end)
  (let-string-start+end (start end) string-reverse! s maybe-start+end
    (do ((i (- end 1) (- i 1))
	 (j start (+ j 1)))
	((<= i j))
      (let ((ci (string-ref s i)))
	(string-set! s i (string-ref s j))
	(string-set! s j ci)))))

(define (reverse-list->string clist)
  (let* ((len (length clist))
	 (s (make-string len)))
    (do ((i (- len 1) (- i 1))   (clist clist (cdr clist)))
	((not (pair? clist)))
      (string-set! s i (car clist)))
    s))

(define (string->list s . maybe-start+end)
  (let-string-start+end (start end) string->list s maybe-start+end
    (do ((i (- end 1) (- i 1))
	 (ans '() (cons (string-ref s i) ans)))
	((< i start) ans))))

(define (string-append/shared . strings) (string-concatenate/shared strings))

(define (string-concatenate/shared strings)
  (let lp ((strings strings) (nchars 0) (first #f))
    (cond ((pair? strings)			; Scan the args, add up total
	   (let* ((string  (car strings))	; length, remember 1st
		  (tail (cdr strings))		; non-empty string.
		  (slen (string-length string)))
	     (if (zero? slen)
		 (lp tail nchars first)
		 (lp tail (+ nchars slen) (or first strings)))))

	  ((zero? nchars) "")

	  ;; Just one non-empty string! Return it.
	  ((= nchars (string-length (car first))) (car first))

	  (else (let ((ans (make-string nchars)))
		  (let lp ((strings first) (i 0))
		    (if (pair? strings)
			(let* ((s (car strings))
			       (slen (string-length s)))
			  (%string-copy! ans i s 0 slen)
			  (lp (cdr strings) (+ i slen)))))
		  ans)))))

(define (string-concatenate strings)
  (let* ((total (do ((strings strings (cdr strings))
		     (i 0 (+ i (string-length (car strings)))))
		    ((not (pair? strings)) i)))
	 (ans (make-string total)))
    (let lp ((i 0) (strings strings))
      (if (pair? strings)
	  (let* ((s (car strings))
		 (slen (string-length s)))
	    (%string-copy! ans i s 0 slen)
	    (lp (+ i slen) (cdr strings)))))
    ans))

(define (string-concatenate-reverse string-list . maybe-final+end)
  (let-optionals* maybe-final+end ((final "" (string? final))
				   (end (string-length final)
					(and (integer? end)
					     (exact? end)
					     (<= 0 end (string-length final)))))
    (let ((len (let lp ((sum 0) (lis string-list))
		 (if (pair? lis)
		     (lp (+ sum (string-length (car lis))) (cdr lis))
		     sum))))

      (%finish-string-concatenate-reverse len string-list final end))))

(define (string-concatenate-reverse/shared string-list . maybe-final+end)
  (let-optionals* maybe-final+end ((final "" (string? final))
				   (end (string-length final)
					(and (integer? end)
					     (exact? end)
					     (<= 0 end (string-length final)))))
    (let lp ((len 0) (nzlist #f) (lis string-list))
      (if (pair? lis)
	  (let ((slen (string-length (car lis))))
	    (lp (+ len slen)
		(if (or nzlist (zero? slen)) nzlist lis)
		(cdr lis)))

	  (cond ((zero? len) (substring/shared final 0 end))

		;; LEN > 0, so NZLIST is non-empty.

		((and (zero? end) (= len (string-length (car nzlist))))
		 (car nzlist))

		(else (%finish-string-concatenate-reverse len nzlist final end)))))))

(define (%finish-string-concatenate-reverse len string-list final end)
  (let ((ans (make-string (+ end len))))
    (%string-copy! ans len final 0 end)
    (let lp ((i len) (lis string-list))
      (if (pair? lis)
	  (let* ((s   (car lis))
		 (lis (cdr lis))
		 (slen (string-length s))
		 (i (- i slen)))
	    (%string-copy! ans i s 0 slen)
	    (lp i lis))))
    ans))

(define (string-replace s1 s2 start1 end1 . maybe-start+end)
  (check-substring-spec string-replace s1 start1 end1)
  (let-string-start+end (start2 end2) string-replace s2 maybe-start+end
    (let* ((slen1 (string-length s1))
	   (sublen2 (- end2 start2))
	   (alen (+ (- slen1 (- end1 start1)) sublen2))
	   (ans (make-string alen)))
      (%string-copy! ans 0 s1 0 start1)
      (%string-copy! ans start1 s2 start2 end2)
      (%string-copy! ans (+ start1 sublen2) s1 end1 slen1)
      ans)))

(define (string-tokenize s . token-chars+start+end)
  (let-optionals* token-chars+start+end
                  ((token-chars char-set:graphic (char-set? token-chars)) rest)
    (let-string-start+end (start end) string-tokenize s rest
      (let lp ((i end) (ans '()))
	(cond ((and (< start i) (string-index-right s token-chars start i)) =>
	       (lambda (tend-1)
		 (let ((tend (+ 1 tend-1)))
		   (cond ((string-skip-right s token-chars start tend-1) =>
			  (lambda (tstart-1)
			    (lp tstart-1
				(cons (substring s (+ 1 tstart-1) tend)
				      ans))))
			 (else (cons (substring s start tend) ans))))))
	      (else ans))))))

(define (xsubstring s from . maybe-to+start+end)
  (check-arg (lambda (val) (and (integer? val) (exact? val)))
	     from xsubstring)
  (receive (to start end)
           (if (pair? maybe-to+start+end)
	       (let-string-start+end (start end) xsubstring s (cdr maybe-to+start+end)
		 (let ((to (car maybe-to+start+end)))
		   (check-arg (lambda (val) (and (integer? val)
						 (exact? val)
						 (<= from val)))
			      to xsubstring)
		   (values to start end)))
	       (let ((slen (string-length (check-arg string? s xsubstring))))
		 (values (+ from slen) 0 slen)))
    (let ((slen   (- end start))
	  (anslen (- to  from)))
      (cond ((zero? anslen) "")
	    ((zero? slen) (error "Cannot replicate empty (sub)string"
				  xsubstring s from to start end))

	    ((= 1 slen)		; Fast path for 1-char replication.
	     (make-string anslen (string-ref s start)))

	    ;; Selected text falls entirely within one span.
	    ((= (floor (/ from slen)) (floor (/ to slen)))
	     (substring s (+ start (modulo from slen))
			  (+ start (modulo to   slen))))

	    ;; Selected text requires multiple spans.
	    (else (let ((ans (make-string anslen)))
		    (%multispan-repcopy! ans 0 s from to start end)
		    ans))))))

(define (string-xcopy! target tstart s sfrom . maybe-sto+start+end)
  (check-arg (lambda (val) (and (integer? val) (exact? val)))
	     sfrom string-xcopy!)
  (receive (sto start end)
           (if (pair? maybe-sto+start+end)
	       (let-string-start+end (start end) string-xcopy! s (cdr maybe-sto+start+end)
		 (let ((sto (car maybe-sto+start+end)))
		   (check-arg (lambda (val) (and (integer? val) (exact? val)))
			      sto string-xcopy!)
		   (values sto start end)))
	       (let ((slen (string-length s)))
		 (values (+ sfrom slen) 0 slen)))

    (let* ((tocopy (- sto sfrom))
	   (tend (+ tstart tocopy))
	   (slen (- end start)))
      (check-substring-spec string-xcopy! target tstart tend)
      (cond ((zero? tocopy))
	    ((zero? slen) (error "Cannot replicate empty (sub)string"
				 string-xcopy!
				 target tstart s sfrom sto start end))

	    ((= 1 slen)			; Fast path for 1-char replication.
	     (string-fill! target (string-ref s start) tstart tend))

	    ;; Selected text falls entirely within one span.
	    ((= (floor (/ sfrom slen)) (floor (/ sto slen)))
	     (%string-copy! target tstart s
			    (+ start (modulo sfrom slen))
			    (+ start (modulo sto   slen))))

	    ;; Multi-span copy.
	    (else (%multispan-repcopy! target tstart s sfrom sto start end))))))

(define (%multispan-repcopy! target tstart s sfrom sto start end)
  (let* ((slen (- end start))
	 (i0 (+ start (modulo sfrom slen)))
	 (total-chars (- sto sfrom)))

    (%string-copy! target tstart s i0 end)

    (let* ((ncopied (- end i0))			; We've copied this many.
	   (nleft (- total-chars ncopied))	; # chars left to copy.
	   (nspans (quotient nleft slen)))	; # whole spans to copy

      (do ((i (+ tstart ncopied) (+ i slen))	; Current target index.
	   (nspans nspans (- nspans 1)))	; # spans to copy
	  ((zero? nspans)
	   ;; Copy the partial-span @ the end & we're done.
	   (%string-copy! target i s start (+ start (- total-chars (- i tstart)))))

	(%string-copy! target i s start end))))); Copy a whole span.

(define (string-join strings . delim+grammar)
  (let-optionals* delim+grammar ((delim " " (string? delim))
				 (grammar 'infix))
    (let ((buildit (lambda (lis final)
		     (let recur ((lis lis))
		       (if (pair? lis)
			   (cons delim (cons (car lis) (recur (cdr lis))))
			   final)))))

      (cond ((pair? strings)
	     (string-concatenate
	      (case grammar

		((infix strict-infix)
		 (cons (car strings) (buildit (cdr strings) '())))

		((prefix) (buildit strings '()))

		((suffix)
		 (cons (car strings) (buildit (cdr strings) (list delim))))

		(else (error "Illegal join grammar"
			     grammar string-join)))))

	     ((not (null? strings))
	      (error "STRINGS parameter not list." strings string-join))

	     ;; STRINGS is ()

	     ((eq? grammar 'strict-infix)
	      (error "Empty list cannot be joined with STRICT-INFIX grammar."
		     string-join))

	     (else "")))))		; Special-cased for infix grammar.

;;; Copyright details
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The prefix/suffix and comparison routines in this code had (extremely
;;; distant) origins in MIT Scheme's string lib, and was substantially
;;; reworked by Olin Shivers (xxxxxx@ai.mit.edu) 9/98. As such, it is
;;; covered by MIT Scheme's open source copyright. See below for details.
;;;
;;; The KMP string-search code was influenced by implementations written
;;; by Stephen Bevan, Brian Dehneyer and Will Fitzgerald. However, this
;;; version was written from scratch by myself.
;;;
;;; The remainder of this code was written from scratch by myself for scsh.
;;; The scsh copyright is a BSD-style open source copyright. See below for
;;; details.
;;;     -Olin Shivers

;;; MIT Scheme copyright terms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This material was developed by the Scheme project at the Massachusetts
;;; Institute of Technology, Department of Electrical Engineering and
;;; Computer Science.  Permission to copy and modify this software, to
;;; redistribute either the original software or a modified version, and
;;; to use this software for any purpose is granted, subject to the
;;; following restrictions and understandings.
;;;
;;; 1. Any copy made of this software must include this copyright notice
;;; in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a) to
;;; return to the MIT Scheme project any improvements or extensions that
;;; they make, so that these may be included in future releases; and (b)
;;; to inform MIT of noteworthy uses of this software.
;;;
;;; 3. All materials developed as a consequence of the use of this
;;; software shall duly acknowledge such use, in accordance with the usual
;;; standards of acknowledging credit in academic research.
;;;
;;; 4. MIT has made no warrantee or representation that the operation of
;;; this software will be error-free, and MIT is under no obligation to
;;; provide any services, by way of maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this material,
;;; there shall be no use of the name of the Massachusetts Institute of
;;; Technology nor of any adaptation thereof in any advertising,
;;; promotional, or sales literature without prior written consent from
;;; MIT in each case.

;;; Scsh copyright terms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;;    notice, this list of conditions and the following disclaimer in the
;;;    documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;;    derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.