source: project/release/4/utf8/trunk/utf8-srfi-13.scm @ 14928

Last change on this file since 14928 was 14928, checked in by Alex Shinn, 11 years ago

Reversing order of arguments of string-filter and string-delete
to match the new SRFI-13, not the old SRFI-13 (cf.
http://article.gmane.org/gmane.lisp.scheme.srfi.srfi-13/156)

File size: 22.8 KB
Line 
1;;;; utf8-srfi-13.scm -- Unicode-aware SRFI-13
2;;
3;; Copyright (c) 2004-2009 Alex Shinn. All rights reserved.
4;; BSD-style license: http://synthcode.com/license.txt
5
6(declare
7  (no-procedure-checks)
8  (bound-to-procedure
9    ##sys#substring ##sys#become!))
10
11(require-library utf8-lolevel utf8-srfi-14 iset utf8-case-map)
12
13(module
14 utf8-srfi-13
15 (
16  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
17  ;; srfi-13
18  ;; predicates
19  string-null? string-every string-any
20  ;; constructors
21  string-tabulate
22  ;; selection
23  string-copy string-copy! substring/shared
24  string-take string-take-right string-drop string-drop-right
25  string-pad string-pad-right string-trim string-trim-right string-trim-both
26  ;; comparison
27  string-compare string-compare-ci string-hash string-ci-hash
28  string= string<> string< string> string<= string>=
29  string-ci= string-ci<> string-ci< string-ci> string-ci<= string-ci>=
30  ;; prefixes & suffixes
31  string-prefix? string-prefix-ci? string-prefix-length string-prefix-length-ci
32  string-suffix? string-suffix-ci? string-suffix-length string-suffix-length-ci
33  ;; searching
34  string-index string-index-right string-skip string-skip-right string-count
35  string-contains string-contains-ci
36  ;; alphabetic case maping
37  string-titlecase string-titlecase! string-upcase string-upcase!
38  string-downcase string-downcase!
39  ;; reverse & append
40  string-reverse string-reverse! string-concatenate
41  string-concatenate/shared string-append/shared
42  string-concatenate-reverse string-concatenate-reverse/shared
43  ;; iteration
44  string-map string-map! string-fold string-fold-right
45  string-unfold string-unfold-right string-for-each string-for-each-index
46  ;; replicate & rotate
47  xsubstring string-xcopy! string-replace string-tokenize
48  ;; filtering & deleting
49  string-filter string-delete
50  )
51
52(import (except scheme string-copy) chicken data-structures ports
53        (except srfi-69 string-hash string-ci-hash)
54        utf8-lolevel utf8-srfi-14 iset utf8-case-map)
55
56(define (string-null? s) (equal? s ""))
57
58(define (string-fold kons knil s . opt)
59  (let-optionals* opt ((start 0) (end (utf8-string-length s)))
60    (let lp ((i start) (b (utf8-index->offset s start)) (acc knil))
61      (if (>= i end)
62          acc
63          (lp (+ i 1)
64              (+ b (utf8-start-byte->length (string-int-ref s b)))
65              (kons (sp-ref s b) acc))))))
66
67(define (string-fold-right kons knil s . opt)
68  (let-optionals* opt ((start 0) (end (utf8-string-length s)))
69    (let lp ((i (- end 1))
70             (b (utf8-prev-char s (utf8-index->offset s end)))
71             (acc knil))
72      (if (< i start)
73          acc
74          (lp (- i 1)
75              (utf8-prev-char s b)
76              (kons (sp-ref s b) acc))))))
77
78(define (string-unfold p f g seed . opt)
79  (let-optionals* opt ((base "")
80                       (make-final (lambda (x) "")))
81    (let ((out (open-output-string)))
82      (display base out) ; base must be a string, so normal display is fine
83      (let lp ((seed seed))
84        (if (p seed) 
85            (display (make-final seed) out)
86            (begin
87              (write-utf8-char (f seed) out)
88              (lp (g seed)))))
89      (get-output-string out))))
90
91(define (string-unfold-right p f g seed . opt)
92  (let-optionals* opt ((base "")
93                       (make-final (lambda (x) "")))
94    (let lp ((seed seed) (ans (list base)))
95      (if (p seed) 
96          (string-intersperse (cons (make-final seed) ans) "")
97          (lp (g seed) (cons (char->utf8-string (f seed)) ans))))))
98
99(define (string-map proc s . opt)
100  (string-intersperse
101   (reverse
102    (map char->utf8-string
103         (apply string-fold (lambda (c acc) (cons (proc c) acc)) '() s opt)))
104   ""))
105
106(define string-map! string-map)
107
108(define (string-for-each proc s . opt)
109  (apply string-fold (lambda (c acc) (proc c)) #f s opt)
110  (if #f #f))
111
112(define (string-for-each-index proc s . opt)
113  (let ((start (if (pair? opt) (car opt) 0))
114        (end (if (and (pair? opt) (pair? (cdr opt)))
115               (cadr opt)
116               (utf8-string-length s))))
117    (do ((i start (+ i 1)))
118        ((= i end))
119      (proc i))))
120
121(define (char-predicate x)
122  (cond ((procedure? x) x)
123        ((char? x) (lambda (c) (eqv? c x)))
124        ((char-set? x) (lambda (c) (char-set-contains? x c)))
125        (else (error "unknown predicate" x))))
126
127(define (string-any x str . opt)
128  (let ((pred (char-predicate x)))
129    (call-with-current-continuation
130     (lambda (return)
131       (apply string-fold
132              (lambda (c acc) (cond ((pred c) => return) (else #f)))
133              #f str opt)))))
134
135(define (string-every x str . opt)
136  (let ((pred (char-predicate x)))
137    (call-with-current-continuation
138     (lambda (return)
139       (apply string-fold
140              (lambda (c acc) (cond ((pred c) => identity) (else (return #f))))
141              #f str opt)))))
142
143(define (string-tabulate proc len)
144  (let ((out (open-output-string)))
145    (let lp ((i 0))
146      (cond
147        ((< i len)
148         (write-utf8-char (proc i) out)
149         (lp (+ i 1)))))
150    (get-output-string out)))
151
152(define (string-copy s . opt)
153  (with-substring-offsets (lambda (s start end) (##sys#substring s start end)) s opt))
154
155(define (substring/shared s . opt)
156  (with-substring-offsets (lambda (s start end) (##sys#substring s start end)) s opt))
157
158(define (byte-string-copy! target t-off str start end)
159  (if (> start t-off)
160      (do ((i start (+ i 1))
161           (j t-off (+ j 1)))
162          ((>= i end))
163        (string-set! target j (string-ref str i)))
164      (do ((i (- end 1) (- i 1))
165           (j (+ -1 t-off (- end start)) (- j 1)))
166          ((< i start))
167        (string-set! target j (string-ref str i)))))
168
169(define (string-copy! target tstart str . opt)
170  (let-optionals* opt ((start 0) (end (utf8-string-length str)))
171    (let* ((str (utf8-substring str start end))
172           (len (- end start))
173           (s-size (string-length str))
174           (t-total-size (string-length target))
175           (t-off (utf8-index->offset target tstart))
176           (t-end-off (utf8-index->offset target (+ tstart len)))
177           (t-size (- t-end-off t-off)))
178      (if (= s-size t-size)
179        (byte-string-copy! target t-off str 0 len)
180        (let ((res (string-append
181                    (##sys#substring target 0 t-off)
182                    str
183                    (##sys#substring target t-end-off t-total-size))))
184          (##sys#become! (list (cons target res))))))))
185
186(define (string-take s n) (utf8-substring s 0 n))
187(define (string-drop s n) (utf8-substring s n))
188(define (string-take-right s n) (utf8-substring s (- (utf8-string-length s) n)))
189(define (string-drop-right s n) (utf8-substring s 0 (- (utf8-string-length s) n)))
190
191(define (string-pad s len . opt)
192  (let-optionals* opt ((ch #\space) (start 0) (end (utf8-string-length s)))
193    (let ((diff (- end start)))
194      (if (<= len diff)
195        (utf8-substring s (- end len) end)
196        (string-append (make-utf8-string (- len diff) ch)
197                       (utf8-substring s start end))))))
198
199(define (string-pad-right s len . opt)
200  (let-optionals* opt ((ch #\space) (start 0) (end (utf8-string-length s)))
201    (let ((diff (- end start)))
202      (if (<= len diff)
203        (utf8-substring s start (+ start len))
204        (string-append (utf8-substring s start end)
205                       (make-utf8-string (- len diff) ch))))))
206
207(define (string-trim s . opt)
208  (let-optionals* opt ((trimmer #\space) (start 0) (end #f))
209    (let* ((pred (char-predicate trimmer))
210           (end-off
211            (if end (utf8-index->offset s end) (string-length s))))
212      (let lp ((i (utf8-index->offset s start)))
213        (if (or (>= i end-off) (not (pred (sp-ref s i))))
214            (##sys#substring s i end-off)
215            (lp (sp-next s i)))))))
216
217(define (string-trim-right s . opt)
218  (let-optionals* opt ((trimmer #\space) (start 0) (end #f))
219    (let ((pred (char-predicate trimmer))
220          (end-off
221           (if end (utf8-index->offset s end) (string-length s))))
222      (let lp ((i (sp-prev s end-off)) (j end-off))
223        (if (or (negative? i) (not (pred (sp-ref s i))))
224            (##sys#substring s (utf8-index->offset s start) j)
225            (lp (sp-prev s i) i))))))
226
227(define (string-trim-both s . opt)
228  (let-optionals* opt ((trimmer #\space))
229    (string-trim (apply string-trim-right s opt) trimmer)))
230
231;; alas, can't use string-compare3 because the predicates get the
232;; index as an argument
233
234(define (string-compare s1 s2 proc< proc= proc> . opt)
235  (with-two-substring-offsets
236      (lambda (s1 s2 start1 end1 start2 end2)
237        (let lp ((i start1) (j start2))
238          (cond
239            ((>= i end1)
240             ((if (>= j end2) proc= proc<)
241              (utf8-offset->index s1 i)))
242            ((>= j end2)
243             (utf8-offset->index s1 i))
244            ((char<? (string-ref s1 i) (string-ref s2 i))
245             (proc< (utf8-offset->index s1 i)))
246            ((char>? (string-ref s1 i) (string-ref s2 i))
247             (proc> (utf8-offset->index s1 i)))
248            (else
249             (lp (+ i 1) (+ j 1))))))
250      s1 s2 opt))
251
252(define (string-compare-ci s1 s2 proc< proc= proc> . opt)
253  (with-two-substring-offsets
254      (lambda (s1 s2 start1 end1 start2 end2)
255        (let lp ((i start1) (j start2))
256          (cond
257            ((>= i end1)
258             ((if (>= j end2) proc= proc<)
259              (utf8-offset->index s1 i)))
260            ((>= j end2)
261             (utf8-offset->index s1 i))
262            ((char-ci<? (string-ref s1 i) (string-ref s2 i))
263             (proc< (utf8-offset->index s1 i)))
264            ((char-ci>? (string-ref s1 i) (string-ref s2 i))
265             (proc> (utf8-offset->index s1 i)))
266            (else
267             (lp (+ i 1) (+ j 1))))))
268      s1 s2 opt))
269
270(define (make-string-comparator proc pred)
271  (lambda (s1 s2 . opt)
272    (if (null? opt)
273        (pred (proc s1 s2))
274        (pred (with-two-substring-offsets
275                  (lambda (s1 s2 start1 end1 start2 end2)
276                    (proc (##sys#substring s1 start1 end1)
277                          (##sys#substring s2 start2 end2)))
278                  s1 s2 opt)))))
279
280(define string= (make-string-comparator string-compare3 zero?))
281(define string<> (make-string-comparator string-compare3 (complement zero?)))
282(define string< (make-string-comparator string-compare3 negative?))
283(define string> (make-string-comparator string-compare3 positive?))
284(define string<= (make-string-comparator string-compare3 (complement positive?)))
285(define string>= (make-string-comparator string-compare3 (complement negative?)))
286
287(define string-ci= (make-string-comparator string-compare3-ci zero?))
288(define string-ci<> (make-string-comparator string-compare3-ci (complement zero?)))
289(define string-ci< (make-string-comparator string-compare3-ci negative?))
290(define string-ci> (make-string-comparator string-compare3-ci positive?))
291(define string-ci<= (make-string-comparator string-compare3-ci (complement positive?)))
292(define string-ci>= (make-string-comparator string-compare3-ci (complement negative?)))
293
294(define (utf8-substring-length s start . opt)
295  (let ((end (if (pair? opt) (car opt) (string-length s))))
296    (let lp ((i start) (res 0))
297      (if (>= i end)
298          res
299          (lp (+ i (utf8-start-byte->length (string-int-ref s i)))
300              (+ res 1))))))
301
302(define (make-string-fix-length proc)
303  (lambda (s1 s2 . opt)
304    (with-two-substring-offsets
305     (lambda (s1 s2 start1 end1 start2 end2)
306       (let ((res (proc s1 s2 start1 start2 end1 end2)))
307         (if (zero? res)
308             res
309             (utf8-substring-length s1 start1 (+ start1 res)))))
310     s1 s2 opt)))
311
312(define (byte-string-prefix-length s1 s2 start1 start2 end1 end2)
313  (let lp ((i start1) (j start2))
314    (cond
315      ((>= i end1) (- i start1))
316      ((>= j end2) (- j start2))
317      ((char=? (string-ref s1 i) (string-ref s2 j))
318       (lp (+ i 1) (+ j 1)))
319      (else (- i start1)))))
320
321(define (byte-string-prefix-length-ci s1 s2 start1 start2 end1 end2)
322  (let lp ((i start1) (j start2))
323    (cond
324      ((>= i end1) (- i start1))
325      ((>= j end2) (- j start2))
326      ((char-ci=? (string-ref s1 i) (string-ref s2 j))
327       (lp (+ i 1) (+ j 1)))
328      (else (- i start1)))))
329
330(define (byte-string-suffix-length s1 s2 start1 start2 end1 end2)
331  (let lp ((i (- end1 1)) (j (- end2 1)))
332    (cond
333      ((< i start1) (- end1 i 1))
334      ((< j start2) (- end2 j 1))
335      ((char=? (string-ref s1 i) (string-ref s2 j))
336       (lp (- i 1) (- j 1)))
337      (else (- end1 i 1)))))
338
339(define (byte-string-suffix-length-ci s1 s2 start1 start2 end1 end2)
340  (let lp ((i (- end1 1)) (j (- end2 1)))
341    (cond
342      ((< i start1) (- end1 i 1))
343      ((< j start2) (- end2 j 1))
344      ((char-ci=? (string-ref s1 i) (string-ref s2 j))
345       (lp (- i 1) (- j 1)))
346      (else (- end1 i 1)))))
347
348(define string-prefix-length
349  (make-string-fix-length byte-string-prefix-length))
350(define string-prefix-length-ci
351  (make-string-fix-length byte-string-prefix-length-ci))
352(define string-suffix-length
353  (make-string-fix-length byte-string-suffix-length))
354(define string-suffix-length-ci
355  (make-string-fix-length byte-string-suffix-length-ci))
356
357(define (make-string-prefix-test proc)
358  (lambda (s1 s2 . opt)
359    (cond
360     ((null? opt)
361      (and (<= (string-length s1) (string-length s2)) (proc s1 s2)))
362     (else
363      (with-two-substring-offsets
364       (lambda (s1 s2 start1 end1 start2 end2)
365         (let ((s1-len (- end1 start1))
366               (s2-len (- end2 start2)))
367           (and (<= s1-len s2-len) (proc s1 s2 start1 start2 s1-len))))
368       s1 s2 opt)))))
369
370(define string-prefix? (make-string-prefix-test substring=?))
371(define string-prefix-ci? (make-string-prefix-test substring-ci=?))
372
373(define (string-suffix? s1 s2 . opt)
374  (with-two-substring-offsets
375      (lambda (s1 s2 start1 end1 start2 end2)
376        (and (>= (- end2 start2) (- end1 start1))
377             (let lp ((i (- end1 1)) (j (- end2 1)))
378               (or (< i start1)
379                   (if (char=? (string-ref s1 i) (string-ref s2 j))
380                       (lp (- i 1) (- j 1))
381                       #f)))))
382      s1 s2 opt))
383
384(define (string-suffix-ci? s1 s2 . opt)
385  (with-two-substring-offsets
386      (lambda (s1 s2 start1 end1 start2 end2)
387        (and (>= (- end2 start2) (- end1 start1))
388             (let lp ((i (- end1 1)) (j (- end2 1)))
389               (or (< i start1)
390                   (if (char-ci=? (string-ref s1 i) (string-ref s2 j))
391                       (lp (- i 1) (- j 1))
392                       #f)))))
393      s1 s2 opt))
394
395(define (make-string-hasher proc)
396  (lambda (s . opt)
397    (cond
398      ((null? opt)
399       (proc s))
400      ((null? (cdr opt))
401       (proc s (car opt)))
402      (else
403       (with-substring-offsets
404           (lambda (s start end)
405             (proc (##sys#substring s start end) (car opt)))
406           s (cdr opt))))))
407
408(define string-hash
409  (make-string-hasher hash))
410(define string-ci-hash
411  (make-string-hasher (lambda (s) (hash (string-downcase s)))))
412
413(define (with-string-index+offset proc s x . opt)
414  (if (equal? s "")
415      #f
416      (let-optionals* opt ((start 0) (end -1))
417        (let ((size (string-length s))
418              (pred (char-predicate x)))
419          (let lp ((i start) (off (utf8-index->offset s start)))
420            (if (or (= i end) (= off size))
421                (proc #f #f)
422                (let ((ch (sp-ref s off)))
423                  (if (pred ch)
424                      (proc i off)
425                      (lp (+ i 1)
426                          (+ off (ucs-integer->length
427                                  (char->integer ch))))))))))))
428
429(define (with-string-index+offset-right proc s x . opt)
430  (if (equal? s "")
431      #f
432      (let-optionals* opt ((start 0) (end (utf8-string-length s)))
433        (let* ((size (string-length s))
434               (pred (char-predicate x)))
435          (let lp ((i (- end 1)) (off (utf8-index->offset s (- end 1))))
436            (if (< i start)
437                (proc #f #f)
438                (let ((ch (sp-ref s off)))
439                  (if (pred ch)
440                      (proc i off)
441                      (if (zero? i)
442                          (lp -1 -1)
443                          (lp (- i 1) (utf8-prev-char s off)))))))))))
444
445(define (arg1 a b) a)
446;;(define (arg2 a b) b)
447
448(define (string-index s x . opt)
449  (apply with-string-index+offset arg1 s x opt))
450;; (define (string-offset s x . opt)
451;;   (apply with-string-index+offset arg2 s x opt))
452(define (string-index-right s x . opt)
453  (apply with-string-index+offset-right arg1 s x opt))
454;; (define (string-offset-right s x . opt)
455;;   (apply with-string-index+offset-right arg2 s x opt))
456
457(define (string-skip s x . opt)
458  (apply string-index s (complement (char-predicate x)) opt))
459(define (string-skip-right s x . opt)
460  (apply string-index-right s (complement (char-predicate x)) opt))
461
462(define (string-count s x . opt)
463  (let ((pred (char-predicate x)))
464    (apply string-fold (lambda (c sum) (if (pred c) (+ sum 1) sum)) 0 s opt)))
465
466;; cleaner to loop ourselves, but the byte-oriented substring-index
467;; uses memcmp directly, so we go out of our way to make use of that,
468;; while avoiding substring if at all possible
469(define (string-contains s1 s2 . opt)
470  (define (return offset index)
471    (and offset (+ (utf8-offset->index s1 offset) index)))
472  (if (null? opt)
473      (return (substring-index s2 s1) 0)
474      (let* ((start1-index (car opt))
475             (opt (cdr opt))
476             (start1 (utf8-index->offset s1 start1-index)))
477        (if (null? opt)
478            (return (substring-index s2 s1 start1) 0)
479            (let* ((end1 (utf8-index->offset s1 (car opt)))
480                   (opt (cdr opt))
481                   (s2 (if (null? opt)
482                           s2
483                           (with-substring-offsets ##sys#substring s2 opt))))
484              (if (= end1 (string-length s1))
485                  (return (substring-index s2 s1 start1) 0)
486                  (return (substring-index
487                           s2
488                           (##sys#substring s1 start1 end1))
489                          start1-index)))))))
490
491;; XXXX consider using full unicode case mappings
492(define (string-contains-ci s1 s2 . opt)
493  (define (return offset index)
494    (and offset (+ (utf8-offset->index s1 offset) index)))
495  (if (null? opt)
496      (return (substring-index s2 s1) 0)
497      (let* ((start1-index (car opt))
498             (opt (cdr opt))
499             (start1 (utf8-index->offset s1 start1-index)))
500        (if (null? opt)
501            (return (substring-index-ci s2 s1 start1) 0)
502            (let* ((end1 (utf8-index->offset s1 (car opt)))
503                   (opt (cdr opt))
504                   (s2 (if (null? opt)
505                           s2
506                           (with-substring-offsets ##sys#substring s2 opt))))
507              (if (= end1 (string-length s1))
508                  (return (substring-index-ci s2 s1 start1) 0)
509                  (return (substring-index-ci
510                           s2
511                           (##sys#substring s1 start1 end1))
512                          start1-index)))))))
513
514;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
515;; case mapping
516
517(define string-titlecase utf8-string-titlecase)
518(define string-titlecase! utf8-string-titlecase)
519(define string-downcase utf8-string-downcase)
520(define string-downcase! utf8-string-downcase)
521(define string-upcase utf8-string-upcase)
522(define string-upcase! utf8-string-upcase)
523
524;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
525;; reverse & append
526
527(define (%string-reverse s start end)
528  (let* ((len (- end start))
529         (res (make-string len)))
530    (let lp ((i end)
531             (j 0))
532      (let ((i2 (utf8-prev-char s i)))
533        (if (not i2)
534            res
535            (let lp2 ((i3 i2) (j j))
536              (if (eqv? i3 i)
537                  (lp i2 j)
538                  (begin
539                    (string-set! res j (string-ref s i3))
540                    (lp2 (+ i3 1) (+ j 1))))))))))
541
542(define (string-reverse s . opt)
543  (with-substring-offsets %string-reverse s opt))
544
545(define (string-reverse! s . opt)
546  (with-substring-offsets
547   (lambda (s start end)
548     (let ((s2 (%string-reverse s start end)))
549       (byte-string-copy! s start s2 0 (string-length s2))))
550   s opt))
551
552(define string-append/shared string-append)
553(define (string-concatenate ls) (string-intersperse ls ""))
554(define (string-concatenate-reverse ls) (string-intersperse (reverse ls) ""))
555(define string-concatenate-reverse/shared string-concatenate-reverse)
556(define string-concatenate/shared string-concatenate)
557
558(define (xsubstring s1 from . opt)
559  (let-optionals* opt ((to1 #f) (start 0) (end (utf8-string-length s1)))
560    (let* ((s (utf8-substring s1 start end))
561           (len (- end start))
562           (to (or to1 (+ from len)))
563           (out (open-output-string)))
564      (let lp ((i from))
565        (cond
566          ((< i to)
567           (write-utf8-char (utf8-string-ref s (modulo i len)) out)
568           (lp (+ i 1)))))
569      (get-output-string out))))
570
571(define (string-xcopy target tstart s from . opt)
572  (let-optionals* opt ((to1 #f) (start 0) (end (utf8-string-length s)))
573    (let ((to (or to1 (+ from - end start))))
574      (string-append (utf8-substring target 0 tstart)
575                     (xsubstring s from to start end)
576                     (utf8-substring target
577                                (+ tstart (- to from))
578                                (utf8-string-length target))))))
579
580(define (string-xcopy! target tstart s from . opt)
581  (let ((res (apply string-xcopy target tstart s from opt)))
582    (##sys#become! (list (cons target res)))))
583
584(define (string-filter filt s . opt)
585  (let ((pred (char-predicate filt)))
586    (with-output-to-string
587      (lambda ()
588        (string-for-each
589         (lambda (c) (if (pred c) (write-utf8-char c)))
590         (if (pair? opt)
591             (apply utf8-substring s opt)
592             s))))))
593
594(define (string-delete filt s . opt)
595  (let ((pred (char-predicate filt)))
596    (apply string-filter s (lambda (c) (not (pred c))) opt)))
597
598(define (string-replace s1 s2 start1 end1 . opt)
599  (let ((start1 (utf8-index->offset s1 start1))
600        (end1 (utf8-index->offset s1 end1)))
601    (with-substring-offsets
602     (lambda (s2 start2 end2)
603       (string-append (##sys#substring s1 0 start1)
604                      (##sys#substring s2 start2 end2)
605                      (##sys#substring s1 end1 (string-length s1))))
606     s2 opt)))
607
608(define (string-tokenize s . opt)
609  (let-optionals* opt ((token-set char-set:graphic)
610                       o2)
611    (with-substring-offsets
612     (lambda (s start end)
613       (letrec
614           ((out
615             (lambda (sp res)
616               (cond
617                 ((>= sp end)
618                  (reverse res))
619                 ((char-set-contains? token-set (sp-ref s sp))
620                  (in (sp-next s sp) sp res))
621                 (else
622                  (out (sp-next s sp) res)))))
623            (in
624             (lambda (sp from res)
625               (cond
626                 ((>= sp end)
627                  (reverse (cons (sp-substring s from end) res)))
628                 ((char-set-contains? token-set (sp-ref s sp))
629                  (in (sp-next s sp) from res))
630                 (else
631                  (out (sp-next s sp) (cons (sp-substring s from sp) res)))))))
632         (out start '())))
633     s o2)))
634
635)
Note: See TracBrowser for help on using the repository browser.