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

;;; Imports
;;; This is a fairly large library. While it was written for portability, you
;;; must be aware of its dependencies in order to run it in a given scheme
;;; implementation. Here is a complete list of the dependencies it has and the
;;; assumptions it makes beyond stock R5RS Scheme:
;;;
;;; This code has the following non-R5RS dependencies:
;;; - (RECEIVE (var ...) mv-exp body ...) multiple-value binding macro;
;;;
;;; - An n-ary ERROR procedure;
;;;   
;;; - A simple CHECK-ARG procedure for checking parameter values; it is 
;;; Inserted here
(define check-arg
   (lambda (pred val proc) 
     (if (pred val) val (error "Bad arg" val pred proc))))

;;; - LET-OPTIONALS* macro for parsing, defaulting & 
;;;   type-checking optional parameters from a rest argument;
;;;   
;;; The code depends upon a small set of core string primitives from R5RS:
;;;     MAKE-STRING STRING-REF STRING? STRING-LENGTH SUBSTRING 
;;; (Actually, SUBSTRING is not a primitive, but we assume that an 
;;; implementation's native version is probably faster than one we could
;;; define, so we import it from R5RS.)
;;;
;;;   

(define (add1 n) (+ 1 n))

;;; Enough introductory blather. On to the source code. (But see the end of
;;; the file for further notes on porting & performance tuning.)


;;; Support for START/END substring specs
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This macro parses optional start/end arguments from arg lists, defaulting
;;; them to 0/(string-length s), and checks them for correctness.

(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 ...))))

;;; This one parses out a *pair* of final start/end indices. 
;;; Not exported; for internal use.
(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 ...))))))


;;; Returns three values: rest start end

(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)))


;;; Defined by R5RS, so commented out here.
;(define (string . chars)
;  (let* ((len (length chars))
;         (ans (make-string len)))
;    (do ((i 0 (+ i 1))
;	 (chars chars (cdr chars)))
;	((>= i len))
;      (string-set! ans i (car chars)))
;    ans))
;
;(define (string . chars) (string-unfold null? car cdr chars))



;;; substring S START [END] 
;;; string-copy      S [START END]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; All this goop is just arg parsing & checking surrounding a call to the
;;; actual primitive, %SUBSTRING.

;;; Split out so that other routines in this library can avoid arg-parsing
;;; overhead for END parameter.
(define (%substring s start end)
  (if (and (zero? start) (= end (string-length s))) s
      (substring s start end)))

;;; Basic iterators and other higher-order abstractions
;;; (string-fold kons knil s [start end])
;;; (string-fold-right kons knil s [start end])
;;; (string-unfold       p f g seed [base make-final])
;;; (string-unfold-right p f g seed [base make-final])
;;; (string-for-each proc s [start end])
;;; (string-every char/pred s [start end])
;;; (string-any   char/pred s [start end])
;;; (string-tabulate proc len)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; You want compiler support for high-level transforms on fold and unfold ops.
;;; You'd at least like a lot of inlining for clients of these procedures.
;;; Don't hold your breath.

(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))))

;;; (string-unfold p f g seed [base make-final])
;;; This is the fundamental constructor for strings. 
;;; - G is used to generate a series of "seed" values from the initial seed:
;;;     SEED, (G SEED), (G^2 SEED), (G^3 SEED), ...
;;; - P tells us when to stop -- when it returns true when applied to one 
;;;   of these seed values.
;;; - F maps each seed value to the corresponding character 
;;;   in the result string. These chars are assembled into the
;;;   string in a left-to-right order.
;;; - BASE is the optional initial/leftmost portion of the constructed string;
;;;   it defaults to the empty string "".
;;; - MAKE-FINAL is applied to the terminal seed value (on which P returns
;;;   true) to produce the final/rightmost portion of the constructed string.
;;;   It defaults to (LAMBDA (X) "").
;;;
;;; In other words, the following (simple, inefficient) definition holds:
;;; (define (string-unfold p f g seed base make-final)
;;;   (string-append base
;;;                  (let recur ((seed seed))
;;;                    (if (p seed) (make-final seed)
;;;                        (string-append (string (f seed))
;;;                                       (recur (g seed)))))))
;;; 
;;; STRING-UNFOLD is a fairly powerful constructor -- you can use it to
;;; reverse a string, copy a string, convert a list to a string, read
;;; a port into a string, and so forth. Examples:
;;; (port->string port) =
;;;   (string-unfold (compose eof-object? peek-char)
;;;                  read-char values port)
;;;
;;; (list->string lis) = (string-unfold null? car cdr lis)
;;; 
;;; (tabulate-string f size) = (string-unfold (lambda (i) (= i size)) f add1 0)

;;; A problem with the following simple formulation is that it pushes one
;;; stack frame for every char in the result string -- an issue if you are
;;; using it to read a 100kchar string. So we don't use it -- but I include
;;; it to give a clear, straightforward description of what the function
;;; does.

;(define (string-unfold p f g seed base make-final)
;  (let ((ans (let recur ((seed seed) (i (string-length base)))
;               (if (p seed)
;                   (let* ((final (make-final seed))
;                          (ans (make-string (+ i (string-length final)))))
;                     (string-copy! ans i final)
;                     ans)
;
;                   (let* ((c (f seed))
;                          (s (recur (g seed) (+ i 1))))
;                     (string-set! s i c)
;                     s)))))
;    (string-copy! ans 0 base)
;    ans))

;;; The strategy is to allocate a series of chunks into which we stash the
;;; chars as we generate them. Chunk size goes up in powers of two starting
;;; with 40 and levelling out at 4k, i.e.
;;;     40 40 80 160 320 640 1280 2560 4096 4096 4096 4096 4096...
;;; This should work pretty well for short strings, 1-line (80 char) strings,
;;; and longer ones. When done, we allocate an answer string and copy the
;;; chars over from the chunk buffers.

(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-every criterion s . maybe-start+end)
  (let-string-start+end (start end) string-every s maybe-start+end
	   (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))))))))



(define (string-any criterion s . maybe-start+end)
  (let-string-start+end (start end) string-any s maybe-start+end
	   (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))))))))



(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))



;;; string-prefix-length s1 s2 [start1 end1 start2 end2]
;;; string-suffix-length s1 s2 [start1 end1 start2 end2]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Find the length of the common prefix/suffix.
;;; It is not required that the two substrings passed be of equal length.
;;; This was microcode in MIT Scheme -- a very tightly bummed primitive.
;;; %STRING-PREFIX-LENGTH is the core routine of all string-comparisons,
;;; so should be as tense as possible.

(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 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)))

;;; string-prefix?    s1 s2 [start1 end1 start2 end2]
;;; string-suffix?    s1 s2 [start1 end1 start2 end2]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These are all simple derivatives of the previous counting funs.

(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)))

;;; 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)))))



;;; Cutting & pasting strings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string-take string nchars
;;; string-drop string nchars
;;;
;;; string-take-right string nchars
;;; string-drop-right string nchars
;;;
;;; string-pad string k [char start end] 
;;; string-pad-right string k [char start end] 
;;; 
;;; string-trim       string [char/char-set/pred start end] 
;;; string-trim-right string [char/char-set/pred start end] 
;;; string-trim-both  string [char/char-set/pred start end] 
;;;
;;; These trimmers invert the char-set meaning from MIT Scheme -- you
;;; say what you want to trim.

(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 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 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 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 s 0 (- len n))))


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

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

(define (string-trim-both s . criterion+start+end)
  (let-optionals* criterion+start+end ((criterion char-whitespace?) rest)
    (let-string-start+end (start end) string-trim-both s rest
      (cond ((string-skip s criterion start end) =>
	     (lambda (i)
	       (%substring 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 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 s (- end n) end)
	    (let ((ans (make-string n char)))
	      (%string-copy! ans (- n len) s start end)
	      ans))))))


;;; Filtering strings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string-remove char/pred string [start end]
;;; string-filter char/pred string [start end]
;;;
;;; If the criterion is a predicate, we don't do this double-scan strategy, 
;;;   because the predicate might have side-effects or be very expensive to
;;;   compute. So we preallocate a temp buffer pessimistically, and only do
;;;   one scan over S. This is likely to be faster and more space-efficient
;;;   than consing a list.

(define (string-remove criterion s . maybe-start+end)
  (let-string-start+end (start end) string-remove s maybe-start+end
	(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)))))

	  

(define (string-filter criterion s . maybe-start+end)
  (let-string-start+end (start end) string-filter s maybe-start+end
	(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)))))

	  


;;; String search
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string-index       string char/pred [start end]
;;; string-index-right string char/pred [start end]
;;; string-skip        string char/pred [start end]
;;; string-skip-right  string char/pred [start end]
;;; string-count       string char/pred [start end]
;;;     There's a lot of replicated code here for efficiency.

(define (string-index str criterion . maybe-start+end)
  (let-string-start+end (start end) string-index str maybe-start+end
           (let lp ((i start))
             (and (< i end)
                  (if (criterion (string-ref str i)) i
                      (lp (+ i 1)))))))

(define (string-index-right str criterion . maybe-start+end)
  (let-string-start+end (start end) string-index-right str maybe-start+end
	   (let lp ((i (- end 1)))
	     (and (>= i start)
		  (if (criterion (string-ref str i)) i
		      (lp (- i 1)))))))

(define (string-skip str criterion . maybe-start+end)
  (let-string-start+end (start end) string-skip str maybe-start+end
           (let lp ((i start))
             (and (< i end)
                  (if (criterion (string-ref str i)) (lp (+ i 1))
                      i)))))

(define (string-skip-right str criterion . maybe-start+end)
  (let-string-start+end (start end) string-skip-right str maybe-start+end
           (let lp ((i (- end 1)))
             (and (>= i start)
                  (if (criterion (string-ref str i)) (lp (- i 1))
                      i)))))

;;; Useful hacks added for SRFI 152

(define (string-take-while s criterion . maybe-start+end)
  (let-string-start+end (start end) string-take-while s maybe-start+end
    (let ((idx (string-skip s criterion start end)))
      (if idx
          (%substring s 0 idx)
          ""))))

(define (string-take-while-right s criterion . maybe-start+end)
  (let-string-start+end (start end) string-take-while s maybe-start+end
    (let ((idx (string-skip-right s criterion start end)))
      (if idx
          (%substring s (+ idx 1) (string-length s))
          ""))))

(define (string-drop-while s criterion . maybe-start+end)
  (let-string-start+end (start end) string-drop-while s maybe-start+end
    (let ((idx (string-skip s criterion start end)))
      (if idx
          (%substring s idx (string-length s))
          s))))

(define (string-drop-while-right s criterion . maybe-start+end)
  (let-string-start+end (start end) string-drop-while s maybe-start+end
    (let ((idx (string-skip-right s criterion start end)))
      (if idx
          (%substring s 0 (+ idx 1))
          s))))

(define (string-span s criterion . maybe-start+end)
  (let-string-start+end (start end) string-span s maybe-start+end
    (let ((idx (string-skip s criterion start end)))
      (if idx
        (values (%substring s 0 idx) (%substring s idx (string-length s)))
        (values "" s)))))

(define (string-break s criterion . maybe-start+end)
  (let-string-start+end (start end) string-break s maybe-start+end
    (let ((idx (string-index s criterion start end)))
      (if idx
        (values (%substring s 0 idx) (%substring s idx (string-length s)))
        (values s "")))))

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




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; %string-copy! to tstart from [fstart fend]
;;; 	Guaranteed to work, even if s1 eq s2.
;;; 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)))))



;;; Returns starting-position in STRING or #f if not true.
;;; This implementation is slow & simple. It is useful as a "spec" or for
;;; comparison testing with fancier implementations.
;;; See below for fast KMP version.

;(define (string-contains string substring . maybe-starts+ends)
;  (let-string-start+end2 (start1 end1 start2 end2) 
;                         string-contains string substring maybe-starts+ends
;    (let* ((len (- end2 start2))
;	   (i-bound (- end1 len)))
;      (let lp ((i start1))
;	(and (< i i-bound)
;	     (if (string= string substring i (+ i len) start2 end2)
;		 i
;		 (lp (+ i 1))))))))


;;; Searching for an occurrence of a substring
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(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-right text pattern . maybe-starts+ends)
  (let-string-start+end2 (t-start t-end p-start p-end)
                         string-contains-right text pattern maybe-starts+ends
    (let* ((t-len (string-length text))
           (p-len (string-length pattern))
           (p-size (- p-end p-start))
           (rt-start (- t-len t-end))
           (rt-end (- t-len t-start))
           (rp-start (- p-len p-end))
           (rp-end (- p-len p-start))
           (res (%kmp-search (string-reverse pattern)
                             (string-reverse text)
                             char=? rp-start rp-end rt-start rt-end)))
      (if res
        (- t-len res p-size)
        #f))))


;;; Knuth-Morris-Pratt string searching
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; See
;;;     "Fast pattern matching in strings"
;;;     SIAM J. Computing 6(2):323-350 1977
;;;     D. E. Knuth, J. H. Morris and V. R. Pratt
;;; also described in
;;;     "Pattern matching in strings"
;;;     Alfred V. Aho
;;;     Formal Language Theory - Perspectives and Open Problems
;;;     Ronald V. Brook (editor)
;;; This algorithm is O(m + n) where m and n are the 
;;; lengths of the pattern and string respectively

;;; KMP search source[start,end) for PATTERN. Return starting index of
;;; leftmost match or #f.

(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))))))))))

;;; (make-kmp-restart-vector pattern [c= start end]) -> integer-vector
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compute the KMP restart vector RV for string PATTERN.  If
;;; we have matched chars 0..i-1 of PATTERN against a search string S, and
;;; PATTERN[i] doesn't match S[k], then reset i := RV[i], and try again to
;;; match S[k].  If RV[i] = -1, then punt S[k] completely, and move on to
;;; S[k+1] and PATTERN[0] -- no possible match of PAT[0..i] contains S[k].
;;;
;;; In other words, if you have matched the first i chars of PATTERN, but
;;; the i+1'th char doesn't match, RV[i] tells you what the next-longest
;;; prefix of PATTERN is that you have matched.
;;;
;;; - C= (default CHAR=?) is used to compare characters for equality.
;;;   Pass in CHAR-CI=? for case-folded string search.
;;;
;;; - START & END restrict the pattern to the indicated substring; the
;;;   returned vector will be of length END - START. The numbers stored
;;;   in the vector will be values in the range [0,END-START) -- that is,
;;;   they are valid indices into the restart vector; you have to add START
;;;   to them to use them as indices into PATTERN.
;;;
;;; I've split this out as a separate function in case other constant-string
;;; searchers might want to use it.
;;;
;;; E.g.:
;;;    a b d  a b x
;;; #(-1 0 0 -1 1 2)

#;(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 (make-kmp-restart-vector pattern . maybe-c=+start+end)
  (let-optionals* maybe-c=+start+end
                  ((c= char=?) rest) ; (procedure? c=))
     (receive (rest2 start end) (string-parse-start+end make-kmp-restart-vector pattern rest)
       (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 (+ i 1))
				 (ck+1 (string-ref pattern (add1 k))))
			     (vector-set! rv i1 (if (c= ck+1 c0) -1 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))))


;;; We've matched I chars from PAT. C is the next char from the search string.
;;; Return the new I after handling C. 
;;;
;;; The pattern is (VECTOR-LENGTH RV) chars long, beginning at index PAT-START
;;; in PAT (PAT-START is usually 0). The I chars of the pattern we've matched
;;; are 
;;;     PAT[PAT-START .. PAT-START + I].
;;;
;;; It's *not* an oversight that there is no friendly error checking or
;;; defaulting of arguments. This is a low-level, inner-loop procedure
;;; that we want integrated/inlined into the point of call.

(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.

;;; Zip through S[start,end), looking for a match of PAT. Assume we've
;;; already matched the first I chars of PAT when we commence at S[start].
;;; - <0:  If we find a match *ending* at index J, return -J.
;;; - >=0: If we get to the end of the S[start,end) span without finding
;;;   a complete match, return the number of chars from PAT we'd matched
;;;   when we ran off the end.
;;;
;;; This is useful for searching *across* buffers -- that is, when your
;;; input comes in chunks of text. We hand-integrate the KMP-STEP loop
;;; for speed.

(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) rest) ; (and (integer? p-start) (exact? p-start) (<= 0 p-start)))
    (receive (rest2 s-start s-end) (string-parse-start+end string-kmp-partial-search s rest)
    ;; Enough prelude. Here's the actual code.
    (let ((patlen (vector-length rv)))
      (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))))))))))))) )


;;; Misc
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (string-null? s)
;;; (reverse-list->string clist)
;;; (string->list s [start end])

(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 (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))


;;; Defined by R5RS, so commented out here.
;(define (list->string lis) (string-unfold null? car cdr lis))


;;; string-concatenate        string-list -> string
;;; string-concatenate/shared string-list -> string
; Alas, Scheme 48's APPLY blows up if you have many, many arguments.
;(define (string-concatenate strings) (apply string-append strings))

;;; Here it is written out. I avoid using REDUCE to add up string lengths
;;; to avoid non-R5RS dependencies.
(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))
	  

;;; Defined by R5RS, so commented out here.
;(define (string-append . strings) (string-concatenate strings))

;;; string-concatenate-reverse        string-list [final-string end] -> string
;;; string-concatenate-reverse/shared string-list [final-string end] -> string
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Return
;;;   (string-concatenate 
;;;     (reverse
;;;       (cons (substring final-string 0 end) string-list)))

(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 (%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))




;;; string-replace s1 s2 start1 end1 [start2 end2] -> string
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Replace S1[START1,END1) with S2[START2,END2).

(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)))


;;; string-split s delimiter [grammar limit start end] -> list
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Returns a list of the words contained in the substring of string from
;;; start (inclusive) to end (exclusive). Delimiter specifies a string
;;; whose characters are to be used as the word separator. The returned
;;; list will then have one more item than the number of non-overlapping
;;; occurrences of the delimiter in the string. If delimiter is an
;;; empty string, then the returned list contains a list of strings,
;;; each of which contains a single character.  Grammar is a symbol with
;;; the same meaning as in the string-join procedure. If it is infix,
;;; which is the default, processing is done as described above, except
;;; that an empty s produces the empty list; if it is strict-infix,
;;; an empty s signals an error. The values prefix and suffix cause a
;;; leading/trailing empty string in the result to be suppressed.
;;;
;;; If limit is a non-negative exact integer, at most that many splits
;;; occur, and the remainder of string is returned as the final element
;;; of the list (thus, the result will have at most limit+1 elements). If
;;; limit is not specified or is #f, then as many splits as possible
;;; are made. It is an error if limit is any other value.
;;;
;;; Thanks to Shiro Kawai for the following code.

(define (string-split s delimiter . args)
  ;; The argument checking part might be refactored with other srfi-130
  ;; routines.
  (if (not (string? s)) (error "string expected" s))
  (if (not (string? delimiter)) (error "string expected" delimiter))
  (let ((slen (string-length s)))
    (receive (grammar limit no-limit start end)
        (if (pair? args)
          (if (pair? (cdr args))
            (if (pair? (cddr args))
              (if (pair? (cdddr args))
                (values (car args) (cadr args) #f (caddr args) (cadddr args))
                (values (car args) (cadr args) #f (caddr args) slen))
              (values (car args) (cadr args) #f 0 slen))
            (values (car args) #f #t 0 slen))
          (values 'infix #f #t 0 slen))
      (if (not (memq grammar '(infix strict-infix prefix suffix)))
        (error "grammar must be one of (infix strict-infix prefix suffix)" grammar))
      (if (not limit) (set! no-limit #t))
      (if (not (or no-limit
                  (and (integer? limit) (exact? limit) (>= limit 0))))
        (error "limit must be exact nonnegative integer or #f" limit))
      (if (not (and (integer? start) (exact? start)))
        (error "start argument must be exact integer" start))
      (if (not (<= 0 start slen))
        (error "start argument out of range" start))
      (if (not (<= 0 end slen))
        (error "end argument out of range" end))
      (if (not (<= start end))
        (error "start argument is greater than end argument" (list start end)))

      (cond ((= start end)
             (if (eq? grammar 'strict-infix)
               (error "empty string cannot be spilt with strict-infix grammar")
               '()))
            ((string-null? delimiter)
             (%string-split-chars s start end limit))
            (else (%string-split s start end delimiter grammar limit))))))

(define (%string-split-chars s start end limit)
  (if (not limit)
    (map string (string->list s start end))
    (let loop ((r '()) (c start) (n 0))
      (cond ((= c end) (reverse r))
            ((>= n limit) (reverse (cons (substring s c end) r)))
            (else (loop (cons (string (string-ref s c)) r)
                        (+ c 1)
                        (+ n 1)))))))

(define (%string-split s start end delimiter grammar limit)
  (let ((dlen (string-length delimiter)))
    (define (finish r c)
      (let ((rest (substring s c end)))
        (if (and (eq? grammar 'suffix) (string-null? rest))
          (reverse r)
          (reverse (cons rest r)))))
    (define (scan r c n)
      (if (and limit (>= n limit))
        (finish r c)
        (let ((i (string-contains s delimiter c end)))
          (if i
            (let ((fragment (substring s c i)))
              (if (and (= n 0) (eq? grammar 'prefix) (string-null? fragment))
                (scan r (+ i dlen) (+ n 1))
                (scan (cons fragment r) 
                      (+ i dlen)
                      (+ n 1))))
            (finish r c)))))
    (scan '() start 0)))



;;; string-replicate s from [to start end] -> string
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; S is a string; START and END are optional arguments that demarcate
;;; a substring of S, defaulting to 0 and the length of S (e.g., the whole
;;; string). Replicate this substring up and down index space, in both the
;;  positive and negative directions. For example, if S = "abcdefg", START=3, 
;;; and END=6, then we have the conceptual bidirectionally-infinite string
;;;     ...  d  e  f  d  e  f  d  e  f  d  e  f  d  e  f  d  e  f  d  e  f ...
;;;     ... -9 -8 -7 -6 -5 -4 -3 -2 -1  0  1  2  3  4  5  6  7  8  9 ...
;;; XSUBSTRING returns the substring of this string beginning at index FROM,
;;; and ending at TO (which defaults to FROM+(END-START)).
;;; 
;;; You can use XSUBSTRING in many ways:
;;; - To rotate a string left:  (string-replicate "abcdef" 2)  => "cdefab"
;;; - To rotate a string right: (string-replicate "abcdef" -2) => "efabcd"
;;; - To replicate a string:    (string-replicate "abc" 0 7) => "abcabca"
;;;
;;; Note that 
;;;   - The FROM/TO indices give a half-open range -- the characters from
;;;     index FROM up to, but not including index TO.
;;;   - The FROM/TO indices are not in terms of the index space for string S.
;;;     They are in terms of the replicated index space of the substring
;;;     defined by S, START, and END.
;;;
;;; It is an error if START=END -- although this is allowed by special
;;; dispensation when FROM=TO.

(define (string-replicate s from . maybe-to+start+end)
  (check-arg (lambda (val) (and (integer? val) (exact? val)))
	     from string-replicate)
  (receive (to start end)
           (if (pair? maybe-to+start+end)
	       (let-string-start+end (start end) string-replicate 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 string-replicate)
		   (values to start end)))
	       (let ((slen (string-length (check-arg string? s string-replicate))))
		 (values (+ from slen) 0 slen)))
    (let ((slen   (- end start))
	  (anslen (- to  from)))
      (cond ((zero? anslen) "")
	    ((zero? slen) (error "Cannot replicate empty (sub)string"
				  string-replicate 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))))))


;;; This is the core copying loop for XSUBSTRING and STRING-XCOPY!
;;; Internal -- not exported, no careful arg checking.
(define (%multispan-repcopy! target tstart s sfrom sto start end)
  (let* ((slen (- end start))
	 (i0 (+ start (modulo sfrom slen)))
	 (total-chars (- sto sfrom)))

    ;; Copy the partial span ! the beginning
    (%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
			   
      ;; Copy the whole spans in the middle.
      (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.



;;; (string-join string-list [delimiter grammar]) => string
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Paste strings together using the delimiter string.
;;;
;;; (string-join '("foo" "bar" "baz") ":") => "foo:bar:baz"
;;;
;;; DELIMITER defaults to a single space " "
;;; GRAMMAR is one of the symbols {prefix, infix, strict-infix, suffix} 
;;; and defaults to 'infix.
;;;
;;; I could rewrite this more efficiently -- precompute the length of the
;;; answer string, then allocate & fill it in iteratively. Using 
;;; STRING-CONCATENATE is less efficient.

(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.

(define (string-segment str k)
  (if (< k 1) (error "minimum segment size is 1" k))
  (let ((len (string-length str)))
    (let loop ((start 0)
               (result '()))
      (if (= start len)
        (reverse result)
        (let ((end (min (+ start k) len)))
          (loop end (cons (%substring str start end) result)))))))


;;; Porting & performance-tuning notes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; See the section at the beginning of this file on external dependencies.
;;;
;;; The biggest issue with respect to porting is the LET-OPTIONALS* macro.
;;; There are many, many optional arguments in this library; the complexity
;;; of parsing, defaulting & type-testing these parameters is handled with the
;;; aid of this macro. There are about 15 uses of LET-OPTIONALS*. You can
;;; rewrite the uses, port the hairy macro definition (which is implemented
;;; using a Clinger-Rees low-level explicit-renaming macro system), or port
;;; the simple, high-level definition, which is less efficient.
;;;
;;; There is a fair amount of argument checking. This is, strictly speaking,
;;; unnecessary -- the actual body of the procedures will blow up if, say, a
;;; START/END index is improper. However, the error message will not be as
;;; good as if the error were caught at the "higher level." Also, a very, very
;;; smart Scheme compiler may be able to exploit having the type checks done
;;; early, so that the actual body of the procedures can assume proper values.
;;; This isn't likely; this kind of compiler technology isn't common any 
;;; longer.
;;; 
;;; The overhead of optional-argument parsing is irritating. The optional
;;; arguments must be consed into a rest list on entry, and then parsed out.
;;; Function call should be a matter of a few register moves and a jump; it
;;; should not involve heap allocation! Your Scheme system may have a superior
;;; non-R5RS optional-argument system that can eliminate this overhead. If so,
;;; then this is a prime candidate for optimising these procedures,
;;; *especially* the many optional START/END index parameters.
;;;
;;; Note that optional arguments are also a barrier to procedure integration.
;;; If your Scheme system permits you to specify alternate entry points
;;; for a call when the number of optional arguments is known in a manner
;;; that enables inlining/integration, this can provide performance 
;;; improvements.
;;;
;;; There is enough *explicit* error checking that *all* string-index
;;; operations should *never* produce a bounds error. Period. Feel like
;;; living dangerously? *Big* performance win to be had by replacing
;;; STRING-REF's and STRING-SET!'s with unsafe equivalents in the loops. 
;;; Similarly, fixnum-specific operators can speed up the arithmetic done on 
;;; the index values in the inner loops. The only arguments that are not
;;; completely error checked are
;;;   - string lists (complete checking requires time proportional to the
;;;     length of the list)
;;;   - procedure arguments, such as char->char maps & predicates.
;;;     There is no way to check the range & domain of procedures in Scheme.
;;; Procedures that take these parameters cannot fully check their
;;; arguments. But all other types to all other procedures are fully
;;; checked.
;;;
;;; This does open up the alternate possibility of simply *removing* these 
;;; checks, and letting the safe primitives raise the errors. On a dumb
;;; Scheme system, this would provide speed (by eliminating the redundant
;;; error checks) at the cost of error-message clarity.
;;;
;;; See the comments preceding the hash function code for notes on tuning
;;; the default bound so that the code never overflows your implementation's
;;; fixnum size into bignum calculation.
;;;
;;; In an interpreted Scheme, some of these procedures, or the internal
;;; routines with % prefixes, are excellent candidates for being rewritten
;;; in C. Consider STRING-HASH, %STRING-COMPARE, the 
;;; %STRING-{SUF,PRE}FIX-LENGTH routines, STRING-COPY!, STRING-INDEX &
;;; STRING-SKIP (char case), SUBSTRING and SUBSTRING,
;;; %KMP-SEARCH, and %MULTISPAN-REPCOPY!.
;;;
;;; It would also be nice to have the ability to mark some of these
;;; routines as candidates for inlining/integration.
;;; 
;;; All the %-prefixed routines in this source code are written
;;; to be called internally to this library. They do *not* perform
;;; friendly error checks on the inputs; they assume everything is
;;; proper. They also do not take optional arguments. These two properties
;;; save calling overhead and enable procedure integration -- but they
;;; are not appropriate for exported routines.


;;; 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 (shivers@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.
