1 /* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
25 #include "libguile/_scm.h"
32 #include "libguile/unif.h"
33 #include "libguile/eval.h"
34 #include "libguile/ports.h"
35 #include "libguile/read.h"
36 #include "libguile/root.h"
37 #include "libguile/strings.h"
38 #include "libguile/modules.h"
39 #include "libguile/validate.h"
40 #include "libguile/deprecation.h"
42 #include "libguile/strports.h"
50 /* {Ports - string ports}
56 We break the rules set forth by strings.h about accessing the
57 internals of strings here. We can do this since we can guarantee
58 that the string used as pt->stream is not in use by anyone else.
59 Thus, it's representation will not change asynchronously.
61 (Ports aren't thread-safe yet anyway...)
63 write_buf/write_end point to the ends of the allocated string.
64 read_buf/read_end in principle point to the part of the string which
65 has been written to, but this is only updated after a flush.
66 read_pos and write_pos in principle should be equal, but this is only true
67 when rw_active is SCM_PORT_NEITHER.
69 ENHANCE-ME - output blocks:
71 The current code keeps an output string as a single block. That means
72 when the size is increased the entire old contents must be copied. It'd
73 be more efficient to begin a new block when the old one is full, so
74 there's no re-copying of previous data.
76 To make seeking efficient, keeping the pieces in a vector might be best,
77 though appending is probably the most common operation. The size of each
78 block could be progressively increased, so the bigger the string the
81 When `get-output-string' is called the blocks have to be coalesced into a
82 string, the result could be kept as a single big block. If blocks were
83 strings then `get-output-string' could notice when there's just one and
84 return that with a copy-on-write (though repeated calls to
85 `get-output-string' are probably unlikely).
87 Another possibility would be to extend the port mechanism to let SCM
88 strings come through directly from `display' and friends. That way if a
89 big string is written it can be kept as a copy-on-write, saving time
90 copying and maybe saving some space. */
93 scm_t_bits scm_tc16_strport;
97 stfill_buffer (SCM port)
99 scm_t_port *pt = SCM_PTAB_ENTRY (port);
101 if (pt->read_pos >= pt->read_end)
104 return scm_return_first_int (*pt->read_pos, port);
107 /* change the size of a port's string to new_size. this doesn't
108 change read_buf_size. */
110 st_resize_port (scm_t_port *pt, off_t new_size)
112 SCM old_stream = SCM_PACK (pt->stream);
113 const char *src = scm_i_string_chars (old_stream);
115 SCM new_stream = scm_i_make_string (new_size, &dst);
116 unsigned long int old_size = scm_i_string_length (old_stream);
117 unsigned long int min_size = min (old_size, new_size);
120 off_t index = pt->write_pos - pt->write_buf;
122 pt->write_buf_size = new_size;
124 for (i = 0; i != min_size; ++i)
127 scm_remember_upto_here_1 (old_stream);
131 pt->stream = SCM_UNPACK (new_stream);
132 pt->read_buf = pt->write_buf = (unsigned char *)dst;
133 pt->read_pos = pt->write_pos = pt->write_buf + index;
134 pt->write_end = pt->write_buf + pt->write_buf_size;
135 pt->read_end = pt->read_buf + pt->read_buf_size;
139 /* amount by which write_buf is expanded. */
140 #define SCM_WRITE_BLOCK 80
142 /* ensure that write_pos < write_end by enlarging the buffer when
143 necessary. update read_buf to account for written chars.
145 The buffer is enlarged by 1.5 times, plus SCM_WRITE_BLOCK. Adding just a
146 fixed amount is no good, because there's a block copy for each increment,
147 and that copying would take quadratic time. In the past it was found to
148 be very slow just adding 80 bytes each time (eg. about 10 seconds for
149 writing a 100kbyte string). */
154 scm_t_port *pt = SCM_PTAB_ENTRY (port);
156 if (pt->write_pos == pt->write_end)
158 st_resize_port (pt, pt->write_buf_size * 3 / 2 + SCM_WRITE_BLOCK);
160 pt->read_pos = pt->write_pos;
161 if (pt->read_pos > pt->read_end)
163 pt->read_end = (unsigned char *) pt->read_pos;
164 pt->read_buf_size = pt->read_end - pt->read_buf;
166 pt->rw_active = SCM_PORT_NEITHER;
170 st_write (SCM port, const void *data, size_t size)
172 scm_t_port *pt = SCM_PTAB_ENTRY (port);
173 const char *input = (char *) data;
177 int space = pt->write_end - pt->write_pos;
178 int write_len = (size > space) ? space : size;
180 memcpy ((char *) pt->write_pos, input, write_len);
181 pt->write_pos += write_len;
184 if (write_len == space)
190 st_end_input (SCM port, int offset)
192 scm_t_port *pt = SCM_PTAB_ENTRY (port);
194 if (pt->read_pos - pt->read_buf < offset)
195 scm_misc_error ("st_end_input", "negative position", SCM_EOL);
197 pt->write_pos = (unsigned char *) (pt->read_pos = pt->read_pos - offset);
198 pt->rw_active = SCM_PORT_NEITHER;
202 st_seek (SCM port, off_t offset, int whence)
204 scm_t_port *pt = SCM_PTAB_ENTRY (port);
207 if (pt->rw_active == SCM_PORT_READ && offset == 0 && whence == SEEK_CUR)
208 /* special case to avoid disturbing the unread-char buffer. */
210 if (pt->read_buf == pt->putback_buf)
212 target = pt->saved_read_pos - pt->saved_read_buf
213 - (pt->read_end - pt->read_pos);
217 target = pt->read_pos - pt->read_buf;
221 /* all other cases. */
223 if (pt->rw_active == SCM_PORT_WRITE)
226 if (pt->rw_active == SCM_PORT_READ)
227 scm_end_input (port);
232 target = pt->read_pos - pt->read_buf + offset;
235 target = pt->read_end - pt->read_buf + offset;
237 default: /* SEEK_SET */
243 scm_misc_error ("st_seek", "negative offset", SCM_EOL);
245 if (target >= pt->write_buf_size)
247 if (!(SCM_CELL_WORD_0 (port) & SCM_WRTNG))
249 if (target > pt->write_buf_size)
251 scm_misc_error ("st_seek",
252 "seek past end of read-only strport",
258 st_resize_port (pt, target + (target == pt->write_buf_size
263 pt->read_pos = pt->write_pos = pt->read_buf + target;
264 if (pt->read_pos > pt->read_end)
266 pt->read_end = (unsigned char *) pt->read_pos;
267 pt->read_buf_size = pt->read_end - pt->read_buf;
274 st_truncate (SCM port, off_t length)
276 scm_t_port *pt = SCM_PTAB_ENTRY (port);
278 if (length > pt->write_buf_size)
279 st_resize_port (pt, length);
281 pt->read_buf_size = length;
282 pt->read_end = pt->read_buf + length;
283 if (pt->read_pos > pt->read_end)
284 pt->read_pos = pt->read_end;
286 if (pt->write_pos > pt->read_end)
287 pt->write_pos = pt->read_end;
291 scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
295 size_t str_len, c_pos;
297 SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
299 str_len = scm_i_string_length (str);
300 c_pos = scm_to_unsigned_integer (pos, 0, str_len);
302 if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG)))
303 scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL);
307 Make a new string to isolate us from changes to the original.
308 This is done so that we can rely on scm_i_string_chars to stay in
309 place even across SCM_TICKs.
311 Additionally, when we are going to write to the string, we make a
312 copy so that we can write to it without having to use
313 scm_i_string_writable_chars.
316 if (modes & SCM_WRTNG)
317 str = scm_c_substring_copy (str, 0, str_len);
319 str = scm_c_substring (str, 0, str_len);
321 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
322 z = scm_new_port_table_entry (scm_tc16_strport);
323 pt = SCM_PTAB_ENTRY(z);
324 SCM_SETSTREAM (z, SCM_UNPACK (str));
325 SCM_SET_CELL_TYPE(z, scm_tc16_strport|modes);
326 /* see above why we can use scm_i_string_chars here. */
327 pt->write_buf = pt->read_buf = (unsigned char *) scm_i_string_chars (str);
328 pt->read_pos = pt->write_pos = pt->read_buf + c_pos;
329 pt->write_buf_size = pt->read_buf_size = str_len;
330 pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size;
334 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
336 /* ensure write_pos is writable. */
337 if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end)
342 /* create a new string from a string port's buffer. */
343 SCM scm_strport_to_string (SCM port)
345 scm_t_port *pt = SCM_PTAB_ENTRY (port);
349 if (pt->rw_active == SCM_PORT_WRITE)
352 str = scm_i_make_string (pt->read_buf_size, &dst);
353 memcpy (dst, (char *) pt->read_buf, pt->read_buf_size);
354 scm_remember_upto_here_1 (port);
358 SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0,
359 (SCM obj, SCM printer),
360 "Return a Scheme string obtained by printing @var{obj}.\n"
361 "Printing function can be specified by the optional second\n"
362 "argument @var{printer} (default: @code{write}).")
363 #define FUNC_NAME s_scm_object_to_string
367 if (!SCM_UNBNDP (printer))
368 SCM_VALIDATE_PROC (2, printer);
370 str = scm_c_make_string (0, SCM_UNDEFINED);
371 port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, FUNC_NAME);
373 if (SCM_UNBNDP (printer))
374 scm_write (obj, port);
376 scm_call_2 (printer, obj, port);
378 return scm_strport_to_string (port);
382 SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0,
384 "Calls the one-argument procedure @var{proc} with a newly created output\n"
385 "port. When the function returns, the string composed of the characters\n"
386 "written into the port is returned.")
387 #define FUNC_NAME s_scm_call_with_output_string
391 p = scm_mkstrport (SCM_INUM0,
392 scm_make_string (SCM_INUM0, SCM_UNDEFINED),
395 scm_call_1 (proc, p);
397 return scm_get_output_string (p);
401 SCM_DEFINE (scm_call_with_input_string, "call-with-input-string", 2, 0, 0,
402 (SCM string, SCM proc),
403 "Calls the one-argument procedure @var{proc} with a newly\n"
404 "created input port from which @var{string}'s contents may be\n"
405 "read. The value yielded by the @var{proc} is returned.")
406 #define FUNC_NAME s_scm_call_with_input_string
408 SCM p = scm_mkstrport(SCM_INUM0, string, SCM_OPN | SCM_RDNG, FUNC_NAME);
409 return scm_call_1 (proc, p);
413 SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0,
415 "Take a string and return an input port that delivers characters\n"
416 "from the string. The port can be closed by\n"
417 "@code{close-input-port}, though its storage will be reclaimed\n"
418 "by the garbage collector if it becomes inaccessible.")
419 #define FUNC_NAME s_scm_open_input_string
421 SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, FUNC_NAME);
426 SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0,
428 "Return an output port that will accumulate characters for\n"
429 "retrieval by @code{get-output-string}. The port can be closed\n"
430 "by the procedure @code{close-output-port}, though its storage\n"
431 "will be reclaimed by the garbage collector if it becomes\n"
433 #define FUNC_NAME s_scm_open_output_string
437 p = scm_mkstrport (SCM_INUM0,
438 scm_make_string (SCM_INUM0, SCM_UNDEFINED),
445 SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0,
447 "Given an output port created by @code{open-output-string},\n"
448 "return a string consisting of the characters that have been\n"
449 "output to the port so far.")
450 #define FUNC_NAME s_scm_get_output_string
452 SCM_VALIDATE_OPOUTSTRPORT (1, port);
453 return scm_strport_to_string (port);
458 /* Given a null-terminated string EXPR containing a Scheme expression
459 read it, and return it as an SCM value. */
461 scm_c_read_string (const char *expr)
463 SCM port = scm_mkstrport (SCM_INUM0,
464 scm_from_locale_string (expr),
466 "scm_c_read_string");
469 /* Read expressions from that port; ignore the values. */
470 form = scm_read (port);
472 scm_close_port (port);
476 /* Given a null-terminated string EXPR containing Scheme program text,
477 evaluate it, and return the result of the last expression evaluated. */
479 scm_c_eval_string (const char *expr)
481 return scm_eval_string (scm_from_locale_string (expr));
485 scm_c_eval_string_in_module (const char *expr, SCM module)
487 return scm_eval_string_in_module (scm_from_locale_string (expr), module);
492 inner_eval_string (void *data)
494 SCM port = (SCM)data;
496 SCM ans = SCM_UNSPECIFIED;
498 /* Read expressions from that port; ignore the values. */
499 while (!SCM_EOF_OBJECT_P (form = scm_read (port)))
500 ans = scm_primitive_eval_x (form);
502 /* Don't close the port here; if we re-enter this function via a
503 continuation, then the next time we enter it, we'll get an error.
504 It's a string port anyway, so there's no advantage to closing it
510 SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0,
511 (SCM string, SCM module),
512 "Evaluate @var{string} as the text representation of a Scheme\n"
513 "form or forms, and return whatever value they produce.\n"
514 "Evaluation takes place in the given module, or the current\n"
515 "module when no module is given.\n"
516 "While the code is evaluated, the given module is made the\n"
517 "current one. The current module is restored when this\n"
518 "procedure returns.")
519 #define FUNC_NAME s_scm_eval_string_in_module
521 SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG,
523 if (SCM_UNBNDP (module))
524 module = scm_current_module ();
526 SCM_VALIDATE_MODULE (2, module);
527 return scm_c_call_with_current_module (module,
528 inner_eval_string, (void *)port);
533 scm_eval_string (SCM string)
535 return scm_eval_string_in_module (string, SCM_UNDEFINED);
541 scm_t_bits tc = scm_make_port_type ("string", stfill_buffer, st_write);
543 scm_set_port_mark (tc, scm_markstream);
544 scm_set_port_end_input (tc, st_end_input);
545 scm_set_port_flush (tc, st_flush);
546 scm_set_port_seek (tc, st_seek);
547 scm_set_port_truncate (tc, st_truncate);
555 scm_tc16_strport = scm_make_stptob ();
557 #include "libguile/strports.x"