source: project/chicken/branches/hygienic/srfi-13.scm @ 11092

Last change on this file since 11092 was 11092, checked in by felix winkelmann, 13 years ago

removed srfi-13 macro from chicken-more-macros

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