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_getc (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
454 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
456 result
= scm_peek_char (port
);
457 if (SCM_CHARP (result
))
458 result
= SCM_I_MAKINUM ((unsigned char) SCM_CHAR (result
));
460 result
= SCM_EOF_VAL
;
466 SCM_DEFINE (scm_get_bytevector_n
, "get-bytevector-n", 2, 0, 0,
467 (SCM port
, SCM count
),
468 "Read @var{count} octets from @var{port}, blocking as "
469 "necessary and return a bytevector containing the octets "
470 "read. If fewer bytes are available, a bytevector smaller "
471 "than @var{count} is returned.")
472 #define FUNC_NAME s_scm_get_bytevector_n
479 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
480 c_count
= scm_to_uint (count
);
482 result
= scm_c_make_bytevector (c_count
);
483 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (result
);
485 if (SCM_LIKELY (c_count
> 0))
486 /* XXX: `scm_c_read ()' does not update the port position. */
487 c_read
= scm_c_read (port
, c_bv
, c_count
);
489 /* Don't invoke `scm_c_read ()' since it may block. */
492 if ((c_read
== 0) && (c_count
> 0))
494 if (SCM_EOF_OBJECT_P (scm_peek_char (port
)))
495 result
= SCM_EOF_VAL
;
497 result
= scm_null_bytevector
;
501 if (c_read
< c_count
)
502 result
= scm_c_shrink_bytevector (result
, c_read
);
509 SCM_DEFINE (scm_get_bytevector_n_x
, "get-bytevector-n!", 4, 0, 0,
510 (SCM port
, SCM bv
, SCM start
, SCM count
),
511 "Read @var{count} bytes from @var{port} and store them "
512 "in @var{bv} starting at index @var{start}. Return either "
513 "the number of bytes actually read or the end-of-file "
515 #define FUNC_NAME s_scm_get_bytevector_n_x
519 unsigned c_start
, c_count
, c_len
;
522 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
523 SCM_VALIDATE_BYTEVECTOR (2, bv
);
524 c_start
= scm_to_uint (start
);
525 c_count
= scm_to_uint (count
);
527 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
528 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
530 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
531 scm_out_of_range (FUNC_NAME
, count
);
533 if (SCM_LIKELY (c_count
> 0))
534 c_read
= scm_c_read (port
, c_bv
+ c_start
, c_count
);
536 /* Don't invoke `scm_c_read ()' since it may block. */
539 if ((c_read
== 0) && (c_count
> 0))
541 if (SCM_EOF_OBJECT_P (scm_peek_char (port
)))
542 result
= SCM_EOF_VAL
;
544 result
= SCM_I_MAKINUM (0);
547 result
= scm_from_size_t (c_read
);
554 SCM_DEFINE (scm_get_bytevector_some
, "get-bytevector-some", 1, 0, 0,
556 "Read from @var{port}, blocking as necessary, until data "
557 "are available or and end-of-file is reached. Return either "
558 "a new bytevector containing the data read or the "
559 "end-of-file object.")
560 #define FUNC_NAME s_scm_get_bytevector_some
562 /* Read at least one byte, unless the end-of-file is already reached, and
563 read while characters are available (buffered). */
570 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
573 c_bv
= (char *) scm_gc_malloc_pointerless (c_len
, SCM_GC_BYTEVECTOR
);
580 if (c_total
+ 1 > c_len
)
582 /* Grow the bytevector. */
583 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_len
* 2,
588 /* We can't use `scm_c_read ()' since it blocks. */
589 c_chr
= scm_getc (port
);
592 c_bv
[c_total
] = (char) c_chr
;
596 while ((scm_is_true (scm_char_ready_p (port
)))
597 && (!SCM_EOF_OBJECT_P (scm_peek_char (port
))));
601 result
= SCM_EOF_VAL
;
602 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
608 /* Shrink the bytevector. */
609 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_total
,
611 c_len
= (unsigned) c_total
;
614 result
= scm_c_take_bytevector ((signed char *) c_bv
, c_len
);
621 SCM_DEFINE (scm_get_bytevector_all
, "get-bytevector-all", 1, 0, 0,
623 "Read from @var{port}, blocking as necessary, until "
624 "the end-of-file is reached. Return either "
625 "a new bytevector containing the data read or the "
626 "end-of-file object (if no data were available).")
627 #define FUNC_NAME s_scm_get_bytevector_all
631 unsigned c_len
, c_count
;
632 size_t c_read
, c_total
;
634 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
636 c_len
= c_count
= 4096;
637 c_bv
= (char *) scm_gc_malloc_pointerless (c_len
, SCM_GC_BYTEVECTOR
);
638 c_total
= c_read
= 0;
642 if (c_total
+ c_read
> c_len
)
644 /* Grow the bytevector. */
645 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_len
* 2,
651 /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
653 c_read
= scm_c_read (port
, c_bv
+ c_total
, c_count
);
654 c_total
+= c_read
, c_count
-= c_read
;
656 while (!SCM_EOF_OBJECT_P (scm_peek_char (port
)));
660 result
= SCM_EOF_VAL
;
661 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
667 /* Shrink the bytevector. */
668 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_total
,
670 c_len
= (unsigned) c_total
;
673 result
= scm_c_take_bytevector ((signed char *) c_bv
, c_len
);
684 /* We currently don't support specific binary input ports. */
685 #define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
688 SCM_DEFINE (scm_put_u8
, "put-u8", 2, 0, 0,
689 (SCM port
, SCM octet
),
690 "Write @var{octet} to binary port @var{port}.")
691 #define FUNC_NAME s_scm_put_u8
695 SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port
);
696 c_octet
= scm_to_uint8 (octet
);
698 scm_putc ((char) c_octet
, port
);
700 return SCM_UNSPECIFIED
;
704 SCM_DEFINE (scm_put_bytevector
, "put-bytevector", 2, 2, 0,
705 (SCM port
, SCM bv
, SCM start
, SCM count
),
706 "Write the contents of @var{bv} to @var{port}, optionally "
707 "starting at index @var{start} and limiting to @var{count} "
709 #define FUNC_NAME s_scm_put_bytevector
712 unsigned c_start
, c_count
, c_len
;
714 SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port
);
715 SCM_VALIDATE_BYTEVECTOR (2, bv
);
717 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
718 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
720 if (start
!= SCM_UNDEFINED
)
722 c_start
= scm_to_uint (start
);
724 if (count
!= SCM_UNDEFINED
)
726 c_count
= scm_to_uint (count
);
727 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
728 scm_out_of_range (FUNC_NAME
, count
);
732 if (SCM_UNLIKELY (c_start
>= c_len
))
733 scm_out_of_range (FUNC_NAME
, start
);
735 c_count
= c_len
- c_start
;
739 c_start
= 0, c_count
= c_len
;
741 scm_c_write (port
, c_bv
+ c_start
, c_count
);
743 return SCM_UNSPECIFIED
;
749 /* Bytevector output port ("bop" for short). */
751 /* Implementation of "bops".
753 Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
754 it. The procedure returned along with the output port is actually an
755 applicable SMOB. The SMOB holds a reference to the port. When applied,
756 the SMOB swallows the port's internal buffer, turning it into a
757 bytevector, and resets it.
759 XXX: Access to a bop's internal buffer is not thread-safe. */
761 static scm_t_bits bytevector_output_port_type
= 0;
763 SCM_SMOB (bytevector_output_port_procedure
,
764 "r6rs-bytevector-output-port-procedure",
767 #define SCM_GC_BOP "r6rs-bytevector-output-port"
768 #define SCM_BOP_BUFFER_INITIAL_SIZE 4096
770 /* Representation of a bop's internal buffer. */
780 /* Accessing a bop's buffer. */
781 #define SCM_BOP_BUFFER(_port) \
782 ((scm_t_bop_buffer *) SCM_STREAM (_port))
783 #define SCM_SET_BOP_BUFFER(_port, _buf) \
784 (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
788 bop_buffer_init (scm_t_bop_buffer
*buf
)
790 buf
->total_len
= buf
->len
= buf
->pos
= 0;
795 bop_buffer_grow (scm_t_bop_buffer
*buf
, size_t min_size
)
800 for (new_size
= buf
->total_len
801 ? buf
->total_len
: SCM_BOP_BUFFER_INITIAL_SIZE
;
806 new_buf
= scm_gc_realloc ((void *) buf
->buffer
, buf
->total_len
,
807 new_size
, SCM_GC_BOP
);
809 new_buf
= scm_gc_malloc_pointerless (new_size
, SCM_GC_BOP
);
811 buf
->buffer
= new_buf
;
812 buf
->total_len
= new_size
;
820 scm_t_bop_buffer
*buf
;
821 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
823 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
825 port
= scm_new_port_table_entry (bytevector_output_port_type
);
827 buf
= (scm_t_bop_buffer
*) scm_gc_malloc (sizeof (* buf
), SCM_GC_BOP
);
828 bop_buffer_init (buf
);
830 c_port
= SCM_PTAB_ENTRY (port
);
831 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
832 c_port
->write_buf_size
= 0;
834 SCM_SET_BOP_BUFFER (port
, buf
);
836 /* Mark PORT as open and writable. */
837 SCM_SET_CELL_TYPE (port
, bytevector_output_port_type
| mode_bits
);
839 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
841 /* Make the bop procedure. */
842 SCM_NEWSMOB (bop_proc
, bytevector_output_port_procedure
, buf
);
844 return (scm_values (scm_list_2 (port
, bop_proc
)));
847 /* Write SIZE octets from DATA to PORT. */
849 bop_write (SCM port
, const void *data
, size_t size
)
851 scm_t_bop_buffer
*buf
;
853 buf
= SCM_BOP_BUFFER (port
);
855 if (buf
->pos
+ size
> buf
->total_len
)
856 bop_buffer_grow (buf
, buf
->pos
+ size
);
858 memcpy (buf
->buffer
+ buf
->pos
, data
, size
);
860 buf
->len
= (buf
->len
> buf
->pos
) ? buf
->len
: buf
->pos
;
864 bop_seek (SCM port
, scm_t_off offset
, int whence
)
865 #define FUNC_NAME "bop_seek"
867 scm_t_bop_buffer
*buf
;
869 buf
= SCM_BOP_BUFFER (port
);
873 offset
+= (scm_t_off
) buf
->pos
;
877 if (offset
< 0 || (unsigned) offset
> buf
->len
)
878 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
884 if (offset
< 0 || (unsigned) offset
>= buf
->len
)
885 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
887 buf
->pos
= buf
->len
- (offset
+ 1);
891 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
892 "invalid `seek' parameter");
899 /* Fetch data from a bop. */
900 SCM_SMOB_APPLY (bytevector_output_port_procedure
,
901 bop_proc_apply
, 0, 0, 0, (SCM bop_proc
))
904 scm_t_bop_buffer
*buf
, result_buf
;
906 buf
= (scm_t_bop_buffer
*) SCM_SMOB_DATA (bop_proc
);
909 bop_buffer_init (buf
);
911 if (result_buf
.len
== 0)
912 bv
= scm_c_take_bytevector (NULL
, 0);
915 if (result_buf
.total_len
> result_buf
.len
)
916 /* Shrink the buffer. */
917 result_buf
.buffer
= scm_gc_realloc ((void *) result_buf
.buffer
,
918 result_buf
.total_len
,
922 bv
= scm_c_take_bytevector ((signed char *) result_buf
.buffer
,
929 SCM_DEFINE (scm_open_bytevector_output_port
,
930 "open-bytevector-output-port", 0, 1, 0,
932 "Return two values: an output port and a procedure. The latter "
933 "should be called with zero arguments to obtain a bytevector "
934 "containing the data accumulated by the port.")
935 #define FUNC_NAME s_scm_open_bytevector_output_port
937 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
938 transcoders_not_implemented ();
940 return (make_bop ());
945 initialize_bytevector_output_ports (void)
947 bytevector_output_port_type
=
948 scm_make_port_type ("r6rs-bytevector-output-port",
951 scm_set_port_seek (bytevector_output_port_type
, bop_seek
);
955 /* Custom binary output port ("cbop" for short). */
957 static scm_t_bits custom_binary_output_port_type
;
959 /* Return the various procedures of PORT. */
960 #define SCM_CBOP_WRITE_PROC(_port) \
961 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
965 make_cbop (SCM write_proc
, SCM get_position_proc
,
966 SCM set_position_proc
, SCM close_proc
)
968 SCM port
, method_vector
;
970 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
972 /* Store the various methods and bytevector in a vector. */
973 method_vector
= scm_c_make_vector (4, SCM_BOOL_F
);
974 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, write_proc
);
975 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
976 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
977 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
979 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
981 port
= scm_new_port_table_entry (custom_binary_output_port_type
);
983 /* Attach it the method vector. */
984 SCM_SETSTREAM (port
, SCM_UNPACK (method_vector
));
986 /* Have the port directly access the buffer (bytevector). */
987 c_port
= SCM_PTAB_ENTRY (port
);
988 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
989 c_port
->write_buf_size
= c_port
->read_buf_size
= 0;
991 /* Mark PORT as open, writable and unbuffered. */
992 SCM_SET_CELL_TYPE (port
, custom_binary_output_port_type
| mode_bits
);
994 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
999 /* Write SIZE octets from DATA to PORT. */
1001 cbop_write (SCM port
, const void *data
, size_t size
)
1002 #define FUNC_NAME "cbop_write"
1006 SCM bv
, write_proc
, result
;
1008 /* XXX: Allocating a new bytevector at each `write' call is inefficient,
1009 but necessary since (1) we don't control the lifetime of the buffer
1010 pointed to by DATA, and (2) the `write!' procedure could capture the
1011 bytevector it is passed. */
1012 bv
= scm_c_make_bytevector (size
);
1013 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), data
, size
);
1015 write_proc
= SCM_CBOP_WRITE_PROC (port
);
1017 /* Since the `write' procedure of Guile's ports has type `void', it must
1018 try hard to write exactly SIZE bytes, regardless of how many bytes the
1022 c_written
+= c_result
)
1024 result
= scm_call_3 (write_proc
, bv
,
1025 scm_from_size_t (c_written
),
1026 scm_from_size_t (size
- c_written
));
1028 c_result
= scm_to_long (result
);
1029 if (SCM_UNLIKELY (c_result
< 0
1030 || (size_t) c_result
> (size
- c_written
)))
1031 scm_wrong_type_arg_msg (FUNC_NAME
, 0, result
,
1032 "R6RS custom binary output port `write!' "
1033 "returned a incorrect integer");
1039 SCM_DEFINE (scm_make_custom_binary_output_port
,
1040 "make-custom-binary-output-port", 5, 0, 0,
1041 (SCM id
, SCM write_proc
, SCM get_position_proc
,
1042 SCM set_position_proc
, SCM close_proc
),
1043 "Return a new custom binary output port whose output is drained "
1044 "by invoking @var{write_proc} and passing it a bytevector, an "
1045 "index where octets should be written, and an octet count.")
1046 #define FUNC_NAME s_scm_make_custom_binary_output_port
1048 SCM_VALIDATE_STRING (1, id
);
1049 SCM_VALIDATE_PROC (2, write_proc
);
1051 if (!scm_is_false (get_position_proc
))
1052 SCM_VALIDATE_PROC (3, get_position_proc
);
1054 if (!scm_is_false (set_position_proc
))
1055 SCM_VALIDATE_PROC (4, set_position_proc
);
1057 if (!scm_is_false (close_proc
))
1058 SCM_VALIDATE_PROC (5, close_proc
);
1060 return (make_cbop (write_proc
, get_position_proc
, set_position_proc
,
1066 /* Instantiate the custom binary output port type. */
1068 initialize_custom_binary_output_ports (void)
1070 custom_binary_output_port_type
=
1071 scm_make_port_type ("r6rs-custom-binary-output-port",
1074 scm_set_port_seek (custom_binary_output_port_type
, cbp_seek
);
1075 scm_set_port_close (custom_binary_output_port_type
, cbp_close
);
1079 /* Transcoded ports ("tp" for short). */
1080 static scm_t_bits transcoded_port_type
= 0;
1082 #define TP_INPUT_BUFFER_SIZE 4096
1084 #define SCM_TP_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port))
1087 make_tp (SCM binary_port
, unsigned long mode
)
1091 const unsigned long mode_bits
= SCM_OPN
| mode
;
1093 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
1095 port
= scm_new_port_table_entry (transcoded_port_type
);
1097 SCM_SETSTREAM (port
, SCM_UNPACK (binary_port
));
1099 SCM_SET_CELL_TYPE (port
, transcoded_port_type
| mode_bits
);
1101 if (SCM_INPUT_PORT_P (port
))
1103 c_port
= SCM_PTAB_ENTRY (port
);
1104 c_port
->read_buf
= scm_gc_malloc_pointerless (TP_INPUT_BUFFER_SIZE
,
1106 c_port
->read_pos
= c_port
->read_end
= c_port
->read_buf
;
1107 c_port
->read_buf_size
= TP_INPUT_BUFFER_SIZE
;
1109 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
1112 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
1118 tp_write (SCM port
, const void *data
, size_t size
)
1120 scm_c_write (SCM_TP_BINARY_PORT (port
), data
, size
);
1124 tp_fill_input (SCM port
)
1127 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
1128 SCM bport
= SCM_TP_BINARY_PORT (port
);
1129 scm_t_port
*c_bport
= SCM_PTAB_ENTRY (bport
);
1131 /* We can't use `scm_c_read' here, since it blocks until the whole
1132 block has been read or EOF. */
1134 if (c_bport
->rw_active
== SCM_PORT_WRITE
)
1135 scm_force_output (bport
);
1137 if (c_bport
->read_pos
>= c_bport
->read_end
)
1138 scm_fill_input (bport
);
1140 count
= c_bport
->read_end
- c_bport
->read_pos
;
1141 if (count
> c_port
->read_buf_size
)
1142 count
= c_port
->read_buf_size
;
1144 memcpy (c_port
->read_buf
, c_bport
->read_pos
, count
);
1145 c_bport
->read_pos
+= count
;
1147 if (c_bport
->rw_random
)
1148 c_bport
->rw_active
= SCM_PORT_READ
;
1154 c_port
->read_pos
= c_port
->read_buf
;
1155 c_port
->read_end
= c_port
->read_buf
+ count
;
1156 return *c_port
->read_buf
;
1163 SCM binary_port
= SCM_TP_BINARY_PORT (port
);
1164 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
1165 size_t count
= c_port
->write_pos
- c_port
->write_buf
;
1167 scm_c_write (binary_port
, c_port
->write_buf
, count
);
1169 c_port
->write_pos
= c_port
->write_buf
;
1170 c_port
->rw_active
= SCM_PORT_NEITHER
;
1172 scm_force_output (binary_port
);
1178 if (SCM_OUTPUT_PORT_P (port
))
1180 return scm_is_true (scm_close_port (SCM_TP_BINARY_PORT (port
))) ? 0 : -1;
1184 initialize_transcoded_ports (void)
1186 transcoded_port_type
=
1187 scm_make_port_type ("r6rs-transcoded-port", tp_fill_input
, tp_write
);
1189 scm_set_port_flush (transcoded_port_type
, tp_flush
);
1190 scm_set_port_close (transcoded_port_type
, tp_close
);
1193 SCM_DEFINE (scm_i_make_transcoded_port
,
1194 "%make-transcoded-port", 1, 0, 0,
1196 "Return a new port which reads and writes to @var{port}")
1197 #define FUNC_NAME s_scm_i_make_transcoded_port
1200 unsigned long mode
= 0;
1202 SCM_VALIDATE_PORT (SCM_ARG1
, port
);
1204 if (scm_is_true (scm_output_port_p (port
)))
1206 else if (scm_is_true (scm_input_port_p (port
)))
1209 result
= make_tp (port
, mode
);
1211 /* FIXME: We should actually close `port' "in a special way" here,
1212 according to R6RS. As there is no way to do that in Guile without
1213 rendering the underlying port unusable for our purposes as well, we
1214 just leave it open. */
1221 /* Initialization. */
1224 scm_register_r6rs_ports (void)
1226 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1227 "scm_init_r6rs_ports",
1228 (scm_t_extension_init_func
) scm_init_r6rs_ports
,
1233 scm_init_r6rs_ports (void)
1235 #include "libguile/r6rs-ports.x"
1237 initialize_bytevector_input_ports ();
1238 initialize_custom_binary_input_ports ();
1239 initialize_bytevector_output_ports ();
1240 initialize_custom_binary_output_ports ();
1241 initialize_transcoded_ports ();