1 /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2006,
2 * 2009, 2010, 2011, 2012, 2013 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 point to the part of the bytevector which has been
61 written to. read_pos and write_pos are always equal.
63 ENHANCE-ME - output blocks:
65 The current code keeps an output string as a single block. That means
66 when the size is increased the entire old contents must be copied. It'd
67 be more efficient to begin a new block when the old one is full, so
68 there's no re-copying of previous data.
70 To make seeking efficient, keeping the pieces in a vector might be best,
71 though appending is probably the most common operation. The size of each
72 block could be progressively increased, so the bigger the string the
75 When `get-output-string' is called the blocks have to be coalesced into a
76 string, the result could be kept as a single big block. If blocks were
77 strings then `get-output-string' could notice when there's just one and
78 return that with a copy-on-write (though repeated calls to
79 `get-output-string' are probably unlikely).
81 Another possibility would be to extend the port mechanism to let SCM
82 strings come through directly from `display' and friends. That way if a
83 big string is written it can be kept as a copy-on-write, saving time
84 copying and maybe saving some space. */
87 scm_t_bits scm_tc16_strport
;
91 st_fill_input (SCM port
)
93 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
95 if (pt
->read_pos
>= pt
->read_end
)
101 /* Change the size of a port's bytevector to NEW_SIZE. This doesn't
102 change `read_buf_size'. */
104 st_resize_port (scm_t_port
*pt
, scm_t_off new_size
)
106 SCM old_stream
= SCM_PACK (pt
->stream
);
107 const signed char *src
= SCM_BYTEVECTOR_CONTENTS (old_stream
);
108 SCM new_stream
= scm_c_make_bytevector (new_size
);
109 signed char *dst
= SCM_BYTEVECTOR_CONTENTS (new_stream
);
110 unsigned long int old_size
= SCM_BYTEVECTOR_LENGTH (old_stream
);
111 unsigned long int min_size
= min (old_size
, new_size
);
113 scm_t_off offset
= pt
->write_pos
- pt
->write_buf
;
115 pt
->write_buf_size
= new_size
;
117 memcpy (dst
, src
, min_size
);
119 scm_remember_upto_here_1 (old_stream
);
123 pt
->stream
= SCM_UNPACK (new_stream
);
124 pt
->read_buf
= pt
->write_buf
= (unsigned char *)dst
;
125 pt
->read_pos
= pt
->write_pos
= pt
->write_buf
+ offset
;
126 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
127 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
132 st_write (SCM port
, const void *data
, size_t size
)
134 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
136 if (size
> pt
->write_end
- pt
->write_pos
)
137 st_resize_port (pt
, max (pt
->write_buf_size
* 2,
138 pt
->write_end
- pt
->write_pos
+ size
));
140 memcpy ((char *) pt
->write_pos
, data
, size
);
141 pt
->read_pos
= (pt
->write_pos
+= size
);
143 if (pt
->read_pos
> pt
->read_end
)
145 pt
->read_end
= (unsigned char *) pt
->read_pos
;
146 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
151 st_end_input (SCM port
, int offset
)
153 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
155 if (pt
->read_pos
- pt
->read_buf
< offset
)
156 scm_misc_error ("st_end_input", "negative position", SCM_EOL
);
158 pt
->write_pos
= (unsigned char *) (pt
->read_pos
= pt
->read_pos
- offset
);
159 pt
->rw_active
= SCM_PORT_NEITHER
;
163 st_seek (SCM port
, scm_t_off offset
, int whence
)
165 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
168 if (pt
->rw_active
== SCM_PORT_READ
&& offset
== 0 && whence
== SEEK_CUR
)
169 /* special case to avoid disturbing the unread-char buffer. */
171 if (pt
->read_buf
== pt
->putback_buf
)
173 target
= pt
->saved_read_pos
- pt
->saved_read_buf
174 - (pt
->read_end
- pt
->read_pos
);
178 target
= pt
->read_pos
- pt
->read_buf
;
182 /* all other cases. */
184 if (pt
->rw_active
== SCM_PORT_READ
)
185 scm_end_input_unlocked (port
);
187 pt
->rw_active
= SCM_PORT_NEITHER
;
192 target
= pt
->read_pos
- pt
->read_buf
+ offset
;
195 target
= pt
->read_end
- pt
->read_buf
+ offset
;
197 default: /* SEEK_SET */
203 scm_misc_error ("st_seek", "negative offset", SCM_EOL
);
205 if (target
>= pt
->write_buf_size
)
207 if (!(SCM_CELL_WORD_0 (port
) & SCM_WRTNG
))
209 if (target
> pt
->write_buf_size
)
211 scm_misc_error ("st_seek",
212 "seek past end of read-only strport",
216 else if (target
== pt
->write_buf_size
)
217 st_resize_port (pt
, target
* 2);
219 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ target
;
220 if (pt
->read_pos
> pt
->read_end
)
222 pt
->read_end
= (unsigned char *) pt
->read_pos
;
223 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
230 st_truncate (SCM port
, scm_t_off length
)
232 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
234 if (length
> pt
->write_buf_size
)
235 st_resize_port (pt
, length
);
237 pt
->read_buf_size
= length
;
238 pt
->read_end
= pt
->read_buf
+ length
;
239 if (pt
->read_pos
> pt
->read_end
)
240 pt
->read_pos
= pt
->write_pos
= pt
->read_end
;
243 /* The initial size in bytes of a string port's buffer. */
244 #define INITIAL_BUFFER_SIZE 128
246 /* Return a new string port with MODES. If STR is #f, a new backing
247 buffer is allocated; otherwise STR must be a string and a copy of it
248 serves as the buffer for the new port. */
250 scm_mkstrport (SCM pos
, SCM str
, long modes
, const char *caller
)
254 size_t read_buf_size
, num_bytes
, c_byte_pos
;
257 if (!((modes
& SCM_WRTNG
) || (modes
& SCM_RDNG
)))
258 scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL
);
260 if (scm_is_false (str
))
262 /* Allocate a new buffer to write to. */
263 num_bytes
= INITIAL_BUFFER_SIZE
;
264 buf
= scm_c_make_bytevector (num_bytes
);
265 c_buf
= (char *) SCM_BYTEVECTOR_CONTENTS (buf
);
267 /* Reset `read_buf_size'. It will contain the actual number of
268 bytes written to the port. */
276 SCM_ASSERT (scm_is_string (str
), str
, SCM_ARG1
, caller
);
278 /* STR is a string. */
279 /* Create a copy of STR in UTF-8. */
280 copy
= scm_to_utf8_stringn (str
, &num_bytes
);
281 buf
= scm_c_make_bytevector (num_bytes
);
282 c_buf
= (char *) SCM_BYTEVECTOR_CONTENTS (buf
);
283 memcpy (c_buf
, copy
, num_bytes
);
286 read_buf_size
= num_bytes
;
288 if (scm_is_eq (pos
, SCM_INUM0
))
291 /* Inefficient but simple way to convert the character position
292 POS into a byte position C_BYTE_POS. */
293 free (scm_to_utf8_stringn (scm_substring (str
, SCM_INUM0
, pos
),
297 z
= scm_c_make_port_with_encoding (scm_tc16_strport
, modes
,
299 scm_i_default_port_conversion_handler (),
302 pt
= SCM_PTAB_ENTRY (z
);
304 pt
->write_buf
= pt
->read_buf
= (unsigned char *) c_buf
;
305 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ c_byte_pos
;
306 pt
->read_buf_size
= read_buf_size
;
307 pt
->write_buf_size
= num_bytes
;
308 pt
->write_end
= pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
314 /* Create a new string from the buffer of PORT, a string port, converting from
315 PORT's encoding to the standard string representation. */
317 scm_strport_to_string (SCM port
)
319 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
321 if (pt
->read_buf_size
== 0)
324 return scm_from_port_stringn ((char *)pt
->read_buf
, pt
->read_buf_size
, port
);
327 SCM_DEFINE (scm_object_to_string
, "object->string", 1, 1, 0,
328 (SCM obj
, SCM printer
),
329 "Return a Scheme string obtained by printing @var{obj}.\n"
330 "Printing function can be specified by the optional second\n"
331 "argument @var{printer} (default: @code{write}).")
332 #define FUNC_NAME s_scm_object_to_string
336 if (!SCM_UNBNDP (printer
))
337 SCM_VALIDATE_PROC (2, printer
);
339 port
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
340 SCM_OPN
| SCM_WRTNG
, FUNC_NAME
);
342 if (SCM_UNBNDP (printer
))
343 scm_write (obj
, port
);
345 scm_call_2 (printer
, obj
, port
);
347 result
= scm_strport_to_string (port
);
349 /* Explicitly close PORT so that the iconv CDs associated with it are
350 deallocated right away. This is important because CDs use a lot of
351 memory that's not visible to the GC, so not freeing them can lead
352 to almost large heap usage. See
353 <http://wingolog.org/archives/2011/02/25/ports-weaks-gc-and-dark-matter>
355 scm_close_port (port
);
362 scm_call_with_output_string (SCM proc
)
364 static SCM var
= SCM_BOOL_F
;
366 if (scm_is_false (var
))
367 var
= scm_c_private_lookup ("guile", "call-with-output-string");
369 return scm_call_1 (scm_variable_ref (var
), proc
);
373 scm_call_with_input_string (SCM string
, SCM proc
)
375 static SCM var
= SCM_BOOL_F
;
377 if (scm_is_false (var
))
378 var
= scm_c_private_lookup ("guile", "call-with-input-string");
380 return scm_call_2 (scm_variable_ref (var
), string
, proc
);
383 SCM_DEFINE (scm_open_input_string
, "open-input-string", 1, 0, 0,
385 "Take a string and return an input port that delivers characters\n"
386 "from the string. The port can be closed by\n"
387 "@code{close-input-port}, though its storage will be reclaimed\n"
388 "by the garbage collector if it becomes inaccessible.")
389 #define FUNC_NAME s_scm_open_input_string
391 SCM p
= scm_mkstrport(SCM_INUM0
, str
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
396 SCM_DEFINE (scm_open_output_string
, "open-output-string", 0, 0, 0,
398 "Return an output port that will accumulate characters for\n"
399 "retrieval by @code{get-output-string}. The port can be closed\n"
400 "by the procedure @code{close-output-port}, though its storage\n"
401 "will be reclaimed by the garbage collector if it becomes\n"
403 #define FUNC_NAME s_scm_open_output_string
407 p
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
414 SCM_DEFINE (scm_get_output_string
, "get-output-string", 1, 0, 0,
416 "Given an output port created by @code{open-output-string},\n"
417 "return a string consisting of the characters that have been\n"
418 "output to the port so far.")
419 #define FUNC_NAME s_scm_get_output_string
421 SCM_VALIDATE_OPOUTSTRPORT (1, port
);
422 return scm_strport_to_string (port
);
427 /* Given a null-terminated string EXPR containing a Scheme expression
428 read it, and return it as an SCM value. */
430 scm_c_read_string (const char *expr
)
432 SCM port
= scm_mkstrport (SCM_INUM0
,
433 scm_from_locale_string (expr
),
435 "scm_c_read_string");
438 form
= scm_read (port
);
440 scm_close_port (port
);
444 /* Given a null-terminated string EXPR containing Scheme program text,
445 evaluate it, and return the result of the last expression evaluated. */
447 scm_c_eval_string (const char *expr
)
449 return scm_eval_string (scm_from_locale_string (expr
));
453 scm_c_eval_string_in_module (const char *expr
, SCM module
)
455 return scm_eval_string_in_module (scm_from_locale_string (expr
), module
);
459 static SCM eval_string_var
;
463 init_eval_string_var_and_k_module (void)
465 eval_string_var
= scm_c_public_variable ("ice-9 eval-string", "eval-string");
466 k_module
= scm_from_locale_keyword ("module");
469 SCM_DEFINE (scm_eval_string_in_module
, "eval-string", 1, 1, 0,
470 (SCM string
, SCM module
),
471 "Evaluate @var{string} as the text representation of a Scheme\n"
472 "form or forms, and return whatever value they produce.\n"
473 "Evaluation takes place in the given module, or the current\n"
474 "module when no module is given.\n"
475 "While the code is evaluated, the given module is made the\n"
476 "current one. The current module is restored when this\n"
477 "procedure returns.")
478 #define FUNC_NAME s_scm_eval_string_in_module
480 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
481 scm_i_pthread_once (&once
, init_eval_string_var_and_k_module
);
483 if (SCM_UNBNDP (module
))
484 module
= scm_current_module ();
486 SCM_VALIDATE_MODULE (2, module
);
488 return scm_call_3 (scm_variable_ref (eval_string_var
),
489 string
, k_module
, module
);
494 scm_eval_string (SCM string
)
496 return scm_eval_string_in_module (string
, SCM_UNDEFINED
);
502 scm_t_bits tc
= scm_make_port_type ("string", st_fill_input
, st_write
);
504 scm_set_port_end_input (tc
, st_end_input
);
505 scm_set_port_seek (tc
, st_seek
);
506 scm_set_port_truncate (tc
, st_truncate
);
514 scm_tc16_strport
= scm_make_stptob ();
516 #include "libguile/strports.x"