1 2/**********************************************************************/ 3/* constructors */ 4/**********************************************************************/ 5 6Scheme_Object * 7X(scheme_make_sized_offset, _string)(Xchar *chars, intptr_t d, intptr_t len, int copy) 8{ 9 Scheme_Object *str; 10 11 if (!chars) chars = EMPTY; 12 13 str = scheme_alloc_object(); 14 str->type = scheme_x_string_type; 15 16 if (len < 0) 17 len = xstrlen(chars XFORM_OK_PLUS d); 18 if (copy) { 19 Xchar *naya; 20 21 if (len < 100) 22 naya = (Xchar *)scheme_malloc_atomic((len + 1) * sizeof(Xchar)); 23 else 24 naya = (Xchar *)scheme_malloc_fail_ok(scheme_malloc_atomic, (len + 1) * sizeof(Xchar)); 25 SCHEME_X_STR_VAL(str) = naya; 26 memcpy(naya, chars + d, len * sizeof(Xchar)); 27 naya[len] = 0; 28 } else 29 SCHEME_X_STR_VAL(str) = chars + d; 30 SCHEME_X_STRTAG_VAL(str) = len; 31 32 return str; 33} 34 35Scheme_Object * 36X(scheme_make_sized, _string)(Xchar *chars, intptr_t len, int copy) 37{ 38 return X(scheme_make_sized_offset, _string)(chars, 0, len, copy); 39} 40 41Scheme_Object * 42X(scheme_make_immutable_sized, _string)(Xchar *chars, intptr_t len, int copy) 43{ 44 Scheme_Object *s; 45 46 s = X(scheme_make_sized_offset, _string)(chars, 0, len, copy); 47 SCHEME_SET_X_STRING_IMMUTABLE(s); 48 49 return s; 50} 51 52Scheme_Object * 53X(scheme_make, _string_without_copying)(Xchar *chars) 54{ 55 return X(scheme_make_sized_offset, _string)(chars, 0, -1, 0); 56} 57 58Scheme_Object * 59X(scheme_make, _string)(const Xchar *chars) 60{ 61 return X(scheme_make_sized_offset, _string)((Xchar *)chars, 0, -1, 1); 62} 63 64Scheme_Object * 65X(scheme_alloc, _string)(intptr_t size, Xchar fill) 66{ 67 Scheme_Object *str; 68 Xchar *s; 69 intptr_t i; 70 71 if (size < 0) { 72 str = scheme_make_integer(size); 73 scheme_wrong_contract("make-" XSTRINGSTR, "exact-nonnegative-integer?", 74 -1, 0, &str); 75 } 76 77 str = scheme_alloc_object(); 78 str->type = scheme_x_string_type; 79 if (size < 100) 80 s = (Xchar *)scheme_malloc_atomic(sizeof(Xchar)*(size + 1)); 81 else 82 s = (Xchar *)scheme_malloc_fail_ok(scheme_malloc_atomic, sizeof(Xchar)*(size + 1)); 83 for (i = size; i--; ) { 84 s[i] = fill; 85 } 86 s[size] = 0; 87 SCHEME_X_STR_VAL(str) = s; 88 SCHEME_X_STRTAG_VAL(str) = size; 89 90 return str; 91} 92 93#if defined(GENERATING_BYTE) 94Scheme_Object * 95X(scheme_alloc_shared, _string)(intptr_t size, Xchar fill) 96{ 97 Scheme_Object *str; 98 Xchar *s; 99 intptr_t i; 100#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) 101 void *original_gc; 102#endif 103 104 if (size < 0) { 105 str = scheme_make_integer(size); 106 scheme_wrong_contract("make-" XSTRINGSTR, "exact-nonnegative-integer?", 107 -1, 0, &str); 108 } 109 110#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) 111 original_gc = GC_switch_to_master_gc(); 112#endif 113 str = scheme_alloc_object(); 114 str->type = scheme_x_string_type; 115 SHARED_ALLOCATED_SET(str); 116 117 if (size < 100) 118 s = (Xchar *)scheme_malloc_atomic(sizeof(Xchar)*(size + 1)); 119 else 120 s = (Xchar *)scheme_malloc_fail_ok(scheme_malloc_atomic, sizeof(Xchar)*(size + 1)); 121#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) 122 GC_switch_back_from_master(original_gc); 123#endif 124 125 for (i = size; i--; ) { 126 s[i] = fill; 127 } 128 s[size] = 0; 129 SCHEME_X_STR_VAL(str) = s; 130 SCHEME_X_STRTAG_VAL(str) = size; 131 132 return str; 133} 134#endif 135 136/**********************************************************************/ 137/* string procs */ 138/**********************************************************************/ 139 140static Scheme_Object * 141X__(string_p) (int argc, Scheme_Object *argv[]) 142{ 143 return (SCHEME_X_STRINGP(argv[0]) ? scheme_true : scheme_false); 144} 145 146static Scheme_Object * 147X_(make, string) (int argc, Scheme_Object *argv[]) 148{ 149 intptr_t len; 150 Xchar fill; 151 Scheme_Object *str; 152 153 len = scheme_extract_index("make-" XSTRINGSTR, 0, argc, argv, -1, 0); 154 155 if (argc == 2) { 156 if (!CHARP(argv[1])) 157 scheme_wrong_contract("make-" XSTRINGSTR, CHAR_STR, 1, argc, argv); 158 fill = (Xchar)CHAR_VAL(argv[1]); 159 } else 160 fill = 0; 161 162 if (len == -1) { 163 scheme_raise_out_of_memory("make-" XSTRINGSTR, "making " XSTR "string of length %s", 164 scheme_make_provided_string(argv[0], 0, NULL)); 165 } 166 167 str = X(scheme_alloc, _string)(len, fill); 168 return str; 169} 170 171static Scheme_Object * 172X__(string) (int argc, Scheme_Object *argv[]) 173{ 174 Scheme_Object *str; 175 int i; 176 177 str = X(scheme_alloc, _string)(argc, 0); 178 179 for ( i=0 ; i<argc ; ++i ) { 180 if (!CHARP(argv[i])) 181 scheme_wrong_contract(XSTRINGSTR, CHAR_STR, i, argc, argv); 182 SCHEME_X_STR_VAL(str)[i] = (Xchar)CHAR_VAL(argv[i]); 183 } 184 185 return str; 186} 187 188#if defined(GENERATING_BYTE) 189static Scheme_Object * 190X_(make_shared, string) (int argc, Scheme_Object *argv[]) 191{ 192 intptr_t len; 193 Xchar fill; 194 Scheme_Object *str; 195 196 len = scheme_extract_index("make-" XSTRINGSTR, 0, argc, argv, -1, 0); 197 198 if (argc == 2) { 199 if (!CHARP(argv[1])) 200 scheme_wrong_contract("make-" XSTRINGSTR, CHAR_STR, 1, argc, argv); 201 fill = (Xchar)CHAR_VAL(argv[1]); 202 } else 203 fill = 0; 204 205 if (len == -1) { 206 scheme_raise_out_of_memory("make-" XSTRINGSTR, "making " XSTR "string of length %s", 207 scheme_make_provided_string(argv[0], 0, NULL)); 208 } 209 210 str = X(scheme_alloc_shared, _string)(len, fill); 211 return str; 212} 213 214static Scheme_Object * 215X_(shared, string) (int argc, Scheme_Object *argv[]) 216{ 217 Scheme_Object *str; 218 int i; 219 220 str = X(scheme_alloc_shared, _string)(argc, 0); 221 222 for ( i=0 ; i<argc ; ++i ) { 223 if (!CHARP(argv[i])) 224 scheme_wrong_contract(XSTRINGSTR, CHAR_STR, i, argc, argv); 225 SCHEME_X_STR_VAL(str)[i] = (Xchar)CHAR_VAL(argv[i]); 226 } 227 228 return str; 229} 230#endif 231 232static Scheme_Object * 233X__(string_length) (int argc, Scheme_Object *argv[]) 234{ 235 if (!SCHEME_X_STRINGP(argv[0])) 236 scheme_wrong_contract(XSTRINGSTR "-length", IS_STR, 0, argc, argv); 237 238 return scheme_make_integer(SCHEME_X_STRTAG_VAL(argv[0])); 239} 240 241Scheme_Object * 242X_(scheme, string_length) (Scheme_Object *v) 243{ 244 return X__(string_length)(1, &v); 245} 246 247Scheme_Object * 248X_(scheme_checked, string_ref) (int argc, Scheme_Object *argv[]) 249{ 250 intptr_t i, len; 251 int c; 252 Xchar *str; 253 254 if (!SCHEME_X_STRINGP(argv[0])) 255 scheme_wrong_contract(XSTRINGSTR "-ref", IS_STR, 0, argc, argv); 256 257 str = SCHEME_X_STR_VAL(argv[0]); 258 len = SCHEME_X_STRTAG_VAL(argv[0]); 259 260 i = scheme_extract_index(XSTRINGSTR "-ref", 1, argc, argv, len, 0); 261 262 if (i >= len) { 263 scheme_out_of_range(XSTRINGSTR "-ref", XSTR "string", "", argv[1], argv[0], -1, len); 264 return NULL; 265 } 266 267 c = ((uXchar *)str)[i]; 268 return MAKE_CHAR(c); 269} 270 271Scheme_Object * 272X_(scheme_checked, string_set) (int argc, Scheme_Object *argv[]) 273{ 274 intptr_t i, len; 275 Xchar *str; 276 277 if (!SCHEME_MUTABLE_X_STRINGP(argv[0])) 278 scheme_wrong_contract(XSTRINGSTR "-set!", "(and/c " IS_STR " (not/c immutable?))", 0, argc, argv); 279 280 str = SCHEME_X_STR_VAL(argv[0]); 281 len = SCHEME_X_STRTAG_VAL(argv[0]); 282 283 i = scheme_extract_index(XSTRINGSTR "-set!", 1, argc, argv, len, 0); 284 285 if (!CHARP(argv[2])) 286 scheme_wrong_contract(XSTRINGSTR "-set!", CHAR_STR, 2, argc, argv); 287 288 if (i >= len) { 289 scheme_out_of_range(XSTRINGSTR "-set!", XSTR "string", "", argv[1], argv[0], 0, len - 1); 290 return NULL; 291 } 292 293 str[i] = (Xchar)CHAR_VAL(argv[2]); 294 295 return scheme_void; 296} 297 298static Scheme_Object * 299X__(substring) (int argc, Scheme_Object *argv[]) 300{ 301 intptr_t start, finish; 302 Xchar *chars; 303 Scheme_Object *str; 304 305 if (!SCHEME_X_STRINGP(argv[0])) 306 scheme_wrong_contract(SUBXSTR, IS_STR, 0, argc, argv); 307 308 chars = SCHEME_X_STR_VAL(argv[0]); 309 310 scheme_do_get_substring_indices(SUBXSTR, argv[0], argc, argv, 1, 2, 311 &start, &finish, SCHEME_X_STRTAG_VAL(argv[0])); 312 313 str = X(scheme_alloc, _string)(finish-start, 0); 314 memcpy(SCHEME_X_STR_VAL(str), chars + start, (finish - start) * sizeof(Xchar)); 315 316 return str; 317} 318 319static Scheme_Object * 320X__(do_string_append) (const char *who, int argc, Scheme_Object *argv[]) 321{ 322 Scheme_Object *naya, *s; 323 Xchar *chars; 324 int i; 325 intptr_t len; 326 327 len = 0; 328 for (i = 0; i < argc; i++) { 329 s = argv[i]; 330 if (!SCHEME_X_STRINGP(s)) 331 scheme_wrong_contract(who, IS_STR, i, argc, argv); 332 len += SCHEME_X_STRTAG_VAL(s); 333 } 334 335 if (!len) 336 return X(zero_length, _string); 337 338 naya = X(scheme_alloc, _string)(len, 0); 339 chars = SCHEME_X_STR_VAL(naya); 340 341 for (i = 0; i < argc; i++) { 342 s = argv[i]; 343 len = SCHEME_X_STRTAG_VAL(s); 344 memcpy(chars, SCHEME_X_STR_VAL(s), len * sizeof(Xchar)); 345 chars = chars XFORM_OK_PLUS len; 346 } 347 348 return naya; 349} 350 351static Scheme_Object * 352X__(string_append) (int argc, Scheme_Object *argv[]) 353{ 354 return X__(do_string_append)(XSTRINGSTR "-append", argc, argv); 355} 356 357Scheme_Object * 358X(scheme_append, _string)(Scheme_Object *str1, Scheme_Object *str2) 359{ 360 intptr_t len1, len2; 361 Xchar *r; 362 Scheme_Object *naya; 363 364 len1 = SCHEME_X_STRTAG_VAL(str1); 365 len2 = SCHEME_X_STRTAG_VAL(str2); 366 367 naya = X(scheme_alloc, _string)(len1 + len2, 0); 368 369 r = SCHEME_X_STR_VAL(naya); 370 memcpy(r, SCHEME_X_STR_VAL(str1), len1 * sizeof(Xchar)); 371 memcpy(r + len1, SCHEME_X_STR_VAL(str2), len2 * sizeof(Xchar)); 372 373 r[len1 + len2] = 0; 374 375 return naya; 376} 377 378static Scheme_Object * 379X__(string_to_list) (int argc, Scheme_Object *argv[]) 380{ 381 int len, i; 382 uXchar *chars; 383 Scheme_Object *pair = scheme_null, *v; 384 385 if (!SCHEME_X_STRINGP(argv[0])) 386 scheme_wrong_contract(XSTRINGSTR "->list", IS_STR, 0, argc, argv); 387 388 chars = (uXchar *)SCHEME_X_STR_VAL(argv[0]); 389 len = SCHEME_X_STRTAG_VAL(argv[0]); 390 391 if (len < 0xFFF) { 392 for (i = len ; i--; ) { 393 v = MAKE_CHAR(chars[i]); 394 pair = scheme_make_pair(v, pair); 395 } 396 } else { 397 for (i = len ; i--; ) { 398 if (!(i & 0xFFF)) 399 SCHEME_USE_FUEL(0xFFF); 400 v = MAKE_CHAR(chars[i]); 401 pair = scheme_make_pair(v, pair); 402 } 403 } 404 405 return pair; 406} 407 408static Scheme_Object * 409X_(list_to, string) (int argc, Scheme_Object *argv[]) 410{ 411 int len, i; 412 Scheme_Object *list, *str, *ch; 413 414 list = argv[0]; 415 len = scheme_list_length(list); 416 str = X(scheme_alloc, _string)(len, 0); 417 i = 0; 418 while (SCHEME_PAIRP (list)) { 419 ch = SCHEME_CAR(list); 420 421 if (!CHARP(ch)) 422 scheme_wrong_contract("list->" XSTRINGSTR, "(listof " CHAR_STR ")", 0, 423 argc, argv); 424 425 SCHEME_X_STR_VAL(str)[i] = (Xchar)CHAR_VAL(ch); 426 i++; 427 list = SCHEME_CDR(list); 428 } 429 430 if (!SCHEME_NULLP(list)) 431 scheme_wrong_contract("list->" XSTRINGSTR, "(listof " CHAR_STR ")", 0, argc, argv); 432 433 return str; 434} 435 436static Scheme_Object * 437X__(string_copy) (int argc, Scheme_Object *argv[]) 438{ 439 if (!SCHEME_X_STRINGP(argv[0])) 440 scheme_wrong_contract(XSTRINGSTR "-copy", IS_STR, 0, argc, argv); 441 442 return X(scheme_make_sized, _string)(SCHEME_X_STR_VAL(argv[0]), 443 SCHEME_X_STRTAG_VAL(argv[0]), 1); 444} 445 446static Scheme_Object * 447X__(string_copy_bang)(int argc, Scheme_Object *argv[]) 448{ 449 Scheme_Object *s1, *s2; 450 intptr_t istart, ifinish; 451 intptr_t ostart, ofinish; 452 453 s1 = argv[0]; 454 if (!SCHEME_MUTABLE_X_STRINGP(s1)) 455 scheme_wrong_contract(XSTRINGSTR "-copy!", "(and/c " IS_STR " (not/c immutable?))", 0, argc, argv); 456 457 scheme_do_get_substring_indices(XSTRINGSTR "-copy!", s1, 458 argc, argv, 1, 5, 459 &ostart, &ofinish, SCHEME_X_STRTAG_VAL(s1)); 460 461 s2 = argv[2]; 462 if (!SCHEME_X_STRINGP(s2)) 463 scheme_wrong_contract(XSTRINGSTR "-copy!", IS_STR, 2, argc, argv); 464 465 scheme_do_get_substring_indices(XSTRINGSTR "-copy!", s2, 466 argc, argv, 3, 4, 467 &istart, &ifinish, SCHEME_X_STRTAG_VAL(s2)); 468 469 if ((ofinish - ostart) < (ifinish - istart)) { 470 scheme_arg_mismatch(XSTRINGSTR "-copy!", 471 "not enough room in target " XSTR "string: ", 472 argv[2]); 473 return NULL; 474 } 475 476 memmove(SCHEME_X_STR_VAL(s1) + ostart, 477 SCHEME_X_STR_VAL(s2) + istart, 478 (ifinish - istart) * sizeof(Xchar)); 479 480 return scheme_void; 481} 482 483static Scheme_Object * 484X__(string_fill) (int argc, Scheme_Object *argv[]) 485{ 486 int len, i; 487 Xchar *chars, ch; 488 489 if (!SCHEME_MUTABLE_X_STRINGP(argv[0])) 490 scheme_wrong_contract(XSTRINGSTR "-fill!", "(and/c " IS_STR " (not/c immutable?))", 0, argc, argv); 491 if (!CHARP(argv[1])) 492 scheme_wrong_contract(XSTRINGSTR "-fill!", CHAR_STR, 1, argc, argv); 493 494 chars = SCHEME_X_STR_VAL(argv[0]); 495 ch = (Xchar)CHAR_VAL(argv[1]); 496 len = SCHEME_X_STRTAG_VAL(argv[0]); 497 for (i = 0; i < len; i++) { 498 chars[i] = ch; 499 } 500 501 return scheme_void; 502} 503 504static Scheme_Object * 505X__(string_to_immutable) (int argc, Scheme_Object *argv[]) 506{ 507 Scheme_Object *s = argv[0]; 508 509 if (!SCHEME_X_STRINGP(s)) 510 scheme_wrong_contract(XSTRINGSTR "->immutable-" XSTRINGSTR, IS_STR, 0, argc, argv); 511 512 if (SCHEME_MUTABLE_X_STRINGP(s)) { 513 Scheme_Object *s2; 514 s2 = X(scheme_make_sized, _string)(SCHEME_X_STR_VAL(s), SCHEME_X_STRTAG_VAL(s), 1); 515 SCHEME_SET_X_STRING_IMMUTABLE(s2); 516 return s2; 517 } else 518 return s; 519} 520 521static Scheme_Object * 522X_(append_all, strings_backwards)(Scheme_Object *l) 523{ 524 int i, len; 525 Scheme_Object **a; 526 527 len = scheme_list_length(l); 528 a = MALLOC_N(Scheme_Object *, len); 529 for (i = len; i--; l = SCHEME_CDR(l)) { 530 a[i] = SCHEME_CAR(l); 531 } 532 533 return X__(string_append)(len, a); 534} 535 536#undef SCHEME_X_STR_VAL 537#undef SCHEME_X_STRTAG_VAL 538#undef SCHEME_X_STRINGP 539#undef SCHEME_MUTABLE_X_STRINGP 540#undef SCHEME_SET_X_STRING_IMMUTABLE 541#undef scheme_x_string_type 542#undef X 543#undef X_ 544#undef X__ 545#undef EMPTY 546#undef Xchar 547#undef uXchar 548#undef XSTR 549#undef IS_STR 550#undef XSTRINGSTR 551#undef SUBXSTR 552#undef CHARP 553#undef CHAR_VAL 554#undef CHAR_STR 555#undef MAKE_CHAR 556#undef xstrlen 557