« back to all changes in this revision
Viewing changes to libguile/srfi-13.c
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Daniel Schepler
- Date: 2006-11-09 03:11:16 UTC
- Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1
- files added:
- am
- benchmark-suite
- benchmark-suite/benchmarks
- doc
- doc/r5rs
- doc/tutorial
- examples
- examples/box
- examples/box-dynamic
- examples/box-dynamic-module
- examples/box-module
- examples/modules
- examples/safe
- examples/scripts
- guile-config
- guile-readline
- guile-readline/ice-9
- ice-9
- ice-9/debugger
- lang
- lang/elisp
- lang/elisp/internals
- lang/elisp/primitives
- libguile
- oop
- oop/goops
- scripts
- srfi
- test-suite
- test-suite/standalone
- test-suite/tests
- test-suite/tests/c-api
added
removed
libguile/srfi-13.c
1
/* srfi-13.c --- SRFI-13 procedures for Guile
2
*
3
* Copyright (C) 2001, 2004, 2005, 2006 Free Software Foundation, Inc.
4
*
5
* This library is free software; you can redistribute it and/or
6
* modify it under the terms of the GNU Lesser General Public
7
* License as published by the Free Software Foundation; either
8
* version 2.1 of the License, or (at your option) any later version.
9
*
10
* This library is distributed in the hope that it will be useful,
11
* but WITHOUT ANY WARRANTY; without even the implied warranty of
12
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13
* Lesser General Public License for more details.
14
*
15
* You should have received a copy of the GNU Lesser General Public
16
* License along with this library; if not, write to the Free Software
17
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
*/
19
20
21
#include <string.h>
22
#include <ctype.h>
23
24
#include "libguile.h"
25
26
#include "libguile/srfi-13.h"
27
#include "libguile/srfi-14.h"
28
29
/* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages
30
messing with the internal representation of strings. We define our
31
own version since we use it so much and are messing with Guile
32
internals anyway.
33
*/
34
35
#define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \
36
pos_start, start, c_start, \
37
pos_end, end, c_end) \
38
do { \
39
SCM_VALIDATE_STRING (pos_str, str); \
40
c_str = scm_i_string_chars (str); \
41
scm_i_get_substring_spec (scm_i_string_length (str), \
42
start, &c_start, end, &c_end); \
43
} while (0)
44
45
/* Expecting "unsigned char *c_str" */
46
#define MY_VALIDATE_SUBSTRING_SPEC_UCOPY(pos_str, str, c_str, \
47
pos_start, start, c_start, \
48
pos_end, end, c_end) \
49
do { \
50
const char *signed_c_str; \
51
MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, signed_c_str, \
52
pos_start, start, c_start, \
53
pos_end, end, c_end); \
54
c_str = (unsigned char *) signed_c_str; \
55
} while (0)
56
57
#define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
58
pos_start, start, c_start, \
59
pos_end, end, c_end) \
60
do { \
61
SCM_VALIDATE_STRING (pos_str, str); \
62
scm_i_get_substring_spec (scm_i_string_length (str), \
63
start, &c_start, end, &c_end); \
64
} while (0)
65
66
SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0,
67
(SCM str),
68
"Return @code{#t} if @var{str}'s length is zero, and\n"
69
"@code{#f} otherwise.\n"
70
"@lisp\n"
71
"(string-null? \"\") @result{} #t\n"
72
"y @result{} \"foo\"\n"
73
"(string-null? y) @result{} #f\n"
74
"@end lisp")
75
#define FUNC_NAME s_scm_string_null_p
76
{
77
SCM_VALIDATE_STRING (1, str);
78
return scm_from_bool (scm_i_string_length (str) == 0);
79
}
80
#undef FUNC_NAME
81
82
#if 0
83
static void
84
race_error ()
85
{
86
scm_misc_error (NULL, "race condition detected", SCM_EOL);
87
}
88
#endif
89
90
SCM_DEFINE (scm_string_any, "string-any-c-code", 2, 2, 0,
91
(SCM char_pred, SCM s, SCM start, SCM end),
92
"Check if @var{char_pred} is true for any character in string @var{s}.\n"
93
"\n"
94
"@var{char_pred} can be a character to check for any equal to that, or\n"
95
"a character set (@pxref{Character Sets}) to check for any in that set,\n"
96
"or a predicate procedure to call.\n"
97
"\n"
98
"For a procedure, calls @code{(@var{char_pred} c)} are made\n"
99
"successively on the characters from @var{start} to @var{end}. If\n"
100
"@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any}\n"
101
"stops and that return value is the return from @code{string-any}. The\n"
102
"call on the last character (ie.@: at @math{@var{end}-1}), if that\n"
103
"point is reached, is a tail call.\n"
104
"\n"
105
"If there are no characters in @var{s} (ie.@: @var{start} equals\n"
106
"@var{end}) then the return is @code{#f}.\n")
107
#define FUNC_NAME s_scm_string_any
108
{
109
const char *cstr;
110
size_t cstart, cend;
111
SCM res = SCM_BOOL_F;
112
113
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
114
3, start, cstart,
115
4, end, cend);
116
117
if (SCM_CHARP (char_pred))
118
{
119
res = (memchr (cstr+cstart, (int) SCM_CHAR (char_pred),
120
cend-cstart) == NULL
121
? SCM_BOOL_F : SCM_BOOL_T);
122
}
123
else if (SCM_CHARSETP (char_pred))
124
{
125
size_t i;
126
for (i = cstart; i < cend; i++)
127
if (SCM_CHARSET_GET (char_pred, cstr[i]))
128
{
129
res = SCM_BOOL_T;
130
break;
131
}
132
}
133
else
134
{
135
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
136
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG1, FUNC_NAME);
137
138
while (cstart < cend)
139
{
140
res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
141
if (scm_is_true (res))
142
break;
143
cstr = scm_i_string_chars (s);
144
cstart++;
145
}
146
}
147
148
scm_remember_upto_here_1 (s);
149
return res;
150
}
151
#undef FUNC_NAME
152
153
154
SCM_DEFINE (scm_string_every, "string-every-c-code", 2, 2, 0,
155
(SCM char_pred, SCM s, SCM start, SCM end),
156
"Check if @var{char_pred} is true for every character in string\n"
157
"@var{s}.\n"
158
"\n"
159
"@var{char_pred} can be a character to check for every character equal\n"
160
"to that, or a character set (@pxref{Character Sets}) to check for\n"
161
"every character being in that set, or a predicate procedure to call.\n"
162
"\n"
163
"For a procedure, calls @code{(@var{char_pred} c)} are made\n"
164
"successively on the characters from @var{start} to @var{end}. If\n"
165
"@var{char_pred} returns @code{#f}, @code{string-every} stops and\n"
166
"returns @code{#f}. The call on the last character (ie.@: at\n"
167
"@math{@var{end}-1}), if that point is reached, is a tail call and the\n"
168
"return from that call is the return from @code{string-every}.\n"
169
"\n"
170
"If there are no characters in @var{s} (ie.@: @var{start} equals\n"
171
"@var{end}) then the return is @code{#t}.\n")
172
#define FUNC_NAME s_scm_string_every
173
{
174
const char *cstr;
175
size_t cstart, cend;
176
SCM res = SCM_BOOL_T;
177
178
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
179
3, start, cstart,
180
4, end, cend);
181
if (SCM_CHARP (char_pred))
182
{
183
char cchr = SCM_CHAR (char_pred);
184
size_t i;
185
for (i = cstart; i < cend; i++)
186
if (cstr[i] != cchr)
187
{
188
res = SCM_BOOL_F;
189
break;
190
}
191
}
192
else if (SCM_CHARSETP (char_pred))
193
{
194
size_t i;
195
for (i = cstart; i < cend; i++)
196
if (!SCM_CHARSET_GET (char_pred, cstr[i]))
197
{
198
res = SCM_BOOL_F;
199
break;
200
}
201
}
202
else
203
{
204
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
205
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG1, FUNC_NAME);
206
207
while (cstart < cend)
208
{
209
res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
210
if (scm_is_false (res))
211
break;
212
cstr = scm_i_string_chars (s);
213
cstart++;
214
}
215
}
216
217
scm_remember_upto_here_1 (s);
218
return res;
219
}
220
#undef FUNC_NAME
221
222
223
SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0,
224
(SCM proc, SCM len),
225
"@var{proc} is an integer->char procedure. Construct a string\n"
226
"of size @var{len} by applying @var{proc} to each index to\n"
227
"produce the corresponding string element. The order in which\n"
228
"@var{proc} is applied to the indices is not specified.")
229
#define FUNC_NAME s_scm_string_tabulate
230
{
231
size_t clen, i;
232
SCM res;
233
SCM ch;
234
char *p;
235
scm_t_trampoline_1 proc_tramp;
236
237
proc_tramp = scm_trampoline_1 (proc);
238
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
239
240
clen = scm_to_size_t (len);
241
SCM_ASSERT_RANGE (2, len, clen >= 0);
242
243
res = scm_i_make_string (clen, &p);
244
i = 0;
245
while (i < clen)
246
{
247
/* The RES string remains untouched since nobody knows about it
248
yet. No need to refetch P.
249
*/
250
ch = proc_tramp (proc, scm_from_size_t (i));
251
if (!SCM_CHARP (ch))
252
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
253
*p++ = SCM_CHAR (ch);
254
i++;
255
}
256
return res;
257
}
258
#undef FUNC_NAME
259
260
261
SCM_DEFINE (scm_substring_to_list, "string->list", 1, 2, 0,
262
(SCM str, SCM start, SCM end),
263
"Convert the string @var{str} into a list of characters.")
264
#define FUNC_NAME s_scm_substring_to_list
265
{
266
const char *cstr;
267
size_t cstart, cend;
268
SCM result = SCM_EOL;
269
270
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
271
2, start, cstart,
272
3, end, cend);
273
while (cstart < cend)
274
{
275
cend--;
276
result = scm_cons (SCM_MAKE_CHAR (cstr[cend]), result);
277
cstr = scm_i_string_chars (str);
278
}
279
scm_remember_upto_here_1 (str);
280
return result;
281
}
282
#undef FUNC_NAME
283
284
/* We export scm_substring_to_list as "string->list" since it is
285
compatible and more general. This function remains for the benefit
286
of C code that used it.
287
*/
288
289
SCM
290
scm_string_to_list (SCM str)
291
{
292
return scm_substring_to_list (str, SCM_UNDEFINED, SCM_UNDEFINED);
293
}
294
295
SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0,
296
(SCM chrs),
297
"An efficient implementation of @code{(compose string->list\n"
298
"reverse)}:\n"
299
"\n"
300
"@smalllisp\n"
301
"(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
302
"@end smalllisp")
303
#define FUNC_NAME s_scm_reverse_list_to_string
304
{
305
SCM result;
306
long i = scm_ilength (chrs);
307
char *data;
308
309
if (i < 0)
310
SCM_WRONG_TYPE_ARG (1, chrs);
311
result = scm_i_make_string (i, &data);
312
313
{
314
315
data += i;
316
while (i > 0 && scm_is_pair (chrs))
317
{
318
SCM elt = SCM_CAR (chrs);
319
320
SCM_VALIDATE_CHAR (SCM_ARGn, elt);
321
data--;
322
*data = SCM_CHAR (elt);
323
chrs = SCM_CDR (chrs);
324
i--;
325
}
326
}
327
328
return result;
329
}
330
#undef FUNC_NAME
331
332
333
SCM_SYMBOL (scm_sym_infix, "infix");
334
SCM_SYMBOL (scm_sym_strict_infix, "strict-infix");
335
SCM_SYMBOL (scm_sym_suffix, "suffix");
336
SCM_SYMBOL (scm_sym_prefix, "prefix");
337
338
static void
339
append_string (char **sp, size_t *lp, SCM str)
340
{
341
size_t len;
342
len = scm_c_string_length (str);
343
if (len > *lp)
344
len = *lp;
345
memcpy (*sp, scm_i_string_chars (str), len);
346
*lp -= len;
347
*sp += len;
348
}
349
350
SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
351
(SCM ls, SCM delimiter, SCM grammar),
352
"Append the string in the string list @var{ls}, using the string\n"
353
"@var{delim} as a delimiter between the elements of @var{ls}.\n"
354
"@var{grammar} is a symbol which specifies how the delimiter is\n"
355
"placed between the strings, and defaults to the symbol\n"
356
"@code{infix}.\n"
357
"\n"
358
"@table @code\n"
359
"@item infix\n"
360
"Insert the separator between list elements. An empty string\n"
361
"will produce an empty list.\n"
362
"@item string-infix\n"
363
"Like @code{infix}, but will raise an error if given the empty\n"
364
"list.\n"
365
"@item suffix\n"
366
"Insert the separator after every list element.\n"
367
"@item prefix\n"
368
"Insert the separator before each list element.\n"
369
"@end table")
370
#define FUNC_NAME s_scm_string_join
371
{
372
#define GRAM_INFIX 0
373
#define GRAM_STRICT_INFIX 1
374
#define GRAM_SUFFIX 2
375
#define GRAM_PREFIX 3
376
SCM tmp;
377
SCM result;
378
int gram = GRAM_INFIX;
379
size_t del_len = 0;
380
size_t len = 0;
381
char *p;
382
long strings = scm_ilength (ls);
383
384
/* Validate the string list. */
385
if (strings < 0)
386
SCM_WRONG_TYPE_ARG (1, ls);
387
388
/* Validate the delimiter and record its length. */
389
if (SCM_UNBNDP (delimiter))
390
{
391
delimiter = scm_from_locale_string (" ");
392
del_len = 1;
393
}
394
else
395
del_len = scm_c_string_length (delimiter);
396
397
/* Validate the grammar symbol and remember the grammar. */
398
if (SCM_UNBNDP (grammar))
399
gram = GRAM_INFIX;
400
else if (scm_is_eq (grammar, scm_sym_infix))
401
gram = GRAM_INFIX;
402
else if (scm_is_eq (grammar, scm_sym_strict_infix))
403
gram = GRAM_STRICT_INFIX;
404
else if (scm_is_eq (grammar, scm_sym_suffix))
405
gram = GRAM_SUFFIX;
406
else if (scm_is_eq (grammar, scm_sym_prefix))
407
gram = GRAM_PREFIX;
408
else
409
SCM_WRONG_TYPE_ARG (3, grammar);
410
411
/* Check grammar constraints and calculate the space required for
412
the delimiter(s). */
413
switch (gram)
414
{
415
case GRAM_INFIX:
416
if (!scm_is_null (ls))
417
len = (strings > 0) ? ((strings - 1) * del_len) : 0;
418
break;
419
case GRAM_STRICT_INFIX:
420
if (strings == 0)
421
SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
422
SCM_EOL);
423
len = (strings - 1) * del_len;
424
break;
425
default:
426
len = strings * del_len;
427
break;
428
}
429
430
tmp = ls;
431
while (scm_is_pair (tmp))
432
{
433
len += scm_c_string_length (SCM_CAR (tmp));
434
tmp = SCM_CDR (tmp);
435
}
436
437
result = scm_i_make_string (len, &p);
438
439
tmp = ls;
440
switch (gram)
441
{
442
case GRAM_INFIX:
443
case GRAM_STRICT_INFIX:
444
while (scm_is_pair (tmp))
445
{
446
append_string (&p, &len, SCM_CAR (tmp));
447
if (!scm_is_null (SCM_CDR (tmp)) && del_len > 0)
448
append_string (&p, &len, delimiter);
449
tmp = SCM_CDR (tmp);
450
}
451
break;
452
case GRAM_SUFFIX:
453
while (scm_is_pair (tmp))
454
{
455
append_string (&p, &len, SCM_CAR (tmp));
456
if (del_len > 0)
457
append_string (&p, &len, delimiter);
458
tmp = SCM_CDR (tmp);
459
}
460
break;
461
case GRAM_PREFIX:
462
while (scm_is_pair (tmp))
463
{
464
if (del_len > 0)
465
append_string (&p, &len, delimiter);
466
append_string (&p, &len, SCM_CAR (tmp));
467
tmp = SCM_CDR (tmp);
468
}
469
break;
470
}
471
472
return result;
473
#undef GRAM_INFIX
474
#undef GRAM_STRICT_INFIX
475
#undef GRAM_SUFFIX
476
#undef GRAM_PREFIX
477
}
478
#undef FUNC_NAME
479
480
481
/* There are a number of functions to consider here for Scheme and C:
482
483
string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
484
substring/copy STR start [end] ;; Guile variant of R5RS substring
485
486
scm_string_copy (str) ;; Old function from Guile
487
scm_substring_copy (str, [start, [end]])
488
;; C version of SRFI-13 string-copy
489
;; and C version of substring/copy
490
491
The C function underlying string-copy is not exported to C
492
programs. scm_substring_copy is defined in strings.c as the
493
underlying function of substring/copy and allows an optional START
494
argument.
495
*/
496
497
SCM scm_srfi13_substring_copy (SCM str, SCM start, SCM end);
498
499
SCM_DEFINE (scm_srfi13_substring_copy, "string-copy", 1, 2, 0,
500
(SCM str, SCM start, SCM end),
501
"Return a freshly allocated copy of the string @var{str}. If\n"
502
"given, @var{start} and @var{end} delimit the portion of\n"
503
"@var{str} which is copied.")
504
#define FUNC_NAME s_scm_srfi13_substring_copy
505
{
506
const char *cstr;
507
size_t cstart, cend;
508
509
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
510
2, start, cstart,
511
3, end, cend);
512
return scm_c_substring_copy (str, cstart, cend);
513
}
514
#undef FUNC_NAME
515
516
SCM
517
scm_string_copy (SCM str)
518
{
519
return scm_c_substring (str, 0, scm_c_string_length (str));
520
}
521
522
SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0,
523
(SCM target, SCM tstart, SCM s, SCM start, SCM end),
524
"Copy the sequence of characters from index range [@var{start},\n"
525
"@var{end}) in string @var{s} to string @var{target}, beginning\n"
526
"at index @var{tstart}. The characters are copied left-to-right\n"
527
"or right-to-left as needed -- the copy is guaranteed to work,\n"
528
"even if @var{target} and @var{s} are the same string. It is an\n"
529
"error if the copy operation runs off the end of the target\n"
530
"string.")
531
#define FUNC_NAME s_scm_string_copy_x
532
{
533
const char *cstr;
534
char *ctarget;
535
size_t cstart, cend, ctstart, dummy, len;
536
SCM sdummy = SCM_UNDEFINED;
537
538
MY_VALIDATE_SUBSTRING_SPEC (1, target,
539
2, tstart, ctstart,
540
2, sdummy, dummy);
541
MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
542
4, start, cstart,
543
5, end, cend);
544
len = cend - cstart;
545
SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart);
546
547
ctarget = scm_i_string_writable_chars (target);
548
memmove (ctarget + ctstart, cstr + cstart, len);
549
scm_i_string_stop_writing ();
550
scm_remember_upto_here_1 (target);
551
552
return SCM_UNSPECIFIED;
553
}
554
#undef FUNC_NAME
555
556
SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0,
557
(SCM str1, SCM start1, SCM end1, SCM str2, SCM start2),
558
"Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
559
"into @var{str2} beginning at position @var{start2}.\n"
560
"@var{str1} and @var{str2} can be the same string.")
561
#define FUNC_NAME s_scm_substring_move_x
562
{
563
return scm_string_copy_x (str2, start2, str1, start1, end1);
564
}
565
#undef FUNC_NAME
566
567
SCM_DEFINE (scm_string_take, "string-take", 2, 0, 0,
568
(SCM s, SCM n),
569
"Return the @var{n} first characters of @var{s}.")
570
#define FUNC_NAME s_scm_string_take
571
{
572
return scm_substring (s, SCM_INUM0, n);
573
}
574
#undef FUNC_NAME
575
576
577
SCM_DEFINE (scm_string_drop, "string-drop", 2, 0, 0,
578
(SCM s, SCM n),
579
"Return all but the first @var{n} characters of @var{s}.")
580
#define FUNC_NAME s_scm_string_drop
581
{
582
return scm_substring (s, n, SCM_UNDEFINED);
583
}
584
#undef FUNC_NAME
585
586
587
SCM_DEFINE (scm_string_take_right, "string-take-right", 2, 0, 0,
588
(SCM s, SCM n),
589
"Return the @var{n} last characters of @var{s}.")
590
#define FUNC_NAME s_scm_string_take_right
591
{
592
return scm_substring (s,
593
scm_difference (scm_string_length (s), n),
594
SCM_UNDEFINED);
595
}
596
#undef FUNC_NAME
597
598
599
SCM_DEFINE (scm_string_drop_right, "string-drop-right", 2, 0, 0,
600
(SCM s, SCM n),
601
"Return all but the last @var{n} characters of @var{s}.")
602
#define FUNC_NAME s_scm_string_drop_right
603
{
604
return scm_substring (s,
605
SCM_INUM0,
606
scm_difference (scm_string_length (s), n));
607
}
608
#undef FUNC_NAME
609
610
611
SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0,
612
(SCM s, SCM len, SCM chr, SCM start, SCM end),
613
"Take that characters from @var{start} to @var{end} from the\n"
614
"string @var{s} and return a new string, right-padded by the\n"
615
"character @var{chr} to length @var{len}. If the resulting\n"
616
"string is longer than @var{len}, it is truncated on the right.")
617
#define FUNC_NAME s_scm_string_pad
618
{
619
char cchr;
620
size_t cstart, cend, clen;
621
622
MY_VALIDATE_SUBSTRING_SPEC (1, s,
623
4, start, cstart,
624
5, end, cend);
625
clen = scm_to_size_t (len);
626
627
if (SCM_UNBNDP (chr))
628
cchr = ' ';
629
else
630
{
631
SCM_VALIDATE_CHAR (3, chr);
632
cchr = SCM_CHAR (chr);
633
}
634
if (clen < (cend - cstart))
635
return scm_c_substring (s, cend - clen, cend);
636
else
637
{
638
SCM result;
639
char *dst;
640
641
result = scm_i_make_string (clen, &dst);
642
memset (dst, cchr, (clen - (cend - cstart)));
643
memmove (dst + clen - (cend - cstart),
644
scm_i_string_chars (s) + cstart, cend - cstart);
645
return result;
646
}
647
}
648
#undef FUNC_NAME
649
650
651
SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0,
652
(SCM s, SCM len, SCM chr, SCM start, SCM end),
653
"Take that characters from @var{start} to @var{end} from the\n"
654
"string @var{s} and return a new string, left-padded by the\n"
655
"character @var{chr} to length @var{len}. If the resulting\n"
656
"string is longer than @var{len}, it is truncated on the left.")
657
#define FUNC_NAME s_scm_string_pad_right
658
{
659
char cchr;
660
size_t cstart, cend, clen;
661
662
MY_VALIDATE_SUBSTRING_SPEC (1, s,
663
4, start, cstart,
664
5, end, cend);
665
clen = scm_to_size_t (len);
666
667
if (SCM_UNBNDP (chr))
668
cchr = ' ';
669
else
670
{
671
SCM_VALIDATE_CHAR (3, chr);
672
cchr = SCM_CHAR (chr);
673
}
674
if (clen < (cend - cstart))
675
return scm_c_substring (s, cstart, cstart + clen);
676
else
677
{
678
SCM result;
679
char *dst;
680
681
result = scm_i_make_string (clen, &dst);
682
memset (dst + (cend - cstart), cchr, clen - (cend - cstart));
683
memmove (dst, scm_i_string_chars (s) + cstart, cend - cstart);
684
return result;
685
}
686
}
687
#undef FUNC_NAME
688
689
690
SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0,
691
(SCM s, SCM char_pred, SCM start, SCM end),
692
"Trim @var{s} by skipping over all characters on the left\n"
693
"that satisfy the parameter @var{char_pred}:\n"
694
"\n"
695
"@itemize @bullet\n"
696
"@item\n"
697
"if it is the character @var{ch}, characters equal to\n"
698
"@var{ch} are trimmed,\n"
699
"\n"
700
"@item\n"
701
"if it is a procedure @var{pred} characters that\n"
702
"satisfy @var{pred} are trimmed,\n"
703
"\n"
704
"@item\n"
705
"if it is a character set, characters in that set are trimmed.\n"
706
"@end itemize\n"
707
"\n"
708
"If called without a @var{char_pred} argument, all whitespace is\n"
709
"trimmed.")
710
#define FUNC_NAME s_scm_string_trim
711
{
712
const char *cstr;
713
size_t cstart, cend;
714
715
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
716
3, start, cstart,
717
4, end, cend);
718
if (SCM_UNBNDP (char_pred))
719
{
720
while (cstart < cend)
721
{
722
if (!isspace((int) (unsigned char) cstr[cstart]))
723
break;
724
cstart++;
725
}
726
}
727
else if (SCM_CHARP (char_pred))
728
{
729
char chr = SCM_CHAR (char_pred);
730
while (cstart < cend)
731
{
732
if (chr != cstr[cstart])
733
break;
734
cstart++;
735
}
736
}
737
else if (SCM_CHARSETP (char_pred))
738
{
739
while (cstart < cend)
740
{
741
if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
742
break;
743
cstart++;
744
}
745
}
746
else
747
{
748
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
749
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
750
751
while (cstart < cend)
752
{
753
SCM res;
754
755
res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
756
if (scm_is_false (res))
757
break;
758
cstr = scm_i_string_chars (s);
759
cstart++;
760
}
761
}
762
return scm_c_substring (s, cstart, cend);
763
}
764
#undef FUNC_NAME
765
766
767
SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0,
768
(SCM s, SCM char_pred, SCM start, SCM end),
769
"Trim @var{s} by skipping over all characters on the rightt\n"
770
"that satisfy the parameter @var{char_pred}:\n"
771
"\n"
772
"@itemize @bullet\n"
773
"@item\n"
774
"if it is the character @var{ch}, characters equal to @var{ch}\n"
775
"are trimmed,\n"
776
"\n"
777
"@item\n"
778
"if it is a procedure @var{pred} characters that satisfy\n"
779
"@var{pred} are trimmed,\n"
780
"\n"
781
"@item\n"
782
"if it is a character sets, all characters in that set are\n"
783
"trimmed.\n"
784
"@end itemize\n"
785
"\n"
786
"If called without a @var{char_pred} argument, all whitespace is\n"
787
"trimmed.")
788
#define FUNC_NAME s_scm_string_trim_right
789
{
790
const char *cstr;
791
size_t cstart, cend;
792
793
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
794
3, start, cstart,
795
4, end, cend);
796
if (SCM_UNBNDP (char_pred))
797
{
798
while (cstart < cend)
799
{
800
if (!isspace((int) (unsigned char) cstr[cend - 1]))
801
break;
802
cend--;
803
}
804
}
805
else if (SCM_CHARP (char_pred))
806
{
807
char chr = SCM_CHAR (char_pred);
808
while (cstart < cend)
809
{
810
if (chr != cstr[cend - 1])
811
break;
812
cend--;
813
}
814
}
815
else if (SCM_CHARSETP (char_pred))
816
{
817
while (cstart < cend)
818
{
819
if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1]))
820
break;
821
cend--;
822
}
823
}
824
else
825
{
826
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
827
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
828
829
while (cstart < cend)
830
{
831
SCM res;
832
833
res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
834
if (scm_is_false (res))
835
break;
836
cstr = scm_i_string_chars (s);
837
cend--;
838
}
839
}
840
return scm_c_substring (s, cstart, cend);
841
}
842
#undef FUNC_NAME
843
844
845
SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0,
846
(SCM s, SCM char_pred, SCM start, SCM end),
847
"Trim @var{s} by skipping over all characters on both sides of\n"
848
"the string that satisfy the parameter @var{char_pred}:\n"
849
"\n"
850
"@itemize @bullet\n"
851
"@item\n"
852
"if it is the character @var{ch}, characters equal to @var{ch}\n"
853
"are trimmed,\n"
854
"\n"
855
"@item\n"
856
"if it is a procedure @var{pred} characters that satisfy\n"
857
"@var{pred} are trimmed,\n"
858
"\n"
859
"@item\n"
860
"if it is a character set, the characters in the set are\n"
861
"trimmed.\n"
862
"@end itemize\n"
863
"\n"
864
"If called without a @var{char_pred} argument, all whitespace is\n"
865
"trimmed.")
866
#define FUNC_NAME s_scm_string_trim_both
867
{
868
const char *cstr;
869
size_t cstart, cend;
870
871
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
872
3, start, cstart,
873
4, end, cend);
874
if (SCM_UNBNDP (char_pred))
875
{
876
while (cstart < cend)
877
{
878
if (!isspace((int) (unsigned char) cstr[cstart]))
879
break;
880
cstart++;
881
}
882
while (cstart < cend)
883
{
884
if (!isspace((int) (unsigned char) cstr[cend - 1]))
885
break;
886
cend--;
887
}
888
}
889
else if (SCM_CHARP (char_pred))
890
{
891
char chr = SCM_CHAR (char_pred);
892
while (cstart < cend)
893
{
894
if (chr != cstr[cstart])
895
break;
896
cstart++;
897
}
898
while (cstart < cend)
899
{
900
if (chr != cstr[cend - 1])
901
break;
902
cend--;
903
}
904
}
905
else if (SCM_CHARSETP (char_pred))
906
{
907
while (cstart < cend)
908
{
909
if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
910
break;
911
cstart++;
912
}
913
while (cstart < cend)
914
{
915
if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1]))
916
break;
917
cend--;
918
}
919
}
920
else
921
{
922
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
923
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
924
925
while (cstart < cend)
926
{
927
SCM res;
928
929
res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
930
if (scm_is_false (res))
931
break;
932
cstr = scm_i_string_chars (s);
933
cstart++;
934
}
935
while (cstart < cend)
936
{
937
SCM res;
938
939
res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
940
if (scm_is_false (res))
941
break;
942
cstr = scm_i_string_chars (s);
943
cend--;
944
}
945
}
946
return scm_c_substring (s, cstart, cend);
947
}
948
#undef FUNC_NAME
949
950
951
SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0,
952
(SCM str, SCM chr, SCM start, SCM end),
953
"Stores @var{chr} in every element of the given @var{str} and\n"
954
"returns an unspecified value.")
955
#define FUNC_NAME s_scm_substring_fill_x
956
{
957
char *cstr;
958
size_t cstart, cend;
959
int c;
960
size_t k;
961
962
/* Older versions of Guile provided the function
963
scm_substring_fill_x with the following order of arguments:
964
965
str, start, end, chr
966
967
We accomodate this here by detecting such a usage and reordering
968
the arguments.
969
*/
970
if (SCM_CHARP (end))
971
{
972
SCM tmp = end;
973
end = start;
974
start = chr;
975
chr = tmp;
976
}
977
978
MY_VALIDATE_SUBSTRING_SPEC (1, str,
979
3, start, cstart,
980
4, end, cend);
981
SCM_VALIDATE_CHAR_COPY (2, chr, c);
982
983
cstr = scm_i_string_writable_chars (str);
984
for (k = cstart; k < cend; k++)
985
cstr[k] = c;
986
scm_i_string_stop_writing ();
987
scm_remember_upto_here_1 (str);
988
989
return SCM_UNSPECIFIED;
990
}
991
#undef FUNC_NAME
992
993
SCM
994
scm_string_fill_x (SCM str, SCM chr)
995
{
996
return scm_substring_fill_x (str, chr, SCM_UNDEFINED, SCM_UNDEFINED);
997
}
998
999
SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0,
1000
(SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2),
1001
"Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1002
"mismatch index, depending upon whether @var{s1} is less than,\n"
1003
"equal to, or greater than @var{s2}. The mismatch index is the\n"
1004
"largest index @var{i} such that for every 0 <= @var{j} <\n"
1005
"@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1006
"@var{i} is the first position that does not match.")
1007
#define FUNC_NAME s_scm_string_compare
1008
{
1009
const unsigned char *cstr1, *cstr2;
1010
size_t cstart1, cend1, cstart2, cend2;
1011
SCM proc;
1012
1013
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
1014
6, start1, cstart1,
1015
7, end1, cend1);
1016
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
1017
8, start2, cstart2,
1018
9, end2, cend2);
1019
SCM_VALIDATE_PROC (3, proc_lt);
1020
SCM_VALIDATE_PROC (4, proc_eq);
1021
SCM_VALIDATE_PROC (5, proc_gt);
1022
1023
while (cstart1 < cend1 && cstart2 < cend2)
1024
{
1025
if (cstr1[cstart1] < cstr2[cstart2])
1026
{
1027
proc = proc_lt;
1028
goto ret;
1029
}
1030
else if (cstr1[cstart1] > cstr2[cstart2])
1031
{
1032
proc = proc_gt;
1033
goto ret;
1034
}
1035
cstart1++;
1036
cstart2++;
1037
}
1038
if (cstart1 < cend1)
1039
proc = proc_gt;
1040
else if (cstart2 < cend2)
1041
proc = proc_lt;
1042
else
1043
proc = proc_eq;
1044
1045
ret:
1046
scm_remember_upto_here_2 (s1, s2);
1047
return scm_call_1 (proc, scm_from_size_t (cstart1));
1048
}
1049
#undef FUNC_NAME
1050
1051
1052
SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0,
1053
(SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2),
1054
"Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1055
"mismatch index, depending upon whether @var{s1} is less than,\n"
1056
"equal to, or greater than @var{s2}. The mismatch index is the\n"
1057
"largest index @var{i} such that for every 0 <= @var{j} <\n"
1058
"@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1059
"@var{i} is the first position that does not match. The\n"
1060
"character comparison is done case-insensitively.")
1061
#define FUNC_NAME s_scm_string_compare_ci
1062
{
1063
const unsigned char *cstr1, *cstr2;
1064
size_t cstart1, cend1, cstart2, cend2;
1065
SCM proc;
1066
1067
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
1068
6, start1, cstart1,
1069
7, end1, cend1);
1070
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
1071
8, start2, cstart2,
1072
9, end2, cend2);
1073
SCM_VALIDATE_PROC (3, proc_lt);
1074
SCM_VALIDATE_PROC (4, proc_eq);
1075
SCM_VALIDATE_PROC (5, proc_gt);
1076
1077
while (cstart1 < cend1 && cstart2 < cend2)
1078
{
1079
if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
1080
{
1081
proc = proc_lt;
1082
goto ret;
1083
}
1084
else if (scm_c_downcase (cstr1[cstart1])
1085
> scm_c_downcase (cstr2[cstart2]))
1086
{
1087
proc = proc_gt;
1088
goto ret;
1089
}
1090
cstart1++;
1091
cstart2++;
1092
}
1093
1094
if (cstart1 < cend1)
1095
proc = proc_gt;
1096
else if (cstart2 < cend2)
1097
proc = proc_lt;
1098
else
1099
proc = proc_eq;
1100
1101
ret:
1102
scm_remember_upto_here (s1, s2);
1103
return scm_call_1 (proc, scm_from_size_t (cstart1));
1104
}
1105
#undef FUNC_NAME
1106
1107
1108
SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0,
1109
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1110
"Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1111
"value otherwise.")
1112
#define FUNC_NAME s_scm_string_eq
1113
{
1114
const char *cstr1, *cstr2;
1115
size_t cstart1, cend1, cstart2, cend2;
1116
1117
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
1118
3, start1, cstart1,
1119
4, end1, cend1);
1120
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
1121
5, start2, cstart2,
1122
6, end2, cend2);
1123
1124
if ((cend1 - cstart1) != (cend2 - cstart2))
1125
goto false;
1126
1127
while (cstart1 < cend1)
1128
{
1129
if (cstr1[cstart1] < cstr2[cstart2])
1130
goto false;
1131
else if (cstr1[cstart1] > cstr2[cstart2])
1132
goto false;
1133
cstart1++;
1134
cstart2++;
1135
}
1136
1137
scm_remember_upto_here_2 (s1, s2);
1138
return scm_from_size_t (cstart1);
1139
1140
false:
1141
scm_remember_upto_here_2 (s1, s2);
1142
return SCM_BOOL_F;
1143
}
1144
#undef FUNC_NAME
1145
1146
1147
SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0,
1148
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1149
"Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1150
"value otherwise.")
1151
#define FUNC_NAME s_scm_string_neq
1152
{
1153
const char *cstr1, *cstr2;
1154
size_t cstart1, cend1, cstart2, cend2;
1155
1156
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
1157
3, start1, cstart1,
1158
4, end1, cend1);
1159
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
1160
5, start2, cstart2,
1161
6, end2, cend2);
1162
1163
while (cstart1 < cend1 && cstart2 < cend2)
1164
{
1165
if (cstr1[cstart1] < cstr2[cstart2])
1166
goto true;
1167
else if (cstr1[cstart1] > cstr2[cstart2])
1168
goto true;
1169
cstart1++;
1170
cstart2++;
1171
}
1172
if (cstart1 < cend1)
1173
goto true;
1174
else if (cstart2 < cend2)
1175
goto true;
1176
else
1177
goto false;
1178
1179
true:
1180
scm_remember_upto_here_2 (s1, s2);
1181
return scm_from_size_t (cstart1);
1182
1183
false:
1184
scm_remember_upto_here_2 (s1, s2);
1185
return SCM_BOOL_F;
1186
}
1187
#undef FUNC_NAME
1188
1189
1190
SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0,
1191
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1192
"Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1193
"true value otherwise.")
1194
#define FUNC_NAME s_scm_string_lt
1195
{
1196
const unsigned char *cstr1, *cstr2;
1197
size_t cstart1, cend1, cstart2, cend2;
1198
1199
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
1200
3, start1, cstart1,
1201
4, end1, cend1);
1202
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
1203
5, start2, cstart2,
1204
6, end2, cend2);
1205
1206
while (cstart1 < cend1 && cstart2 < cend2)
1207
{
1208
if (cstr1[cstart1] < cstr2[cstart2])
1209
goto true;
1210
else if (cstr1[cstart1] > cstr2[cstart2])
1211
goto false;
1212
cstart1++;
1213
cstart2++;
1214
}
1215
if (cstart1 < cend1)
1216
goto false;
1217
else if (cstart2 < cend2)
1218
goto true;
1219
else
1220
goto false;
1221
1222
true:
1223
scm_remember_upto_here_2 (s1, s2);
1224
return scm_from_size_t (cstart1);
1225
1226
false:
1227
scm_remember_upto_here_2 (s1, s2);
1228
return SCM_BOOL_F;
1229
}
1230
#undef FUNC_NAME
1231
1232
1233
SCM_DEFINE (scm_string_gt, "string>", 2, 4, 0,
1234
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1235
"Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1236
"true value otherwise.")
1237
#define FUNC_NAME s_scm_string_gt
1238
{
1239
const unsigned char *cstr1, *cstr2;
1240
size_t cstart1, cend1, cstart2, cend2;
1241
1242
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
1243
3, start1, cstart1,
1244
4, end1, cend1);
1245
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
1246
5, start2, cstart2,
1247
6, end2, cend2);
1248
1249
while (cstart1 < cend1 && cstart2 < cend2)
1250
{
1251
if (cstr1[cstart1] < cstr2[cstart2])
1252
goto false;
1253
else if (cstr1[cstart1] > cstr2[cstart2])
1254
goto true;
1255
cstart1++;
1256
cstart2++;
1257
}
1258
if (cstart1 < cend1)
1259
goto true;
1260
else if (cstart2 < cend2)
1261
goto false;
1262
else
1263
goto false;
1264
1265
true:
1266
scm_remember_upto_here_2 (s1, s2);
1267
return scm_from_size_t (cstart1);
1268
1269
false:
1270
scm_remember_upto_here_2 (s1, s2);
1271
return SCM_BOOL_F;
1272
}
1273
#undef FUNC_NAME
1274
1275
1276
SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0,
1277
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1278
"Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1279
"value otherwise.")
1280
#define FUNC_NAME s_scm_string_le
1281
{
1282
const unsigned char *cstr1, *cstr2;
1283
size_t cstart1, cend1, cstart2, cend2;
1284
1285
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
1286
3, start1, cstart1,
1287
4, end1, cend1);
1288
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
1289
5, start2, cstart2,
1290
6, end2, cend2);
1291
1292
while (cstart1 < cend1 && cstart2 < cend2)
1293
{
1294
if (cstr1[cstart1] < cstr2[cstart2])
1295
goto true;
1296
else if (cstr1[cstart1] > cstr2[cstart2])
1297
goto false;
1298
cstart1++;
1299
cstart2++;
1300
}
1301
if (cstart1 < cend1)
1302
goto false;
1303
else if (cstart2 < cend2)
1304
goto true;
1305
else
1306
goto true;
1307
1308
true:
1309
scm_remember_upto_here_2 (s1, s2);
1310
return scm_from_size_t (cstart1);
1311
1312
false:
1313
scm_remember_upto_here_2 (s1, s2);
1314
return SCM_BOOL_F;
1315
}
1316
#undef FUNC_NAME
1317
1318
1319
SCM_DEFINE (scm_string_ge, "string>=", 2, 4, 0,
1320
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1321
"Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1322
"otherwise.")
1323
#define FUNC_NAME s_scm_string_ge
1324
{
1325
const unsigned char *cstr1, *cstr2;
1326
size_t cstart1, cend1, cstart2, cend2;
1327
1328
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
1329
3, start1, cstart1,
1330
4, end1, cend1);
1331
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
1332
5, start2, cstart2,
1333
6, end2, cend2);
1334
1335
while (cstart1 < cend1 && cstart2 < cend2)
1336
{
1337
if (cstr1[cstart1] < cstr2[cstart2])
1338
goto false;
1339
else if (cstr1[cstart1] > cstr2[cstart2])
1340
goto true;
1341
cstart1++;
1342
cstart2++;
1343
}
1344
if (cstart1 < cend1)
1345
goto true;
1346
else if (cstart2 < cend2)
1347
goto false;
1348
else
1349
goto true;
1350
1351
true:
1352
scm_remember_upto_here_2 (s1, s2);
1353
return scm_from_size_t (cstart1);
1354
1355
false:
1356
scm_remember_upto_here_2 (s1, s2);
1357
return SCM_BOOL_F;
1358
}
1359
#undef FUNC_NAME
1360
1361
1362
SCM_DEFINE (scm_string_ci_eq, "string-ci=", 2, 4, 0,
1363
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1364
"Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1365
"value otherwise. The character comparison is done\n"
1366
"case-insensitively.")
1367
#define FUNC_NAME s_scm_string_ci_eq
1368
{
1369
const char *cstr1, *cstr2;
1370
size_t cstart1, cend1, cstart2, cend2;
1371
1372
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
1373
3, start1, cstart1,
1374
4, end1, cend1);
1375
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
1376
5, start2, cstart2,
1377
6, end2, cend2);
1378
1379
while (cstart1 < cend1 && cstart2 < cend2)
1380
{
1381
if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
1382
goto false;
1383
else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
1384
goto false;
1385
cstart1++;
1386
cstart2++;
1387
}
1388
if (cstart1 < cend1)
1389
goto false;
1390
else if (cstart2 < cend2)
1391
goto false;
1392
else
1393
goto true;
1394
1395
true:
1396
scm_remember_upto_here_2 (s1, s2);
1397
return scm_from_size_t (cstart1);
1398
1399
false:
1400
scm_remember_upto_here_2 (s1, s2);
1401
return SCM_BOOL_F;
1402
}
1403
#undef FUNC_NAME
1404
1405
1406
SCM_DEFINE (scm_string_ci_neq, "string-ci<>", 2, 4, 0,
1407
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1408
"Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1409
"value otherwise. The character comparison is done\n"
1410
"case-insensitively.")
1411
#define FUNC_NAME s_scm_string_ci_neq
1412
{
1413
const char *cstr1, *cstr2;
1414
size_t cstart1, cend1, cstart2, cend2;
1415
1416
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
1417
3, start1, cstart1,
1418
4, end1, cend1);
1419
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
1420
5, start2, cstart2,
1421
6, end2, cend2);
1422
1423
while (cstart1 < cend1 && cstart2 < cend2)
1424
{
1425
if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
1426
goto true;
1427
else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
1428
goto true;
1429
cstart1++;
1430
cstart2++;
1431
}
1432
if (cstart1 < cend1)
1433
goto true;
1434
else if (cstart2 < cend2)
1435
goto true;
1436
else
1437
goto false;
1438
1439
true:
1440
scm_remember_upto_here_2 (s1, s2);
1441
return scm_from_size_t (cstart1);
1442
1443
false:
1444
scm_remember_upto_here_2 (s1, s2);
1445
return SCM_BOOL_F;
1446
}
1447
#undef FUNC_NAME
1448
1449
1450
SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0,
1451
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1452
"Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1453
"true value otherwise. The character comparison is done\n"
1454
"case-insensitively.")
1455
#define FUNC_NAME s_scm_string_ci_lt
1456
{
1457
const unsigned char *cstr1, *cstr2;
1458
size_t cstart1, cend1, cstart2, cend2;
1459
1460
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
1461
3, start1, cstart1,
1462
4, end1, cend1);
1463
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
1464
5, start2, cstart2,
1465
6, end2, cend2);
1466
1467
while (cstart1 < cend1 && cstart2 < cend2)
1468
{
1469
if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
1470
goto true;
1471
else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
1472
goto false;
1473
cstart1++;
1474
cstart2++;
1475
}
1476
if (cstart1 < cend1)
1477
goto false;
1478
else if (cstart2 < cend2)
1479
goto true;
1480
else
1481
goto false;
1482
1483
true:
1484
scm_remember_upto_here_2 (s1, s2);
1485
return scm_from_size_t (cstart1);
1486
1487
false:
1488
scm_remember_upto_here_2 (s1, s2);
1489
return SCM_BOOL_F;
1490
}
1491
#undef FUNC_NAME
1492
1493
1494
SCM_DEFINE (scm_string_ci_gt, "string-ci>", 2, 4, 0,
1495
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1496
"Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1497
"true value otherwise. The character comparison is done\n"
1498
"case-insensitively.")
1499
#define FUNC_NAME s_scm_string_ci_gt
1500
{
1501
const unsigned char *cstr1, *cstr2;
1502
size_t cstart1, cend1, cstart2, cend2;
1503
1504
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
1505
3, start1, cstart1,
1506
4, end1, cend1);
1507
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
1508
5, start2, cstart2,
1509
6, end2, cend2);
1510
1511
while (cstart1 < cend1 && cstart2 < cend2)
1512
{
1513
if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
1514
goto false;
1515
else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
1516
goto true;
1517
cstart1++;
1518
cstart2++;
1519
}
1520
if (cstart1 < cend1)
1521
goto true;
1522
else if (cstart2 < cend2)
1523
goto false;
1524
else
1525
goto false;
1526
1527
true:
1528
scm_remember_upto_here_2 (s1, s2);
1529
return scm_from_size_t (cstart1);
1530
1531
false:
1532
scm_remember_upto_here_2 (s1, s2);
1533
return SCM_BOOL_F;
1534
}
1535
#undef FUNC_NAME
1536
1537
1538
SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0,
1539
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1540
"Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1541
"value otherwise. The character comparison is done\n"
1542
"case-insensitively.")
1543
#define FUNC_NAME s_scm_string_ci_le
1544
{
1545
const unsigned char *cstr1, *cstr2;
1546
size_t cstart1, cend1, cstart2, cend2;
1547
1548
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
1549
3, start1, cstart1,
1550
4, end1, cend1);
1551
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
1552
5, start2, cstart2,
1553
6, end2, cend2);
1554
1555
while (cstart1 < cend1 && cstart2 < cend2)
1556
{
1557
if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
1558
goto true;
1559
else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
1560
goto false;
1561
cstart1++;
1562
cstart2++;
1563
}
1564
if (cstart1 < cend1)
1565
goto false;
1566
else if (cstart2 < cend2)
1567
goto true;
1568
else
1569
goto true;
1570
1571
true:
1572
scm_remember_upto_here_2 (s1, s2);
1573
return scm_from_size_t (cstart1);
1574
1575
false:
1576
scm_remember_upto_here_2 (s1, s2);
1577
return SCM_BOOL_F;
1578
}
1579
#undef FUNC_NAME
1580
1581
1582
SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0,
1583
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1584
"Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1585
"otherwise. The character comparison is done\n"
1586
"case-insensitively.")
1587
#define FUNC_NAME s_scm_string_ci_ge
1588
{
1589
const unsigned char *cstr1, *cstr2;
1590
size_t cstart1, cend1, cstart2, cend2;
1591
1592
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
1593
3, start1, cstart1,
1594
4, end1, cend1);
1595
MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
1596
5, start2, cstart2,
1597
6, end2, cend2);
1598
1599
while (cstart1 < cend1 && cstart2 < cend2)
1600
{
1601
if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
1602
goto false;
1603
else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
1604
goto true;
1605
cstart1++;
1606
cstart2++;
1607
}
1608
if (cstart1 < cend1)
1609
goto true;
1610
else if (cstart2 < cend2)
1611
goto false;
1612
else
1613
goto true;
1614
1615
true:
1616
scm_remember_upto_here_2 (s1, s2);
1617
return scm_from_size_t (cstart1);
1618
1619
false:
1620
scm_remember_upto_here_2 (s1, s2);
1621
return SCM_BOOL_F;
1622
}
1623
#undef FUNC_NAME
1624
1625
SCM_DEFINE (scm_substring_hash, "string-hash", 1, 3, 0,
1626
(SCM s, SCM bound, SCM start, SCM end),
1627
"Compute a hash value for @var{S}. the optional argument "
1628
"@var{bound} is a non-negative exact "
1629
"integer specifying the range of the hash function. "
1630
"A positive value restricts the return value to the "
1631
"range [0,bound).")
1632
#define FUNC_NAME s_scm_substring_hash
1633
{
1634
if (SCM_UNBNDP (bound))
1635
bound = scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM);
1636
if (SCM_UNBNDP (start))
1637
start = SCM_INUM0;
1638
return scm_hash (scm_substring_shared (s, start, end), bound);
1639
}
1640
#undef FUNC_NAME
1641
1642
SCM_DEFINE (scm_substring_hash_ci, "string-hash-ci", 1, 3, 0,
1643
(SCM s, SCM bound, SCM start, SCM end),
1644
"Compute a hash value for @var{S}. the optional argument "
1645
"@var{bound} is a non-negative exact "
1646
"integer specifying the range of the hash function. "
1647
"A positive value restricts the return value to the "
1648
"range [0,bound).")
1649
#define FUNC_NAME s_scm_substring_hash_ci
1650
{
1651
return scm_substring_hash (scm_substring_downcase (s, start, end),
1652
bound,
1653
SCM_UNDEFINED, SCM_UNDEFINED);
1654
}
1655
#undef FUNC_NAME
1656
1657
SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0,
1658
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1659
"Return the length of the longest common prefix of the two\n"
1660
"strings.")
1661
#define FUNC_NAME s_scm_string_prefix_length
1662
{
1663
const char *cstr1, *cstr2;
1664
size_t cstart1, cend1, cstart2, cend2;
1665
size_t len = 0;
1666
1667
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
1668
3, start1, cstart1,
1669
4, end1, cend1);
1670
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
1671
5, start2, cstart2,
1672
6, end2, cend2);
1673
while (cstart1 < cend1 && cstart2 < cend2)
1674
{
1675
if (cstr1[cstart1] != cstr2[cstart2])
1676
goto ret;
1677
len++;
1678
cstart1++;
1679
cstart2++;
1680
}
1681
1682
ret:
1683
scm_remember_upto_here_2 (s1, s2);
1684
return scm_from_size_t (len);
1685
}
1686
#undef FUNC_NAME
1687
1688
1689
SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0,
1690
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1691
"Return the length of the longest common prefix of the two\n"
1692
"strings, ignoring character case.")
1693
#define FUNC_NAME s_scm_string_prefix_length_ci
1694
{
1695
const char *cstr1, *cstr2;
1696
size_t cstart1, cend1, cstart2, cend2;
1697
size_t len = 0;
1698
1699
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
1700
3, start1, cstart1,
1701
4, end1, cend1);
1702
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
1703
5, start2, cstart2,
1704
6, end2, cend2);
1705
while (cstart1 < cend1 && cstart2 < cend2)
1706
{
1707
if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2]))
1708
goto ret;
1709
len++;
1710
cstart1++;
1711
cstart2++;
1712
}
1713
1714
ret:
1715
scm_remember_upto_here_2 (s1, s2);
1716
return scm_from_size_t (len);
1717
}
1718
#undef FUNC_NAME
1719
1720
1721
SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0,
1722
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1723
"Return the length of the longest common suffix of the two\n"
1724
"strings.")
1725
#define FUNC_NAME s_scm_string_suffix_length
1726
{
1727
const char *cstr1, *cstr2;
1728
size_t cstart1, cend1, cstart2, cend2;
1729
size_t len = 0;
1730
1731
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
1732
3, start1, cstart1,
1733
4, end1, cend1);
1734
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
1735
5, start2, cstart2,
1736
6, end2, cend2);
1737
while (cstart1 < cend1 && cstart2 < cend2)
1738
{
1739
cend1--;
1740
cend2--;
1741
if (cstr1[cend1] != cstr2[cend2])
1742
goto ret;
1743
len++;
1744
}
1745
1746
ret:
1747
scm_remember_upto_here_2 (s1, s2);
1748
return scm_from_size_t (len);
1749
}
1750
#undef FUNC_NAME
1751
1752
1753
SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0,
1754
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1755
"Return the length of the longest common suffix of the two\n"
1756
"strings, ignoring character case.")
1757
#define FUNC_NAME s_scm_string_suffix_length_ci
1758
{
1759
const char *cstr1, *cstr2;
1760
size_t cstart1, cend1, cstart2, cend2;
1761
size_t len = 0;
1762
1763
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
1764
3, start1, cstart1,
1765
4, end1, cend1);
1766
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
1767
5, start2, cstart2,
1768
6, end2, cend2);
1769
while (cstart1 < cend1 && cstart2 < cend2)
1770
{
1771
cend1--;
1772
cend2--;
1773
if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2]))
1774
goto ret;
1775
len++;
1776
}
1777
1778
ret:
1779
scm_remember_upto_here_2 (s1, s2);
1780
return scm_from_size_t (len);
1781
}
1782
#undef FUNC_NAME
1783
1784
1785
SCM_DEFINE (scm_string_prefix_p, "string-prefix?", 2, 4, 0,
1786
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1787
"Is @var{s1} a prefix of @var{s2}?")
1788
#define FUNC_NAME s_scm_string_prefix_p
1789
{
1790
const char *cstr1, *cstr2;
1791
size_t cstart1, cend1, cstart2, cend2;
1792
size_t len = 0, len1;
1793
1794
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
1795
3, start1, cstart1,
1796
4, end1, cend1);
1797
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
1798
5, start2, cstart2,
1799
6, end2, cend2);
1800
len1 = cend1 - cstart1;
1801
while (cstart1 < cend1 && cstart2 < cend2)
1802
{
1803
if (cstr1[cstart1] != cstr2[cstart2])
1804
goto ret;
1805
len++;
1806
cstart1++;
1807
cstart2++;
1808
}
1809
1810
ret:
1811
scm_remember_upto_here_2 (s1, s2);
1812
return scm_from_bool (len == len1);
1813
}
1814
#undef FUNC_NAME
1815
1816
1817
SCM_DEFINE (scm_string_prefix_ci_p, "string-prefix-ci?", 2, 4, 0,
1818
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1819
"Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1820
#define FUNC_NAME s_scm_string_prefix_ci_p
1821
{
1822
const char *cstr1, *cstr2;
1823
size_t cstart1, cend1, cstart2, cend2;
1824
size_t len = 0, len1;
1825
1826
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
1827
3, start1, cstart1,
1828
4, end1, cend1);
1829
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
1830
5, start2, cstart2,
1831
6, end2, cend2);
1832
len1 = cend1 - cstart1;
1833
while (cstart1 < cend1 && cstart2 < cend2)
1834
{
1835
if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2]))
1836
goto ret;
1837
len++;
1838
cstart1++;
1839
cstart2++;
1840
}
1841
1842
ret:
1843
scm_remember_upto_here_2 (s1, s2);
1844
return scm_from_bool (len == len1);
1845
}
1846
#undef FUNC_NAME
1847
1848
1849
SCM_DEFINE (scm_string_suffix_p, "string-suffix?", 2, 4, 0,
1850
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1851
"Is @var{s1} a suffix of @var{s2}?")
1852
#define FUNC_NAME s_scm_string_suffix_p
1853
{
1854
const char *cstr1, *cstr2;
1855
size_t cstart1, cend1, cstart2, cend2;
1856
size_t len = 0, len1;
1857
1858
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
1859
3, start1, cstart1,
1860
4, end1, cend1);
1861
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
1862
5, start2, cstart2,
1863
6, end2, cend2);
1864
len1 = cend1 - cstart1;
1865
while (cstart1 < cend1 && cstart2 < cend2)
1866
{
1867
cend1--;
1868
cend2--;
1869
if (cstr1[cend1] != cstr2[cend2])
1870
goto ret;
1871
len++;
1872
}
1873
1874
ret:
1875
scm_remember_upto_here_2 (s1, s2);
1876
return scm_from_bool (len == len1);
1877
}
1878
#undef FUNC_NAME
1879
1880
1881
SCM_DEFINE (scm_string_suffix_ci_p, "string-suffix-ci?", 2, 4, 0,
1882
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1883
"Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1884
#define FUNC_NAME s_scm_string_suffix_ci_p
1885
{
1886
const char *cstr1, *cstr2;
1887
size_t cstart1, cend1, cstart2, cend2;
1888
size_t len = 0, len1;
1889
1890
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
1891
3, start1, cstart1,
1892
4, end1, cend1);
1893
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
1894
5, start2, cstart2,
1895
6, end2, cend2);
1896
len1 = cend1 - cstart1;
1897
while (cstart1 < cend1 && cstart2 < cend2)
1898
{
1899
cend1--;
1900
cend2--;
1901
if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2]))
1902
goto ret;
1903
len++;
1904
}
1905
1906
ret:
1907
scm_remember_upto_here_2 (s1, s2);
1908
return scm_from_bool (len == len1);
1909
}
1910
#undef FUNC_NAME
1911
1912
1913
SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0,
1914
(SCM s, SCM char_pred, SCM start, SCM end),
1915
"Search through the string @var{s} from left to right, returning\n"
1916
"the index of the first occurence of a character which\n"
1917
"\n"
1918
"@itemize @bullet\n"
1919
"@item\n"
1920
"equals @var{char_pred}, if it is character,\n"
1921
"\n"
1922
"@item\n"
1923
"satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1924
"\n"
1925
"@item\n"
1926
"is in the set @var{char_pred}, if it is a character set.\n"
1927
"@end itemize")
1928
#define FUNC_NAME s_scm_string_index
1929
{
1930
const char *cstr;
1931
size_t cstart, cend;
1932
1933
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
1934
3, start, cstart,
1935
4, end, cend);
1936
if (SCM_CHARP (char_pred))
1937
{
1938
char cchr = SCM_CHAR (char_pred);
1939
while (cstart < cend)
1940
{
1941
if (cchr == cstr[cstart])
1942
goto found;
1943
cstart++;
1944
}
1945
}
1946
else if (SCM_CHARSETP (char_pred))
1947
{
1948
while (cstart < cend)
1949
{
1950
if (SCM_CHARSET_GET (char_pred, cstr[cstart]))
1951
goto found;
1952
cstart++;
1953
}
1954
}
1955
else
1956
{
1957
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
1958
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
1959
1960
while (cstart < cend)
1961
{
1962
SCM res;
1963
res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
1964
if (scm_is_true (res))
1965
goto found;
1966
cstr = scm_i_string_chars (s);
1967
cstart++;
1968
}
1969
}
1970
1971
scm_remember_upto_here_1 (s);
1972
return SCM_BOOL_F;
1973
1974
found:
1975
scm_remember_upto_here_1 (s);
1976
return scm_from_size_t (cstart);
1977
}
1978
#undef FUNC_NAME
1979
1980
SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0,
1981
(SCM s, SCM char_pred, SCM start, SCM end),
1982
"Search through the string @var{s} from right to left, returning\n"
1983
"the index of the last occurence of a character which\n"
1984
"\n"
1985
"@itemize @bullet\n"
1986
"@item\n"
1987
"equals @var{char_pred}, if it is character,\n"
1988
"\n"
1989
"@item\n"
1990
"satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1991
"\n"
1992
"@item\n"
1993
"is in the set if @var{char_pred} is a character set.\n"
1994
"@end itemize")
1995
#define FUNC_NAME s_scm_string_index_right
1996
{
1997
const char *cstr;
1998
size_t cstart, cend;
1999
2000
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
2001
3, start, cstart,
2002
4, end, cend);
2003
if (SCM_CHARP (char_pred))
2004
{
2005
char cchr = SCM_CHAR (char_pred);
2006
while (cstart < cend)
2007
{
2008
cend--;
2009
if (cchr == cstr[cend])
2010
goto found;
2011
}
2012
}
2013
else if (SCM_CHARSETP (char_pred))
2014
{
2015
while (cstart < cend)
2016
{
2017
cend--;
2018
if (SCM_CHARSET_GET (char_pred, cstr[cend]))
2019
goto found;
2020
}
2021
}
2022
else
2023
{
2024
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
2025
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
2026
2027
while (cstart < cend)
2028
{
2029
SCM res;
2030
cend--;
2031
res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend]));
2032
if (scm_is_true (res))
2033
goto found;
2034
cstr = scm_i_string_chars (s);
2035
}
2036
}
2037
2038
scm_remember_upto_here_1 (s);
2039
return SCM_BOOL_F;
2040
2041
found:
2042
scm_remember_upto_here_1 (s);
2043
return scm_from_size_t (cend);
2044
}
2045
#undef FUNC_NAME
2046
2047
SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0,
2048
(SCM s, SCM char_pred, SCM start, SCM end),
2049
"Search through the string @var{s} from right to left, returning\n"
2050
"the index of the last occurence of a character which\n"
2051
"\n"
2052
"@itemize @bullet\n"
2053
"@item\n"
2054
"equals @var{char_pred}, if it is character,\n"
2055
"\n"
2056
"@item\n"
2057
"satisifies the predicate @var{char_pred}, if it is a procedure,\n"
2058
"\n"
2059
"@item\n"
2060
"is in the set if @var{char_pred} is a character set.\n"
2061
"@end itemize")
2062
#define FUNC_NAME s_scm_string_rindex
2063
{
2064
return scm_string_index_right (s, char_pred, start, end);
2065
}
2066
#undef FUNC_NAME
2067
2068
SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0,
2069
(SCM s, SCM char_pred, SCM start, SCM end),
2070
"Search through the string @var{s} from left to right, returning\n"
2071
"the index of the first occurence of a character which\n"
2072
"\n"
2073
"@itemize @bullet\n"
2074
"@item\n"
2075
"does not equal @var{char_pred}, if it is character,\n"
2076
"\n"
2077
"@item\n"
2078
"does not satisify the predicate @var{char_pred}, if it is a\n"
2079
"procedure,\n"
2080
"\n"
2081
"@item\n"
2082
"is not in the set if @var{char_pred} is a character set.\n"
2083
"@end itemize")
2084
#define FUNC_NAME s_scm_string_skip
2085
{
2086
const char *cstr;
2087
size_t cstart, cend;
2088
2089
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
2090
3, start, cstart,
2091
4, end, cend);
2092
if (SCM_CHARP (char_pred))
2093
{
2094
char cchr = SCM_CHAR (char_pred);
2095
while (cstart < cend)
2096
{
2097
if (cchr != cstr[cstart])
2098
goto found;
2099
cstart++;
2100
}
2101
}
2102
else if (SCM_CHARSETP (char_pred))
2103
{
2104
while (cstart < cend)
2105
{
2106
if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
2107
goto found;
2108
cstart++;
2109
}
2110
}
2111
else
2112
{
2113
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
2114
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
2115
2116
while (cstart < cend)
2117
{
2118
SCM res;
2119
res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
2120
if (scm_is_false (res))
2121
goto found;
2122
cstr = scm_i_string_chars (s);
2123
cstart++;
2124
}
2125
}
2126
2127
scm_remember_upto_here_1 (s);
2128
return SCM_BOOL_F;
2129
2130
found:
2131
scm_remember_upto_here_1 (s);
2132
return scm_from_size_t (cstart);
2133
}
2134
#undef FUNC_NAME
2135
2136
2137
SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0,
2138
(SCM s, SCM char_pred, SCM start, SCM end),
2139
"Search through the string @var{s} from right to left, returning\n"
2140
"the index of the last occurence of a character which\n"
2141
"\n"
2142
"@itemize @bullet\n"
2143
"@item\n"
2144
"does not equal @var{char_pred}, if it is character,\n"
2145
"\n"
2146
"@item\n"
2147
"does not satisfy the predicate @var{char_pred}, if it is a\n"
2148
"procedure,\n"
2149
"\n"
2150
"@item\n"
2151
"is not in the set if @var{char_pred} is a character set.\n"
2152
"@end itemize")
2153
#define FUNC_NAME s_scm_string_skip_right
2154
{
2155
const char *cstr;
2156
size_t cstart, cend;
2157
2158
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
2159
3, start, cstart,
2160
4, end, cend);
2161
if (SCM_CHARP (char_pred))
2162
{
2163
char cchr = SCM_CHAR (char_pred);
2164
while (cstart < cend)
2165
{
2166
cend--;
2167
if (cchr != cstr[cend])
2168
goto found;
2169
}
2170
}
2171
else if (SCM_CHARSETP (char_pred))
2172
{
2173
while (cstart < cend)
2174
{
2175
cend--;
2176
if (!SCM_CHARSET_GET (char_pred, cstr[cend]))
2177
goto found;
2178
}
2179
}
2180
else
2181
{
2182
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
2183
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
2184
2185
while (cstart < cend)
2186
{
2187
SCM res;
2188
cend--;
2189
res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend]));
2190
if (scm_is_false (res))
2191
goto found;
2192
cstr = scm_i_string_chars (s);
2193
}
2194
}
2195
2196
scm_remember_upto_here_1 (s);
2197
return SCM_BOOL_F;
2198
2199
found:
2200
scm_remember_upto_here_1 (s);
2201
return scm_from_size_t (cend);
2202
2203
}
2204
#undef FUNC_NAME
2205
2206
2207
SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0,
2208
(SCM s, SCM char_pred, SCM start, SCM end),
2209
"Return the count of the number of characters in the string\n"
2210
"@var{s} which\n"
2211
"\n"
2212
"@itemize @bullet\n"
2213
"@item\n"
2214
"equals @var{char_pred}, if it is character,\n"
2215
"\n"
2216
"@item\n"
2217
"satisifies the predicate @var{char_pred}, if it is a procedure.\n"
2218
"\n"
2219
"@item\n"
2220
"is in the set @var{char_pred}, if it is a character set.\n"
2221
"@end itemize")
2222
#define FUNC_NAME s_scm_string_count
2223
{
2224
const char *cstr;
2225
size_t cstart, cend;
2226
size_t count = 0;
2227
2228
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
2229
3, start, cstart,
2230
4, end, cend);
2231
if (SCM_CHARP (char_pred))
2232
{
2233
char cchr = SCM_CHAR (char_pred);
2234
while (cstart < cend)
2235
{
2236
if (cchr == cstr[cstart])
2237
count++;
2238
cstart++;
2239
}
2240
}
2241
else if (SCM_CHARSETP (char_pred))
2242
{
2243
while (cstart < cend)
2244
{
2245
if (SCM_CHARSET_GET (char_pred, cstr[cstart]))
2246
count++;
2247
cstart++;
2248
}
2249
}
2250
else
2251
{
2252
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
2253
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
2254
2255
while (cstart < cend)
2256
{
2257
SCM res;
2258
res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
2259
if (scm_is_true (res))
2260
count++;
2261
cstr = scm_i_string_chars (s);
2262
cstart++;
2263
}
2264
}
2265
2266
scm_remember_upto_here_1 (s);
2267
return scm_from_size_t (count);
2268
}
2269
#undef FUNC_NAME
2270
2271
2272
/* FIXME::martin: This should definitely get implemented more
2273
efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2274
implementation. */
2275
SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0,
2276
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
2277
"Does string @var{s1} contain string @var{s2}? Return the index\n"
2278
"in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2279
"The optional start/end indices restrict the operation to the\n"
2280
"indicated substrings.")
2281
#define FUNC_NAME s_scm_string_contains
2282
{
2283
const char *cs1, * cs2;
2284
size_t cstart1, cend1, cstart2, cend2;
2285
size_t len2, i, j;
2286
2287
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1,
2288
3, start1, cstart1,
2289
4, end1, cend1);
2290
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2,
2291
5, start2, cstart2,
2292
6, end2, cend2);
2293
len2 = cend2 - cstart2;
2294
if (cend1 - cstart1 >= len2)
2295
while (cstart1 <= cend1 - len2)
2296
{
2297
i = cstart1;
2298
j = cstart2;
2299
while (i < cend1 && j < cend2 && cs1[i] == cs2[j])
2300
{
2301
i++;
2302
j++;
2303
}
2304
if (j == cend2)
2305
{
2306
scm_remember_upto_here_2 (s1, s2);
2307
return scm_from_size_t (cstart1);
2308
}
2309
cstart1++;
2310
}
2311
2312
scm_remember_upto_here_2 (s1, s2);
2313
return SCM_BOOL_F;
2314
}
2315
#undef FUNC_NAME
2316
2317
2318
/* FIXME::martin: This should definitely get implemented more
2319
efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2320
implementation. */
2321
SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0,
2322
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
2323
"Does string @var{s1} contain string @var{s2}? Return the index\n"
2324
"in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2325
"The optional start/end indices restrict the operation to the\n"
2326
"indicated substrings. Character comparison is done\n"
2327
"case-insensitively.")
2328
#define FUNC_NAME s_scm_string_contains_ci
2329
{
2330
const char *cs1, * cs2;
2331
size_t cstart1, cend1, cstart2, cend2;
2332
size_t len2, i, j;
2333
2334
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1,
2335
3, start1, cstart1,
2336
4, end1, cend1);
2337
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2,
2338
5, start2, cstart2,
2339
6, end2, cend2);
2340
len2 = cend2 - cstart2;
2341
if (cend1 - cstart1 >= len2)
2342
while (cstart1 <= cend1 - len2)
2343
{
2344
i = cstart1;
2345
j = cstart2;
2346
while (i < cend1 && j < cend2 &&
2347
scm_c_downcase (cs1[i]) == scm_c_downcase (cs2[j]))
2348
{
2349
i++;
2350
j++;
2351
}
2352
if (j == cend2)
2353
{
2354
scm_remember_upto_here_2 (s1, s2);
2355
return scm_from_size_t (cstart1);
2356
}
2357
cstart1++;
2358
}
2359
2360
scm_remember_upto_here_2 (s1, s2);
2361
return SCM_BOOL_F;
2362
}
2363
#undef FUNC_NAME
2364
2365
2366
/* Helper function for the string uppercase conversion functions.
2367
* No argument checking is performed. */
2368
static SCM
2369
string_upcase_x (SCM v, size_t start, size_t end)
2370
{
2371
size_t k;
2372
char *dst;
2373
2374
dst = scm_i_string_writable_chars (v);
2375
for (k = start; k < end; ++k)
2376
dst[k] = scm_c_upcase (dst[k]);
2377
scm_i_string_stop_writing ();
2378
scm_remember_upto_here_1 (v);
2379
2380
return v;
2381
}
2382
2383
SCM_DEFINE (scm_substring_upcase_x, "string-upcase!", 1, 2, 0,
2384
(SCM str, SCM start, SCM end),
2385
"Destructively upcase every character in @code{str}.\n"
2386
"\n"
2387
"@lisp\n"
2388
"(string-upcase! y)\n"
2389
"@result{} \"ARRDEFG\"\n"
2390
"y\n"
2391
"@result{} \"ARRDEFG\"\n"
2392
"@end lisp")
2393
#define FUNC_NAME s_scm_substring_upcase_x
2394
{
2395
const char *cstr;
2396
size_t cstart, cend;
2397
2398
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
2399
2, start, cstart,
2400
3, end, cend);
2401
return string_upcase_x (str, cstart, cend);
2402
}
2403
#undef FUNC_NAME
2404
2405
SCM
2406
scm_string_upcase_x (SCM str)
2407
{
2408
return scm_substring_upcase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
2409
}
2410
2411
SCM_DEFINE (scm_substring_upcase, "string-upcase", 1, 2, 0,
2412
(SCM str, SCM start, SCM end),
2413
"Upcase every character in @code{str}.")
2414
#define FUNC_NAME s_scm_substring_upcase
2415
{
2416
const char *cstr;
2417
size_t cstart, cend;
2418
2419
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
2420
2, start, cstart,
2421
3, end, cend);
2422
return string_upcase_x (scm_string_copy (str), cstart, cend);
2423
}
2424
#undef FUNC_NAME
2425
2426
SCM
2427
scm_string_upcase (SCM str)
2428
{
2429
return scm_substring_upcase (str, SCM_UNDEFINED, SCM_UNDEFINED);
2430
}
2431
2432
/* Helper function for the string lowercase conversion functions.
2433
* No argument checking is performed. */
2434
static SCM
2435
string_downcase_x (SCM v, size_t start, size_t end)
2436
{
2437
size_t k;
2438
char *dst;
2439
2440
dst = scm_i_string_writable_chars (v);
2441
for (k = start; k < end; ++k)
2442
dst[k] = scm_c_downcase (dst[k]);
2443
scm_i_string_stop_writing ();
2444
scm_remember_upto_here_1 (v);
2445
2446
return v;
2447
}
2448
2449
SCM_DEFINE (scm_substring_downcase_x, "string-downcase!", 1, 2, 0,
2450
(SCM str, SCM start, SCM end),
2451
"Destructively downcase every character in @var{str}.\n"
2452
"\n"
2453
"@lisp\n"
2454
"y\n"
2455
"@result{} \"ARRDEFG\"\n"
2456
"(string-downcase! y)\n"
2457
"@result{} \"arrdefg\"\n"
2458
"y\n"
2459
"@result{} \"arrdefg\"\n"
2460
"@end lisp")
2461
#define FUNC_NAME s_scm_substring_downcase_x
2462
{
2463
const char *cstr;
2464
size_t cstart, cend;
2465
2466
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
2467
2, start, cstart,
2468
3, end, cend);
2469
return string_downcase_x (str, cstart, cend);
2470
}
2471
#undef FUNC_NAME
2472
2473
SCM
2474
scm_string_downcase_x (SCM str)
2475
{
2476
return scm_substring_downcase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
2477
}
2478
2479
SCM_DEFINE (scm_substring_downcase, "string-downcase", 1, 2, 0,
2480
(SCM str, SCM start, SCM end),
2481
"Downcase every character in @var{str}.")
2482
#define FUNC_NAME s_scm_substring_downcase
2483
{
2484
const char *cstr;
2485
size_t cstart, cend;
2486
2487
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
2488
2, start, cstart,
2489
3, end, cend);
2490
return string_downcase_x (scm_string_copy (str), cstart, cend);
2491
}
2492
#undef FUNC_NAME
2493
2494
SCM
2495
scm_string_downcase (SCM str)
2496
{
2497
return scm_substring_downcase (str, SCM_UNDEFINED, SCM_UNDEFINED);
2498
}
2499
2500
/* Helper function for the string capitalization functions.
2501
* No argument checking is performed. */
2502
static SCM
2503
string_titlecase_x (SCM str, size_t start, size_t end)
2504
{
2505
unsigned char *sz;
2506
size_t i;
2507
int in_word = 0;
2508
2509
sz = (unsigned char *) scm_i_string_writable_chars (str);
2510
for(i = start; i < end; i++)
2511
{
2512
if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz[i]))))
2513
{
2514
if (!in_word)
2515
{
2516
sz[i] = scm_c_upcase(sz[i]);
2517
in_word = 1;
2518
}
2519
else
2520
{
2521
sz[i] = scm_c_downcase(sz[i]);
2522
}
2523
}
2524
else
2525
in_word = 0;
2526
}
2527
scm_i_string_stop_writing ();
2528
scm_remember_upto_here_1 (str);
2529
2530
return str;
2531
}
2532
2533
2534
SCM_DEFINE (scm_string_titlecase_x, "string-titlecase!", 1, 2, 0,
2535
(SCM str, SCM start, SCM end),
2536
"Destructively titlecase every first character in a word in\n"
2537
"@var{str}.")
2538
#define FUNC_NAME s_scm_string_titlecase_x
2539
{
2540
const char *cstr;
2541
size_t cstart, cend;
2542
2543
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
2544
2, start, cstart,
2545
3, end, cend);
2546
return string_titlecase_x (str, cstart, cend);
2547
}
2548
#undef FUNC_NAME
2549
2550
2551
SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0,
2552
(SCM str, SCM start, SCM end),
2553
"Titlecase every first character in a word in @var{str}.")
2554
#define FUNC_NAME s_scm_string_titlecase
2555
{
2556
const char *cstr;
2557
size_t cstart, cend;
2558
2559
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
2560
2, start, cstart,
2561
3, end, cend);
2562
return string_titlecase_x (scm_string_copy (str), cstart, cend);
2563
}
2564
#undef FUNC_NAME
2565
2566
SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0,
2567
(SCM str),
2568
"Upcase the first character of every word in @var{str}\n"
2569
"destructively and return @var{str}.\n"
2570
"\n"
2571
"@lisp\n"
2572
"y @result{} \"hello world\"\n"
2573
"(string-capitalize! y) @result{} \"Hello World\"\n"
2574
"y @result{} \"Hello World\"\n"
2575
"@end lisp")
2576
#define FUNC_NAME s_scm_string_capitalize_x
2577
{
2578
return scm_string_titlecase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
2579
}
2580
#undef FUNC_NAME
2581
2582
2583
SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0,
2584
(SCM str),
2585
"Return a freshly allocated string with the characters in\n"
2586
"@var{str}, where the first character of every word is\n"
2587
"capitalized.")
2588
#define FUNC_NAME s_scm_string_capitalize
2589
{
2590
return scm_string_capitalize_x (scm_string_copy (str));
2591
}
2592
#undef FUNC_NAME
2593
2594
2595
/* Reverse the portion of @var{str} between str[cstart] (including)
2596
and str[cend] excluding. */
2597
static void
2598
string_reverse_x (char * str, size_t cstart, size_t cend)
2599
{
2600
char tmp;
2601
2602
if (cend > 0)
2603
{
2604
cend--;
2605
while (cstart < cend)
2606
{
2607
tmp = str[cstart];
2608
str[cstart] = str[cend];
2609
str[cend] = tmp;
2610
cstart++;
2611
cend--;
2612
}
2613
}
2614
}
2615
2616
2617
SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0,
2618
(SCM str, SCM start, SCM end),
2619
"Reverse the string @var{str}. The optional arguments\n"
2620
"@var{start} and @var{end} delimit the region of @var{str} to\n"
2621
"operate on.")
2622
#define FUNC_NAME s_scm_string_reverse
2623
{
2624
const char *cstr;
2625
char *ctarget;
2626
size_t cstart, cend;
2627
SCM result;
2628
2629
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
2630
2, start, cstart,
2631
3, end, cend);
2632
result = scm_string_copy (str);
2633
ctarget = scm_i_string_writable_chars (result);
2634
string_reverse_x (ctarget, cstart, cend);
2635
scm_i_string_stop_writing ();
2636
scm_remember_upto_here_1 (str);
2637
return result;
2638
}
2639
#undef FUNC_NAME
2640
2641
2642
SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0,
2643
(SCM str, SCM start, SCM end),
2644
"Reverse the string @var{str} in-place. The optional arguments\n"
2645
"@var{start} and @var{end} delimit the region of @var{str} to\n"
2646
"operate on. The return value is unspecified.")
2647
#define FUNC_NAME s_scm_string_reverse_x
2648
{
2649
char *cstr;
2650
size_t cstart, cend;
2651
2652
MY_VALIDATE_SUBSTRING_SPEC (1, str,
2653
2, start, cstart,
2654
3, end, cend);
2655
2656
cstr = scm_i_string_writable_chars (str);
2657
string_reverse_x (cstr, cstart, cend);
2658
scm_i_string_stop_writing ();
2659
scm_remember_upto_here_1 (str);
2660
return SCM_UNSPECIFIED;
2661
}
2662
#undef FUNC_NAME
2663
2664
2665
SCM_DEFINE (scm_string_append_shared, "string-append/shared", 0, 0, 1,
2666
(SCM rest),
2667
"Like @code{string-append}, but the result may share memory\n"
2668
"with the argument strings.")
2669
#define FUNC_NAME s_scm_string_append_shared
2670
{
2671
/* If "rest" contains just one non-empty string, return that.
2672
If it's entirely empty strings, then return scm_nullstr.
2673
Otherwise use scm_string_concatenate. */
2674
2675
SCM ret = scm_nullstr;
2676
int seen_nonempty = 0;
2677
SCM l, s;
2678
2679
SCM_VALIDATE_REST_ARGUMENT (rest);
2680
2681
for (l = rest; scm_is_pair (l); l = SCM_CDR (l))
2682
{
2683
s = SCM_CAR (l);
2684
if (scm_c_string_length (s) != 0)
2685
{
2686
if (seen_nonempty)
2687
/* two or more non-empty strings, need full concat */
2688
return scm_string_append (rest);
2689
2690
seen_nonempty = 1;
2691
ret = s;
2692
}
2693
}
2694
return ret;
2695
}
2696
#undef FUNC_NAME
2697
2698
2699
SCM_DEFINE (scm_string_concatenate, "string-concatenate", 1, 0, 0,
2700
(SCM ls),
2701
"Append the elements of @var{ls} (which must be strings)\n"
2702
"together into a single string. Guaranteed to return a freshly\n"
2703
"allocated string.")
2704
#define FUNC_NAME s_scm_string_concatenate
2705
{
2706
SCM_VALIDATE_LIST (SCM_ARG1, ls);
2707
return scm_string_append (ls);
2708
}
2709
#undef FUNC_NAME
2710
2711
2712
SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, 0,
2713
(SCM ls, SCM final_string, SCM end),
2714
"Without optional arguments, this procedure is equivalent to\n"
2715
"\n"
2716
"@smalllisp\n"
2717
"(string-concatenate (reverse ls))\n"
2718
"@end smalllisp\n"
2719
"\n"
2720
"If the optional argument @var{final_string} is specified, it is\n"
2721
"consed onto the beginning to @var{ls} before performing the\n"
2722
"list-reverse and string-concatenate operations. If @var{end}\n"
2723
"is given, only the characters of @var{final_string} up to index\n"
2724
"@var{end} are used.\n"
2725
"\n"
2726
"Guaranteed to return a freshly allocated string.")
2727
#define FUNC_NAME s_scm_string_concatenate_reverse
2728
{
2729
if (!SCM_UNBNDP (end))
2730
final_string = scm_substring (final_string, SCM_INUM0, end);
2731
2732
if (!SCM_UNBNDP (final_string))
2733
ls = scm_cons (final_string, ls);
2734
2735
return scm_string_concatenate (scm_reverse (ls));
2736
}
2737
#undef FUNC_NAME
2738
2739
2740
SCM_DEFINE (scm_string_concatenate_shared, "string-concatenate/shared", 1, 0, 0,
2741
(SCM ls),
2742
"Like @code{string-concatenate}, but the result may share memory\n"
2743
"with the strings in the list @var{ls}.")
2744
#define FUNC_NAME s_scm_string_concatenate_shared
2745
{
2746
SCM_VALIDATE_LIST (SCM_ARG1, ls);
2747
return scm_string_append_shared (ls);
2748
}
2749
#undef FUNC_NAME
2750
2751
2752
SCM_DEFINE (scm_string_concatenate_reverse_shared, "string-concatenate-reverse/shared", 1, 2, 0,
2753
(SCM ls, SCM final_string, SCM end),
2754
"Like @code{string-concatenate-reverse}, but the result may\n"
2755
"share memory with the the strings in the @var{ls} arguments.")
2756
#define FUNC_NAME s_scm_string_concatenate_reverse_shared
2757
{
2758
/* Just call the non-sharing version. */
2759
return scm_string_concatenate_reverse (ls, final_string, end);
2760
}
2761
#undef FUNC_NAME
2762
2763
2764
SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0,
2765
(SCM proc, SCM s, SCM start, SCM end),
2766
"@var{proc} is a char->char procedure, it is mapped over\n"
2767
"@var{s}. The order in which the procedure is applied to the\n"
2768
"string elements is not specified.")
2769
#define FUNC_NAME s_scm_string_map
2770
{
2771
char *p;
2772
size_t cstart, cend;
2773
SCM result;
2774
scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
2775
2776
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
2777
MY_VALIDATE_SUBSTRING_SPEC (2, s,
2778
3, start, cstart,
2779
4, end, cend);
2780
result = scm_i_make_string (cend - cstart, &p);
2781
while (cstart < cend)
2782
{
2783
SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart));
2784
if (!SCM_CHARP (ch))
2785
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
2786
cstart++;
2787
*p++ = SCM_CHAR (ch);
2788
}
2789
return result;
2790
}
2791
#undef FUNC_NAME
2792
2793
2794
SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0,
2795
(SCM proc, SCM s, SCM start, SCM end),
2796
"@var{proc} is a char->char procedure, it is mapped over\n"
2797
"@var{s}. The order in which the procedure is applied to the\n"
2798
"string elements is not specified. The string @var{s} is\n"
2799
"modified in-place, the return value is not specified.")
2800
#define FUNC_NAME s_scm_string_map_x
2801
{
2802
size_t cstart, cend;
2803
scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
2804
2805
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
2806
MY_VALIDATE_SUBSTRING_SPEC (2, s,
2807
3, start, cstart,
2808
4, end, cend);
2809
while (cstart < cend)
2810
{
2811
SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart));
2812
if (!SCM_CHARP (ch))
2813
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
2814
scm_c_string_set_x (s, cstart, ch);
2815
cstart++;
2816
}
2817
return SCM_UNSPECIFIED;
2818
}
2819
#undef FUNC_NAME
2820
2821
2822
SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0,
2823
(SCM kons, SCM knil, SCM s, SCM start, SCM end),
2824
"Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2825
"as the terminating element, from left to right. @var{kons}\n"
2826
"must expect two arguments: The actual character and the last\n"
2827
"result of @var{kons}' application.")
2828
#define FUNC_NAME s_scm_string_fold
2829
{
2830
const char *cstr;
2831
size_t cstart, cend;
2832
SCM result;
2833
2834
SCM_VALIDATE_PROC (1, kons);
2835
MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
2836
4, start, cstart,
2837
5, end, cend);
2838
result = knil;
2839
while (cstart < cend)
2840
{
2841
unsigned int c = (unsigned char) cstr[cstart];
2842
result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result);
2843
cstr = scm_i_string_chars (s);
2844
cstart++;
2845
}
2846
2847
scm_remember_upto_here_1 (s);
2848
return result;
2849
}
2850
#undef FUNC_NAME
2851
2852
2853
SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0,
2854
(SCM kons, SCM knil, SCM s, SCM start, SCM end),
2855
"Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2856
"as the terminating element, from right to left. @var{kons}\n"
2857
"must expect two arguments: The actual character and the last\n"
2858
"result of @var{kons}' application.")
2859
#define FUNC_NAME s_scm_string_fold_right
2860
{
2861
const char *cstr;
2862
size_t cstart, cend;
2863
SCM result;
2864
2865
SCM_VALIDATE_PROC (1, kons);
2866
MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
2867
4, start, cstart,
2868
5, end, cend);
2869
result = knil;
2870
while (cstart < cend)
2871
{
2872
unsigned int c = (unsigned char) cstr[cend - 1];
2873
result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result);
2874
cstr = scm_i_string_chars (s);
2875
cend--;
2876
}
2877
2878
scm_remember_upto_here_1 (s);
2879
return result;
2880
}
2881
#undef FUNC_NAME
2882
2883
2884
SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0,
2885
(SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final),
2886
"@itemize @bullet\n"
2887
"@item @var{g} is used to generate a series of @emph{seed}\n"
2888
"values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2889
"@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2890
"@dots{}\n"
2891
"@item @var{p} tells us when to stop -- when it returns true\n"
2892
"when applied to one of these seed values.\n"
2893
"@item @var{f} maps each seed value to the corresponding\n"
2894
"character in the result string. These chars are assembled\n"
2895
"into the string in a left-to-right order.\n"
2896
"@item @var{base} is the optional initial/leftmost portion\n"
2897
"of the constructed string; it default to the empty\n"
2898
"string.\n"
2899
"@item @var{make_final} is applied to the terminal seed\n"
2900
"value (on which @var{p} returns true) to produce\n"
2901
"the final/rightmost portion of the constructed string.\n"
2902
"It defaults to @code{(lambda (x) "")}.\n"
2903
"@end itemize")
2904
#define FUNC_NAME s_scm_string_unfold
2905
{
2906
SCM res, ans;
2907
2908
SCM_VALIDATE_PROC (1, p);
2909
SCM_VALIDATE_PROC (2, f);
2910
SCM_VALIDATE_PROC (3, g);
2911
if (!SCM_UNBNDP (base))
2912
{
2913
SCM_VALIDATE_STRING (5, base);
2914
ans = base;
2915
}
2916
else
2917
ans = scm_i_make_string (0, NULL);
2918
if (!SCM_UNBNDP (make_final))
2919
SCM_VALIDATE_PROC (6, make_final);
2920
2921
res = scm_call_1 (p, seed);
2922
while (scm_is_false (res))
2923
{
2924
SCM str;
2925
char *ptr;
2926
SCM ch = scm_call_1 (f, seed);
2927
if (!SCM_CHARP (ch))
2928
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
2929
str = scm_i_make_string (1, &ptr);
2930
*ptr = SCM_CHAR (ch);
2931
2932
ans = scm_string_append (scm_list_2 (ans, str));
2933
seed = scm_call_1 (g, seed);
2934
res = scm_call_1 (p, seed);
2935
}
2936
if (!SCM_UNBNDP (make_final))
2937
{
2938
res = scm_call_1 (make_final, seed);
2939
return scm_string_append (scm_list_2 (ans, res));
2940
}
2941
else
2942
return ans;
2943
}
2944
#undef FUNC_NAME
2945
2946
2947
SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0,
2948
(SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final),
2949
"@itemize @bullet\n"
2950
"@item @var{g} is used to generate a series of @emph{seed}\n"
2951
"values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2952
"@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2953
"@dots{}\n"
2954
"@item @var{p} tells us when to stop -- when it returns true\n"
2955
"when applied to one of these seed values.\n"
2956
"@item @var{f} maps each seed value to the corresponding\n"
2957
"character in the result string. These chars are assembled\n"
2958
"into the string in a right-to-left order.\n"
2959
"@item @var{base} is the optional initial/rightmost portion\n"
2960
"of the constructed string; it default to the empty\n"
2961
"string.\n"
2962
"@item @var{make_final} is applied to the terminal seed\n"
2963
"value (on which @var{p} returns true) to produce\n"
2964
"the final/leftmost portion of the constructed string.\n"
2965
"It defaults to @code{(lambda (x) "")}.\n"
2966
"@end itemize")
2967
#define FUNC_NAME s_scm_string_unfold_right
2968
{
2969
SCM res, ans;
2970
2971
SCM_VALIDATE_PROC (1, p);
2972
SCM_VALIDATE_PROC (2, f);
2973
SCM_VALIDATE_PROC (3, g);
2974
if (!SCM_UNBNDP (base))
2975
{
2976
SCM_VALIDATE_STRING (5, base);
2977
ans = base;
2978
}
2979
else
2980
ans = scm_i_make_string (0, NULL);
2981
if (!SCM_UNBNDP (make_final))
2982
SCM_VALIDATE_PROC (6, make_final);
2983
2984
res = scm_call_1 (p, seed);
2985
while (scm_is_false (res))
2986
{
2987
SCM str;
2988
char *ptr;
2989
SCM ch = scm_call_1 (f, seed);
2990
if (!SCM_CHARP (ch))
2991
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
2992
str = scm_i_make_string (1, &ptr);
2993
*ptr = SCM_CHAR (ch);
2994
2995
ans = scm_string_append (scm_list_2 (str, ans));
2996
seed = scm_call_1 (g, seed);
2997
res = scm_call_1 (p, seed);
2998
}
2999
if (!SCM_UNBNDP (make_final))
3000
{
3001
res = scm_call_1 (make_final, seed);
3002
return scm_string_append (scm_list_2 (res, ans));
3003
}
3004
else
3005
return ans;
3006
}
3007
#undef FUNC_NAME
3008
3009
3010
SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0,
3011
(SCM proc, SCM s, SCM start, SCM end),
3012
"@var{proc} is mapped over @var{s} in left-to-right order. The\n"
3013
"return value is not specified.")
3014
#define FUNC_NAME s_scm_string_for_each
3015
{
3016
const char *cstr;
3017
size_t cstart, cend;
3018
scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
3019
3020
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
3021
MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
3022
3, start, cstart,
3023
4, end, cend);
3024
while (cstart < cend)
3025
{
3026
unsigned int c = (unsigned char) cstr[cstart];
3027
proc_tramp (proc, SCM_MAKE_CHAR (c));
3028
cstr = scm_i_string_chars (s);
3029
cstart++;
3030
}
3031
3032
scm_remember_upto_here_1 (s);
3033
return SCM_UNSPECIFIED;
3034
}
3035
#undef FUNC_NAME
3036
3037
SCM_DEFINE (scm_string_for_each_index, "string-for-each-index", 2, 2, 0,
3038
(SCM proc, SCM s, SCM start, SCM end),
3039
"Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
3040
"left to right.\n"
3041
"\n"
3042
"For example, to change characters to alternately upper and\n"
3043
"lower case,\n"
3044
"\n"
3045
"@example\n"
3046
"(define str (string-copy \"studly\"))\n"
3047
"(string-for-each-index\n"
3048
" (lambda (i)\n"
3049
" (string-set! str i\n"
3050
" ((if (even? i) char-upcase char-downcase)\n"
3051
" (string-ref str i))))\n"
3052
" str)\n"
3053
"str @result{} \"StUdLy\"\n"
3054
"@end example")
3055
#define FUNC_NAME s_scm_string_for_each_index
3056
{
3057
size_t cstart, cend;
3058
scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
3059
3060
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
3061
MY_VALIDATE_SUBSTRING_SPEC (2, s,
3062
3, start, cstart,
3063
4, end, cend);
3064
3065
while (cstart < cend)
3066
{
3067
proc_tramp (proc, scm_from_size_t (cstart));
3068
cstart++;
3069
}
3070
3071
scm_remember_upto_here_1 (s);
3072
return SCM_UNSPECIFIED;
3073
}
3074
#undef FUNC_NAME
3075
3076
SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0,
3077
(SCM s, SCM from, SCM to, SCM start, SCM end),
3078
"This is the @emph{extended substring} procedure that implements\n"
3079
"replicated copying of a substring of some string.\n"
3080
"\n"
3081
"@var{s} is a string, @var{start} and @var{end} are optional\n"
3082
"arguments that demarcate a substring of @var{s}, defaulting to\n"
3083
"0 and the length of @var{s}. Replicate this substring up and\n"
3084
"down index space, in both the positive and negative directions.\n"
3085
"@code{xsubstring} returns the substring of this string\n"
3086
"beginning at index @var{from}, and ending at @var{to}, which\n"
3087
"defaults to @var{from} + (@var{end} - @var{start}).")
3088
#define FUNC_NAME s_scm_xsubstring
3089
{
3090
const char *cs;
3091
char *p;
3092
size_t cstart, cend;
3093
int cfrom, cto;
3094
SCM result;
3095
3096
MY_VALIDATE_SUBSTRING_SPEC (1, s,
3097
4, start, cstart,
3098
5, end, cend);
3099
3100
cfrom = scm_to_int (from);
3101
if (SCM_UNBNDP (to))
3102
cto = cfrom + (cend - cstart);
3103
else
3104
cto = scm_to_int (to);
3105
if (cstart == cend && cfrom != cto)
3106
SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
3107
3108
result = scm_i_make_string (cto - cfrom, &p);
3109
3110
cs = scm_i_string_chars (s);
3111
while (cfrom < cto)
3112
{
3113
size_t t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart);
3114
if (cfrom < 0)
3115
*p = cs[(cend - cstart) - t];
3116
else
3117
*p = cs[t];
3118
cfrom++;
3119
p++;
3120
}
3121
3122
scm_remember_upto_here_1 (s);
3123
return result;
3124
}
3125
#undef FUNC_NAME
3126
3127
3128
SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0,
3129
(SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end),
3130
"Exactly the same as @code{xsubstring}, but the extracted text\n"
3131
"is written into the string @var{target} starting at index\n"
3132
"@var{tstart}. The operation is not defined if @code{(eq?\n"
3133
"@var{target} @var{s})} or these arguments share storage -- you\n"
3134
"cannot copy a string on top of itself.")
3135
#define FUNC_NAME s_scm_string_xcopy_x
3136
{
3137
char *p;
3138
const char *cs;
3139
size_t ctstart, cstart, cend;
3140
int csfrom, csto;
3141
SCM dummy = SCM_UNDEFINED;
3142
size_t cdummy;
3143
3144
MY_VALIDATE_SUBSTRING_SPEC (1, target,
3145
2, tstart, ctstart,
3146
2, dummy, cdummy);
3147
MY_VALIDATE_SUBSTRING_SPEC (3, s,
3148
6, start, cstart,
3149
7, end, cend);
3150
csfrom = scm_to_int (sfrom);
3151
if (SCM_UNBNDP (sto))
3152
csto = csfrom + (cend - cstart);
3153
else
3154
csto = scm_to_int (sto);
3155
if (cstart == cend && csfrom != csto)
3156
SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
3157
SCM_ASSERT_RANGE (1, tstart,
3158
ctstart + (csto - csfrom) <= scm_i_string_length (target));
3159
3160
p = scm_i_string_writable_chars (target) + ctstart;
3161
cs = scm_i_string_chars (s);
3162
while (csfrom < csto)
3163
{
3164
size_t t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart);
3165
if (csfrom < 0)
3166
*p = cs[(cend - cstart) - t];
3167
else
3168
*p = cs[t];
3169
csfrom++;
3170
p++;
3171
}
3172
scm_i_string_stop_writing ();
3173
3174
scm_remember_upto_here_2 (target, s);
3175
return SCM_UNSPECIFIED;
3176
}
3177
#undef FUNC_NAME
3178
3179
3180
SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0,
3181
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
3182
"Return the string @var{s1}, but with the characters\n"
3183
"@var{start1} @dots{} @var{end1} replaced by the characters\n"
3184
"@var{start2} @dots{} @var{end2} from @var{s2}.")
3185
#define FUNC_NAME s_scm_string_replace
3186
{
3187
const char *cstr1, *cstr2;
3188
char *p;
3189
size_t cstart1, cend1, cstart2, cend2;
3190
SCM result;
3191
3192
MY_VALIDATE_SUBSTRING_SPEC (1, s1,
3193
3, start1, cstart1,
3194
4, end1, cend1);
3195
MY_VALIDATE_SUBSTRING_SPEC (2, s2,
3196
5, start2, cstart2,
3197
6, end2, cend2);
3198
result = scm_i_make_string (cstart1 + (cend2 - cstart2) +
3199
scm_i_string_length (s1) - cend1, &p);
3200
cstr1 = scm_i_string_chars (s1);
3201
cstr2 = scm_i_string_chars (s2);
3202
memmove (p, cstr1, cstart1 * sizeof (char));
3203
memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2) * sizeof (char));
3204
memmove (p + cstart1 + (cend2 - cstart2),
3205
cstr1 + cend1,
3206
(scm_i_string_length (s1) - cend1) * sizeof (char));
3207
scm_remember_upto_here_2 (s1, s2);
3208
return result;
3209
}
3210
#undef FUNC_NAME
3211
3212
3213
SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0,
3214
(SCM s, SCM token_set, SCM start, SCM end),
3215
"Split the string @var{s} into a list of substrings, where each\n"
3216
"substring is a maximal non-empty contiguous sequence of\n"
3217
"characters from the character set @var{token_set}, which\n"
3218
"defaults to @code{char-set:graphic}.\n"
3219
"If @var{start} or @var{end} indices are provided, they restrict\n"
3220
"@code{string-tokenize} to operating on the indicated substring\n"
3221
"of @var{s}.")
3222
#define FUNC_NAME s_scm_string_tokenize
3223
{
3224
const char *cstr;
3225
size_t cstart, cend;
3226
SCM result = SCM_EOL;
3227
3228
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
3229
3, start, cstart,
3230
4, end, cend);
3231
3232
if (SCM_UNBNDP (token_set))
3233
token_set = scm_char_set_graphic;
3234
3235
if (SCM_CHARSETP (token_set))
3236
{
3237
size_t idx;
3238
3239
while (cstart < cend)
3240
{
3241
while (cstart < cend)
3242
{
3243
if (SCM_CHARSET_GET (token_set, cstr[cend - 1]))
3244
break;
3245
cend--;
3246
}
3247
if (cstart >= cend)
3248
break;
3249
idx = cend;
3250
while (cstart < cend)
3251
{
3252
if (!SCM_CHARSET_GET (token_set, cstr[cend - 1]))
3253
break;
3254
cend--;
3255
}
3256
result = scm_cons (scm_c_substring (s, cend, idx), result);
3257
cstr = scm_i_string_chars (s);
3258
}
3259
}
3260
else
3261
SCM_WRONG_TYPE_ARG (2, token_set);
3262
3263
scm_remember_upto_here_1 (s);
3264
return result;
3265
}
3266
#undef FUNC_NAME
3267
3268
SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0,
3269
(SCM str, SCM chr),
3270
"Split the string @var{str} into the a list of the substrings delimited\n"
3271
"by appearances of the character @var{chr}. Note that an empty substring\n"
3272
"between separator characters will result in an empty string in the\n"
3273
"result list.\n"
3274
"\n"
3275
"@lisp\n"
3276
"(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
3277
"@result{}\n"
3278
"(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
3279
"\n"
3280
"(string-split \"::\" #\\:)\n"
3281
"@result{}\n"
3282
"(\"\" \"\" \"\")\n"
3283
"\n"
3284
"(string-split \"\" #\\:)\n"
3285
"@result{}\n"
3286
"(\"\")\n"
3287
"@end lisp")
3288
#define FUNC_NAME s_scm_string_split
3289
{
3290
long idx, last_idx;
3291
const char * p;
3292
char ch;
3293
SCM res = SCM_EOL;
3294
3295
SCM_VALIDATE_STRING (1, str);
3296
SCM_VALIDATE_CHAR (2, chr);
3297
3298
idx = scm_i_string_length (str);
3299
p = scm_i_string_chars (str);
3300
ch = SCM_CHAR (chr);
3301
while (idx >= 0)
3302
{
3303
last_idx = idx;
3304
while (idx > 0 && p[idx - 1] != ch)
3305
idx--;
3306
if (idx >= 0)
3307
{
3308
res = scm_cons (scm_c_substring (str, idx, last_idx), res);
3309
p = scm_i_string_chars (str);
3310
idx--;
3311
}
3312
}
3313
scm_remember_upto_here_1 (str);
3314
return res;
3315
}
3316
#undef FUNC_NAME
3317
3318
3319
SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
3320
(SCM s, SCM char_pred, SCM start, SCM end),
3321
"Filter the string @var{s}, retaining only those characters\n"
3322
"which satisfy @var{char_pred}.\n"
3323
"\n"
3324
"If @var{char_pred} is a procedure, it is applied to each\n"
3325
"character as a predicate, if it is a character, it is tested\n"
3326
"for equality and if it is a character set, it is tested for\n"
3327
"membership.")
3328
#define FUNC_NAME s_scm_string_filter
3329
{
3330
const char *cstr;
3331
size_t cstart, cend;
3332
SCM result;
3333
size_t idx;
3334
3335
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
3336
3, start, cstart,
3337
4, end, cend);
3338
3339
/* The explicit loops below stripping leading and trailing non-matches
3340
mean we can return a substring if those are the only deletions, making
3341
string-filter as efficient as string-trim-both in that case. */
3342
3343
if (SCM_CHARP (char_pred))
3344
{
3345
size_t count;
3346
char chr;
3347
3348
chr = SCM_CHAR (char_pred);
3349
3350
/* strip leading non-matches by incrementing cstart */
3351
while (cstart < cend && cstr[cstart] != chr)
3352
cstart++;
3353
3354
/* strip trailing non-matches by decrementing cend */
3355
while (cend > cstart && cstr[cend-1] != chr)
3356
cend--;
3357
3358
/* count chars to keep */
3359
count = 0;
3360
for (idx = cstart; idx < cend; idx++)
3361
if (cstr[idx] == chr)
3362
count++;
3363
3364
if (count == cend - cstart)
3365
{
3366
/* whole of cstart to cend is to be kept, return a copy-on-write
3367
substring */
3368
result_substring:
3369
result = scm_i_substring (s, cstart, cend);
3370
}
3371
else
3372
result = scm_c_make_string (count, char_pred);
3373
}
3374
else if (SCM_CHARSETP (char_pred))
3375
{
3376
size_t count;
3377
3378
/* strip leading non-matches by incrementing cstart */
3379
while (cstart < cend && ! SCM_CHARSET_GET (char_pred, cstr[cstart]))
3380
cstart++;
3381
3382
/* strip trailing non-matches by decrementing cend */
3383
while (cend > cstart && ! SCM_CHARSET_GET (char_pred, cstr[cend-1]))
3384
cend--;
3385
3386
/* count chars to be kept */
3387
count = 0;
3388
for (idx = cstart; idx < cend; idx++)
3389
if (SCM_CHARSET_GET (char_pred, cstr[idx]))
3390
count++;
3391
3392
/* if whole of start to end kept then return substring */
3393
if (count == cend - cstart)
3394
goto result_substring;
3395
else
3396
{
3397
char *dst;
3398
result = scm_i_make_string (count, &dst);
3399
cstr = scm_i_string_chars (s);
3400
3401
/* decrement "count" in this loop as well as using idx, so that if
3402
another thread is simultaneously changing "s" there's no chance
3403
it'll make us copy more than count characters */
3404
for (idx = cstart; idx < cend && count != 0; idx++)
3405
{
3406
if (SCM_CHARSET_GET (char_pred, cstr[idx]))
3407
{
3408
*dst++ = cstr[idx];
3409
count--;
3410
}
3411
}
3412
}
3413
}
3414
else
3415
{
3416
SCM ls = SCM_EOL;
3417
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
3418
3419
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
3420
idx = cstart;
3421
while (idx < cend)
3422
{
3423
SCM res, ch;
3424
ch = SCM_MAKE_CHAR (cstr[idx]);
3425
res = pred_tramp (char_pred, ch);
3426
if (scm_is_true (res))
3427
ls = scm_cons (ch, ls);
3428
cstr = scm_i_string_chars (s);
3429
idx++;
3430
}
3431
result = scm_reverse_list_to_string (ls);
3432
}
3433
3434
scm_remember_upto_here_1 (s);
3435
return result;
3436
}
3437
#undef FUNC_NAME
3438
3439
3440
SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
3441
(SCM s, SCM char_pred, SCM start, SCM end),
3442
"Delete characters satisfying @var{char_pred} from @var{s}.\n"
3443
"\n"
3444
"If @var{char_pred} is a procedure, it is applied to each\n"
3445
"character as a predicate, if it is a character, it is tested\n"
3446
"for equality and if it is a character set, it is tested for\n"
3447
"membership.")
3448
#define FUNC_NAME s_scm_string_delete
3449
{
3450
const char *cstr;
3451
size_t cstart, cend;
3452
SCM result;
3453
size_t idx;
3454
3455
MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
3456
3, start, cstart,
3457
4, end, cend);
3458
3459
/* The explicit loops below stripping leading and trailing matches mean we
3460
can return a substring if those are the only deletions, making
3461
string-delete as efficient as string-trim-both in that case. */
3462
3463
if (SCM_CHARP (char_pred))
3464
{
3465
size_t count;
3466
char chr;
3467
3468
chr = SCM_CHAR (char_pred);
3469
3470
/* strip leading matches by incrementing cstart */
3471
while (cstart < cend && cstr[cstart] == chr)
3472
cstart++;
3473
3474
/* strip trailing matches by decrementing cend */
3475
while (cend > cstart && cstr[cend-1] == chr)
3476
cend--;
3477
3478
/* count chars to be kept */
3479
count = 0;
3480
for (idx = cstart; idx < cend; idx++)
3481
if (cstr[idx] != chr)
3482
count++;
3483
3484
if (count == cend - cstart)
3485
{
3486
/* whole of cstart to cend is to be kept, return a copy-on-write
3487
substring */
3488
result_substring:
3489
result = scm_i_substring (s, cstart, cend);
3490
}
3491
else
3492
{
3493
/* new string for retained portion */
3494
char *dst;
3495
result = scm_i_make_string (count, &dst);
3496
cstr = scm_i_string_chars (s);
3497
3498
/* decrement "count" in this loop as well as using idx, so that if
3499
another thread is simultaneously changing "s" there's no chance
3500
it'll make us copy more than count characters */
3501
for (idx = cstart; idx < cend && count != 0; idx++)
3502
{
3503
if (cstr[idx] != chr)
3504
{
3505
*dst++ = cstr[idx];
3506
count--;
3507
}
3508
}
3509
}
3510
}
3511
else if (SCM_CHARSETP (char_pred))
3512
{
3513
size_t count;
3514
3515
/* strip leading matches by incrementing cstart */
3516
while (cstart < cend && SCM_CHARSET_GET (char_pred, cstr[cstart]))
3517
cstart++;
3518
3519
/* strip trailing matches by decrementing cend */
3520
while (cend > cstart && SCM_CHARSET_GET (char_pred, cstr[cend-1]))
3521
cend--;
3522
3523
/* count chars to be kept */
3524
count = 0;
3525
for (idx = cstart; idx < cend; idx++)
3526
if (! SCM_CHARSET_GET (char_pred, cstr[idx]))
3527
count++;
3528
3529
if (count == cend - cstart)
3530
goto result_substring;
3531
else
3532
{
3533
/* new string for retained portion */
3534
char *dst;
3535
result = scm_i_make_string (count, &dst);
3536
cstr = scm_i_string_chars (s);
3537
3538
/* decrement "count" in this loop as well as using idx, so that if
3539
another thread is simultaneously changing "s" there's no chance
3540
it'll make us copy more than count characters */
3541
for (idx = cstart; idx < cend && count != 0; idx++)
3542
{
3543
if (! SCM_CHARSET_GET (char_pred, cstr[idx]))
3544
{
3545
*dst++ = cstr[idx];
3546
count--;
3547
}
3548
}
3549
}
3550
}
3551
else
3552
{
3553
SCM ls = SCM_EOL;
3554
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
3555
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
3556
3557
idx = cstart;
3558
while (idx < cend)
3559
{
3560
SCM res, ch = SCM_MAKE_CHAR (cstr[idx]);
3561
res = pred_tramp (char_pred, ch);
3562
if (scm_is_false (res))
3563
ls = scm_cons (ch, ls);
3564
cstr = scm_i_string_chars (s);
3565
idx++;
3566
}
3567
result = scm_reverse_list_to_string (ls);
3568
}
3569
3570
scm_remember_upto_here_1 (s);
3571
return result;
3572
}
3573
#undef FUNC_NAME
3574
3575
void
3576
scm_init_srfi_13 (void)
3577
{
3578
#include "libguile/srfi-13.x"
3579
}
3580
3581
/* End of srfi-13.c. */
Loggerhead is a web-based interface for Breezy
Version: 2.0.1