;; strings.scm - Srfi-13 string library
;;
;; Copyright (c) 2009, 2010 by Marco Benelli <mbenelli@yahoo.com>
;; All Rights Reserved.
;;
;; Based of srfi-13 reference implementation.
;; There is also a couple of bug-fixes suggested in post-finalization
;; discussion (string-concatenate-reverse/shared and make-kmp-restart-vector)

(##namespace ("strings#"))
(##include "~~lib/gambit#.scm")
(##include "charsets#.scm")
(##include "strings#.scm")

(declare
 (standard-bindings)
 (extended-bindings)
 (block)
 (not safe)
 (fixnum))

(define (check-arg pred val caller)
  (let lp ((val val))
    (if (pred val) val (lp (error "Bad argument" val pred caller)))))

;;; TODO: need redefinitions for unicode?

(define (char-cased? c)
  (or (and (char>? c #\a) (char<? c #\z))
      (and (char>? c #\A) (char<? c #\Z))))

(define char-titlecase char-upcase)

;;;

(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/shared S START [END]
;;; string-copy      S [START END]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Use optional arg and call %substring/shared

(define (substring/shared s start #!optional (end (string-length s)))
  (%substring/shared s start end))

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

(define (string-copy s #!optional (start 0) (end (string-length s)))
  (substring s start end))

;This library uses the R5RS SUBSTRING, but doesn't export it.
;Here is a definition, just for completeness.
;(define (substring s start end)
;  (check-substring-spec substring s start end)
;  (let* ((slen (- end start))
;         (ans (make-string slen)))
;    (do ((i 0 (+ i 1))
;         (j start (+ j 1)))
;        ((>= i slen) ans)
;      (string-set! ans i (string-ref s j)))))

;;; Basic iterators and other higher-order abstractions
;;; (string-map proc s [start end])
;;; (string-map! proc s [start end])
;;; (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-for-each-index proc s [start end])
;;; (string-every char-set/char/pred s [start end])
;;; (string-any   char-set/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-map proc s #!optional (start 0) (end (string-length s)))
  (%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 #!optional (start 0) (end (string-length s)))
  (%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 #!optional (start 0) (end (string-length s)))
  (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 #!optional (start 0) (end (string-length s)))
  (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 #!optional (base "") (make-final (lambda (x) "")))

    (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 #!optional (base "") (make-final (lambda (x) "")))
  (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 #!optional (start 0) (end (string-length s)))
  (let lp ((i start))
    (if (< i end)
      (begin (proc (string-ref s i))
             (lp (+ i 1))))))

(define (string-for-each-index proc s #!optional (start 0) (end (string-length s)))
  (let lp ((i start))
    (if (< i end) (begin (proc i) (lp (+ i 1))))))

(define (string-every criterion s #!optional (start 0) (end (string-length s)))
  (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 #!optional (start 0) (end (string-length s)))
  (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))



;;; string-prefix-length[-ci] s1 s2 [start1 end1 start2 end2]
;;; string-suffix-length[-ci] 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-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 #!optional
			       (start1 0) (end1 (string-length s1))
			       (start2 0) (end2 (string-length s2)))
  (%string-prefix-length s1 start1 end1 s2 start2 end2))


(define (string-suffix-length s1 s2 #!optional
			       (start1 0) (end1 (string-length s1))
			       (start2 0) (end2 (string-length s2)))
  (%string-suffix-length s1 start1 end1 s2 start2 end2))


(define (string-prefix-length-ci s1 s2 #!optional
				  (start1 0) (end1 (string-length s1))
				  (start2 0) (end2 (string-length s2)))
  (%string-prefix-length-ci s1 start1 end1 s2 start2 end2))


(define (string-suffix-length-ci s1 s2 #!optional
				  (start1 0) (end1 (string-length s1))
				  (start2 0) (end2 (string-length s2)))
  (%string-suffix-length-ci s1 start1 end1 s2 start2 end2))



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

(define (string-prefix? s1 s2 #!optional
                        (start1 0) (end1 (string-length s1))
                        (start2 0) (end2 (string-length s2)))
  (%string-prefix? s1 start1 end1 s2 start2 end2))


(define (string-suffix? s1 s2 #!optional
                        (start1 0) (end1 (string-length s1))
                        (start2 0) (end2 (string-length s2)))
  (%string-suffix? s1 start1 end1 s2 start2 end2))


(define (string-prefix-ci? s1 s2 #!optional
                           (start1 0) (end1 (string-length s1))
                           (start2 0) (end2 (string-length s2)))
  (%string-prefix-ci? s1 start1 end1 s2 start2 end2))


(define (string-suffix-ci? s1 s2 #!optional
                           (start1 0) (end1 (string-length s1))
                           (start2 0) (end2 (string-length s2)))
  (%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)))))


;;; string-compare    s1 s2 proc< proc= proc> [start1 end1 start2 end2]
;;; string-compare-ci s1 s2 proc< proc= proc> [start1 end1 start2 end2]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Primitive string-comparison functions.
;;; Continuation order is different from MIT Scheme.
;;; Continuations are applied to s1's mismatch index;
;;; in the case of equality, this is END1.

(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> #!optional
                        (start1 0) (end1 (string-length s1))
                        (start2 0) (end2 (string-length s2)))
  (%string-compare s1 start1 end1 s2 start2 end2 proc< proc= proc>))



(define (string-compare-ci s1 s2 proc< proc= proc> #!optional
                           (start1 0) (end1 (string-length s1))
                           (start2 0) (end2 (string-length s2)))
  (%string-compare-ci s1 start1 end1 s2 start2 end2 proc< proc= proc>))



;;; string=          string<>           string-ci=          string-ci<>
;;; string<          string>            string-ci<          string-ci>
;;; string<=         string>=           string-ci<=         string-ci>=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Simple definitions in terms of the previous comparison funs.
;;; I sure hope the %STRING-COMPARE calls get integrated.

(define (string= s1 s2 #!optional
          (start1 0) (end1 (string-length s1))
          (start2 0) (end2 (string-length s2)))
  (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 #!optional
                  (start1 0) (end1 (string-length s1))
                  (start2 0) (end2 (string-length s2)))
  (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 #!optional
                 (start1 0) (end1 (string-length s1))
                 (start2 0) (end2 (string-length s2)))
    (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 #!optional
                 (start1 0) (end1 (string-length s1))
                 (start2 0) (end2 (string-length s2)))
  (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 #!optional
                  (start1 0) (end1 (string-length s1))
                  (start2 0) (end2 (string-length s2)))
  (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 #!optional
                  (start1 0) (end1 (string-length s1))
                  (start2 0) (end2 (string-length s2)))
  (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 #!optional
                    (start1 0) (end1 (string-length s1))
                    (start2 0) (end2 (string-length s2)))
  (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 #!optional
                     (start1 0) (end1 (string-length s1))
                     (start2 0) (end2 (string-length s2)))
  (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 #!optional
                    (start1 0) (end1 (string-length s1))
                    (start2 0) (end2 (string-length s2)))
  (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 #!optional
                    (start1 0) (end1 (string-length s1))
                    (start2 0) (end2 (string-length s2)))
  (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 #!optional
                     (start1 0) (end1 (string-length s1))
                     (start2 0) (end2 (string-length s2)))
  (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 #!optional
                     (start1 0) (end1 (string-length s1))
                     (start2 0) (end2 (string-length s2)))
  (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)))


;;; Hash
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compute (c + 37 c + 37^2 c + ...) modulo BOUND, with sleaze thrown in
;;; to keep the intermediate values small. (We do the calculation with just
;;; enough bits to represent BOUND, masking off high bits at each step in
;;; calculation. If this screws up any important properties of the hash
;;; function I'd like to hear about it. -Olin)
;;;
;;; If you keep BOUND small enough, the intermediate calculations will
;;; always be fixnums. How small is dependent on the underlying Scheme system;
;;; we use a default BOUND of 2^22 = 4194304, which should hack it in
;;; Schemes that give you at least 29 signed bits for fixnums. The core
;;; calculation that you don't want to overflow is, worst case,
;;;     (+ 65535 (* 37 (- bound 1)))
;;; where 65535 is the max character code. Choose the default BOUND to be the
;;; biggest power of two that won't cause this expression to fixnum overflow,
;;; and everything will be copacetic.

(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 #!optional
                     (bound 4194304) (start 0) (end (string-length s)))
  (let ((bound (if (zero? bound) 4194304 bound)))
    (%string-hash s char->integer bound start end)))


(define (string-hash-ci s #!optional
                        (bound 4194304) (start 0) (end (string-length s)))
  (let ((bound (if (zero? bound) 4194304 bound)))
    (%string-hash s (lambda (c) (char->integer (char-downcase c)))
                  bound start end)))


;;; Case hacking
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string-upcase  s [start end]
;;; string-upcase! s [start end]
;;; string-downcase  s [start end]
;;; string-downcase! s [start end]
;;;
;;; string-titlecase  s [start end]
;;; string-titlecase! s [start end]
;;;   Capitalize every contiguous alpha sequence: capitalise
;;;   first char, lowercase rest.

(define (string-upcase  s #!optional (start 0) (end (string-length s)))
  (%string-map char-upcase s start end))

(define (string-upcase! s #!optional (start 0) (end (string-length s)))
  (%string-map! char-upcase s start end))

(define (string-downcase s #!optional (start 0) (end (string-length s)))
  (%string-map char-downcase s start end))

(define (string-downcase! s #!optional (start 0) (end (string-length s)))
  (%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 #!optional (start 0) (end (string-length s)))
    (%string-titlecase! s start end))

(define (string-titlecase s #!optional (start 0) (end (string-length s)))
  (let ((ans (substring s start end)))
    (%string-titlecase! ans 0 (- end start))
    ans))


;;; 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/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 #!optional
                     (criterion char-set:whitespace)
                     (start 0) (end (string-length s)))
  (cond ((string-skip s criterion start end)
         => (lambda (i) (%substring/shared s i end)))
        (else "")))

(define (string-trim-rigth s #!optional
                           (criterion char-set:whitespace)
                           (start 0) (end (string-length s)))
  (cond ((string-skip-right s criterion start end)
         => (lambda (i) (%substring/shared s 0 (+ 1 i))))
        (else "")))

(define (string-trim-both s #!optional
                          (criterion char-set:whitespace)
                          (start 0) (end (string-length s)))
  (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 #!optional
                          (char #\space) (start 0) (end (string-length s)))
  (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 #!optional
                    (char #\space) (start 0) (end (string-length s)))
  (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))))



;;; Filtering strings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string-delete char/char-set/pred string [start end]
;;; string-filter char/char-set/pred string [start end]
;;;
;;; If the criterion is a char or char-set, we scan the string twice with
;;;   string-fold -- once to determine the length of the result string,
;;;   and once to do the filtered copy.
;;; 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-delete criterion s #!optional
                       (start 0) (end (string-length s)))
  (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 #!optional
                       (start 0) (end (string-length s)))
  (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)))


;;; String search
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string-index       string char/char-set/pred [start end]
;;; string-index-right string char/char-set/pred [start end]
;;; string-skip        string char/char-set/pred [start end]
;;; string-skip-right  string char/char-set/pred [start end]
;;; string-count       string char/char-set/pred [start end]
;;;     There's a lot of replicated code here for efficiency.
;;;     For example, the char/char-set/pred discrimination has
;;;     been lifted above the inner loop of each proc.

(define (string-index str criterion #!optional
                      (start 0) (end (string-length str)))
  (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 #!optional
                            (start 0) (end (string-length str)))
  (cond ((char? criterion)
         (let lp ((i (- end 1)))
           (and (>= i 0)
                (if (char=? criterion (string-ref str i)) i
                  (lp (- i 1))))))
        ((char-set? criterion)
         (let lp ((i (- end 1)))
           (and (>= i 0)
                (if (char-set-contains? criterion (string-ref str i)) i
                  (lp (- i 1))))))
        ((procedure? criterion)
         (let lp ((i (- end 1)))
           (and (>= i 0)
                (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 #!optional
                     (start 0) (end (string-length str)))
  (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 #!optional
                           (start 0) (end (string-length str)))
  (cond ((char? criterion)
         (let lp ((i (- end 1)))
           (and (>= i 0)
                (if (char=? criterion (string-ref str i))
                  (lp (- i 1))
                  i))))
        ((char-set? criterion)
         (let lp ((i (- end 1)))
           (and (>= i 0)
                (if (char-set-contains? criterion (string-ref str i))
                  (lp (- i 1))
                  i))))
        ((procedure? criterion)
         (let lp ((i (- end 1)))
           (and (>= i 0)
                (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 #!optional
                      (start 0) (end (string-length s)))
  (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))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string-fill! string char [start end]
;;;
;;; string-copy! to tstart from [fstart fend]
;;;     Guaranteed to work, even if s1 eq s2.

(define (string-fill! s char #!optional
                       (start 0) (end (string-length s)))
    (do ((i (- end 1) (- i 1)))
        ((< i start))
      (string-set! s i char)))

(define (string-copy! to tstart from #!optional
                       (fstart 0) (fend (string-length from)))
    (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)))))



;;; 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 #!optional
                         (t-start 0) (t-end (string-length text))
                         (p-start 0) (p-end (string-length pattern)))
  (%kmp-search pattern text char=? p-start p-end t-start t-end))

(define (string-contains-ci text pattern #!optional
                            (t-start 0) (t-end (string-length text))
                            (p-start 0) (p-end (string-length pattern)))
  (%kmp-search pattern text char-ci=? p-start p-end t-start t-end))

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

; Reference version has a bug, as reported in:
; http://srfi.schemers.org/srfi-13/post-mail-archive/msg00002.html
; This version has the fix:
; http://srfi.schemers.org/srfi-13/post-mail-archive/msg00004.html
; applied.

(define (make-kmp-restart-vector pattern #!optional
                                 (c= char=?)
                                 (start 0)
                                 (end (string-length pattern)))

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

; Original (buggy) version:

;(define (make-kmp-restart-vector pattern #!optional
;                                 (c= char=?)
;                                 (start 0)
;                                 (end (string-length pattern)))
;
;  (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)
;
;            (let ((ck (string-ref pattern k)))
;              ;; 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)))
;                         (vector-set! rv i1 (if (c= ck c0) -1 0))
;                         (lp1 i1 0 (+ k 1))))
;
;                      ;; pat[(k-j) .. k] matches pat[start..start+j].
;                      ((c= ck (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
          #!optional
          (c= char=?)
          (p-start 0)
          (s-start 0)
          (s-end (string-length s)))

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

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

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

(define (string-reverse s #!optional (start 0) (end (string-length s)))
  (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 #!optional (start 0) (end (string-length s)))
  (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)
;  (apply string-fold-right cons '() s maybe-start+end))

(define (string->list s #!optional (start 0) (end (string-length s)))
  (do ((i (- end 1) (- i 1))
       (ans '() (cons (string-ref s i) ans)))
    ((< i start) ans)))

;;; 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
;;; string-append/shared s ... -> string
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STRING-APPEND/SHARED has license to return a string that shares storage
;;; with any of its arguments. In particular, if there is only one non-empty
;;; string amongst its parameters, it is permitted to return that string as
;;; its result. STRING-APPEND, by contrast, always allocates new storage.
;;;
;;; STRING-CONCATENATE & STRING-CONCATENATE/SHARED are passed a list of
;;; strings, which they concatenate into a result string. STRING-CONCATENATE
;;; always allocates a fresh string; STRING-CONCATENATE/SHARED may (or may
;;; not) return a result that shares storage with any of its arguments. In
;;; particular, if it is applied to a singleton list, it is permitted to
;;; return the car of that list as its value.

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


; 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 #!optional
                                    (final "") (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 #!optional
                                           (final "")
                                           (end (string-length final)))
  ;; Add up the lengths of all the strings in STRING-LIST; also get a
  ;; pointer NZLIST into STRING-LIST showing where the first non-zero-length
  ;; string starts.
  (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))




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

(define (string-replace s1 s2 start1 end1 #!optional
                        (start2 0) (end2 (string-length s2)))
  (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-tokenize s [token-set start end] -> list
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Break S up into a list of token strings, where a token is a maximal
;;; non-empty contiguous sequence of chars belonging to TOKEN-SET.
;;; (string-tokenize "hello, world") => ("hello," "world")

(define (string-tokenize s #!optional (token-chars char-set:graphic)
                         (start 0) (end (string-length s)))
  (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))))


;;; xsubstring 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:  (xsubstring "abcdef" 2)  => "cdefab"
;;; - To rotate a string right: (xsubstring "abcdef" -2) => "efabcd"
;;; - To replicate a string:    (xsubstring "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 (xsubstring s from #!optional (to 0)
                    (start 0) (end (string-length s)))
  (let ((to (+ from (- end start))))
    (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))))))

;;; Original version:

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


;;; string-xcopy! target tstart s sfrom [sto start end] -> unspecific
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Exactly the same as xsubstring, but the extracted text is written
;;; into the string TARGET starting at index TSTART.
;;; This operation is not defined if (EQ? TARGET S) -- you cannot copy
;;; a string on top of itself.

(define (string-xcopy! target tstart s sfrom #!optional
                       (sto 0) (start 0) (end (string-length s)))
  (let ((sto (+ sfrom (- end start))))
    (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 (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))))))
;
;;; 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.
;;;
;;; (join-strings '("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 #!optional (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.


;;; 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-set & char cases), SUBSTRING and SUBSTRING/SHARED,
;;; %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.
