source: project/chicken/branches/scrutiny/srfi-13.scm @ 14827

Last change on this file since 14827 was 14827, checked in by felix winkelmann, 10 years ago

merged trunk changes until 14826 into scrutiny branch

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