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/arrays.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 We break the rules set forth by strings.h about accessing the
59 internals of strings here. We can do this since we can guarantee
60 that the string used as pt->stream is not in use by anyone else.
61 Thus, it's representation will not change asynchronously.
63 (Ports aren't thread-safe yet anyway...)
65 write_buf/write_end point to the ends of the allocated string.
66 read_buf/read_end in principle point to the part of the string which
67 has been written to, but this is only updated after a flush.
68 read_pos and write_pos in principle should be equal, but this is only true
69 when rw_active is SCM_PORT_NEITHER.
71 ENHANCE-ME - output blocks:
73 The current code keeps an output string as a single block. That means
74 when the size is increased the entire old contents must be copied. It'd
75 be more efficient to begin a new block when the old one is full, so
76 there's no re-copying of previous data.
78 To make seeking efficient, keeping the pieces in a vector might be best,
79 though appending is probably the most common operation. The size of each
80 block could be progressively increased, so the bigger the string the
83 When `get-output-string' is called the blocks have to be coalesced into a
84 string, the result could be kept as a single big block. If blocks were
85 strings then `get-output-string' could notice when there's just one and
86 return that with a copy-on-write (though repeated calls to
87 `get-output-string' are probably unlikely).
89 Another possibility would be to extend the port mechanism to let SCM
90 strings come through directly from `display' and friends. That way if a
91 big string is written it can be kept as a copy-on-write, saving time
92 copying and maybe saving some space. */
95 scm_t_bits scm_tc16_strport
;
99 stfill_buffer (SCM port
)
101 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
103 if (pt
->read_pos
>= pt
->read_end
)
106 return scm_return_first_int (*pt
->read_pos
, port
);
109 /* change the size of a port's string to new_size. this doesn't
110 change read_buf_size. */
112 st_resize_port (scm_t_port
*pt
, scm_t_off new_size
)
114 SCM old_stream
= SCM_PACK (pt
->stream
);
115 const char *src
= scm_i_string_chars (old_stream
);
117 SCM new_stream
= scm_i_make_string (new_size
, &dst
);
118 unsigned long int old_size
= scm_i_string_length (old_stream
);
119 unsigned long int min_size
= min (old_size
, new_size
);
122 scm_t_off index
= pt
->write_pos
- pt
->write_buf
;
124 pt
->write_buf_size
= new_size
;
126 for (i
= 0; i
!= min_size
; ++i
)
129 scm_remember_upto_here_1 (old_stream
);
133 pt
->stream
= SCM_UNPACK (new_stream
);
134 pt
->read_buf
= pt
->write_buf
= (unsigned char *)dst
;
135 pt
->read_pos
= pt
->write_pos
= pt
->write_buf
+ index
;
136 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
137 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
141 /* amount by which write_buf is expanded. */
142 #define SCM_WRITE_BLOCK 80
144 /* ensure that write_pos < write_end by enlarging the buffer when
145 necessary. update read_buf to account for written chars.
147 The buffer is enlarged by 1.5 times, plus SCM_WRITE_BLOCK. Adding just a
148 fixed amount is no good, because there's a block copy for each increment,
149 and that copying would take quadratic time. In the past it was found to
150 be very slow just adding 80 bytes each time (eg. about 10 seconds for
151 writing a 100kbyte string). */
156 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
158 if (pt
->write_pos
== pt
->write_end
)
160 st_resize_port (pt
, pt
->write_buf_size
* 3 / 2 + SCM_WRITE_BLOCK
);
162 pt
->read_pos
= pt
->write_pos
;
163 if (pt
->read_pos
> pt
->read_end
)
165 pt
->read_end
= (unsigned char *) pt
->read_pos
;
166 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
168 pt
->rw_active
= SCM_PORT_NEITHER
;
172 st_write (SCM port
, const void *data
, size_t size
)
174 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
175 const char *input
= (char *) data
;
179 int space
= pt
->write_end
- pt
->write_pos
;
180 int write_len
= (size
> space
) ? space
: size
;
182 memcpy ((char *) pt
->write_pos
, input
, write_len
);
183 pt
->write_pos
+= write_len
;
186 if (write_len
== space
)
192 st_end_input (SCM port
, int offset
)
194 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
196 if (pt
->read_pos
- pt
->read_buf
< offset
)
197 scm_misc_error ("st_end_input", "negative position", SCM_EOL
);
199 pt
->write_pos
= (unsigned char *) (pt
->read_pos
= pt
->read_pos
- offset
);
200 pt
->rw_active
= SCM_PORT_NEITHER
;
204 st_seek (SCM port
, scm_t_off offset
, int whence
)
206 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
209 if (pt
->rw_active
== SCM_PORT_READ
&& offset
== 0 && whence
== SEEK_CUR
)
210 /* special case to avoid disturbing the unread-char buffer. */
212 if (pt
->read_buf
== pt
->putback_buf
)
214 target
= pt
->saved_read_pos
- pt
->saved_read_buf
215 - (pt
->read_end
- pt
->read_pos
);
219 target
= pt
->read_pos
- pt
->read_buf
;
223 /* all other cases. */
225 if (pt
->rw_active
== SCM_PORT_WRITE
)
228 if (pt
->rw_active
== SCM_PORT_READ
)
229 scm_end_input (port
);
234 target
= pt
->read_pos
- pt
->read_buf
+ offset
;
237 target
= pt
->read_end
- pt
->read_buf
+ offset
;
239 default: /* SEEK_SET */
245 scm_misc_error ("st_seek", "negative offset", SCM_EOL
);
247 if (target
>= pt
->write_buf_size
)
249 if (!(SCM_CELL_WORD_0 (port
) & SCM_WRTNG
))
251 if (target
> pt
->write_buf_size
)
253 scm_misc_error ("st_seek",
254 "seek past end of read-only strport",
260 st_resize_port (pt
, target
+ (target
== pt
->write_buf_size
265 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ target
;
266 if (pt
->read_pos
> pt
->read_end
)
268 pt
->read_end
= (unsigned char *) pt
->read_pos
;
269 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
276 st_truncate (SCM port
, scm_t_off length
)
278 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
280 if (length
> pt
->write_buf_size
)
281 st_resize_port (pt
, length
);
283 pt
->read_buf_size
= length
;
284 pt
->read_end
= pt
->read_buf
+ length
;
285 if (pt
->read_pos
> pt
->read_end
)
286 pt
->read_pos
= pt
->read_end
;
288 if (pt
->write_pos
> pt
->read_end
)
289 pt
->write_pos
= pt
->read_end
;
293 scm_i_mkstrport (SCM pos
, const char *locale_str
, size_t str_len
, long modes
, const char *caller
)
300 /* Because ports are inherently 8-bit, strings need to be converted
301 to a locale representation for storage. But, since string ports
302 rely on string functionality for their memory management, we need
303 to create a new string that has the 8-bit locale representation
304 of the underlying string.
306 locale_str is already in the locale of the port. */
307 str
= scm_i_make_string (str_len
, &buf
);
308 memcpy (buf
, locale_str
, str_len
);
310 c_pos
= scm_to_unsigned_integer (pos
, 0, str_len
);
312 if (!((modes
& SCM_WRTNG
) || (modes
& SCM_RDNG
)))
313 scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL
);
315 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
316 z
= scm_new_port_table_entry (scm_tc16_strport
);
317 pt
= SCM_PTAB_ENTRY(z
);
318 SCM_SETSTREAM (z
, SCM_UNPACK (str
));
319 SCM_SET_CELL_TYPE(z
, scm_tc16_strport
|modes
);
320 pt
->write_buf
= pt
->read_buf
= (unsigned char *) scm_i_string_chars (str
);
321 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ c_pos
;
322 pt
->write_buf_size
= pt
->read_buf_size
= str_len
;
323 pt
->write_end
= pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
327 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
329 /* ensure write_pos is writable. */
330 if ((modes
& SCM_WRTNG
) && pt
->write_pos
== pt
->write_end
)
336 scm_mkstrport (SCM pos
, SCM str
, long modes
, const char *caller
)
342 SCM_ASSERT (scm_is_string (str
), str
, SCM_ARG1
, caller
);
344 /* Because ports are inherently 8-bit, strings need to be converted
345 to a locale representation for storage. But, since string ports
346 rely on string functionality for their memory management, we need
347 to create a new string that has the 8-bit locale representation
348 of the underlying string. This violates the guideline that the
349 internal encoding of characters in strings is in unicode
352 /* Ports are initialized with the thread-default values for encoding and
353 invalid sequence handling. */
354 buf
= scm_to_locale_stringn (str
, &str_len
);
355 z
= scm_i_mkstrport (pos
, buf
, str_len
, modes
, caller
);
360 /* Create a new string from a string port's buffer, converting from
361 the port's 8-bit locale-specific representation to the standard
362 string representation. */
363 SCM
scm_strport_to_string (SCM port
)
365 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
368 if (pt
->rw_active
== SCM_PORT_WRITE
)
371 if (pt
->read_buf_size
== 0)
374 if (pt
->encoding
== NULL
)
377 str
= scm_i_make_string (pt
->read_buf_size
, &buf
);
378 memcpy (buf
, pt
->read_buf
, pt
->read_buf_size
);
381 str
= scm_i_from_stringn ((char *)pt
->read_buf
, pt
->read_buf_size
,
382 pt
->encoding
, pt
->ilseq_handler
);
383 scm_remember_upto_here_1 (port
);
387 /* Create a vector containing the locale representation of the string in the
389 SCM
scm_strport_to_locale_u8vector (SCM port
)
391 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
395 if (pt
->rw_active
== SCM_PORT_WRITE
)
398 buf
= scm_malloc (pt
->read_buf_size
);
399 memcpy (buf
, pt
->read_buf
, pt
->read_buf_size
);
400 vec
= scm_take_u8vector ((unsigned char *) buf
, pt
->read_buf_size
);
401 scm_remember_upto_here_1 (port
);
405 SCM_DEFINE (scm_object_to_string
, "object->string", 1, 1, 0,
406 (SCM obj
, SCM printer
),
407 "Return a Scheme string obtained by printing @var{obj}.\n"
408 "Printing function can be specified by the optional second\n"
409 "argument @var{printer} (default: @code{write}).")
410 #define FUNC_NAME s_scm_object_to_string
414 if (!SCM_UNBNDP (printer
))
415 SCM_VALIDATE_PROC (2, printer
);
417 str
= scm_c_make_string (0, SCM_UNDEFINED
);
418 port
= scm_mkstrport (SCM_INUM0
, str
, SCM_OPN
| SCM_WRTNG
, FUNC_NAME
);
420 if (SCM_UNBNDP (printer
))
421 scm_write (obj
, port
);
423 scm_call_2 (printer
, obj
, port
);
425 return scm_strport_to_string (port
);
429 SCM_DEFINE (scm_call_with_output_locale_u8vector
, "call-with-output-locale-u8vector", 1, 0, 0,
431 "Calls the one-argument procedure @var{proc} with a newly created output\n"
432 "port. When the function returns, a vector containing the bytes of a\n"
433 "locale representation of the characters written into the port is returned\n")
434 #define FUNC_NAME s_scm_call_with_output_locale_u8vector
438 p
= scm_mkstrport (SCM_INUM0
,
439 scm_make_string (SCM_INUM0
, SCM_UNDEFINED
),
442 scm_call_1 (proc
, p
);
444 return scm_get_output_locale_u8vector (p
);
448 SCM_DEFINE (scm_call_with_output_string
, "call-with-output-string", 1, 0, 0,
450 "Calls the one-argument procedure @var{proc} with a newly created output\n"
451 "port. When the function returns, the string composed of the characters\n"
452 "written into the port is returned.")
453 #define FUNC_NAME s_scm_call_with_output_string
457 p
= scm_mkstrport (SCM_INUM0
,
458 scm_make_string (SCM_INUM0
, SCM_UNDEFINED
),
461 scm_call_1 (proc
, p
);
463 return scm_get_output_string (p
);
467 SCM_DEFINE (scm_call_with_input_string
, "call-with-input-string", 2, 0, 0,
468 (SCM string
, SCM proc
),
469 "Calls the one-argument procedure @var{proc} with a newly\n"
470 "created input port from which @var{string}'s contents may be\n"
471 "read. The value yielded by the @var{proc} is returned.")
472 #define FUNC_NAME s_scm_call_with_input_string
474 SCM p
= scm_mkstrport(SCM_INUM0
, string
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
475 return scm_call_1 (proc
, p
);
479 SCM_DEFINE (scm_open_input_string
, "open-input-string", 1, 0, 0,
481 "Take a string and return an input port that delivers characters\n"
482 "from the string. The port can be closed by\n"
483 "@code{close-input-port}, though its storage will be reclaimed\n"
484 "by the garbage collector if it becomes inaccessible.")
485 #define FUNC_NAME s_scm_open_input_string
487 SCM p
= scm_mkstrport(SCM_INUM0
, str
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
492 SCM_DEFINE (scm_open_input_locale_u8vector
, "open-input-locale-u8vector", 1, 0, 0,
494 "Take a u8vector containing the bytes of a string encoded in the\n"
495 "current locale and return an input port that delivers characters\n"
496 "from the string. The port can be closed by\n"
497 "@code{close-input-port}, though its storage will be reclaimed\n"
498 "by the garbage collector if it becomes inaccessible.")
499 #define FUNC_NAME s_scm_open_input_locale_u8vector
501 scm_t_array_handle hnd
;
504 const scm_t_uint8
*buf
;
506 buf
= scm_u8vector_elements (vec
, &hnd
, &len
, &inc
);
507 SCM p
= scm_i_mkstrport(SCM_INUM0
, (const char *) buf
, len
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
508 scm_array_handle_release (&hnd
);
513 SCM_DEFINE (scm_open_output_string
, "open-output-string", 0, 0, 0,
515 "Return an output port that will accumulate characters for\n"
516 "retrieval by @code{get-output-string}. The port can be closed\n"
517 "by the procedure @code{close-output-port}, though its storage\n"
518 "will be reclaimed by the garbage collector if it becomes\n"
520 #define FUNC_NAME s_scm_open_output_string
524 p
= scm_mkstrport (SCM_INUM0
,
525 scm_make_string (SCM_INUM0
, SCM_UNDEFINED
),
532 SCM_DEFINE (scm_get_output_string
, "get-output-string", 1, 0, 0,
534 "Given an output port created by @code{open-output-string},\n"
535 "return a string consisting of the characters that have been\n"
536 "output to the port so far.")
537 #define FUNC_NAME s_scm_get_output_string
539 SCM_VALIDATE_OPOUTSTRPORT (1, port
);
540 return scm_strport_to_string (port
);
545 SCM_DEFINE (scm_get_output_locale_u8vector
, "get-output-locale-u8vector", 1, 0, 0,
547 "Given an output port created by @code{open-output-string},\n"
548 "return a u8 vector containing the characters of the string\n"
549 "encoded in the current locale.")
550 #define FUNC_NAME s_scm_get_output_locale_u8vector
552 SCM_VALIDATE_OPOUTSTRPORT (1, port
);
553 return scm_strport_to_locale_u8vector (port
);
558 /* Given a null-terminated string EXPR containing a Scheme expression
559 read it, and return it as an SCM value. */
561 scm_c_read_string (const char *expr
)
563 /* FIXME: the c string gets packed into a string, only to get
564 immediately unpacked in scm_mkstrport. */
565 SCM port
= scm_mkstrport (SCM_INUM0
,
566 scm_from_locale_string (expr
),
568 "scm_c_read_string");
571 /* Read expressions from that port; ignore the values. */
572 form
= scm_read (port
);
574 scm_close_port (port
);
578 /* Given a null-terminated string EXPR containing Scheme program text,
579 evaluate it, and return the result of the last expression evaluated. */
581 scm_c_eval_string (const char *expr
)
583 return scm_eval_string (scm_from_locale_string (expr
));
587 scm_c_eval_string_in_module (const char *expr
, SCM module
)
589 return scm_eval_string_in_module (scm_from_locale_string (expr
), module
);
594 inner_eval_string (void *data
)
596 SCM port
= (SCM
)data
;
598 SCM ans
= SCM_UNSPECIFIED
;
600 /* Read expressions from that port; ignore the values. */
601 while (!SCM_EOF_OBJECT_P (form
= scm_read (port
)))
602 ans
= scm_primitive_eval_x (form
);
604 /* Don't close the port here; if we re-enter this function via a
605 continuation, then the next time we enter it, we'll get an error.
606 It's a string port anyway, so there's no advantage to closing it
612 SCM_DEFINE (scm_eval_string_in_module
, "eval-string", 1, 1, 0,
613 (SCM string
, SCM module
),
614 "Evaluate @var{string} as the text representation of a Scheme\n"
615 "form or forms, and return whatever value they produce.\n"
616 "Evaluation takes place in the given module, or the current\n"
617 "module when no module is given.\n"
618 "While the code is evaluated, the given module is made the\n"
619 "current one. The current module is restored when this\n"
620 "procedure returns.")
621 #define FUNC_NAME s_scm_eval_string_in_module
623 SCM port
= scm_mkstrport (SCM_INUM0
, string
, SCM_OPN
| SCM_RDNG
,
625 if (SCM_UNBNDP (module
))
626 module
= scm_current_module ();
628 SCM_VALIDATE_MODULE (2, module
);
629 return scm_c_call_with_current_module (module
,
630 inner_eval_string
, (void *)port
);
635 scm_eval_string (SCM string
)
637 return scm_eval_string_in_module (string
, SCM_UNDEFINED
);
643 scm_t_bits tc
= scm_make_port_type ("string", stfill_buffer
, st_write
);
645 scm_set_port_mark (tc
, scm_markstream
);
646 scm_set_port_end_input (tc
, st_end_input
);
647 scm_set_port_flush (tc
, st_flush
);
648 scm_set_port_seek (tc
, st_seek
);
649 scm_set_port_truncate (tc
, st_truncate
);
657 scm_tc16_strport
= scm_make_stptob ();
659 #include "libguile/strports.x"