source: project/chicken/branches/prerelease/srfi-13.scm @ 15101

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

merged trunk changes from 14491:15100 into prerelease branch

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