1 /* string.c -*- mode:c; coding:utf-8; -*-
2 *
3 * Copyright (c) 2010-2021 Takashi Kato <ktakashi@ymail.com>
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 *
9 * 1. Redistributions of source code must retain the above copyright
10 * notice, this list of conditions and the following disclaimer.
11 *
12 * 2. Redistributions in binary form must reproduce the above copyright
13 * notice, this list of conditions and the following disclaimer in the
14 * documentation and/or other materials provided with the distribution.
15 *
16 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
17 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
18 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
19 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
20 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
21 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
22 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
23 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
24 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
25 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
26 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27 *
28 * $Id: $
29 */
30 #include <string.h>
31 #define LIBSAGITTARIUS_BODY
32 #include "sagittarius/private/string.h"
33 #include "sagittarius/private/collection.h"
34 #include "sagittarius/private/hashtable.h"
35 #include "sagittarius/private/unicode.h"
36 #include "sagittarius/private/pair.h"
37 #include "sagittarius/private/port.h"
38 #include "sagittarius/private/error.h"
39 #include "sagittarius/private/number.h"
40 #include "sagittarius/private/symbol.h"
41 #include "sagittarius/private/thread.h"
42 #include "sagittarius/private/values.h"
43 #include "sagittarius/private/writer.h"
44
string_print(SgObject o,SgPort * port,SgWriteContext * ctx)45 static void string_print(SgObject o, SgPort *port, SgWriteContext *ctx)
46 {
47 SgString *obj = SG_STRING(o);
48 SG_PORT_LOCK_WRITE(port);
49 if (SG_WRITE_MODE(ctx) == SG_WRITE_DISPLAY) {
50 Sg_PutsUnsafe(port, obj);
51 } else {
52 SgChar *s = obj->value;
53 long i, size = obj->size;
54 Sg_PutcUnsafe(port, '"');
55 for (i = 0; i < size; i++) {
56 SgChar ch = s[i];
57 switch (ch) {
58 case '\\':
59 Sg_PutcUnsafe(port, '\\'); Sg_PutcUnsafe(port, '\\');
60 break;
61 case '\n':
62 Sg_PutcUnsafe(port, '\\'); Sg_PutcUnsafe(port, 'n');
63 break;
64 case '\a':
65 Sg_PutcUnsafe(port, '\\'); Sg_PutcUnsafe(port, 'a');
66 break;
67 case '\b':
68 Sg_PutcUnsafe(port, '\\'); Sg_PutcUnsafe(port, 'b');
69 break;
70 case '\t':
71 Sg_PutcUnsafe(port, '\\'); Sg_PutcUnsafe(port, 't');
72 break;
73 case '\v':
74 Sg_PutcUnsafe(port, '\\'); Sg_PutcUnsafe(port, 'v');
75 break;
76 case '\r':
77 Sg_PutcUnsafe(port, '\\'); Sg_PutcUnsafe(port, 'r');
78 break;
79 case '\f':
80 Sg_PutcUnsafe(port, '\\'); Sg_PutcUnsafe(port, 'f');
81 break;
82 case '\"':
83 Sg_PutcUnsafe(port, '\\'); Sg_PutcUnsafe(port, '\"');
84 break;
85 default:
86 {
87 const int ASCII_SPC = 0x20;
88 const int ASCII_DEL = 0x7f;
89 if ((ch != 0xa && ch != 0xd && ch < ASCII_SPC) ||
90 ch == ASCII_DEL ||
91 ch == 0x80 ||
92 /* Issue #256, ÿ should have printed as it is */
93 /* ch == 0xff || */
94 ch == 0xD7FF ||
95 ch == 0xE000 ||
96 ch == 0x10FFFF) { // todo
97 char buf[32];
98 snprintf(buf, sizeof(buf), "\\x%X;", ch);
99 Sg_PutzUnsafe(port, buf);
100 } else {
101 Sg_PutcUnsafe(port, ch);
102 }
103 }
104 }
105 }
106 Sg_PutcUnsafe(port, '"');
107 }
108 SG_PORT_UNLOCK_WRITE(port);
109 }
110
111 SG_DEFINE_BUILTIN_CLASS(Sg_StringClass, string_print, NULL, NULL, NULL,
112 SG_CLASS_SEQUENCE_CPL);
113
114 #define ALLOC_TEMP_STRING SG_ALLOC_TEMP_STRING
115
make_string(long size)116 static SgString* make_string(long size)
117 {
118 SgString *z = SG_NEW_ATOMIC2(SgString *, SG_STRING_ALLOC_SIZE(size));
119 SG_SET_CLASS(z, SG_CLASS_STRING);
120 z->size = size;
121 z->immutablep = FALSE;
122 return z;
123 }
124
125 #define COPY_STRING(ret, src, size, offset) \
126 do { \
127 long i; \
128 for (i = 0; i < (size); i++) { \
129 ((ret)->value)[i + (offset)] = (src[i]); \
130 } \
131 } while (0)
132
133 static SgInternalMutex smutex;
134
135 #include "gc-incl.inc"
136
137 #ifdef USE_WEAK_STRING
138 # include "sagittarius/weak.h"
139 # define Sg_HashTableRef Sg_WeakHashTableRef
140 # define Sg_HashTableSet Sg_WeakHashTableSet
141 static SgWeakHashTable *stable = NULL;
142 #else
143 static SgHashTable *stable = NULL;
144 #endif
145
makestring(const SgChar * value,SgStringType flag,long length)146 static SgObject makestring(const SgChar *value, SgStringType flag, long length)
147 {
148 SgObject r;
149 SgString *z;
150
151 if (flag == SG_LITERAL_STRING) {
152 SgString *tmp;
153 Sg_LockMutex(&smutex);
154 ALLOC_TEMP_STRING(tmp, length);
155 COPY_STRING(tmp, value, length, 0);
156 r = Sg_HashTableRef(stable, SG_OBJ(tmp), SG_FALSE);
157 Sg_UnlockMutex(&smutex);
158 if (!SG_FALSEP(r)) {
159 ASSERT(SG_STRINGP(r));
160 return r;
161 }
162 }
163
164 z = make_string(length);
165 COPY_STRING(z, value, z->size, 0);
166 z->value[z->size] = 0;
167
168 if (flag == SG_LITERAL_STRING || flag == SG_IMMUTABLE_STRING) {
169 z->immutablep = TRUE;
170 }
171 /* store it if it's literal */
172 if (flag == SG_LITERAL_STRING) {
173 Sg_LockMutex(&smutex);
174 r = Sg_HashTableSet(stable, SG_OBJ(z), SG_OBJ(z),
175 SG_HASH_NO_OVERWRITE);
176 Sg_UnlockMutex(&smutex);
177 } else {
178 r = SG_OBJ(z);
179 }
180 return r;
181 }
182
Sg_MakeString(const SgChar * value,SgStringType flag,long length)183 SgObject Sg_MakeString(const SgChar *value, SgStringType flag, long length)
184 {
185 if (length < 0) {
186 long len = (long)ustrlen(value);
187 return makestring(value, flag, len);
188 } else {
189 return makestring(value, flag, length);
190 }
191 }
192
193 /* This method assumes given value as ASCII for now */
Sg_MakeStringC(const char * value)194 SgObject Sg_MakeStringC(const char *value)
195 {
196 SgString *z;
197 z = make_string((long)strlen(value));
198 COPY_STRING(z, value, z->size, 0);
199 z->value[z->size] = 0;
200 return SG_OBJ(z);
201 }
202
Sg_ReserveString(long size,SgChar fill)203 SgObject Sg_ReserveString(long size, SgChar fill)
204 {
205 SgString *z = make_string(size);
206 long i;
207 for (i = 0; i < size; i++) {
208 z->value[i] = fill;
209 }
210 z->value[size] = 0;
211 return SG_OBJ(z);
212 }
213
Sg_MakeEmptyString()214 SgObject Sg_MakeEmptyString()
215 {
216 SgString *z = make_string(0);
217 return SG_OBJ(z);
218 }
219
Sg_LiteralStringP(SgString * s)220 int Sg_LiteralStringP(SgString *s)
221 {
222 /* TODO should we lock the table? */
223 SgObject r;
224 Sg_LockMutex(&smutex);
225 r = Sg_HashTableRef(stable, SG_OBJ(s), SG_FALSE);
226 Sg_UnlockMutex(&smutex);
227 return SG_EQ(s, r);
228 }
229 /* converts given string to immutable string if it's not */
Sg_StringToIString(SgString * s,long start,long end)230 SgObject Sg_StringToIString(SgString *s, long start, long end)
231 {
232 SgObject r;
233 long size = SG_STRING_SIZE(s);
234 SG_CHECK_START_END(start, end, size);
235
236 if (start == 0 && end == size && SG_IMMUTABLE_STRINGP(s)) return s;
237
238 r = Sg_Substring(s, start, end);
239 SG_STRING(r)->immutablep = TRUE;
240 return r;
241 }
242 /* mostly for cache */
Sg_StringIntern(SgString * s)243 SgObject Sg_StringIntern(SgString *s)
244 {
245 SgObject r;
246 Sg_LockMutex(&smutex);
247 r = Sg_HashTableRef(stable, SG_OBJ(s), SG_FALSE);
248 if (SG_FALSEP(r)) {
249 SG_STRING(r)->immutablep = TRUE;
250 r = Sg_HashTableSet(stable, SG_OBJ(r), SG_OBJ(r),
251 SG_HASH_NO_OVERWRITE);
252 }
253 Sg_UnlockMutex(&smutex);
254 return r;
255 }
256
257
string_equal(SgChar * s1,long size1,SgChar * s2,long size2)258 static int string_equal(SgChar *s1, long size1, SgChar *s2, long size2)
259 {
260 if (size1 != size2) return FALSE;
261 else {
262 long i;
263 for (i = 0; i < size1; i++) {
264 if (s1[i] != s2[i]) return FALSE;
265 }
266 }
267 return TRUE;
268 }
269
Sg_StringEqual(SgString * s1,SgString * s2)270 int Sg_StringEqual(SgString *s1, SgString *s2)
271 {
272 return string_equal(s1->value, s1->size, s2->value, s2->size);
273 }
274
string_compare_rec(SgString * s1,SgString * s2,long len)275 static inline int string_compare_rec(SgString *s1, SgString *s2, long len)
276 {
277 long i;
278 for (i = 0; i < len; i++) {
279 if (SG_STRING_VALUE_AT(s1, i) > SG_STRING_VALUE_AT(s2, i)) {
280 return 1;
281 } else if (SG_STRING_VALUE_AT(s1, i) < SG_STRING_VALUE_AT(s2, i)) {
282 return -1;
283 }
284 }
285 return 0;
286 }
287
Sg_StringCompare(SgString * s1,SgString * s2)288 int Sg_StringCompare(SgString *s1, SgString *s2)
289 {
290 long s1_len = SG_STRING_SIZE(s1);
291 long s2_len = SG_STRING_SIZE(s2);
292 long len = (s1_len > s2_len) ? s2_len : s1_len;
293 int result = string_compare_rec(s1, s2, len);
294 if (result == 0) {
295 if (s1_len == s2_len) return 0;
296 else if (s1_len > s2_len) return 1;
297 else return -1;
298 } else {
299 return result;
300 }
301 }
302
Sg_StringAppend2(SgString * a,SgString * b)303 SgObject Sg_StringAppend2(SgString *a, SgString *b)
304 {
305 SgString *z = make_string(a->size + b->size);
306 COPY_STRING(z, a->value, a->size, 0);
307 COPY_STRING(z, b->value, b->size, a->size);
308 z->value[a->size + b->size] = '\0';
309 return SG_OBJ(z);
310 }
311
Sg_StringAppendC(SgString * a,const SgChar * s,long sizey)312 SgObject Sg_StringAppendC(SgString *a, const SgChar *s, long sizey)
313 {
314 long sizex = a->size;
315 SgString *p = make_string(sizex + sizey);
316 /* manual copy */
317 COPY_STRING(p, a->value, sizex, 0);
318 COPY_STRING(p, s, sizey, sizex);
319 p->value[sizex + sizey] = '\0';
320
321 return SG_OBJ(p);
322 }
323
Sg_StringAppend(SgObject args)324 SgObject Sg_StringAppend(SgObject args)
325 {
326 long len = 0, off = 0;
327 SgObject cp;
328 SgString *r;
329 /* calculate length */
330 SG_FOR_EACH(cp, args) {
331 if (!SG_STRINGP(SG_CAR(cp))) {
332 Sg_Error(UC("string required, but got %S"), SG_CAR(cp));
333 }
334 len += SG_STRING(SG_CAR(cp))->size;
335 }
336 if (!SG_NULLP(cp)) {
337 Sg_Error(UC("improper list is not allowed"), args);
338 }
339 r = make_string(len);
340 /* append */
341 SG_FOR_EACH(cp, args) {
342 COPY_STRING(r, SG_STRING(SG_CAR(cp))->value,
343 SG_STRING(SG_CAR(cp))->size, off);
344 off += SG_STRING(SG_CAR(cp))->size;
345 }
346 r->value[len] = 0;
347 return SG_OBJ(r);
348 }
349
Sg_StringToList(SgString * s,long start,long end)350 SgObject Sg_StringToList(SgString *s, long start, long end)
351 {
352 long size = SG_STRING_SIZE(s), i;
353 const SgChar *buf = SG_STRING_VALUE(s);
354 SgObject h = SG_NIL, t = SG_NIL;
355 SG_CHECK_START_END(start, end, size);
356 for (i = start; i < end; i++) {
357 SG_APPEND1(h, t, SG_MAKE_CHAR(buf[i]));
358 }
359 return h;
360 }
361
Sg_ListToString(SgObject chars,long start,long end)362 SgObject Sg_ListToString(SgObject chars, long start, long end)
363 {
364 SgObject cp, r;
365 long len = 0, i;
366 SgChar *buf;
367
368 if (start < 0 || (end >= 0 && start > end)) {
369 Sg_Error(UC("argument out of range (start %d, end %d)"), start, end);
370 }
371
372 i = start;
373 chars = Sg_ListTail(chars, start, SG_UNBOUND);
374 SG_FOR_EACH(cp, chars) {
375 if (end >= 0 && i == end) break;
376 if (!SG_CHARP(SG_CAR(cp))) {
377 Sg_Error(UC("character required, but got %S"), SG_CAR(cp));
378 }
379 len++;
380 i++;
381 }
382 if (len < (end - start)) {
383 Sg_Error(UC("list is too short %S"), chars);
384 }
385
386 r = make_string(len);
387 buf = SG_STRING_VALUE(r);
388 i = start;
389 SG_FOR_EACH(cp, chars) {
390 if (end >= 0 && i == end) break;
391 *buf++ = SG_CHAR_VALUE(SG_CAR(cp));
392 i++;
393 }
394 *buf = 0;
395 return r;
396 }
397
Sg_CopyString(SgString * a)398 SgObject Sg_CopyString(SgString *a)
399 {
400 /* TODO consider if src string was literal */
401 SgString *s = make_string(a->size);
402 COPY_STRING(s, a->value, a->size, 0);
403 s->value[s->size] = '\0';
404 return SG_OBJ(s);
405 }
406
boyer_moore(const SgChar * ss1,long siz1,const SgChar * ss2,long siz2)407 static inline long boyer_moore(const SgChar *ss1, long siz1,
408 const SgChar *ss2, long siz2)
409 {
410 long shift[256];
411 long i, j, k;
412 for (i = 0; i < 256; i++) { shift[i] = siz2; }
413 for (j = 0; j < siz2-1; j++) {
414 shift[(uint32_t)ss2[j]] = siz2-j-1;
415 }
416 for (i = siz2 - 1; i < siz1; i += shift[ss1[i]]) {
417 for (j = siz2 - 1, k = i; j >= 0 && ss1[k] == ss2[j]; j--, k--)
418 ;
419 if (j == -1) return k+1;
420 }
421 return -1;
422 }
423
string_scan(SgString * s,const SgChar * ss2,long size2,int retmode)424 static SgObject string_scan(SgString *s, const SgChar *ss2,
425 long size2, int retmode)
426 {
427 long i;
428 const SgChar *ss1 = SG_STRING_VALUE(s);
429 long size1 = SG_STRING_SIZE(s);
430 const SgObject nullstr = SG_MAKE_STRING("");
431
432 if (retmode < 0 || retmode > SG_STRING_SCAN_BOTH) {
433 Sg_Error(UC("return mode out of range' %d"), retmode);
434 }
435 if (size2 == 0) {
436 /* shortcut */
437 switch (retmode) {
438 case SG_STRING_SCAN_INDEX: return SG_MAKE_INT(0);
439 case SG_STRING_SCAN_BEFORE: return nullstr;
440 case SG_STRING_SCAN_AFTER: return Sg_CopyString(s);
441 case SG_STRING_SCAN_BEFORE2:;
442 case SG_STRING_SCAN_AFTER2:;
443 case SG_STRING_SCAN_BOTH:
444 return Sg_Values2(nullstr, Sg_CopyString(s));
445 }
446 }
447 if (size1 >= size2) {
448 const SgChar *ssp = ss1;
449 for (i = 0; i < size1 - size2; i++) {
450 if (memcmp(ssp, ss2, size2 * sizeof(SgChar)) == 0) {
451 switch (retmode) {
452 case SG_STRING_SCAN_INDEX: return Sg_MakeInteger(i);
453 case SG_STRING_SCAN_BEFORE: return Sg_Substring(s, 0, i);
454 case SG_STRING_SCAN_AFTER: return Sg_Substring(s, i + size2, -1);
455 case SG_STRING_SCAN_BEFORE2:
456 return Sg_Values2(Sg_Substring(s, 0, i),
457 Sg_Substring(s, i, -1));
458 case SG_STRING_SCAN_AFTER2:
459 return Sg_Values2(Sg_Substring(s, 0, i + size2),
460 Sg_Substring(s, i + size2, -1));
461 case SG_STRING_SCAN_BOTH:
462 return Sg_Values2(Sg_Substring(s, 0, i),
463 Sg_Substring(s, i + size2, -1));
464 }
465 }
466 ssp++;
467 }
468 }
469 if (size1 < size2) goto failed;
470 if (size1 < 256 || size2 >= 256) {
471 for (i = 0; i <= size1 - size2; i++) {
472 if (memcmp(ss2, ss1 + i, size2 * sizeof(SgChar)) == 0) break;
473 }
474 if (i == size1 - size2 + 1) goto failed;
475 } else {
476 i = boyer_moore(ss1, size1, ss2, size2);
477 if (i < 0) goto failed;
478 }
479
480 switch (retmode) {
481 case SG_STRING_SCAN_INDEX: return Sg_MakeInteger(i);
482 case SG_STRING_SCAN_BEFORE: return Sg_Substring(s, 0, i);
483 case SG_STRING_SCAN_AFTER: return Sg_Substring(s, i + size2, -1);
484 case SG_STRING_SCAN_BEFORE2:
485 return Sg_Values2(Sg_Substring(s, 0, i),
486 Sg_Substring(s, i, -1));
487 case SG_STRING_SCAN_AFTER2:
488 return Sg_Values2(Sg_Substring(s, 0, i + size2),
489 Sg_Substring(s, i + size2, -1));
490 case SG_STRING_SCAN_BOTH:
491 return Sg_Values2(Sg_Substring(s, 0, i),
492 Sg_Substring(s, i + size2, -1));
493 }
494 failed:
495 if (retmode <= SG_STRING_SCAN_AFTER) {
496 return SG_FALSE;
497 } else {
498 return Sg_Values2(SG_FALSE, SG_FALSE);
499 }
500 }
501
Sg_StringScan(SgString * s1,SgString * s2,int retmode)502 SgObject Sg_StringScan(SgString *s1, SgString *s2, int retmode)
503 {
504 return string_scan(s1, SG_STRING_VALUE(s2), SG_STRING_SIZE(s2), retmode);
505 }
506
Sg_StringScanChar(SgString * s1,SgChar ch,int retmode)507 SgObject Sg_StringScanChar(SgString *s1, SgChar ch, int retmode)
508 {
509 SgChar buf[2];
510 buf[0] = ch;
511 buf[1] = '\0';
512 return string_scan(s1, buf, 1, retmode);
513 }
514
Sg_StringSplitChar(SgString * s1,SgChar ch)515 SgObject Sg_StringSplitChar(SgString *s1, SgChar ch)
516 {
517 /* we can't use values since this might be used before initialisation */
518 SgObject pos = Sg_StringScanChar(s1, ch, SG_STRING_SCAN_INDEX);
519 SgObject h = SG_NIL, t = SG_NIL, s = s1;
520
521 while (!SG_FALSEP(pos)) {
522 long p = SG_INT_VALUE(pos);
523 SG_APPEND1(h, t, Sg_Substring(s, 0, p));
524 s = Sg_Substring(s, p+1, SG_STRING_SIZE(s));
525 pos = Sg_StringScanChar(s, ch, SG_STRING_SCAN_INDEX);
526 }
527 SG_APPEND1(h, t, s);
528 return h;
529 }
530
Sg_Substring(SgString * x,long start,long end)531 SgObject Sg_Substring(SgString *x, long start, long end)
532 {
533 long len = x->size;
534 SgString *ret;
535 SG_CHECK_START_END(start, end, len);
536
537 ret = make_string(end - start);
538 memcpy(ret->value, x->value + start, (end - start) * sizeof(SgChar));
539 ret->value[end-start] = 0;
540 return ret;
541 }
542
Sg_StringFill(SgString * s,SgChar c,long start,long end)543 void Sg_StringFill(SgString *s, SgChar c, long start, long end)
544 {
545 long size = s->size, i;
546 SG_CHECK_START_END(start, end, size);
547 for (i = start; i < end; i++) {
548 SG_STRING_VALUE_AT(s, i) = c;
549 }
550 }
551
Sg_MaybeSubstring(SgString * s,long start,long end)552 SgObject Sg_MaybeSubstring(SgString *s, long start, long end)
553 {
554 if (start == 0 && end < 0) return SG_OBJ(s);
555 return Sg_Substring(s, start, end);
556 }
557
558
Sg_AsciiToString(const char * s,size_t len)559 SgObject Sg_AsciiToString(const char *s, size_t len)
560 {
561 SgObject ss = Sg_ReserveString(len, 0);
562 size_t i;
563 for (i = 0; i < len; i++) {
564 SG_STRING_VALUE_AT(ss, i) = s[i];
565 }
566 return ss;
567 }
568
Sg_Utf8ToString(const char * s,size_t len)569 SgObject Sg_Utf8ToString(const char *s, size_t len)
570 {
571 /* just forward */
572 return Sg_Utf8sToUtf32s(s, len);
573 }
574
Sg_IsString(SgObject obj)575 int Sg_IsString(SgObject obj)
576 {
577 return SG_STRINGP(obj);
578 }
Sg_StringLength(SgObject s)579 long Sg_StringLength(SgObject s)
580 {
581 return SG_STRING_SIZE(s);
582 }
Sg_StringRef(SgObject s,long k)583 SgChar Sg_StringRef(SgObject s, long k)
584 {
585 if (k > SG_STRING_SIZE(s) || k < 0) {
586 Sg_AssertionViolation(SG_INTERN("string-ref"),
587 SG_MAKE_STRING("index out of bounds"),
588 SG_LIST2(s, SG_MAKE_INT(k)));
589 }
590 return SG_STRING_VALUE_AT(s, k);
591 }
592
Sg_StringSet(SgObject s,long k,SgChar c)593 void Sg_StringSet(SgObject s, long k, SgChar c)
594 {
595 if (k < 0) {
596 Sg_WrongTypeOfArgumentViolation(
597 SG_INTERN("string-set!"),
598 SG_MAKE_STRING("non negative exact integer"),
599 SG_MAKE_INT(k),
600 SG_LIST3(s, SG_MAKE_INT(k), SG_MAKE_CHAR(c)));
601 }
602 if (k > SG_STRING_SIZE(s)) {
603 Sg_AssertionViolation(SG_INTERN("string-set!"),
604 SG_MAKE_STRING("index out of bounds"),
605 SG_LIST2(s, SG_MAKE_INT(k)));
606 }
607 if (SG_IMMUTABLE_STRINGP(s)) {
608 Sg_AssertionViolation(
609 SG_INTERN("string-set!"),
610 SG_MAKE_STRING("attempted to modify an immutable string"),
611 s);
612 }
613 SG_STRING_VALUE_AT(s, k) = c;
614 }
615
616
617 #ifdef USE_WEAK_STRING
DEFINE_DEBUG_DUMPER(string,stable)618 DEFINE_DEBUG_DUMPER(string, stable)
619 #endif
620
621 void Sg__InitString()
622 {
623 Sg_InitMutex(&smutex, FALSE);
624 #ifdef USE_WEAK_STRING
625 /* keys are refered by its values anyway */
626 stable = Sg_MakeWeakHashTableSimple(SG_HASH_STRING, SG_WEAK_REMOVE_VALUE,
627 4096, SG_FALSE);
628 #else
629 stable = Sg_MakeHashTableSimple(SG_HASH_STRING, 4096);
630 #endif
631
632 #ifdef USE_WEAK_STRING
633 ADD_DEBUG_DUMPER(string);
634 #endif
635 }
636
637 /*
638 end of file
639 Local Variables:
640 coding: utf-8-unix
641 End:
642 */
643