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.