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 (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 size_t str_len
, c_pos
;
283 if (!((modes
& SCM_WRTNG
) || (modes
& SCM_RDNG
)))
284 scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL
);
286 scm_dynwind_begin (0);
287 scm_i_dynwind_pthread_mutex_lock (&scm_i_port_table_mutex
);
289 z
= scm_new_port_table_entry (scm_tc16_strport
);
290 pt
= SCM_PTAB_ENTRY(z
);
292 if (scm_is_false (str
))
294 /* Allocate a new buffer to write to. */
295 str_len
= INITIAL_BUFFER_SIZE
;
296 buf
= scm_c_make_bytevector (str_len
);
297 c_buf
= (char *) SCM_BYTEVECTOR_CONTENTS (buf
);
299 /* Reset `read_buf_size'. It will contain the actual number of
300 bytes written to PT. */
301 pt
->read_buf_size
= 0;
306 /* STR is a string. */
309 SCM_ASSERT (scm_is_string (str
), str
, SCM_ARG1
, caller
);
311 /* Create a copy of STR in the encoding of PT. */
312 copy
= scm_to_stringn (str
, &str_len
, pt
->encoding
,
313 SCM_FAILED_CONVERSION_ERROR
);
314 buf
= scm_c_make_bytevector (str_len
);
315 c_buf
= (char *) SCM_BYTEVECTOR_CONTENTS (buf
);
316 memcpy (c_buf
, copy
, str_len
);
319 c_pos
= scm_to_unsigned_integer (pos
, 0, str_len
);
320 pt
->read_buf_size
= str_len
;
323 SCM_SETSTREAM (z
, SCM_UNPACK (buf
));
324 SCM_SET_CELL_TYPE (z
, scm_tc16_strport
| modes
);
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
->write_buf_size
= str_len
;
329 pt
->write_end
= pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
335 /* Ensure WRITE_POS is writable. */
336 if ((modes
& SCM_WRTNG
) && pt
->write_pos
== pt
->write_end
)
339 scm_i_set_conversion_strategy_x (z
, SCM_FAILED_CONVERSION_ERROR
);
343 /* Create a new string from the buffer of PORT, a string port, converting from
344 PORT's encoding to the standard string representation. */
346 scm_strport_to_string (SCM port
)
349 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
351 if (pt
->rw_active
== SCM_PORT_WRITE
)
354 if (pt
->read_buf_size
== 0)
357 if (pt
->encoding
== NULL
)
360 str
= scm_i_make_string (pt
->read_buf_size
, &buf
);
361 memcpy (buf
, pt
->read_buf
, pt
->read_buf_size
);
364 str
= scm_from_stringn ((char *)pt
->read_buf
, pt
->read_buf_size
,
365 pt
->encoding
, pt
->ilseq_handler
);
366 scm_remember_upto_here_1 (port
);
370 SCM_DEFINE (scm_object_to_string
, "object->string", 1, 1, 0,
371 (SCM obj
, SCM printer
),
372 "Return a Scheme string obtained by printing @var{obj}.\n"
373 "Printing function can be specified by the optional second\n"
374 "argument @var{printer} (default: @code{write}).")
375 #define FUNC_NAME s_scm_object_to_string
379 if (!SCM_UNBNDP (printer
))
380 SCM_VALIDATE_PROC (2, printer
);
382 port
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
383 SCM_OPN
| SCM_WRTNG
, FUNC_NAME
);
385 if (SCM_UNBNDP (printer
))
386 scm_write (obj
, port
);
388 scm_call_2 (printer
, obj
, port
);
390 return scm_strport_to_string (port
);
394 SCM_DEFINE (scm_call_with_output_string
, "call-with-output-string", 1, 0, 0,
396 "Calls the one-argument procedure @var{proc} with a newly created output\n"
397 "port. When the function returns, the string composed of the characters\n"
398 "written into the port is returned.")
399 #define FUNC_NAME s_scm_call_with_output_string
403 p
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
406 scm_call_1 (proc
, p
);
408 return scm_get_output_string (p
);
412 SCM_DEFINE (scm_call_with_input_string
, "call-with-input-string", 2, 0, 0,
413 (SCM string
, SCM proc
),
414 "Calls the one-argument procedure @var{proc} with a newly\n"
415 "created input port from which @var{string}'s contents may be\n"
416 "read. The value yielded by the @var{proc} is returned.")
417 #define FUNC_NAME s_scm_call_with_input_string
419 SCM p
= scm_mkstrport(SCM_INUM0
, string
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
420 return scm_call_1 (proc
, p
);
424 SCM_DEFINE (scm_open_input_string
, "open-input-string", 1, 0, 0,
426 "Take a string and return an input port that delivers characters\n"
427 "from the string. The port can be closed by\n"
428 "@code{close-input-port}, though its storage will be reclaimed\n"
429 "by the garbage collector if it becomes inaccessible.")
430 #define FUNC_NAME s_scm_open_input_string
432 SCM p
= scm_mkstrport(SCM_INUM0
, str
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
437 SCM_DEFINE (scm_open_output_string
, "open-output-string", 0, 0, 0,
439 "Return an output port that will accumulate characters for\n"
440 "retrieval by @code{get-output-string}. The port can be closed\n"
441 "by the procedure @code{close-output-port}, though its storage\n"
442 "will be reclaimed by the garbage collector if it becomes\n"
444 #define FUNC_NAME s_scm_open_output_string
448 p
= scm_mkstrport (SCM_INUM0
, SCM_BOOL_F
,
455 SCM_DEFINE (scm_get_output_string
, "get-output-string", 1, 0, 0,
457 "Given an output port created by @code{open-output-string},\n"
458 "return a string consisting of the characters that have been\n"
459 "output to the port so far.")
460 #define FUNC_NAME s_scm_get_output_string
462 SCM_VALIDATE_OPOUTSTRPORT (1, port
);
463 return scm_strport_to_string (port
);
468 /* Given a null-terminated string EXPR containing a Scheme expression
469 read it, and return it as an SCM value. */
471 scm_c_read_string (const char *expr
)
473 SCM port
= scm_mkstrport (SCM_INUM0
,
474 scm_from_locale_string (expr
),
476 "scm_c_read_string");
479 form
= scm_read (port
);
481 scm_close_port (port
);
485 /* Given a null-terminated string EXPR containing Scheme program text,
486 evaluate it, and return the result of the last expression evaluated. */
488 scm_c_eval_string (const char *expr
)
490 return scm_eval_string (scm_from_locale_string (expr
));
494 scm_c_eval_string_in_module (const char *expr
, SCM module
)
496 return scm_eval_string_in_module (scm_from_locale_string (expr
), module
);
501 inner_eval_string (void *data
)
503 SCM port
= (SCM
)data
;
505 SCM ans
= SCM_UNSPECIFIED
;
507 /* Read expressions from that port; ignore the values. */
508 while (!SCM_EOF_OBJECT_P (form
= scm_read (port
)))
509 ans
= scm_primitive_eval_x (form
);
511 /* Don't close the port here; if we re-enter this function via a
512 continuation, then the next time we enter it, we'll get an error.
513 It's a string port anyway, so there's no advantage to closing it
519 SCM_DEFINE (scm_eval_string_in_module
, "eval-string", 1, 1, 0,
520 (SCM string
, SCM module
),
521 "Evaluate @var{string} as the text representation of a Scheme\n"
522 "form or forms, and return whatever value they produce.\n"
523 "Evaluation takes place in the given module, or the current\n"
524 "module when no module is given.\n"
525 "While the code is evaluated, the given module is made the\n"
526 "current one. The current module is restored when this\n"
527 "procedure returns.")
528 #define FUNC_NAME s_scm_eval_string_in_module
530 SCM port
= scm_mkstrport (SCM_INUM0
, string
, SCM_OPN
| SCM_RDNG
,
532 if (SCM_UNBNDP (module
))
533 module
= scm_current_module ();
535 SCM_VALIDATE_MODULE (2, module
);
536 return scm_c_call_with_current_module (module
,
537 inner_eval_string
, (void *)port
);
542 scm_eval_string (SCM string
)
544 return scm_eval_string_in_module (string
, SCM_UNDEFINED
);
550 scm_t_bits tc
= scm_make_port_type ("string", stfill_buffer
, st_write
);
552 scm_set_port_end_input (tc
, st_end_input
);
553 scm_set_port_flush (tc
, st_flush
);
554 scm_set_port_seek (tc
, st_seek
);
555 scm_set_port_truncate (tc
, st_truncate
);
563 scm_tc16_strport
= scm_make_stptob ();
565 #include "libguile/strports.x"