1 /* Copyright (C) 2009, 2010 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
);
91 /* Prevent BV from being GC'd. */
92 SCM_SETSTREAM (port
, SCM_UNPACK (bv
));
94 /* Have the port directly access the bytevector. */
95 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
96 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
98 c_port
= SCM_PTAB_ENTRY (port
);
99 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
100 c_port
->read_end
= (unsigned char *) c_bv
+ c_len
;
101 c_port
->read_buf_size
= c_len
;
103 /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
104 SCM_SET_CELL_TYPE (port
, bytevector_input_port_type
| mode_bits
);
106 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
112 bip_fill_input (SCM port
)
115 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
117 if (c_port
->read_pos
>= c_port
->read_end
)
120 result
= (int) *c_port
->read_pos
;
126 bip_seek (SCM port
, scm_t_off offset
, int whence
)
127 #define FUNC_NAME "bip_seek"
129 scm_t_off c_result
= 0;
130 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
135 offset
+= c_port
->read_pos
- c_port
->read_buf
;
139 if (c_port
->read_buf
+ offset
< c_port
->read_end
)
141 c_port
->read_pos
= c_port
->read_buf
+ offset
;
145 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
149 if (c_port
->read_end
- offset
>= c_port
->read_buf
)
151 c_port
->read_pos
= c_port
->read_end
- offset
;
152 c_result
= c_port
->read_pos
- c_port
->read_buf
;
155 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
159 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
160 "invalid `seek' parameter");
168 /* Instantiate the bytevector input port type. */
170 initialize_bytevector_input_ports (void)
172 bytevector_input_port_type
=
173 scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input
,
176 scm_set_port_seek (bytevector_input_port_type
, bip_seek
);
180 SCM_DEFINE (scm_open_bytevector_input_port
,
181 "open-bytevector-input-port", 1, 1, 0,
182 (SCM bv
, SCM transcoder
),
183 "Return an input port whose contents are drawn from "
184 "bytevector @var{bv}.")
185 #define FUNC_NAME s_scm_open_bytevector_input_port
187 SCM_VALIDATE_BYTEVECTOR (1, bv
);
188 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
189 transcoders_not_implemented ();
191 return (make_bip (bv
));
196 /* Custom binary ports. The following routines are shared by input and
197 output custom binary ports. */
199 #define SCM_CBP_GET_POSITION_PROC(_port) \
200 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
201 #define SCM_CBP_SET_POSITION_PROC(_port) \
202 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
203 #define SCM_CBP_CLOSE_PROC(_port) \
204 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
207 cbp_seek (SCM port
, scm_t_off offset
, int whence
)
208 #define FUNC_NAME "cbp_seek"
211 scm_t_off c_result
= 0;
217 SCM get_position_proc
;
219 get_position_proc
= SCM_CBP_GET_POSITION_PROC (port
);
220 if (SCM_LIKELY (scm_is_true (get_position_proc
)))
221 result
= scm_call_0 (get_position_proc
);
223 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
224 "R6RS custom binary port does not "
225 "support `port-position'");
227 offset
+= scm_to_int (result
);
233 SCM set_position_proc
;
235 set_position_proc
= SCM_CBP_SET_POSITION_PROC (port
);
236 if (SCM_LIKELY (scm_is_true (set_position_proc
)))
237 result
= scm_call_1 (set_position_proc
, scm_from_int (offset
));
239 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
240 "R6RS custom binary port does not "
241 "support `set-port-position!'");
243 /* Assuming setting the position succeeded. */
249 /* `SEEK_END' cannot be supported. */
250 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
251 "R6RS custom binary ports do not "
252 "support `SEEK_END'");
264 close_proc
= SCM_CBP_CLOSE_PROC (port
);
265 if (scm_is_true (close_proc
))
266 /* Invoke the `close' thunk. */
267 scm_call_0 (close_proc
);
273 /* Custom binary input port ("cbip" for short). */
275 static scm_t_bits custom_binary_input_port_type
= 0;
277 /* Size of the buffer embedded in custom binary input ports. */
278 #define CBIP_BUFFER_SIZE 4096
280 /* Return the bytevector associated with PORT. */
281 #define SCM_CBIP_BYTEVECTOR(_port) \
282 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
284 /* Return the various procedures of PORT. */
285 #define SCM_CBIP_READ_PROC(_port) \
286 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
290 make_cbip (SCM read_proc
, SCM get_position_proc
,
291 SCM set_position_proc
, SCM close_proc
)
293 SCM port
, bv
, method_vector
;
297 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
;
299 /* Use a bytevector as the underlying buffer. */
300 c_len
= CBIP_BUFFER_SIZE
;
301 bv
= scm_c_make_bytevector (c_len
);
302 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
304 /* Store the various methods and bytevector in a vector. */
305 method_vector
= scm_c_make_vector (5, SCM_BOOL_F
);
306 SCM_SIMPLE_VECTOR_SET (method_vector
, 4, bv
);
307 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, read_proc
);
308 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
309 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
310 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
312 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
314 port
= scm_new_port_table_entry (custom_binary_input_port_type
);
316 /* Attach it the method vector. */
317 SCM_SETSTREAM (port
, SCM_UNPACK (method_vector
));
319 /* Have the port directly access the buffer (bytevector). */
320 c_port
= SCM_PTAB_ENTRY (port
);
321 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
322 c_port
->read_end
= (unsigned char *) c_bv
;
323 c_port
->read_buf_size
= c_len
;
325 /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
326 SCM_SET_CELL_TYPE (port
, custom_binary_input_port_type
| mode_bits
);
328 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
334 cbip_fill_input (SCM port
)
335 #define FUNC_NAME "cbip_fill_input"
338 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
341 if (c_port
->read_pos
>= c_port
->read_end
)
343 /* Invoke the user's `read!' procedure. */
345 SCM bv
, read_proc
, octets
;
347 /* Use the bytevector associated with PORT as the buffer passed to the
348 `read!' procedure, thereby avoiding additional allocations. */
349 bv
= SCM_CBIP_BYTEVECTOR (port
);
350 read_proc
= SCM_CBIP_READ_PROC (port
);
352 /* The assumption here is that C_PORT's internal buffer wasn't changed
354 assert (c_port
->read_buf
==
355 (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
));
356 assert ((unsigned) c_port
->read_buf_size
357 == SCM_BYTEVECTOR_LENGTH (bv
));
359 octets
= scm_call_3 (read_proc
, bv
, SCM_INUM0
,
360 SCM_I_MAKINUM (CBIP_BUFFER_SIZE
));
361 c_octets
= scm_to_uint (octets
);
363 c_port
->read_pos
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
364 c_port
->read_end
= (unsigned char *) c_port
->read_pos
+ c_octets
;
372 result
= (int) *c_port
->read_pos
;
379 SCM_DEFINE (scm_make_custom_binary_input_port
,
380 "make-custom-binary-input-port", 5, 0, 0,
381 (SCM id
, SCM read_proc
, SCM get_position_proc
,
382 SCM set_position_proc
, SCM close_proc
),
383 "Return a new custom binary input port whose input is drained "
384 "by invoking @var{read_proc} and passing it a bytevector, an "
385 "index where octets should be written, and an octet count.")
386 #define FUNC_NAME s_scm_make_custom_binary_input_port
388 SCM_VALIDATE_STRING (1, id
);
389 SCM_VALIDATE_PROC (2, read_proc
);
391 if (!scm_is_false (get_position_proc
))
392 SCM_VALIDATE_PROC (3, get_position_proc
);
394 if (!scm_is_false (set_position_proc
))
395 SCM_VALIDATE_PROC (4, set_position_proc
);
397 if (!scm_is_false (close_proc
))
398 SCM_VALIDATE_PROC (5, close_proc
);
400 return (make_cbip (read_proc
, get_position_proc
, set_position_proc
,
406 /* Instantiate the custom binary input port type. */
408 initialize_custom_binary_input_ports (void)
410 custom_binary_input_port_type
=
411 scm_make_port_type ("r6rs-custom-binary-input-port",
412 cbip_fill_input
, NULL
);
414 scm_set_port_seek (custom_binary_input_port_type
, cbp_seek
);
415 scm_set_port_close (custom_binary_input_port_type
, cbp_close
);
422 /* We currently don't support specific binary input ports. */
423 #define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
425 SCM_DEFINE (scm_get_u8
, "get-u8", 1, 0, 0,
427 "Read an octet from @var{port}, a binary input port, "
428 "blocking as necessary.")
429 #define FUNC_NAME s_scm_get_u8
434 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
436 c_result
= scm_get_byte_or_eof (port
);
438 result
= SCM_EOF_VAL
;
440 result
= SCM_I_MAKINUM ((unsigned char) c_result
);
446 SCM_DEFINE (scm_lookahead_u8
, "lookahead-u8", 1, 0, 0,
448 "Like @code{get-u8} but does not update @var{port} to "
449 "point past the octet.")
450 #define FUNC_NAME s_scm_lookahead_u8
455 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
457 u8
= scm_get_byte_or_eof (port
);
459 result
= SCM_EOF_VAL
;
462 scm_unget_byte (u8
, port
);
463 result
= SCM_I_MAKINUM ((scm_t_uint8
) u8
);
470 SCM_DEFINE (scm_get_bytevector_n
, "get-bytevector-n", 2, 0, 0,
471 (SCM port
, SCM count
),
472 "Read @var{count} octets from @var{port}, blocking as "
473 "necessary and return a bytevector containing the octets "
474 "read. If fewer bytes are available, a bytevector smaller "
475 "than @var{count} is returned.")
476 #define FUNC_NAME s_scm_get_bytevector_n
483 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
484 c_count
= scm_to_uint (count
);
486 result
= scm_c_make_bytevector (c_count
);
487 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (result
);
489 if (SCM_LIKELY (c_count
> 0))
490 /* XXX: `scm_c_read ()' does not update the port position. */
491 c_read
= scm_c_read (port
, c_bv
, c_count
);
493 /* Don't invoke `scm_c_read ()' since it may block. */
496 if ((c_read
== 0) && (c_count
> 0))
498 if (SCM_EOF_OBJECT_P (scm_peek_char (port
)))
499 result
= SCM_EOF_VAL
;
501 result
= scm_null_bytevector
;
505 if (c_read
< c_count
)
506 result
= scm_c_shrink_bytevector (result
, c_read
);
513 SCM_DEFINE (scm_get_bytevector_n_x
, "get-bytevector-n!", 4, 0, 0,
514 (SCM port
, SCM bv
, SCM start
, SCM count
),
515 "Read @var{count} bytes from @var{port} and store them "
516 "in @var{bv} starting at index @var{start}. Return either "
517 "the number of bytes actually read or the end-of-file "
519 #define FUNC_NAME s_scm_get_bytevector_n_x
523 unsigned c_start
, c_count
, c_len
;
526 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
527 SCM_VALIDATE_BYTEVECTOR (2, bv
);
528 c_start
= scm_to_uint (start
);
529 c_count
= scm_to_uint (count
);
531 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
532 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
534 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
535 scm_out_of_range (FUNC_NAME
, count
);
537 if (SCM_LIKELY (c_count
> 0))
538 c_read
= scm_c_read (port
, c_bv
+ c_start
, c_count
);
540 /* Don't invoke `scm_c_read ()' since it may block. */
543 if ((c_read
== 0) && (c_count
> 0))
545 if (SCM_EOF_OBJECT_P (scm_peek_char (port
)))
546 result
= SCM_EOF_VAL
;
548 result
= SCM_I_MAKINUM (0);
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 data "
561 "are available or and end-of-file is reached. Return either "
562 "a new bytevector containing the data read or the "
563 "end-of-file object.")
564 #define FUNC_NAME s_scm_get_bytevector_some
566 /* Read at least one byte, unless the end-of-file is already reached, and
567 read while characters are available (buffered). */
574 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
577 c_bv
= (char *) scm_gc_malloc_pointerless (c_len
, SCM_GC_BYTEVECTOR
);
584 if (c_total
+ 1 > c_len
)
586 /* Grow the bytevector. */
587 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_len
* 2,
592 /* We can't use `scm_c_read ()' since it blocks. */
593 c_chr
= scm_getc (port
);
596 c_bv
[c_total
] = (char) c_chr
;
600 while ((scm_is_true (scm_char_ready_p (port
)))
601 && (!SCM_EOF_OBJECT_P (scm_peek_char (port
))));
605 result
= SCM_EOF_VAL
;
606 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
612 /* Shrink the bytevector. */
613 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_total
,
615 c_len
= (unsigned) c_total
;
618 result
= scm_c_take_bytevector ((signed char *) c_bv
, c_len
);
625 SCM_DEFINE (scm_get_bytevector_all
, "get-bytevector-all", 1, 0, 0,
627 "Read from @var{port}, blocking as necessary, until "
628 "the end-of-file is reached. Return either "
629 "a new bytevector containing the data read or the "
630 "end-of-file object (if no data were available).")
631 #define FUNC_NAME s_scm_get_bytevector_all
635 unsigned c_len
, c_count
;
636 size_t c_read
, c_total
;
638 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
640 c_len
= c_count
= 4096;
641 c_bv
= (char *) scm_gc_malloc_pointerless (c_len
, SCM_GC_BYTEVECTOR
);
642 c_total
= c_read
= 0;
646 if (c_total
+ c_read
> c_len
)
648 /* Grow the bytevector. */
649 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_len
* 2,
655 /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
657 c_read
= scm_c_read (port
, c_bv
+ c_total
, c_count
);
658 c_total
+= c_read
, c_count
-= c_read
;
660 while (!SCM_EOF_OBJECT_P (scm_peek_char (port
)));
664 result
= SCM_EOF_VAL
;
665 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
671 /* Shrink the bytevector. */
672 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_total
,
674 c_len
= (unsigned) c_total
;
677 result
= scm_c_take_bytevector ((signed char *) c_bv
, c_len
);
688 /* We currently don't support specific binary input ports. */
689 #define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
692 SCM_DEFINE (scm_put_u8
, "put-u8", 2, 0, 0,
693 (SCM port
, SCM octet
),
694 "Write @var{octet} to binary port @var{port}.")
695 #define FUNC_NAME s_scm_put_u8
699 SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port
);
700 c_octet
= scm_to_uint8 (octet
);
702 scm_putc ((char) c_octet
, port
);
704 return SCM_UNSPECIFIED
;
708 SCM_DEFINE (scm_put_bytevector
, "put-bytevector", 2, 2, 0,
709 (SCM port
, SCM bv
, SCM start
, SCM count
),
710 "Write the contents of @var{bv} to @var{port}, optionally "
711 "starting at index @var{start} and limiting to @var{count} "
713 #define FUNC_NAME s_scm_put_bytevector
716 unsigned c_start
, c_count
, c_len
;
718 SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port
);
719 SCM_VALIDATE_BYTEVECTOR (2, bv
);
721 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
722 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
724 if (start
!= SCM_UNDEFINED
)
726 c_start
= scm_to_uint (start
);
728 if (count
!= SCM_UNDEFINED
)
730 c_count
= scm_to_uint (count
);
731 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
732 scm_out_of_range (FUNC_NAME
, count
);
736 if (SCM_UNLIKELY (c_start
>= c_len
))
737 scm_out_of_range (FUNC_NAME
, start
);
739 c_count
= c_len
- c_start
;
743 c_start
= 0, c_count
= c_len
;
745 scm_c_write (port
, c_bv
+ c_start
, c_count
);
747 return SCM_UNSPECIFIED
;
753 /* Bytevector output port ("bop" for short). */
755 /* Implementation of "bops".
757 Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
758 it. The procedure returned along with the output port is actually an
759 applicable SMOB. The SMOB holds a reference to the port. When applied,
760 the SMOB swallows the port's internal buffer, turning it into a
761 bytevector, and resets it.
763 XXX: Access to a bop's internal buffer is not thread-safe. */
765 static scm_t_bits bytevector_output_port_type
= 0;
767 SCM_SMOB (bytevector_output_port_procedure
,
768 "r6rs-bytevector-output-port-procedure",
771 #define SCM_GC_BOP "r6rs-bytevector-output-port"
772 #define SCM_BOP_BUFFER_INITIAL_SIZE 4096
774 /* Representation of a bop's internal buffer. */
784 /* Accessing a bop's buffer. */
785 #define SCM_BOP_BUFFER(_port) \
786 ((scm_t_bop_buffer *) SCM_STREAM (_port))
787 #define SCM_SET_BOP_BUFFER(_port, _buf) \
788 (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
792 bop_buffer_init (scm_t_bop_buffer
*buf
)
794 buf
->total_len
= buf
->len
= buf
->pos
= 0;
799 bop_buffer_grow (scm_t_bop_buffer
*buf
, size_t min_size
)
804 for (new_size
= buf
->total_len
805 ? buf
->total_len
: SCM_BOP_BUFFER_INITIAL_SIZE
;
810 new_buf
= scm_gc_realloc ((void *) buf
->buffer
, buf
->total_len
,
811 new_size
, SCM_GC_BOP
);
813 new_buf
= scm_gc_malloc_pointerless (new_size
, SCM_GC_BOP
);
815 buf
->buffer
= new_buf
;
816 buf
->total_len
= new_size
;
824 scm_t_bop_buffer
*buf
;
825 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
827 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
829 port
= scm_new_port_table_entry (bytevector_output_port_type
);
831 buf
= (scm_t_bop_buffer
*) scm_gc_malloc (sizeof (* buf
), SCM_GC_BOP
);
832 bop_buffer_init (buf
);
834 c_port
= SCM_PTAB_ENTRY (port
);
835 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
836 c_port
->write_buf_size
= 0;
838 SCM_SET_BOP_BUFFER (port
, buf
);
840 /* Mark PORT as open and writable. */
841 SCM_SET_CELL_TYPE (port
, bytevector_output_port_type
| mode_bits
);
843 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
845 /* Make the bop procedure. */
846 SCM_NEWSMOB (bop_proc
, bytevector_output_port_procedure
, buf
);
848 return (scm_values (scm_list_2 (port
, bop_proc
)));
851 /* Write SIZE octets from DATA to PORT. */
853 bop_write (SCM port
, const void *data
, size_t size
)
855 scm_t_bop_buffer
*buf
;
857 buf
= SCM_BOP_BUFFER (port
);
859 if (buf
->pos
+ size
> buf
->total_len
)
860 bop_buffer_grow (buf
, buf
->pos
+ size
);
862 memcpy (buf
->buffer
+ buf
->pos
, data
, size
);
864 buf
->len
= (buf
->len
> buf
->pos
) ? buf
->len
: buf
->pos
;
868 bop_seek (SCM port
, scm_t_off offset
, int whence
)
869 #define FUNC_NAME "bop_seek"
871 scm_t_bop_buffer
*buf
;
873 buf
= SCM_BOP_BUFFER (port
);
877 offset
+= (scm_t_off
) buf
->pos
;
881 if (offset
< 0 || (unsigned) offset
> buf
->len
)
882 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
888 if (offset
< 0 || (unsigned) offset
>= buf
->len
)
889 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
891 buf
->pos
= buf
->len
- (offset
+ 1);
895 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
896 "invalid `seek' parameter");
903 /* Fetch data from a bop. */
904 SCM_SMOB_APPLY (bytevector_output_port_procedure
,
905 bop_proc_apply
, 0, 0, 0, (SCM bop_proc
))
908 scm_t_bop_buffer
*buf
, result_buf
;
910 buf
= (scm_t_bop_buffer
*) SCM_SMOB_DATA (bop_proc
);
913 bop_buffer_init (buf
);
915 if (result_buf
.len
== 0)
916 bv
= scm_c_take_bytevector (NULL
, 0);
919 if (result_buf
.total_len
> result_buf
.len
)
920 /* Shrink the buffer. */
921 result_buf
.buffer
= scm_gc_realloc ((void *) result_buf
.buffer
,
922 result_buf
.total_len
,
926 bv
= scm_c_take_bytevector ((signed char *) result_buf
.buffer
,
933 SCM_DEFINE (scm_open_bytevector_output_port
,
934 "open-bytevector-output-port", 0, 1, 0,
936 "Return two values: an output port and a procedure. The latter "
937 "should be called with zero arguments to obtain a bytevector "
938 "containing the data accumulated by the port.")
939 #define FUNC_NAME s_scm_open_bytevector_output_port
941 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
942 transcoders_not_implemented ();
944 return (make_bop ());
949 initialize_bytevector_output_ports (void)
951 bytevector_output_port_type
=
952 scm_make_port_type ("r6rs-bytevector-output-port",
955 scm_set_port_seek (bytevector_output_port_type
, bop_seek
);
959 /* Custom binary output port ("cbop" for short). */
961 static scm_t_bits custom_binary_output_port_type
;
963 /* Return the various procedures of PORT. */
964 #define SCM_CBOP_WRITE_PROC(_port) \
965 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
969 make_cbop (SCM write_proc
, SCM get_position_proc
,
970 SCM set_position_proc
, SCM close_proc
)
972 SCM port
, method_vector
;
974 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
976 /* Store the various methods and bytevector in a vector. */
977 method_vector
= scm_c_make_vector (4, SCM_BOOL_F
);
978 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, write_proc
);
979 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
980 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
981 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
983 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
985 port
= scm_new_port_table_entry (custom_binary_output_port_type
);
987 /* Attach it the method vector. */
988 SCM_SETSTREAM (port
, SCM_UNPACK (method_vector
));
990 /* Have the port directly access the buffer (bytevector). */
991 c_port
= SCM_PTAB_ENTRY (port
);
992 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
993 c_port
->write_buf_size
= c_port
->read_buf_size
= 0;
995 /* Mark PORT as open, writable and unbuffered. */
996 SCM_SET_CELL_TYPE (port
, custom_binary_output_port_type
| mode_bits
);
998 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
1003 /* Write SIZE octets from DATA to PORT. */
1005 cbop_write (SCM port
, const void *data
, size_t size
)
1006 #define FUNC_NAME "cbop_write"
1010 SCM bv
, write_proc
, result
;
1012 /* XXX: Allocating a new bytevector at each `write' call is inefficient,
1013 but necessary since (1) we don't control the lifetime of the buffer
1014 pointed to by DATA, and (2) the `write!' procedure could capture the
1015 bytevector it is passed. */
1016 bv
= scm_c_make_bytevector (size
);
1017 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), data
, size
);
1019 write_proc
= SCM_CBOP_WRITE_PROC (port
);
1021 /* Since the `write' procedure of Guile's ports has type `void', it must
1022 try hard to write exactly SIZE bytes, regardless of how many bytes the
1026 c_written
+= c_result
)
1028 result
= scm_call_3 (write_proc
, bv
,
1029 scm_from_size_t (c_written
),
1030 scm_from_size_t (size
- c_written
));
1032 c_result
= scm_to_long (result
);
1033 if (SCM_UNLIKELY (c_result
< 0
1034 || (size_t) c_result
> (size
- c_written
)))
1035 scm_wrong_type_arg_msg (FUNC_NAME
, 0, result
,
1036 "R6RS custom binary output port `write!' "
1037 "returned a incorrect integer");
1043 SCM_DEFINE (scm_make_custom_binary_output_port
,
1044 "make-custom-binary-output-port", 5, 0, 0,
1045 (SCM id
, SCM write_proc
, SCM get_position_proc
,
1046 SCM set_position_proc
, SCM close_proc
),
1047 "Return a new custom binary output port whose output is drained "
1048 "by invoking @var{write_proc} and passing it a bytevector, an "
1049 "index where octets should be written, and an octet count.")
1050 #define FUNC_NAME s_scm_make_custom_binary_output_port
1052 SCM_VALIDATE_STRING (1, id
);
1053 SCM_VALIDATE_PROC (2, write_proc
);
1055 if (!scm_is_false (get_position_proc
))
1056 SCM_VALIDATE_PROC (3, get_position_proc
);
1058 if (!scm_is_false (set_position_proc
))
1059 SCM_VALIDATE_PROC (4, set_position_proc
);
1061 if (!scm_is_false (close_proc
))
1062 SCM_VALIDATE_PROC (5, close_proc
);
1064 return (make_cbop (write_proc
, get_position_proc
, set_position_proc
,
1070 /* Instantiate the custom binary output port type. */
1072 initialize_custom_binary_output_ports (void)
1074 custom_binary_output_port_type
=
1075 scm_make_port_type ("r6rs-custom-binary-output-port",
1078 scm_set_port_seek (custom_binary_output_port_type
, cbp_seek
);
1079 scm_set_port_close (custom_binary_output_port_type
, cbp_close
);
1083 /* Transcoded ports ("tp" for short). */
1084 static scm_t_bits transcoded_port_type
= 0;
1086 #define TP_INPUT_BUFFER_SIZE 4096
1088 #define SCM_TP_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port))
1091 make_tp (SCM binary_port
, unsigned long mode
)
1095 const unsigned long mode_bits
= SCM_OPN
| mode
;
1097 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
1099 port
= scm_new_port_table_entry (transcoded_port_type
);
1101 SCM_SETSTREAM (port
, SCM_UNPACK (binary_port
));
1103 SCM_SET_CELL_TYPE (port
, transcoded_port_type
| mode_bits
);
1105 if (SCM_INPUT_PORT_P (port
))
1107 c_port
= SCM_PTAB_ENTRY (port
);
1108 c_port
->read_buf
= scm_gc_malloc_pointerless (TP_INPUT_BUFFER_SIZE
,
1110 c_port
->read_pos
= c_port
->read_end
= c_port
->read_buf
;
1111 c_port
->read_buf_size
= TP_INPUT_BUFFER_SIZE
;
1113 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
1116 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
1122 tp_write (SCM port
, const void *data
, size_t size
)
1124 scm_c_write (SCM_TP_BINARY_PORT (port
), data
, size
);
1128 tp_fill_input (SCM port
)
1131 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
1132 SCM bport
= SCM_TP_BINARY_PORT (port
);
1133 scm_t_port
*c_bport
= SCM_PTAB_ENTRY (bport
);
1135 /* We can't use `scm_c_read' here, since it blocks until the whole
1136 block has been read or EOF. */
1138 if (c_bport
->rw_active
== SCM_PORT_WRITE
)
1139 scm_force_output (bport
);
1141 if (c_bport
->read_pos
>= c_bport
->read_end
)
1142 scm_fill_input (bport
);
1144 count
= c_bport
->read_end
- c_bport
->read_pos
;
1145 if (count
> c_port
->read_buf_size
)
1146 count
= c_port
->read_buf_size
;
1148 memcpy (c_port
->read_buf
, c_bport
->read_pos
, count
);
1149 c_bport
->read_pos
+= count
;
1151 if (c_bport
->rw_random
)
1152 c_bport
->rw_active
= SCM_PORT_READ
;
1158 c_port
->read_pos
= c_port
->read_buf
;
1159 c_port
->read_end
= c_port
->read_buf
+ count
;
1160 return *c_port
->read_buf
;
1167 SCM binary_port
= SCM_TP_BINARY_PORT (port
);
1168 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
1169 size_t count
= c_port
->write_pos
- c_port
->write_buf
;
1171 scm_c_write (binary_port
, c_port
->write_buf
, count
);
1173 c_port
->write_pos
= c_port
->write_buf
;
1174 c_port
->rw_active
= SCM_PORT_NEITHER
;
1176 scm_force_output (binary_port
);
1182 if (SCM_OUTPUT_PORT_P (port
))
1184 return scm_is_true (scm_close_port (SCM_TP_BINARY_PORT (port
))) ? 0 : -1;
1188 initialize_transcoded_ports (void)
1190 transcoded_port_type
=
1191 scm_make_port_type ("r6rs-transcoded-port", tp_fill_input
, tp_write
);
1193 scm_set_port_flush (transcoded_port_type
, tp_flush
);
1194 scm_set_port_close (transcoded_port_type
, tp_close
);
1197 SCM_DEFINE (scm_i_make_transcoded_port
,
1198 "%make-transcoded-port", 1, 0, 0,
1200 "Return a new port which reads and writes to @var{port}")
1201 #define FUNC_NAME s_scm_i_make_transcoded_port
1204 unsigned long mode
= 0;
1206 SCM_VALIDATE_PORT (SCM_ARG1
, port
);
1208 if (scm_is_true (scm_output_port_p (port
)))
1210 else if (scm_is_true (scm_input_port_p (port
)))
1213 result
= make_tp (port
, mode
);
1215 /* FIXME: We should actually close `port' "in a special way" here,
1216 according to R6RS. As there is no way to do that in Guile without
1217 rendering the underlying port unusable for our purposes as well, we
1218 just leave it open. */
1225 /* Initialization. */
1228 scm_register_r6rs_ports (void)
1230 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1231 "scm_init_r6rs_ports",
1232 (scm_t_extension_init_func
) scm_init_r6rs_ports
,
1237 scm_init_r6rs_ports (void)
1239 #include "libguile/r6rs-ports.x"
1241 initialize_bytevector_input_ports ();
1242 initialize_custom_binary_input_ports ();
1243 initialize_bytevector_output_ports ();
1244 initialize_custom_binary_output_ports ();
1245 initialize_transcoded_ports ();