1 /* Copyright (C) 2009, 2010, 2011, 2013, 2014 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
31 #include "libguile/_scm.h"
32 #include "libguile/bytevectors.h"
33 #include "libguile/chars.h"
34 #include "libguile/eval.h"
35 #include "libguile/r6rs-ports.h"
36 #include "libguile/strings.h"
37 #include "libguile/validate.h"
38 #include "libguile/values.h"
39 #include "libguile/vectors.h"
43 /* Unimplemented features. */
46 /* Transoders are currently not implemented since Guile 1.8 is not
47 Unicode-capable. Thus, most of the code here assumes the use of the
50 transcoders_not_implemented (void)
52 fprintf (stderr
, "%s: warning: transcoders not implemented\n",
57 /* End-of-file object. */
59 SCM_DEFINE (scm_eof_object
, "eof-object", 0, 0, 0,
61 "Return the end-of-file object.")
62 #define FUNC_NAME s_scm_eof_object
72 # define MIN(a,b) ((a) < (b) ? (a) : (b))
75 /* Bytevector input ports or "bip" for short. */
76 static scm_t_bits bytevector_input_port_type
= 0;
85 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
;
87 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
89 port
= scm_new_port_table_entry (bytevector_input_port_type
);
90 c_port
= SCM_PTAB_ENTRY (port
);
92 /* Match the expectation of `binary-port?'. */
93 c_port
->encoding
= NULL
;
95 /* Prevent BV from being GC'd. */
96 SCM_SETSTREAM (port
, SCM_UNPACK (bv
));
98 /* Have the port directly access the bytevector. */
99 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
100 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
102 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
103 c_port
->read_end
= (unsigned char *) c_bv
+ c_len
;
104 c_port
->read_buf_size
= c_len
;
106 /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
107 SCM_SET_CELL_TYPE (port
, bytevector_input_port_type
| mode_bits
);
109 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
115 bip_fill_input (SCM port
)
118 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
120 if (c_port
->read_pos
>= c_port
->read_end
)
123 result
= (int) *c_port
->read_pos
;
129 bip_seek (SCM port
, scm_t_off offset
, int whence
)
130 #define FUNC_NAME "bip_seek"
132 scm_t_off c_result
= 0;
133 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
138 offset
+= c_port
->read_pos
- c_port
->read_buf
;
142 if (c_port
->read_buf
+ offset
<= c_port
->read_end
)
144 c_port
->read_pos
= c_port
->read_buf
+ offset
;
148 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
152 if (c_port
->read_end
- offset
>= c_port
->read_buf
)
154 c_port
->read_pos
= c_port
->read_end
- offset
;
155 c_result
= c_port
->read_pos
- c_port
->read_buf
;
158 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
162 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
163 "invalid `seek' parameter");
171 /* Instantiate the bytevector input port type. */
173 initialize_bytevector_input_ports (void)
175 bytevector_input_port_type
=
176 scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input
,
179 scm_set_port_seek (bytevector_input_port_type
, bip_seek
);
183 SCM_DEFINE (scm_open_bytevector_input_port
,
184 "open-bytevector-input-port", 1, 1, 0,
185 (SCM bv
, SCM transcoder
),
186 "Return an input port whose contents are drawn from "
187 "bytevector @var{bv}.")
188 #define FUNC_NAME s_scm_open_bytevector_input_port
190 SCM_VALIDATE_BYTEVECTOR (1, bv
);
191 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
192 transcoders_not_implemented ();
194 return (make_bip (bv
));
199 /* Custom binary ports. The following routines are shared by input and
200 output custom binary ports. */
202 #define SCM_CBP_GET_POSITION_PROC(_port) \
203 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
204 #define SCM_CBP_SET_POSITION_PROC(_port) \
205 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
206 #define SCM_CBP_CLOSE_PROC(_port) \
207 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
210 cbp_seek (SCM port
, scm_t_off offset
, int whence
)
211 #define FUNC_NAME "cbp_seek"
214 scm_t_off c_result
= 0;
220 SCM get_position_proc
;
222 get_position_proc
= SCM_CBP_GET_POSITION_PROC (port
);
223 if (SCM_LIKELY (scm_is_true (get_position_proc
)))
224 result
= scm_call_0 (get_position_proc
);
226 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
227 "R6RS custom binary port with "
228 "`port-position' support");
229 c_result
= scm_to_int (result
);
231 /* We just want to know the current position. */
240 SCM set_position_proc
;
242 set_position_proc
= SCM_CBP_SET_POSITION_PROC (port
);
243 if (SCM_LIKELY (scm_is_true (set_position_proc
)))
244 result
= scm_call_1 (set_position_proc
, scm_from_int (offset
));
246 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
247 "seekable R6RS custom binary port");
249 /* Assuming setting the position succeeded. */
255 /* `SEEK_END' cannot be supported. */
256 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
257 "R6RS custom binary ports do not "
258 "support `SEEK_END'");
270 close_proc
= SCM_CBP_CLOSE_PROC (port
);
271 if (scm_is_true (close_proc
))
272 /* Invoke the `close' thunk. */
273 scm_call_0 (close_proc
);
279 /* Custom binary input port ("cbip" for short). */
281 static scm_t_bits custom_binary_input_port_type
= 0;
283 /* Size of the buffer embedded in custom binary input ports. */
284 #define CBIP_BUFFER_SIZE 4096
286 /* Return the bytevector associated with PORT. */
287 #define SCM_CBIP_BYTEVECTOR(_port) \
288 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
290 /* Return the various procedures of PORT. */
291 #define SCM_CBIP_READ_PROC(_port) \
292 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
296 make_cbip (SCM read_proc
, SCM get_position_proc
,
297 SCM set_position_proc
, SCM close_proc
)
299 SCM port
, bv
, method_vector
;
303 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
;
305 /* Use a bytevector as the underlying buffer. */
306 c_len
= CBIP_BUFFER_SIZE
;
307 bv
= scm_c_make_bytevector (c_len
);
308 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
310 /* Store the various methods and bytevector in a vector. */
311 method_vector
= scm_c_make_vector (5, SCM_BOOL_F
);
312 SCM_SIMPLE_VECTOR_SET (method_vector
, 4, bv
);
313 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, read_proc
);
314 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
315 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
316 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
318 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
320 port
= scm_new_port_table_entry (custom_binary_input_port_type
);
321 c_port
= SCM_PTAB_ENTRY (port
);
323 /* Match the expectation of `binary-port?'. */
324 c_port
->encoding
= NULL
;
326 /* Attach it the method vector. */
327 SCM_SETSTREAM (port
, SCM_UNPACK (method_vector
));
329 /* Have the port directly access the buffer (bytevector). */
330 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
331 c_port
->read_end
= (unsigned char *) c_bv
;
332 c_port
->read_buf_size
= c_len
;
334 /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
335 SCM_SET_CELL_TYPE (port
, custom_binary_input_port_type
| mode_bits
);
337 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
343 cbip_fill_input (SCM port
)
344 #define FUNC_NAME "cbip_fill_input"
347 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
350 if (c_port
->read_pos
>= c_port
->read_end
)
352 /* Invoke the user's `read!' procedure. */
353 size_t c_octets
, c_requested
;
354 SCM bv
, read_proc
, octets
;
356 c_requested
= c_port
->read_buf_size
;
358 /* Use the bytevector associated with PORT as the buffer passed to the
359 `read!' procedure, thereby avoiding additional allocations. */
360 bv
= SCM_CBIP_BYTEVECTOR (port
);
361 read_proc
= SCM_CBIP_READ_PROC (port
);
363 /* The assumption here is that C_PORT's internal buffer wasn't changed
365 assert (c_port
->read_buf
==
366 (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
));
367 assert ((unsigned) c_port
->read_buf_size
368 == SCM_BYTEVECTOR_LENGTH (bv
));
370 octets
= scm_call_3 (read_proc
, bv
, SCM_INUM0
,
371 scm_from_size_t (c_requested
));
372 c_octets
= scm_to_size_t (octets
);
373 if (SCM_UNLIKELY (c_octets
> c_requested
))
374 scm_out_of_range (FUNC_NAME
, octets
);
376 c_port
->read_pos
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
377 c_port
->read_end
= (unsigned char *) c_port
->read_pos
+ c_octets
;
385 result
= (int) *c_port
->read_pos
;
392 SCM_DEFINE (scm_make_custom_binary_input_port
,
393 "make-custom-binary-input-port", 5, 0, 0,
394 (SCM id
, SCM read_proc
, SCM get_position_proc
,
395 SCM set_position_proc
, SCM close_proc
),
396 "Return a new custom binary input port whose input is drained "
397 "by invoking @var{read_proc} and passing it a bytevector, an "
398 "index where octets should be written, and an octet count.")
399 #define FUNC_NAME s_scm_make_custom_binary_input_port
401 SCM_VALIDATE_STRING (1, id
);
402 SCM_VALIDATE_PROC (2, read_proc
);
404 if (!scm_is_false (get_position_proc
))
405 SCM_VALIDATE_PROC (3, get_position_proc
);
407 if (!scm_is_false (set_position_proc
))
408 SCM_VALIDATE_PROC (4, set_position_proc
);
410 if (!scm_is_false (close_proc
))
411 SCM_VALIDATE_PROC (5, close_proc
);
413 return (make_cbip (read_proc
, get_position_proc
, set_position_proc
,
419 /* Instantiate the custom binary input port type. */
421 initialize_custom_binary_input_ports (void)
423 custom_binary_input_port_type
=
424 scm_make_port_type ("r6rs-custom-binary-input-port",
425 cbip_fill_input
, NULL
);
427 scm_set_port_seek (custom_binary_input_port_type
, cbp_seek
);
428 scm_set_port_close (custom_binary_input_port_type
, cbp_close
);
435 /* We currently don't support specific binary input ports. */
436 #define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
438 SCM_DEFINE (scm_get_u8
, "get-u8", 1, 0, 0,
440 "Read an octet from @var{port}, a binary input port, "
441 "blocking as necessary.")
442 #define FUNC_NAME s_scm_get_u8
447 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
449 c_result
= scm_get_byte_or_eof (port
);
451 result
= SCM_EOF_VAL
;
453 result
= SCM_I_MAKINUM ((unsigned char) c_result
);
459 SCM_DEFINE (scm_lookahead_u8
, "lookahead-u8", 1, 0, 0,
461 "Like @code{get-u8} but does not update @var{port} to "
462 "point past the octet.")
463 #define FUNC_NAME s_scm_lookahead_u8
468 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
470 u8
= scm_peek_byte_or_eof (port
);
472 result
= SCM_EOF_VAL
;
474 result
= SCM_I_MAKINUM ((scm_t_uint8
) u8
);
480 SCM_DEFINE (scm_get_bytevector_n
, "get-bytevector-n", 2, 0, 0,
481 (SCM port
, SCM count
),
482 "Read @var{count} octets from @var{port}, blocking as "
483 "necessary and return a bytevector containing the octets "
484 "read. If fewer bytes are available, a bytevector smaller "
485 "than @var{count} is returned.")
486 #define FUNC_NAME s_scm_get_bytevector_n
493 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
494 c_count
= scm_to_uint (count
);
496 result
= scm_c_make_bytevector (c_count
);
497 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (result
);
499 if (SCM_LIKELY (c_count
> 0))
500 /* XXX: `scm_c_read ()' does not update the port position. */
501 c_read
= scm_c_read (port
, c_bv
, c_count
);
503 /* Don't invoke `scm_c_read ()' since it may block. */
506 if (c_read
< c_count
)
509 result
= SCM_EOF_VAL
;
511 result
= scm_c_shrink_bytevector (result
, c_read
);
518 SCM_DEFINE (scm_get_bytevector_n_x
, "get-bytevector-n!", 4, 0, 0,
519 (SCM port
, SCM bv
, SCM start
, SCM count
),
520 "Read @var{count} bytes from @var{port} and store them "
521 "in @var{bv} starting at index @var{start}. Return either "
522 "the number of bytes actually read or the end-of-file "
524 #define FUNC_NAME s_scm_get_bytevector_n_x
528 unsigned c_start
, c_count
, c_len
;
531 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
532 SCM_VALIDATE_BYTEVECTOR (2, bv
);
533 c_start
= scm_to_uint (start
);
534 c_count
= scm_to_uint (count
);
536 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
537 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
539 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
540 scm_out_of_range (FUNC_NAME
, count
);
542 if (SCM_LIKELY (c_count
> 0))
543 c_read
= scm_c_read (port
, c_bv
+ c_start
, c_count
);
545 /* Don't invoke `scm_c_read ()' since it may block. */
548 if (c_read
== 0 && c_count
> 0)
549 result
= SCM_EOF_VAL
;
551 result
= scm_from_size_t (c_read
);
558 SCM_DEFINE (scm_get_bytevector_some
, "get-bytevector-some", 1, 0, 0,
560 "Read from @var{port}, blocking as necessary, until bytes "
561 "are available or an end-of-file is reached. Return either "
562 "the end-of-file object or a new bytevector containing some "
563 "of the available bytes (at least one), and update the port "
564 "position to point just past these bytes.")
565 #define FUNC_NAME s_scm_get_bytevector_some
571 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
572 pt
= SCM_PTAB_ENTRY (port
);
574 if (pt
->rw_active
== SCM_PORT_WRITE
)
575 scm_ptobs
[SCM_PTOBNUM (port
)].flush (port
);
578 pt
->rw_active
= SCM_PORT_READ
;
580 if (pt
->read_pos
>= pt
->read_end
)
582 if (scm_fill_input (port
) == EOF
)
586 size
= pt
->read_end
- pt
->read_pos
;
587 if (pt
->read_buf
== pt
->putback_buf
)
588 size
+= pt
->saved_read_end
- pt
->saved_read_pos
;
590 bv
= scm_c_make_bytevector (size
);
591 scm_take_from_input_buffers
592 (port
, (char *) SCM_BYTEVECTOR_CONTENTS (bv
), size
);
598 SCM_DEFINE (scm_get_bytevector_all
, "get-bytevector-all", 1, 0, 0,
600 "Read from @var{port}, blocking as necessary, until "
601 "the end-of-file is reached. Return either "
602 "a new bytevector containing the data read or the "
603 "end-of-file object (if no data were available).")
604 #define FUNC_NAME s_scm_get_bytevector_all
608 unsigned c_len
, c_count
;
609 size_t c_read
, c_total
;
611 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
613 c_len
= c_count
= 4096;
614 c_bv
= (char *) scm_gc_malloc_pointerless (c_len
, SCM_GC_BYTEVECTOR
);
615 c_total
= c_read
= 0;
619 if (c_total
+ c_read
> c_len
)
621 /* Grow the bytevector. */
622 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_len
* 2,
628 /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
630 c_read
= scm_c_read (port
, c_bv
+ c_total
, c_count
);
631 c_total
+= c_read
, c_count
-= c_read
;
633 while (c_count
== 0);
637 result
= SCM_EOF_VAL
;
638 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
644 /* Shrink the bytevector. */
645 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_total
,
647 c_len
= (unsigned) c_total
;
650 result
= scm_c_take_gc_bytevector ((signed char *) c_bv
, c_len
);
661 /* We currently don't support specific binary input ports. */
662 #define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
665 SCM_DEFINE (scm_put_u8
, "put-u8", 2, 0, 0,
666 (SCM port
, SCM octet
),
667 "Write @var{octet} to binary port @var{port}.")
668 #define FUNC_NAME s_scm_put_u8
672 SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port
);
673 c_octet
= scm_to_uint8 (octet
);
675 scm_putc ((char) c_octet
, port
);
677 return SCM_UNSPECIFIED
;
681 SCM_DEFINE (scm_put_bytevector
, "put-bytevector", 2, 2, 0,
682 (SCM port
, SCM bv
, SCM start
, SCM count
),
683 "Write the contents of @var{bv} to @var{port}, optionally "
684 "starting at index @var{start} and limiting to @var{count} "
686 #define FUNC_NAME s_scm_put_bytevector
689 unsigned c_start
, c_count
, c_len
;
691 SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port
);
692 SCM_VALIDATE_BYTEVECTOR (2, bv
);
694 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
695 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
697 if (!scm_is_eq (start
, SCM_UNDEFINED
))
699 c_start
= scm_to_uint (start
);
701 if (!scm_is_eq (count
, SCM_UNDEFINED
))
703 c_count
= scm_to_uint (count
);
704 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
705 scm_out_of_range (FUNC_NAME
, count
);
709 if (SCM_UNLIKELY (c_start
>= c_len
))
710 scm_out_of_range (FUNC_NAME
, start
);
712 c_count
= c_len
- c_start
;
716 c_start
= 0, c_count
= c_len
;
718 scm_c_write (port
, c_bv
+ c_start
, c_count
);
720 return SCM_UNSPECIFIED
;
724 SCM_DEFINE (scm_unget_bytevector
, "unget-bytevector", 2, 2, 0,
725 (SCM port
, SCM bv
, SCM start
, SCM count
),
726 "Unget the contents of @var{bv} to @var{port}, optionally "
727 "starting at index @var{start} and limiting to @var{count} "
729 #define FUNC_NAME s_scm_unget_bytevector
732 size_t c_start
, c_count
, c_len
;
734 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
735 SCM_VALIDATE_BYTEVECTOR (2, bv
);
737 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
738 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
740 if (!scm_is_eq (start
, SCM_UNDEFINED
))
742 c_start
= scm_to_size_t (start
);
744 if (!scm_is_eq (count
, SCM_UNDEFINED
))
746 c_count
= scm_to_size_t (count
);
747 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
748 scm_out_of_range (FUNC_NAME
, count
);
752 if (SCM_UNLIKELY (c_start
>= c_len
))
753 scm_out_of_range (FUNC_NAME
, start
);
755 c_count
= c_len
- c_start
;
759 c_start
= 0, c_count
= c_len
;
761 scm_unget_bytes (c_bv
+ c_start
, c_count
, port
);
763 return SCM_UNSPECIFIED
;
769 /* Bytevector output port ("bop" for short). */
771 /* Implementation of "bops".
773 Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
774 it. The procedure returned along with the output port is actually an
775 applicable SMOB. The SMOB holds a reference to the port. When applied,
776 the SMOB swallows the port's internal buffer, turning it into a
777 bytevector, and resets it.
779 XXX: Access to a bop's internal buffer is not thread-safe. */
781 static scm_t_bits bytevector_output_port_type
= 0;
783 SCM_SMOB (bytevector_output_port_procedure
,
784 "r6rs-bytevector-output-port-procedure",
787 #define SCM_GC_BOP "r6rs-bytevector-output-port"
788 #define SCM_BOP_BUFFER_INITIAL_SIZE 4096
790 /* Representation of a bop's internal buffer. */
800 /* Accessing a bop's buffer. */
801 #define SCM_BOP_BUFFER(_port) \
802 ((scm_t_bop_buffer *) SCM_STREAM (_port))
803 #define SCM_SET_BOP_BUFFER(_port, _buf) \
804 (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
808 bop_buffer_init (scm_t_bop_buffer
*buf
)
810 buf
->total_len
= buf
->len
= buf
->pos
= 0;
815 bop_buffer_grow (scm_t_bop_buffer
*buf
, size_t min_size
)
820 for (new_size
= buf
->total_len
821 ? buf
->total_len
: SCM_BOP_BUFFER_INITIAL_SIZE
;
826 new_buf
= scm_gc_realloc ((void *) buf
->buffer
, buf
->total_len
,
827 new_size
, SCM_GC_BOP
);
829 new_buf
= scm_gc_malloc_pointerless (new_size
, SCM_GC_BOP
);
831 buf
->buffer
= new_buf
;
832 buf
->total_len
= new_size
;
840 scm_t_bop_buffer
*buf
;
841 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
843 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
845 port
= scm_new_port_table_entry (bytevector_output_port_type
);
846 c_port
= SCM_PTAB_ENTRY (port
);
848 /* Match the expectation of `binary-port?'. */
849 c_port
->encoding
= NULL
;
851 buf
= (scm_t_bop_buffer
*) scm_gc_malloc (sizeof (* buf
), SCM_GC_BOP
);
852 bop_buffer_init (buf
);
854 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
855 c_port
->write_buf_size
= 0;
857 SCM_SET_BOP_BUFFER (port
, buf
);
859 /* Mark PORT as open and writable. */
860 SCM_SET_CELL_TYPE (port
, bytevector_output_port_type
| mode_bits
);
862 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
864 /* Make the bop procedure. */
865 SCM_NEWSMOB (bop_proc
, bytevector_output_port_procedure
, buf
);
867 return (scm_values (scm_list_2 (port
, bop_proc
)));
870 /* Write SIZE octets from DATA to PORT. */
872 bop_write (SCM port
, const void *data
, size_t size
)
874 scm_t_bop_buffer
*buf
;
876 buf
= SCM_BOP_BUFFER (port
);
878 if (buf
->pos
+ size
> buf
->total_len
)
879 bop_buffer_grow (buf
, buf
->pos
+ size
);
881 memcpy (buf
->buffer
+ buf
->pos
, data
, size
);
883 buf
->len
= (buf
->len
> buf
->pos
) ? buf
->len
: buf
->pos
;
887 bop_seek (SCM port
, scm_t_off offset
, int whence
)
888 #define FUNC_NAME "bop_seek"
890 scm_t_bop_buffer
*buf
;
892 buf
= SCM_BOP_BUFFER (port
);
896 offset
+= (scm_t_off
) buf
->pos
;
900 if (offset
< 0 || (unsigned) offset
> buf
->len
)
901 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
907 if (offset
< 0 || (unsigned) offset
>= buf
->len
)
908 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
910 buf
->pos
= buf
->len
- (offset
+ 1);
914 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
915 "invalid `seek' parameter");
922 /* Fetch data from a bop. */
923 SCM_SMOB_APPLY (bytevector_output_port_procedure
,
924 bop_proc_apply
, 0, 0, 0, (SCM bop_proc
))
927 scm_t_bop_buffer
*buf
, result_buf
;
929 buf
= (scm_t_bop_buffer
*) SCM_SMOB_DATA (bop_proc
);
932 bop_buffer_init (buf
);
934 if (result_buf
.len
== 0)
935 bv
= scm_c_take_gc_bytevector (NULL
, 0);
938 if (result_buf
.total_len
> result_buf
.len
)
939 /* Shrink the buffer. */
940 result_buf
.buffer
= scm_gc_realloc ((void *) result_buf
.buffer
,
941 result_buf
.total_len
,
945 bv
= scm_c_take_gc_bytevector ((signed char *) result_buf
.buffer
,
952 SCM_DEFINE (scm_open_bytevector_output_port
,
953 "open-bytevector-output-port", 0, 1, 0,
955 "Return two values: an output port and a procedure. The latter "
956 "should be called with zero arguments to obtain a bytevector "
957 "containing the data accumulated by the port.")
958 #define FUNC_NAME s_scm_open_bytevector_output_port
960 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
961 transcoders_not_implemented ();
963 return (make_bop ());
968 initialize_bytevector_output_ports (void)
970 bytevector_output_port_type
=
971 scm_make_port_type ("r6rs-bytevector-output-port",
974 scm_set_port_seek (bytevector_output_port_type
, bop_seek
);
978 /* Custom binary output port ("cbop" for short). */
980 static scm_t_bits custom_binary_output_port_type
;
982 /* Return the various procedures of PORT. */
983 #define SCM_CBOP_WRITE_PROC(_port) \
984 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
988 make_cbop (SCM write_proc
, SCM get_position_proc
,
989 SCM set_position_proc
, SCM close_proc
)
991 SCM port
, method_vector
;
993 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
995 /* Store the various methods and bytevector in a vector. */
996 method_vector
= scm_c_make_vector (4, SCM_BOOL_F
);
997 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, write_proc
);
998 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
999 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
1000 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
1002 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
1004 port
= scm_new_port_table_entry (custom_binary_output_port_type
);
1005 c_port
= SCM_PTAB_ENTRY (port
);
1007 /* Match the expectation of `binary-port?'. */
1008 c_port
->encoding
= NULL
;
1010 /* Attach it the method vector. */
1011 SCM_SETSTREAM (port
, SCM_UNPACK (method_vector
));
1013 /* Have the port directly access the buffer (bytevector). */
1014 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
1015 c_port
->write_buf_size
= c_port
->read_buf_size
= 0;
1017 /* Mark PORT as open, writable and unbuffered. */
1018 SCM_SET_CELL_TYPE (port
, custom_binary_output_port_type
| mode_bits
);
1020 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
1025 /* Write SIZE octets from DATA to PORT. */
1027 cbop_write (SCM port
, const void *data
, size_t size
)
1028 #define FUNC_NAME "cbop_write"
1032 SCM bv
, write_proc
, result
;
1034 /* XXX: Allocating a new bytevector at each `write' call is inefficient,
1035 but necessary since (1) we don't control the lifetime of the buffer
1036 pointed to by DATA, and (2) the `write!' procedure could capture the
1037 bytevector it is passed. */
1038 bv
= scm_c_make_bytevector (size
);
1039 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), data
, size
);
1041 write_proc
= SCM_CBOP_WRITE_PROC (port
);
1043 /* Since the `write' procedure of Guile's ports has type `void', it must
1044 try hard to write exactly SIZE bytes, regardless of how many bytes the
1048 c_written
+= c_result
)
1050 result
= scm_call_3 (write_proc
, bv
,
1051 scm_from_size_t (c_written
),
1052 scm_from_size_t (size
- c_written
));
1054 c_result
= scm_to_long (result
);
1055 if (SCM_UNLIKELY (c_result
< 0
1056 || (size_t) c_result
> (size
- c_written
)))
1057 scm_wrong_type_arg_msg (FUNC_NAME
, 0, result
,
1058 "R6RS custom binary output port `write!' "
1059 "returned a incorrect integer");
1065 SCM_DEFINE (scm_make_custom_binary_output_port
,
1066 "make-custom-binary-output-port", 5, 0, 0,
1067 (SCM id
, SCM write_proc
, SCM get_position_proc
,
1068 SCM set_position_proc
, SCM close_proc
),
1069 "Return a new custom binary output port whose output is drained "
1070 "by invoking @var{write_proc} and passing it a bytevector, an "
1071 "index where octets should be written, and an octet count.")
1072 #define FUNC_NAME s_scm_make_custom_binary_output_port
1074 SCM_VALIDATE_STRING (1, id
);
1075 SCM_VALIDATE_PROC (2, write_proc
);
1077 if (!scm_is_false (get_position_proc
))
1078 SCM_VALIDATE_PROC (3, get_position_proc
);
1080 if (!scm_is_false (set_position_proc
))
1081 SCM_VALIDATE_PROC (4, set_position_proc
);
1083 if (!scm_is_false (close_proc
))
1084 SCM_VALIDATE_PROC (5, close_proc
);
1086 return (make_cbop (write_proc
, get_position_proc
, set_position_proc
,
1092 /* Instantiate the custom binary output port type. */
1094 initialize_custom_binary_output_ports (void)
1096 custom_binary_output_port_type
=
1097 scm_make_port_type ("r6rs-custom-binary-output-port",
1100 scm_set_port_seek (custom_binary_output_port_type
, cbp_seek
);
1101 scm_set_port_close (custom_binary_output_port_type
, cbp_close
);
1105 /* Transcoded ports ("tp" for short). */
1106 static scm_t_bits transcoded_port_type
= 0;
1108 #define TP_INPUT_BUFFER_SIZE 4096
1110 #define SCM_TP_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port))
1113 make_tp (SCM binary_port
, unsigned long mode
)
1117 const unsigned long mode_bits
= SCM_OPN
| mode
;
1119 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
1121 port
= scm_new_port_table_entry (transcoded_port_type
);
1123 SCM_SETSTREAM (port
, SCM_UNPACK (binary_port
));
1125 SCM_SET_CELL_TYPE (port
, transcoded_port_type
| mode_bits
);
1127 if (SCM_INPUT_PORT_P (port
))
1129 c_port
= SCM_PTAB_ENTRY (port
);
1130 c_port
->read_buf
= scm_gc_malloc_pointerless (TP_INPUT_BUFFER_SIZE
,
1132 c_port
->read_pos
= c_port
->read_end
= c_port
->read_buf
;
1133 c_port
->read_buf_size
= TP_INPUT_BUFFER_SIZE
;
1135 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
1138 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
1144 tp_write (SCM port
, const void *data
, size_t size
)
1146 scm_c_write (SCM_TP_BINARY_PORT (port
), data
, size
);
1150 tp_fill_input (SCM port
)
1153 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
1154 SCM bport
= SCM_TP_BINARY_PORT (port
);
1155 scm_t_port
*c_bport
= SCM_PTAB_ENTRY (bport
);
1157 /* We can't use `scm_c_read' here, since it blocks until the whole
1158 block has been read or EOF. */
1160 if (c_bport
->rw_active
== SCM_PORT_WRITE
)
1161 scm_force_output (bport
);
1163 if (c_bport
->read_pos
>= c_bport
->read_end
)
1164 scm_fill_input (bport
);
1166 count
= c_bport
->read_end
- c_bport
->read_pos
;
1167 if (count
> c_port
->read_buf_size
)
1168 count
= c_port
->read_buf_size
;
1170 memcpy (c_port
->read_buf
, c_bport
->read_pos
, count
);
1171 c_bport
->read_pos
+= count
;
1173 if (c_bport
->rw_random
)
1174 c_bport
->rw_active
= SCM_PORT_READ
;
1180 c_port
->read_pos
= c_port
->read_buf
;
1181 c_port
->read_end
= c_port
->read_buf
+ count
;
1182 return *c_port
->read_buf
;
1189 SCM binary_port
= SCM_TP_BINARY_PORT (port
);
1190 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
1191 size_t count
= c_port
->write_pos
- c_port
->write_buf
;
1193 /* As the runtime will try to flush all ports upon exit, we test for
1194 the underlying port still being open here. Otherwise, when you
1195 would explicitly close the underlying port and the transcoded port
1196 still had data outstanding, you'd get an exception on Guile exit.
1198 We just throw away the data when the underlying port is closed. */
1200 if (SCM_OPOUTPORTP (binary_port
))
1201 scm_c_write (binary_port
, c_port
->write_buf
, count
);
1203 c_port
->write_pos
= c_port
->write_buf
;
1204 c_port
->rw_active
= SCM_PORT_NEITHER
;
1206 if (SCM_OPOUTPORTP (binary_port
))
1207 scm_force_output (binary_port
);
1213 if (SCM_OUTPUT_PORT_P (port
))
1215 return scm_is_true (scm_close_port (SCM_TP_BINARY_PORT (port
))) ? 0 : -1;
1219 initialize_transcoded_ports (void)
1221 transcoded_port_type
=
1222 scm_make_port_type ("r6rs-transcoded-port", tp_fill_input
, tp_write
);
1224 scm_set_port_flush (transcoded_port_type
, tp_flush
);
1225 scm_set_port_close (transcoded_port_type
, tp_close
);
1228 SCM_DEFINE (scm_i_make_transcoded_port
,
1229 "%make-transcoded-port", 1, 0, 0,
1231 "Return a new port which reads and writes to @var{port}")
1232 #define FUNC_NAME s_scm_i_make_transcoded_port
1235 unsigned long mode
= 0;
1237 SCM_VALIDATE_PORT (SCM_ARG1
, port
);
1239 if (scm_is_true (scm_output_port_p (port
)))
1241 else if (scm_is_true (scm_input_port_p (port
)))
1244 result
= make_tp (port
, mode
);
1246 /* FIXME: We should actually close `port' "in a special way" here,
1247 according to R6RS. As there is no way to do that in Guile without
1248 rendering the underlying port unusable for our purposes as well, we
1249 just leave it open. */
1258 SCM_DEFINE (scm_get_string_n_x
,
1259 "get-string-n!", 4, 0, 0,
1260 (SCM port
, SCM str
, SCM start
, SCM count
),
1261 "Read up to @var{count} characters from @var{port} into "
1262 "@var{str}, starting at @var{start}. If no characters "
1263 "can be read before the end of file is encountered, the end "
1264 "of file object is returned. Otherwise, the number of "
1265 "characters read is returned.")
1266 #define FUNC_NAME s_scm_get_string_n_x
1268 size_t c_start
, c_count
, c_len
, c_end
, j
;
1271 SCM_VALIDATE_OPINPORT (1, port
);
1272 SCM_VALIDATE_STRING (2, str
);
1273 c_len
= scm_c_string_length (str
);
1274 c_start
= scm_to_size_t (start
);
1275 c_count
= scm_to_size_t (count
);
1276 c_end
= c_start
+ c_count
;
1278 if (SCM_UNLIKELY (c_end
> c_len
))
1279 scm_out_of_range (FUNC_NAME
, count
);
1281 for (j
= c_start
; j
< c_end
; j
++)
1283 c
= scm_getc (port
);
1286 size_t chars_read
= j
- c_start
;
1287 return chars_read
== 0 ? SCM_EOF_VAL
: scm_from_size_t (chars_read
);
1289 scm_c_string_set_x (str
, j
, SCM_MAKE_CHAR (c
));
1296 /* Initialization. */
1299 scm_register_r6rs_ports (void)
1301 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1302 "scm_init_r6rs_ports",
1303 (scm_t_extension_init_func
) scm_init_r6rs_ports
,
1308 scm_init_r6rs_ports (void)
1310 #include "libguile/r6rs-ports.x"
1312 initialize_bytevector_input_ports ();
1313 initialize_custom_binary_input_ports ();
1314 initialize_bytevector_output_ports ();
1315 initialize_custom_binary_output_ports ();
1316 initialize_transcoded_ports ();