source: project/chicken/trunk/srfi-13.scm @ 13737

Last change on this file since 13737 was 13737, checked in by Kon Lovett, 11 years ago

Rmvd noin-existent ident. Updated for apropos status.

File size: 79.9 KB
Line 
1;;;; srfi-13.scm - Shivers' reference implementation of SRFI-13
2
3
4(declare
5  (unit srfi-13)
6  (uses srfi-14)
7  (fixnum)
8  (disable-warning redef)
9  (hide %string-prefix? %string-hash %finish-string-concatenate-reverse %string-suffix-length %string-prefix-length
10        %string-map %string-copy! %string-compare %substring/shared %string-suffix? %multispan-repcopy!
11        %string-prefix-length-ci %string-suffix-length-ci %string-prefix-ci? %string-suffix-ci?
12        ##srfi13#traverse
13        %string-titlecase! %string-map! %string-compare-ci ##srfi13#string-fill!)
14  (standard-bindings not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr
15                     cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar
16                     cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!
17                     null? list list? length zero? * - error + / - > < >= <= current-output-port current-input-port
18                     write-char newline write display append symbol->string char? char->integer
19                     integer->char eof-object? vector-length string-length string-ref string-set! vector-ref 
20                     vector-set! char=? char<? char>? char>=? char<=? gcd lcm reverse symbol? string->symbol
21                     number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact?
22                     max min quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact
23                     exp log sin expt sqrt cos tan asin acos atan number->string string->number char-ci=?
24                     char-ci<? char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric?
25                     char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string<?
26                     string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?
27                     string-append list->string vector? vector->list list->vector string read map for-each
28                     read-char substring vector-fill! make-string make-vector open-input-file
29                     open-output-file call-with-input-file call-with-output-file close-input-port close-output-port
30                     port? values call-with-values vector procedure? memq memv assq assv member assoc) 
31  (extended-bindings)
32  (disable-interrupts) )
33
34(cond-expand
35 [paranoia]
36 [else
37  (declare
38    (no-procedure-checks-for-usual-bindings)
39    (bound-to-procedure
40     string-concatenate check-substring-spec ##srfi13#string-fill! string-parse-final-start+end
41     ##sys#substring string-index-right string-skip-right substring/shared
42     string-concatenate/shared make-kmp-restart-vector string-ci= string= char-set?
43     char-set-contains? string-fold char-set string-skip string-index string-downcase! char->int
44     string-parse-start+end substring-spec-ok?)
45    (no-bound-checks) ) ] )
46
47(include "unsafe-declarations.scm")
48
49(register-feature! 'srfi-13)
50
51
52(define-inline (char-cased? c) (char-alphabetic? c))
53(define-inline (char-titlecase c) (char-upcase c))
54
55
56;;; SRFI 13 string library reference implementation             -*- Scheme -*-
57;;; Olin Shivers 5/2000
58;;;
59;;; Copyright (c) 1988-1994 Massachusetts Institute of Technology.
60;;; Copyright (c) 1998, 1999, 2000 Olin Shivers. All rights reserved.
61;;;   The details of the copyrights appear at the end of the file. Short
62;;;   summary: BSD-style open source.
63
64;;; Exports:
65;;; string-map string-map!
66;;; string-fold       string-unfold
67;;; string-fold-right string-unfold-right
68;;; string-tabulate string-for-each string-for-each-index
69;;; string-every string-any
70;;; string-hash string-hash-ci
71;;; string-compare string-compare-ci
72;;; string=    string<    string>    string<=    string>=    string<>
73;;; string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<>
74;;; string-downcase  string-upcase  string-titlecase 
75;;; string-downcase! string-upcase! string-titlecase!
76;;; string-take string-take-right
77;;; string-drop string-drop-right
78;;; string-pad string-pad-right
79;;; string-trim string-trim-right string-trim-both
80;;; string-filter string-delete
81;;; string-index string-index-right
82;;; string-skip  string-skip-right
83;;; string-count
84;;; string-prefix-length string-prefix-length-ci
85;;; string-suffix-length string-suffix-length-ci
86;;; string-prefix? string-prefix-ci?
87;;; string-suffix? string-suffix-ci?
88;;; string-contains string-contains-ci
89;;; string-copy! substring/shared
90;;; string-reverse string-reverse! reverse-list->string
91;;; string-concatenate string-concatenate/shared string-concatenate-reverse
92;;; string-append/shared
93;;; xsubstring string-xcopy!
94;;; string-null?
95;;; string-join
96;;; string-tokenize
97;;; string-replace
98;;;
99;;; R5RS extended:
100;;; string->list string-copy string-fill!
101;;;
102;;; R5RS re-exports:
103;;; string? make-string string-length string-ref string-set!
104;;;
105;;; R5RS re-exports (also defined here but commented-out):
106;;; string string-append list->string
107;;;
108;;; Low-level routines:
109;;; make-kmp-restart-vector string-kmp-partial-search kmp-step
110;;; string-parse-start+end
111;;; string-parse-final-start+end
112;;; let-string-start+end
113;;; check-substring-spec
114;;; substring-spec-ok?
115
116;;; Imports
117;;; This is a fairly large library. While it was written for portability, you
118;;; must be aware of its dependencies in order to run it in a given scheme
119;;; implementation. Here is a complete list of the dependencies it has and the
120;;; assumptions it makes beyond stock R5RS Scheme:
121;;;
122;;; This code has the following non-R5RS dependencies:
123;;; - (RECEIVE (var ...) mv-exp body ...) multiple-value binding macro;
124;;;
125;;; - Various imports from the char-set library for the routines that can
126;;;   take char-set arguments;
127;;;   
128;;; - An n-ary ERROR procedure;
129;;;   
130;;; - BITWISE-AND for the hash functions;
131;;;   
132;;; - A simple CHECK-ARG procedure for checking parameter values; it is
133;;;   (lambda (pred val proc)
134;;;     (if (pred val) val (error "Bad arg" val pred proc)))
135;;;   
136;;; - :OPTIONAL and LET-OPTIONALS* macros for parsing, defaulting &
137;;;   type-checking optional parameters from a rest argument;
138;;;   
139;;; - CHAR-CASED? and CHAR-TITLECASE for the STRING-TITLECASE &
140;;;   STRING-TITLECASE! procedures. The former returns true iff a character is
141;;;   one that has case distinctions; in ASCII it returns true on a-z and A-Z.
142;;;   CHAR-TITLECASE is analagous to CHAR-UPCASE and CHAR-DOWNCASE. In ASCII &
143;;;   Latin-1, it is the same as CHAR-UPCASE.
144;;;
145;;; The code depends upon a small set of core string primitives from R5RS:
146;;;     MAKE-STRING STRING-REF STRING-SET! STRING? STRING-LENGTH SUBSTRING
147;;; (Actually, SUBSTRING is not a primitive, but we assume that an
148;;; implementation's native version is probably faster than one we could
149;;; define, so we import it from R5RS.)
150;;;
151;;; The code depends upon a small set of R5RS character primitives:
152;;;   char? char=? char-ci=? char<? char-ci<?
153;;;   char-upcase char-downcase
154;;;   char->integer (for the hash functions)
155;;;   
156;;; We assume the following:
157;;; - CHAR-DOWNCASE o CHAR-UPCASE = CHAR-DOWNCASE
158;;; - CHAR-CI=? is equivalent to
159;;;     (lambda (c1 c2) (char=? (char-downcase (char-upcase c1))
160;;;                             (char-downcase (char-upcase c2))))
161;;; - CHAR-UPCASE, CHAR-DOWNCASE and CHAR-TITLECASE are locale-insensitive
162;;;   and consistent with Unicode's 1-1 char-mapping spec.
163;;; These things are typically true, but if not, you would need to modify
164;;; the case-mapping and case-insensitive routines.
165
166;;; Enough introductory blather. On to the source code. (But see the end of
167;;; the file for further notes on porting & performance tuning.)
168
169
170;;; Support for START/END substring specs
171;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
172
173(cond-expand
174 ((not hygienic-macros)
175  (define-macro (let-string-start+end2 s-e proc s1 s2 args . body)
176    (let ([procv (gensym)]
177          [rest (gensym)] )
178      `(let ((,procv ,proc))
179         (let-string-start+end 
180          (,(car s-e) ,(cadr s-e) ,rest) ,procv ,s1 ,args
181          (let-string-start+end 
182           ,(cddr s-e) ,procv ,s2 ,rest
183           ,@body) ) ) ) ) )
184 (else
185  (define-syntax let-string-start+end2
186    (syntax-rules ()
187      ((_ (s-e1 s-e2 s-e3 s-e4) proc s1 s2 args . body)
188       (let ((procv proc))
189         (let-string-start+end 
190          (s-e1 s-e2 rest) procv s1 args
191          (let-string-start+end 
192           (s-e3 s-e4) procv s2 rest
193           . body) ) ) ) ) ) ) )
194
195(cond-expand
196 ((not hygienic-macros)
197  (define-macro (let-string-start+end s-e-r proc s-exp args-exp . body)
198    (if (pair? (cddr s-e-r))
199        `(receive (,(caddr s-e-r) ,(car s-e-r) ,(cadr s-e-r))
200             (string-parse-start+end ,proc ,s-exp ,args-exp)
201           ,@body)
202        `(receive ,s-e-r
203             (string-parse-final-start+end ,proc ,s-exp ,args-exp)
204           ,@body) ) ) )
205 (else
206  (define-syntax let-string-start+end
207    (lambda (form r c)
208      (##sys#check-syntax 'let-string-start+end form '(_ _ _ _ _ . _))
209      (let ((s-e-r (cadr form))
210            (proc (caddr form))
211            (s-exp (cadddr form))
212            (args-exp (car (cddddr form)))
213            (body (cdr (cddddr form)))
214            (%receive (r 'receive))
215            (%string-parse-start+end (r 'string-parse-start+end))
216            (%string-parse-final-start+end (r 'string-parse-final-start+end)))
217        (if (pair? (cddr s-e-r))
218            `(,%receive (,(caddr s-e-r) ,(car s-e-r) ,(cadr s-e-r))
219                        (,%string-parse-start+end ,proc ,s-exp ,args-exp)
220                        ,@body)
221            `(,%receive ,s-e-r
222                        (,%string-parse-final-start+end ,proc ,s-exp ,args-exp)
223                        ,@body) ) )))) )
224
225
226;;; Returns three values: rest start end
227
228(define (string-parse-start+end proc s args)
229  (##sys#check-string s 'string-parse-start+end)
230  (let ((slen (string-length s)))
231    (if (pair? args)
232
233        (let ((start (car args))
234              (args (cdr args)))
235;         (if (and (integer? start) (exact? start) (>= start 0))
236          (if (and (fixnum? start) (>= start 0))
237              (receive (end args)
238                  (if (pair? args)
239                      (let ((end (car args))
240                            (args (cdr args)))
241;                       (if (and (integer? end) (exact? end) (<= end slen))
242                        (if (and (fixnum? end) (<= end slen))
243                            (values end args)
244                            (##sys#error 'string-parse-start+end "Illegal substring END spec" proc end s)))
245                      (values slen args))
246                (if (<= start end) (values args start end)
247                    (##sys#error 'string-parse-start+end "Illegal substring START/END spec"
248                           proc start end s)))
249              (##sys#error 'string-parse-start+end "Illegal substring START spec" proc start s)))
250
251        (values '() 0 slen))))
252
253(define (string-parse-final-start+end proc s args)
254  (receive (rest start end) (string-parse-start+end proc s args)
255    (if (pair? rest) (##sys#error 'string-parse-final-start+end "Extra arguments to procedure" proc rest)
256        (values start end))))
257
258(define (substring-spec-ok? s start end)
259  (and (string? s)
260;       (integer? start)
261;       (exact? start)
262;       (integer? end)
263;       (exact? end)
264       (fixnum? start)
265       (fixnum? end)
266       (<= 0 start)
267       (<= start end)
268       (<= end (string-length s))))
269
270(define (check-substring-spec proc s start end)
271  (if (not (substring-spec-ok? s start end))
272      (##sys#error 'check-substring-spec "Illegal substring spec." proc s start end)))
273
274
275;;; Defined by R5RS, so commented out here.
276;(define (string . chars)
277;  (let* ((len (length chars))
278;         (ans (make-string len)))
279;    (do ((i 0 (+ i 1))
280;        (chars chars (cdr chars)))
281;       ((>= i len))
282;      (string-set! ans i (car chars)))
283;    ans))
284;
285;(define (string . chars) (string-unfold null? car cdr chars))
286
287
288
289;;; substring/shared S START [END]
290;;; string-copy      S [START END]
291;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
292
293;;; All this goop is just arg parsing & checking surrounding a call to the
294;;; actual primitive, %SUBSTRING/SHARED.
295
296(define (substring/shared s start . maybe-end)
297;  (check-arg string? s substring/shared)
298  (let ((slen (string-length s)))
299;    (check-arg (lambda (start) (and (integer? start) (exact? start) (<= 0 start)))
300;              start substring/shared)
301    (let ([n (optional maybe-end slen)])
302      (##sys#check-exact n 'substring/shared)
303      (check-substring-spec 'substring/shared s start n)
304      (%substring/shared s start n) ) ) )
305#|
306    (%substring/shared s start
307                       (:optional maybe-end slen
308                                  (lambda (end) (and (integer? end)
309                                                     (exact? end)
310                                                     (<= start end)
311                                                     (<= end slen)))))))
312|#
313
314;;; Split out so that other routines in this library can avoid arg-parsing
315;;; overhead for END parameter.
316(define (%substring/shared s start end)
317  (if (and (zero? start) (= end (string-length s))) s
318      (##sys#substring s start end)))
319
320(define (string-copy s . maybe-start+end)
321  (let-string-start+end (start end) string-copy s maybe-start+end
322    (##sys#substring s start end)))
323
324;This library uses the R5RS SUBSTRING, but doesn't export it.
325;Here is a definition, just for completeness.
326;(define (substring s start end)
327;  (check-substring-spec substring s start end)
328;  (let* ((slen (- end start))
329;         (ans (make-string slen)))
330;    (do ((i 0 (+ i 1))
331;         (j start (+ j 1)))
332;        ((>= i slen) ans)
333;      (string-set! ans i (string-ref s j)))))
334
335;;; Basic iterators and other higher-order abstractions
336;;; (string-map proc s [start end])
337;;; (string-map! proc s [start end])
338;;; (string-fold kons knil s [start end])
339;;; (string-fold-right kons knil s [start end])
340;;; (string-unfold       p f g seed [base make-final])
341;;; (string-unfold-right p f g seed [base make-final])
342;;; (string-for-each       proc s [start end])
343;;; (string-for-each-index proc s [start end])
344;;; (string-every char-set/char/pred s [start end])
345;;; (string-any   char-set/char/pred s [start end])
346;;; (string-tabulate len proc)
347;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
348;;; You want compiler support for high-level transforms on fold and unfold ops.
349;;; You'd at least like a lot of inlining for clients of these procedures.
350;;; Don't hold your breath.
351
352;;; Shut up, Olin (flw)
353
354(define (string-map proc s . maybe-start+end)
355;  (check-arg procedure? proc string-map)
356  (let-string-start+end (start end) string-map s maybe-start+end
357    (%string-map proc s start end)))
358
359(define (%string-map proc s start end)  ; Internal utility
360  (let* ((len (- end start))
361         (ans (make-string len)))
362    (do ((i 0 (+ i 1))
363         (j start (+ j 1)))
364        ((>= i len))
365      (string-set! ans i (proc (string-ref s j))))
366    ans))
367
368(define (string-map! proc s . maybe-start+end)
369;  (check-arg procedure? proc string-map!)
370  (let-string-start+end (start end) string-map! s maybe-start+end
371    (%string-map! proc s start end)))
372
373(define (%string-map! proc s start end)
374  (do ((i start (+ i 1)))
375      ((>= i end) s)
376    (string-set! s i (proc (string-ref s i)))))
377
378(define (string-fold kons knil s . maybe-start+end)
379;  (check-arg procedure? kons string-fold)
380  (let-string-start+end (start end) string-fold s maybe-start+end
381    (let lp ((v knil) (i start))
382      (if (< i end) (lp (kons (string-ref s i) v) (+ i 1))
383          v))))
384
385(define (string-fold-right kons knil s . maybe-start+end)
386;  (check-arg procedure? kons string-fold-right)
387  (let-string-start+end (start end) string-fold-right s maybe-start+end
388    (let lp ((v knil) (i (- end 1)))
389      (if (>= i start) (lp (kons (string-ref s i) v) (- i 1))
390          v))))
391
392;;; (string-unfold p f g seed [base make-final])
393;;; This is the fundamental constructor for strings.
394;;; - G is used to generate a series of "seed" values from the initial seed:
395;;;     SEED, (G SEED), (G^2 SEED), (G^3 SEED), ...
396;;; - P tells us when to stop -- when it returns true when applied to one
397;;;   of these seed values.
398;;; - F maps each seed value to the corresponding character
399;;;   in the result string. These chars are assembled into the
400;;;   string in a left-to-right order.
401;;; - BASE is the optional initial/leftmost portion of the constructed string;
402;;;   it defaults to the empty string "".
403;;; - MAKE-FINAL is applied to the terminal seed value (on which P returns
404;;;   true) to produce the final/rightmost portion of the constructed string.
405;;;   It defaults to (LAMBDA (X) "").
406;;;
407;;; In other words, the following (simple, inefficient) definition holds:
408;;; (define (string-unfold p f g seed base make-final)
409;;;   (string-append base
410;;;                  (let recur ((seed seed))
411;;;                    (if (p seed) (make-final seed)
412;;;                        (string-append (string (f seed))
413;;;                                       (recur (g seed)))))))
414;;;
415;;; STRING-UNFOLD is a fairly powerful constructor -- you can use it to
416;;; reverse a string, copy a string, convert a list to a string, read
417;;; a port into a string, and so forth. Examples:
418;;; (port->string port) =
419;;;   (string-unfold (compose eof-object? peek-char)
420;;;                  read-char values port)
421;;;
422;;; (list->string lis) = (string-unfold null? car cdr lis)
423;;;
424;;; (tabulate-string f size) = (string-unfold (lambda (i) (= i size)) f add1 0)
425
426;;; A problem with the following simple formulation is that it pushes one
427;;; stack frame for every char in the result string -- an issue if you are
428;;; using it to read a 100kchar string. So we don't use it -- but I include
429;;; it to give a clear, straightforward description of what the function
430;;; does.
431
432;(define (string-unfold p f g seed base make-final)
433;  (let ((ans (let recur ((seed seed) (i (string-length base)))
434;               (if (p seed)
435;                   (let* ((final (make-final seed))
436;                          (ans (make-string (+ i (string-length final)))))
437;                     (string-copy! ans i final)
438;                     ans)
439;
440;                   (let* ((c (f seed))
441;                          (s (recur (g seed) (+ i 1))))
442;                     (string-set! s i c)
443;                     s)))))
444;    (string-copy! ans 0 base)
445;    ans))
446
447;;; The strategy is to allocate a series of chunks into which we stash the
448;;; chars as we generate them. Chunk size goes up in powers of two starting
449;;; with 40 and levelling out at 4k, i.e.
450;;;     40 40 80 160 320 640 1280 2560 4096 4096 4096 4096 4096...
451;;; This should work pretty well for short strings, 1-line (80 char) strings,
452;;; and longer ones. When done, we allocate an answer string and copy the
453;;; chars over from the chunk buffers.
454
455(define (string-unfold p f g seed . base+make-final)
456;  (check-arg procedure? p string-unfold)
457;  (check-arg procedure? f string-unfold)
458;  (check-arg procedure? g string-unfold)
459  (let-optionals* base+make-final
460                  ((base       "")              ; (string? base))
461                   (make-final (lambda (x) ""))) ;(procedure? make-final)))
462    (let lp ((chunks '())               ; Previously filled chunks
463             (nchars 0)                 ; Number of chars in CHUNKS
464             (chunk (make-string 40))   ; Current chunk into which we write
465             (chunk-len 40)
466             (i 0)                      ; Number of chars written into CHUNK
467             (seed seed))
468      (let lp2 ((i i) (seed seed))
469        (if (not (p seed))
470            (let ((c (f seed))
471                  (seed (g seed)))
472              (if (< i chunk-len)
473                  (begin (string-set! chunk i c)
474                         (lp2 (+ i 1) seed))
475
476                  (let* ((nchars2 (+ chunk-len nchars))
477                         (chunk-len2 (min 4096 nchars2))
478                         (new-chunk (make-string chunk-len2)))
479                    (string-set! new-chunk 0 c)
480                    (lp (cons chunk chunks) (+ nchars chunk-len)
481                        new-chunk chunk-len2 1 seed))))
482
483            ;; We're done. Make the answer string & install the bits.
484            (let* ((final (make-final seed))
485                   (flen (string-length final))
486                   (base-len (string-length base))
487                   (j (+ base-len nchars i))
488                   (ans (make-string (+ j flen))))
489              (%string-copy! ans j final 0 flen)        ; Install FINAL.
490              (let ((j (- j i)))
491                (%string-copy! ans j chunk 0 i)         ; Install CHUNK[0,I).
492                (let lp ((j j) (chunks chunks))         ; Install CHUNKS.
493                  (if (pair? chunks)
494                      (let* ((chunk  (car chunks))
495                             (chunks (cdr chunks))
496                             (chunk-len (string-length chunk))
497                             (j (- j chunk-len)))
498                        (%string-copy! ans j chunk 0 chunk-len)
499                        (lp j chunks)))))
500              (%string-copy! ans 0 base 0 base-len)     ; Install BASE.
501              ans))))))
502
503(define (string-unfold-right p f g seed . base+make-final)
504  (let-optionals* base+make-final
505                  ((base       "");              (string? base))
506                   (make-final (lambda (x) ""))); (procedure? make-final)))
507    (let lp ((chunks '())               ; Previously filled chunks
508             (nchars 0)                 ; Number of chars in CHUNKS
509             (chunk (make-string 40))   ; Current chunk into which we write
510             (chunk-len 40)
511             (i 40)                     ; Number of chars available in CHUNK
512             (seed seed))
513      (let lp2 ((i i) (seed seed))      ; Fill up CHUNK from right
514        (if (not (p seed))              ; to left.
515            (let ((c (f seed))
516                  (seed (g seed)))
517              (if (> i 0)
518                  (let ((i (- i 1)))
519                    (string-set! chunk i c)
520                    (lp2 i seed))
521
522                  (let* ((nchars2 (+ chunk-len nchars))
523                         (chunk-len2 (min 4096 nchars2))
524                         (new-chunk (make-string chunk-len2))
525                         (i (- chunk-len2 1)))
526                    (string-set! new-chunk i c)
527                    (lp (cons chunk chunks) (+ nchars chunk-len)
528                        new-chunk chunk-len2 i seed))))
529
530            ;; We're done. Make the answer string & install the bits.
531            (let* ((final (make-final seed))
532                   (flen (string-length final))
533                   (base-len (string-length base))
534                   (chunk-used (- chunk-len i))
535                   (j (+ base-len nchars chunk-used))
536                   (ans (make-string (+ j flen))))
537              (%string-copy! ans 0 final 0 flen)        ; Install FINAL.
538              (%string-copy! ans flen chunk i chunk-len); Install CHUNK[I,).
539              (let lp ((j (+ flen chunk-used))          ; Install CHUNKS.
540                       (chunks chunks))         
541                  (if (pair? chunks)
542                      (let* ((chunk  (car chunks))
543                             (chunks (cdr chunks))
544                             (chunk-len (string-length chunk)))
545                        (%string-copy! ans j chunk 0 chunk-len)
546                        (lp (+ j chunk-len) chunks))
547                      (%string-copy! ans j base 0 base-len))); Install BASE.
548              ans))))))
549
550
551(define (string-for-each proc s . maybe-start+end)
552;  (check-arg procedure? proc string-for-each)
553  (let-string-start+end (start end) string-for-each s maybe-start+end
554    (let lp ((i start))
555      (if (< i end)
556          (begin (proc (string-ref s i)) 
557                 (lp (+ i 1)))))))
558
559(define (string-for-each-index proc s . maybe-start+end)
560;  (check-arg procedure? proc string-for-each-index)
561  (let-string-start+end (start end) string-for-each-index s maybe-start+end
562    (let lp ((i start))
563      (if (< i end) (begin (proc i) (lp (+ i 1)))))))
564
565(define (string-every criteria s . maybe-start+end)
566  (let-string-start+end (start end) string-every s maybe-start+end
567    (cond ((char? criteria)
568           (let lp ((i start))
569             (or (>= i end)
570                 (and (char=? criteria (string-ref s i))
571                      (lp (+ i 1))))))
572
573          ((char-set? criteria)
574           (let lp ((i start))
575             (or (>= i end)
576                 (and (char-set-contains? criteria (string-ref s i))
577                      (lp (+ i 1))))))
578
579          ((procedure? criteria)                ; Slightly funky loop so that
580           (or (= start end)                    ; final (PRED S[END-1]) call
581               (let lp ((i start))              ; is a tail call.
582                 (let ((c (string-ref s i))
583                       (i1 (+ i 1)))
584                   (if (= i1 end) (criteria c)  ; Tail call.
585                       (and (criteria c) (lp i1)))))))
586
587          (else (##sys#error 'string-every "Second param is neither char-set, char, or predicate procedure."
588                       string-every criteria)))))
589
590
591(define (string-any criteria s . maybe-start+end)
592  (let-string-start+end (start end) string-any s maybe-start+end
593    (cond ((char? criteria)
594           (let lp ((i start))
595             (and (< i end)
596                  (or (char=? criteria (string-ref s i))
597                      (lp (+ i 1))))))
598
599          ((char-set? criteria)
600           (let lp ((i start))
601             (and (< i end)
602                  (or (char-set-contains? criteria (string-ref s i))
603                      (lp (+ i 1))))))
604
605          ((procedure? criteria)                ; Slightly funky loop so that
606           (and (< start end)                   ; final (PRED S[END-1]) call
607                (let lp ((i start))             ; is a tail call.
608                  (let ((c (string-ref s i))
609                        (i1 (+ i 1)))
610                    (if (= i1 end) (criteria c) ; Tail call
611                        (or (criteria c) (lp i1)))))))
612
613          (else (##sys#error 'string-any "Second param is neither char-set, char, or predicate procedure."
614                       string-any criteria)))))
615
616
617(define (string-tabulate proc len)
618;  (check-arg procedure? proc string-tabulate)
619;  (check-arg (lambda (val) (and (integer? val) (exact? val) (<= 0 val)))
620;            len string-tabulate)
621  (##sys#check-exact len 'string-tabulate)
622  (let ((s (make-string len)))
623    (do ((i (- len 1) (- i 1)))
624        ((< i 0))
625      (string-set! s i (proc i)))
626    s))
627
628
629
630;;; string-prefix-length[-ci] s1 s2 [start1 end1 start2 end2]
631;;; string-suffix-length[-ci] s1 s2 [start1 end1 start2 end2]
632;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
633;;; Find the length of the common prefix/suffix.
634;;; It is not required that the two substrings passed be of equal length.
635;;; This was microcode in MIT Scheme -- a very tightly bummed primitive.
636;;; %STRING-PREFIX-LENGTH is the core routine of all string-comparisons,
637;;; so should be as tense as possible.
638
639(define (%string-prefix-length s1 start1 end1 s2 start2 end2)
640  (let* ((delta (min (- end1 start1) (- end2 start2)))
641         (end1 (+ start1 delta)))
642
643    (if (and (eq? s1 s2) (= start1 start2))     ; EQ fast path
644        delta
645
646        (let lp ((i start1) (j start2))         ; Regular path
647          (if (or (>= i end1)
648                  (not (char=? (string-ref s1 i)
649                               (string-ref s2 j))))
650              (- i start1)
651              (lp (+ i 1) (+ j 1)))))))
652
653(define (%string-suffix-length s1 start1 end1 s2 start2 end2)
654  (let* ((delta (min (- end1 start1) (- end2 start2)))
655         (start1 (- end1 delta)))
656
657    (if (and (eq? s1 s2) (= end1 end2))         ; EQ fast path
658        delta
659
660        (let lp ((i (- end1 1)) (j (- end2 1))) ; Regular path
661          (if (or (< i start1)
662                  (not (char=? (string-ref s1 i)
663                               (string-ref s2 j))))
664              (- (- end1 i) 1)
665              (lp (- i 1) (- j 1)))))))
666
667(define (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)
668  (let* ((delta (min (- end1 start1) (- end2 start2)))
669         (end1 (+ start1 delta)))
670
671    (if (and (eq? s1 s2) (= start1 start2))     ; EQ fast path
672        delta
673
674        (let lp ((i start1) (j start2))         ; Regular path
675          (if (or (>= i end1)
676                  (not (char-ci=? (string-ref s1 i)
677                                  (string-ref s2 j))))
678              (- i start1)
679              (lp (+ i 1) (+ j 1)))))))
680
681(define (%string-suffix-length-ci s1 start1 end1 s2 start2 end2)
682  (let* ((delta (min (- end1 start1) (- end2 start2)))
683         (start1 (- end1 delta)))
684
685    (if (and (eq? s1 s2) (= end1 end2))         ; EQ fast path
686        delta
687
688        (let lp ((i (- end1 1)) (j (- end2 1))) ; Regular path
689          (if (or (< i start1)
690                  (not (char-ci=? (string-ref s1 i)
691                                  (string-ref s2 j))))
692              (- (- end1 i) 1)
693              (lp (- i 1) (- j 1)))))))
694
695
696(define (string-prefix-length s1 s2 . maybe-starts+ends)
697  (let-string-start+end2 (start1 end1 start2 end2) 
698                         string-prefix-length s1 s2 maybe-starts+ends
699    (%string-prefix-length s1 start1 end1 s2 start2 end2)))
700
701(define (string-suffix-length s1 s2 . maybe-starts+ends)
702  (let-string-start+end2 (start1 end1 start2 end2) 
703                         string-suffix-length s1 s2 maybe-starts+ends
704    (%string-suffix-length s1 start1 end1 s2 start2 end2)))
705
706(define (string-prefix-length-ci s1 s2 . maybe-starts+ends)
707  (let-string-start+end2 (start1 end1 start2 end2) 
708                         string-prefix-length-ci s1 s2 maybe-starts+ends
709    (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)))
710
711(define (string-suffix-length-ci s1 s2 . maybe-starts+ends)
712  (let-string-start+end2 (start1 end1 start2 end2) 
713                         string-suffix-length-ci s1 s2 maybe-starts+ends
714    (%string-suffix-length-ci s1 start1 end1 s2 start2 end2)))
715
716
717;;; string-prefix?    s1 s2 [start1 end1 start2 end2]
718;;; string-suffix?    s1 s2 [start1 end1 start2 end2]
719;;; string-prefix-ci? s1 s2 [start1 end1 start2 end2]
720;;; string-suffix-ci? s1 s2 [start1 end1 start2 end2]
721;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
722;;; These are all simple derivatives of the previous counting funs.
723
724(define (string-prefix? s1 s2 . maybe-starts+ends)
725  (let-string-start+end2 (start1 end1 start2 end2) 
726                         string-prefix? s1 s2 maybe-starts+ends
727    (%string-prefix? s1 start1 end1 s2 start2 end2)))
728
729(define (string-suffix? s1 s2 . maybe-starts+ends)
730  (let-string-start+end2 (start1 end1 start2 end2) 
731                         string-suffix? s1 s2 maybe-starts+ends
732    (%string-suffix? s1 start1 end1 s2 start2 end2)))
733
734(define (string-prefix-ci? s1 s2 . maybe-starts+ends)
735  (let-string-start+end2 (start1 end1 start2 end2) 
736                         string-prefix-ci? s1 s2 maybe-starts+ends
737    (%string-prefix-ci? s1 start1 end1 s2 start2 end2)))
738
739(define (string-suffix-ci? s1 s2 . maybe-starts+ends)
740  (let-string-start+end2 (start1 end1 start2 end2) 
741                         string-suffix-ci? s1 s2 maybe-starts+ends
742    (%string-suffix-ci? s1 start1 end1 s2 start2 end2)))
743
744
745;;; Here are the internal routines that do the real work.
746
747(define (%string-prefix? s1 start1 end1 s2 start2 end2)
748  (let ((len1 (- end1 start1)))
749    (and (<= len1 (- end2 start2))      ; Quick check
750         (= (%string-prefix-length s1 start1 end1
751                                   s2 start2 end2)
752            len1))))
753
754(define (%string-suffix? s1 start1 end1 s2 start2 end2)
755  (let ((len1 (- end1 start1)))
756    (and (<= len1 (- end2 start2))      ; Quick check
757         (= len1 (%string-suffix-length s1 start1 end1
758                                        s2 start2 end2)))))
759
760(define (%string-prefix-ci? s1 start1 end1 s2 start2 end2)
761  (let ((len1 (- end1 start1)))
762    (and (<= len1 (- end2 start2))      ; Quick check
763         (= len1 (%string-prefix-length-ci s1 start1 end1
764                                           s2 start2 end2)))))
765
766(define (%string-suffix-ci? s1 start1 end1 s2 start2 end2)
767  (let ((len1 (- end1 start1)))
768    (and (<= len1 (- end2 start2))      ; Quick check
769         (= len1 (%string-suffix-length-ci s1 start1 end1
770                                           s2 start2 end2)))))
771
772
773;;; string-compare    s1 s2 proc< proc= proc> [start1 end1 start2 end2]
774;;; string-compare-ci s1 s2 proc< proc= proc> [start1 end1 start2 end2]
775;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
776;;; Primitive string-comparison functions.
777;;; Continuation order is different from MIT Scheme.
778;;; Continuations are applied to s1's mismatch index;
779;;; in the case of equality, this is END1.
780
781(define (%string-compare s1 start1 end1 s2 start2 end2
782                           proc< proc= proc>)
783  (let ((size1 (- end1 start1))
784        (size2 (- end2 start2)))
785    (let ((match (%string-prefix-length s1 start1 end1 s2 start2 end2)))
786      (if (= match size1)
787          ((if (= match size2) proc= proc<) end1)
788          ((if (= match size2)
789               proc>
790               (if (char<? (string-ref s1 (+ start1 match))
791                           (string-ref s2 (+ start2 match)))
792                   proc< proc>))
793           (+ match start1))))))
794
795(define (%string-compare-ci s1 start1 end1 s2 start2 end2
796                              proc< proc= proc>)
797  (let ((size1 (- end1 start1))
798        (size2 (- end2 start2)))
799    (let ((match (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)))
800      (if (= match size1)
801          ((if (= match size2) proc= proc<) end1)
802          ((if (= match size2) proc>
803               (if (char-ci<? (string-ref s1 (+ start1 match))
804                              (string-ref s2 (+ start2 match)))
805                   proc< proc>))
806           (+ start1 match))))))
807
808(define (string-compare s1 s2 proc< proc= proc> . maybe-starts+ends)
809;  (check-arg procedure? proc< string-compare)
810;  (check-arg procedure? proc= string-compare)
811;  (check-arg procedure? proc> string-compare)
812  (let-string-start+end2 (start1 end1 start2 end2) 
813                         string-compare s1 s2 maybe-starts+ends
814    (%string-compare s1 start1 end1 s2 start2 end2 proc< proc= proc>)))
815
816(define (string-compare-ci s1 s2 proc< proc= proc> . maybe-starts+ends)
817;  (check-arg procedure? proc< string-compare-ci)
818;  (check-arg procedure? proc= string-compare-ci)
819;  (check-arg procedure? proc> string-compare-ci)
820  (let-string-start+end2 (start1 end1 start2 end2) 
821                         string-compare-ci s1 s2 maybe-starts+ends
822    (%string-compare-ci s1 start1 end1 s2 start2 end2 proc< proc= proc>)))
823
824
825
826;;; string=          string<>           string-ci=          string-ci<>
827;;; string<          string>            string-ci<          string-ci>
828;;; string<=         string>=           string-ci<=         string-ci>=
829;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
830;;; Simple definitions in terms of the previous comparison funs.
831;;; I sure hope the %STRING-COMPARE calls get integrated.
832
833(define (string= s1 s2 . maybe-starts+ends)
834  (let-string-start+end2 (start1 end1 start2 end2) 
835                         string= s1 s2 maybe-starts+ends
836    (and (= (- end1 start1) (- end2 start2))                    ; Quick filter
837         (or (and (eq? s1 s2) (= start1 start2))                ; Fast path
838             (%string-compare s1 start1 end1 s2 start2 end2     ; Real test
839                              (lambda (i) #f)
840                              values
841                              (lambda (i) #f))))))
842
843(define (string<> s1 s2 . maybe-starts+ends)
844  (let-string-start+end2 (start1 end1 start2 end2) 
845                         string<> s1 s2 maybe-starts+ends
846    (or (not (= (- end1 start1) (- end2 start2)))               ; Fast path
847        (and (not (and (eq? s1 s2) (= start1 start2)))          ; Quick filter
848             (%string-compare s1 start1 end1 s2 start2 end2     ; Real test
849                              values
850                              (lambda (i) #f)
851                              values)))))
852
853(define (string< s1 s2 . maybe-starts+ends)
854  (let-string-start+end2 (start1 end1 start2 end2) 
855                         string< s1 s2 maybe-starts+ends
856    (if (and (eq? s1 s2) (= start1 start2))                     ; Fast path
857        (< end1 end2)
858
859        (%string-compare s1 start1 end1 s2 start2 end2          ; Real test
860                         values
861                         (lambda (i) #f)
862                         (lambda (i) #f)))))
863
864(define (string> s1 s2 . maybe-starts+ends)
865  (let-string-start+end2 (start1 end1 start2 end2) 
866                         string> s1 s2 maybe-starts+ends
867    (if (and (eq? s1 s2) (= start1 start2))                     ; Fast path
868        (> end1 end2)
869
870        (%string-compare s1 start1 end1 s2 start2 end2          ; Real test
871                         (lambda (i) #f)
872                         (lambda (i) #f)
873                         values))))
874
875(define (string<= s1 s2 . maybe-starts+ends)
876  (let-string-start+end2 (start1 end1 start2 end2) 
877                         string<= s1 s2 maybe-starts+ends
878    (if (and (eq? s1 s2) (= start1 start2))                     ; Fast path
879        (<= end1 end2)
880
881        (%string-compare s1 start1 end1 s2 start2 end2          ; Real test
882                         values
883                         values
884                         (lambda (i) #f)))))
885
886(define (string>= s1 s2 . maybe-starts+ends)
887  (let-string-start+end2 (start1 end1 start2 end2) 
888                         string>= s1 s2 maybe-starts+ends
889    (if (and (eq? s1 s2) (= start1 start2))                     ; Fast path
890        (>= end1 end2)
891
892        (%string-compare s1 start1 end1 s2 start2 end2          ; Real test
893                         (lambda (i) #f)
894                         values
895                         values))))
896
897(define (string-ci= s1 s2 . maybe-starts+ends)
898  (let-string-start+end2 (start1 end1 start2 end2) 
899                         string-ci= s1 s2 maybe-starts+ends
900    (and (= (- end1 start1) (- end2 start2))                    ; Quick filter
901         (or (and (eq? s1 s2) (= start1 start2))                ; Fast path
902             (%string-compare-ci s1 start1 end1 s2 start2 end2  ; Real test
903                                 (lambda (i) #f)
904                                 values
905                                 (lambda (i) #f))))))
906
907(define (string-ci<> s1 s2 . maybe-starts+ends)
908  (let-string-start+end2 (start1 end1 start2 end2) 
909                         string-ci<> s1 s2 maybe-starts+ends
910    (or (not (= (- end1 start1) (- end2 start2)))               ; Fast path
911        (and (not (and (eq? s1 s2) (= start1 start2)))          ; Quick filter
912             (%string-compare-ci s1 start1 end1 s2 start2 end2  ; Real test
913                                 values
914                                 (lambda (i) #f)
915                                 values)))))
916
917(define (string-ci< s1 s2 . maybe-starts+ends)
918  (let-string-start+end2 (start1 end1 start2 end2) 
919                         string-ci< s1 s2 maybe-starts+ends
920    (if (and (eq? s1 s2) (= start1 start2))                     ; Fast path
921        (< end1 end2)
922
923        (%string-compare-ci s1 start1 end1 s2 start2 end2       ; Real test
924                            values
925                            (lambda (i) #f)
926                            (lambda (i) #f)))))
927
928(define (string-ci> s1 s2 . maybe-starts+ends)
929  (let-string-start+end2 (start1 end1 start2 end2) 
930                         string-ci> s1 s2 maybe-starts+ends
931    (if (and (eq? s1 s2) (= start1 start2))                     ; Fast path
932        (> end1 end2)
933
934        (%string-compare-ci s1 start1 end1 s2 start2 end2       ; Real test
935                            (lambda (i) #f)
936                            (lambda (i) #f)
937                            values))))
938
939(define (string-ci<= s1 s2 . maybe-starts+ends)
940  (let-string-start+end2 (start1 end1 start2 end2) 
941                         string-ci<= s1 s2 maybe-starts+ends
942    (if (and (eq? s1 s2) (= start1 start2))                     ; Fast path
943        (<= end1 end2)
944
945        (%string-compare-ci s1 start1 end1 s2 start2 end2       ; Real test
946                            values
947                            values
948                            (lambda (i) #f)))))
949
950(define (string-ci>= s1 s2 . maybe-starts+ends)
951  (let-string-start+end2 (start1 end1 start2 end2) 
952                         string-ci>= s1 s2 maybe-starts+ends
953    (if (and (eq? s1 s2) (= start1 start2))                     ; Fast path
954        (>= end1 end2)
955
956        (%string-compare-ci s1 start1 end1 s2 start2 end2       ; Real test
957                            (lambda (i) #f)
958                            values
959                            values))))
960
961
962;;; Hash
963;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
964;;; Compute (c + 37 c + 37^2 c + ...) modulo BOUND.
965;;; If you keep BOUND small enough, the intermediate calculations will
966;;; always be fixnums. How small is dependent on the underlying Scheme system;
967;;; we use a default BOUND of 2^22 = 4194304, which should hack it in
968;;; Schemes that give you at least 29 signed bits for fixnums. The core
969;;; calculation that you don't want to overflow is, worst case,
970;;;     (+ 65535 (* 37 (- bound 1)))
971;;; where 65535 is the max character code. Choose the default BOUND to be the
972;;; biggest power of two that won't cause this expression to fixnum overflow,
973;;; and everything will be copacetic.
974
975(define (%string-hash s char->int bound start end)
976  (let ((iref (lambda (s i) (char->int (string-ref s i))))
977        ;; Compute a 111...1 mask that will cover BOUND-1:
978        (mask (let lp ((i #x10000)) ; Let's skip first 16 iterations, eh?
979                (if (>= i bound) (- i 1) (lp (+ i i))))))
980    (let lp ((i start) (ans 0))
981      (if (>= i end) (modulo ans bound)
982          (lp (+ i 1) (fxand mask (+ (* 37 ans) (iref s i))))))))
983
984(define (string-hash s . maybe-bound+start+end)
985  (let-optionals* maybe-bound+start+end ((bound 4194304); (and (integer? bound)
986                                                        ;     (exact? bound)
987                                                        ;     (<= 0 bound)))
988                                         rest)
989    (if (zero? bound) (set! bound 4194304))
990    (##sys#check-exact bound 'string-hash)             
991    (let-string-start+end (start end) string-hash s rest
992      (%string-hash s char->integer bound start end))))
993
994(define (string-hash-ci s . maybe-bound+start+end)
995  (let-optionals* maybe-bound+start+end ((bound 4194304) ;(and (integer? bound)
996                                                         ;    (exact? bound)
997                                                         ;    (<= 0 bound)))
998                                         rest)
999    (if (zero? bound) (set! bound 4194304))
1000    (##sys#check-exact bound 'string-hash-ci)
1001    (let-string-start+end (start end) string-hash-ci s rest
1002      (%string-hash s (lambda (c) (char->integer (char-downcase c)))
1003                    bound start end))))
1004
1005;;; Case hacking
1006;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1007;;; string-upcase  s [start end]
1008;;; string-upcase! s [start end]
1009;;; string-downcase  s [start end]
1010;;; string-downcase! s [start end]
1011;;;
1012;;; string-titlecase  s [start end]
1013;;; string-titlecase! s [start end]
1014;;;   Capitalize every contiguous alpha sequence: capitalise
1015;;;   first char, lowercase rest.
1016
1017(define (string-upcase  s . maybe-start+end)
1018  (let-string-start+end (start end) string-upcase s maybe-start+end
1019    (%string-map char-upcase s start end)))
1020
1021(define (string-upcase! s . maybe-start+end)
1022  (let-string-start+end (start end) string-upcase! s maybe-start+end
1023    (%string-map! char-upcase s start end)))
1024
1025(define (string-downcase  s . maybe-start+end)
1026  (let-string-start+end (start end) string-downcase s maybe-start+end
1027    (%string-map char-downcase s start end)))
1028
1029(define (string-downcase! s . maybe-start+end)
1030  (let-string-start+end (start end) string-downcase! s maybe-start+end
1031    (%string-map! char-downcase s start end)))
1032
1033(define (%string-titlecase! s start end)
1034  (let lp ((i start))
1035    (cond ((string-index s char-cased? i end) =>
1036           (lambda (i)
1037             (string-set! s i (char-titlecase (string-ref s i)))
1038             (let ((i1 (+ i 1)))
1039               (cond ((string-skip s char-cased? i1 end) =>
1040                      (lambda (j)
1041                        (string-downcase! s i1 j)
1042                        (lp (+ j 1))))
1043                     (else (string-downcase! s i1 end)))))))))
1044
1045(define (string-titlecase! s . maybe-start+end)
1046  (let-string-start+end (start end) string-titlecase! s maybe-start+end
1047    (%string-titlecase! s start end)))
1048
1049(define (string-titlecase s . maybe-start+end)
1050  (let-string-start+end (start end) string-titlecase! s maybe-start+end
1051    (let ((ans (##sys#substring s start end)))
1052      (%string-titlecase! ans 0 (- end start))
1053      ans)))
1054
1055
1056;;; Cutting & pasting strings
1057;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1058;;; string-take string nchars
1059;;; string-drop string nchars
1060;;;
1061;;; string-take-right string nchars
1062;;; string-drop-right string nchars
1063;;;
1064;;; string-pad string k [char start end]
1065;;; string-pad-right string k [char start end]
1066;;;
1067;;; string-trim       string [char/char-set/pred start end]
1068;;; string-trim-right string [char/char-set/pred start end]
1069;;; string-trim-both  string [char/char-set/pred start end]
1070;;;
1071;;; These trimmers invert the char-set meaning from MIT Scheme -- you
1072;;; say what you want to trim.
1073
1074(define (string-take s n)
1075;  (check-arg string? s string-take)
1076;  (check-arg (lambda (val) (and (integer? n) (exact? n)
1077;                               (<= 0 n (string-length s))))
1078;            n string-take)
1079  (##sys#check-string s 'string-take)
1080  (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-take)
1081  (%substring/shared s 0 n))
1082
1083(define (string-take-right s n)
1084;  (check-arg string? s string-take-right)
1085  (##sys#check-string s 'string-take-right)
1086  (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-take-right)
1087  (let ((len (##sys#size s)))
1088;    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
1089;              n string-take-right)
1090    (%substring/shared s (- len n) len)))
1091
1092(define (string-drop s n)
1093;  (check-arg string? s string-drop)
1094  (##sys#check-string s 'string-drop)
1095  (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-drop)
1096  (let ((len (##sys#size s)))
1097;    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
1098;              n string-drop)
1099    (%substring/shared s n len)))
1100
1101(define (string-drop-right s n)
1102;  (check-arg string? s string-drop-right)
1103  (##sys#check-string s 'string-drop-right)
1104  (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-drop-right)
1105  (let ((len (##sys#size s)))
1106;    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
1107;              n string-drop-right)
1108    (%substring/shared s 0 (- len n))))
1109
1110
1111(define (string-trim s . criteria+start+end)
1112  (let-optionals* criteria+start+end ((criteria char-set:whitespace) rest)
1113    (let-string-start+end (start end) string-trim s rest
1114      (cond ((string-skip s criteria start end) =>
1115             (lambda (i) (%substring/shared s i end)))
1116            (else "")))))
1117
1118(define (string-trim-right s . criteria+start+end)
1119  (let-optionals* criteria+start+end ((criteria char-set:whitespace) rest)
1120    (let-string-start+end (start end) string-trim-right s rest
1121      (cond ((string-skip-right s criteria start end) =>
1122             (lambda (i) (%substring/shared s 0 (+ 1 i))))
1123            (else "")))))
1124
1125(define (string-trim-both s . criteria+start+end)
1126  (let-optionals* criteria+start+end ((criteria char-set:whitespace) rest)
1127    (let-string-start+end (start end) string-trim-both s rest
1128      (cond ((string-skip s criteria start end) =>
1129             (lambda (i)
1130               (%substring/shared s i (+ 1 (string-skip-right s criteria i end)))))
1131            (else "")))))
1132
1133
1134(define (string-pad-right s n . char+start+end)
1135  (##sys#check-exact n 'string-pad-right)
1136  (let-optionals* char+start+end ((char #\space) rest) ; (char? char)) rest)
1137    (let-string-start+end (start end) string-pad-right s rest
1138      (let ((len (- end start)))
1139        (if (<= n len)
1140            (%substring/shared s start (+ start n))
1141            (let ((ans (make-string n char)))
1142              (%string-copy! ans 0 s start end)
1143              ans))))))
1144
1145(define (string-pad s n . char+start+end)
1146  (##sys#check-exact n 'string-pad)
1147  (let-optionals* char+start+end ((char #\space) rest) ; (char? char)) rest)
1148    (let-string-start+end (start end) string-pad s rest
1149      (let ((len (- end start)))
1150        (if (<= n len)
1151            (%substring/shared s (- end n) end)
1152            (let ((ans (make-string n char)))
1153              (%string-copy! ans (- n len) s start end)
1154              ans))))))
1155
1156
1157
1158;;; Filtering strings
1159;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1160;;; string-delete char/char-set/pred string [start end]
1161;;; string-filter char/char-set/pred string [start end]
1162;;;
1163;;; If the criteria is a char or char-set, we scan the string twice with
1164;;;   string-fold -- once to determine the length of the result string,
1165;;;   and once to do the filtered copy.
1166;;; If the criteria is a predicate, we don't do this double-scan strategy,
1167;;;   because the predicate might have side-effects or be very expensive to
1168;;;   compute. So we preallocate a temp buffer pessimistically, and only do
1169;;;   one scan over S. This is likely to be faster and more space-efficient
1170;;;   than consing a list.
1171
1172(define (string-delete criteria s . maybe-start+end)
1173  (let-string-start+end (start end) string-delete s maybe-start+end
1174    (if (procedure? criteria)
1175        (let* ((slen (- end start))
1176               (temp (make-string slen))
1177               (ans-len (string-fold (lambda (c i)
1178                                       (if (criteria c) i
1179                                           (begin (string-set! temp i c)
1180                                                  (+ i 1))))
1181                                     0 s start end)))
1182          (if (= ans-len slen) temp (##sys#substring temp 0 ans-len)))
1183
1184        (let* ((cset (cond ((char-set? criteria) criteria)
1185                           ((char? criteria) (char-set criteria))
1186                           (else (##sys#error 'string-delete "string-delete criteria not predicate, char or char-set" criteria))))
1187               (len (string-fold (lambda (c i) (if (char-set-contains? cset c)
1188                                                   i
1189                                                   (+ i 1)))
1190                                 0 s start end))
1191               (ans (make-string len)))
1192          (string-fold (lambda (c i) (if (char-set-contains? cset c)
1193                                         i
1194                                         (begin (string-set! ans i c)
1195                                                (+ i 1))))
1196                       0 s start end)
1197          ans))))
1198
1199(define (string-filter criteria s . maybe-start+end)
1200  (let-string-start+end (start end) string-filter s maybe-start+end
1201    (if (procedure? criteria)
1202        (let* ((slen (- end start))
1203               (temp (make-string slen))
1204               (ans-len (string-fold (lambda (c i)
1205                                       (if (criteria c)
1206                                           (begin (string-set! temp i c)
1207                                                  (+ i 1))
1208                                           i))
1209                                     0 s start end)))
1210          (if (= ans-len slen) temp (##sys#substring temp 0 ans-len)))
1211
1212        (let* ((cset (cond ((char-set? criteria) criteria)
1213                           ((char? criteria) (char-set criteria))
1214                           (else (##sys#error 'string-filter "string-delete criteria not predicate, char or char-set" criteria))))
1215
1216               (len (string-fold (lambda (c i) (if (char-set-contains? cset c)
1217                                                   (+ i 1)
1218                                                   i))
1219                                 0 s start end))
1220               (ans (make-string len)))
1221          (string-fold (lambda (c i) (if (char-set-contains? cset c)
1222                                         (begin (string-set! ans i c)
1223                                                (+ i 1))
1224                                         i))
1225                       0 s start end)
1226          ans))))
1227
1228
1229;;; String search
1230;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1231;;; string-index       string char/char-set/pred [start end]
1232;;; string-index-right string char/char-set/pred [start end]
1233;;; string-skip        string char/char-set/pred [start end]
1234;;; string-skip-right  string char/char-set/pred [start end]
1235;;; string-count       char/char-set/pred string [start end]
1236;;;     There's a lot of replicated code here for efficiency.
1237;;;     For example, the char/char-set/pred discrimination has
1238;;;     been lifted above the inner loop of each proc.
1239
1240(define (string-index str criteria . maybe-start+end)
1241  (let-string-start+end (start end) string-index str maybe-start+end
1242    (cond ((char? criteria)
1243           (let lp ((i start))
1244             (and (< i end)
1245                  (if (char=? criteria (string-ref str i)) i
1246                      (lp (+ i 1))))))
1247          ((char-set? criteria)
1248           (let lp ((i start))
1249             (and (< i end)
1250                  (if (char-set-contains? criteria (string-ref str i)) i
1251                      (lp (+ i 1))))))
1252          ((procedure? criteria)
1253           (let lp ((i start))
1254             (and (< i end)
1255                  (if (criteria (string-ref str i)) i
1256                      (lp (+ i 1))))))
1257          (else (##sys#error 'string-index "Second param is neither char-set, char, or predicate procedure."
1258                       string-index criteria)))))
1259
1260(define (string-index-right str criteria . maybe-start+end)
1261  (let-string-start+end (start end) string-index-right str maybe-start+end
1262    (cond ((char? criteria)
1263           (let lp ((i (- end 1)))
1264             (and (>= i 0)
1265                  (if (char=? criteria (string-ref str i)) i
1266                      (lp (- i 1))))))
1267          ((char-set? criteria)
1268           (let lp ((i (- end 1)))
1269             (and (>= i 0)
1270                  (if (char-set-contains? criteria (string-ref str i)) i
1271                      (lp (- i 1))))))
1272          ((procedure? criteria)
1273           (let lp ((i (- end 1)))
1274             (and (>= i 0)
1275                  (if (criteria (string-ref str i)) i
1276                      (lp (- i 1))))))
1277          (else (##sys#error 'string-index-right "Second param is neither char-set, char, or predicate procedure."
1278                       string-index-right criteria)))))
1279
1280(define (string-skip str criteria . maybe-start+end)
1281  (let-string-start+end (start end) string-skip str maybe-start+end
1282    (cond ((char? criteria)
1283           (let lp ((i start))
1284             (and (< i end)
1285                  (if (char=? criteria (string-ref str i))
1286                      (lp (+ i 1))
1287                      i))))
1288          ((char-set? criteria)
1289           (let lp ((i start))
1290             (and (< i end)
1291                  (if (char-set-contains? criteria (string-ref str i))
1292                      (lp (+ i 1))
1293                      i))))
1294          ((procedure? criteria)
1295           (let lp ((i start))
1296             (and (< i end)
1297                  (if (criteria (string-ref str i)) (lp (+ i 1))
1298                      i))))
1299          (else (##sys#error 'string-skip "Second param is neither char-set, char, or predicate procedure."
1300                       string-skip criteria)))))
1301
1302(define (string-skip-right str criteria . maybe-start+end)
1303  (let-string-start+end (start end) string-skip-right str maybe-start+end
1304    (cond ((char? criteria)
1305           (let lp ((i (- end 1)))
1306             (and (>= i 0)
1307                  (if (char=? criteria (string-ref str i))
1308                      (lp (- i 1))
1309                      i))))
1310          ((char-set? criteria)
1311           (let lp ((i (- end 1)))
1312             (and (>= i 0)
1313                  (if (char-set-contains? criteria (string-ref str i))
1314                      (lp (- i 1))
1315                      i))))
1316          ((procedure? criteria)
1317           (let lp ((i (- end 1)))
1318             (and (>= i 0)
1319                  (if (criteria (string-ref str i)) (lp (- i 1))
1320                      i))))
1321          (else (##sys#error 'string-skip-right "CRITERIA param is neither char-set or char."
1322                       string-skip-right criteria)))))
1323
1324
1325; [felix] Boooh! original code had "s" and "criteria" in the wrong order:
1326
1327(define (string-count s criteria . maybe-start+end)
1328  (let-string-start+end (start end) string-count s maybe-start+end
1329    (cond ((char? criteria)
1330           (do ((i start (+ i 1))
1331                (count 0 (if (char=? criteria (string-ref s i))
1332                             (+ count 1)
1333                             count)))
1334               ((>= i end) count)))
1335
1336          ((char-set? criteria)
1337           (do ((i start (+ i 1))
1338                (count 0 (if (char-set-contains? criteria (string-ref s i))
1339                             (+ count 1)
1340                             count)))
1341               ((>= i end) count)))
1342
1343          ((procedure? criteria)
1344           (do ((i start (+ i 1))
1345                (count 0 (if (criteria (string-ref s i)) (+ count 1) count)))
1346               ((>= i end) count)))
1347
1348          (else (##sys#error 'string-count "CRITERIA param is neither char-set or char."
1349                       string-count criteria)))))
1350
1351
1352
1353;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1354;;; string-fill! string char [start end]
1355;;;
1356;;; string-copy! to tstart from [fstart fend]
1357;;;     Guaranteed to work, even if s1 eq s2.
1358
1359(define (string-fill! s char . maybe-start+end)
1360;  (check-arg char? char string-fill!)
1361  (let-string-start+end (start end) string-fill! s maybe-start+end
1362    (do ((i (- end 1) (- i 1)))
1363        ((< i start))
1364      (string-set! s i char))))
1365
1366(define (string-copy! to tstart from . maybe-fstart+fend)
1367  (let-string-start+end (fstart fend) string-copy! from maybe-fstart+fend
1368;    (check-arg integer? tstart string-copy!)
1369    (##sys#check-exact tstart 'string-copy!)                   
1370    (check-substring-spec string-copy! to tstart (+ tstart (- fend fstart)))
1371    (%string-copy! to tstart from fstart fend)))
1372
1373;;; Library-internal routine
1374(define (%string-copy! to tstart from fstart fend)
1375  (##core#inline "C_substring_copy" from to fstart fend tstart))
1376
1377
1378;;; Returns starting-position in STRING or #f if not true.
1379;;; This implementation is slow & simple. It is useful as a "spec" or for
1380;;; comparison testing with fancier implementations.
1381;;; See below for fast KMP version.
1382
1383(define (string-contains string substring . maybe-starts+ends)
1384  (let-string-start+end2 (start1 end1 start2 end2) 
1385                         string-contains string substring maybe-starts+ends
1386    (let* ((len (fx- end2 start2))
1387           (i-bound (fx- end1 len)))
1388      (let lp ((i start1))
1389        (and (fx<= i i-bound)
1390             (if (string= string substring i (fx+ i len) start2 end2)
1391                 i
1392                 (lp (fx+ i 1))))))))
1393
1394(define (string-contains-ci string substring . maybe-starts+ends)
1395  (let-string-start+end2 (start1 end1 start2 end2) 
1396                         string-contains string substring maybe-starts+ends
1397    (let* ((len (fx- end2 start2))
1398           (i-bound (fx- end1 len)))
1399      (let lp ((i start1))
1400        (and (fx<= i i-bound)
1401             (if (string-ci= string substring i (fx+ i len) start2 end2)
1402                 i
1403                 (lp (fx+ i 1))))))))
1404
1405
1406;;; Searching for an occurrence of a substring
1407;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1408
1409; this is completely broken and was probably never tested. Thanks, Olin! (flw)
1410
1411
1412;;; Knuth-Morris-Pratt string searching
1413;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1414;;; See
1415;;;     "Fast pattern matching in strings"
1416;;;     SIAM J. Computing 6(2):323-350 1977
1417;;;     D. E. Knuth, J. H. Morris and V. R. Pratt
1418;;; also described in
1419;;;     "Pattern matching in strings"
1420;;;     Alfred V. Aho
1421;;;     Formal Language Theory - Perspectives and Open Problems
1422;;;     Ronald V. Brook (editor)
1423;;; This algorithm is O(m + n) where m and n are the
1424;;; lengths of the pattern and string respectively
1425
1426
1427;;; (make-kmp-restart-vector pattern [c= start end]) -> integer-vector
1428;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1429;;; Compute the KMP restart vector RV for string PATTERN.  If
1430;;; we have matched chars 0..i-1 of PATTERN against a search string S, and
1431;;; PATTERN[i] doesn't match S[k], then reset i := RV[i], and try again to
1432;;; match S[k].  If RV[i] = -1, then punt S[k] completely, and move on to
1433;;; S[k+1] and PATTERN[0] -- no possible match of PAT[0..i] contains S[k].
1434;;;
1435;;; In other words, if you have matched the first i chars of PATTERN, but
1436;;; the i+1'th char doesn't match, RV[i] tells you what the next-longest
1437;;; prefix of PATTERN is that you have matched.
1438;;;
1439;;; - C= (default CHAR=?) is used to compare characters for equality.
1440;;;   Pass in CHAR-CI=? for case-folded string search.
1441;;;
1442;;; - START & END restrict the pattern to the indicated substring; the
1443;;;   returned vector will be of length END - START. The numbers stored
1444;;;   in the vector will be values in the range [0,END-START) -- that is,
1445;;;   they are valid indices into the restart vector; you have to add START
1446;;;   to them to use them as indices into PATTERN.
1447;;;
1448;;; I've split this out as a separate function in case other constant-string
1449;;; searchers might want to use it.
1450;;;
1451;;; E.g.:
1452;;;    a b d  a b x
1453;;; #(-1 0 0 -1 1 2)
1454
1455(define (make-kmp-restart-vector pattern . maybe-c=+start+end)
1456  (let-optionals* maybe-c=+start+end
1457                  ((c= char=?) rest) ; (procedure? c=))
1458     (receive (rest2 start end) (string-parse-start+end make-kmp-restart-vector pattern rest)
1459       (let* ((rvlen (- end start))
1460           (rv (make-vector rvlen -1)))
1461      (if (> rvlen 0)
1462          (let ((rvlen-1 (- rvlen 1))
1463                (c0 (string-ref pattern start)))
1464
1465            ;; Here's the main loop. We have set rv[0] ... rv[i].
1466            ;; K = I + START -- it is the corresponding index into PATTERN.
1467            (let lp1 ((i 0) (j -1) (k start))   
1468              (if (< i rvlen-1)
1469
1470                  (let ((ck (string-ref pattern k)))
1471                    ;; lp2 invariant:
1472                    ;;   pat[(k-j) .. k-1] matches pat[start .. start+j-1]
1473                    ;;   or j = -1.
1474                    (let lp2 ((j j))
1475
1476                      (cond ((= j -1)
1477                             (let ((i1 (+ i 1)))
1478                               (vector-set! rv i1 (if (c= ck c0) -1 0))
1479                               (lp1 i1 0 (+ k 1))))
1480
1481                            ;; pat[(k-j) .. k] matches pat[start..start+j].
1482                            ((c= ck (string-ref pattern (+ j start)))
1483                             (let* ((i1 (+ 1 i))
1484                                    (j1 (+ 1 j)))
1485                               (vector-set! rv i1 j1)
1486                               (lp1 i1 j1 (+ k 1))))
1487
1488                            (else (lp2 (vector-ref rv j))))))))))
1489      rv))))
1490
1491
1492;;; We've matched I chars from PAT. C is the next char from the search string.
1493;;; Return the new I after handling C.
1494;;;
1495;;; The pattern is (VECTOR-LENGTH RV) chars long, beginning at index PAT-START
1496;;; in PAT (PAT-START is usually 0). The I chars of the pattern we've matched
1497;;; are
1498;;;     PAT[PAT-START .. PAT-START + I].
1499;;;
1500;;; It's *not* an oversight that there is no friendly error checking or
1501;;; defaulting of arguments. This is a low-level, inner-loop procedure
1502;;; that we want integrated/inlined into the point of call.
1503
1504(define (kmp-step pat rv c i c= p-start)
1505  (let lp ((i i))
1506    (if (c= c (string-ref pat (+ i p-start)))   ; Match =>
1507        (+ i 1)                                 ;   Done.
1508        (let ((i (vector-ref rv i)))            ; Back up in PAT.
1509          (if (= i -1) 0                        ; Can't back up further.
1510              (lp i))))))                       ; Keep trying for match.
1511
1512;;; Zip through S[start,end), looking for a match of PAT. Assume we've
1513;;; already matched the first I chars of PAT when we commence at S[start].
1514;;; - <0:  If we find a match *ending* at index J, return -J.
1515;;; - >=0: If we get to the end of the S[start,end) span without finding
1516;;;   a complete match, return the number of chars from PAT we'd matched
1517;;;   when we ran off the end.
1518;;;
1519;;; This is useful for searching *across* buffers -- that is, when your
1520;;; input comes in chunks of text. We hand-integrate the KMP-STEP loop
1521;;; for speed.
1522
1523(define (string-kmp-partial-search pat rv s i . c=+p-start+s-start+s-end)
1524;  (check-arg vector? rv string-kmp-partial-search)
1525  (let-optionals* c=+p-start+s-start+s-end
1526      ((c=      char=?) ; (procedure? c=))
1527       (p-start 0) rest) ; (and (integer? p-start) (exact? p-start) (<= 0 p-start)))
1528    (receive (rest2 s-start s-end) (string-parse-start+end string-kmp-partial-search s rest)
1529    ;; Enough prelude. Here's the actual code.
1530    (let ((patlen (vector-length rv)))
1531      (let lp ((si s-start)             ; An index into S.
1532               (vi i))                  ; An index into RV.
1533        (cond ((= vi patlen) (- si))    ; Win.
1534              ((= si s-end) vi)         ; Ran off the end.
1535              (else                     ; Match s[si] & loop.
1536               (let ((c (string-ref s si)))
1537                 (lp (+ si 1)   
1538                     (let lp2 ((vi vi)) ; This is just KMP-STEP.
1539                       (if (c= c (string-ref pat (+ vi p-start)))
1540                           (+ vi 1)
1541                           (let ((vi (vector-ref rv vi)))
1542                             (if (= vi -1) 0
1543                                 (lp2 vi))))))))))))) )
1544
1545
1546;;; Misc
1547;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1548;;; (string-null? s)
1549;;; (string-reverse  s [start end])
1550;;; (string-reverse! s [start end])
1551;;; (reverse-list->string clist)
1552;;; (string->list s [start end])
1553
1554(define (string-null? s) (##core#inline "C_i_string_null_p" s))
1555
1556(define (string-reverse s . maybe-start+end)
1557  (let-string-start+end (start end) string-reverse s maybe-start+end
1558    (let* ((len (- end start))
1559           (ans (make-string len)))
1560      (do ((i start (+ i 1))
1561           (j (- len 1) (- j 1)))
1562          ((< j 0))
1563        (string-set! ans j (string-ref s i)))
1564      ans)))
1565
1566(define (string-reverse! s . maybe-start+end)
1567  (let-string-start+end (start end) string-reverse! s maybe-start+end
1568    (do ((i (- end 1) (- i 1))
1569         (j start (+ j 1)))
1570        ((<= i j))
1571      (let ((ci (string-ref s i)))
1572        (string-set! s i (string-ref s j))
1573        (string-set! s j ci)))))
1574
1575
1576#| this is already available in library.scm:
1577
1578(define (reverse-list->string clist)
1579  (let* ((len (length clist))
1580         (s (make-string len)))
1581    (do ((i (- len 1) (- i 1))   (clist clist (cdr clist)))
1582        ((not (pair? clist)))
1583      (string-set! s i (car clist)))
1584    s))
1585|#
1586
1587
1588;(define (string->list s . maybe-start+end)
1589;  (apply string-fold-right cons '() s maybe-start+end))
1590
1591(define (string->list s . maybe-start+end)
1592  (let-string-start+end (start end) string->list s maybe-start+end
1593    (do ((i (- end 1) (- i 1))
1594         (ans '() (cons (string-ref s i) ans)))
1595        ((< i start) ans))))
1596
1597;;; Defined by R5RS, so commented out here.
1598;(define (list->string lis) (string-unfold null? car cdr lis))
1599
1600
1601;;; string-concatenate        string-list -> string
1602;;; string-concatenate/shared string-list -> string
1603;;; string-append/shared s ... -> string
1604;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1605;;; STRING-APPEND/SHARED has license to return a string that shares storage
1606;;; with any of its arguments. In particular, if there is only one non-empty
1607;;; string amongst its parameters, it is permitted to return that string as
1608;;; its result. STRING-APPEND, by contrast, always allocates new storage.
1609;;;
1610;;; STRING-CONCATENATE & STRING-CONCATENATE/SHARED are passed a list of
1611;;; strings, which they concatenate into a result string. STRING-CONCATENATE
1612;;; always allocates a fresh string; STRING-CONCATENATE/SHARED may (or may
1613;;; not) return a result that shares storage with any of its arguments. In
1614;;; particular, if it is applied to a singleton list, it is permitted to
1615;;; return the car of that list as its value.
1616
1617(define (string-append/shared . strings) (string-concatenate/shared strings))
1618
1619(define (string-concatenate/shared strings)
1620  (let lp ((strings strings) (nchars 0) (first #f))
1621    (cond ((pair? strings)                      ; Scan the args, add up total
1622           (let* ((string  (car strings))       ; length, remember 1st
1623                  (tail (cdr strings))          ; non-empty string.
1624                  (slen (string-length string)))
1625             (if (zero? slen)
1626                 (lp tail nchars first)
1627                 (lp tail (+ nchars slen) (or first strings)))))
1628
1629          ((zero? nchars) "")
1630
1631          ;; Just one non-empty string! Return it.
1632          ((= nchars (string-length (car first))) (car first))
1633
1634          (else (let ((ans (make-string nchars)))
1635                  (let lp ((strings first) (i 0))
1636                    (if (pair? strings)
1637                        (let* ((s (car strings))
1638                               (slen (string-length s)))
1639                          (%string-copy! ans i s 0 slen)
1640                          (lp (cdr strings) (+ i slen)))))
1641                  ans)))))
1642                       
1643
1644; Alas, Scheme 48's APPLY blows up if you have many, many arguments.
1645;(define (string-concatenate strings) (apply string-append strings))
1646
1647;;; Here it is written out. I avoid using REDUCE to add up string lengths
1648;;; to avoid non-R5RS dependencies.
1649(define (string-concatenate strings)
1650  (let* ((total (do ((strings strings (cdr strings))
1651                     (i 0 (+ i (string-length (car strings)))))
1652                    ((not (pair? strings)) i)))
1653         (ans (make-string total)))
1654    (let lp ((i 0) (strings strings))
1655      (if (pair? strings)
1656          (let* ((s (car strings))
1657                 (slen (string-length s)))
1658            (%string-copy! ans i s 0 slen)
1659            (lp (+ i slen) (cdr strings)))))
1660    ans))
1661         
1662
1663;;; Defined by R5RS, so commented out here.
1664;(define (string-append . strings) (string-concatenate strings))
1665
1666;;; string-concatenate-reverse        string-list [final-string end] -> string
1667;;; string-concatenate-reverse/shared string-list [final-string end] -> string
1668;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1669;;; Return
1670;;;   (string-concatenate
1671;;;     (reverse
1672;;;       (cons (substring final-string 0 end) string-list)))
1673
1674(define (string-concatenate-reverse string-list . maybe-final+end)
1675  (let-optionals* maybe-final+end ((final ""); (string? final))
1676                                   (end (string-length final)) )
1677;                                       (and (integer? end)
1678;                                            (exact? end)
1679;                                            (<= 0 end (string-length final)))))
1680    (##sys#check-exact end 'string-concatenate-reverse)
1681    (let ((len (let lp ((sum 0) (lis string-list))
1682                 (if (pair? lis)
1683                     (lp (+ sum (string-length (car lis))) (cdr lis))
1684                     sum))))
1685
1686      (%finish-string-concatenate-reverse len string-list final end))))
1687
1688(define (string-concatenate-reverse/shared string-list . maybe-final+end)
1689  (let-optionals* maybe-final+end ((final ""); (string? final))
1690                                   (end (string-length final)))
1691;                                       (and (integer? end)
1692;                                            (exact? end)
1693;                                            (<= 0 end (string-length final)))))
1694    (##sys#check-exact end 'string-concatenate-reverse/shared)
1695    ;; Add up the lengths of all the strings in STRING-LIST; also get a
1696    ;; pointer NZLIST into STRING-LIST showing where the first non-zero-length
1697    ;; string starts.
1698    (let lp ((len 0) (nzlist #f) (lis string-list))
1699      (if (pair? lis)
1700          (let ((slen (string-length (car lis))))
1701            (lp (+ len slen)
1702                (if (or nzlist (zero? slen)) nzlist lis)
1703                (cdr lis)))
1704
1705          (cond ((zero? len) (substring/shared final 0 end))
1706
1707                ;; LEN > 0, so NZLIST is non-empty.
1708
1709                ((and (zero? end) (= len (string-length (car nzlist))))
1710                 (car nzlist))
1711
1712                (else (%finish-string-concatenate-reverse len nzlist final end)))))))
1713
1714(define (%finish-string-concatenate-reverse len string-list final end)
1715  (let ((ans (make-string (+ end len))))
1716    (%string-copy! ans len final 0 end)
1717    (let lp ((i len) (lis string-list))
1718      (if (pair? lis)
1719          (let* ((s   (car lis))
1720                 (lis (cdr lis))
1721                 (slen (string-length s))
1722                 (i (- i slen)))
1723            (%string-copy! ans i s 0 slen)
1724            (lp i lis))))
1725    ans))
1726
1727
1728
1729
1730;;; string-replace s1 s2 start1 end1 [start2 end2] -> string
1731;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1732;;; Replace S1[START1,END1) with S2[START2,END2).
1733
1734(define (string-replace s1 s2 start1 end1 . maybe-start+end)
1735  (check-substring-spec string-replace s1 start1 end1)
1736  (let-string-start+end (start2 end2) string-replace s2 maybe-start+end
1737    (let* ((slen1 (string-length s1))
1738           (sublen2 (- end2 start2))
1739           (alen (+ (- slen1 (- end1 start1)) sublen2))
1740           (ans (make-string alen)))
1741      (%string-copy! ans 0 s1 0 start1)
1742      (%string-copy! ans start1 s2 start2 end2)
1743      (%string-copy! ans (+ start1 sublen2) s1 end1 slen1)
1744      ans)))
1745
1746
1747;;; string-tokenize s [token-set start end] -> list
1748;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1749;;; Break S up into a list of token strings, where a token is a maximal
1750;;; non-empty contiguous sequence of chars belonging to TOKEN-SET.
1751;;; (string-tokenize "hello, world") => ("hello," "world")
1752
1753(define (string-tokenize s . token-chars+start+end)
1754  (let-optionals* token-chars+start+end
1755      ((token-chars char-set:graphic) rest) ; (char-set? token-chars)) rest)
1756    (let-string-start+end (start end) string-tokenize s rest
1757      (let lp ((i end) (ans '()))
1758        (cond ((and (< start i) (string-index-right s token-chars start i)) =>
1759               (lambda (tend-1)
1760                 (let ((tend (+ 1 tend-1)))
1761                   (cond ((string-skip-right s token-chars start tend-1) =>
1762                          (lambda (tstart-1)
1763                            (lp tstart-1
1764                                (cons (##sys#substring s (+ 1 tstart-1) tend)
1765                                      ans))))
1766                         (else (cons (##sys#substring s start tend) ans))))))
1767              (else ans))))))
1768
1769
1770;;; xsubstring s from [to start end] -> string
1771;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1772;;; S is a string; START and END are optional arguments that demarcate
1773;;; a substring of S, defaulting to 0 and the length of S (e.g., the whole
1774;;; string). Replicate this substring up and down index space, in both the
1775;;  positive and negative directions. For example, if S = "abcdefg", START=3,
1776;;; and END=6, then we have the conceptual bidirectionally-infinite string
1777;;;     ...  d  e  f  d  e  f  d  e  f  d  e  f  d  e  f  d  e  f  d  e  f ...
1778;;;     ... -9 -8 -7 -6 -5 -4 -3 -2 -1  0  1  2  3  4  5  6  7  8  9 ...
1779;;; XSUBSTRING returns the substring of this string beginning at index FROM,
1780;;; and ending at TO (which defaults to FROM+(END-START)).
1781;;;
1782;;; You can use XSUBSTRING in many ways:
1783;;; - To rotate a string left:  (xsubstring "abcdef" 2)  => "cdefab"
1784;;; - To rotate a string right: (xsubstring "abcdef" -2) => "efabcd"
1785;;; - To replicate a string:    (xsubstring "abc" 0 7) => "abcabca"
1786;;;
1787;;; Note that
1788;;;   - The FROM/TO indices give a half-open range -- the characters from
1789;;;     index FROM up to, but not including index TO.
1790;;;   - The FROM/TO indices are not in terms of the index space for string S.
1791;;;     They are in terms of the replicated index space of the substring
1792;;;     defined by S, START, and END.
1793;;;
1794;;; It is an error if START=END -- although this is allowed by special
1795;;; dispensation when FROM=TO.
1796
1797(define (xsubstring s from . maybe-to+start+end)
1798;  (check-arg (lambda (val) (and (integer? val) (exact? val)))
1799;            from xsubstring)
1800  (##sys#check-exact from 'xsubstring)
1801  (receive (to start end)
1802           (if (pair? maybe-to+start+end)
1803               (let-string-start+end (start end) xsubstring s (cdr maybe-to+start+end)
1804                 (let ((to (car maybe-to+start+end)))
1805;                  (check-arg (lambda (val) (and (integer? val)
1806;                                                (exact? val)
1807;                                                (<= from val)))
1808;                             to xsubstring)
1809                   (##sys#check-exact to 'xsubstring)
1810                   (values to start end)))
1811;              (let ((slen (string-length (check-arg string? s xsubstring))))
1812               (let ((slen (string-length s)))
1813                 (values (+ from slen) 0 slen)))
1814    (let ((slen   (- end start))
1815          (anslen (- to  from)))
1816      (cond ((zero? anslen) "")
1817            ((zero? slen) (##sys#error 'xsubstring "Cannot replicate empty (sub)string"
1818                                  xsubstring s from to start end))
1819
1820            ((= 1 slen)         ; Fast path for 1-char replication.
1821             (make-string anslen (string-ref s start)))
1822
1823            ;; Selected text falls entirely within one span.
1824            ((= (floor (/ from slen)) (floor (/ to slen)))
1825             (##sys#substring s (+ start (modulo from slen))
1826                          (+ start (modulo to   slen))))
1827
1828            ;; Selected text requires multiple spans.
1829            (else (let ((ans (make-string anslen)))
1830                    (%multispan-repcopy! ans 0 s from to start end)
1831                    ans))))))
1832
1833
1834;;; string-xcopy! target tstart s sfrom [sto start end] -> unspecific
1835;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1836;;; Exactly the same as xsubstring, but the extracted text is written
1837;;; into the string TARGET starting at index TSTART.
1838;;; This operation is not defined if (EQ? TARGET S) -- you cannot copy
1839;;; a string on top of itself.
1840
1841(define ##srfi13#string-fill! string-fill!) ; or we use std-binding.
1842
1843(define (string-xcopy! target tstart s sfrom . maybe-sto+start+end)
1844;  (check-arg (lambda (val) (and (integer? val) (exact? val)))
1845;            sfrom string-xcopy!)
1846  (##sys#check-exact sfrom 'string-xcopy!)
1847  (receive (sto start end)
1848           (if (pair? maybe-sto+start+end)
1849               (let-string-start+end (start end) string-xcopy! s (cdr maybe-sto+start+end)
1850                 (let ((sto (car maybe-sto+start+end)))
1851;                  (check-arg (lambda (val) (and (integer? val) (exact? val)))
1852;                             sto string-xcopy!)
1853                   (##sys#check-exact sto 'string-xcopy!)
1854                   (values sto start end)))
1855               (let ((slen (string-length s)))
1856                 (values (+ sfrom slen) 0 slen)))
1857
1858    (let* ((tocopy (- sto sfrom))
1859           (tend (+ tstart tocopy))
1860           (slen (- end start)))
1861      (check-substring-spec string-xcopy! target tstart tend)
1862      (cond ((zero? tocopy))
1863            ((zero? slen) (##sys#error 'string-xcopy! "Cannot replicate empty (sub)string"
1864                                 string-xcopy!
1865                                 target tstart s sfrom sto start end))
1866
1867            ((= 1 slen)                 ; Fast path for 1-char replication.
1868             (##srfi13#string-fill! target (string-ref s start) tstart tend))
1869
1870            ;; Selected text falls entirely within one span.
1871            ((= (floor (/ sfrom slen)) (floor (/ sto slen)))
1872             (%string-copy! target tstart s 
1873                            (+ start (modulo sfrom slen))
1874                            (+ start (modulo sto   slen))))
1875
1876            ;; Multi-span copy.
1877            (else (%multispan-repcopy! target tstart s sfrom sto start end))))))
1878
1879;;; This is the core copying loop for XSUBSTRING and STRING-XCOPY!
1880;;; Internal -- not exported, no careful arg checking.
1881(define (%multispan-repcopy! target tstart s sfrom sto start end)
1882  (let* ((slen (- end start))
1883         (i0 (+ start (modulo sfrom slen)))
1884         (total-chars (- sto sfrom)))
1885
1886    ;; Copy the partial span @ the beginning
1887    (%string-copy! target tstart s i0 end)
1888                   
1889    (let* ((ncopied (- end i0))                 ; We've copied this many.
1890           (nleft (- total-chars ncopied))      ; # chars left to copy.
1891           (nspans (quotient nleft slen)))      ; # whole spans to copy
1892                           
1893      ;; Copy the whole spans in the middle.
1894      (do ((i (+ tstart ncopied) (+ i slen))    ; Current target index.
1895           (nspans nspans (- nspans 1)))        ; # spans to copy
1896          ((zero? nspans)
1897           ;; Copy the partial-span @ the end & we're done.
1898           (%string-copy! target i s start (+ start (- total-chars (- i tstart)))))
1899
1900        (%string-copy! target i s start end))))); Copy a whole span.
1901
1902
1903
1904;;; (string-join string-list [delimiter grammar]) => string
1905;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1906;;; Paste strings together using the delimiter string.
1907;;;
1908;;; (join-strings '("foo" "bar" "baz") ":") => "foo:bar:baz"
1909;;;
1910;;; DELIMITER defaults to a single space " "
1911;;; GRAMMAR is one of the symbols {prefix, infix, strict-infix, suffix}
1912;;; and defaults to 'infix.
1913;;;
1914;;; I could rewrite this more efficiently -- precompute the length of the
1915;;; answer string, then allocate & fill it in iteratively. Using
1916;;; STRING-CONCATENATE is less efficient.
1917
1918(define (string-join strings . delim+grammar)
1919  (let-optionals* delim+grammar ((delim " ") ; (string? delim))
1920                                 (grammar 'infix))
1921    (let ((buildit (lambda (lis final)
1922                     (let recur ((lis lis))
1923                       (if (pair? lis)
1924                           (cons delim (cons (car lis) (recur (cdr lis))))
1925                           final)))))
1926
1927      (cond ((pair? strings)
1928             (string-concatenate
1929              (case grammar
1930
1931                ((infix strict-infix)
1932                 (cons (car strings) (buildit (cdr strings) '())))
1933
1934                ((prefix) (buildit strings '()))
1935
1936                ((suffix)
1937                 (cons (car strings) (buildit (cdr strings) (list delim))))
1938
1939                (else (##sys#error 'string-join "Illegal join grammar"
1940                             grammar string-join)))))
1941
1942             ((not (null? strings))
1943              (##sys#error 'string-join "STRINGS parameter not list." strings string-join))
1944
1945             ;; STRINGS is ()
1946
1947             ((eq? grammar 'strict-infix)
1948              (##sys#error 'string-join "Empty list cannot be joined with STRICT-INFIX grammar."
1949                     string-join))
1950
1951             (else "")))))              ; Special-cased for infix grammar.
1952
1953
1954;;; Porting & performance-tuning notes
1955;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1956;;; See the section at the beginning of this file on external dependencies.
1957;;;
1958;;; The biggest issue with respect to porting is the LET-OPTIONALS* macro.
1959;;; There are many, many optional arguments in this library; the complexity
1960;;; of parsing, defaulting & type-testing these parameters is handled with the
1961;;; aid of this macro. There are about 15 uses of LET-OPTIONALS*. You can
1962;;; rewrite the uses, port the hairy macro definition (which is implemented
1963;;; using a Clinger-Rees low-level explicit-renaming macro system), or port
1964;;; the simple, high-level definition, which is less efficient.
1965;;;
1966;;; There is a fair amount of argument checking. This is, strictly speaking,
1967;;; unnecessary -- the actual body of the procedures will blow up if, say, a
1968;;; START/END index is improper. However, the error message will not be as
1969;;; good as if the error were caught at the "higher level." Also, a very, very
1970;;; smart Scheme compiler may be able to exploit having the type checks done
1971;;; early, so that the actual body of the procedures can assume proper values.
1972;;; This isn't likely; this kind of compiler technology isn't common any
1973;;; longer.
1974;;;
1975;;; The overhead of optional-argument parsing is irritating. The optional
1976;;; arguments must be consed into a rest list on entry, and then parsed out.
1977;;; Function call should be a matter of a few register moves and a jump; it
1978;;; should not involve heap allocation! Your Scheme system may have a superior
1979;;; non-R5RS optional-argument system that can eliminate this overhead. If so,
1980;;; then this is a prime candidate for optimising these procedures,
1981;;; *especially* the many optional START/END index parameters.
1982;;;
1983;;; Note that optional arguments are also a barrier to procedure integration.
1984;;; If your Scheme system permits you to specify alternate entry points
1985;;; for a call when the number of optional arguments is known in a manner
1986;;; that enables inlining/integration, this can provide performance
1987;;; improvements.
1988;;;
1989;;; There is enough *explicit* error checking that *all* string-index
1990;;; operations should *never* produce a bounds error. Period. Feel like
1991;;; living dangerously? *Big* performance win to be had by replacing
1992;;; STRING-REF's and STRING-SET!'s with unsafe equivalents in the loops.
1993;;; Similarly, fixnum-specific operators can speed up the arithmetic done on
1994;;; the index values in the inner loops. The only arguments that are not
1995;;; completely error checked are
1996;;;   - string lists (complete checking requires time proportional to the
1997;;;     length of the list)
1998;;;   - procedure arguments, such as char->char maps & predicates.
1999;;;     There is no way to check the range & domain of procedures in Scheme.
2000;;; Procedures that take these parameters cannot fully check their
2001;;; arguments. But all other types to all other procedures are fully
2002;;; checked.
2003;;;
2004;;; This does open up the alternate possibility of simply *removing* these
2005;;; checks, and letting the safe primitives raise the errors. On a dumb
2006;;; Scheme system, this would provide speed (by eliminating the redundant
2007;;; error checks) at the cost of error-message clarity.
2008;;;
2009;;; See the comments preceding the hash function code for notes on tuning
2010;;; the default bound so that the code never overflows your implementation's
2011;;; fixnum size into bignum calculation.
2012;;;
2013;;; In an interpreted Scheme, some of these procedures, or the internal
2014;;; routines with % prefixes, are excellent candidates for being rewritten
2015;;; in C. Consider STRING-HASH, %STRING-COMPARE, the
2016;;; %STRING-{SUF,PRE}FIX-LENGTH routines, STRING-COPY!, STRING-INDEX &
2017;;; STRING-SKIP (char-set & char cases), SUBSTRING and SUBSTRING/SHARED,
2018;;; %KMP-SEARCH, and %MULTISPAN-REPCOPY!.
2019;;;
2020;;; It would also be nice to have the ability to mark some of these
2021;;; routines as candidates for inlining/integration.
2022;;;
2023;;; All the %-prefixed routines in this source code are written
2024;;; to be called internally to this library. They do *not* perform
2025;;; friendly error checks on the inputs; they assume everything is
2026;;; proper. They also do not take optional arguments. These two properties
2027;;; save calling overhead and enable procedure integration -- but they
2028;;; are not appropriate for exported routines.
2029
2030
2031;;; Copyright details
2032;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2033;;; The prefix/suffix and comparison routines in this code had (extremely
2034;;; distant) origins in MIT Scheme's string lib, and was substantially
2035;;; reworked by Olin Shivers (shivers@ai.mit.edu) 9/98. As such, it is
2036;;; covered by MIT Scheme's open source copyright. See below for details.
2037;;;
2038;;; The KMP string-search code was influenced by implementations written
2039;;; by Stephen Bevan, Brian Dehneyer and Will Fitzgerald. However, this
2040;;; version was written from scratch by myself.
2041
2042;;; I guessed that much. (flw)
2043
2044;;;
2045;;; The remainder of this code was written from scratch by myself for scsh.
2046;;; The scsh copyright is a BSD-style open source copyright. See below for
2047;;; details.
2048;;;     -Olin Shivers
2049
2050;;; MIT Scheme copyright terms
2051;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2052;;; This material was developed by the Scheme project at the Massachusetts
2053;;; Institute of Technology, Department of Electrical Engineering and
2054;;; Computer Science.  Permission to copy and modify this software, to
2055;;; redistribute either the original software or a modified version, and
2056;;; to use this software for any purpose is granted, subject to the
2057;;; following restrictions and understandings.
2058;;;
2059;;; 1. Any copy made of this software must include this copyright notice
2060;;; in full.
2061;;;
2062;;; 2. Users of this software agree to make their best efforts (a) to
2063;;; return to the MIT Scheme project any improvements or extensions that
2064;;; they make, so that these may be included in future releases; and (b)
2065;;; to inform MIT of noteworthy uses of this software.
2066;;;
2067;;; 3. All materials developed as a consequence of the use of this
2068;;; software shall duly acknowledge such use, in accordance with the usual
2069;;; standards of acknowledging credit in academic research.
2070;;;
2071;;; 4. MIT has made no warrantee or representation that the operation of
2072;;; this software will be error-free, and MIT is under no obligation to
2073;;; provide any services, by way of maintenance, update, or otherwise.
2074;;;
2075;;; 5. In conjunction with products arising from the use of this material,
2076;;; there shall be no use of the name of the Massachusetts Institute of
2077;;; Technology nor of any adaptation thereof in any advertising,
2078;;; promotional, or sales literature without prior written consent from
2079;;; MIT in each case.
2080
2081;;; Scsh copyright terms
2082;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2083;;; All rights reserved.
2084;;;
2085;;; Redistribution and use in source and binary forms, with or without
2086;;; modification, are permitted provided that the following conditions
2087;;; are met:
2088;;; 1. Redistributions of source code must retain the above copyright
2089;;;    notice, this list of conditions and the following disclaimer.
2090;;; 2. Redistributions in binary form must reproduce the above copyright
2091;;;    notice, this list of conditions and the following disclaimer in the
2092;;;    documentation and/or other materials provided with the distribution.
2093;;; 3. The name of the authors may not be used to endorse or promote products
2094;;;    derived from this software without specific prior written permission.
2095;;;
2096;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
2097;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
2098;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
2099;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
2100;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
2101;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
2102;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
2103;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
2104;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
2105;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Note: See TracBrowser for help on using the repository browser.