1 /* Copyright (C) 1995,1996,1998,1999 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. */
62 /* {Ports - string ports}
67 write_buf/write_end point to the ends of the allocated string.
68 read_buf/read_end in principle point to the part of the string which
69 has been written to, but this is only updated after a flush.
70 read_pos and write_pos in principle should be equal, but this is only true
71 when rw_active is SCM_PORT_NEITHER.
75 stfill_buffer (SCM port
)
77 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
79 if (pt
->read_pos
>= pt
->read_end
)
82 return scm_return_first (*pt
->read_pos
, port
);
85 /* change the size of a port's string to new_size. this doesn't
86 change read_buf_size. */
88 st_resize_port (scm_port
*pt
, off_t new_size
)
90 off_t index
= pt
->write_pos
- pt
->write_buf
;
92 pt
->write_buf_size
= new_size
;
94 scm_vector_set_length_x (pt
->stream
, SCM_MAKINUM (new_size
));
96 /* reset buffer in case reallocation moved the string. */
98 pt
->read_buf
= pt
->write_buf
= SCM_CHARS (pt
->stream
);
99 pt
->read_pos
= pt
->write_pos
= pt
->write_buf
+ index
;
100 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
101 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
105 /* amount by which write_buf is expanded. */
106 #define SCM_WRITE_BLOCK 80
108 /* ensure that write_pos < write_end by enlarging the buffer when
109 necessary. update read_buf to account for written chars. */
113 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
115 if (pt
->write_pos
== pt
->write_end
)
117 st_resize_port (pt
, pt
->write_buf_size
+ SCM_WRITE_BLOCK
);
119 pt
->read_pos
= pt
->write_pos
;
120 if (pt
->read_pos
> pt
->read_end
)
122 pt
->read_end
= (unsigned char *) pt
->read_pos
;
123 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
125 pt
->rw_active
= SCM_PORT_NEITHER
;
129 st_write (SCM port
, void *data
, size_t size
)
131 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
132 const char *input
= (char *) data
;
136 int space
= pt
->write_end
- pt
->write_pos
;
137 int write_len
= (size
> space
) ? space
: size
;
139 strncpy (pt
->write_pos
, input
, write_len
);
140 pt
->write_pos
+= write_len
;
143 if (write_len
== space
)
149 st_end_input (SCM port
, int offset
)
151 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
152 const unsigned char *pos
= pt
->read_pos
- offset
;
154 if (pos
< pt
->read_buf
)
155 scm_misc_error ("st_end_input", "negative position", SCM_EOL
);
157 pt
->write_pos
= (unsigned char *) pt
->read_pos
= pos
;
158 pt
->rw_active
= SCM_PORT_NEITHER
;
162 st_seek (SCM port
, off_t offset
, int whence
)
164 scm_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_WRITE
)
186 if (pt
->rw_active
== SCM_PORT_READ
)
187 scm_end_input (port
);
192 target
= pt
->read_pos
- pt
->read_buf
+ offset
;
195 target
= pt
->read_end
- pt
->read_buf
+ offset
;
197 default: /* SEEK_SET */
203 scm_misc_error ("st_seek", "negative offset", SCM_EOL
);
205 if (target
>= pt
->write_buf_size
)
207 if (!(SCM_CAR (port
) & SCM_WRTNG
))
209 if (target
> pt
->write_buf_size
)
211 scm_misc_error ("st_seek",
212 "seek past end of read-only strport",
218 st_resize_port (pt
, target
+ (target
== pt
->write_buf_size
223 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ target
;
224 if (pt
->read_pos
> pt
->read_end
)
226 pt
->read_end
= (unsigned char *) pt
->read_pos
;
227 pt
->read_buf_size
= pt
->read_end
- pt
->read_buf
;
234 st_truncate (SCM port
, off_t length
)
236 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
238 if (length
> pt
->write_buf_size
)
239 st_resize_port (pt
, length
);
241 pt
->read_buf_size
= length
;
242 pt
->read_end
= pt
->read_buf
+ length
;
243 if (pt
->read_pos
> pt
->read_end
)
244 pt
->read_pos
= pt
->read_end
;
246 if (pt
->write_pos
> pt
->read_end
)
247 pt
->write_pos
= pt
->read_end
;
251 scm_mkstrport (pos
, str
, modes
, caller
)
261 SCM_ASSERT (SCM_INUMP(pos
) && SCM_INUM(pos
) >= 0, pos
, SCM_ARG1
, caller
);
262 SCM_ASSERT (SCM_NIMP(str
) && SCM_ROSTRINGP(str
), str
, SCM_ARG1
, caller
);
263 str_len
= SCM_ROLENGTH (str
);
264 if (SCM_INUM (pos
) > str_len
)
265 scm_out_of_range (caller
, pos
);
266 if (!((modes
& SCM_WRTNG
) || (modes
& SCM_RDNG
)))
267 scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL
);
270 pt
= scm_add_to_port_table (z
);
271 SCM_SETCAR (z
, scm_tc16_strport
| modes
);
272 SCM_SETPTAB_ENTRY (z
, pt
);
273 SCM_SETSTREAM (z
, str
);
274 pt
->write_buf
= pt
->read_buf
= SCM_ROCHARS (str
);
275 pt
->read_pos
= pt
->write_pos
= pt
->read_buf
+ SCM_INUM (pos
);
276 pt
->write_buf_size
= pt
->read_buf_size
= str_len
;
277 pt
->write_end
= pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
283 /* ensure write_pos is writable. */
284 if ((modes
& SCM_WRTNG
) && pt
->write_pos
== pt
->write_end
)
289 /* create a new string from a string port's buffer. */
290 SCM
scm_strport_to_string (SCM port
)
292 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
294 if (pt
->rw_active
== SCM_PORT_WRITE
)
296 return scm_makfromstr (pt
->read_buf
, pt
->read_buf_size
, 0);
299 SCM_PROC(s_call_with_output_string
, "call-with-output-string", 1, 0, 0, scm_call_with_output_string
);
302 scm_call_with_output_string (proc
)
307 p
= scm_mkstrport (SCM_INUM0
,
308 scm_make_string (SCM_INUM0
, SCM_UNDEFINED
),
310 s_call_with_output_string
);
311 scm_apply (proc
, p
, scm_listofnull
);
313 return scm_strport_to_string (p
);
318 /* Return a Scheme string obtained by printing a given object.
323 scm_strprint_obj (obj
)
329 str
= scm_makstr (0, 0);
330 port
= scm_mkstrport (SCM_INUM0
, str
, SCM_OPN
| SCM_WRTNG
, "scm_strprint_obj");
331 scm_prin1 (obj
, port
, 1);
333 return scm_strport_to_string (port
);
340 SCM_PROC(s_call_with_input_string
, "call-with-input-string", 2, 0, 0, scm_call_with_input_string
);
343 scm_call_with_input_string (str
, proc
)
347 SCM p
= scm_mkstrport(SCM_INUM0
, str
, SCM_OPN
| SCM_RDNG
, s_call_with_input_string
);
348 return scm_apply (proc
, p
, scm_listofnull
);
353 /* Given a null-terminated string EXPR containing a Scheme expression
354 read it, and return it as an SCM value. */
359 SCM port
= scm_mkstrport (SCM_INUM0
,
360 scm_makfrom0str (expr
),
365 /* Read expressions from that port; ignore the values. */
366 form
= scm_read (port
);
368 scm_close_port (port
);
372 /* Given a null-terminated string EXPR containing Scheme program text,
373 evaluate it, and return the result of the last expression evaluated. */
378 return scm_eval_string (scm_makfrom0str (expr
));
382 SCM_PROC (s_eval_string
, "eval-string", 1, 0, 0, scm_eval_string
);
385 scm_eval_string (string
)
388 SCM port
= scm_mkstrport (SCM_INUM0
, string
, SCM_OPN
| SCM_RDNG
,
391 SCM ans
= SCM_UNSPECIFIED
;
393 /* Read expressions from that port; ignore the values. */
394 while (!SCM_EOF_OBJECT_P (form
= scm_read (port
)))
395 ans
= scm_eval_x (form
);
397 /* Don't close the port here; if we re-enter this function via a
398 continuation, then the next time we enter it, we'll get an error.
399 It's a string port anyway, so there's no advantage to closing it
405 void scm_make_stptob (void); /* Called from ports.c */
410 long tc
= scm_make_port_type ("string", stfill_buffer
, st_write
);
411 scm_set_port_mark (tc
, scm_markstream
);
412 scm_set_port_end_input (tc
, st_end_input
);
413 scm_set_port_flush (tc
, st_flush
);
414 scm_set_port_seek (tc
, st_seek
);
415 scm_set_port_truncate (tc
, st_truncate
);
421 #include "strports.x"