1 /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2006,
2 * 2009, 2010, 2011, 2012, 2013, 2014 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"
32 #include "libguile/bytevectors.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"
41 #include "libguile/srfi-4.h"
43 #include "libguile/strports.h"
51 /* {Ports - string ports}
57 write_buf/write_end point to the ends of the allocated bytevector.
58 read_buf/read_end point to the part of the bytevector which has been
59 written to. read_pos and write_pos are always equal.
61 ENHANCE-ME - output blocks:
63 The current code keeps an output string as a single block. That means
64 when the size is increased the entire old contents must be copied. It'd
65 be more efficient to begin a new block when the old one is full, so
66 there's no re-copying of previous data.
68 To make seeking efficient, keeping the pieces in a vector might be best,
69 though appending is probably the most common operation. The size of each
70 block could be progressively increased, so the bigger the string the
73 When `get-output-string' is called the blocks have to be coalesced into a
74 string, the result could be kept as a single big block. If blocks were
75 strings then `get-output-string' could notice when there's just one and
76 return that with a copy-on-write (though repeated calls to
77 `get-output-string' are probably unlikely).
79 Another possibility would be to extend the port mechanism to let SCM
80 strings come through directly from `display' and friends. That way if a
81 big string is written it can be kept as a copy-on-write, saving time
82 copying and maybe saving some space. */
85 scm_t_bits scm_tc16_strport
;
89 st_fill_input (SCM port
)
91 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
93 if (pt
->read_pos
>= pt
->read_end
)
99 /* Change the size of a port's bytevector to NEW_SIZE. This doesn't
100 change `read_buf_size'. */
102 st_resize_port (scm_t_port
*pt
, scm_t_off new_size
)
104 SCM old_stream
= SCM_PACK (pt
->stream
);
105 const signed char *src
= SCM_BYTEVECTOR_CONTENTS (old_stream
);
106 SCM new_stream
= scm_c_make_bytevector (new_size
);
107 signed char *dst
= SCM_BYTEVECTOR_CONTENTS (new_stream
);
108 unsigned long int old_size
= SCM_BYTEVECTOR_LENGTH (old_stream
);
109 unsigned long int min_size
= min (old_size
, new_size
);
111 scm_t_off offset
= pt
->write_pos
- pt
->write_buf
;
113 pt
->write_buf_size
= new_size
;
115 memcpy (dst
, src
, min_size
);
117 scm_remember_upto_here_1 (old_stream
);
121 pt
->stream
= SCM_UNPACK (new_stream
);
122 pt
->read_buf
= pt
->write_buf
= (unsigned char *)dst
;
123 pt
->read_pos
= pt
->write_pos
= pt
->write_buf
+ offset
;
124 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
125 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
130 st_write (SCM port
, const void *data
, size_t size
)
132 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
134 if (size
> pt
->write_end
- pt
->write_pos
)
135 st_resize_port (pt
, max (pt
->write_buf_size
* 2,
136 pt
->write_end
- pt
->write_pos
+ size
));
138 memcpy ((char *) pt
->write_pos
, data
, size
);
139 pt
->read_pos
= (pt
->write_pos
+= size
);
141 if (pt
->read_pos
> pt
->read_end
)
143 pt
->read_end
= (unsigned char *) pt
->read_pos
;
144 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
149 st_end_input (SCM port
, int offset
)
151 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
153 if (pt
->read_pos
- pt
->read_buf
< offset
)
154 scm_misc_error ("st_end_input", "negative position", SCM_EOL
);
156 pt
->write_pos
= (unsigned char *) (pt
->read_pos
= pt
->read_pos
- offset
);
157 pt
->rw_active
= SCM_PORT_NEITHER
;
161 st_seek (SCM port
, scm_t_off offset
, int whence
)
163 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
166 if (pt
->rw_active
== SCM_PORT_READ
&& offset
== 0 && whence
== SEEK_CUR
)
167 /* special case to avoid disturbing the unread-char buffer. */
169 if (pt
->read_buf
== pt
->putback_buf
)
171 target
= pt
->saved_read_pos
- pt
->saved_read_buf
172 - (pt
->read_end
- pt
->read_pos
);
176 target
= pt
->read_pos
- pt
->read_buf
;
180 /* all other cases. */
182 if (pt
->rw_active
== SCM_PORT_READ
)
183 scm_end_input_unlocked (port
);
185 pt
->rw_active
= SCM_PORT_NEITHER
;
190 target
= pt
->read_pos
- pt
->read_buf
+ offset
;
193 target
= pt
->read_end
- pt
->read_buf
+ offset
;
195 default: /* SEEK_SET */
201 scm_misc_error ("st_seek", "negative offset", SCM_EOL
);
203 if (target
>= pt
->write_buf_size
)
205 if (!(SCM_CELL_WORD_0 (port
) & SCM_WRTNG
))
207 if (target
> pt
->write_buf_size
)
209 scm_misc_error ("st_seek",
210 "seek past end of read-only strport",
214 else if (target
== pt
->write_buf_size
)
215 st_resize_port (pt
, target
* 2);
217 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ target
;
218 if (pt
->read_pos
> pt
->read_end
)
220 pt
->read_end
= (unsigned char *) pt
->read_pos
;
221 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
228 st_truncate (SCM port
, scm_t_off length
)
230 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
232 if (length
> pt
->write_buf_size
)
233 st_resize_port (pt
, length
);
235 pt
->read_buf_size
= length
;
236 pt
->read_end
= pt
->read_buf
+ length
;
237 if (pt
->read_pos
> pt
->read_end
)
238 pt
->read_pos
= pt
->write_pos
= pt
->read_end
;
241 /* The initial size in bytes of a string port's buffer. */
242 #define INITIAL_BUFFER_SIZE 128
244 /* Return a new string port with MODES. If STR is #f, a new backing
245 buffer is allocated; otherwise STR must be a string and a copy of it
246 serves as the buffer for the new port. */
248 scm_mkstrport (SCM pos
, SCM str
, long modes
, const char *caller
)
252 size_t read_buf_size
, num_bytes
, c_byte_pos
;
255 if (!((modes
& SCM_WRTNG
) || (modes
& SCM_RDNG
)))
256 scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL
);
258 if (scm_is_false (str
))
260 /* Allocate a new buffer to write to. */
261 num_bytes
= INITIAL_BUFFER_SIZE
;
262 buf
= scm_c_make_bytevector (num_bytes
);
263 c_buf
= (char *) SCM_BYTEVECTOR_CONTENTS (buf
);
265 /* Reset `read_buf_size'. It will contain the actual number of
266 bytes written to the port. */
274 SCM_ASSERT (scm_is_string (str
), str
, SCM_ARG1
, caller
);
276 /* STR is a string. */
277 /* Create a copy of STR in UTF-8. */
278 copy
= scm_to_utf8_stringn (str
, &num_bytes
);
279 buf
= scm_c_make_bytevector (num_bytes
);
280 c_buf
= (char *) SCM_BYTEVECTOR_CONTENTS (buf
);
281 memcpy (c_buf
, copy
, num_bytes
);
284 read_buf_size
= num_bytes
;
286 if (scm_is_eq (pos
, SCM_INUM0
))
289 /* Inefficient but simple way to convert the character position
290 POS into a byte position C_BYTE_POS. */
291 free (scm_to_utf8_stringn (scm_substring (str
, SCM_INUM0
, pos
),
295 z
= scm_c_make_port_with_encoding (scm_tc16_strport
, modes
,
297 scm_i_default_port_conversion_handler (),
300 pt
= SCM_PTAB_ENTRY (z
);
302 pt
->write_buf
= pt
->read_buf
= (unsigned char *) c_buf
;
303 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ c_byte_pos
;
304 pt
->read_buf_size
= read_buf_size
;
305 pt
->write_buf_size
= num_bytes
;
306 pt
->write_end
= pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
312 /* Create a new string from the buffer of PORT, a string port, converting from
313 PORT's encoding to the standard string representation. */
315 scm_strport_to_string (SCM port
)
317 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
319 if (pt
->read_buf_size
== 0)
322 return scm_from_port_stringn ((char *)pt
->read_buf
, pt
->read_buf_size
, port
);
325 SCM_DEFINE (scm_object_to_string
, "object->string", 1, 1, 0,
326 (SCM obj
, SCM printer
),
327 "Return a Scheme string obtained by printing @var{obj}.\n"
328 "Printing function can be specified by the optional second\n"
329 "argument @var{printer} (default: @code{write}).")
330 #define FUNC_NAME s_scm_object_to_string
334 if (!SCM_UNBNDP (printer
))
335 SCM_VALIDATE_PROC (2, printer
);
337 port
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
338 SCM_OPN
| SCM_WRTNG
, FUNC_NAME
);
340 if (SCM_UNBNDP (printer
))
341 scm_write (obj
, port
);
343 scm_call_2 (printer
, obj
, port
);
345 result
= scm_strport_to_string (port
);
347 /* Explicitly close PORT so that the iconv CDs associated with it are
348 deallocated right away. This is important because CDs use a lot of
349 memory that's not visible to the GC, so not freeing them can lead
350 to almost large heap usage. See
351 <http://wingolog.org/archives/2011/02/25/ports-weaks-gc-and-dark-matter>
353 scm_close_port (port
);
360 scm_call_with_output_string (SCM proc
)
362 static SCM var
= SCM_BOOL_F
;
364 if (scm_is_false (var
))
365 var
= scm_c_private_lookup ("guile", "call-with-output-string");
367 return scm_call_1 (scm_variable_ref (var
), proc
);
371 scm_call_with_input_string (SCM string
, SCM proc
)
373 static SCM var
= SCM_BOOL_F
;
375 if (scm_is_false (var
))
376 var
= scm_c_private_lookup ("guile", "call-with-input-string");
378 return scm_call_2 (scm_variable_ref (var
), string
, proc
);
381 SCM_DEFINE (scm_open_input_string
, "open-input-string", 1, 0, 0,
383 "Take a string and return an input port that delivers characters\n"
384 "from the string. The port can be closed by\n"
385 "@code{close-input-port}, though its storage will be reclaimed\n"
386 "by the garbage collector if it becomes inaccessible.")
387 #define FUNC_NAME s_scm_open_input_string
389 SCM p
= scm_mkstrport(SCM_INUM0
, str
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
394 SCM_DEFINE (scm_open_output_string
, "open-output-string", 0, 0, 0,
396 "Return an output port that will accumulate characters for\n"
397 "retrieval by @code{get-output-string}. The port can be closed\n"
398 "by the procedure @code{close-output-port}, though its storage\n"
399 "will be reclaimed by the garbage collector if it becomes\n"
401 #define FUNC_NAME s_scm_open_output_string
405 p
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
412 SCM_DEFINE (scm_get_output_string
, "get-output-string", 1, 0, 0,
414 "Given an output port created by @code{open-output-string},\n"
415 "return a string consisting of the characters that have been\n"
416 "output to the port so far.")
417 #define FUNC_NAME s_scm_get_output_string
419 SCM_VALIDATE_OPOUTSTRPORT (1, port
);
420 return scm_strport_to_string (port
);
425 /* Given a null-terminated string EXPR containing a Scheme expression
426 read it, and return it as an SCM value. */
428 scm_c_read_string (const char *expr
)
430 SCM port
= scm_mkstrport (SCM_INUM0
,
431 scm_from_locale_string (expr
),
433 "scm_c_read_string");
436 form
= scm_read (port
);
438 scm_close_port (port
);
442 /* Given a null-terminated string EXPR containing Scheme program text,
443 evaluate it, and return the result of the last expression evaluated. */
445 scm_c_eval_string (const char *expr
)
447 return scm_eval_string (scm_from_locale_string (expr
));
451 scm_c_eval_string_in_module (const char *expr
, SCM module
)
453 return scm_eval_string_in_module (scm_from_locale_string (expr
), module
);
457 static SCM eval_string_var
;
461 init_eval_string_var_and_k_module (void)
463 eval_string_var
= scm_c_public_variable ("ice-9 eval-string", "eval-string");
464 k_module
= scm_from_locale_keyword ("module");
467 SCM_DEFINE (scm_eval_string_in_module
, "eval-string", 1, 1, 0,
468 (SCM string
, SCM module
),
469 "Evaluate @var{string} as the text representation of a Scheme\n"
470 "form or forms, and return whatever value they produce.\n"
471 "Evaluation takes place in the given module, or the current\n"
472 "module when no module is given.\n"
473 "While the code is evaluated, the given module is made the\n"
474 "current one. The current module is restored when this\n"
475 "procedure returns.")
476 #define FUNC_NAME s_scm_eval_string_in_module
478 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
479 scm_i_pthread_once (&once
, init_eval_string_var_and_k_module
);
481 if (SCM_UNBNDP (module
))
482 module
= scm_current_module ();
484 SCM_VALIDATE_MODULE (2, module
);
486 return scm_call_3 (scm_variable_ref (eval_string_var
),
487 string
, k_module
, module
);
492 scm_eval_string (SCM string
)
494 return scm_eval_string_in_module (string
, SCM_UNDEFINED
);
500 scm_t_bits tc
= scm_make_port_type ("string", st_fill_input
, st_write
);
502 scm_set_port_end_input (tc
, st_end_input
);
503 scm_set_port_seek (tc
, st_seek
);
504 scm_set_port_truncate (tc
, st_truncate
);
512 scm_tc16_strport
= scm_make_stptob ();
514 #include "libguile/strports.x"