1 /* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009 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/unif.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"
43 #include "libguile/strports.h"
51 /* {Ports - string ports}
57 We break the rules set forth by strings.h about accessing the
58 internals of strings here. We can do this since we can guarantee
59 that the string used as pt->stream is not in use by anyone else.
60 Thus, it's representation will not change asynchronously.
62 (Ports aren't thread-safe yet anyway...)
64 write_buf/write_end point to the ends of the allocated string.
65 read_buf/read_end in principle point to the part of the string which
66 has been written to, but this is only updated after a flush.
67 read_pos and write_pos in principle should be equal, but this is only true
68 when rw_active is SCM_PORT_NEITHER.
70 ENHANCE-ME - output blocks:
72 The current code keeps an output string as a single block. That means
73 when the size is increased the entire old contents must be copied. It'd
74 be more efficient to begin a new block when the old one is full, so
75 there's no re-copying of previous data.
77 To make seeking efficient, keeping the pieces in a vector might be best,
78 though appending is probably the most common operation. The size of each
79 block could be progressively increased, so the bigger the string the
82 When `get-output-string' is called the blocks have to be coalesced into a
83 string, the result could be kept as a single big block. If blocks were
84 strings then `get-output-string' could notice when there's just one and
85 return that with a copy-on-write (though repeated calls to
86 `get-output-string' are probably unlikely).
88 Another possibility would be to extend the port mechanism to let SCM
89 strings come through directly from `display' and friends. That way if a
90 big string is written it can be kept as a copy-on-write, saving time
91 copying and maybe saving some space. */
94 scm_t_bits scm_tc16_strport
;
98 stfill_buffer (SCM port
)
100 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
102 if (pt
->read_pos
>= pt
->read_end
)
105 return scm_return_first_int (*pt
->read_pos
, port
);
108 /* change the size of a port's string to new_size. this doesn't
109 change read_buf_size. */
111 st_resize_port (scm_t_port
*pt
, scm_t_off new_size
)
113 SCM old_stream
= SCM_PACK (pt
->stream
);
114 const char *src
= scm_i_string_chars (old_stream
);
116 SCM new_stream
= scm_i_make_string (new_size
, &dst
);
117 unsigned long int old_size
= scm_i_string_length (old_stream
);
118 unsigned long int min_size
= min (old_size
, new_size
);
121 scm_t_off index
= pt
->write_pos
- pt
->write_buf
;
123 pt
->write_buf_size
= new_size
;
125 for (i
= 0; i
!= min_size
; ++i
)
128 scm_remember_upto_here_1 (old_stream
);
132 pt
->stream
= SCM_UNPACK (new_stream
);
133 pt
->read_buf
= pt
->write_buf
= (unsigned char *)dst
;
134 pt
->read_pos
= pt
->write_pos
= pt
->write_buf
+ index
;
135 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
136 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
140 /* amount by which write_buf is expanded. */
141 #define SCM_WRITE_BLOCK 80
143 /* ensure that write_pos < write_end by enlarging the buffer when
144 necessary. update read_buf to account for written chars.
146 The buffer is enlarged by 1.5 times, plus SCM_WRITE_BLOCK. Adding just a
147 fixed amount is no good, because there's a block copy for each increment,
148 and that copying would take quadratic time. In the past it was found to
149 be very slow just adding 80 bytes each time (eg. about 10 seconds for
150 writing a 100kbyte string). */
155 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
157 if (pt
->write_pos
== pt
->write_end
)
159 st_resize_port (pt
, pt
->write_buf_size
* 3 / 2 + SCM_WRITE_BLOCK
);
161 pt
->read_pos
= pt
->write_pos
;
162 if (pt
->read_pos
> pt
->read_end
)
164 pt
->read_end
= (unsigned char *) pt
->read_pos
;
165 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
167 pt
->rw_active
= SCM_PORT_NEITHER
;
171 st_write (SCM port
, const void *data
, size_t size
)
173 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
174 const char *input
= (char *) data
;
178 int space
= pt
->write_end
- pt
->write_pos
;
179 int write_len
= (size
> space
) ? space
: size
;
181 memcpy ((char *) pt
->write_pos
, input
, write_len
);
182 pt
->write_pos
+= write_len
;
185 if (write_len
== space
)
191 st_end_input (SCM port
, int offset
)
193 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
195 if (pt
->read_pos
- pt
->read_buf
< offset
)
196 scm_misc_error ("st_end_input", "negative position", SCM_EOL
);
198 pt
->write_pos
= (unsigned char *) (pt
->read_pos
= pt
->read_pos
- offset
);
199 pt
->rw_active
= SCM_PORT_NEITHER
;
203 st_seek (SCM port
, scm_t_off offset
, int whence
)
205 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
208 if (pt
->rw_active
== SCM_PORT_READ
&& offset
== 0 && whence
== SEEK_CUR
)
209 /* special case to avoid disturbing the unread-char buffer. */
211 if (pt
->read_buf
== pt
->putback_buf
)
213 target
= pt
->saved_read_pos
- pt
->saved_read_buf
214 - (pt
->read_end
- pt
->read_pos
);
218 target
= pt
->read_pos
- pt
->read_buf
;
222 /* all other cases. */
224 if (pt
->rw_active
== SCM_PORT_WRITE
)
227 if (pt
->rw_active
== SCM_PORT_READ
)
228 scm_end_input (port
);
233 target
= pt
->read_pos
- pt
->read_buf
+ offset
;
236 target
= pt
->read_end
- pt
->read_buf
+ offset
;
238 default: /* SEEK_SET */
244 scm_misc_error ("st_seek", "negative offset", SCM_EOL
);
246 if (target
>= pt
->write_buf_size
)
248 if (!(SCM_CELL_WORD_0 (port
) & SCM_WRTNG
))
250 if (target
> pt
->write_buf_size
)
252 scm_misc_error ("st_seek",
253 "seek past end of read-only strport",
259 st_resize_port (pt
, target
+ (target
== pt
->write_buf_size
264 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ target
;
265 if (pt
->read_pos
> pt
->read_end
)
267 pt
->read_end
= (unsigned char *) pt
->read_pos
;
268 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
275 st_truncate (SCM port
, scm_t_off length
)
277 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
279 if (length
> pt
->write_buf_size
)
280 st_resize_port (pt
, length
);
282 pt
->read_buf_size
= length
;
283 pt
->read_end
= pt
->read_buf
+ length
;
284 if (pt
->read_pos
> pt
->read_end
)
285 pt
->read_pos
= pt
->read_end
;
287 if (pt
->write_pos
> pt
->read_end
)
288 pt
->write_pos
= pt
->read_end
;
292 scm_mkstrport (SCM pos
, SCM str
, long modes
, const char *caller
)
296 size_t str_len
, c_pos
;
298 SCM_ASSERT (scm_is_string (str
), str
, SCM_ARG1
, caller
);
300 str_len
= scm_i_string_length (str
);
301 c_pos
= scm_to_unsigned_integer (pos
, 0, str_len
);
303 if (!((modes
& SCM_WRTNG
) || (modes
& SCM_RDNG
)))
304 scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL
);
308 Make a new string to isolate us from changes to the original.
309 This is done so that we can rely on scm_i_string_chars to stay in
310 place even across SCM_TICKs.
312 Additionally, when we are going to write to the string, we make a
313 copy so that we can write to it without having to use
314 scm_i_string_writable_chars.
317 if (modes
& SCM_WRTNG
)
318 str
= scm_c_substring_copy (str
, 0, str_len
);
320 str
= scm_c_substring (str
, 0, str_len
);
322 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
323 z
= scm_new_port_table_entry (scm_tc16_strport
);
324 pt
= SCM_PTAB_ENTRY(z
);
325 SCM_SETSTREAM (z
, SCM_UNPACK (str
));
326 SCM_SET_CELL_TYPE(z
, scm_tc16_strport
|modes
);
327 /* see above why we can use scm_i_string_chars here. */
328 pt
->write_buf
= pt
->read_buf
= (unsigned char *) scm_i_string_chars (str
);
329 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ c_pos
;
330 pt
->write_buf_size
= pt
->read_buf_size
= str_len
;
331 pt
->write_end
= pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
335 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
337 /* ensure write_pos is writable. */
338 if ((modes
& SCM_WRTNG
) && pt
->write_pos
== pt
->write_end
)
343 /* create a new string from a string port's buffer. */
344 SCM
scm_strport_to_string (SCM port
)
346 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
350 if (pt
->rw_active
== SCM_PORT_WRITE
)
353 str
= scm_i_make_string (pt
->read_buf_size
, &dst
);
354 memcpy (dst
, (char *) pt
->read_buf
, pt
->read_buf_size
);
355 scm_remember_upto_here_1 (port
);
359 SCM_DEFINE (scm_object_to_string
, "object->string", 1, 1, 0,
360 (SCM obj
, SCM printer
),
361 "Return a Scheme string obtained by printing @var{obj}.\n"
362 "Printing function can be specified by the optional second\n"
363 "argument @var{printer} (default: @code{write}).")
364 #define FUNC_NAME s_scm_object_to_string
368 if (!SCM_UNBNDP (printer
))
369 SCM_VALIDATE_PROC (2, printer
);
371 str
= scm_c_make_string (0, SCM_UNDEFINED
);
372 port
= scm_mkstrport (SCM_INUM0
, str
, SCM_OPN
| SCM_WRTNG
, FUNC_NAME
);
374 if (SCM_UNBNDP (printer
))
375 scm_write (obj
, port
);
377 scm_call_2 (printer
, obj
, port
);
379 return scm_strport_to_string (port
);
383 SCM_DEFINE (scm_call_with_output_string
, "call-with-output-string", 1, 0, 0,
385 "Calls the one-argument procedure @var{proc} with a newly created output\n"
386 "port. When the function returns, the string composed of the characters\n"
387 "written into the port is returned.")
388 #define FUNC_NAME s_scm_call_with_output_string
392 p
= scm_mkstrport (SCM_INUM0
,
393 scm_make_string (SCM_INUM0
, SCM_UNDEFINED
),
396 scm_call_1 (proc
, p
);
398 return scm_get_output_string (p
);
402 SCM_DEFINE (scm_call_with_input_string
, "call-with-input-string", 2, 0, 0,
403 (SCM string
, SCM proc
),
404 "Calls the one-argument procedure @var{proc} with a newly\n"
405 "created input port from which @var{string}'s contents may be\n"
406 "read. The value yielded by the @var{proc} is returned.")
407 #define FUNC_NAME s_scm_call_with_input_string
409 SCM p
= scm_mkstrport(SCM_INUM0
, string
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
410 return scm_call_1 (proc
, p
);
414 SCM_DEFINE (scm_open_input_string
, "open-input-string", 1, 0, 0,
416 "Take a string and return an input port that delivers characters\n"
417 "from the string. The port can be closed by\n"
418 "@code{close-input-port}, though its storage will be reclaimed\n"
419 "by the garbage collector if it becomes inaccessible.")
420 #define FUNC_NAME s_scm_open_input_string
422 SCM p
= scm_mkstrport(SCM_INUM0
, str
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
427 SCM_DEFINE (scm_open_output_string
, "open-output-string", 0, 0, 0,
429 "Return an output port that will accumulate characters for\n"
430 "retrieval by @code{get-output-string}. The port can be closed\n"
431 "by the procedure @code{close-output-port}, though its storage\n"
432 "will be reclaimed by the garbage collector if it becomes\n"
434 #define FUNC_NAME s_scm_open_output_string
438 p
= scm_mkstrport (SCM_INUM0
,
439 scm_make_string (SCM_INUM0
, SCM_UNDEFINED
),
446 SCM_DEFINE (scm_get_output_string
, "get-output-string", 1, 0, 0,
448 "Given an output port created by @code{open-output-string},\n"
449 "return a string consisting of the characters that have been\n"
450 "output to the port so far.")
451 #define FUNC_NAME s_scm_get_output_string
453 SCM_VALIDATE_OPOUTSTRPORT (1, port
);
454 return scm_strport_to_string (port
);
459 /* Given a null-terminated string EXPR containing a Scheme expression
460 read it, and return it as an SCM value. */
462 scm_c_read_string (const char *expr
)
464 SCM port
= scm_mkstrport (SCM_INUM0
,
465 scm_from_locale_string (expr
),
467 "scm_c_read_string");
470 /* Read expressions from that port; ignore the values. */
471 form
= scm_read (port
);
473 scm_close_port (port
);
477 /* Given a null-terminated string EXPR containing Scheme program text,
478 evaluate it, and return the result of the last expression evaluated. */
480 scm_c_eval_string (const char *expr
)
482 return scm_eval_string (scm_from_locale_string (expr
));
486 scm_c_eval_string_in_module (const char *expr
, SCM module
)
488 return scm_eval_string_in_module (scm_from_locale_string (expr
), module
);
493 inner_eval_string (void *data
)
495 SCM port
= (SCM
)data
;
497 SCM ans
= SCM_UNSPECIFIED
;
499 /* Read expressions from that port; ignore the values. */
500 while (!SCM_EOF_OBJECT_P (form
= scm_read (port
)))
501 ans
= scm_primitive_eval_x (form
);
503 /* Don't close the port here; if we re-enter this function via a
504 continuation, then the next time we enter it, we'll get an error.
505 It's a string port anyway, so there's no advantage to closing it
511 SCM_DEFINE (scm_eval_string_in_module
, "eval-string", 1, 1, 0,
512 (SCM string
, SCM module
),
513 "Evaluate @var{string} as the text representation of a Scheme\n"
514 "form or forms, and return whatever value they produce.\n"
515 "Evaluation takes place in the given module, or the current\n"
516 "module when no module is given.\n"
517 "While the code is evaluated, the given module is made the\n"
518 "current one. The current module is restored when this\n"
519 "procedure returns.")
520 #define FUNC_NAME s_scm_eval_string_in_module
522 SCM port
= scm_mkstrport (SCM_INUM0
, string
, SCM_OPN
| SCM_RDNG
,
524 if (SCM_UNBNDP (module
))
525 module
= scm_current_module ();
527 SCM_VALIDATE_MODULE (2, module
);
528 return scm_c_call_with_current_module (module
,
529 inner_eval_string
, (void *)port
);
534 scm_eval_string (SCM string
)
536 return scm_eval_string_in_module (string
, SCM_UNDEFINED
);
542 scm_t_bits tc
= scm_make_port_type ("string", stfill_buffer
, st_write
);
544 scm_set_port_mark (tc
, scm_markstream
);
545 scm_set_port_end_input (tc
, st_end_input
);
546 scm_set_port_flush (tc
, st_flush
);
547 scm_set_port_seek (tc
, st_seek
);
548 scm_set_port_truncate (tc
, st_truncate
);
556 scm_tc16_strport
= scm_make_stptob ();
558 #include "libguile/strports.x"