strports.c 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417
  1. /* Copyright 1995,1996,1998-2003,2005-2006,2009-2014,2016-2019
  2. Free Software Foundation, Inc.
  3. This file is part of Guile.
  4. Guile is free software: you can redistribute it and/or modify it
  5. under the terms of the GNU Lesser General Public License as published
  6. by the Free Software Foundation, either version 3 of the License, or
  7. (at your option) any later version.
  8. Guile is distributed in the hope that it will be useful, but WITHOUT
  9. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  10. FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
  11. License for more details.
  12. You should have received a copy of the GNU Lesser General Public
  13. License along with Guile. If not, see
  14. <https://www.gnu.org/licenses/>. */
  15. #ifdef HAVE_CONFIG_H
  16. # include <config.h>
  17. #endif
  18. #include <stdio.h>
  19. #include <string.h>
  20. #include <unistd.h>
  21. #include <intprops.h>
  22. #include "bytevectors.h"
  23. #include "deprecation.h"
  24. #include "eval.h"
  25. #include "gsubr.h"
  26. #include "keywords.h"
  27. #include "modules.h"
  28. #include "ports.h"
  29. #include "procs.h"
  30. #include "read.h"
  31. #include "srfi-4.h"
  32. #include "strings.h"
  33. #include "symbols.h"
  34. #include "syscalls.h"
  35. #include "threads.h"
  36. #include "variable.h"
  37. #include "strports.h"
  38. /* {Ports - string ports}
  39. *
  40. */
  41. SCM_SYMBOL (sym_UTF_8, "UTF-8");
  42. scm_t_port_type *scm_string_port_type;
  43. struct string_port {
  44. SCM bytevector;
  45. size_t pos;
  46. size_t len;
  47. };
  48. static size_t
  49. string_port_read (SCM port, SCM dst, size_t start, size_t count)
  50. {
  51. struct string_port *stream = (void *) SCM_STREAM (port);
  52. if (stream->pos >= stream->len)
  53. return 0;
  54. if (count > stream->len - stream->pos)
  55. count = stream->len - stream->pos;
  56. memcpy (SCM_BYTEVECTOR_CONTENTS (dst) + start,
  57. SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos,
  58. count);
  59. stream->pos += count;
  60. return count;
  61. }
  62. #define MAX(A, B) ((A) >= (B) ? (A) : (B))
  63. static size_t
  64. string_port_write (SCM port, SCM src, size_t start, size_t count)
  65. #define FUNC_NAME "string_port_write"
  66. {
  67. struct string_port *stream = (void *) SCM_STREAM (port);
  68. size_t old_size = SCM_BYTEVECTOR_LENGTH (stream->bytevector);
  69. if (count > old_size - stream->pos)
  70. {
  71. SCM new_bv;
  72. size_t new_size;
  73. if (INT_ADD_OVERFLOW (stream->pos, count))
  74. scm_num_overflow (FUNC_NAME);
  75. /* If (old_size * 2) overflows, it's harmless. */
  76. new_size = MAX (old_size * 2, stream->pos + count);
  77. new_bv = scm_c_make_bytevector (new_size);
  78. memcpy (SCM_BYTEVECTOR_CONTENTS (new_bv),
  79. SCM_BYTEVECTOR_CONTENTS (stream->bytevector),
  80. stream->len);
  81. stream->bytevector = new_bv;
  82. }
  83. memcpy (SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos,
  84. SCM_BYTEVECTOR_CONTENTS (src) + start,
  85. count);
  86. stream->pos += count;
  87. if (stream->pos > stream->len)
  88. stream->len = stream->pos;
  89. return count;
  90. }
  91. #undef FUNC_NAME
  92. static scm_t_off
  93. string_port_seek (SCM port, scm_t_off offset, int whence)
  94. #define FUNC_NAME "string_port_seek"
  95. {
  96. struct string_port *stream = (void *) SCM_STREAM (port);
  97. size_t base;
  98. scm_t_off target;
  99. if (whence == SEEK_CUR)
  100. base = stream->pos;
  101. else if (whence == SEEK_SET)
  102. base = 0;
  103. else if (whence == SEEK_END)
  104. base = stream->len;
  105. else
  106. scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "invalid `seek' parameter");
  107. if (base > SCM_T_OFF_MAX
  108. || INT_ADD_OVERFLOW ((scm_t_off) base, offset))
  109. scm_num_overflow (FUNC_NAME);
  110. target = (scm_t_off) base + offset;
  111. if (target >= 0 && target <= stream->len)
  112. stream->pos = target;
  113. else
  114. scm_out_of_range (FUNC_NAME, scm_from_off_t (offset));
  115. return target;
  116. }
  117. #undef FUNC_NAME
  118. static void
  119. string_port_truncate (SCM port, scm_t_off length)
  120. #define FUNC_NAME "string_port_truncate"
  121. {
  122. struct string_port *stream = (void *) SCM_STREAM (port);
  123. if (0 <= length && stream->pos <= length && length <= stream->len)
  124. stream->len = length;
  125. else
  126. scm_out_of_range (FUNC_NAME, scm_from_off_t (length));
  127. }
  128. #undef FUNC_NAME
  129. /* The initial size in bytes of a string port's buffer. */
  130. #define INITIAL_BUFFER_SIZE 128
  131. /* Return a new string port with MODES. If STR is #f, a new backing
  132. buffer is allocated; otherwise STR must be a string and a copy of it
  133. serves as the buffer for the new port. */
  134. SCM
  135. scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
  136. {
  137. SCM buf;
  138. size_t len, byte_pos;
  139. struct string_port *stream;
  140. if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG)))
  141. scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL);
  142. if (scm_is_false (str))
  143. {
  144. /* Allocate a new buffer to write to. */
  145. buf = scm_c_make_bytevector (INITIAL_BUFFER_SIZE);
  146. len = byte_pos = 0;
  147. }
  148. else
  149. {
  150. SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
  151. buf = scm_string_to_utf8 (str);
  152. len = scm_c_bytevector_length (buf);
  153. if (scm_is_eq (pos, SCM_INUM0))
  154. byte_pos = 0;
  155. else
  156. /* Inefficient but simple way to convert the character position
  157. POS into a byte position BYTE_POS. */
  158. byte_pos = scm_c_string_utf8_length
  159. (scm_substring (str, SCM_INUM0, pos));
  160. }
  161. stream = scm_gc_typed_calloc (struct string_port);
  162. stream->bytevector = buf;
  163. stream->pos = byte_pos;
  164. stream->len = len;
  165. return
  166. scm_c_make_port_with_encoding (scm_string_port_type, modes, sym_UTF_8,
  167. scm_i_default_port_conversion_strategy (),
  168. (scm_t_bits) stream);
  169. }
  170. /* Create a new string from the buffer of PORT, a string port, converting from
  171. PORT's encoding to the standard string representation. */
  172. SCM
  173. scm_strport_to_string (SCM port)
  174. {
  175. signed char *ptr;
  176. struct string_port *stream = (void *) SCM_STREAM (port);
  177. scm_flush (port);
  178. if (stream->len == 0)
  179. return scm_nullstr;
  180. ptr = SCM_BYTEVECTOR_CONTENTS (stream->bytevector);
  181. return scm_from_port_stringn ((char *) ptr, stream->len, port);
  182. }
  183. SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0,
  184. (SCM obj, SCM printer),
  185. "Return a Scheme string obtained by printing @var{obj}.\n"
  186. "Printing function can be specified by the optional second\n"
  187. "argument @var{printer} (default: @code{write}).")
  188. #define FUNC_NAME s_scm_object_to_string
  189. {
  190. SCM port, result;
  191. if (!SCM_UNBNDP (printer))
  192. SCM_VALIDATE_PROC (2, printer);
  193. port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_WRTNG, FUNC_NAME);
  194. if (SCM_UNBNDP (printer))
  195. scm_write (obj, port);
  196. else
  197. scm_call_2 (printer, obj, port);
  198. result = scm_strport_to_string (port);
  199. /* Explicitly close PORT so that the iconv CDs associated with it are
  200. deallocated right away. This is important because CDs use a lot of
  201. memory that's not visible to the GC, so not freeing them can lead
  202. to almost large heap usage. See
  203. <http://wingolog.org/archives/2011/02/25/ports-weaks-gc-and-dark-matter>
  204. for details. */
  205. scm_close_port (port);
  206. return result;
  207. }
  208. #undef FUNC_NAME
  209. SCM
  210. scm_call_with_output_string (SCM proc)
  211. {
  212. static SCM var = SCM_BOOL_F;
  213. if (scm_is_false (var))
  214. var = scm_c_private_lookup ("guile", "call-with-output-string");
  215. return scm_call_1 (scm_variable_ref (var), proc);
  216. }
  217. SCM
  218. scm_call_with_input_string (SCM string, SCM proc)
  219. {
  220. static SCM var = SCM_BOOL_F;
  221. if (scm_is_false (var))
  222. var = scm_c_private_lookup ("guile", "call-with-input-string");
  223. return scm_call_2 (scm_variable_ref (var), string, proc);
  224. }
  225. SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0,
  226. (SCM str),
  227. "Take a string and return an input port that delivers characters\n"
  228. "from the string. The port can be closed by\n"
  229. "@code{close-input-port}, though its storage will be reclaimed\n"
  230. "by the garbage collector if it becomes inaccessible.")
  231. #define FUNC_NAME s_scm_open_input_string
  232. {
  233. return scm_mkstrport (SCM_INUM0, str, SCM_RDNG, FUNC_NAME);
  234. }
  235. #undef FUNC_NAME
  236. SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0,
  237. (void),
  238. "Return an output port that will accumulate characters for\n"
  239. "retrieval by @code{get-output-string}. The port can be closed\n"
  240. "by the procedure @code{close-output-port}, though its storage\n"
  241. "will be reclaimed by the garbage collector if it becomes\n"
  242. "inaccessible.")
  243. #define FUNC_NAME s_scm_open_output_string
  244. {
  245. return scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_WRTNG, FUNC_NAME);
  246. }
  247. #undef FUNC_NAME
  248. SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0,
  249. (SCM port),
  250. "Given an output port created by @code{open-output-string},\n"
  251. "return a string consisting of the characters that have been\n"
  252. "output to the port so far.")
  253. #define FUNC_NAME s_scm_get_output_string
  254. {
  255. SCM_VALIDATE_OPOUTSTRPORT (1, port);
  256. return scm_strport_to_string (port);
  257. }
  258. #undef FUNC_NAME
  259. /* Given a null-terminated string EXPR containing a Scheme expression
  260. read it, and return it as an SCM value. */
  261. SCM
  262. scm_c_read_string (const char *expr)
  263. {
  264. SCM port, form;
  265. port = scm_mkstrport (SCM_INUM0, scm_from_locale_string (expr),
  266. SCM_RDNG, "scm_c_read_string");
  267. form = scm_read (port);
  268. scm_close_port (port);
  269. return form;
  270. }
  271. /* Given a null-terminated string EXPR containing Scheme program text,
  272. evaluate it, and return the result of the last expression evaluated. */
  273. SCM
  274. scm_c_eval_string (const char *expr)
  275. {
  276. return scm_eval_string (scm_from_locale_string (expr));
  277. }
  278. SCM
  279. scm_c_eval_string_in_module (const char *expr, SCM module)
  280. {
  281. return scm_eval_string_in_module (scm_from_locale_string (expr), module);
  282. }
  283. static SCM eval_string_var;
  284. static SCM k_module;
  285. static void
  286. init_eval_string_var_and_k_module (void)
  287. {
  288. eval_string_var = scm_c_public_variable ("ice-9 eval-string", "eval-string");
  289. k_module = scm_from_utf8_keyword ("module");
  290. }
  291. SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0,
  292. (SCM string, SCM module),
  293. "Evaluate @var{string} as the text representation of a Scheme\n"
  294. "form or forms, and return whatever value they produce.\n"
  295. "Evaluation takes place in the given module, or the current\n"
  296. "module when no module is given.\n"
  297. "While the code is evaluated, the given module is made the\n"
  298. "current one. The current module is restored when this\n"
  299. "procedure returns.")
  300. #define FUNC_NAME s_scm_eval_string_in_module
  301. {
  302. static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
  303. scm_i_pthread_once (&once, init_eval_string_var_and_k_module);
  304. if (SCM_UNBNDP (module))
  305. module = scm_current_module ();
  306. else
  307. SCM_VALIDATE_MODULE (2, module);
  308. return scm_call_3 (scm_variable_ref (eval_string_var),
  309. string, k_module, module);
  310. }
  311. #undef FUNC_NAME
  312. SCM
  313. scm_eval_string (SCM string)
  314. {
  315. return scm_eval_string_in_module (string, SCM_UNDEFINED);
  316. }
  317. static scm_t_port_type *
  318. scm_make_string_port_type ()
  319. {
  320. scm_t_port_type *ptob = scm_make_port_type ("string",
  321. string_port_read,
  322. string_port_write);
  323. scm_set_port_seek (ptob, string_port_seek);
  324. scm_set_port_truncate (ptob, string_port_truncate);
  325. return ptob;
  326. }
  327. void
  328. scm_init_strports ()
  329. {
  330. scm_string_port_type = scm_make_string_port_type ();
  331. #include "strports.x"
  332. }