1 /* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
45 #include "libguile/_scm.h"
52 #include "libguile/unif.h"
53 #include "libguile/eval.h"
54 #include "libguile/ports.h"
55 #include "libguile/read.h"
56 #include "libguile/root.h"
57 #include "libguile/strings.h"
58 #include "libguile/modules.h"
59 #include "libguile/validate.h"
60 #include "libguile/deprecation.h"
62 #include "libguile/strports.h"
70 /* {Ports - string ports}
75 write_buf/write_end point to the ends of the allocated string.
76 read_buf/read_end in principle point to the part of the string which
77 has been written to, but this is only updated after a flush.
78 read_pos and write_pos in principle should be equal, but this is only true
79 when rw_active is SCM_PORT_NEITHER.
82 scm_t_bits scm_tc16_strport
;
86 stfill_buffer (SCM port
)
88 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
90 if (pt
->read_pos
>= pt
->read_end
)
93 return scm_return_first_int (*pt
->read_pos
, port
);
96 /* change the size of a port's string to new_size. this doesn't
97 change read_buf_size. */
99 st_resize_port (scm_t_port
*pt
, off_t new_size
)
101 SCM old_stream
= SCM_PACK (pt
->stream
);
102 SCM new_stream
= scm_allocate_string (new_size
);
103 unsigned long int old_size
= SCM_STRING_LENGTH (old_stream
);
104 unsigned long int min_size
= min (old_size
, new_size
);
107 off_t index
= pt
->write_pos
- pt
->write_buf
;
109 pt
->write_buf_size
= new_size
;
111 for (i
= 0; i
!= min_size
; ++i
)
112 SCM_STRING_CHARS (new_stream
) [i
] = SCM_STRING_CHARS (old_stream
) [i
];
116 pt
->stream
= SCM_UNPACK (new_stream
);
117 pt
->read_buf
= pt
->write_buf
= SCM_STRING_UCHARS (new_stream
);
118 pt
->read_pos
= pt
->write_pos
= pt
->write_buf
+ index
;
119 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
120 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
124 /* amount by which write_buf is expanded. */
125 #define SCM_WRITE_BLOCK 80
127 /* ensure that write_pos < write_end by enlarging the buffer when
128 necessary. update read_buf to account for written chars. */
132 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
134 if (pt
->write_pos
== pt
->write_end
)
136 st_resize_port (pt
, pt
->write_buf_size
+ SCM_WRITE_BLOCK
);
138 pt
->read_pos
= pt
->write_pos
;
139 if (pt
->read_pos
> pt
->read_end
)
141 pt
->read_end
= (unsigned char *) pt
->read_pos
;
142 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
144 pt
->rw_active
= SCM_PORT_NEITHER
;
148 st_write (SCM port
, const void *data
, size_t size
)
150 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
151 const char *input
= (char *) data
;
155 int space
= pt
->write_end
- pt
->write_pos
;
156 int write_len
= (size
> space
) ? space
: size
;
158 memcpy ((char *) pt
->write_pos
, input
, write_len
);
159 pt
->write_pos
+= write_len
;
162 if (write_len
== space
)
168 st_end_input (SCM port
, int offset
)
170 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
172 if (pt
->read_pos
- pt
->read_buf
< offset
)
173 scm_misc_error ("st_end_input", "negative position", SCM_EOL
);
175 pt
->write_pos
= (unsigned char *) (pt
->read_pos
= pt
->read_pos
- offset
);
176 pt
->rw_active
= SCM_PORT_NEITHER
;
180 st_seek (SCM port
, off_t offset
, int whence
)
182 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
185 if (pt
->rw_active
== SCM_PORT_READ
&& offset
== 0 && whence
== SEEK_CUR
)
186 /* special case to avoid disturbing the unread-char buffer. */
188 if (pt
->read_buf
== pt
->putback_buf
)
190 target
= pt
->saved_read_pos
- pt
->saved_read_buf
191 - (pt
->read_end
- pt
->read_pos
);
195 target
= pt
->read_pos
- pt
->read_buf
;
199 /* all other cases. */
201 if (pt
->rw_active
== SCM_PORT_WRITE
)
204 if (pt
->rw_active
== SCM_PORT_READ
)
205 scm_end_input (port
);
210 target
= pt
->read_pos
- pt
->read_buf
+ offset
;
213 target
= pt
->read_end
- pt
->read_buf
+ offset
;
215 default: /* SEEK_SET */
221 scm_misc_error ("st_seek", "negative offset", SCM_EOL
);
223 if (target
>= pt
->write_buf_size
)
225 if (!(SCM_CELL_WORD_0 (port
) & SCM_WRTNG
))
227 if (target
> pt
->write_buf_size
)
229 scm_misc_error ("st_seek",
230 "seek past end of read-only strport",
236 st_resize_port (pt
, target
+ (target
== pt
->write_buf_size
241 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ target
;
242 if (pt
->read_pos
> pt
->read_end
)
244 pt
->read_end
= (unsigned char *) pt
->read_pos
;
245 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
252 st_truncate (SCM port
, off_t length
)
254 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
256 if (length
> pt
->write_buf_size
)
257 st_resize_port (pt
, length
);
259 pt
->read_buf_size
= length
;
260 pt
->read_end
= pt
->read_buf
+ length
;
261 if (pt
->read_pos
> pt
->read_end
)
262 pt
->read_pos
= pt
->read_end
;
264 if (pt
->write_pos
> pt
->read_end
)
265 pt
->write_pos
= pt
->read_end
;
269 scm_mkstrport (SCM pos
, SCM str
, long modes
, const char *caller
)
275 SCM_ASSERT (SCM_INUMP(pos
) && SCM_INUM(pos
) >= 0, pos
, SCM_ARG1
, caller
);
276 SCM_ASSERT (SCM_STRINGP (str
), str
, SCM_ARG1
, caller
);
277 str_len
= SCM_STRING_LENGTH (str
);
278 if (SCM_INUM (pos
) > str_len
)
279 scm_out_of_range (caller
, pos
);
280 if (!((modes
& SCM_WRTNG
) || (modes
& SCM_RDNG
)))
281 scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL
);
284 pt
= scm_add_to_port_table (z
);
285 SCM_SET_CELL_TYPE (z
, scm_tc16_strport
| modes
);
286 SCM_SETPTAB_ENTRY (z
, pt
);
287 SCM_SETSTREAM (z
, SCM_UNPACK (str
));
288 pt
->write_buf
= pt
->read_buf
= SCM_STRING_UCHARS (str
);
289 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ SCM_INUM (pos
);
290 pt
->write_buf_size
= pt
->read_buf_size
= str_len
;
291 pt
->write_end
= pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
297 /* ensure write_pos is writable. */
298 if ((modes
& SCM_WRTNG
) && pt
->write_pos
== pt
->write_end
)
303 /* create a new string from a string port's buffer. */
304 SCM
scm_strport_to_string (SCM port
)
306 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
309 if (pt
->rw_active
== SCM_PORT_WRITE
)
312 str
= scm_mem2string ((char *) pt
->read_buf
, pt
->read_buf_size
);
313 scm_remember_upto_here_1 (port
);
317 SCM_DEFINE (scm_object_to_string
, "object->string", 1, 1, 0,
318 (SCM obj
, SCM printer
),
319 "Return a Scheme string obtained by printing @var{obj}.\n"
320 "Printing function can be specified by the optional second\n"
321 "argument @var{printer} (default: @code{write}).")
322 #define FUNC_NAME s_scm_object_to_string
326 if (!SCM_UNBNDP (printer
))
327 SCM_VALIDATE_PROC (2, printer
);
329 str
= scm_allocate_string (0);
330 port
= scm_mkstrport (SCM_INUM0
, str
, SCM_OPN
| SCM_WRTNG
, FUNC_NAME
);
332 if (SCM_UNBNDP (printer
))
333 scm_write (obj
, port
);
335 scm_call_2 (printer
, obj
, port
);
337 return scm_strport_to_string (port
);
341 #if (SCM_DEBUG_DEPRECATED == 0)
344 scm_strprint_obj (SCM obj
)
346 return scm_object_to_string (obj
, SCM_UNDEFINED
);
349 #endif /* (SCM_DEBUG_DEPRECATED == 0) */
351 SCM_DEFINE (scm_call_with_output_string
, "call-with-output-string", 1, 0, 0,
353 "Calls the one-argument procedure @var{proc} with a newly created output\n"
354 "port. When the function returns, the string composed of the characters\n"
355 "written into the port is returned.")
356 #define FUNC_NAME s_scm_call_with_output_string
360 p
= scm_mkstrport (SCM_INUM0
,
361 scm_make_string (SCM_INUM0
, SCM_UNDEFINED
),
364 scm_call_1 (proc
, p
);
366 return scm_strport_to_string (p
);
370 SCM_DEFINE (scm_call_with_input_string
, "call-with-input-string", 2, 0, 0,
371 (SCM string
, SCM proc
),
372 "Calls the one-argument procedure @var{proc} with a newly\n"
373 "created input port from which @var{string}'s contents may be\n"
374 "read. The value yielded by the @var{proc} is returned.")
375 #define FUNC_NAME s_scm_call_with_input_string
377 SCM p
= scm_mkstrport(SCM_INUM0
, string
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
378 return scm_call_1 (proc
, p
);
382 SCM_DEFINE (scm_open_input_string
, "open-input-string", 1, 0, 0,
384 "Take a string and return an input port that delivers characters\n"
385 "from the string. The port can be closed by\n"
386 "@code{close-input-port}, though its storage will be reclaimed\n"
387 "by the garbage collector if it becomes inaccessible.")
388 #define FUNC_NAME s_scm_open_input_string
390 SCM p
= scm_mkstrport(SCM_INUM0
, str
, SCM_OPN
| SCM_RDNG
, FUNC_NAME
);
395 SCM_DEFINE (scm_open_output_string
, "open-output-string", 0, 0, 0,
397 "Return an output port that will accumulate characters for\n"
398 "retrieval by @code{get-output-string}. The port can be closed\n"
399 "by the procedure @code{close-output-port}, though its storage\n"
400 "will be reclaimed by the garbage collector if it becomes\n"
402 #define FUNC_NAME s_scm_open_output_string
406 p
= scm_mkstrport (SCM_INUM0
,
407 scm_make_string (SCM_INUM0
, SCM_UNDEFINED
),
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_makfrom0str (expr
),
435 "scm_c_read_string");
438 /* Read expressions from that port; ignore the values. */
439 form
= scm_read (port
);
441 scm_close_port (port
);
445 /* Given a null-terminated string EXPR containing Scheme program text,
446 evaluate it, and return the result of the last expression evaluated. */
448 scm_c_eval_string (const char *expr
)
450 return scm_eval_string (scm_makfrom0str (expr
));
453 #if SCM_DEBUG_DEPRECATED == 0
456 scm_read_0str (char *expr
)
458 scm_c_issue_deprecation_warning
459 ("scm_read_0str is deprecated. Use scm_c_read_string instead.");
461 return scm_c_read_string (expr
);
465 scm_eval_0str (const char *expr
)
467 scm_c_issue_deprecation_warning
468 ("scm_eval_0str is deprecated. Use scm_c_eval_string instead.");
470 return scm_c_eval_string (expr
);
476 inner_eval_string (void *data
)
478 SCM port
= (SCM
)data
;
480 SCM ans
= SCM_UNSPECIFIED
;
482 /* Read expressions from that port; ignore the values. */
483 while (!SCM_EOF_OBJECT_P (form
= scm_read (port
)))
484 ans
= scm_primitive_eval_x (form
);
486 /* Don't close the port here; if we re-enter this function via a
487 continuation, then the next time we enter it, we'll get an error.
488 It's a string port anyway, so there's no advantage to closing it
494 SCM_DEFINE (scm_eval_string
, "eval-string", 1, 0, 0,
496 "Evaluate @var{string} as the text representation of a Scheme\n"
497 "form or forms, and return whatever value they produce.\n"
498 "Evaluation takes place in the environment returned by the\n"
499 "procedure @code{interaction-environment}.")
500 #define FUNC_NAME s_scm_eval_string
502 SCM port
= scm_mkstrport (SCM_INUM0
, string
, SCM_OPN
| SCM_RDNG
,
504 return scm_c_call_with_current_module (scm_interaction_environment (),
505 inner_eval_string
, (void *)port
);
512 scm_t_bits tc
= scm_make_port_type ("string", stfill_buffer
, st_write
);
514 scm_set_port_mark (tc
, scm_markstream
);
515 scm_set_port_end_input (tc
, st_end_input
);
516 scm_set_port_flush (tc
, st_flush
);
517 scm_set_port_seek (tc
, st_seek
);
518 scm_set_port_truncate (tc
, st_truncate
);
526 scm_tc16_strport
= scm_make_stptob ();
528 #ifndef SCM_MAGIC_SNARFER
529 #include "libguile/strports.x"