1 /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2006,
2 * 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
27 #include "libguile/_scm.h"
34 #include "libguile/bytevectors.h"
35 #include "libguile/eval.h"
36 #include "libguile/ports.h"
37 #include "libguile/read.h"
38 #include "libguile/root.h"
39 #include "libguile/strings.h"
40 #include "libguile/modules.h"
41 #include "libguile/validate.h"
42 #include "libguile/deprecation.h"
43 #include "libguile/srfi-4.h"
45 #include "libguile/strports.h"
53 /* {Ports - string ports}
59 write_buf/write_end point to the ends of the allocated bytevector.
60 read_buf/read_end in principle point to the part of the bytevector which
61 has been written to, but this is only updated after a flush.
62 read_pos and write_pos in principle should be equal, but this is only true
63 when rw_active is SCM_PORT_NEITHER.
65 ENHANCE-ME - output blocks:
67 The current code keeps an output string as a single block. That means
68 when the size is increased the entire old contents must be copied. It'd
69 be more efficient to begin a new block when the old one is full, so
70 there's no re-copying of previous data.
72 To make seeking efficient, keeping the pieces in a vector might be best,
73 though appending is probably the most common operation. The size of each
74 block could be progressively increased, so the bigger the string the
77 When `get-output-string' is called the blocks have to be coalesced into a
78 string, the result could be kept as a single big block. If blocks were
79 strings then `get-output-string' could notice when there's just one and
80 return that with a copy-on-write (though repeated calls to
81 `get-output-string' are probably unlikely).
83 Another possibility would be to extend the port mechanism to let SCM
84 strings come through directly from `display' and friends. That way if a
85 big string is written it can be kept as a copy-on-write, saving time
86 copying and maybe saving some space. */
89 scm_t_bits scm_tc16_strport
;
93 stfill_buffer (SCM port
)
95 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
97 if (pt
->read_pos
>= pt
->read_end
)
100 return scm_return_first_int (*pt
->read_pos
, port
);
103 /* Change the size of a port's bytevector to NEW_SIZE. This doesn't
104 change `read_buf_size'. */
106 st_resize_port (scm_t_port
*pt
, scm_t_off new_size
)
108 SCM old_stream
= SCM_PACK (pt
->stream
);
109 const signed char *src
= SCM_BYTEVECTOR_CONTENTS (old_stream
);
110 SCM new_stream
= scm_c_make_bytevector (new_size
);
111 signed char *dst
= SCM_BYTEVECTOR_CONTENTS (new_stream
);
112 unsigned long int old_size
= SCM_BYTEVECTOR_LENGTH (old_stream
);
113 unsigned long int min_size
= min (old_size
, new_size
);
115 scm_t_off index
= pt
->write_pos
- pt
->write_buf
;
117 pt
->write_buf_size
= new_size
;
119 memcpy (dst
, src
, min_size
);
121 scm_remember_upto_here_1 (old_stream
);
125 pt
->stream
= SCM_UNPACK (new_stream
);
126 pt
->read_buf
= pt
->write_buf
= (unsigned char *)dst
;
127 pt
->read_pos
= pt
->write_pos
= pt
->write_buf
+ index
;
128 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
129 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
133 /* Ensure that `write_pos' < `write_end' by enlarging the buffer when
134 necessary. Update `read_buf' to account for written chars. The
135 buffer is enlarged geometrically. */
139 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
141 if (pt
->write_pos
== pt
->write_end
)
142 st_resize_port (pt
, pt
->write_buf_size
* 2);
144 pt
->read_pos
= pt
->write_pos
;
145 if (pt
->read_pos
> pt
->read_end
)
147 pt
->read_end
= (unsigned char *) pt
->read_pos
;
148 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
150 pt
->rw_active
= SCM_PORT_NEITHER
;
154 st_write (SCM port
, const void *data
, size_t size
)
156 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
157 const char *input
= (char *) data
;
161 int space
= pt
->write_end
- pt
->write_pos
;
162 int write_len
= (size
> space
) ? space
: size
;
164 memcpy ((char *) pt
->write_pos
, input
, write_len
);
165 pt
->write_pos
+= write_len
;
168 if (write_len
== space
)
174 st_end_input (SCM port
, int offset
)
176 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
178 if (pt
->read_pos
- pt
->read_buf
< offset
)
179 scm_misc_error ("st_end_input", "negative position", SCM_EOL
);
181 pt
->write_pos
= (unsigned char *) (pt
->read_pos
= pt
->read_pos
- offset
);
182 pt
->rw_active
= SCM_PORT_NEITHER
;
186 st_seek (SCM port
, scm_t_off offset
, int whence
)
188 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
191 if (pt
->rw_active
== SCM_PORT_READ
&& offset
== 0 && whence
== SEEK_CUR
)
192 /* special case to avoid disturbing the unread-char buffer. */
194 if (pt
->read_buf
== pt
->putback_buf
)
196 target
= pt
->saved_read_pos
- pt
->saved_read_buf
197 - (pt
->read_end
- pt
->read_pos
);
201 target
= pt
->read_pos
- pt
->read_buf
;
205 /* all other cases. */
207 if (pt
->rw_active
== SCM_PORT_WRITE
)
210 if (pt
->rw_active
== SCM_PORT_READ
)
211 scm_end_input (port
);
216 target
= pt
->read_pos
- pt
->read_buf
+ offset
;
219 target
= pt
->read_end
- pt
->read_buf
+ offset
;
221 default: /* SEEK_SET */
227 scm_misc_error ("st_seek", "negative offset", SCM_EOL
);
229 if (target
>= pt
->write_buf_size
)
231 if (!(SCM_CELL_WORD_0 (port
) & SCM_WRTNG
))
233 if (target
> pt
->write_buf_size
)
235 scm_misc_error ("st_seek",
236 "seek past end of read-only strport",
240 else if (target
== pt
->write_buf_size
)
241 st_resize_port (pt
, target
* 2);
243 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ target
;
244 if (pt
->read_pos
> pt
->read_end
)
246 pt
->read_end
= (unsigned char *) pt
->read_pos
;
247 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
254 st_truncate (SCM port
, scm_t_off length
)
256 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
258 if (length
> pt
->write_buf_size
)
259 st_resize_port (pt
, length
);
261 pt
->read_buf_size
= length
;
262 pt
->read_end
= pt
->read_buf
+ length
;
263 if (pt
->read_pos
> pt
->read_end
)
264 pt
->read_pos
= pt
->read_end
;
266 if (pt
->write_pos
> pt
->read_end
)
267 pt
->write_pos
= pt
->read_end
;
270 /* The initial size in bytes of a string port's buffer. */
271 #define INITIAL_BUFFER_SIZE 128
273 /* Return a new string port with MODES. If STR is #f, a new backing
274 buffer is allocated; otherwise STR must be a string and a copy of it
275 serves as the buffer for the new port. */
277 scm_mkstrport (SCM pos
, SCM str
, long modes
, const char *caller
)
281 size_t 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 scm_dynwind_begin (0);
288 scm_i_dynwind_pthread_mutex_lock (&scm_i_port_table_mutex
);
290 z
= scm_new_port_table_entry (scm_tc16_strport
);
291 SCM_SET_CELL_TYPE (z
, scm_tc16_strport
);
292 pt
= SCM_PTAB_ENTRY (z
);
294 /* Make PT initially empty, and release the port-table mutex
295 immediately. This is so that if one of the function calls below
296 raises an exception, a pre-unwind catch handler can still create
297 new ports; for instance, `display-backtrace' needs to be able to
298 allocate a new string port. See <http://bugs.gnu.org/11197>. */
299 scm_port_non_buffer (pt
);
300 SCM_SETSTREAM (z
, SCM_UNPACK (scm_null_bytevector
));
304 if (scm_is_false (str
))
306 /* Allocate a new buffer to write to. */
307 str_len
= INITIAL_BUFFER_SIZE
;
308 buf
= scm_c_make_bytevector (str_len
);
309 c_buf
= (char *) SCM_BYTEVECTOR_CONTENTS (buf
);
314 /* STR is a string. */
317 SCM_ASSERT (scm_is_string (str
), str
, SCM_ARG1
, caller
);
319 /* Create a copy of STR in the encoding of PT. */
320 copy
= scm_to_stringn (str
, &str_len
, pt
->encoding
,
321 SCM_FAILED_CONVERSION_ERROR
);
322 buf
= scm_c_make_bytevector (str_len
);
323 c_buf
= (char *) SCM_BYTEVECTOR_CONTENTS (buf
);
324 memcpy (c_buf
, copy
, str_len
);
327 c_pos
= scm_to_unsigned_integer (pos
, 0, str_len
);
330 /* Now, finish up the port. */
331 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
333 SCM_SETSTREAM (z
, SCM_UNPACK (buf
));
334 SCM_SET_CELL_TYPE (z
, scm_tc16_strport
| modes
);
336 if (scm_is_false (str
))
337 /* Reset `read_buf_size'. It will contain the actual number of
338 bytes written to PT. */
339 pt
->read_buf_size
= 0;
341 pt
->read_buf_size
= str_len
;
343 pt
->write_buf
= pt
->read_buf
= (unsigned char *) c_buf
;
344 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ c_pos
;
345 pt
->write_buf_size
= str_len
;
346 pt
->write_end
= pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
350 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
352 /* Ensure WRITE_POS is writable. */
353 if ((modes
& SCM_WRTNG
) && pt
->write_pos
== pt
->write_end
)
359 /* Create a new string from the buffer of PORT, a string port, converting from
360 PORT's encoding to the standard string representation. */
362 scm_strport_to_string (SCM port
)
365 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
367 if (pt
->rw_active
== SCM_PORT_WRITE
)
370 if (pt
->read_buf_size
== 0)
373 if (pt
->encoding
== NULL
)
376 str
= scm_i_make_string (pt
->read_buf_size
, &buf
, 0);
377 memcpy (buf
, pt
->read_buf
, pt
->read_buf_size
);
380 str
= scm_from_stringn ((char *)pt
->read_buf
, pt
->read_buf_size
,
381 pt
->encoding
, pt
->ilseq_handler
);
382 scm_remember_upto_here_1 (port
);
386 SCM_DEFINE (scm_object_to_string
, "object->string", 1, 1, 0,
387 (SCM obj
, SCM printer
),
388 "Return a Scheme string obtained by printing @var{obj}.\n"
389 "Printing function can be specified by the optional second\n"
390 "argument @var{printer} (default: @code{write}).")
391 #define FUNC_NAME s_scm_object_to_string
395 if (!SCM_UNBNDP (printer
))
396 SCM_VALIDATE_PROC (2, printer
);
398 port
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
399 SCM_OPN
| SCM_WRTNG
, FUNC_NAME
);
401 if (SCM_UNBNDP (printer
))
402 scm_write (obj
, port
);
404 scm_call_2 (printer
, obj
, port
);
406 result
= scm_strport_to_string (port
);
408 /* Explicitly close PORT so that the iconv CDs associated with it are
409 deallocated right away. This is important because CDs use a lot of
410 memory that's not visible to the GC, so not freeing them can lead
411 to almost large heap usage. See
412 <http://wingolog.org/archives/2011/02/25/ports-weaks-gc-and-dark-matter>
414 scm_close_port (port
);
420 SCM_DEFINE (scm_call_with_output_string
, "call-with-output-string", 1, 0, 0,
422 "Calls the one-argument procedure @var{proc} with a newly created output\n"
423 "port. When the function returns, the string composed of the characters\n"
424 "written into the port is returned.")
425 #define FUNC_NAME s_scm_call_with_output_string
429 p
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
432 scm_call_1 (proc
, p
);
434 return scm_get_output_string (p
);
438 SCM_DEFINE (scm_call_with_input_string
, "call-with-input-string", 2, 0, 0,
439 (SCM string
, SCM proc
),
440 "Calls the one-argument procedure @var{proc} with a newly\n"
441 "created input port from which @var{string}'s contents may be\n"
442 "read. The value yielded by the @var{proc} is returned.")
443 #define FUNC_NAME s_scm_call_with_input_string
445 SCM p
= scm_mkstrport(SCM_INUM0
, string
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
446 return scm_call_1 (proc
, p
);
450 SCM_DEFINE (scm_open_input_string
, "open-input-string", 1, 0, 0,
452 "Take a string and return an input port that delivers characters\n"
453 "from the string. The port can be closed by\n"
454 "@code{close-input-port}, though its storage will be reclaimed\n"
455 "by the garbage collector if it becomes inaccessible.")
456 #define FUNC_NAME s_scm_open_input_string
458 SCM p
= scm_mkstrport(SCM_INUM0
, str
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
463 SCM_DEFINE (scm_open_output_string
, "open-output-string", 0, 0, 0,
465 "Return an output port that will accumulate characters for\n"
466 "retrieval by @code{get-output-string}. The port can be closed\n"
467 "by the procedure @code{close-output-port}, though its storage\n"
468 "will be reclaimed by the garbage collector if it becomes\n"
470 #define FUNC_NAME s_scm_open_output_string
474 p
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
481 SCM_DEFINE (scm_get_output_string
, "get-output-string", 1, 0, 0,
483 "Given an output port created by @code{open-output-string},\n"
484 "return a string consisting of the characters that have been\n"
485 "output to the port so far.")
486 #define FUNC_NAME s_scm_get_output_string
488 SCM_VALIDATE_OPOUTSTRPORT (1, port
);
489 return scm_strport_to_string (port
);
494 /* Given a null-terminated string EXPR containing a Scheme expression
495 read it, and return it as an SCM value. */
497 scm_c_read_string (const char *expr
)
499 SCM port
= scm_mkstrport (SCM_INUM0
,
500 scm_from_locale_string (expr
),
502 "scm_c_read_string");
505 form
= scm_read (port
);
507 scm_close_port (port
);
511 /* Given a null-terminated string EXPR containing Scheme program text,
512 evaluate it, and return the result of the last expression evaluated. */
514 scm_c_eval_string (const char *expr
)
516 return scm_eval_string (scm_from_locale_string (expr
));
520 scm_c_eval_string_in_module (const char *expr
, SCM module
)
522 return scm_eval_string_in_module (scm_from_locale_string (expr
), module
);
526 SCM_DEFINE (scm_eval_string_in_module
, "eval-string", 1, 1, 0,
527 (SCM string
, SCM module
),
528 "Evaluate @var{string} as the text representation of a Scheme\n"
529 "form or forms, and return whatever value they produce.\n"
530 "Evaluation takes place in the given module, or the current\n"
531 "module when no module is given.\n"
532 "While the code is evaluated, the given module is made the\n"
533 "current one. The current module is restored when this\n"
534 "procedure returns.")
535 #define FUNC_NAME s_scm_eval_string_in_module
537 static SCM eval_string
= SCM_UNDEFINED
, k_module
= SCM_UNDEFINED
;
538 static scm_i_pthread_mutex_t init_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
540 scm_i_scm_pthread_mutex_lock (&init_mutex
);
541 if (SCM_UNBNDP (eval_string
))
543 eval_string
= scm_c_public_variable ("ice-9 eval-string", "eval-string");
544 k_module
= scm_from_locale_keyword ("module");
546 scm_i_pthread_mutex_unlock (&init_mutex
);
548 if (SCM_UNBNDP (module
))
549 module
= scm_current_module ();
551 SCM_VALIDATE_MODULE (2, module
);
553 return scm_call_3 (scm_variable_ref (eval_string
), string
, k_module
, module
);
558 scm_eval_string (SCM string
)
560 return scm_eval_string_in_module (string
, SCM_UNDEFINED
);
566 scm_t_bits tc
= scm_make_port_type ("string", stfill_buffer
, st_write
);
568 scm_set_port_end_input (tc
, st_end_input
);
569 scm_set_port_flush (tc
, st_flush
);
570 scm_set_port_seek (tc
, st_seek
);
571 scm_set_port_truncate (tc
, st_truncate
);
579 scm_tc16_strport
= scm_make_stptob ();
581 #include "libguile/strports.x"