/racket/src/racket/src/string.c

http://github.com/plt/racket · C · 5610 lines · 4599 code · 714 blank · 297 comment · 1059 complexity · 5a88f05530bc3f678e0a97f47d3bb508 MD5 · raw file

Large files are truncated click here to view the full file

    

  1. #include "schpriv.h"
    2. 

  2. #include "schvers.h"
    3. 

  3. #include "schrktio.h"
    4. 

  4. #include <string.h>
    5. 

  5. #include <ctype.h>
    6. 

  6. #ifdef NO_ERRNO_GLOBAL
    7. 

  7. # define errno -1
    8. 

  8. #else
    9. 

  9. # include <errno.h>
    10. 

  10. #endif
    11. 

  11. 

  12. #ifndef SCHEME_PLATFORM_LIBRARY_SUBPATH
    13. 

  13. # include "schsys.h"
    14. 

  14. #endif
    15. 

  15. 

  16. #ifndef SPLS_SUFFIX
    17. 

  17. # define SPLS_SUFFIX ""
    18. 

  18. #endif
    19. 

  19. 

  20. #include "schustr.inc"
    21. 

  21. 

  22. #ifdef MACOS_UNICODE_SUPPORT
    23. 

  23. # define mzLOCALE_IS_UTF_8(s) (!s || !(*s))
    24. 

  24. #endif
    25. 

  25. #ifdef WINDOWS_UNICODE_SUPPORT
    26. 

  26. # define mzLOCALE_IS_UTF_8(s) (!s || !(*s))
    27. 

  27. #endif
    28. 

  28. #ifndef mzLOCALE_IS_UTF_8
    29. 

  29. # define mzLOCALE_IS_UTF_8(s) (!(rktio_convert_properties(scheme_rktio) & RKTIO_CONVERTER_SUPPORTED))
    30. 

  30. #endif
    31. 

  31. 

  32. #define mzICONV_KIND 0
    33. 

  33. #define mzUTF8_KIND 1
    34. 

  34. #define mzUTF8_TO_UTF16_KIND 2
    35. 

  35. #define mzUTF16_TO_UTF8_KIND 3
    36. 

  36. 

  37. typedef struct Scheme_Converter {
    38. 

  38.   Scheme_Object so;
    39. 

  39.   short closed;
    40. 

  40.   short kind;
    41. 

  41.   rktio_converter_t *cd;
    42. 

  42.   int permissive;
    43. 

  43.   Scheme_Custodian_Reference *mref;
    44. 

  44. } Scheme_Converter;
    45. 

  45. 

  46. Scheme_Object *scheme_system_type_proc;
    47. 

  47. 

  48. static Scheme_Object *make_string (int argc, Scheme_Object *argv[]);
    49. 

  49. static Scheme_Object *string (int argc, Scheme_Object *argv[]);
    50. 

  50. static Scheme_Object *string_p (int argc, Scheme_Object *argv[]);
    51. 

  51. static Scheme_Object *string_length (int argc, Scheme_Object *argv[]);
    52. 

  52. static Scheme_Object *string_eq (int argc, Scheme_Object *argv[]);
    53. 

  53. static Scheme_Object *string_locale_eq (int argc, Scheme_Object *argv[]);
    54. 

  54. static Scheme_Object *string_ci_eq (int argc, Scheme_Object *argv[]);
    55. 

  55. static Scheme_Object *string_locale_ci_eq (int argc, Scheme_Object *argv[]);
    56. 

  56. static Scheme_Object *string_lt (int argc, Scheme_Object *argv[]);
    57. 

  57. static Scheme_Object *string_locale_lt (int argc, Scheme_Object *argv[]);
    58. 

  58. static Scheme_Object *string_gt (int argc, Scheme_Object *argv[]);
    59. 

  59. static Scheme_Object *string_locale_gt (int argc, Scheme_Object *argv[]);
    60. 

  60. static Scheme_Object *string_lt_eq (int argc, Scheme_Object *argv[]);
    61. 

  61. static Scheme_Object *string_gt_eq (int argc, Scheme_Object *argv[]);
    62. 

  62. static Scheme_Object *string_ci_lt (int argc, Scheme_Object *argv[]);
    63. 

  63. static Scheme_Object *string_locale_ci_lt (int argc, Scheme_Object *argv[]);
    64. 

  64. static Scheme_Object *string_ci_gt (int argc, Scheme_Object *argv[]);
    65. 

  65. static Scheme_Object *string_locale_ci_gt (int argc, Scheme_Object *argv[]);
    66. 

  66. static Scheme_Object *string_ci_lt_eq (int argc, Scheme_Object *argv[]);
    67. 

  67. static Scheme_Object *string_ci_gt_eq (int argc, Scheme_Object *argv[]);
    68. 

  68. static Scheme_Object *string_upcase (int argc, Scheme_Object *argv[]);
    69. 

  69. static Scheme_Object *string_downcase (int argc, Scheme_Object *argv[]);
    70. 

  70. static Scheme_Object *string_titlecase (int argc, Scheme_Object *argv[]);
    71. 

  71. static Scheme_Object *string_foldcase (int argc, Scheme_Object *argv[]);
    72. 

  72. static Scheme_Object *string_locale_upcase (int argc, Scheme_Object *argv[]);
    73. 

  73. static Scheme_Object *string_locale_downcase (int argc, Scheme_Object *argv[]);
    74. 

  74. static Scheme_Object *substring (int argc, Scheme_Object *argv[]);
    75. 

  75. static Scheme_Object *string_append (int argc, Scheme_Object *argv[]);
    76. 

  76. static Scheme_Object *string_append_immutable (int argc, Scheme_Object *argv[]);
    77. 

  77. static Scheme_Object *string_to_list (int argc, Scheme_Object *argv[]);
    78. 

  78. static Scheme_Object *list_to_string (int argc, Scheme_Object *argv[]);
    79. 

  79. static Scheme_Object *string_copy (int argc, Scheme_Object *argv[]);
    80. 

  80. static Scheme_Object *string_copy_bang (int argc, Scheme_Object *argv[]);
    81. 

  81. static Scheme_Object *string_fill (int argc, Scheme_Object *argv[]);
    82. 

  82. static Scheme_Object *string_to_immutable (int argc, Scheme_Object *argv[]);
    83. 

  83. static Scheme_Object *string_normalize_c (int argc, Scheme_Object *argv[]);
    84. 

  84. static Scheme_Object *string_normalize_kc (int argc, Scheme_Object *argv[]);
    85. 

  85. static Scheme_Object *string_normalize_d (int argc, Scheme_Object *argv[]);
    86. 

  86. static Scheme_Object *string_normalize_kd (int argc, Scheme_Object *argv[]);
    87. 

  87. 

  88. static Scheme_Object *make_shared_byte_string (int argc, Scheme_Object *argv[]);
    89. 

  89. static Scheme_Object *shared_byte_string (int argc, Scheme_Object *argv[]);
    90. 

  90. 

  91. static Scheme_Object *make_byte_string (int argc, Scheme_Object *argv[]);
    92. 

  92. static Scheme_Object *byte_string (int argc, Scheme_Object *argv[]);
    93. 

  93. static Scheme_Object *byte_p (int argc, Scheme_Object *argv[]);
    94. 

  94. static Scheme_Object *byte_string_p (int argc, Scheme_Object *argv[]);
    95. 

  95. static Scheme_Object *byte_string_length (int argc, Scheme_Object *argv[]);
    96. 

  96. static Scheme_Object *byte_string_eq (int argc, Scheme_Object *argv[]);
    97. 

  97. static Scheme_Object *byte_string_lt (int argc, Scheme_Object *argv[]);
    98. 

  98. static Scheme_Object *byte_string_gt (int argc, Scheme_Object *argv[]);
    99. 

  99. static Scheme_Object *byte_substring (int argc, Scheme_Object *argv[]);
    100. 

  100. static Scheme_Object *byte_string_append (int argc, Scheme_Object *argv[]);
    101. 

  101. static Scheme_Object *byte_string_to_list (int argc, Scheme_Object *argv[]);
    102. 

  102. static Scheme_Object *list_to_byte_string (int argc, Scheme_Object *argv[]);
    103. 

  103. static Scheme_Object *byte_string_copy (int argc, Scheme_Object *argv[]);
    104. 

  104. static Scheme_Object *byte_string_copy_bang (int argc, Scheme_Object *argv[]);
    105. 

  105. static Scheme_Object *byte_string_fill (int argc, Scheme_Object *argv[]);
    106. 

  106. static Scheme_Object *byte_string_to_immutable (int argc, Scheme_Object *argv[]);
    107. 

  107. 

  108. static Scheme_Object *byte_string_utf8_index (int argc, Scheme_Object *argv[]);
    109. 

  109. static Scheme_Object *byte_string_utf8_ref (int argc, Scheme_Object *argv[]);
    110. 

  110. static Scheme_Object *byte_string_utf8_length (int argc, Scheme_Object *argv[]);
    111. 

  111. 

  112. static Scheme_Object *byte_string_to_char_string (int argc, Scheme_Object *argv[]);
    113. 

  113. static Scheme_Object *byte_string_to_char_string_locale (int argc, Scheme_Object *argv[]);
    114. 

  114. static Scheme_Object *byte_string_to_char_string_latin1 (int argc, Scheme_Object *argv[]);
    115. 

  115. static Scheme_Object *char_string_to_byte_string (int argc, Scheme_Object *argv[]);
    116. 

  116. static Scheme_Object *char_string_to_byte_string_locale (int argc, Scheme_Object *argv[]);
    117. 

  117. static Scheme_Object *char_string_to_byte_string_latin1 (int argc, Scheme_Object *argv[]);
    118. 

  118. static Scheme_Object *char_string_utf8_length (int argc, Scheme_Object *argv[]);
    119. 

  119. 

  120. static Scheme_Object *version(int argc, Scheme_Object *argv[]);
    121. 

  121. static Scheme_Object *format(int argc, Scheme_Object *argv[]);
    122. 

  122. static Scheme_Object *sch_printf(int argc, Scheme_Object *argv[]);
    123. 

  123. static Scheme_Object *sch_eprintf(int argc, Scheme_Object *argv[]);
    124. 

  124. static Scheme_Object *sch_fprintf(int argc, Scheme_Object *argv[]);
    125. 

  125. static Scheme_Object *banner(int argc, Scheme_Object *argv[]);
    126. 

  126. static Scheme_Object *env_p(int argc, Scheme_Object *argv[]);
    127. 

  127. static Scheme_Object *sch_getenv(int argc, Scheme_Object *argv[]);
    128. 

  128. static Scheme_Object *sch_getenv_names(int argc, Scheme_Object *argv[]);
    129. 

  129. static Scheme_Object *sch_putenv(int argc, Scheme_Object *argv[]);
    130. 

  130. static Scheme_Object *env_copy(int argc, Scheme_Object *argv[]);
    131. 

  131. static Scheme_Object *env_make(int argc, Scheme_Object *argv[]);
    132. 

  132. static Scheme_Object *current_environment_variables(int argc, Scheme_Object *argv[]);
    133. 

  133. static Scheme_Object *system_type(int argc, Scheme_Object *argv[]);
    134. 

  134. static Scheme_Object *system_library_subpath(int argc, Scheme_Object *argv[]);
    135. 

  135. static Scheme_Object *cmdline_args(int argc, Scheme_Object *argv[]);
    136. 

  136. static Scheme_Object *current_locale(int argc, Scheme_Object *argv[]);
    137. 

  137. static Scheme_Object *locale_string_encoding(int argc, Scheme_Object *argv[]);
    138. 

  138. static Scheme_Object *system_language_country(int argc, Scheme_Object *argv[]);
    139. 

  139. 

  140. static Scheme_Object *byte_string_open_converter(int argc, Scheme_Object *argv[]);
    141. 

  141. static Scheme_Object *byte_string_close_converter(int argc, Scheme_Object *argv[]);
    142. 

  142. static Scheme_Object *byte_string_convert(int argc, Scheme_Object *argv[]);
    143. 

  143. static Scheme_Object *byte_string_convert_end(int argc, Scheme_Object *argv[]);
    144. 

  144. static Scheme_Object *byte_converter_p(int argc, Scheme_Object *argv[]);
    145. 

  145. 

  146. static Scheme_Object *path_lt (int argc, Scheme_Object *argv[]);
    147. 

  147. 

  148. #ifdef MZ_PRECISE_GC
    149. 

  149. static void register_traversers(void);
    150. 

  150. #endif
    151. 

  151. 

  152. static int mz_char_strcmp(const char *who, const mzchar *str1, intptr_t l1, const mzchar *str2, intptr_t l2, int locale, int size_shortcut);
    153. 

  153. static int mz_char_strcmp_ci(const char *who, const mzchar *str1, intptr_t l1, const mzchar *str2, intptr_t l2, int locale, int size_shortcut);
    154. 

  154. static int mz_strcmp(const char *who, unsigned char *str1, intptr_t l1, unsigned char *str2, intptr_t l2);
    155. 

  155. 

  156. XFORM_NONGCING static intptr_t utf8_decode_x(const unsigned char *s, intptr_t start, intptr_t end,
    157. 

  157. 					unsigned int *us, intptr_t dstart, intptr_t dend,
    158. 

  158. 					intptr_t *ipos, intptr_t *jpos,
    159. 

  159. 					char compact, char utf16,
    160. 

  160. 					int *state, int might_continue, int permissive);
    161. 

  161. XFORM_NONGCING static intptr_t utf8_encode_x(const unsigned int *us, intptr_t start, intptr_t end,
    162. 

  162. 					unsigned char *s, intptr_t dstart, intptr_t dend,
    163. 

  163. 					intptr_t *_ipos, intptr_t *_opos, char utf16);
    164. 

  164. 

  165. static char *string_to_from_locale(int to_bytes,
    166. 

  166. 				   char *in, intptr_t delta, intptr_t len,
    167. 

  167. 				   intptr_t *olen, int perm,
    168. 

  168. 				   int *no_cvt);
    169. 

  169. 

  170. static void cache_locale_or_close(int to_bytes, rktio_converter_t *cd, char *le);
    171. 

  171. 

  172. #define portable_isspace(x) (((x) < 128) && isspace(x))
    173. 

  173. 

  174. ROSYM static Scheme_Object *sys_symbol;
    175. 

  175. ROSYM static Scheme_Object *link_symbol, *machine_symbol, *vm_symbol, *gc_symbol;
    176. 

  176. ROSYM static Scheme_Object *so_suffix_symbol, *so_mode_symbol, *word_symbol;
    177. 

  177. ROSYM static Scheme_Object *os_symbol, *fs_change_symbol, *target_machine_symbol, *cross_symbol;
    178. 

  178. ROSYM static Scheme_Object *racket_symbol, *cgc_symbol, *_3m_symbol, *cs_symbol;
    179. 

  179. ROSYM static Scheme_Object *force_symbol, *infer_symbol;
    180. 

  180. ROSYM static Scheme_Object *platform_3m_path, *platform_cgc_path, *platform_cs_path;
    181. 

  181. READ_ONLY static Scheme_Object *zero_length_char_string;
    182. 

  182. READ_ONLY static Scheme_Object *zero_length_char_immutable_string;
    183. 

  183. READ_ONLY static Scheme_Object *zero_length_byte_string;
    184. 

  184. 

  185. SHARED_OK static char *embedding_banner;
    186. 

  186. SHARED_OK static Scheme_Object *vers_str;
    187. 

  187. SHARED_OK static Scheme_Object *banner_str;
    188. 

  188. 

  189. THREAD_LOCAL_DECL(static Scheme_Object *fs_change_props);
    190. 

  190. 

  191. THREAD_LOCAL_DECL(static char *cached_locale_encoding_name);
    192. 

  192. THREAD_LOCAL_DECL(struct rktio_converter_t *cached_locale_to_converter);
    193. 

  193. THREAD_LOCAL_DECL(struct rktio_converter_t *cached_locale_from_converter);
    194. 

  194. 

  195. READ_ONLY static Scheme_Object *complete_symbol, *continues_symbol, *aborts_symbol, *error_symbol;
    196. 

  196. 

  197. READ_ONLY Scheme_Object *scheme_string_p_proc;
    198. 

  198. READ_ONLY Scheme_Object *scheme_byte_string_p_proc;
    199. 

  199. 

  200. READ_ONLY static int cross_compile_mode;
    201. 

  201. 

  202. /* These two locale variables are only valid when reset_locale()
    203. 

  203.    is called after continuation marks (and hence parameterization)
    204. 

  204.    may have changed. Similarly, setlocale() is only up-to-date
    205. 

  205.    when reset_locale() has been called. */
    206. 

  206. THREAD_LOCAL_DECL(static int locale_on);
    207. 

  207. THREAD_LOCAL_DECL(static void *current_locale_name_ptr);
    208. 

  208. static void reset_locale(void);
    209. 

  209. 

  210. #define current_locale_name ((const mzchar *)current_locale_name_ptr)
    211. 

  211. 

  212. static const mzchar empty_char_string[1] = { 0 };
    213. 

  213. static const mzchar xes_char_string[2] = { 0x78787878, 0 };
    214. 

  214. 

  215. void
    216. 

  216. scheme_init_string (Scheme_Startup_Env *env)
    217. 

  217. {
    218. 

  218.   Scheme_Object *p;
    219. 

  219. 

  220.   REGISTER_SO(sys_symbol);
    221. 

  221.   sys_symbol = scheme_intern_symbol(SYSTEM_TYPE_NAME);
    222. 

  222. 

  223.   REGISTER_SO(link_symbol);
    224. 

  224.   REGISTER_SO(machine_symbol);
    225. 

  225.   REGISTER_SO(gc_symbol);
    226. 

  226.   REGISTER_SO(vm_symbol);
    227. 

  227.   REGISTER_SO(so_suffix_symbol);
    228. 

  228.   REGISTER_SO(so_mode_symbol);
    229. 

  229.   REGISTER_SO(word_symbol);
    230. 

  230.   REGISTER_SO(os_symbol);
    231. 

  231.   REGISTER_SO(fs_change_symbol);
    232. 

  232.   REGISTER_SO(target_machine_symbol);
    233. 

  233.   REGISTER_SO(cross_symbol);
    234. 

  234.   link_symbol = scheme_intern_symbol("link");
    235. 

  235.   machine_symbol = scheme_intern_symbol("machine");
    236. 

  236.   vm_symbol = scheme_intern_symbol("vm");
    237. 

  237.   gc_symbol = scheme_intern_symbol("gc");
    238. 

  238.   so_suffix_symbol = scheme_intern_symbol("so-suffix");
    239. 

  239.   so_mode_symbol = scheme_intern_symbol("so-mode");
    240. 

  240.   word_symbol = scheme_intern_symbol("word");
    241. 

  241.   os_symbol = scheme_intern_symbol("os");
    242. 

  242.   fs_change_symbol = scheme_intern_symbol("fs-change");
    243. 

  243.   target_machine_symbol = scheme_intern_symbol("target-machine");
    244. 

  244.   cross_symbol = scheme_intern_symbol("cross");
    245. 

  245. 

  246.   REGISTER_SO(racket_symbol);
    247. 

  247.   REGISTER_SO(cgc_symbol);
    248. 

  248.   REGISTER_SO(_3m_symbol);
    249. 

  249.   REGISTER_SO(cs_symbol);
    250. 

  250.   racket_symbol = scheme_intern_symbol("racket");
    251. 

  251.   cgc_symbol = scheme_intern_symbol("cgc");
    252. 

  252.   _3m_symbol = scheme_intern_symbol("3m");
    253. 

  253.   cs_symbol = scheme_intern_symbol("cs");
    254. 

  254. 

  255.   REGISTER_SO(force_symbol);
    256. 

  256.   REGISTER_SO(infer_symbol);
    257. 

  257.   force_symbol = scheme_intern_symbol("force");
    258. 

  258.   infer_symbol = scheme_intern_symbol("infer");
    259. 

  259. 

  260.   REGISTER_SO(zero_length_char_string);
    261. 

  261.   REGISTER_SO(zero_length_char_immutable_string);
    262. 

  262.   REGISTER_SO(zero_length_byte_string);
    263. 

  263.   zero_length_char_string = scheme_alloc_char_string(0, 0);
    264. 

  264.   zero_length_char_immutable_string = scheme_alloc_char_string(0, 0);
    265. 

  265.   SCHEME_SET_CHAR_STRING_IMMUTABLE(zero_length_char_immutable_string);
    266. 

  266.   zero_length_byte_string = scheme_alloc_byte_string(0, 0);
    267. 

  267. 

  268.   REGISTER_SO(complete_symbol);
    269. 

  269.   REGISTER_SO(continues_symbol);
    270. 

  270.   REGISTER_SO(aborts_symbol);
    271. 

  271.   REGISTER_SO(error_symbol);
    272. 

  272.   complete_symbol = scheme_intern_symbol("complete");
    273. 

  273.   continues_symbol = scheme_intern_symbol("continues");
    274. 

  274.   aborts_symbol = scheme_intern_symbol("aborts");
    275. 

  275.   error_symbol = scheme_intern_symbol("error");
    276. 

  276. 

  277.   REGISTER_SO(platform_3m_path);
    278. 

  278. # ifdef DOS_FILE_SYSTEM
    279. 

  279. #  define MZ3M_SUBDIR "\\3m"
    280. 

  280. #  define MZCS_SUBDIR "\\cs"
    281. 

  281. # else
    282. 

  282. #  define MZ3M_SUBDIR "/3m"
    283. 

  283. #  define MZCS_SUBDIR "/cs"
    284. 

  284. #endif
    285. 

  285.   REGISTER_SO(platform_3m_path);
    286. 

  286.   REGISTER_SO(platform_cgc_path);
    287. 

  287.   REGISTER_SO(platform_cs_path);
    288. 

  288.   platform_cgc_path = scheme_make_path(SCHEME_PLATFORM_LIBRARY_SUBPATH SPLS_SUFFIX);
    289. 

  289.   platform_3m_path = scheme_make_path(SCHEME_PLATFORM_LIBRARY_SUBPATH SPLS_SUFFIX MZ3M_SUBDIR);
    290. 

  290.   platform_cs_path = scheme_make_path(SCHEME_PLATFORM_LIBRARY_SUBPATH SPLS_SUFFIX MZCS_SUBDIR);
    291. 

  291. 

  292.   REGISTER_SO(embedding_banner);
    293. 

  293.   REGISTER_SO(vers_str);
    294. 

  294.   REGISTER_SO(banner_str);
    295. 

  295. 

  296.   vers_str = scheme_make_utf8_string(scheme_version());
    297. 

  297.   SCHEME_SET_CHAR_STRING_IMMUTABLE(vers_str);
    298. 

  298.   banner_str = scheme_make_utf8_string(scheme_banner());
    299. 

  299.   SCHEME_SET_CHAR_STRING_IMMUTABLE(banner_str);
    300. 

  300. 

  301.   REGISTER_SO(scheme_string_p_proc);
    302. 

  302.   p = scheme_make_folding_prim(string_p, "string?", 1, 1, 1);
    303. 

  303.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
    304. 

  304.                                                             | SCHEME_PRIM_IS_OMITABLE
    305. 

  305.                                                             | SCHEME_PRIM_PRODUCES_BOOL);
    306. 

  306.   scheme_addto_prim_instance("string?", p, env);
    307. 

  307.   scheme_string_p_proc = p;
    308. 

  308. 

  309.   scheme_addto_prim_instance("make-string",
    310. 

  310. 			     scheme_make_immed_prim(make_string,
    311. 

  311. 						    "make-string",
    312. 

  312. 						    1, 2),
    313. 

  313. 			     env);
    314. 

  314.   scheme_addto_prim_instance("string",
    315. 

  315. 			     scheme_make_immed_prim(string,
    316. 

  316. 						    "string",
    317. 

  317. 						    0, -1),
    318. 

  318. 			     env);
    319. 

  319.   
    320. 

  320.   p = scheme_make_folding_prim(string_length, "string-length", 1, 1, 1);
    321. 

  321.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
    322. 

  322.                                                             |SCHEME_PRIM_PRODUCES_FIXNUM
    323. 

  323.                                                             | SCHEME_PRIM_AD_HOC_OPT);
    324. 

  324.   scheme_addto_prim_instance("string-length", p,
    325. 

  325. 			     env);
    326. 

  326. 

  327.   p = scheme_make_immed_prim(scheme_checked_string_ref, "string-ref", 2, 2);
    328. 

  328.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
    329. 

  329.                                                             | SCHEME_PRIM_AD_HOC_OPT);
    330. 

  330.   scheme_addto_prim_instance("string-ref", p, env);
    331. 

  331. 

  332.   p = scheme_make_immed_prim(scheme_checked_string_set, "string-set!", 3, 3);
    333. 

  333.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED
    334. 

  334.                                                             | SCHEME_PRIM_AD_HOC_OPT);
    335. 

  335.   scheme_addto_prim_instance("string-set!", p, env);
    336. 

  336. 

  337.   p = scheme_make_immed_prim(string_eq, "string=?", 1, -1);
    338. 

  338.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
    339. 

  339.                                                             | SCHEME_PRIM_PRODUCES_BOOL
    340. 

  340.                                                             | SCHEME_PRIM_PRODUCES_BOOL);
    341. 

  341.   scheme_addto_prim_instance("string=?", p, env);
    342. 

  342. 

  343.   scheme_addto_prim_instance("string-locale=?",
    344. 

  344. 			     scheme_make_immed_prim(string_locale_eq,
    345. 

  345. 						    "string-locale=?",
    346. 

  346. 						    1, -1),
    347. 

  347. 			     env);
    348. 

  348.   scheme_addto_prim_instance("string-ci=?",
    349. 

  349. 			     scheme_make_immed_prim(string_ci_eq,
    350. 

  350. 						    "string-ci=?",
    351. 

  351. 						    1, -1),
    352. 

  352. 			     env);
    353. 

  353.   scheme_addto_prim_instance("string-locale-ci=?",
    354. 

  354. 			     scheme_make_immed_prim(string_locale_ci_eq,
    355. 

  355. 						    "string-locale-ci=?",
    356. 

  356. 						    1, -1),
    357. 

  357. 			     env);
    358. 

  358.   scheme_addto_prim_instance("string<?",
    359. 

  359. 			     scheme_make_immed_prim(string_lt,
    360. 

  360. 						    "string<?",
    361. 

  361. 						    1, -1),
    362. 

  362. 			     env);
    363. 

  363.   scheme_addto_prim_instance("string-locale<?",
    364. 

  364. 			     scheme_make_immed_prim(string_locale_lt,
    365. 

  365. 						    "string-locale<?",
    366. 

  366. 						    1, -1),
    367. 

  367. 			     env);
    368. 

  368.   scheme_addto_prim_instance("string>?",
    369. 

  369. 			     scheme_make_immed_prim(string_gt,
    370. 

  370. 						    "string>?",
    371. 

  371. 						    1, -1),
    372. 

  372. 			     env);
    373. 

  373.   scheme_addto_prim_instance("string-locale>?",
    374. 

  374. 			     scheme_make_immed_prim(string_locale_gt,
    375. 

  375. 						    "string-locale>?",
    376. 

  376. 						    1, -1),
    377. 

  377. 			     env);
    378. 

  378.   scheme_addto_prim_instance("string<=?",
    379. 

  379. 			     scheme_make_immed_prim(string_lt_eq,
    380. 

  380. 						    "string<=?",
    381. 

  381. 						    1, -1),
    382. 

  382. 			     env);
    383. 

  383.   scheme_addto_prim_instance("string>=?",
    384. 

  384. 			     scheme_make_immed_prim(string_gt_eq,
    385. 

  385. 						    "string>=?",
    386. 

  386. 						    1, -1),
    387. 

  387. 			     env);
    388. 

  388.   scheme_addto_prim_instance("string-ci<?",
    389. 

  389. 			     scheme_make_immed_prim(string_ci_lt,
    390. 

  390. 						    "string-ci<?",
    391. 

  391. 						    1, -1),
    392. 

  392. 			     env);
    393. 

  393.   scheme_addto_prim_instance("string-locale-ci<?",
    394. 

  394. 			     scheme_make_immed_prim(string_locale_ci_lt,
    395. 

  395. 						    "string-locale-ci<?",
    396. 

  396. 						    1, -1),
    397. 

  397. 			     env);
    398. 

  398.   scheme_addto_prim_instance("string-ci>?",
    399. 

  399. 			     scheme_make_immed_prim(string_ci_gt,
    400. 

  400. 						    "string-ci>?",
    401. 

  401. 						    1, -1),
    402. 

  402. 			     env);
    403. 

  403.   scheme_addto_prim_instance("string-locale-ci>?",
    404. 

  404. 			     scheme_make_immed_prim(string_locale_ci_gt,
    405. 

  405. 						    "string-locale-ci>?",
    406. 

  406. 						    1, -1),
    407. 

  407. 			     env);
    408. 

  408.   scheme_addto_prim_instance("string-ci<=?",
    409. 

  409. 			     scheme_make_immed_prim(string_ci_lt_eq,
    410. 

  410. 						    "string-ci<=?",
    411. 

  411. 						    1, -1),
    412. 

  412. 			     env);
    413. 

  413.   scheme_addto_prim_instance("string-ci>=?",
    414. 

  414. 			     scheme_make_immed_prim(string_ci_gt_eq,
    415. 

  415. 						    "string-ci>=?",
    416. 

  416. 						    1, -1),
    417. 

  417. 			     env);
    418. 

  418. 

  419.   scheme_addto_prim_instance("substring",
    420. 

  420. 			     scheme_make_immed_prim(substring,
    421. 

  421. 						    "substring",
    422. 

  422. 						    2, 3),
    423. 

  423. 			     env);
    424. 

  424. 

  425.   p = scheme_make_immed_prim(string_append, "string-append", 0, -1);
    426. 

  426.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);
    427. 

  427.   scheme_addto_prim_instance("string-append", p, env);
    428. 

  428. 

  429.   p = scheme_make_immed_prim(string_append_immutable, "string-append-immutable", 0, -1);
    430. 

  430.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);
    431. 

  431.   scheme_addto_prim_instance("string-append-immutable", p, env);
    432. 

  432. 

  433.   scheme_addto_prim_instance("string->list",
    434. 

  434. 			     scheme_make_immed_prim(string_to_list,
    435. 

  435. 						    "string->list",
    436. 

  436. 						    1, 1),
    437. 

  437. 			     env);
    438. 

  438.   scheme_addto_prim_instance("list->string",
    439. 

  439. 			     scheme_make_immed_prim(list_to_string,
    440. 

  440. 						    "list->string",
    441. 

  441. 						    1, 1),
    442. 

  442. 			     env);
    443. 

  443.   scheme_addto_prim_instance("string-copy",
    444. 

  444. 			     scheme_make_immed_prim(string_copy,
    445. 

  445. 						    "string-copy",
    446. 

  446. 						    1, 1),
    447. 

  447. 			     env);
    448. 

  448.   scheme_addto_prim_instance("string-copy!",
    449. 

  449. 			     scheme_make_immed_prim(string_copy_bang,
    450. 

  450. 						    "string-copy!",
    451. 

  451. 						    3, 5),
    452. 

  452. 			     env);
    453. 

  453.   scheme_addto_prim_instance("string-fill!",
    454. 

  454. 			     scheme_make_immed_prim(string_fill,
    455. 

  455. 						    "string-fill!",
    456. 

  456. 						    2, 2),
    457. 

  457. 			     env);
    458. 

  458. 

  459.   p = scheme_make_immed_prim(string_to_immutable, "string->immutable-string", 1, 1);
    460. 

  460.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);
    461. 

  461.   scheme_addto_prim_instance("string->immutable-string", p, env);
    462. 

  462.   
    463. 

  463.   scheme_addto_prim_instance("string-normalize-nfc",
    464. 

  464. 			     scheme_make_immed_prim(string_normalize_c,
    465. 

  465. 						    "string-normalize-nfc",
    466. 

  466. 						    1, 1),
    467. 

  467. 			     env);
    468. 

  468.   scheme_addto_prim_instance("string-normalize-nfkc",
    469. 

  469. 			     scheme_make_immed_prim(string_normalize_kc,
    470. 

  470. 						    "string-normalize-nfkc",
    471. 

  471. 						    1, 1),
    472. 

  472. 			     env);
    473. 

  473.   scheme_addto_prim_instance("string-normalize-nfd",
    474. 

  474. 			     scheme_make_immed_prim(string_normalize_d,
    475. 

  475. 						    "string-normalize-nfd",
    476. 

  476. 						    1, 1),
    477. 

  477. 			     env);
    478. 

  478.   scheme_addto_prim_instance("string-normalize-nfkd",
    479. 

  479. 			     scheme_make_immed_prim(string_normalize_kd,
    480. 

  480. 						    "string-normalize-nfkd",
    481. 

  481. 						    1, 1),
    482. 

  482. 			     env);
    483. 

  483. 

  484.   scheme_addto_prim_instance("string-upcase",
    485. 

  485. 			     scheme_make_immed_prim(string_upcase,
    486. 

  486. 						    "string-upcase",
    487. 

  487. 						    1, 1),
    488. 

  488. 			     env);
    489. 

  489.   scheme_addto_prim_instance("string-downcase",
    490. 

  490. 			     scheme_make_immed_prim(string_downcase,
    491. 

  491. 						    "string-downcase",
    492. 

  492. 						    1, 1),
    493. 

  493. 			     env);
    494. 

  494.   scheme_addto_prim_instance("string-titlecase",
    495. 

  495. 			     scheme_make_immed_prim(string_titlecase,
    496. 

  496. 						    "string-titlecase",
    497. 

  497. 						    1, 1),
    498. 

  498. 			     env);
    499. 

  499.   scheme_addto_prim_instance("string-foldcase",
    500. 

  500. 			     scheme_make_immed_prim(string_foldcase,
    501. 

  501. 						    "string-foldcase",
    502. 

  502. 						    1, 1),
    503. 

  503. 			     env);
    504. 

  504. 

  505.   scheme_addto_prim_instance("string-locale-upcase",
    506. 

  506. 			     scheme_make_immed_prim(string_locale_upcase,
    507. 

  507. 						    "string-locale-upcase",
    508. 

  508. 						    1, 1),
    509. 

  509. 			     env);
    510. 

  510.   scheme_addto_prim_instance("string-locale-downcase",
    511. 

  511. 			     scheme_make_immed_prim(string_locale_downcase,
    512. 

  512. 						    "string-locale-downcase",
    513. 

  513. 						    1, 1),
    514. 

  514. 			     env);
    515. 

  515. 

  516.   scheme_addto_prim_instance("current-locale",
    517. 

  517. 			     scheme_register_parameter(current_locale,
    518. 

  518. 						       "current-locale",
    519. 

  519. 						       MZCONFIG_LOCALE),
    520. 

  520. 			     env);
    521. 

  521.   scheme_addto_prim_instance("locale-string-encoding",
    522. 

  522. 			     scheme_make_immed_prim(locale_string_encoding,
    523. 

  523. 						    "locale-string-encoding",
    524. 

  524. 						    0, 0),
    525. 

  525. 			     env);
    526. 

  526.   scheme_addto_prim_instance("system-language+country",
    527. 

  527. 			     scheme_make_immed_prim(system_language_country,
    528. 

  528. 						    "system-language+country",
    529. 

  529. 						    0, 0),
    530. 

  530. 			     env);
    531. 

  531. 

  532.   scheme_addto_prim_instance("bytes-converter?",
    533. 

  533. 			     scheme_make_immed_prim(byte_converter_p,
    534. 

  534. 						    "bytes-converter?",
    535. 

  535. 						    1, 1),
    536. 

  536. 			     env);
    537. 

  537.   scheme_addto_prim_instance("bytes-convert",
    538. 

  538. 			     scheme_make_prim_w_arity2(byte_string_convert,
    539. 

  539. 						       "bytes-convert",
    540. 

  540. 						       2, 7,
    541. 

  541. 						       3, 3),
    542. 

  542. 			     env);
    543. 

  543.   scheme_addto_prim_instance("bytes-convert-end",
    544. 

  544. 			     scheme_make_prim_w_arity2(byte_string_convert_end,
    545. 

  545. 						       "bytes-convert-end",
    546. 

  546. 						       1, 4,
    547. 

  547. 						       2, 2),
    548. 

  548. 			     env);
    549. 

  549.   scheme_addto_prim_instance("bytes-open-converter",
    550. 

  550. 			     scheme_make_immed_prim(byte_string_open_converter,
    551. 

  551. 						    "bytes-open-converter",
    552. 

  552. 						    2, 2),
    553. 

  553. 			     env);
    554. 

  554.   scheme_addto_prim_instance("bytes-close-converter",
    555. 

  555. 			     scheme_make_immed_prim(byte_string_close_converter,
    556. 

  556. 						    "bytes-close-converter",
    557. 

  557. 						    1, 1),
    558. 

  558. 			     env);
    559. 

  559. 

  560.   scheme_addto_prim_instance("format",
    561. 

  561. 			     scheme_make_noncm_prim(format,
    562. 

  562.                                                     "format",
    563. 

  563.                                                     1, -1),
    564. 

  564. 			     env);
    565. 

  565.   scheme_addto_prim_instance("printf",
    566. 

  566. 			     scheme_make_noncm_prim(sch_printf,
    567. 

  567.                                                     "printf",
    568. 

  568.                                                     1, -1),
    569. 

  569. 			     env);
    570. 

  570.   scheme_addto_prim_instance("eprintf",
    571. 

  571. 			     scheme_make_noncm_prim(sch_eprintf,
    572. 

  572.                                                     "eprintf",
    573. 

  573.                                                     1, -1),
    574. 

  574. 			     env);
    575. 

  575.   scheme_addto_prim_instance("fprintf",
    576. 

  576. 			     scheme_make_noncm_prim(sch_fprintf,
    577. 

  577.                                                     "fprintf",
    578. 

  578.                                                     2, -1),
    579. 

  579. 			     env);
    580. 

  580. 

  581.   scheme_addto_prim_instance("byte?",
    582. 

  582. 			     scheme_make_folding_prim(byte_p,
    583. 

  583. 						      "byte?",
    584. 

  584. 						      1, 1, 1),
    585. 

  585. 			     env);
    586. 

  586. 

  587.   REGISTER_SO(scheme_byte_string_p_proc);
    588. 

  588.   p = scheme_make_folding_prim(byte_string_p, "bytes?", 1, 1, 1);
    589. 

  589.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
    590. 

  590.                                                             | SCHEME_PRIM_IS_OMITABLE
    591. 

  591.                                                             | SCHEME_PRIM_PRODUCES_BOOL);
    592. 

  592.   scheme_addto_prim_instance("bytes?", p, env);
    593. 

  593.   scheme_byte_string_p_proc = p;
    594. 

  594. 

  595.   scheme_addto_prim_instance("make-bytes",
    596. 

  596. 			     scheme_make_immed_prim(make_byte_string,
    597. 

  597. 						    "make-bytes",
    598. 

  598. 						    1, 2),
    599. 

  599. 			     env);
    600. 

  600.   scheme_addto_prim_instance("bytes",
    601. 

  601. 			     scheme_make_immed_prim(byte_string,
    602. 

  602. 						    "bytes",
    603. 

  603. 						    0, -1),
    604. 

  604. 			     env);
    605. 

  605. 

  606.   ADD_PRIM_W_ARITY("make-shared-bytes", make_shared_byte_string, 1, 2, env);
    607. 

  607.   ADD_PRIM_W_ARITY("shared-bytes", shared_byte_string, 0, -1, env);
    608. 

  608. 

  609.   p = scheme_make_folding_prim(byte_string_length, "bytes-length", 1, 1, 1);
    610. 

  610.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
    611. 

  611.                                                             | SCHEME_PRIM_PRODUCES_FIXNUM
    612. 

  612.                                                             | SCHEME_PRIM_AD_HOC_OPT);
    613. 

  613.   scheme_addto_prim_instance("bytes-length", p, env);
    614. 

  614. 

  615.   p = scheme_make_immed_prim(scheme_checked_byte_string_ref, "bytes-ref", 2, 2);
    616. 

  616.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
    617. 

  617.                                                             | SCHEME_PRIM_PRODUCES_FIXNUM
    618. 

  618.                                                             | SCHEME_PRIM_AD_HOC_OPT);
    619. 

  619.   scheme_addto_prim_instance("bytes-ref", p, env);
    620. 

  620. 

  621.   p = scheme_make_immed_prim(scheme_checked_byte_string_set, "bytes-set!", 3, 3);
    622. 

  622.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED
    623. 

  623.                                                             | SCHEME_PRIM_AD_HOC_OPT);
    624. 

  624.   scheme_addto_prim_instance("bytes-set!", p, env);
    625. 

  625. 

  626.   p = scheme_make_immed_prim(byte_string_eq, "bytes=?", 1, -1);
    627. 

  627.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
    628. 

  628.                                                             | SCHEME_PRIM_PRODUCES_BOOL);
    629. 

  629.   scheme_addto_prim_instance("bytes=?", p, env);
    630. 

  630. 

  631.   scheme_addto_prim_instance("bytes<?",
    632. 

  632. 			     scheme_make_immed_prim(byte_string_lt,
    633. 

  633. 						    "bytes<?",
    634. 

  634. 						    1, -1),
    635. 

  635. 			     env);
    636. 

  636.   scheme_addto_prim_instance("bytes>?",
    637. 

  637. 			     scheme_make_immed_prim(byte_string_gt,
    638. 

  638. 						    "bytes>?",
    639. 

  639. 						    1, -1),
    640. 

  640. 			     env);
    641. 

  641. 

  642.   scheme_addto_prim_instance("subbytes",
    643. 

  643. 			     scheme_make_immed_prim(byte_substring,
    644. 

  644. 						    "subbytes",
    645. 

  645. 						    2, 3),
    646. 

  646. 			     env);
    647. 

  647. 

  648.   p = scheme_make_immed_prim(byte_string_append, "bytes-append", 0, -1);
    649. 

  649.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);
    650. 

  650.   scheme_addto_prim_instance("bytes-append", p, env);
    651. 

  651.   
    652. 

  652.   scheme_addto_prim_instance("bytes->list",
    653. 

  653. 			     scheme_make_immed_prim(byte_string_to_list,
    654. 

  654. 						    "bytes->list",
    655. 

  655. 						    1, 1),
    656. 

  656. 			     env);
    657. 

  657.   scheme_addto_prim_instance("list->bytes",
    658. 

  658. 			     scheme_make_immed_prim(list_to_byte_string,
    659. 

  659. 						    "list->bytes",
    660. 

  660. 						    1, 1),
    661. 

  661. 			     env);
    662. 

  662.   scheme_addto_prim_instance("bytes-copy",
    663. 

  663. 			     scheme_make_immed_prim(byte_string_copy,
    664. 

  664. 						    "bytes-copy",
    665. 

  665. 						    1, 1),
    666. 

  666. 			     env);
    667. 

  667.   scheme_addto_prim_instance("bytes-copy!",
    668. 

  668. 			     scheme_make_immed_prim(byte_string_copy_bang,
    669. 

  669. 						    "bytes-copy!",
    670. 

  670. 						    3, 5),
    671. 

  671. 			     env);
    672. 

  672.   scheme_addto_prim_instance("bytes-fill!",
    673. 

  673. 			     scheme_make_immed_prim(byte_string_fill,
    674. 

  674. 						    "bytes-fill!",
    675. 

  675. 						    2, 2),
    676. 

  676. 			     env);
    677. 

  677. 

  678.   p = scheme_make_immed_prim(byte_string_to_immutable, "bytes->immutable-bytes", 1, 1);
    679. 

  679.   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);
    680. 

  680.   scheme_addto_prim_instance("bytes->immutable-bytes", p, env);
    681. 

  681. 

  682.   p = scheme_make_immed_prim(byte_string_utf8_index, "bytes-utf-8-index", 2, 5);
    683. 

  683.   /* Incorrect, since the result can be #f:
    684. 

  684.      SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_PRODUCES_FIXNUM); */
    685. 

  685.   scheme_addto_prim_instance("bytes-utf-8-index", p, env);
    686. 

  686. 

  687.   p = scheme_make_immed_prim(byte_string_utf8_length, "bytes-utf-8-length", 1, 4);
    688. 

  688.   /* Incorrect, since the result can be #f:
    689. 

  689.      SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_PRODUCES_FIXNUM); */
    690. 

  690.   scheme_addto_prim_instance("bytes-utf-8-length", p, env);
    691. 

  691. 

  692.   scheme_addto_prim_instance("bytes-utf-8-ref",
    693. 

  693. 			     scheme_make_immed_prim(byte_string_utf8_ref,
    694. 

  694. 						    "bytes-utf-8-ref",
    695. 

  695. 						    2, 5),
    696. 

  696. 			     env);
    697. 

  697. 

  698.   scheme_addto_prim_instance("bytes->string/utf-8",
    699. 

  699. 			     scheme_make_immed_prim(byte_string_to_char_string,
    700. 

  700. 						    "bytes->string/utf-8",
    701. 

  701. 						    1, 4),
    702. 

  702. 			     env);
    703. 

  703.   scheme_addto_prim_instance("bytes->string/locale",
    704. 

  704. 			     scheme_make_immed_prim(byte_string_to_char_string_locale,
    705. 

  705. 						    "bytes->string/locale",
    706. 

  706. 						    1, 4),
    707. 

  707. 			     env);
    708. 

  708.   scheme_addto_prim_instance("bytes->string/latin-1",
    709. 

  709. 			     scheme_make_immed_prim(byte_string_to_char_string_latin1,
    710. 

  710. 						    "bytes->string/latin-1",
    711. 

  711. 						    1, 4),
    712. 

  712. 			     env);
    713. 

  713.   scheme_addto_prim_instance("string->bytes/utf-8",
    714. 

  714. 			     scheme_make_immed_prim(char_string_to_byte_string,
    715. 

  715. 						    "string->bytes/utf-8",
    716. 

  716. 						    1, 4),
    717. 

  717. 			     env);
    718. 

  718.   scheme_addto_prim_instance("string->bytes/locale",
    719. 

  719. 			     scheme_make_immed_prim(char_string_to_byte_string_locale,
    720. 

  720. 						    "string->bytes/locale",
    721. 

  721. 						    1, 4),
    722. 

  722. 			     env);
    723. 

  723.   scheme_addto_prim_instance("string->bytes/latin-1",
    724. 

  724. 			     scheme_make_immed_prim(char_string_to_byte_string_latin1,
    725. 

  725. 						    "string->bytes/latin-1",
    726. 

  726. 						    1, 4),
    727. 

  727. 			     env);
    728. 

  728. 

  729.   scheme_addto_prim_instance("string-utf-8-length",
    730. 

  730. 			     scheme_make_immed_prim(char_string_utf8_length,
    731. 

  731. 						    "string-utf-8-length",
    732. 

  732. 						    1, 3),
    733. 

  733. 			     env);
    734. 

  734. 

  735. 

  736.   /* In principle, `version' could be foldable, but it invites
    737. 

  737.      more problems than it solves... */
    738. 

  738. 

  739.   scheme_addto_prim_instance("version",
    740. 

  740. 			     scheme_make_immed_prim(version,
    741. 

  741. 						    "version",
    742. 

  742. 						    0, 0),
    743. 

  743. 			     env);
    744. 

  744.   scheme_addto_prim_instance("banner",
    745. 

  745. 			     scheme_make_immed_prim(banner,
    746. 

  746. 						    "banner",
    747. 

  747. 						    0, 0),
    748. 

  748. 			     env);
    749. 

  749. 

  750.   /* Environment variables */
    751. 

  751. 

  752.   scheme_addto_prim_instance("environment-variables?",
    753. 

  753. 			     scheme_make_folding_prim(env_p,
    754. 

  754.                                                       "environment-variables?",
    755. 

  755.                                                       1, 1, 1),
    756. 

  756. 			     env);
    757. 

  757. 

  758.   scheme_addto_prim_instance("current-environment-variables",
    759. 

  759. 			     scheme_register_parameter(current_environment_variables,
    760. 

  760. 						       "current-environment-variables",
    761. 

  761. 						       MZCONFIG_CURRENT_ENV_VARS),
    762. 

  762. 			     env);  
    763. 

  763. 

  764.   scheme_addto_prim_instance("environment-variables-ref",
    765. 

  765. 			     scheme_make_immed_prim(sch_getenv,
    766. 

  766. 						    "environment-variables-ref",
    767. 

  767. 						    2, 2),
    768. 

  768. 			     env);
    769. 

  769. 

  770.   scheme_addto_prim_instance("environment-variables-set!",
    771. 

  771. 			     scheme_make_prim_w_arity(sch_putenv,
    772. 

  772.                                                       "environment-variables-set!",
    773. 

  773.                                                       3, 4),
    774. 

  774. 			     env);
    775. 

  775. 

  776.   scheme_addto_prim_instance("environment-variables-names",
    777. 

  777. 			     scheme_make_immed_prim(sch_getenv_names,
    778. 

  778. 						    "environment-variables-names",
    779. 

  779. 						    1, 1),
    780. 

  780. 			     env);
    781. 

  781. 

  782.   scheme_addto_prim_instance("environment-variables-copy",
    783. 

  783. 			     scheme_make_immed_prim(env_copy,
    784. 

  784. 						    "environment-variables-copy",
    785. 

  785. 						    1, 1),
    786. 

  786. 			     env);
    787. 

  787. 

  788.   scheme_addto_prim_instance("make-environment-variables",
    789. 

  789. 			     scheme_make_immed_prim(env_make,
    790. 

  790. 						    "make-environment-variables",
    791. 

  791. 						    0, -1),
    792. 

  792. 			     env);
    793. 

  793. 

  794.   /* Don't make these folding, since they're platform-specific: */
    795. 

  795. 

  796.   REGISTER_SO(scheme_system_type_proc);
    797. 

  797.   scheme_system_type_proc = scheme_make_immed_prim(system_type,
    798. 

  798.                                                    "system-type",
    799. 

  799.                                                    0, 1);
    800. 

  800.   scheme_addto_prim_instance("system-type", scheme_system_type_proc, env);
    801. 

  801. 

  802.   scheme_addto_prim_instance("system-library-subpath",
    803. 

  803. 			     scheme_make_immed_prim(system_library_subpath,
    804. 

  804. 						    "system-library-subpath",
    805. 

  805. 						    0, 1),
    806. 

  806. 			     env);
    807. 

  807. 

  808.   scheme_addto_prim_instance("current-command-line-arguments",
    809. 

  809. 			     scheme_register_parameter(cmdline_args,
    810. 

  810. 						       "current-command-line-arguments",
    811. 

  811. 						       MZCONFIG_CMDLINE_ARGS),
    812. 

  812. 			     env);
    813. 

  813. 

  814. 

  815.   scheme_addto_prim_instance("path<?",
    816. 

  816. 			     scheme_make_immed_prim(path_lt,
    817. 

  817. 						    "path<?",
    818. 

  818. 						    1, -1),
    819. 

  819. 			     env);
    820. 

  820. 

  821. #ifdef MZ_PRECISE_GC
    822. 

  822.   register_traversers();
    823. 

  823. #endif
    824. 

  824. }
    825. 

  825. 

  826. void scheme_init_string_places(void) {
    827. 

  827.   REGISTER_SO(current_locale_name_ptr);
    828. 

  828.   current_locale_name_ptr = (void *)xes_char_string;
    829. 

  829. 

  830.   REGISTER_SO(fs_change_props);
    831. 

  831.   {
    832. 

  832.     int supported, scalable, low_latency, file_level;
    833. 

  833.     Scheme_Object *s;
    834. 

  834.     scheme_fs_change_properties(&supported, &scalable, &low_latency, &file_level);
    835. 

  835.     fs_change_props = scheme_make_vector(4, scheme_false);
    836. 

  836.     if (supported) {
    837. 

  837.       s = scheme_intern_symbol("supported");
    838. 

  838.       SCHEME_VEC_ELS(fs_change_props)[0] = s;
    839. 

  839.     }
    840. 

  840.     if (scalable) {
    841. 

  841.       s = scheme_intern_symbol("scalable");
    842. 

  842.       SCHEME_VEC_ELS(fs_change_props)[1] = s;
    843. 

  843.     }
    844. 

  844.     if (low_latency) {
    845. 

  845.       s = scheme_intern_symbol("low-latency");
    846. 

  846.       SCHEME_VEC_ELS(fs_change_props)[2] = s;
    847. 

  847.     }
    848. 

  848.     if (file_level) {
    849. 

  849.       s = scheme_intern_symbol("file-level");
    850. 

  850.       SCHEME_VEC_ELS(fs_change_props)[3] = s;
    851. 

  851.     }
    852. 

  852.     SCHEME_SET_IMMUTABLE(fs_change_props);
    853. 

  853.   }
    854. 

  854. }
    855. 

  855. 

  856. /**********************************************************************/
    857. 

  857. /*                     UTF-8 char constructors                        */
    858. 

  858. /**********************************************************************/
    859. 

  859. 

  860. Scheme_Object *scheme_make_sized_offset_utf8_string(char *chars, intptr_t d, intptr_t len)
    861. 

  861. {
    862. 

  862.   intptr_t ulen;
    863. 

  863.   mzchar *us;
    864. 

  864. 

  865.   if (len) {
    866. 

  866.     ulen = scheme_utf8_decode((unsigned char *)chars, d, d + len,
    867. 

  867. 			      NULL, 0, -1,
    868. 

  868. 			      NULL, 0 /* not UTF-16 */, 0xFFFD);
    869. 

  869.     us = scheme_malloc_atomic(sizeof(mzchar) * (ulen + 1));
    870. 

  870.     scheme_utf8_decode((unsigned char *)chars, d, d + len,
    871. 

  871.                        us, 0, -1,
    872. 

  872.                        NULL, 0 /* not UTF-16 */, 0xFFFD);
    873. 

  873.     us[ulen] = 0;
    874. 

  874.   } else {
    875. 

  875.     us = (mzchar *)empty_char_string;
    876. 

  876.     ulen = 0;
    877. 

  877.   }
    878. 

  878.   return scheme_make_sized_offset_char_string(us, 0, ulen, 0);
    879. 

  879. }
    880. 

  880. 

  881. Scheme_Object *
    882. 

  882. scheme_make_sized_utf8_string(char *chars, intptr_t len)
    883. 

  883. {
    884. 

  884.   return scheme_make_sized_offset_utf8_string(chars, 0, len);
    885. 

  885. }
    886. 

  886. 

  887. Scheme_Object *
    888. 

  888. scheme_make_immutable_sized_utf8_string(char *chars, intptr_t len)
    889. 

  889. {
    890. 

  890.   Scheme_Object *s;
    891. 

  891. 

  892.   s = scheme_make_sized_offset_utf8_string(chars, 0, len);
    893. 

  893.   if (len)
    894. 

  894.     SCHEME_SET_CHAR_STRING_IMMUTABLE(s);
    895. 

  895. 

  896.   return s;
    897. 

  897. }
    898. 

  898. 

  899. Scheme_Object *
    900. 

  900. scheme_make_utf8_string(const char *chars)
    901. 

  901. {
    902. 

  902.   return scheme_make_sized_offset_utf8_string((char *)chars, 0, -1);
    903. 

  903. }
    904. 

  904. 

  905. Scheme_Object *
    906. 

  906. scheme_make_locale_string(const char *chars)
    907. 

  907. {
    908. 

  908.   return scheme_byte_string_to_char_string_locale(scheme_make_byte_string((char *)chars));
    909. 

  909. }
    910. 

  910. 

  911. Scheme_Object *scheme_append_strings(Scheme_Object *s1, Scheme_Object *s2)
    912. 

  912. {
    913. 

  913.   Scheme_Object *a[2];
    914. 

  914.   a[0] = s1;
    915. 

  915.   a[1] = s2;
    916. 

  916.   return string_append(2, a);
    917. 

  917. }
    918. 

  918. 

  919. /**********************************************************************/
    920. 

  920. /*                         index helpers                              */
    921. 

  921. /**********************************************************************/
    922. 

  922. 

  923. intptr_t scheme_extract_index(const char *name, int pos, int argc, Scheme_Object **argv, intptr_t top, int false_ok)
    924. 

  924. {
    925. 

  925.   intptr_t i;
    926. 

  926.   int is_top = 0;
    927. 

  927. 

  928.   if (SCHEME_INTP(argv[pos])) {
    929. 

  929.     i = SCHEME_INT_VAL(argv[pos]);
    930. 

  930.   } else if (SCHEME_BIGNUMP(argv[pos])) {
    931. 

  931.     if (SCHEME_BIGPOS(argv[pos])) {
    932. 

  932.       i = top; /* out-of-bounds */
    933. 

  933.       is_top = 1;
    934. 

  934.     } else
    935. 

  935.       i = -1; /* negative */
    936. 

  936.   } else
    937. 

  937.     i = -1;
    938. 

  938. 

  939.   if (!is_top && (i < 0))
    940. 

  940.     scheme_wrong_contract(name,
    941. 

  941.                           (false_ok ? "(or/c exact-nonnegative-integer? #f)" : "exact-nonnegative-integer?"),
    942. 

  942.                           pos, argc, argv);
    943. 

  943. 

  944.   return i;
    945. 

  945. }
    946. 

  946. 

  947. void scheme_get_substring_indices(const char *name, Scheme_Object *str,
    948. 

  948.                                   int argc, Scheme_Object **argv,
    949. 

  949.                                   int spos, int fpos, intptr_t *_start, intptr_t *_finish)
    950. 

  950. {
    951. 

  951.   intptr_t len;
    952. 

  952.   intptr_t start, finish;
    953. 

  953. 

  954.   if (SCHEME_CHAPERONE_VECTORP(str))
    955. 

  955.     len = SCHEME_CHAPERONE_VEC_SIZE(str);
    956. 

  956.   else if (SCHEME_CHAR_STRINGP(str))
    957. 

  957.     len = SCHEME_CHAR_STRTAG_VAL(str);
    958. 

  958.   else
    959. 

  959.     len = SCHEME_BYTE_STRTAG_VAL(str);
    960. 

  960. 

  961.   if (argc > spos)
    962. 

  962.     start = scheme_extract_index(name, spos, argc, argv, len + 1, 0);
    963. 

  963.   else
    964. 

  964.     start = 0;
    965. 

  965.   if (argc > fpos)
    966. 

  966.     finish = scheme_extract_index(name, fpos, argc, argv, len + 1, 0);
    967. 

  967.   else
    968. 

  968.     finish = len;
    969. 

  969. 

  970.   if (!(start <= len)) {
    971. 

  971.     scheme_out_of_range(name, NULL, (fpos < 100) ? "starting " : "", argv[spos], str, 0, len);
    972. 

  972.   }
    973. 

  973.   if (!(finish >= start && finish <= len)) {
    974. 

  974.     scheme_out_of_range(name, NULL, "ending ", argv[fpos], str, start, len);
    975. 

  975.   }
    976. 

  976. 

  977.   *_start = start;
    978. 

  978.   *_finish = finish;
    979. 

  979. }
    980. 

  980. 

  981. void scheme_do_get_substring_indices(const char *name, Scheme_Object *str,
    982. 

  982.                                      int argc, Scheme_Object **argv,
    983. 

  983.                                      int spos, int fpos, intptr_t *_start, intptr_t *_finish, intptr_t len)
    984. 

  984. {
    985. 

  985.   if (argc > spos) {
    986. 

  986.     if (SCHEME_INTP(argv[spos])) {
    987. 

  987.       intptr_t start = SCHEME_INT_VAL(argv[spos]);
    988. 

  988.       if ((start >= 0) && (start < len)) {
    989. 

  989.         *_start = start;
    990. 

  990.         if (argc > fpos) {
    991. 

  991.           intptr_t finish = SCHEME_INT_VAL(argv[fpos]);
    992. 

  992.           if ((finish >= start) && (finish <= len)) {
    993. 

  993.             *_finish = finish;
    994. 

  994.             return;
    995. 

  995.           }
    996. 

  996.         } else {
    997. 

  997.           *_finish = len;
    998. 

  998.           return;
    999. 

  999.         }
    1000. 

  1000.       }
    1001. 

  1001.     }
    1002. 

  1002.   } else {
    1003. 

  1003.     *_start = 0;
    1004. 

  1004.     *_finish = len;
    1005. 

  1005.     return;
    1006. 

  1006.   }
    1007. 

  1007. 

  1008.   scheme_get_substring_indices(name, str, argc, argv, spos, fpos, _start, _finish);
    1009. 

  1009. }
    1010. 

  1010. 

  1011. /**********************************************************************/
    1012. 

  1012. /*                          char strings                              */
    1013. 

  1013. /**********************************************************************/
    1014. 

  1014. 

  1015. #define SCHEME_X_STR_VAL(x) SCHEME_CHAR_STR_VAL(x)
    1016. 

  1016. #define SCHEME_X_STRTAG_VAL(x) SCHEME_CHAR_STRTAG_VAL(x)
    1017. 

  1017. #define SCHEME_X_STRINGP(x) SCHEME_CHAR_STRINGP(x)
    1018. 

  1018. #define SCHEME_MUTABLE_X_STRINGP(x) SCHEME_MUTABLE_CHAR_STRINGP(x)
    1019. 

  1019. #define SCHEME_SET_X_STRING_IMMUTABLE(x) SCHEME_SET_CHAR_STRING_IMMUTABLE(x)
    1020. 

  1020. #define scheme_x_string_type scheme_char_string_type
    1021. 

  1021. #define X(a, b) a##_char##b
    1022. 

  1022. #define X_(a, b) a##_##b
    1023. 

  1023. #define X__(a) a
    1024. 

  1024. #define EMPTY (mzchar *)"\0\0\0"
    1025. 

  1025. #define Xchar mzchar
    1026. 

  1026. #define uXchar mzchar
    1027. 

  1027. #define XSTR ""
    1028. 

  1028. #define IS_STR "string?"
    1029. 

  1029. #define XSTRINGSTR "string"
    1030. 

  1030. #define SUBXSTR "substring"
    1031. 

  1031. #define CHARP(x) SCHEME_CHARP(x)
    1032. 

  1032. #define CHAR_VAL(x) SCHEME_CHAR_VAL(x)
    1033. 

  1033. #define CHAR_STR "char?"
    1034. 

  1034. #define MAKE_CHAR(x) _scheme_make_char(x)
    1035. 

  1035. #define xstrlen scheme_char_strlen
    1036. 

  1036. #include "strops.inc"
    1037. 

  1037. 

  1038. #define GEN_STRING_COMP(name, scheme_name, comp, op, ul, size_shortcut)     \
    1039. 

  1039. static Scheme_Object * name (int argc, Scheme_Object *argv[]) \
    1040. 

  1040. {  mzchar *s, *prev; int i, sl, pl; int falz = 0;\
    1041. 

  1041.    if (!SCHEME_CHAR_STRINGP(argv[0])) \
    1042. 

  1042.     scheme_wrong_contract(scheme_name, "string?", 0, argc, argv); \
    1043. 

  1043.    prev = SCHEME_CHAR_STR_VAL(argv[0]); pl = SCHEME_CHAR_STRTAG_VAL(argv[0]); \
    1044. 

  1044.    for (i = 1; i < argc; i++) { \
    1045. 

  1045.      if (!SCHEME_CHAR_STRINGP(argv[i])) \
    1046. 

  1046.       scheme_wrong_contract(scheme_name, "string?", i, argc, argv); \
    1047. 

  1047.      s = SCHEME_CHAR_STR_VAL(argv[i]); sl = SCHEME_CHAR_STRTAG_VAL(argv[i]); \
    1048. 

  1048.      if (!falz) if (!(comp(scheme_name, \
    1049. 

  1049.                            prev, pl, \
    1050. 

  1050.                            s, sl, ul, size_shortcut) op 0)) falz = 1; \
    1051. 

  1051.      prev = s; pl = sl; \
    1052. 

  1052.   } \
    1053. 

  1053.   return falz ? scheme_false : scheme_true; \
    1054. 

  1054. }
    1055. 

  1055. 

  1056. GEN_STRING_COMP(string_eq, "string=?", mz_char_strcmp, ==, 0, 1)
    1057. 

  1057. GEN_STRING_COMP(string_lt, "string<?", mz_char_strcmp, <, 0, 0)
    1058. 

  1058. GEN_STRING_COMP(string_gt, "string>?", mz_char_strcmp, >, 0, 0)
    1059. 

  1059. GEN_STRING_COMP(string_lt_eq, "string<=?", mz_char_strcmp, <=, 0, 0)
    1060. 

  1060. GEN_STRING_COMP(string_gt_eq, "string>=?", mz_char_strcmp, >=, 0, 0)
    1061. 

  1061. 

  1062. GEN_STRING_COMP(string_ci_eq, "string-ci=?", mz_char_strcmp_ci, ==, 0, 0)
    1063. 

  1063. GEN_STRING_COMP(string_ci_lt, "string-ci<?", mz_char_strcmp_ci, <, 0, 0)
    1064. 

  1064. GEN_STRING_COMP(string_ci_gt, "string-ci>?", mz_char_strcmp_ci, >, 0, 0)
    1065. 

  1065. GEN_STRING_COMP(string_ci_lt_eq, "string-ci<=?", mz_char_strcmp_ci, <=, 0, 0)
    1066. 

  1066. GEN_STRING_COMP(string_ci_gt_eq, "string-ci>=?", mz_char_strcmp_ci, >=, 0, 0)
    1067. 

  1067. 

  1068. GEN_STRING_COMP(string_locale_eq, "string-locale=?", mz_char_strcmp, ==, 1, 0)
    1069. 

  1069. GEN_STRING_COMP(string_locale_lt, "string-locale<?", mz_char_strcmp, <, 1, 0)
    1070. 

  1070. GEN_STRING_COMP(string_locale_gt, "string-locale>?", mz_char_strcmp, >, 1, 0)
    1071. 

  1071. GEN_STRING_COMP(string_locale_ci_eq, "string-locale-ci=?", mz_char_strcmp_ci, ==, 1, 0)
    1072. 

  1072. GEN_STRING_COMP(string_locale_ci_lt, "string-locale-ci<?", mz_char_strcmp_ci, <, 1, 0)
    1073. 

  1073. GEN_STRING_COMP(string_locale_ci_gt, "string-locale-ci>?", mz_char_strcmp_ci, >, 1, 0)
    1074. 

  1074. 

  1075. Scheme_Object *scheme_string_eq_2(Scheme_Object *str1, Scheme_Object *str2)
    1076. 

  1076. {
    1077. 

  1077.   Scheme_Object *a[2];
    1078. 

  1078.   a[0] = str1;
    1079. 

  1079.   a[1] = str2;       
    1080. 

  1080.   return string_eq(2, a);
    1081. 

  1081. }
    1082. 

  1082. 

  1083. Scheme_Object *string_append_immutable(int argc, Scheme_Object *argv[])
    1084. 

  1084. {
    1085. 

  1085.   Scheme_Object *r;
    1086. 

  1086. 

  1087.   r = do_string_append("string-append-immutable", argc, argv);
    1088. 

  1088. 

  1089.   if (r == zero_length_char_string)
    1090. 

  1090.     return zero_length_char_immutable_string;
    1091. 

  1091. 

  1092.   SCHEME_SET_CHAR_STRING_IMMUTABLE(r);
    1093. 

  1093. 

  1094.   return r;
    1095. 

  1095. }
    1096. 

  1096. 

  1097. /**********************************************************************/
    1098. 

  1098. /*                         byte strings                               */
    1099. 

  1099. /**********************************************************************/
    1100. 

  1100. 

  1101. #define SCHEME_BYTEP(x) ((SCHEME_INTP(x)) && (SCHEME_INT_VAL(x) >= 0) && (SCHEME_INT_VAL(x) <= 255))
    1102. 

  1102. 

  1103. static Scheme_Object *
    1104. 

  1104. byte_p(int argc, Scheme_Object *argv[])
    1105. 

  1105. {
    1106. 

  1106.   return (SCHEME_BYTEP(argv[0]) ? scheme_true : scheme_false);
    1107. 

  1107. }
    1108. 

  1108. 

  1109. #define SCHEME_X_STR_VAL(x) SCHEME_BYTE_STR_VAL(x)
    1110. 

  1110. #define SCHEME_X_STRTAG_VAL(x) SCHEME_BYTE_STRTAG_VAL(x)
    1111. 

  1111. #define SCHEME_X_STRINGP(x) SCHEME_BYTE_STRINGP(x)
    1112. 

  1112. #define SCHEME_MUTABLE_X_STRINGP(x) SCHEME_MUTABLE_BYTE_STRINGP(x)
    1113. 

  1113. #define SCHEME_SET_X_STRING_IMMUTABLE(x) SCHEME_SET_BYTE_STRING_IMMUTABLE(x)
    1114. 

  1114. #define scheme_x_string_type scheme_byte_string_type
    1115. 

  1115. #define X(a, b) a##_byte##b
    1116. 

  1116. #define X_(a, b) a##_byte_##b
    1117. 

  1117. #define X__(a) byte_##a
    1118. 

  1118. #define EMPTY ""
    1119. 

  1119. #define Xchar char
    1120. 

  1120. #define uXchar unsigned char
    1121. 

  1121. #define XSTR "byte "
    1122. 

  1122. #define IS_STR "bytes?"
    1123. 

  1123. #define XSTRINGSTR "bytes"
    1124. 

  1124. #define SUBXSTR "subbytes"
    1125. 

  1125. #define CHARP(x) SCHEME_BYTEP(x)
    1126. 

  1126. #define CHAR_VAL(x) SCHEME_INT_VAL(x)
    1127. 

  1127. #define CHAR_STR "byte?"
    1128. 

  1128. #define MAKE_CHAR(x) scheme_make_integer_value(x)
    1129. 

  1129. #define xstrlen strlen
    1130. 

  1130. #define GENERATING_BYTE
    1131. 

  1131. #include "strops.inc"
    1132. 

  1132. #undef GENERATING_BYTE
    1133. 

  1133. 

  1134. /* comparisons */
    1135. 

  1135. 

  1136. #define GEN_BYTE_STRING_PATH_COMP(name, scheme_name, comp, op, PRED, contract)     \
    1137. 

  1137. static Scheme_Object * name (int argc, Scheme_Object *argv[]) \
    1138. 

  1138. {  char *s, *prev; int i, sl, pl; int falz = 0;\
    1139. 

  1139.   if (!PRED(argv[0])) \
    1140. 

  1140.     scheme_wrong_contract(scheme_name, contract, 0, argc, argv); \
    1141. 

  1141.    prev = SCHEME_BYTE_STR_VAL(argv[0]); pl = SCHEME_BYTE_STRTAG_VAL(argv[0]); \
    1142. 

  1142.    for (i = 1; i < argc; i++) { \
    1143. 

  1143.      if (!PRED(argv[i])) \
    1144. 

  1144.       scheme_wrong_contract(scheme_name, contract, i, argc, argv); \
    1145. 

  1145.      s = SCHEME_BYTE_STR_VAL(argv[i]); sl = SCHEME_BYTE_STRTAG_VAL(argv[i]); \
    1146. 

  1146.      if (!falz) if (!(comp(scheme_name, \
    1147. 

  1147.                            (unsigned char *)prev, pl, \
    1148. 

  1148.                            (unsigned char *)s, sl) op 0)) falz = 1; \
    1149. 

  1149.      prev = s; pl = sl; \
    1150. 

  1150.   } \
    1151. 

  1151.   return falz ? scheme_false : scheme_true; \
    1152. 

  1152. }
    1153. 

  1153. 

  1154. #define GEN_BYTE_STRING_COMP(name, scheme_name, comp, op) \
    1155. 

  1155.   GEN_BYTE_STRING_PATH_COMP(name, scheme_name, comp, op, SCHEME_BYTE_STRINGP, "bytes?") \
    1156. 

  1156. 

  1157. GEN_BYTE_STRING_COMP(byte_string_eq, "bytes=?", mz_strcmp, ==)
    1158. 

  1158. GEN_BYTE_STRING_COMP(byte_string_lt, "bytes<?", mz_strcmp, <)
    1159. 

  1159. GEN_BYTE_STRING_COMP(byte_string_gt, "bytes>?", mz_strcmp, >)
    1160. 

  1160. 

  1161. GEN_BYTE_STRING_PATH_COMP(path_lt, "path<?", mz_strcmp, <, SCHEME_PATHP, "path?")
    1162. 

  1162. 

  1163. Scheme_Object *scheme_byte_string_eq_2(Scheme_Object *str1, Scheme_Object *str2)
    1164. 

  1164. {
    1165. 

  1165.   Scheme_Object *a[2];
    1166. 

  1166.   a[0] = str1;
    1167. 

  1167.   a[1] = str2;       
    1168. 

  1168.   return byte_string_eq(2, a);
    1169. 

  1169. }
    1170. 

  1170. 

  1171. /**********************************************************************/
    1172. 

  1172. /*                   byte string <-> char string                      */
    1173. 

  1173. /**********************************************************************/
    1174. 

  1174. 

  1175. /************************* bytes->string *************************/
    1176. 

  1176. 

  1177. static Scheme_Object *
    1178. 

  1178. do_byte_string_to_char_string(const char *who,
    1179. 

  1179. 			      Scheme_Object *bstr,
    1180. 

  1180. 			      intptr_t istart, intptr_t ifinish,
    1181. 

  1181. 			      int perm, int as_locale)
    1182. 

  1182. {
    1183. 

  1183.   int i, ulen;
    1184. 

  1184.   char *chars;
    1185. 

  1185.   unsigned int *v;
    1186. 

  1186. 

  1187.   chars = SCHEME_BYTE_STR_VAL(bstr);
    1188. 

  1188. 

  1189.   ulen = utf8_decode_x((unsigned char *)chars, istart, ifinish,
    1190. 

  1190. 		       NULL, 0, -1,
    1191. 

  1191. 		       NULL, NULL, 0, 0,
    1192. 

  1192. 		       NULL, 0, 
    1193. 

  1193. 		       (perm > -1) ? 0xD800 : 0);
    1194. 

  1194.   if (ulen < 0) {
    1195. 

  1195.     scheme_contract_error(who,
    1196. 

  1196.                           "string is not a well-formed UTF-8 encoding",
    1197. 

  1197.                           "string", 1, bstr,
    1198. 

  1198.                           NULL);
    1199. 

  1199.   }
    1200. 

  1200. 

  1201.   v = (unsigned int *)scheme_malloc_atomic((ulen + 1) * sizeof(unsigned int));
    1202. 

  1202.   utf8_decode_x((unsigned char *)chars, istart, ifinish,
    1203. 

  1203. 		v, 0, -1,
    1204. 

  1204. 		NULL, NULL, 0, 0,
    1205. 

  1205. 		NULL, 0, 
    1206. 

  1206. 		(perm > -1) ? 0xD800 : 0);
    1207. 

  1207.   
    1208. 

  1208.   if (perm > -1) {
    1209. 

  1209.     for (i = 0; i < ulen; i++) {
    1210. 

  1210.       if (v[i] == 0xD800)
    1211. 

  1211. 	v[i] = perm;
    1212. 

  1212.     }
    1213. 

  1213.   }
    1214. 

  1214.   v[ulen] = 0;
    1215. 

  1215. 

  1216.   return scheme_make_sized_char_string(v, ulen, 0);
    1217. 

  1217. }
    1218. 

  1218. 

  1219. static Scheme_Object *
    1220. 

  1220. do_byte_string_to_char_string_locale(const char *who,
    1221. 

  1221. 				     Scheme_Object *bstr,
    1222. 

  1222. 				     intptr_t istart, intptr_t ifinish,
    1223. 

  1223. 				     int perm)
    1224. 

  1224. {
    1225. 

  1225.   char *us;
    1226. 

  1226.   intptr_t olen;
    1227. 

  1227. 

  1228.   reset_locale();
    1229. 

  1229. 

  1230.   if (mzLOCALE_IS_UTF_8(current_locale_name) || !locale_on
    1231. 

  1231.       || !(rktio_convert_properties(scheme_rktio) & RKTIO_CONVERTER_SUPPORTED))
    1232. 

  1232.     return do_byte_string_to_char_string(who, bstr, istart, ifinish, perm, 1);
    1233. 

  1233. 

  1234.   if (istart < ifinish) {
    1235. 

  1235.     int no_cvt;
    1236. 

  1236. 

  1237.     us = string_to_from_locale(0, SCHEME_BYTE_STR_VAL(bstr),
    1238. 

  1238. 			       istart, ifinish - istart,
    1239. 

  1239. 			       &olen, perm, &no_cvt);
    1240. 

  1240. 

  1241.     if (!us) {
    1242. 

  1242.       if (no_cvt) {
    1243. 

  1243. 	return do_byte_string_to_char_string(who, bstr, istart, ifinish, perm, 1);
    1244. 

  1244.       } else {
    1245. 

  1245. 	scheme_contract_error(who,
    1246. 

  1246.                               "byte string is not a valid encoding for the current locale",
    1247. 

  1247.                               "byte string", 1, bstr,
    1248. 

  1248.                               NULL);
    1249. 

  1249.       }
    1250. 

  1250.     }
    1251. 

  1251.     ((mzchar *)us)[olen] = 0;
    1252. 

  1252.   } else {
    1253. 

  1253.     us = "\0\0\0";
    1254. 

  1254.     olen = 0;
    1255. 

  1255.   }
    1256. 

  1256. 

  1257.   return scheme_make_sized_char_string((mzchar *)us, olen, 0);
    1258. 

  1258. }
    1259. 

  1259. 

  1260. static Scheme_Object *
    1261. 

  1261. do_string_to_vector(const char *who, int mode, int argc, Scheme_Object *argv[])
    1262. 

  1262. {
    1263. 

  1263.   int permc;
    1264. 

  1264.   intptr_t istart, ifinish;
    1265. 

  1265. 

  1266.   if (!SCHEME_BYTE_STRINGP(argv[0]))
    1267. 

  1267.     scheme_wrong_contract(who, "bytes?", 0, argc, argv);
    1268. 

  1268. 

  1269.   if ((argc < 2) || SCHEME_FALSEP(argv[1]))
    1270. 

  1270.     permc = -1;
    1271. 

  1271.   else {
    1272. 

  1272.     if (!SCHEME_CHARP(argv[1]))
    1273. 

  1273.       scheme_wrong_contract(who, "(or/c char? #f)", 1, argc, argv);
    1274. 

  1274.     permc = SCHEME_CHAR_VAL(argv[1]);
    1275. 

  1275.   }
    1276. 

  1276. 

  1277.   scheme_get_substring_indices(who, argv[0], argc, argv,
    1278. 

  1278. 			       2, 3,
    1279. 

  1279. 			       &istart, &ifinish);
    1280. 

  1280. 

  1281.   if (mode == 0)
    1282. 

  1282.     return do_byte_string_to_char_string(who, argv[0], istart, ifinish, permc, 0);
    1283. 

  1283.   else if (mode == 1)
    1284. 

  1284.     return do_byte_string_to_char_string_locale(who, argv[0], istart, ifinish, permc);
    1285. 

  1285.   else {
    1286. 

  1286.     /* Latin-1 */
    1287. 

  1287.     mzchar *us;
    1288. 

  1288.     unsigned char *s;
    1289. 

  1289.     intptr_t i, len;
    1290. 

  1290.     len = ifinish - istart;
    1291. 

  1291.     s = (unsigned char *)SCHEME_BYTE_STR_VAL(argv[0]);
    1292. 

  1292.     us = (mzchar *)scheme_malloc_atomic((len + 1) * sizeof(mzchar));
    1293. 

  1293.     for (i = istart; i < ifinish; i++) {
    1294. 

  1294.       us[i - istart] = s[i];
    1295. 

  1295.     }
    1296. 

  1296.     us[len] = 0;
    1297. 

  1297. 

  1298.     return scheme_make_sized_char_string(us, len, 0);
    1299. 

  1299.   }
    1300. 

  1300. }
    1301. 

  1301. 

  1302. 

  1303. static Scheme_Object *
    1304. 

  1304. byte_string_to_char_string (int argc, Scheme_Object *argv[])
    1305. 

  1305. {
    1306. 

  1306.   return do_string_to_vector("bytes->string/utf-8", 0, argc, argv);
    1307. 

  1307. }
    1308. 

  1308. 

  1309. static Scheme_Object *
    1310. 

  1310. byte_string_to_char_string_locale (int argc, Scheme_Object *argv[])
    1311. 

  1311. {
    1312. 

  1312.   return do_string_to_vector("bytes->string/locale", 1, argc, argv);
    1313. 

  1313. }
    1314. 

  1314. 

  1315. static Scheme_Object *
    1316. 

  1316. byte_string_to_char_string_latin1 (int argc, Scheme_Object *argv[])
    1317. 

  1317. {
    1318. 

  1318.   return do_string_to_vector("bytes->string/latin-1", 2, argc, argv);
    1319. 

  1319. }
    1320. 

  1320. 

  1321. Scheme_Object *scheme_byte_string_to_char_string(Scheme_Object *o)
    1322. 

  1322. {
    1323. 

  1323.   return do_byte_string_to_char_string("s->s", o, 0, SCHEME_BYTE_STRLEN_VAL(o), 0xFFFD, 0);
    1324. 

  1324. }
    1325. 

  1325. 

  1326. Scheme_Object *scheme_byte_string_to_char_string_locale(Scheme_Object *o)
    1327. 

  1327. {
    1328. 

  1328.   return do_byte_string_to_char_string_locale("s->s", o, 0, SCHEME_BYTE_STRLEN_VAL(o), 0xFFFD);
    1329. 

  1329. }
    1330. 

  1330. 

  1331. /************************* string->bytes *************************/
    1332. 

  1332. 

  1333. static Scheme_Object *do_char_string_to_byte_string(Scheme_Object *s, intptr_t istart, intptr_t ifinish, 
    1334. 

  1334. 						    int as_locale)
    1335. 

  1335. {
    1336. 

  1336.   char *bs;
    1337. 

  1337.   int slen;
    1338. 

  1338. 

  1339.   slen = scheme_utf8_encode(SCHEME_CHAR_STR_VAL(s), istart, ifinish,
    1340. 

  1340. 			    NULL, 0,
    1341. 

  1341. 			    0 /* UTF-16 */);
    1342. 

  1342.   bs = (char *)scheme_malloc_atomic(slen + 1);
    1343. 

  1343.   scheme_utf8_encode(SCHEME_CHAR_STR_VAL(s), istart, ifinish,
    1344. 

  1344. 		     (unsigned char *)bs, 0,
    1345. 

  1345. 		     0 /* UTF-16 */);
    1346. 

  1346.   bs[slen] = 0;
    1347. 

  1347. 

  1348.   return scheme_make_sized_byte_string(bs, slen, 0);
    1349. 

  1349. }
    1350. 

  1350. 

  1351. static Scheme_Object *
    1352. 

  1352. do_char_string_to_byte_string_locale(const char *who,
    1353. 

  1353. 				     Scheme_Object *cstr,
    1354. 

  1354. 				     intptr_t istart, intptr_t ifinish,
    1355. 

  1355. 				     int perm)
    1356. 

  1356. {
    1357. 

  1357.   char *s;
    1358. 

  1358.   intptr_t olen;
    1359. 

  1359. 

  1360.   reset_locale();
    1361. 

  1361. 

  1362.   if (mzLOCALE_IS_UTF_8(current_locale_name) || !locale_on
    1363. 

  1363.       || !(rktio_convert_properties(scheme_rktio) & RKTIO_CONVERTER_SUPPORTED))
    1364. 

  1364.     return do_char_string_to_byte_string(cstr, istart, ifinish, 1);
    1365. 

  1365. 

  1366.   if (istart < ifinish) {
    1367. 

  1367.     int no_cvt;
    1368. 

  1368. 

  1369.     s = string_to_from_locale(1, (char *)SCHEME_CHAR_STR_VAL(cstr),
    1370. 

  1370. 			      istart, ifinish - istart,
    1371. 

  1371. 			      &olen, perm, &no_cvt);
    1372. 

  1372. 

  1373.     if (!s) {
    1374. 

  1374.       if (no_cvt) {
    1375. 

  1375. 	return do_char_string_to_byte_string(cstr, istart, ifinish, 1);
    1376. 

  1376.       } else {
    1377. 

  1377. 	scheme_contract…
    1378.