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