1 /* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009, 2010, 2011 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 License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * 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
26 #include "libguile/_scm.h"
33 #include "libguile/bytevectors.h"
34 #include "libguile/eval.h"
35 #include "libguile/ports.h"
36 #include "libguile/read.h"
37 #include "libguile/root.h"
38 #include "libguile/strings.h"
39 #include "libguile/modules.h"
40 #include "libguile/validate.h"
41 #include "libguile/deprecation.h"
42 #include "libguile/srfi-4.h"
44 #include "libguile/strports.h"
52 /* {Ports - string ports}
58 write_buf/write_end point to the ends of the allocated bytevector.
59 read_buf/read_end in principle point to the part of the bytevector which
60 has been written to, but this is only updated after a flush.
61 read_pos and write_pos in principle should be equal, but this is only true
62 when rw_active is SCM_PORT_NEITHER.
64 ENHANCE-ME - output blocks:
66 The current code keeps an output string as a single block. That means
67 when the size is increased the entire old contents must be copied. It'd
68 be more efficient to begin a new block when the old one is full, so
69 there's no re-copying of previous data.
71 To make seeking efficient, keeping the pieces in a vector might be best,
72 though appending is probably the most common operation. The size of each
73 block could be progressively increased, so the bigger the string the
76 When `get-output-string' is called the blocks have to be coalesced into a
77 string, the result could be kept as a single big block. If blocks were
78 strings then `get-output-string' could notice when there's just one and
79 return that with a copy-on-write (though repeated calls to
80 `get-output-string' are probably unlikely).
82 Another possibility would be to extend the port mechanism to let SCM
83 strings come through directly from `display' and friends. That way if a
84 big string is written it can be kept as a copy-on-write, saving time
85 copying and maybe saving some space. */
88 scm_t_bits scm_tc16_strport
;
92 stfill_buffer (SCM port
)
94 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
96 if (pt
->read_pos
>= pt
->read_end
)
99 return scm_return_first_int (*pt
->read_pos
, port
);
102 /* Change the size of a port's bytevector to NEW_SIZE. This doesn't
103 change `read_buf_size'. */
105 st_resize_port (scm_t_port
*pt
, scm_t_off new_size
)
107 SCM old_stream
= SCM_PACK (pt
->stream
);
108 const signed char *src
= SCM_BYTEVECTOR_CONTENTS (old_stream
);
109 SCM new_stream
= scm_c_make_bytevector (new_size
);
110 signed char *dst
= SCM_BYTEVECTOR_CONTENTS (new_stream
);
111 unsigned long int old_size
= SCM_BYTEVECTOR_LENGTH (old_stream
);
112 unsigned long int min_size
= min (old_size
, new_size
);
114 scm_t_off index
= pt
->write_pos
- pt
->write_buf
;
116 pt
->write_buf_size
= new_size
;
118 memcpy (dst
, src
, min_size
);
120 scm_remember_upto_here_1 (old_stream
);
124 pt
->stream
= SCM_UNPACK (new_stream
);
125 pt
->read_buf
= pt
->write_buf
= (unsigned char *)dst
;
126 pt
->read_pos
= pt
->write_pos
= pt
->write_buf
+ index
;
127 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
128 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
132 /* Ensure that `write_pos' < `write_end' by enlarging the buffer when
133 necessary. Update `read_buf' to account for written chars. The
134 buffer is enlarged geometrically. */
138 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
140 if (pt
->write_pos
== pt
->write_end
)
141 st_resize_port (pt
, pt
->write_buf_size
* 2);
143 pt
->read_pos
= pt
->write_pos
;
144 if (pt
->read_pos
> pt
->read_end
)
146 pt
->read_end
= (unsigned char *) pt
->read_pos
;
147 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
149 pt
->rw_active
= SCM_PORT_NEITHER
;
153 st_write (SCM port
, const void *data
, size_t size
)
155 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
156 const char *input
= (char *) data
;
160 int space
= pt
->write_end
- pt
->write_pos
;
161 int write_len
= (size
> space
) ? space
: size
;
163 memcpy ((char *) pt
->write_pos
, input
, write_len
);
164 pt
->write_pos
+= write_len
;
167 if (write_len
== space
)
173 st_end_input (SCM port
, int offset
)
175 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
177 if (pt
->read_pos
- pt
->read_buf
< offset
)
178 scm_misc_error ("st_end_input", "negative position", SCM_EOL
);
180 pt
->write_pos
= (unsigned char *) (pt
->read_pos
= pt
->read_pos
- offset
);
181 pt
->rw_active
= SCM_PORT_NEITHER
;
185 st_seek (SCM port
, scm_t_off offset
, int whence
)
187 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
190 if (pt
->rw_active
== SCM_PORT_READ
&& offset
== 0 && whence
== SEEK_CUR
)
191 /* special case to avoid disturbing the unread-char buffer. */
193 if (pt
->read_buf
== pt
->putback_buf
)
195 target
= pt
->saved_read_pos
- pt
->saved_read_buf
196 - (pt
->read_end
- pt
->read_pos
);
200 target
= pt
->read_pos
- pt
->read_buf
;
204 /* all other cases. */
206 if (pt
->rw_active
== SCM_PORT_WRITE
)
209 if (pt
->rw_active
== SCM_PORT_READ
)
210 scm_end_input_unlocked (port
);
215 target
= pt
->read_pos
- pt
->read_buf
+ offset
;
218 target
= pt
->read_end
- pt
->read_buf
+ offset
;
220 default: /* SEEK_SET */
226 scm_misc_error ("st_seek", "negative offset", SCM_EOL
);
228 if (target
>= pt
->write_buf_size
)
230 if (!(SCM_CELL_WORD_0 (port
) & SCM_WRTNG
))
232 if (target
> pt
->write_buf_size
)
234 scm_misc_error ("st_seek",
235 "seek past end of read-only strport",
239 else if (target
== pt
->write_buf_size
)
240 st_resize_port (pt
, target
* 2);
242 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ target
;
243 if (pt
->read_pos
> pt
->read_end
)
245 pt
->read_end
= (unsigned char *) pt
->read_pos
;
246 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
253 st_truncate (SCM port
, scm_t_off length
)
255 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
257 if (length
> pt
->write_buf_size
)
258 st_resize_port (pt
, length
);
260 pt
->read_buf_size
= length
;
261 pt
->read_end
= pt
->read_buf
+ length
;
262 if (pt
->read_pos
> pt
->read_end
)
263 pt
->read_pos
= pt
->read_end
;
265 if (pt
->write_pos
> pt
->read_end
)
266 pt
->write_pos
= pt
->read_end
;
269 /* The initial size in bytes of a string port's buffer. */
270 #define INITIAL_BUFFER_SIZE 128
272 /* Return a new string port with MODES. If STR is #f, a new backing
273 buffer is allocated; otherwise STR must be a string and a copy of it
274 serves as the buffer for the new port. */
276 scm_mkstrport (SCM pos
, SCM str
, long modes
, const char *caller
)
280 const char *encoding
;
281 size_t read_buf_size
, str_len
, c_pos
;
284 if (!((modes
& SCM_WRTNG
) || (modes
& SCM_RDNG
)))
285 scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL
);
287 encoding
= scm_i_default_port_encoding ();
289 if (scm_is_false (str
))
291 /* Allocate a new buffer to write to. */
292 str_len
= INITIAL_BUFFER_SIZE
;
293 buf
= scm_c_make_bytevector (str_len
);
294 c_buf
= (char *) SCM_BYTEVECTOR_CONTENTS (buf
);
296 /* Reset `read_buf_size'. It will contain the actual number of
297 bytes written to the port. */
303 /* STR is a string. */
306 SCM_ASSERT (scm_is_string (str
), str
, SCM_ARG1
, caller
);
308 /* Create a copy of STR in ENCODING. */
309 copy
= scm_to_stringn (str
, &str_len
, encoding
,
310 SCM_FAILED_CONVERSION_ERROR
);
311 buf
= scm_c_make_bytevector (str_len
);
312 c_buf
= (char *) SCM_BYTEVECTOR_CONTENTS (buf
);
313 memcpy (c_buf
, copy
, str_len
);
316 c_pos
= scm_to_unsigned_integer (pos
, 0, str_len
);
317 read_buf_size
= str_len
;
320 z
= scm_c_make_port_with_encoding (scm_tc16_strport
, modes
,
322 SCM_FAILED_CONVERSION_ERROR
,
325 pt
= SCM_PTAB_ENTRY (z
);
326 pt
->write_buf
= pt
->read_buf
= (unsigned char *) c_buf
;
327 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ c_pos
;
328 pt
->read_buf_size
= read_buf_size
;
329 pt
->write_buf_size
= str_len
;
330 pt
->write_end
= pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
333 /* Ensure WRITE_POS is writable. */
334 if ((modes
& SCM_WRTNG
) && pt
->write_pos
== pt
->write_end
)
340 /* Create a new string from the buffer of PORT, a string port, converting from
341 PORT's encoding to the standard string representation. */
343 scm_strport_to_string (SCM port
)
346 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
348 if (pt
->rw_active
== SCM_PORT_WRITE
)
351 if (pt
->read_buf_size
== 0)
354 if (pt
->encoding
== NULL
)
357 str
= scm_i_make_string (pt
->read_buf_size
, &buf
, 0);
358 memcpy (buf
, pt
->read_buf
, pt
->read_buf_size
);
361 str
= scm_from_stringn ((char *)pt
->read_buf
, pt
->read_buf_size
,
362 pt
->encoding
, pt
->ilseq_handler
);
363 scm_remember_upto_here_1 (port
);
367 SCM_DEFINE (scm_object_to_string
, "object->string", 1, 1, 0,
368 (SCM obj
, SCM printer
),
369 "Return a Scheme string obtained by printing @var{obj}.\n"
370 "Printing function can be specified by the optional second\n"
371 "argument @var{printer} (default: @code{write}).")
372 #define FUNC_NAME s_scm_object_to_string
376 if (!SCM_UNBNDP (printer
))
377 SCM_VALIDATE_PROC (2, printer
);
379 port
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
380 SCM_OPN
| SCM_WRTNG
, FUNC_NAME
);
382 if (SCM_UNBNDP (printer
))
383 scm_write (obj
, port
);
385 scm_call_2 (printer
, obj
, port
);
387 result
= scm_strport_to_string (port
);
389 /* Explicitly close PORT so that the iconv CDs associated with it are
390 deallocated right away. This is important because CDs use a lot of
391 memory that's not visible to the GC, so not freeing them can lead
392 to almost large heap usage. See
393 <http://wingolog.org/archives/2011/02/25/ports-weaks-gc-and-dark-matter>
395 scm_close_port (port
);
401 SCM_DEFINE (scm_call_with_output_string
, "call-with-output-string", 1, 0, 0,
403 "Calls the one-argument procedure @var{proc} with a newly created output\n"
404 "port. When the function returns, the string composed of the characters\n"
405 "written into the port is returned.")
406 #define FUNC_NAME s_scm_call_with_output_string
410 p
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
413 scm_call_1 (proc
, p
);
415 return scm_get_output_string (p
);
419 SCM_DEFINE (scm_call_with_input_string
, "call-with-input-string", 2, 0, 0,
420 (SCM string
, SCM proc
),
421 "Calls the one-argument procedure @var{proc} with a newly\n"
422 "created input port from which @var{string}'s contents may be\n"
423 "read. The value yielded by the @var{proc} is returned.")
424 #define FUNC_NAME s_scm_call_with_input_string
426 SCM p
= scm_mkstrport(SCM_INUM0
, string
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
427 return scm_call_1 (proc
, p
);
431 SCM_DEFINE (scm_open_input_string
, "open-input-string", 1, 0, 0,
433 "Take a string and return an input port that delivers characters\n"
434 "from the string. The port can be closed by\n"
435 "@code{close-input-port}, though its storage will be reclaimed\n"
436 "by the garbage collector if it becomes inaccessible.")
437 #define FUNC_NAME s_scm_open_input_string
439 SCM p
= scm_mkstrport(SCM_INUM0
, str
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
444 SCM_DEFINE (scm_open_output_string
, "open-output-string", 0, 0, 0,
446 "Return an output port that will accumulate characters for\n"
447 "retrieval by @code{get-output-string}. The port can be closed\n"
448 "by the procedure @code{close-output-port}, though its storage\n"
449 "will be reclaimed by the garbage collector if it becomes\n"
451 #define FUNC_NAME s_scm_open_output_string
455 p
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
462 SCM_DEFINE (scm_get_output_string
, "get-output-string", 1, 0, 0,
464 "Given an output port created by @code{open-output-string},\n"
465 "return a string consisting of the characters that have been\n"
466 "output to the port so far.")
467 #define FUNC_NAME s_scm_get_output_string
469 SCM_VALIDATE_OPOUTSTRPORT (1, port
);
470 return scm_strport_to_string (port
);
475 /* Given a null-terminated string EXPR containing a Scheme expression
476 read it, and return it as an SCM value. */
478 scm_c_read_string (const char *expr
)
480 SCM port
= scm_mkstrport (SCM_INUM0
,
481 scm_from_locale_string (expr
),
483 "scm_c_read_string");
486 form
= scm_read (port
);
488 scm_close_port (port
);
492 /* Given a null-terminated string EXPR containing Scheme program text,
493 evaluate it, and return the result of the last expression evaluated. */
495 scm_c_eval_string (const char *expr
)
497 return scm_eval_string (scm_from_locale_string (expr
));
501 scm_c_eval_string_in_module (const char *expr
, SCM module
)
503 return scm_eval_string_in_module (scm_from_locale_string (expr
), module
);
507 SCM_DEFINE (scm_eval_string_in_module
, "eval-string", 1, 1, 0,
508 (SCM string
, SCM module
),
509 "Evaluate @var{string} as the text representation of a Scheme\n"
510 "form or forms, and return whatever value they produce.\n"
511 "Evaluation takes place in the given module, or the current\n"
512 "module when no module is given.\n"
513 "While the code is evaluated, the given module is made the\n"
514 "current one. The current module is restored when this\n"
515 "procedure returns.")
516 #define FUNC_NAME s_scm_eval_string_in_module
518 static SCM eval_string
= SCM_BOOL_F
, k_module
= SCM_BOOL_F
;
520 if (scm_is_false (eval_string
))
522 eval_string
= scm_c_public_lookup ("ice-9 eval-string", "eval-string");
523 k_module
= scm_from_locale_keyword ("module");
526 if (SCM_UNBNDP (module
))
527 module
= scm_current_module ();
529 SCM_VALIDATE_MODULE (2, module
);
531 return scm_call_3 (scm_variable_ref (eval_string
), string
, k_module
, module
);
536 scm_eval_string (SCM string
)
538 return scm_eval_string_in_module (string
, SCM_UNDEFINED
);
544 scm_t_bits tc
= scm_make_port_type ("string", stfill_buffer
, st_write
);
546 scm_set_port_end_input (tc
, st_end_input
);
547 scm_set_port_flush (tc
, st_flush
);
548 scm_set_port_seek (tc
, st_seek
);
549 scm_set_port_truncate (tc
, st_truncate
);
557 scm_tc16_strport
= scm_make_stptob ();
559 #include "libguile/strports.x"