Back to index

plt-scheme  4.2.1
strops.inc
Go to the documentation of this file.
00001 
00002 /**********************************************************************/
00003 /*                           constructors                             */
00004 /**********************************************************************/
00005 
00006 Scheme_Object *
00007 X(scheme_make_sized_offset, _string)(Xchar *chars, long d, long len, int copy)
00008 {
00009   Scheme_Object *str;
00010 
00011   if (!chars) chars = EMPTY;
00012 
00013   str = scheme_alloc_object();
00014   str->type = scheme_x_string_type;
00015 
00016   if (len < 0)
00017     len = xstrlen(chars XFORM_OK_PLUS d);
00018   if (copy) {
00019     Xchar *naya;
00020 
00021     naya = (Xchar *)scheme_malloc_fail_ok(scheme_malloc_atomic, (len + 1) * sizeof(Xchar));
00022     SCHEME_X_STR_VAL(str) = naya;
00023     memcpy(naya, chars + d, len * sizeof(Xchar));
00024     naya[len] = 0;
00025   } else
00026     SCHEME_X_STR_VAL(str) = chars + d;
00027   SCHEME_X_STRTAG_VAL(str) = len;
00028 
00029   return str;
00030 }
00031 
00032 Scheme_Object *
00033 X(scheme_make_sized, _string)(Xchar *chars, long len, int copy)
00034 {
00035   return X(scheme_make_sized_offset, _string)(chars, 0, len, copy);
00036 }
00037 
00038 Scheme_Object *
00039 X(scheme_make_immutable_sized, _string)(Xchar *chars, long len, int copy)
00040 {
00041   Scheme_Object *s;
00042   
00043   s = X(scheme_make_sized_offset, _string)(chars, 0, len, copy);
00044   SCHEME_SET_X_STRING_IMMUTABLE(s);
00045 
00046   return s;
00047 }
00048 
00049 Scheme_Object *
00050 X(scheme_make, _string_without_copying)(Xchar *chars)
00051 {
00052   return X(scheme_make_sized_offset, _string)(chars, 0, -1, 0);
00053 }
00054 
00055 Scheme_Object *
00056 X(scheme_make, _string)(const Xchar *chars)
00057 {
00058   return X(scheme_make_sized_offset, _string)((Xchar *)chars, 0, -1, 1);
00059 }
00060 
00061 Scheme_Object *
00062 X(scheme_alloc, _string)(long size, Xchar fill)
00063 {
00064   Scheme_Object *str;
00065   Xchar *s;
00066   long i;
00067   
00068   if (size < 0) {
00069     str = scheme_make_integer(size);
00070     scheme_wrong_type("make-" XSTRINGSTR, "non-negative exact integer",
00071                     -1, 0, &str);
00072   }
00073 
00074   str = scheme_alloc_object();
00075   str->type = scheme_x_string_type;
00076   if (size < 100)
00077     s = (Xchar *)scheme_malloc_atomic(sizeof(Xchar)*(size + 1));
00078   else
00079     s = (Xchar *)scheme_malloc_fail_ok(scheme_malloc_atomic, sizeof(Xchar)*(size + 1));
00080   for (i = size; i--; ) {
00081     s[i] = fill;
00082   }
00083   s[size] = 0;
00084   SCHEME_X_STR_VAL(str) = s;
00085   SCHEME_X_STRTAG_VAL(str) = size;
00086 
00087   return str;
00088 }
00089 
00090 /**********************************************************************/
00091 /*                          string procs                              */
00092 /**********************************************************************/
00093 
00094 static Scheme_Object *
00095 X__(string_p) (int argc, Scheme_Object *argv[])
00096 {
00097   return (SCHEME_X_STRINGP(argv[0]) ? scheme_true : scheme_false);
00098 }
00099 
00100 static Scheme_Object *
00101 X_(make, string) (int argc, Scheme_Object *argv[])
00102 {
00103   long len;
00104   Xchar fill;
00105   Scheme_Object *str;
00106 
00107   len = scheme_extract_index("make-" XSTRINGSTR, 0, argc, argv, -1, 0);
00108 
00109   if (argc == 2) {
00110     if (!CHARP(argv[1]))
00111       scheme_wrong_type("make-" XSTRINGSTR, CHAR_STR, 1, argc, argv);
00112     fill = (Xchar)CHAR_VAL(argv[1]);
00113   } else
00114     fill = 0;
00115 
00116   if (len == -1) {
00117     scheme_raise_out_of_memory("make-" XSTRINGSTR, "making " XSTR "string of length %s",
00118                             scheme_make_provided_string(argv[0], 0, NULL));
00119   }
00120 
00121   str = X(scheme_alloc, _string)(len, fill);
00122   return str;
00123 }
00124 
00125 static Scheme_Object *
00126 X__(string) (int argc, Scheme_Object *argv[])
00127 {
00128   Scheme_Object *str;
00129   int i;
00130 
00131   str = X(scheme_alloc, _string)(argc, 0);
00132 
00133   for ( i=0 ; i<argc ; ++i ) {
00134     if (!CHARP(argv[i]))
00135       scheme_wrong_type(XSTRINGSTR, CHAR_STR, i, argc, argv);
00136     SCHEME_X_STR_VAL(str)[i] = (Xchar)CHAR_VAL(argv[i]);
00137   }
00138 
00139   return str;
00140 }
00141 
00142 static Scheme_Object *
00143 X__(string_length) (int argc, Scheme_Object *argv[])
00144 {
00145   if (!SCHEME_X_STRINGP(argv[0]))
00146     scheme_wrong_type(XSTRINGSTR "-length", XSTR "string", 0, argc, argv);
00147 
00148   return scheme_make_integer(SCHEME_X_STRTAG_VAL(argv[0]));
00149 }
00150 
00151 Scheme_Object *
00152 X_(scheme_checked, string_ref) (int argc, Scheme_Object *argv[])
00153 {
00154   long i, len;
00155   int c;
00156   Xchar *str;
00157 
00158   if (!SCHEME_X_STRINGP(argv[0]))
00159     scheme_wrong_type(XSTRINGSTR "-ref", XSTR "string", 0, argc, argv);
00160 
00161   str = SCHEME_X_STR_VAL(argv[0]);
00162   len = SCHEME_X_STRTAG_VAL(argv[0]);
00163 
00164   i = scheme_extract_index(XSTRINGSTR "-ref", 1, argc, argv, len, 0);
00165 
00166   if (i >= len) {
00167     scheme_out_of_string_range(XSTRINGSTR "-ref", "", argv[1], argv[0], 0, len - 1);
00168     return NULL;
00169   }
00170 
00171   c = ((uXchar *)str)[i];
00172   return MAKE_CHAR(c);
00173 }
00174 
00175 Scheme_Object *
00176 X_(scheme_checked, string_set) (int argc, Scheme_Object *argv[])
00177 {
00178   long i, len;
00179   Xchar *str;
00180   
00181   if (!SCHEME_MUTABLE_X_STRINGP(argv[0]))
00182     scheme_wrong_type(XSTRINGSTR "-set!", "mutable " XSTR "string", 0, argc, argv);
00183 
00184   str = SCHEME_X_STR_VAL(argv[0]);
00185   len = SCHEME_X_STRTAG_VAL(argv[0]);
00186 
00187   i = scheme_extract_index(XSTRINGSTR "-set!", 1, argc, argv, len, 0);
00188 
00189   if (!CHARP(argv[2]))
00190     scheme_wrong_type(XSTRINGSTR "-set!", CHAR_STR, 2, argc, argv);
00191 
00192   if (i >= len) {
00193     scheme_out_of_string_range(XSTRINGSTR "-set!", "", argv[1], argv[0], 0, len - 1);
00194     return NULL;
00195   }
00196 
00197   str[i] = (Xchar)CHAR_VAL(argv[2]);
00198 
00199   return scheme_void;
00200 }
00201 
00202 static Scheme_Object *
00203 X__(substring) (int argc, Scheme_Object *argv[])
00204 {
00205   long start, finish;
00206   Xchar *chars;
00207   Scheme_Object *str;
00208 
00209   if (!SCHEME_X_STRINGP(argv[0]))
00210     scheme_wrong_type(SUBXSTR, XSTR "string", 0, argc, argv);
00211 
00212   chars = SCHEME_X_STR_VAL(argv[0]);
00213 
00214   scheme_do_get_substring_indices(SUBXSTR, argv[0], argc, argv, 1, 2,
00215                                   &start, &finish, SCHEME_X_STRTAG_VAL(argv[0]));
00216 
00217   str = X(scheme_alloc, _string)(finish-start, 0);
00218   memcpy(SCHEME_X_STR_VAL(str), chars + start, (finish - start) * sizeof(Xchar));
00219   
00220   return str;
00221 }
00222 
00223 static Scheme_Object *
00224 X__(string_append) (int argc, Scheme_Object *argv[])
00225 {
00226   Scheme_Object *naya, *s;
00227   Xchar *chars;
00228   int i;
00229   long len;
00230 
00231   len = 0;
00232   for (i = 0; i < argc; i++) {
00233     s = argv[i];
00234     if (!SCHEME_X_STRINGP(s))
00235       scheme_wrong_type(XSTRINGSTR "-append", XSTR "string", i, argc, argv);
00236     len += SCHEME_X_STRTAG_VAL(s);
00237   }
00238 
00239   if (!len)
00240     return X(zero_length, _string);
00241 
00242   naya = X(scheme_alloc, _string)(len, 0);
00243   chars = SCHEME_X_STR_VAL(naya);
00244 
00245   for (i = 0; i < argc; i++) {
00246     s = argv[i];
00247     len = SCHEME_X_STRTAG_VAL(s);
00248     memcpy(chars, SCHEME_X_STR_VAL(s), len * sizeof(Xchar));
00249     chars = chars XFORM_OK_PLUS len;
00250   }
00251   
00252   return naya;
00253 }
00254 
00255 Scheme_Object *
00256 X(scheme_append, _string)(Scheme_Object *str1, Scheme_Object *str2)
00257 {
00258   int len1, len2;
00259   Xchar *r;
00260   Scheme_Object *naya;
00261 
00262   len1 = SCHEME_X_STRTAG_VAL(str1);
00263   len2 = SCHEME_X_STRTAG_VAL(str2);
00264 
00265   naya = X(scheme_alloc, _string)(len1 + len2, 0);
00266 
00267   r = SCHEME_X_STR_VAL(naya);
00268   memcpy(r, SCHEME_X_STR_VAL(str1), len1 * sizeof(Xchar));
00269   memcpy(r + len1, SCHEME_X_STR_VAL(str2), len2 * sizeof(Xchar));
00270 
00271   r[len1 + len2] = 0;
00272 
00273   return naya;
00274 }
00275 
00276 static Scheme_Object *
00277 X__(string_to_list) (int argc, Scheme_Object *argv[])
00278 {
00279   int len, i;
00280   uXchar *chars;
00281   Scheme_Object *pair = scheme_null, *v;
00282 
00283   if (!SCHEME_X_STRINGP(argv[0]))
00284     scheme_wrong_type(XSTRINGSTR "->list", XSTR "string", 0, argc, argv);
00285 
00286   chars = (uXchar *)SCHEME_X_STR_VAL(argv[0]);
00287   len = SCHEME_X_STRTAG_VAL(argv[0]);
00288 
00289   if (len < 0xFFF) {
00290     for (i = len ; i--; ) {
00291       v = MAKE_CHAR(chars[i]);
00292       pair = scheme_make_pair(v, pair);
00293     }
00294   } else {
00295     for (i = len ; i--; ) {
00296       if (!(i & 0xFFF))
00297        SCHEME_USE_FUEL(0xFFF);
00298       v = MAKE_CHAR(chars[i]);
00299       pair = scheme_make_pair(v, pair);
00300     }
00301   }
00302 
00303   return pair;
00304 }
00305 
00306 static Scheme_Object *
00307 X_(list_to, string) (int argc, Scheme_Object *argv[])
00308 {
00309   int len, i;
00310   Scheme_Object *list, *str, *ch;
00311 
00312   list = argv[0];
00313   len = scheme_list_length(list);
00314   str = X(scheme_alloc, _string)(len, 0);
00315   i = 0;
00316   while (SCHEME_PAIRP (list)) {
00317     ch = SCHEME_CAR(list);
00318     
00319     if (!CHARP(ch))
00320       scheme_wrong_type("list->" XSTRINGSTR, "list of " CHAR_STR, 0, 
00321                      argc, argv);
00322     
00323     SCHEME_X_STR_VAL(str)[i] = (Xchar)CHAR_VAL(ch);
00324     i++;
00325     list = SCHEME_CDR(list);
00326   }  
00327   
00328   if (!SCHEME_NULLP(list))
00329     scheme_wrong_type("list->" XSTRINGSTR, "list of " CHAR_STR, 0, argc, argv);
00330 
00331   return str;
00332 }
00333 
00334 static Scheme_Object *
00335 X__(string_copy) (int argc, Scheme_Object *argv[])
00336 {
00337   if (!SCHEME_X_STRINGP(argv[0]))
00338     scheme_wrong_type(XSTRINGSTR "-copy", XSTR "string", 0, argc, argv);
00339 
00340   return X(scheme_make_sized, _string)(SCHEME_X_STR_VAL(argv[0]), 
00341                                        SCHEME_X_STRTAG_VAL(argv[0]), 1);
00342 }
00343 
00344 static Scheme_Object *
00345 X__(string_copy_bang)(int argc, Scheme_Object *argv[])
00346 {
00347   Scheme_Object *s1, *s2;
00348   long istart, ifinish;
00349   long ostart, ofinish;
00350 
00351   s1 = argv[0];
00352   if (!SCHEME_MUTABLE_X_STRINGP(s1))
00353     scheme_wrong_type(XSTRINGSTR "-copy!", "mutable " XSTR "string", 0, argc, argv);
00354 
00355   scheme_do_get_substring_indices(XSTRINGSTR "-copy!", s1, 
00356                                   argc, argv, 1, 5, 
00357                                   &ostart, &ofinish, SCHEME_X_STRTAG_VAL(s1));
00358 
00359   s2 = argv[2];
00360   if (!SCHEME_X_STRINGP(s2))
00361     scheme_wrong_type(XSTRINGSTR "-copy!", XSTR "string", 2, argc, argv);
00362 
00363   scheme_do_get_substring_indices(XSTRINGSTR "-copy!", s2, 
00364                                   argc, argv, 3, 4, 
00365                                   &istart, &ifinish, SCHEME_X_STRTAG_VAL(s2));
00366   
00367   if ((ofinish - ostart) < (ifinish - istart)) {
00368     scheme_arg_mismatch(XSTRINGSTR "-copy!",
00369                      "not enough room in target " XSTR "string: ",
00370                      argv[2]);
00371     return NULL;
00372   }
00373 
00374   memmove(SCHEME_X_STR_VAL(s1) + ostart,
00375          SCHEME_X_STR_VAL(s2) + istart,
00376          (ifinish - istart) * sizeof(Xchar));
00377   
00378   return scheme_void;
00379 }
00380 
00381 static Scheme_Object *
00382 X__(string_fill) (int argc, Scheme_Object *argv[])
00383 {
00384   int len, i;
00385   Xchar *chars, ch;
00386 
00387   if (!SCHEME_MUTABLE_X_STRINGP(argv[0]))
00388     scheme_wrong_type(XSTRINGSTR "-fill!", "mutable " XSTR "string", 0, argc, argv);
00389   if (!CHARP(argv[1]))
00390     scheme_wrong_type(XSTRINGSTR "-fill!", CHAR_STR, 1, argc, argv);
00391   
00392   chars = SCHEME_X_STR_VAL(argv[0]);
00393   ch = (Xchar)CHAR_VAL(argv[1]);
00394   len = SCHEME_X_STRTAG_VAL(argv[0]);
00395   for (i = 0; i < len; i++) {
00396     chars[i] = ch;
00397   }
00398 
00399   return scheme_void;
00400 }
00401 
00402 static Scheme_Object *
00403 X__(string_to_immutable) (int argc, Scheme_Object *argv[])
00404 {
00405   Scheme_Object *s = argv[0];
00406 
00407   if (!SCHEME_X_STRINGP(s))
00408     scheme_wrong_type(XSTRINGSTR "->immutable-" XSTRINGSTR, XSTR "string", 0, argc, argv);
00409 
00410   if (SCHEME_MUTABLE_X_STRINGP(s)) {
00411     Scheme_Object *s2;
00412     s2 = X(scheme_make_sized, _string)(SCHEME_X_STR_VAL(s), SCHEME_X_STRTAG_VAL(s), 1);
00413     SCHEME_SET_X_STRING_IMMUTABLE(s2);
00414     return s2;
00415   } else
00416     return s;
00417 }
00418 
00419 static Scheme_Object *
00420 X_(append_all, strings_backwards)(Scheme_Object *l)
00421 {
00422   int i, len;
00423   Scheme_Object **a;
00424 
00425   len = scheme_list_length(l);
00426   a = MALLOC_N(Scheme_Object *, len);
00427   for (i = len; i--; l = SCHEME_CDR(l)) {
00428     a[i] = SCHEME_CAR(l);
00429   }
00430   
00431   return X__(string_append)(len, a);
00432 }
00433 
00434 #undef SCHEME_X_STR_VAL
00435 #undef SCHEME_X_STRTAG_VAL
00436 #undef SCHEME_X_STRINGP
00437 #undef SCHEME_MUTABLE_X_STRINGP
00438 #undef SCHEME_SET_X_STRING_IMMUTABLE
00439 #undef scheme_x_string_type
00440 #undef X
00441 #undef X_
00442 #undef X__
00443 #undef EMPTY
00444 #undef Xchar
00445 #undef uXchar
00446 #undef XSTR
00447 #undef XSTRINGSTR
00448 #undef SUBXSTR
00449 #undef CHARP
00450 #undef CHAR_VAL
00451 #undef CHAR_STR
00452 #undef MAKE_CHAR
00453 #undef xstrlen