source: project/release/5/srfi-13/trunk/srfi-13.scm @ 34334

Last change on this file since 34334 was 34334, checked in by mario, 23 months ago

release/5/srfi-13: use chicken.string for reverse-list->string

reverse-list->string has been moved to chicken.string in
09c6dc9f2d77e2c5d1b4cfcdcef2377b2d92ed81

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