1 /* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009, 2010, 2011, 2012 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 point to the part of the bytevector which has been
60 written to. read_pos and write_pos are always equal.
62 ENHANCE-ME - output blocks:
64 The current code keeps an output string as a single block. That means
65 when the size is increased the entire old contents must be copied. It'd
66 be more efficient to begin a new block when the old one is full, so
67 there's no re-copying of previous data.
69 To make seeking efficient, keeping the pieces in a vector might be best,
70 though appending is probably the most common operation. The size of each
71 block could be progressively increased, so the bigger the string the
74 When `get-output-string' is called the blocks have to be coalesced into a
75 string, the result could be kept as a single big block. If blocks were
76 strings then `get-output-string' could notice when there's just one and
77 return that with a copy-on-write (though repeated calls to
78 `get-output-string' are probably unlikely).
80 Another possibility would be to extend the port mechanism to let SCM
81 strings come through directly from `display' and friends. That way if a
82 big string is written it can be kept as a copy-on-write, saving time
83 copying and maybe saving some space. */
86 scm_t_bits scm_tc16_strport
;
90 st_fill_input (SCM port
)
92 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
94 if (pt
->read_pos
>= pt
->read_end
)
100 /* Change the size of a port's bytevector to NEW_SIZE. This doesn't
101 change `read_buf_size'. */
103 st_resize_port (scm_t_port
*pt
, scm_t_off new_size
)
105 SCM old_stream
= SCM_PACK (pt
->stream
);
106 const signed char *src
= SCM_BYTEVECTOR_CONTENTS (old_stream
);
107 SCM new_stream
= scm_c_make_bytevector (new_size
);
108 signed char *dst
= SCM_BYTEVECTOR_CONTENTS (new_stream
);
109 unsigned long int old_size
= SCM_BYTEVECTOR_LENGTH (old_stream
);
110 unsigned long int min_size
= min (old_size
, new_size
);
112 scm_t_off offset
= pt
->write_pos
- pt
->write_buf
;
114 pt
->write_buf_size
= new_size
;
116 memcpy (dst
, src
, min_size
);
118 scm_remember_upto_here_1 (old_stream
);
122 pt
->stream
= SCM_UNPACK (new_stream
);
123 pt
->read_buf
= pt
->write_buf
= (unsigned char *)dst
;
124 pt
->read_pos
= pt
->write_pos
= pt
->write_buf
+ offset
;
125 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
126 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
131 st_write (SCM port
, const void *data
, size_t size
)
133 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
135 if (size
> pt
->write_end
- pt
->write_pos
)
136 st_resize_port (pt
, max (pt
->write_buf_size
* 2,
137 pt
->write_end
- pt
->write_pos
+ size
));
139 memcpy ((char *) pt
->write_pos
, data
, size
);
140 pt
->read_pos
= (pt
->write_pos
+= size
);
142 if (pt
->read_pos
> pt
->read_end
)
144 pt
->read_end
= (unsigned char *) pt
->read_pos
;
145 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
150 st_end_input (SCM port
, int offset
)
152 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
154 if (pt
->read_pos
- pt
->read_buf
< offset
)
155 scm_misc_error ("st_end_input", "negative position", SCM_EOL
);
157 pt
->write_pos
= (unsigned char *) (pt
->read_pos
= pt
->read_pos
- offset
);
158 pt
->rw_active
= SCM_PORT_NEITHER
;
162 st_seek (SCM port
, scm_t_off offset
, int whence
)
164 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
167 if (pt
->rw_active
== SCM_PORT_READ
&& offset
== 0 && whence
== SEEK_CUR
)
168 /* special case to avoid disturbing the unread-char buffer. */
170 if (pt
->read_buf
== pt
->putback_buf
)
172 target
= pt
->saved_read_pos
- pt
->saved_read_buf
173 - (pt
->read_end
- pt
->read_pos
);
177 target
= pt
->read_pos
- pt
->read_buf
;
181 /* all other cases. */
183 if (pt
->rw_active
== SCM_PORT_READ
)
184 scm_end_input_unlocked (port
);
186 pt
->rw_active
= SCM_PORT_NEITHER
;
191 target
= pt
->read_pos
- pt
->read_buf
+ offset
;
194 target
= pt
->read_end
- pt
->read_buf
+ offset
;
196 default: /* SEEK_SET */
202 scm_misc_error ("st_seek", "negative offset", SCM_EOL
);
204 if (target
>= pt
->write_buf_size
)
206 if (!(SCM_CELL_WORD_0 (port
) & SCM_WRTNG
))
208 if (target
> pt
->write_buf_size
)
210 scm_misc_error ("st_seek",
211 "seek past end of read-only strport",
215 else if (target
== pt
->write_buf_size
)
216 st_resize_port (pt
, target
* 2);
218 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ target
;
219 if (pt
->read_pos
> pt
->read_end
)
221 pt
->read_end
= (unsigned char *) pt
->read_pos
;
222 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
229 st_truncate (SCM port
, scm_t_off length
)
231 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
233 if (length
> pt
->write_buf_size
)
234 st_resize_port (pt
, length
);
236 pt
->read_buf_size
= length
;
237 pt
->read_end
= pt
->read_buf
+ length
;
238 if (pt
->read_pos
> pt
->read_end
)
239 pt
->read_pos
= pt
->write_pos
= pt
->read_end
;
242 /* The initial size in bytes of a string port's buffer. */
243 #define INITIAL_BUFFER_SIZE 128
245 /* Return a new string port with MODES. If STR is #f, a new backing
246 buffer is allocated; otherwise STR must be a string and a copy of it
247 serves as the buffer for the new port. */
249 scm_mkstrport (SCM pos
, SCM str
, long modes
, const char *caller
)
253 const char *encoding
;
254 size_t read_buf_size
, str_len
, c_pos
;
257 if (!((modes
& SCM_WRTNG
) || (modes
& SCM_RDNG
)))
258 scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL
);
260 encoding
= scm_i_default_port_encoding ();
262 if (scm_is_false (str
))
264 /* Allocate a new buffer to write to. */
265 str_len
= INITIAL_BUFFER_SIZE
;
266 buf
= scm_c_make_bytevector (str_len
);
267 c_buf
= (char *) SCM_BYTEVECTOR_CONTENTS (buf
);
269 /* Reset `read_buf_size'. It will contain the actual number of
270 bytes written to the port. */
276 /* STR is a string. */
279 SCM_ASSERT (scm_is_string (str
), str
, SCM_ARG1
, caller
);
281 /* Create a copy of STR in ENCODING. */
282 copy
= scm_to_stringn (str
, &str_len
, encoding
,
283 SCM_FAILED_CONVERSION_ERROR
);
284 buf
= scm_c_make_bytevector (str_len
);
285 c_buf
= (char *) SCM_BYTEVECTOR_CONTENTS (buf
);
286 memcpy (c_buf
, copy
, str_len
);
289 c_pos
= scm_to_unsigned_integer (pos
, 0, str_len
);
290 read_buf_size
= str_len
;
293 z
= scm_c_make_port_with_encoding (scm_tc16_strport
, modes
,
295 SCM_FAILED_CONVERSION_ERROR
,
298 pt
= SCM_PTAB_ENTRY (z
);
299 pt
->write_buf
= pt
->read_buf
= (unsigned char *) c_buf
;
300 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ c_pos
;
301 pt
->read_buf_size
= read_buf_size
;
302 pt
->write_buf_size
= str_len
;
303 pt
->write_end
= pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
309 /* Create a new string from the buffer of PORT, a string port, converting from
310 PORT's encoding to the standard string representation. */
312 scm_strport_to_string (SCM port
)
314 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
316 if (pt
->read_buf_size
== 0)
319 return scm_from_stringn ((char *)pt
->read_buf
, pt
->read_buf_size
,
320 pt
->encoding
, pt
->ilseq_handler
);
323 SCM_DEFINE (scm_object_to_string
, "object->string", 1, 1, 0,
324 (SCM obj
, SCM printer
),
325 "Return a Scheme string obtained by printing @var{obj}.\n"
326 "Printing function can be specified by the optional second\n"
327 "argument @var{printer} (default: @code{write}).")
328 #define FUNC_NAME s_scm_object_to_string
332 if (!SCM_UNBNDP (printer
))
333 SCM_VALIDATE_PROC (2, printer
);
335 port
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
336 SCM_OPN
| SCM_WRTNG
, FUNC_NAME
);
338 if (SCM_UNBNDP (printer
))
339 scm_write (obj
, port
);
341 scm_call_2 (printer
, obj
, port
);
343 result
= scm_strport_to_string (port
);
345 /* Explicitly close PORT so that the iconv CDs associated with it are
346 deallocated right away. This is important because CDs use a lot of
347 memory that's not visible to the GC, so not freeing them can lead
348 to almost large heap usage. See
349 <http://wingolog.org/archives/2011/02/25/ports-weaks-gc-and-dark-matter>
351 scm_close_port (port
);
358 scm_call_with_output_string (SCM proc
)
360 static SCM var
= SCM_BOOL_F
;
362 if (scm_is_false (var
))
363 var
= scm_c_private_lookup ("guile", "call-with-output-string");
365 return scm_call_1 (scm_variable_ref (var
), proc
);
369 scm_call_with_input_string (SCM string
, SCM proc
)
371 static SCM var
= SCM_BOOL_F
;
373 if (scm_is_false (var
))
374 var
= scm_c_private_lookup ("guile", "call-with-input-string");
376 return scm_call_2 (scm_variable_ref (var
), string
, proc
);
379 SCM_DEFINE (scm_open_input_string
, "open-input-string", 1, 0, 0,
381 "Take a string and return an input port that delivers characters\n"
382 "from the string. The port can be closed by\n"
383 "@code{close-input-port}, though its storage will be reclaimed\n"
384 "by the garbage collector if it becomes inaccessible.")
385 #define FUNC_NAME s_scm_open_input_string
387 SCM p
= scm_mkstrport(SCM_INUM0
, str
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
392 SCM_DEFINE (scm_open_output_string
, "open-output-string", 0, 0, 0,
394 "Return an output port that will accumulate characters for\n"
395 "retrieval by @code{get-output-string}. The port can be closed\n"
396 "by the procedure @code{close-output-port}, though its storage\n"
397 "will be reclaimed by the garbage collector if it becomes\n"
399 #define FUNC_NAME s_scm_open_output_string
403 p
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
410 SCM_DEFINE (scm_get_output_string
, "get-output-string", 1, 0, 0,
412 "Given an output port created by @code{open-output-string},\n"
413 "return a string consisting of the characters that have been\n"
414 "output to the port so far.")
415 #define FUNC_NAME s_scm_get_output_string
417 SCM_VALIDATE_OPOUTSTRPORT (1, port
);
418 return scm_strport_to_string (port
);
423 /* Given a null-terminated string EXPR containing a Scheme expression
424 read it, and return it as an SCM value. */
426 scm_c_read_string (const char *expr
)
428 SCM port
= scm_mkstrport (SCM_INUM0
,
429 scm_from_locale_string (expr
),
431 "scm_c_read_string");
434 form
= scm_read (port
);
436 scm_close_port (port
);
440 /* Given a null-terminated string EXPR containing Scheme program text,
441 evaluate it, and return the result of the last expression evaluated. */
443 scm_c_eval_string (const char *expr
)
445 return scm_eval_string (scm_from_locale_string (expr
));
449 scm_c_eval_string_in_module (const char *expr
, SCM module
)
451 return scm_eval_string_in_module (scm_from_locale_string (expr
), module
);
455 SCM_DEFINE (scm_eval_string_in_module
, "eval-string", 1, 1, 0,
456 (SCM string
, SCM module
),
457 "Evaluate @var{string} as the text representation of a Scheme\n"
458 "form or forms, and return whatever value they produce.\n"
459 "Evaluation takes place in the given module, or the current\n"
460 "module when no module is given.\n"
461 "While the code is evaluated, the given module is made the\n"
462 "current one. The current module is restored when this\n"
463 "procedure returns.")
464 #define FUNC_NAME s_scm_eval_string_in_module
466 static SCM eval_string
= SCM_BOOL_F
, k_module
= SCM_BOOL_F
;
468 if (scm_is_false (eval_string
))
470 eval_string
= scm_c_public_lookup ("ice-9 eval-string", "eval-string");
471 k_module
= scm_from_locale_keyword ("module");
474 if (SCM_UNBNDP (module
))
475 module
= scm_current_module ();
477 SCM_VALIDATE_MODULE (2, module
);
479 return scm_call_3 (scm_variable_ref (eval_string
), string
, k_module
, module
);
484 scm_eval_string (SCM string
)
486 return scm_eval_string_in_module (string
, SCM_UNDEFINED
);
492 scm_t_bits tc
= scm_make_port_type ("string", st_fill_input
, st_write
);
494 scm_set_port_end_input (tc
, st_end_input
);
495 scm_set_port_seek (tc
, st_seek
);
496 scm_set_port_truncate (tc
, st_truncate
);
504 scm_tc16_strport
= scm_make_stptob ();
506 #include "libguile/strports.x"