1 /* -*- tab-width:4; -*- */
2 /*
3 * The strings
4 *
5 * $Id: str.c 1.35 Wed, 19 Apr 2000 22:43:15 +0200 crad $
6 */
7 #include "s.h"
8 #include "heap.h"
9
10 /*** create a new string of len char */
scm_str_alloc(int len)11 SOBJ scm_str_alloc(int len)
12 {
13 int qlen;
14 SOBJ str = scm_newcell(SOBJ_T_STRING);
15
16 SCM_STR_LEN(str) = len;
17 qlen = scm_str_lenq(len+1);
18 SCM_STR_VALUE(str) = scm_must_alloc(qlen);
19 return(str);
20 }
21
22 /*** resize str to newlen chars */
scm_str_resize(SOBJ str,int newlen)23 SOBJ scm_str_resize(SOBJ str, int newlen)
24 {
25 int qlen, nlen;
26
27 if (SCM_STR_VALUE(str)) { /* already allocated */
28 qlen = scm_str_lenq(SCM_STR_LEN(str));
29 nlen = scm_str_lenq(newlen+1);
30 if (qlen != nlen)
31 SCM_STR_VALUE(str) = scm_must_realloc(SCM_STR_VALUE(str), nlen);
32
33 } else { /* fresh string */
34 nlen = scm_str_lenq(newlen+1);
35 SCM_STR_VALUE(str) = scm_must_alloc(nlen);
36 }
37 SCM_STR_LEN(str) = newlen;
38 return(str);
39 }
40
41 /*** make a string: if str == NULL, create a new one else clone str */
scm_mkstring(char * str)42 SOBJ scm_mkstring(char *str)
43 {
44 SOBJ obj;
45 int len;
46
47 if (str) {
48 len = strlen(str);
49 obj = scm_str_alloc(len);
50 strcpy(SCM_STR_VALUE(obj), str);
51 } else {
52 obj = scm_str_alloc(0);
53 }
54 return(obj);
55 }
56
57 /*** return the string length or -1 on error */
scm_strlen(SOBJ str)58 int scm_strlen(SOBJ str)
59 {
60 if (!SCM_STRINGP(str)) return(-1);
61 return(SCM_STR_LEN(str));
62 }
63
64 /*** append a char to string */
scm_strcat_chr(SOBJ str,int c)65 SOBJ scm_strcat_chr(SOBJ str, int c)
66 {
67 int l = SCM_STR_LEN(str);
68 scm_str_resize(str, l + 1);
69 SCM_STR_VALUE(str)[l] = c;
70 SCM_STR_VALUE(str)[l+1] = 0;
71 return(str);
72 }
73
74 /*** append content of a buffer to string */
scm_strcat_buf(SOBJ str,char * buf,int len)75 SOBJ scm_strcat_buf(SOBJ str, char *buf, int len)
76 {
77 int l = SCM_STR_LEN(str);
78
79 scm_str_resize(str, l + len);
80 memcpy(SCM_STR_VALUE(str) + l, buf, len);
81 return(str);
82 }
83
84 /*E* (string-append-char STRING CHAR) => STRING */
85 /*D* Returns a new STRING with CHAR appended. */
86
scm_string_append_char(SOBJ str,SOBJ chr)87 SOBJ scm_string_append_char(SOBJ str, SOBJ chr)
88 {
89 if (str == NULL) str = scm_mkstring(NULL);
90
91 if (!SCM_STRINGP(str)) SCM_ERR("want a string", str);
92 if (!SCM_INUMP(chr) && !SCM_CHARP(chr)) SCM_ERR("bad int or chr", chr);
93 return(scm_strcat_chr(str, SCM_INUMP(chr) ? SCM_INUM(chr) : SCM_CHAR(chr)));
94 }
95
96 /************************************************************************
97 * String type definition
98 ************************************************************************/
99
scm_string_sweep(SOBJ str)100 void scm_string_sweep(SOBJ str)
101 {
102 #ifdef DEBUG
103 scm_puts("; removing string at "); port_putx(SCM_OUTP, str); scm_puts("\n");
104 #endif
105 if (str && SCM_STR_VALUE(str)) {
106 scm_free(SCM_STR_VALUE(str));
107 SCM_STR_VALUE(str) = NULL;
108 }
109 }
110
scm_string_print(SOBJ str,PORT * p)111 void scm_string_print(SOBJ str, PORT *p)
112 {
113 port_write(p, str, SCM_STR_LEN(str));
114 }
115
scm_string_write(SOBJ str,PORT * p)116 void scm_string_write(SOBJ str, PORT *p)
117 {
118 int c, i;
119 char buf[32];
120
121 port_putc(p, '\"');
122 for (i = 0; i < SCM_STR_LEN(str); i++) {
123 c = SCM_STR_VALUE(str)[i] & 0xff;
124 if (c < ' ' || c == 127) {
125 switch(c) {
126 case '\a': port_puts(p, "\\a"); break;
127 case '\b': port_puts(p, "\\b"); break;
128 case '\t': port_puts(p, "\\t"); break;
129 case '\n': port_puts(p, "\\n"); break;
130 case '\v': port_puts(p, "\\v"); break;
131 case '\f': port_puts(p, "\\f"); break;
132 case '\r': port_puts(p, "\\r"); break;
133 default:
134 sprintf(buf, "\\%03u", c);
135 port_puts(p, buf);
136 }
137 } else {
138 switch(c) {
139 case '\\': port_puts(p, "\\\\"); break;
140 case '\"': port_puts(p, "\\\""); break;
141 default: port_putc(p, c);
142 }
143 }
144 }
145 port_putc(p, '\"');
146 }
147
148
149
150 /*-- detect valid string starter char */
scm_string_reconize(PORT * port,int c)151 int scm_string_reconize(PORT *port, int c)
152 {
153 return(c == '\"');
154 }
155
xdigit2nibble(int x)156 static int xdigit2nibble(int x)
157 {
158 int n = (x <= '9') ? (x - '0') : (tolower(x) - ('a' - 10));
159 return(n);
160 }
161
nibble2xdigit(int x)162 static int nibble2xdigit(int x)
163 {
164 static char cv[] = "0123456789ABCDEF";
165 return(cv[x & 0x0f]);
166 }
167
168 /*-- read from SCM_INP */
scm_string_parse(PORT * port,int start_char)169 SOBJ scm_string_parse(PORT *port, int start_char)
170 {
171 int c, n, i;
172 SOBJ str = scm_mkstring("");
173
174 while( (c = port_getc(port)) != EOF) {
175 if (c == '\"') break;
176
177 if (c == '\\') { /* escape sequence */
178 if ((c = port_getc(port)) == EOF) {
179 SCM_ERR("EOF while reading string...", NULL);
180 }
181 c &= 0xff;
182 switch(c) {
183 case 'n': c = '\n'; break;
184 case 'r': c = '\r'; break;
185 case 'b': c = '\b'; break;
186 case 't': c = '\t'; break;
187 case 'x':
188 n = 0;
189 for (i = 0; i < 2 && isxdigit(port_peekc(port)); i++) {
190 c = port_getc(port) & 0xff;
191 n = (n << 4) | xdigit2nibble(c);
192 }
193 c = n;
194 break;
195 default:
196 n = 0;
197 if (isdigit(c) && c < '8') {
198 n = c - '0';
199 for (i = 1; i < 3 && isdigit(port_peekc(port)); i++) {
200 c = port_getc(port) & 0xff;
201 n = (n << 3) | (c - '0');
202 }
203 }
204 c = n;
205
206 /* nothing yet */
207 }
208 }
209 str = scm_strcat_chr(str, c);
210 }
211 return(str);
212 }
213
214 /*-- library */
215
scm_string_compare(SOBJ s1,SOBJ s2)216 SOBJ scm_string_compare(SOBJ s1, SOBJ s2)
217 {
218 return( (strcmp(SCM_STR_VALUE(s1), SCM_STR_VALUE(s2)) == 0) ?
219 scm_true : scm_false);
220 }
221
222 /*S* (string? OBJ) => BOOLEAN */
223 /*D* Returns #t if OBJ is a string, #f otherwise */
scm_stringp(SOBJ x)224 SOBJ scm_stringp(SOBJ x)
225 {
226 return(SCM_MKBOOL(SCM_STRINGP(x)));
227 }
228
scm_make_string2(SOBJ l,SOBJ c)229 SOBJ scm_make_string2(SOBJ l, SOBJ c)
230 {
231 SOBJ s;
232 int len, i, j;
233
234 if (!SCM_INUMP(l)) SCM_ERR("make-string: bad integer", l);
235 if (c != NULL && !SCM_CHARP(c)) SCM_ERR("make-string: bad char", c);
236
237 len = SCM_INUM(l);
238 s = scm_str_alloc(len);
239 j = (c == NULL) ? 0 : SCM_CHAR(c);
240 for (i = 0; i < len; i++) SCM_STR_VALUE(s)[i] = j;
241 SCM_STR_VALUE(s)[len] = 0; /* null terminated for c compatibility */
242 return(s);
243 }
244
245 /*S* (make-string LEN [CHAR]) => STRING */
246 /*D* Returns a newly allocated string of length LEN. If CHAR is given,
247 then all elements of the string are initialized to CHAR, otherwise
248 the contents of the string are unspecified. */
scm_make_string(int nargs,SOBJ * a)249 SOBJ scm_make_string(int nargs, SOBJ *a)
250 {
251 if (nargs < 1 || nargs > 2) SCM_ERR("make-string: bad number of args", NULL);
252
253 return(scm_make_string2(a[0], (nargs == 2) ? a[1] : NULL));
254 }
255
256 /*S* (string CHAR ...) => STRING */
257 /*D* Returns a newly allocated string composed of the arguments. NOTE:
258 * CHAR may also be a number representing the ASCII code of the
259 * char. */
scm_string(int nargs,SOBJ * a)260 SOBJ scm_string(int nargs, SOBJ *a)
261 {
262 int i;
263 SOBJ str = scm_str_alloc(nargs);
264
265 for (i = 0; i < nargs; i++) {
266 if (SCM_INUMP(a[i])) {
267 SCM_STR_VALUE(str)[i] = SCM_INUM(a[i]);
268 continue;
269 }
270 if (SCM_CHARP(a[i])) {
271 SCM_STR_VALUE(str)[i] = SCM_CHAR(a[i]);
272 continue;
273 }
274 if (SCM_STRINGP(a[i])) {
275 SCM_STR_VALUE(str)[i] = SCM_STR_VALUE(a[i])[0];
276 continue;
277 }
278 SCM_ERR("bad char", a[i]);
279 }
280 return(str);
281 }
282
283 /*S* (string-length STRING) => NUMBER */
284 /*D* Returns the number of characters in the given string. */
scm_string_length(SOBJ str)285 SOBJ scm_string_length(SOBJ str)
286 {
287 if (!SCM_STRINGP(str)) SCM_ERR("string-length: bad string", str);
288 return(SCM_MKINUM(SCM_STR_LEN(str)));
289 }
290
291 /*S* (string-ref STRING K) => CHAR */
292 /*D* Returns character K of STRING using zero-origin indexing. */
scm_string_ref(SOBJ str,SOBJ index)293 SOBJ scm_string_ref(SOBJ str, SOBJ index)
294 {
295 int i;
296
297 if (!SCM_STRINGP(str)) SCM_ERR("string-ref: bad string", str);
298 if (!SCM_INUMP(index)) SCM_ERR("string-ref: bad index", index);
299
300 i = SCM_INUM(index);
301 if (i < 0 || i >= SCM_STR_LEN(str))
302 SCM_ERR("string-ref: index out of range", index);
303
304 return(scm_mkchar(SCM_STR_VALUE(str)[i]));
305 }
306
307 /*S* (string-set! STRING K CHAR) => #undefined */
308 /*D* Stores CHAR in element K of STRING and returns an unspecified
309 value. */
scm_string_set(SOBJ str,SOBJ index,SOBJ chr)310 SOBJ scm_string_set(SOBJ str, SOBJ index, SOBJ chr)
311 {
312 int i;
313
314 if (!SCM_STRINGP(str)) SCM_ERR("string-set!: bad string", str);
315 if (!SCM_INUMP(index)) SCM_ERR("string-set!: bad index", index);
316 if (!SCM_CHARP(chr)) SCM_ERR("string-set!: bad char", chr);
317
318 i = SCM_INUM(index);
319 if (i < 0 || i >= SCM_STR_LEN(str))
320 SCM_ERR("string-set!: index out of range", index);
321
322 SCM_STR_VALUE(str)[i] = SCM_CHAR(chr);
323
324 return(scm_undefined);
325 }
326
scmp(SOBJ s1,SOBJ s2)327 static int scmp(SOBJ s1, SOBJ s2)
328 {
329 char *p, *q, *lp, *lq;
330
331 if (!SCM_STRINGP(s1)) SCM_ERR("string-cmp: bad string", s1);
332 if (!SCM_STRINGP(s2)) SCM_ERR("string-cmp: bad string", s2);
333
334 p = SCM_STR_VALUE(s1); lp = p + SCM_STR_LEN(s1);
335 q = SCM_STR_VALUE(s2); lq = q + SCM_STR_LEN(s2);
336 while(p < lp && q < lq) {
337 if (*p - *q != 0) return(*p - *q);
338 p++;
339 q++;
340 }
341 if (p == lp && q == lq) return(0);
342 return(*p - *q);
343 }
344
scmpi(SOBJ s1,SOBJ s2)345 static int scmpi(SOBJ s1, SOBJ s2)
346 {
347 char *p, *q, *lp, *lq;
348
349 if (!SCM_STRINGP(s1)) SCM_ERR("string-cmp: bad string", s1);
350 if (!SCM_STRINGP(s2)) SCM_ERR("string-cmp: bad string", s2);
351
352 p = SCM_STR_VALUE(s1); lp = p + SCM_STR_LEN(s1);
353 q = SCM_STR_VALUE(s2); lq = q + SCM_STR_LEN(s2);
354 while(p < lp && q < lq) {
355 if (tolower(*p) - tolower(*q) != 0) return(tolower(*p) - tolower(*q));
356 p++;
357 q++;
358 }
359 if (p == lp && q == lq) return(0);
360 return(tolower(*p) - tolower(*q));
361 }
362
363 /*S* (string<? STRING1 STRING2) => BOOLEAN */
364 /*D* Returns #t if STRING1 is lexicographically less than STRING2, #f
365 otherwise. */
scm_string_lt(SOBJ s1,SOBJ s2)366 SOBJ scm_string_lt(SOBJ s1, SOBJ s2) { return(SCM_MKBOOL(scmp(s1,s2) < 0)); }
367
368 /*S* (string<=? STRING1 STRING2) => BOOLEAN */
369 /*D* Returns #t if STRING1 is lexicographically less or equal than
370 STRING2, #f otherwise. */
scm_string_le(SOBJ s1,SOBJ s2)371 SOBJ scm_string_le(SOBJ s1, SOBJ s2) { return(SCM_MKBOOL(scmp(s1,s2) <= 0)); }
372
373 /*S* (string=? STRING1 STRING2) => BOOLEAN */
374 /*D* Returns #t if STRING1 is the same as STRING2, #f otherwise. */
scm_string_eq(SOBJ s1,SOBJ s2)375 SOBJ scm_string_eq(SOBJ s1, SOBJ s2) { return(SCM_MKBOOL(scmp(s1,s2) == 0)); }
376
377 /*S* (string>? STRING1 STRING2) => BOOLEAN */
378 /*D* Returns #t if STRING1 is lexicographically greater than STRING2,
379 #f otherwise. */
scm_string_ge(SOBJ s1,SOBJ s2)380 SOBJ scm_string_ge(SOBJ s1, SOBJ s2) { return(SCM_MKBOOL(scmp(s1,s2) >= 0)); }
381
382 /*S* (string>=? STRING1 STRING2) => BOOLEAN */
383 /*D* Returns #t if STRING1 is lexicographically greater or equal than
384 STRING2, #f otherwise. */
scm_string_gt(SOBJ s1,SOBJ s2)385 SOBJ scm_string_gt(SOBJ s1, SOBJ s2) { return(SCM_MKBOOL(scmp(s1,s2) > 0)); }
386
387 /*S* (string-ci<? STRING1 STRING2) => BOOLEAN */
388 /*D* Returns #t if STRING1 is lexicographically less than STRING2, #f
389 otherwise. The comparison is case insensitive. */
scm_string_ci_lt(SOBJ s1,SOBJ s2)390 SOBJ scm_string_ci_lt(SOBJ s1, SOBJ s2){return(SCM_MKBOOL(scmpi(s1,s2) < 0));}
391
392 /*S* (string-ci<=? STRING1 STRING2) => BOOLEAN */
393 /*D* Returns #t if STRING1 is lexicographically less or equal than
394 STRING2, #f otherwise. The comparison is case insensitive. */
scm_string_ci_le(SOBJ s1,SOBJ s2)395 SOBJ scm_string_ci_le(SOBJ s1, SOBJ s2){return(SCM_MKBOOL(scmpi(s1,s2) <= 0));}
396
397 /*S* (string-ci=? STRING1 STRING2) => BOOLEAN */
398 /*D* Returns #t if STRING1 is the same as STRING2, #f otherwise. The
399 comparison is case insensitive. */
scm_string_ci_eq(SOBJ s1,SOBJ s2)400 SOBJ scm_string_ci_eq(SOBJ s1, SOBJ s2){return(SCM_MKBOOL(scmpi(s1,s2) == 0));}
401
402 /*S* (string-ci>? STRING1 STRING2) => BOOLEAN */
403 /*D* Returns #t if STRING1 is lexicographically greater than STRING2,
404 #f otherwise. The comparison is case insensitive. */
scm_string_ci_ge(SOBJ s1,SOBJ s2)405 SOBJ scm_string_ci_ge(SOBJ s1, SOBJ s2){return(SCM_MKBOOL(scmpi(s1,s2) >= 0));}
406
407 /*S* (string-ci>=? STRING1 STRING2) => BOOLEAN */
408 /*D* Returns #t if STRING1 is lexicographically greater or equal than
409 STRING2, #f otherwise. The comparison is case insensitive. */
scm_string_ci_gt(SOBJ s1,SOBJ s2)410 SOBJ scm_string_ci_gt(SOBJ s1, SOBJ s2){return(SCM_MKBOOL(scmpi(s1,s2) > 0));}
411
412 /*S* (substring START END) => STRING */
413 /*D* Returns a newly allocated string formed from the characters of
414 string beginning with index start (inclusive) and ending with index
415 end (exclusive). */
scm_substring(SOBJ string,SOBJ start,SOBJ end)416 SOBJ scm_substring(SOBJ string, SOBJ start, SOBJ end)
417 {
418 SOBJ s;
419 int len;
420
421 if (!SCM_STRINGP(string)) SCM_ERR("substring: bad string", string);
422 if (!SCM_INUMP(start)) SCM_ERR("substring: bad start", start);
423 if (!SCM_INUMP(end)) SCM_ERR("substring: bad end", start);
424
425 len = SCM_INUM(end) - SCM_INUM(start);
426 if (len < 0) SCM_ERR("substring: start is not <= end", start);
427
428 s = scm_str_alloc(len);
429 strncpy(SCM_STR_VALUE(s),
430 SCM_STR_VALUE(string) + SCM_INUM(start),
431 len);
432 SCM_STR_VALUE(s)[len] = 0;
433 return(s);
434 }
435
436 /*S* (string-append STRING ...) => STRING */
437 /*D* Returns a newly allocated string whose characters form the
438 concatenation of the given strings. */
scm_string_append(int nargs,SOBJ * s)439 SOBJ scm_string_append(int nargs, SOBJ *s)
440 {
441 int i, len;
442 SOBJ str;
443 char *p;
444
445 len = 0;
446 for (i = 0; i < nargs; i++) {
447 if (!SCM_STRINGP(s[i])) SCM_ERR("string-append: bad string", s[i]);
448 len += SCM_STR_LEN(s[i]);
449 }
450 str = scm_str_alloc(len);
451 p = SCM_STR_VALUE(str);
452 for (i = 0; i < nargs; i++) {
453 strncpy(p, SCM_STR_VALUE(s[i]), SCM_STR_LEN(s[i]));
454 p += SCM_STR_LEN(s[i]);
455 }
456 return(str);
457 }
458
459 /*S* (string-append2 STR1 STR2) => STRING */
460 /*D* Returns a newly allocated string whose characters form the
461 concatenation of STR1 and STR2 */
scm_string_append2(SOBJ str1,SOBJ str2)462 SOBJ scm_string_append2(SOBJ str1, SOBJ str2)
463 {
464 SOBJ str;
465 if (!SCM_STRINGP(str1)) SCM_ERR("string-append2: bad string", str1);
466 if (!SCM_STRINGP(str2)) SCM_ERR("string-append2: bad string", str2);
467
468 str = scm_str_alloc(SCM_STR_LEN(str1) + SCM_STR_LEN(str2));
469 strcpy(SCM_STR_VALUE(str), SCM_STR_VALUE(str1));
470 strcpy(SCM_STR_VALUE(str) + SCM_STR_LEN(str1), SCM_STR_VALUE(str2));
471 return(str);
472 }
473
474 /*E* (string-append! STR1 STR2) => #undefined */
475 /*D* Append STR2 to STR1. */
scm_string_concat(SOBJ str1,SOBJ str2)476 SOBJ scm_string_concat(SOBJ str1, SOBJ str2)
477 {
478 int l1, l2;
479 if (!SCM_STRINGP(str1)) SCM_ERR("string-concat!: bad string", str1);
480 if (!SCM_STRINGP(str2)) SCM_ERR("string-concat!: bad string", str2);
481
482 l1 = SCM_STR_LEN(str1);
483 l2 = SCM_STR_LEN(str2);
484 scm_str_resize(str1, l1 + l2);
485 memcpy(SCM_STR_VALUE(str1) + l1, SCM_STR_VALUE(str2), l2);
486 SCM_STR_VALUE(str1)[l1+l2]=0;
487 return(scm_undefined);
488 }
489
490 /*-- string coerse */
491
492 /*S* (string->list STRING) => LIST */
493 /*D* Returns a newly allocated list of the characters that make
494 up the given STRING. */
scm_string_to_list(SOBJ str)495 SOBJ scm_string_to_list(SOBJ str)
496 {
497 SOBJ list;
498 int i;
499
500 if (!SCM_STRINGP(str)) SCM_ERR("string->list: bad string", str);
501
502 list = NULL;
503 for (i = SCM_STR_LEN(str)-1; i >= 0; --i) {
504 list = scm_cons(scm_mkchar(SCM_STR_VALUE(str)[i]), list);
505 }
506 return(list);
507 }
508
509 /*S* (string->symbol STRING) => SYMBOL */
510 /*D* Returns the symbol whose name is string. */
scm_string_to_symbol(SOBJ str)511 SOBJ scm_string_to_symbol(SOBJ str)
512 {
513 if (!SCM_STRINGP(str)) SCM_ERR("string->symbol: bad string", str);
514 return(scm_mksymbol(SCM_STR_VALUE(str)));
515 }
516
517 /*S* (symbol->string SYMBOL) => STRING */
518 /*D* Returns the name of symbol as a string. */
scm_symbol_to_string(SOBJ sym)519 SOBJ scm_symbol_to_string(SOBJ sym)
520 {
521 switch(SCM_OBJTYPE(sym)) {
522 case SOBJ_T_SYMBOL: return(scm_atom_to_string(SCM_SYM_NAME(sym)));
523 case SOBJ_T_ATOM: return(scm_atom_to_string(sym));
524 }
525 SCM_ERR("symbol->string: bad symbol", sym);
526 return(scm_undefined);
527 }
528
529 /*S* (list->string LIST) => STRING */
530 /*D* Returns a newly allocated STRING formed from the characters in
531 the list LIST, which must be a list of characters.*/
scm_list_to_string(SOBJ list)532 SOBJ scm_list_to_string(SOBJ list)
533 {
534 SOBJ str;
535 int len;
536 char *p;
537
538 len = scm_list_length(list);
539 if (len < 0) SCM_ERR("list->string: bad list", list);
540
541 str = scm_str_alloc(len);
542 p = SCM_STR_VALUE(str);
543 while(list) {
544 if (!SCM_CHARP(SCM_CAR(list)))
545 SCM_ERR("list->string: bad char", SCM_CAR(list));
546 *p++ = SCM_CHAR(SCM_CAR(list));
547 list = SCM_CDR(list);
548 }
549 *p = 0;
550 return(str);
551 }
552
553 /*S* (string-copy STRING) => STRING */
554 /*D* Returns a newly allocated copy of the given STRING. */
scm_string_copy(SOBJ str)555 SOBJ scm_string_copy(SOBJ str)
556 {
557 SOBJ s;
558
559 if (!SCM_STRINGP(str)) SCM_ERR("string-copy: bad string", str);
560
561 s = scm_str_alloc(SCM_STR_LEN(str));
562 strncpy(SCM_STR_VALUE(s), SCM_STR_VALUE(str), SCM_STR_LEN(str));
563 return(s);
564 }
565
566 /*S* (string-fill! STRING CHR) => #undefined */
567 /*D* Stores CHAR in every element of the given STRING and returns an
568 unspecified value. */
scm_string_fill(SOBJ str,SOBJ chr)569 SOBJ scm_string_fill(SOBJ str, SOBJ chr)
570 {
571 int i;
572 if (!SCM_STRINGP(str)) SCM_ERR("string-fill: bad string", str);
573 if (!SCM_CHARP(chr)) SCM_ERR("string-fill: bad char", chr);
574
575 for (i = 0; i < SCM_STR_LEN(str); i++) {
576 SCM_STR_VALUE(str)[i] = SCM_CHAR(chr);
577 }
578 return(scm_undefined);
579 }
580
581 /*E* (string-index STRING SEARCHED) => INDEX | #f */
582 /*D* Returns the index of first occurence of the SEARCHED string in
583 STRING. If no occurence of SEARCHED is found, returns #f */
scm_string_index(SOBJ instr,SOBJ ssearch)584 SOBJ scm_string_index(SOBJ instr, SOBJ ssearch)
585 {
586 char *is, *ss, *q;
587 int is_len, ss_len;
588 char sbuf[2]="a";
589
590 if (!SCM_STRINGP(instr)) SCM_ERR("string-index: bad string", instr);
591 is = SCM_STR_VALUE(instr); is_len = SCM_STR_LEN(instr);
592
593 if (SCM_CHARP(ssearch)) {
594 sbuf[0] = SCM_CHAR(ssearch);
595 ss = sbuf; ss_len = 1;
596 } else if (SCM_STRINGP(ssearch)) {
597 ss = SCM_STR_VALUE(ssearch); ss_len = SCM_STR_LEN(ssearch);
598 } else {
599 SCM_ERR("string-index: bad search string", ssearch);
600 return(scm_false);
601 }
602 q = is + (is_len - ss_len);
603 while( is <= q ) {
604 if (memcmp(is, ss, ss_len) == 0)
605 return(SCM_MKINUM((is - SCM_STR_VALUE(instr))));
606 is++;
607 }
608 return(scm_false);
609 }
610
611
612 /*E* (string-chop STR) => STRING */
613 /*D* Modifies STR in such way that everything from the first NEWLINE
614 to the end of line is removed. */
scm_string_chop(SOBJ str)615 SOBJ scm_string_chop(SOBJ str)
616 {
617 char *p, *l;
618
619 if (!SCM_STRINGP(str)) return(str);
620
621 p = SCM_STR_VALUE(str);
622 l = p + SCM_STR_LEN(str);
623 while(p < l) {
624 if (*p == '\n') {
625 *p = 0;
626 SCM_STR_LEN(str) = p - SCM_STR_VALUE(str);
627 break;
628 }
629 p++;
630 }
631 return(str);
632 }
633
634 /*E* (string-split DELIM STRING) => LIST */
635 /*D* Returns a LIST of strings created by splitting STRING at each
636 character that is in the DELIM argument. */
637 /*X* (string-split "." "comp.os.linux") => ("comp" "os" "linux") */
scm_string_split(SOBJ delim,SOBJ str)638 SOBJ scm_string_split(SOBJ delim, SOBJ str)
639 {
640 char *p, *l, *s;
641 SOBJ res, *pn;
642
643 if (!SCM_STRINGP(str)) SCM_ERR("bad string", str);
644 if (!SCM_STRINGP(delim)) SCM_ERR("bad string", delim);
645
646 p = SCM_STR_VALUE(str);
647 l = p + SCM_STR_LEN(str);
648 s = p;
649 res = NULL;
650 pn = &res;
651
652 while(p < l) {
653 if (strchr(SCM_STR_VALUE(delim), *p)) { /* is a delim ? */
654 SOBJ tmp = scm_str_alloc( p - s );
655 strncpy(SCM_STR_VALUE(tmp), s, p - s);
656 SCM_STR_VALUE(tmp)[p-s] = 0;
657 *pn = scm_cons(tmp, NULL);
658 pn = &SCM_CDR(*pn);
659 s = p+1;
660 }
661 p++;
662 }
663 *pn = scm_cons(scm_mkstring(s), NULL);
664 return(res);
665 }
666
667 /*E* (string-join SEP LIST) => STRING */
668 /*D* Return a STRING which is the result of the concatenation of each
669 string of LIST separated by SEP. */
670 /*X* (string-join "." '("comp" "os" "linux")) => "comp.os.linux" */
scm_string_join(SOBJ sep,SOBJ list)671 SOBJ scm_string_join(SOBJ sep, SOBJ list)
672 {
673 SOBJ l;
674 int len, seplen, nstring;
675 char *p;
676 SOBJ str;
677
678 if (!SCM_STRINGP(sep)) SCM_ERR("bad string", sep);
679 len = 0;
680 seplen = SCM_STR_LEN(sep);
681 nstring = 0;
682 for (l = list; l; l = SCM_CDR(l)) {
683 if (!SCM_PAIRP(l)) SCM_ERR("bad list", list);
684 if (!SCM_STRINGP(SCM_CAR(l))) SCM_ERR("bad string", SCM_CAR(l));
685 len += SCM_STR_LEN(SCM_CAR(l));
686 nstring++;
687 }
688 if (nstring > 0) {
689 str = scm_str_alloc(len + ((nstring - 1) * seplen));
690 p = SCM_STR_VALUE(str);
691 for (l = list; l; l = SCM_CDR(l)) {
692 strncpy(p, SCM_STR_VALUE(SCM_CAR(l)), SCM_STR_LEN(SCM_CAR(l)));
693 p += SCM_STR_LEN(SCM_CAR(l));
694 if (SCM_CDR(l)) {
695 strncpy(p, SCM_STR_VALUE(sep), seplen);
696 p += seplen;
697 }
698 }
699 return(str);
700 }
701 return(scm_mkstring(""));
702 }
703
704 /*E* (string-lower STR1) => STRING */
705 /*D* Returns a newly allocated STRING which is a copy of STR1 with all
706 characters converted to lower case */
scm_string_lower(SOBJ str)707 SOBJ scm_string_lower(SOBJ str)
708 {
709 SOBJ new;
710 char *p, *l, *d;
711
712 if (!SCM_STRINGP(str)) SCM_ERR("string-lower: bad string", str);
713
714 new = scm_str_alloc(SCM_STR_LEN(str));
715
716 d = SCM_STR_VALUE(new);
717 p = SCM_STR_VALUE(str);
718 l = p + SCM_STR_LEN(str);
719 while(p < l) {
720 *d = tolower(*p);
721 p++;
722 d++;
723 }
724 *d = 0;
725 return(new);
726 }
727
728 /*E* (string-upper STRING) => STRING */
729 /*D* Returns a newly allocated STRING which is a copy of STR1 with all
730 characters converted to upper case */
scm_string_upper(SOBJ str)731 SOBJ scm_string_upper(SOBJ str)
732 {
733 SOBJ new;
734 char *p, *l, *d;
735
736 if (!SCM_STRINGP(str)) SCM_ERR("string-upper: bad string", str);
737
738 new = scm_str_alloc(SCM_STR_LEN(str));
739
740 d = SCM_STR_VALUE(new);
741 p = SCM_STR_VALUE(str);
742 l = p + SCM_STR_LEN(str);
743 while(p < l) {
744 *d = toupper(*p);
745 p++;
746 d++;
747 }
748 *d = 0;
749 return(new);
750 }
751
752 /*E* (string-translate STR WHAT REPL) => STRING*/
753 /*D* Returns a newly allocated string where all chars of STR having a
754 match in the WHAT string are replaced by the corresponding char in
755 the REPL string. */
756 /*X* (string-translate "comp.os.linux" "." "-") => "comp-os-linux" */
scm_string_translate(SOBJ str,SOBJ fr,SOBJ to)757 SOBJ scm_string_translate(SOBJ str, SOBJ fr, SOBJ to)
758 {
759 SOBJ new;
760 char *p, *q, *fstr, *tstr;
761 if (!SCM_STRINGP(str)) SCM_ERR("bad string", str);
762 if (!SCM_STRINGP(fr)) SCM_ERR("bad string", fr);
763 if (!SCM_STRINGP(to)) SCM_ERR("bad string", to);
764
765 if (SCM_STR_LEN(fr) != SCM_STR_LEN(to))
766 SCM_ERR("length of map string does not match", scm_cons(fr,to));
767
768 fstr = SCM_STR_VALUE(fr);
769 tstr = SCM_STR_VALUE(to);
770
771 new = scm_mkstring(SCM_STR_VALUE(str));
772
773 p = SCM_STR_VALUE(new);
774 while(*p) {
775 if ((q = strchr(fstr, *p)) != NULL) {
776 *p = tstr[ q - fstr ];
777 }
778 p++;
779 }
780 return(new);
781 }
782
783 /*E* (string-pack TEMPLATE OBJ...) => STRING */
784 /*D* Return a new string containing a binary structure. The TEMPLATE
785 is a string giving order and type of value to convert. Values are
786 taken from the list of OBJ. TEMPLATE format is the same as the perl
787 one. */
788
scm_string_pack(int nargs,SOBJ * arg)789 SOBJ scm_string_pack(int nargs, SOBJ *arg)
790 {
791 char *fmt;
792 SOBJ str;
793 int c, rpt;
794
795 if (nargs < 2)
796 SCM_ERR("string-pack: bad number of args", NULL);
797
798 if (!SCM_STRINGP(arg[0]))
799 SCM_ERR("string-pack: bad format", arg[0]);
800
801 str = scm_mkstring(NULL);
802
803 fmt = SCM_STR_VALUE(*arg);
804 arg++; nargs--;
805
806 while(*fmt != 0) {
807 c = *fmt++ & 0xff;
808 if (isspace(c)) continue;
809
810 if (strchr("@xX", c) == NULL && nargs <= 0)
811 SCM_ERR("string-pack: not enough args", NULL);
812
813
814 /* parse optionnal repetition number */
815 if (*fmt != 0 && isdigit((int)(*fmt))) {
816 for (rpt = 0; *fmt != 0 && isdigit((int)(*fmt)); fmt++)
817 rpt = (rpt * 10) + (*fmt - '0');
818
819 } else if (*fmt != 0 && *fmt == '*') {
820 fmt++;
821 rpt = -1;
822 } else {
823 rpt = 1;
824 }
825
826 switch(c) {
827 case 'a': /* string with binary data, pad 0 */
828 case 'A': /* Ascii string, pad ' ' */
829 case 'Z': /* null terminated string, pad 0 */
830 {
831 int alen; /* argument len */
832 int slen; /* string len */
833 int fill;
834
835 if (!SCM_STRINGP(*arg)) SCM_ERR("pack: bad string", *arg);
836
837 alen = SCM_STR_LEN(*arg);
838 slen = SCM_STR_LEN(str);
839
840 if (rpt == -1) rpt = alen;
841
842 fill = rpt - alen;
843 str = scm_str_resize(str, slen + rpt);
844
845 if (fill > 0) { /* have to fill */
846 memcpy(SCM_STR_VALUE(str) + slen, SCM_STR_VALUE(*arg), alen);
847 memset(SCM_STR_VALUE(str) + slen + alen, (c=='A')?' ':0, fill);
848 } else { /* have to trucate */
849 memcpy(SCM_STR_VALUE(str) + slen, SCM_STR_VALUE(*arg), rpt);
850 }
851 arg++;
852 nargs--;
853 }
854 break;
855
856 case 'b': /* bit string (ascending bit order). */
857 {
858 int slen, nbytes, r, i;
859 char *s, *d, *l;
860
861 if (!SCM_STRINGP(*arg)) SCM_ERR("pack: bad string", *arg);
862
863 /* if '*', use arg string length */
864 if (rpt == -1) rpt = SCM_STR_LEN(*arg);
865 nbytes = (rpt + 7) / 8;
866 slen = SCM_STR_LEN(str);
867 str = scm_str_resize(str, slen + nbytes);
868
869 s = SCM_STR_VALUE(*arg);
870 d = SCM_STR_VALUE(str) + slen; l = d + slen + nbytes;
871 while (d < l) {
872 for (r = 0, i = 0; i < 8; i++) {
873 r = r >> 1;
874 if (*s && *s++ != '0') r |= 0x80;
875 }
876 *d++ = r;
877 }
878 break;
879 }
880 case 'B': /* bit string (descending bit order). */
881 {
882 int slen, nbytes, r, i;
883 char *s, *d, *l;
884
885 if (!SCM_STRINGP(*arg)) SCM_ERR("pack: bad string", *arg);
886
887 /* if '*', use arg string length */
888 if (rpt == -1) rpt = SCM_STR_LEN(*arg);
889 nbytes = (rpt + 7) / 8;
890 slen = SCM_STR_LEN(str);
891 str = scm_str_resize(str, slen + nbytes);
892
893 s = SCM_STR_VALUE(*arg);
894 d = SCM_STR_VALUE(str) + slen; l = d + slen + nbytes;
895 while (d < l) {
896 for (r = 0, i = 0; i < 8; i++) {
897 r = r << 1;
898 if (*s && *s++ != '0') r |= 1;
899 }
900 *d++ = r;
901 }
902 break;
903 }
904 case 'h': /* hex string (low nybble first). */
905 {
906 int slen, nbytes, r, i;
907 char *s, *d, *l;
908
909 if (!SCM_STRINGP(*arg)) SCM_ERR("pack: bad string", *arg);
910
911 /* if '*', use arg string length */
912 if (rpt == -1) rpt = SCM_STR_LEN(*arg);
913 nbytes = (rpt + 1) / 2;
914 slen = SCM_STR_LEN(str);
915 str = scm_str_resize(str, slen + nbytes);
916
917 s = SCM_STR_VALUE(*arg);
918 d = SCM_STR_VALUE(str) + slen; l = d + slen + nbytes;
919 while (d < l) {
920 r = 0;
921 if (*s && (i = *s++) && isxdigit(i)) r |= xdigit2nibble(i);
922 if (*s && (i = *s++) && isxdigit(i)) r |= (xdigit2nibble(i) << 4);
923 *d++ = r;
924 }
925 break;
926 }
927
928 case 'H': /* hex string (high nybble first). */
929 {
930 int slen, nbytes, r, i;
931 char *s, *d, *l;
932
933 if (!SCM_STRINGP(*arg)) SCM_ERR("pack: bad string", *arg);
934
935 /* if '*', use arg string length */
936 if (rpt == -1) rpt = SCM_STR_LEN(*arg);
937 nbytes = (rpt + 1) / 2;
938 slen = SCM_STR_LEN(str);
939 str = scm_str_resize(str, slen + nbytes);
940
941 s = SCM_STR_VALUE(*arg);
942 d = SCM_STR_VALUE(str) + slen; l = d + slen + nbytes;
943 while (d < l) {
944 r = 0;
945 if (*s && isxdigit( (i = *s++) )) r |= (xdigit2nibble(i) << 4);
946 if (*s && isxdigit( (i = *s++) )) r |= xdigit2nibble(i);
947 *d++ = r;
948 }
949 break;
950 }
951
952 case 'c': /* signed char value */
953 case 'C': /* unsigned char value */
954 if (rpt == -1) rpt = nargs;
955 if (rpt > nargs) SCM_ERR("string-pack: bad number of args",NULL);
956
957 while(rpt-- > 0) {
958 str = scm_strcat_chr(str, scm_number2long(*arg));
959 arg++; nargs--;
960 }
961 break;
962
963 case 's': /* signed short value */
964 case 'S': /* unsigned short value */
965 if (rpt == -1) rpt = nargs;
966 if (rpt > nargs) SCM_ERR("string-pack: bad number of args",NULL);
967
968 while(rpt-- > 0) {
969 short n;
970 n = scm_number2long(*arg);
971 str = scm_strcat_buf(str, (void*)&n, sizeof(n));
972 arg++; nargs--;
973 }
974 break;
975
976 case 'i': /* signed integer value */
977 case 'I': /* unsigned integer value */
978 if (rpt == -1) rpt = nargs;
979 if (rpt > nargs) SCM_ERR("string-pack: bad number of args",NULL);
980
981 while(rpt-- > 0) {
982 int n;
983 n = scm_number2long(*arg);
984 str = scm_strcat_buf(str, (void*)&n, sizeof(n));
985 arg++; nargs--;
986 }
987 break;
988
989 case 'l': /* signed long value */
990 case 'L': /* An unsigned long value */
991 if (rpt == -1) rpt = nargs;
992 if (rpt > nargs) SCM_ERR("string-pack: bad number of args",NULL);
993
994 while(rpt-- > 0) {
995 long n;
996 n = scm_number2long(*arg);
997 str = scm_strcat_buf(str, (void*)&n, sizeof(n));
998 arg++; nargs--;
999 }
1000 break;
1001
1002 case 'n': /* short "network" (big-endian) 16b */
1003 if (rpt == -1) rpt = nargs;
1004 if (rpt > nargs) SCM_ERR("string-pack: bad number of args",NULL);
1005
1006 while(rpt-- > 0) {
1007 short n;
1008 n = scm_number2long(*arg);
1009 str = scm_strcat_chr(str, n >> 8);
1010 str = scm_strcat_chr(str, n);
1011 arg++; nargs--;
1012 }
1013 break;
1014
1015
1016 case 'N': /* long "network" (big-endian) 32b */
1017 if (rpt == -1) rpt = nargs;
1018 if (rpt > nargs) SCM_ERR("string-pack: bad number of args",NULL);
1019
1020 while(rpt-- > 0) {
1021 long n;
1022 n = scm_number2long(*arg);
1023 str = scm_strcat_chr(str, n >> 24);
1024 str = scm_strcat_chr(str, n >> 16);
1025 str = scm_strcat_chr(str, n >> 8);
1026 str = scm_strcat_chr(str, n);
1027 arg++; nargs--;
1028 }
1029 break;
1030
1031 case 'v': /* short "VAX" (little-endian) 16b */
1032 if (rpt == -1) rpt = nargs;
1033 if (rpt > nargs) SCM_ERR("string-pack: bad number of args",NULL);
1034
1035 while(rpt-- > 0) {
1036 short n;
1037 n = scm_number2long(*arg);
1038 str = scm_strcat_chr(str, n);
1039 str = scm_strcat_chr(str, n >> 8);
1040 arg++; nargs--;
1041 }
1042 break;
1043
1044 case 'V': /* long "VAX" (little-endian) 32b */
1045 if (rpt == -1) rpt = nargs;
1046 if (rpt > nargs) SCM_ERR("string-pack: bad number of args",NULL);
1047
1048 while(rpt-- > 0) {
1049 long n;
1050 n = scm_number2long(*arg);
1051 str = scm_strcat_chr(str, n);
1052 str = scm_strcat_chr(str, n >> 8);
1053 str = scm_strcat_chr(str, n >> 16);
1054 str = scm_strcat_chr(str, n >> 24);
1055 arg++; nargs--;
1056 }
1057 break;
1058
1059 case 'q': /* signed quad (64-bit) value. */
1060 case 'Q': /* unsigned quad value. */
1061 SCM_ERR("string-pack: q and q not supported in format",NULL);
1062
1063 case 'f': /* single-precision native float */
1064 if (rpt == -1) rpt = nargs;
1065 if (rpt > nargs) SCM_ERR("string-pack: bad number of args",NULL);
1066
1067 while(rpt-- > 0) {
1068 float n;
1069 n = scm_number2double(*arg);
1070 str = scm_strcat_buf(str, (void*)&n, sizeof(n));
1071 arg++; nargs--;
1072 }
1073 break;
1074
1075 case 'd': /* double-precision native float */
1076 if (rpt == -1) rpt = nargs;
1077 if (rpt > nargs) SCM_ERR("string-pack: bad number of args",NULL);
1078
1079 while(rpt-- > 0) {
1080 double n;
1081 n = scm_number2double(*arg);
1082 str = scm_strcat_buf(str, (void*)&n, sizeof(n));
1083 arg++; nargs--;
1084 }
1085 break;
1086
1087 case 'x': /* null byte */
1088 while(rpt-- > 0) {
1089 str = scm_strcat_chr(str, 0);
1090 }
1091 break;
1092
1093 case 'X': /* delete a byte */
1094 if (rpt > 0) {
1095 if (SCM_STR_LEN(str) < rpt) {
1096 SCM_STR_LEN(str) = 0;
1097 } else {
1098 SCM_STR_LEN(str) -= rpt;
1099 }
1100 }
1101 break;
1102
1103 case 'p': /* pointer to null terminated string */
1104 case 'P': /* pointer to fixed-length string */
1105 {
1106 void *p;
1107 while(rpt-- > 0) {
1108 p = scm_getstr(*arg);
1109 str = scm_strcat_buf(str, (void*)&p, sizeof(p));
1110 arg++; nargs--;
1111 }
1112 }
1113 break;
1114
1115 case 'u': /* uuencoded string */
1116 case 'w': /* BER int */
1117 case '@': /* Null fill to absolute position */
1118 SCM_ERR("string-pack: unsupported char in format", scm_mkchar(c));
1119 }
1120 }
1121 SCM_STR_VALUE(str)[SCM_STR_LEN(str)] = 0;
1122 return(str);
1123 }
1124
1125 /*E* (string-unpack TEMPLATE STRING) => LIST */
1126 /*D* Unpack a string containing a binary structure to a list of
1127 elements. Convertions is driven by the content of the TEMPLATE
1128 string */
1129
scm_string_unpack(SOBJ tmpl,SOBJ string)1130 SOBJ scm_string_unpack(SOBJ tmpl, SOBJ string)
1131 {
1132 SOBJ l, *cdrp,new;
1133 char *fmt, *str, *slimit;
1134 int c, rpt, slen;
1135
1136 if (!SCM_STRINGP(tmpl)) SCM_ERR("string-unpack: bad template", tmpl);
1137 if (!SCM_STRINGP(string)) SCM_ERR("string-unpack: bad string", string);
1138
1139 l = NULL; new = NULL;
1140 cdrp = &l;
1141 fmt = SCM_STR_VALUE(tmpl);
1142 str = SCM_STR_VALUE(string);
1143 slen = SCM_STR_LEN(string);
1144 slimit = str + slen;
1145
1146 while(*fmt != 0) {
1147 c = *fmt++ & 0xff;
1148 if (isspace(c)) continue;
1149
1150 /* parse optionnal repetition number */
1151 if (*fmt != 0 && isdigit((int)(*fmt))) {
1152 for (rpt = 0; *fmt != 0 && isdigit((int)(*fmt)); fmt++)
1153 rpt = (rpt * 10) + (*fmt - '0');
1154 } else if (*fmt != 0 && *fmt == '*') {
1155 fmt++;
1156 rpt = -1;
1157 } else {
1158 rpt = 1;
1159 }
1160 switch(c) {
1161 case 'x': /* null bytes */
1162 while(--rpt >= 0 && str < slimit) {
1163 str++;
1164 }
1165 continue;
1166 case 'X': /* ignored */
1167 case '@':
1168 continue;
1169
1170 case 'a':
1171 case 'A':
1172 case 'Z':
1173 {
1174 char *p, *l;
1175
1176 l = (rpt == -1) ? slimit : str + rpt;
1177 if (l > slimit) l = slimit;
1178 if (c == 'Z') {
1179 for (p = str; p < l && *p != 0; p++) ;
1180 l = p;
1181 }
1182 new = scm_str_alloc(l - str);
1183 memcpy(SCM_STR_VALUE(new), str, l - str);
1184 SCM_STR_VALUE(new)[SCM_STR_LEN(new)] = 0;
1185 str = l;
1186 break;
1187 }
1188 case 'b':
1189 case 'B':
1190 {
1191 char *p, *l, *d;
1192 int n, i, nbytes;
1193
1194 if (rpt == -1) rpt = (slimit - str) * 8;
1195 nbytes = (rpt + 7) / 8;
1196 new = scm_str_alloc(rpt);
1197 p = str; l = str + nbytes; d = SCM_STR_VALUE(new);
1198 if (l > slimit) l = slimit;
1199 while(p < l) {
1200 n = *p++;
1201 for (i = 0; i < 8 && --rpt >= 0; i++) {
1202 if (c == 'b') {
1203 *d++ = (n & 0x01) ? '1' : '0'; n >>= 1;
1204 } else {
1205 *d++ = (n & 0x80) ? '1' : '0'; n <<= 1;
1206 }
1207 }
1208 }
1209 *d = 0; str = l;
1210 break;
1211 }
1212 case 'h': /* hex digit (low nibble first).*/
1213 case 'H': /* hex digit (high nibble first). */
1214 {
1215 char *d, *p, *l;
1216 int n, nbytes;
1217 if (rpt == -1) rpt = (slimit - str) * 2;
1218 nbytes = (rpt + 1) / 2;
1219 new = scm_str_alloc(rpt);
1220 p = str; l = str + rpt; d = SCM_STR_VALUE(new);
1221 if (l > slimit) l = slimit;
1222 while(p < l) {
1223 n = *p++;
1224 if (c == 'h') {
1225 if (--rpt >= 0) { *d++ = nibble2xdigit(n); }
1226 if (--rpt >= 0) { *d++ = nibble2xdigit(n>>4); }
1227 } else {
1228 if (--rpt >= 0) { *d++ = nibble2xdigit(n>>4); }
1229 if (--rpt >= 0) { *d++ = nibble2xdigit(n); }
1230 }
1231 }
1232 *d = 0; str = l;
1233 }
1234 break;
1235 case 'c': /* signed char */
1236 case 'C': /* unsigned char */
1237 {
1238 char *l;
1239 int n;
1240 if (rpt == -1) {
1241 l = slimit;
1242 } else {
1243 if ((l = str + rpt) > slimit) l = slimit;
1244 }
1245 while(str < l) {
1246 n = *str++;
1247 if (c == 'C') n &= 0xff;
1248 *cdrp = scm_cons(SCM_MKINUM(c), NULL);
1249 cdrp = &(SCM_CDR(*cdrp));
1250 }
1251 continue;
1252 }
1253 case 's': /* signed short */
1254 case 'S': /* unsigned short */
1255 {
1256 char *l;
1257 short n;
1258 if (rpt == -1) {
1259 l = slimit;
1260 } else {
1261 if ((l = str + (rpt * sizeof(n))) > slimit) l = slimit;
1262 }
1263 while(str < l) {
1264 memcpy(&n, str, sizeof(n)); str += sizeof(n);
1265 new = SCM_MKINUM( (c == 'S') ? ((unsigned int)n) : n );
1266 *cdrp = scm_cons(new, NULL);
1267 cdrp = &(SCM_CDR(*cdrp));
1268 }
1269 continue;
1270 }
1271 case 'i': /* signed int */
1272 {
1273 char *l;
1274 int n;
1275 if (rpt == -1) {
1276 l = slimit;
1277 } else {
1278 if ((l = str + (rpt * sizeof(n))) > slimit) l = slimit;
1279 }
1280 while(str < l) {
1281 memcpy(&n, str, sizeof(n)); str += sizeof(n);
1282 *cdrp = scm_cons(scm_int2num(n), NULL);
1283 cdrp = &(SCM_CDR(*cdrp));
1284 }
1285 continue;
1286 }
1287 case 'I': /* unsigned int */
1288 {
1289 char *l;
1290 unsigned int n;
1291 if (rpt == -1) {
1292 l = slimit;
1293 } else {
1294 if ((l = str + (rpt * sizeof(n))) > slimit) l = slimit;
1295 }
1296 while(str < l) {
1297 memcpy(&n, str, sizeof(n)); str += sizeof(n);
1298 *cdrp = scm_cons(scm_uint2num(n), NULL);
1299 cdrp = &(SCM_CDR(*cdrp));
1300 }
1301 continue;
1302 }
1303
1304 case 'l': /* signed long */
1305 {
1306 char *l;
1307 long n;
1308 if (rpt == -1) {
1309 l = slimit;
1310 } else {
1311 if ((l = str + (rpt * sizeof(n))) > slimit) l = slimit;
1312 }
1313 while(str < l) {
1314 memcpy(&n, str, sizeof(n)); str += sizeof(n);
1315 *cdrp = scm_cons(scm_int2num(n), NULL);
1316 cdrp = &(SCM_CDR(*cdrp));
1317 }
1318 continue;
1319 }
1320 case 'L': /* unsigned long */
1321 {
1322 char *l;
1323 unsigned long n;
1324 if (rpt == -1) {
1325 l = slimit;
1326 } else {
1327 if ((l = str + (rpt * sizeof(n))) > slimit) l = slimit;
1328 }
1329 while(str < l) {
1330 memcpy(&n, str, sizeof(n)); str += sizeof(n);
1331 *cdrp = scm_cons(scm_uint2num(n), NULL);
1332 cdrp = &(SCM_CDR(*cdrp));
1333 }
1334 continue;
1335 }
1336 case 'n':
1337 {
1338 char *l;
1339 unsigned short n;
1340 if (rpt == -1) {
1341 l = slimit;
1342 } else {
1343 if ((l = str + (rpt * sizeof(n))) > slimit) l = slimit;
1344 }
1345 while(str < l) {
1346 n = (*str++ & 0xff) << 8;
1347 n |= (*str++ & 0xff);
1348 *cdrp = scm_cons(scm_uint2num(n), NULL);
1349 cdrp = &(SCM_CDR(*cdrp));
1350 }
1351 continue;
1352 }
1353 case 'N':
1354 {
1355 char *l;
1356 unsigned long n;
1357 if (rpt == -1) {
1358 l = slimit;
1359 } else {
1360 if ((l = str + (rpt * sizeof(n))) > slimit) l = slimit;
1361 }
1362 while(str < l) {
1363 n = (*str++ & 0xff) << 24;
1364 n |= (*str++ & 0xff) << 16;
1365 n |= (*str++ & 0xff) << 8;
1366 n |= (*str++ & 0xff);
1367 *cdrp = scm_cons(scm_uint2num(n), NULL);
1368 cdrp = &(SCM_CDR(*cdrp));
1369 }
1370 continue;
1371 }
1372 case 'v':
1373 {
1374 char *l;
1375 unsigned short n;
1376 if (rpt == -1) {
1377 l = slimit;
1378 } else {
1379 if ((l = str + (rpt * sizeof(n))) > slimit) l = slimit;
1380 }
1381 while(str < l) {
1382 n = (*str++ & 0xff);
1383 n |= (*str++ & 0xff) << 8;
1384 *cdrp = scm_cons(scm_uint2num(n), NULL);
1385 cdrp = &(SCM_CDR(*cdrp));
1386 }
1387 continue;
1388 }
1389 case 'V':
1390 {
1391 char *l;
1392 unsigned long n;
1393 if (rpt == -1) {
1394 l = slimit;
1395 } else {
1396 if ((l = str + (rpt * sizeof(n))) > slimit) l = slimit;
1397 }
1398 while(str < l) {
1399 n = (*str++ & 0xff);
1400 n |= (*str++ & 0xff) << 8;
1401 n |= (*str++ & 0xff) << 16;
1402 n |= (*str++ & 0xff) << 24;
1403 *cdrp = scm_cons(scm_uint2num(n), NULL);
1404 cdrp = &(SCM_CDR(*cdrp));
1405 }
1406 continue;
1407 }
1408 case 'f': /* float number */
1409 {
1410 char *l;
1411 float n;
1412 if (rpt == -1) {
1413 l = slimit;
1414 } else {
1415 if ((l = str + (rpt * sizeof(n))) > slimit) l = slimit;
1416 }
1417 while(str < l) {
1418 memcpy(&n, str, sizeof(n)); str += sizeof(n);
1419 *cdrp = scm_cons(scm_flt2num(n),NULL);
1420 cdrp = &(SCM_CDR(*cdrp));
1421 }
1422 continue;
1423 }
1424
1425 case 'd': /* double number */
1426 {
1427 char *l;
1428 double n;
1429 if (rpt == -1) {
1430 l = slimit;
1431 } else {
1432 if ((l = str + (rpt * sizeof(n))) > slimit) l = slimit;
1433 }
1434 while(str < l) {
1435 memcpy(&n, str, sizeof(n)); str += sizeof(n);
1436 *cdrp = scm_cons(scm_flt2num(n),NULL);
1437 cdrp = &(SCM_CDR(*cdrp));
1438 }
1439 continue;
1440 }
1441
1442 case 'p': /* null terminated string */
1443 {
1444 char *p;
1445 while(--rpt >= 0) {
1446 if (str + sizeof(p) >= slimit) break;
1447 memcpy(&p, str, sizeof(p)); str += sizeof(p);
1448 *cdrp = scm_cons(scm_mkstring(p),NULL);
1449 cdrp = &(SCM_CDR(*cdrp));
1450 }
1451 continue;
1452 }
1453 case 'P': /* structure */
1454 {
1455 void *p;
1456 if (rpt >= 0 && (str + sizeof(p)) < slimit) {
1457 memcpy(&p, str, sizeof(p)); str += sizeof(p);
1458 new = scm_str_alloc(rpt);
1459 memcpy(SCM_STR_VALUE(new), p, rpt);
1460 *cdrp = scm_cons(new, NULL);
1461 cdrp = &(SCM_CDR(*cdrp));
1462 }
1463 continue;
1464 }
1465
1466 default:
1467 SCM_ERR("string-unpack: unknow type char", scm_mkchar(c));
1468 }
1469 *cdrp = scm_cons(new, NULL);
1470 cdrp = &(SCM_CDR(*cdrp));
1471 }
1472 return(l);
1473 }
1474
1475 /*E* (string-resize! STR LEN) => STR */
1476 /*D* Change the size of the string STR to LEN. Returns the STR. */
scm_string_resize(SOBJ str,SOBJ len)1477 SOBJ scm_string_resize(SOBJ str, SOBJ len)
1478 {
1479 if (!SCM_INUMP(len)) SCM_ERR("string-resize!: bad length", len);
1480 return(scm_str_resize(str, SCM_INUM(len)));
1481 }
1482
scm_init_str()1483 void scm_init_str()
1484 {
1485 /*-- r5rs string */
1486 scm_add_cprim("string?", scm_stringp, 1);
1487 scm_add_cprim("make-string", scm_make_string, -1);
1488 scm_add_cprim("make-string2", scm_make_string2, 2);
1489 scm_add_cprim("string", scm_string, -1);
1490 scm_add_cprim("string-length", scm_string_length, 1);
1491 scm_add_cprim("string-ref", scm_string_ref, 2);
1492 scm_add_cprim("string-set!", scm_string_set, 3);
1493
1494 scm_add_cprim("string<?", scm_string_lt, 2);
1495 scm_add_cprim("string<=?", scm_string_le, 2);
1496 scm_add_cprim("string=?", scm_string_eq, 2);
1497 scm_add_cprim("string>=?", scm_string_ge, 2);
1498 scm_add_cprim("string>?", scm_string_gt, 2);
1499
1500 scm_add_cprim("string-ci<?", scm_string_ci_lt, 2);
1501 scm_add_cprim("string-ci<=?", scm_string_ci_le, 2);
1502 scm_add_cprim("string-ci=?", scm_string_ci_eq, 2);
1503 scm_add_cprim("string-ci>=?", scm_string_ci_ge, 2);
1504 scm_add_cprim("string-ci>?", scm_string_ci_gt, 2);
1505
1506 scm_add_cprim("substring", scm_substring, 3);
1507 scm_add_cprim("string-append", scm_string_append, -1);
1508
1509 scm_add_cprim("string->list", scm_string_to_list, 1);
1510 scm_add_cprim("list->string", scm_list_to_string, 1);
1511 scm_add_cprim("string->symbol", scm_string_to_symbol, 1);
1512 scm_add_cprim("symbol->string", scm_symbol_to_string, 1);
1513 scm_add_cprim("string-copy", scm_string_copy, 1);
1514 scm_add_cprim("string-fill!", scm_string_fill, 2);
1515
1516 /*-- string extensions */
1517
1518 scm_add_cprim("string-append2", scm_string_append2, 2);
1519 scm_add_cprim("string-append-char", scm_string_append_char, 2);
1520 scm_add_cprim("string-concat!", scm_string_concat, 2);
1521
1522 scm_add_cprim("string-index", scm_string_index, 2);
1523 scm_add_cprim("string-chop", scm_string_chop, 1);
1524 scm_add_cprim("string-split", scm_string_split, 2);
1525 scm_add_cprim("string-join", scm_string_join, 2);
1526 scm_add_cprim("string-lower", scm_string_lower, 1);
1527 scm_add_cprim("string-upper", scm_string_upper, 1);
1528 scm_add_cprim("string-translate", scm_string_translate, 3);
1529
1530 scm_add_cprim("string-pack", scm_string_pack, -1);
1531 scm_add_cprim("string-unpack", scm_string_unpack, 2);
1532 scm_add_cprim("string-resize!", scm_string_resize, 2);
1533 }
1534