1 /* Guile-R6RS-Libs --- Implementation of R6RS standard libraries.
2 Copyright (C) 2007, 2008 Ludovic Courtès <ludo@gnu.org>
4 Guile-R6RS-Libs is free software; you can redistribute it and/or
5 modify it under the terms of the GNU Lesser General Public
6 License as published by the Free Software Foundation; either
7 version 2.1 of the License, or (at your option) any later version.
9 Guile-R6RS-Libs is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 Lesser General Public License for more details.
14 You should have received a copy of the GNU Lesser General Public
15 License along with Guile-R6RS-Libs; if not, write to the Free Software
16 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */
27 #include "bytevector.h"
31 /* Unimplemented features. */
34 /* Transoders are currently not implemented since Guile 1.8 is not
35 Unicode-capable. Thus, most of the code here assumes the use of the
38 transcoders_not_implemented (void)
40 fprintf (stderr
, "%s: warning: transcoders not implemented\n",
45 /* End-of-file object. */
47 SCM_DEFINE (scm_r6rs_eof_object
, "eof-object", 0, 0, 0,
49 "Return the end-of-file object.")
50 #define FUNC_NAME s_scm_r6rs_eof_object
60 # define MIN(a,b) ((a) < (b) ? (a) : (b))
63 /* Bytevector input ports or "bip" for short. */
64 static scm_t_bits bytevector_input_port_type
= 0;
73 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
;
75 port
= scm_new_port_table_entry (bytevector_input_port_type
);
77 /* Prevent BV from being GC'd. */
78 SCM_SETSTREAM (port
, SCM_UNPACK (bv
));
80 /* Have the port directly access the bytevector. */
81 c_bv
= (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
82 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
84 c_port
= SCM_PTAB_ENTRY (port
);
85 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
86 c_port
->read_end
= (unsigned char *) c_bv
+ c_len
;
87 c_port
->read_buf_size
= c_len
;
89 /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
90 SCM_SET_CELL_TYPE (port
, bytevector_input_port_type
| mode_bits
);
98 /* Mark the underlying bytevector. */
99 return (SCM_PACK (SCM_STREAM (port
)));
102 #ifndef HAVE_SCM_SET_PORT_READ
105 bip_fill_input (SCM port
)
108 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
110 if (c_port
->read_pos
>= c_port
->read_end
)
113 result
= (int) *c_port
->read_pos
;
118 #else /* HAVE_SCM_SET_PORT_READ */
121 bip_read (SCM port
, void *buffer
, size_t size
)
123 size_t remaining
, count
;
124 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
126 remaining
= c_port
->read_end
- c_port
->read_pos
;
127 count
= MIN (remaining
, size
);
129 memcpy (buffer
, c_port
->read_pos
, count
);
130 c_port
->read_pos
+= count
;
135 #endif /* HAVE_SCM_SET_PORT_READ */
138 bip_seek (SCM port
, off_t offset
, int whence
)
139 #define FUNC_NAME "bip_seek"
142 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
147 offset
+= c_port
->read_pos
- c_port
->read_buf
;
151 if (c_port
->read_buf
+ offset
< c_port
->read_end
)
153 c_port
->read_pos
= c_port
->read_buf
+ offset
;
157 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
161 if (c_port
->read_end
- offset
>= c_port
->read_buf
)
163 c_port
->read_pos
= c_port
->read_end
- offset
;
164 c_result
= c_port
->read_pos
- c_port
->read_buf
;
167 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
171 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
172 "invalid `seek' parameter");
180 /* Instantiate the bytevector input port type. */
182 initialize_bytevector_input_ports (void)
184 bytevector_input_port_type
=
185 scm_make_port_type ("r6rs-bytevector-input-port",
186 PORT_FILL_INPUT_METHOD (bip_fill_input
),
189 scm_set_port_read (bytevector_input_port_type
, bip_read
);
190 scm_set_port_mark (bytevector_input_port_type
, bip_mark
);
191 scm_set_port_seek (bytevector_input_port_type
, bip_seek
);
195 SCM_DEFINE (scm_r6rs_open_bytevector_input_port
,
196 "open-bytevector-input-port", 1, 1, 0,
197 (SCM bv
, SCM transcoder
),
198 "Return an input port whose contents are drawn from "
199 "bytevector @var{bv}.")
200 #define FUNC_NAME s_scm_r6rs_open_bytevector_input_port
202 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv
);
203 if (transcoder
!= SCM_UNDEFINED
)
204 transcoders_not_implemented ();
206 return (make_bip (bv
));
212 /* Custom binary input port ("cbip" for short). */
214 static scm_t_bits custom_binary_input_port_type
= 0;
216 /* Size of the buffer embedded in custom binary input ports. */
217 #define CBIP_BUFFER_SIZE 4096
219 /* Return the bytevector associated to PORT. */
220 #define SCM_R6RS_CBIP_BYTEVECTOR(_port) \
221 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
223 /* Return the various procedures of PORT. */
224 #define SCM_R6RS_CBIP_READ_PROC(_port) \
225 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
226 #define SCM_R6RS_CBIP_GET_POSITION_PROC(_port) \
227 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
228 #define SCM_R6RS_CBIP_SET_POSITION_PROC(_port) \
229 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
230 #define SCM_R6RS_CBIP_CLOSE_PROC(_port) \
231 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
235 make_cbip (SCM read_proc
, SCM get_position_proc
,
236 SCM set_position_proc
, SCM close_proc
)
238 SCM port
, bv
, method_vector
;
242 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
;
244 /* Use a bytevector as the underlying buffer. */
245 c_len
= CBIP_BUFFER_SIZE
;
246 bv
= scm_r6rs_c_make_bytevector (c_len
);
247 c_bv
= (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
249 /* Store the various methods and bytevector in a vector. */
250 method_vector
= scm_c_make_vector (5, SCM_BOOL_F
);
251 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, bv
);
252 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, read_proc
);
253 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, get_position_proc
);
254 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, set_position_proc
);
255 SCM_SIMPLE_VECTOR_SET (method_vector
, 4, close_proc
);
257 port
= scm_new_port_table_entry (custom_binary_input_port_type
);
259 /* Attach it the method vector. */
260 SCM_SETSTREAM (port
, SCM_UNPACK (method_vector
));
262 /* Have the port directly access the buffer (bytevector). */
263 c_port
= SCM_PTAB_ENTRY (port
);
264 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
265 c_port
->read_end
= (unsigned char *) c_bv
;
266 c_port
->read_buf_size
= c_len
;
268 /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
269 SCM_SET_CELL_TYPE (port
, custom_binary_input_port_type
| mode_bits
);
277 /* Mark the underlying bytevector and methods. */
278 return (SCM_PACK (SCM_STREAM (port
)));
282 cbip_fill_input (SCM port
)
283 #define FUNC_NAME "cbip_fill_input"
286 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
289 if (c_port
->read_pos
>= c_port
->read_end
)
291 /* Invoke the user's `read!' procedure. */
293 SCM bv
, read_proc
, octets
;
295 /* Use the bytevector associated with PORT as the buffer passed to the
296 `read!' procedure, thereby avoiding additional allocations. */
297 bv
= SCM_R6RS_CBIP_BYTEVECTOR (port
);
298 read_proc
= SCM_R6RS_CBIP_READ_PROC (port
);
300 /* The assumption here is that C_PORT's internal buffer wasn't changed
302 assert (c_port
->read_buf
==
303 (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
));
304 assert (c_port
->read_buf_size
== SCM_R6RS_BYTEVECTOR_LENGTH (bv
));
306 octets
= scm_call_3 (read_proc
, bv
, SCM_INUM0
,
307 SCM_I_MAKINUM (CBIP_BUFFER_SIZE
));
308 c_octets
= scm_to_uint (octets
);
310 c_port
->read_pos
= (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
311 c_port
->read_end
= (unsigned char *) c_port
->read_pos
+ c_octets
;
319 result
= (int) *c_port
->read_pos
;
326 cbip_seek (SCM port
, off_t offset
, int whence
)
327 #define FUNC_NAME "cbip_seek"
336 SCM get_position_proc
;
338 get_position_proc
= SCM_R6RS_CBIP_GET_POSITION_PROC (port
);
339 if (EXPECT_TRUE (scm_is_true (get_position_proc
)))
340 result
= scm_call_0 (get_position_proc
);
342 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
343 "R6RS custom binary input port does not "
344 "support `port-position'");
346 offset
+= scm_to_int (result
);
352 SCM set_position_proc
;
354 set_position_proc
= SCM_R6RS_CBIP_SET_POSITION_PROC (port
);
355 if (EXPECT_TRUE (scm_is_true (set_position_proc
)))
356 result
= scm_call_1 (set_position_proc
, scm_from_int (offset
));
358 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
359 "R6RS custom binary input port does not "
360 "support `set-port-position!'");
362 /* Assuming setting the position succeeded. */
368 /* `SEEK_END' cannot be supported. */
369 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
370 "R6RS custom binary input ports do not "
371 "support `SEEK_END'");
379 cbip_close (SCM port
)
383 close_proc
= SCM_R6RS_CBIP_CLOSE_PROC (port
);
384 if (scm_is_true (close_proc
))
385 /* Invoke the `close' thunk. */
386 scm_call_0 (close_proc
);
392 SCM_DEFINE (scm_r6rs_make_custom_binary_input_port
,
393 "make-custom-binary-input-port", 2, 3, 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_r6rs_make_custom_binary_input_port
401 SCM_VALIDATE_STRING (1, id
);
402 SCM_VALIDATE_PROC (2, read_proc
);
404 if (get_position_proc
== SCM_UNDEFINED
)
405 get_position_proc
= SCM_BOOL_F
;
407 SCM_VALIDATE_PROC (3, get_position_proc
);
409 if (set_position_proc
== SCM_UNDEFINED
)
410 set_position_proc
= SCM_BOOL_F
;
412 SCM_VALIDATE_PROC (4, set_position_proc
);
414 if (close_proc
== SCM_UNDEFINED
)
415 close_proc
= SCM_BOOL_F
;
417 SCM_VALIDATE_PROC (5, close_proc
);
419 return (make_cbip (read_proc
, get_position_proc
, set_position_proc
,
425 /* Instantiate the custom binary input port type. */
427 initialize_custom_binary_input_ports (void)
429 custom_binary_input_port_type
=
430 scm_make_port_type ("r6rs-custom-binary-input-port",
431 cbip_fill_input
, NULL
);
433 scm_set_port_mark (custom_binary_input_port_type
, cbip_mark
);
434 scm_set_port_seek (custom_binary_input_port_type
, cbip_seek
);
435 scm_set_port_close (custom_binary_input_port_type
, cbip_close
);
442 /* We currently don't support specific binary input ports. */
443 #define SCM_VALIDATE_R6RS_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
445 SCM_DEFINE (scm_r6rs_get_u8
, "get-u8", 1, 0, 0,
447 "Read an octet from @var{port}, a binary input port, "
448 "blocking as necessary.")
449 #define FUNC_NAME s_scm_r6rs_get_u8
454 SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port
);
456 c_result
= scm_getc (port
);
458 result
= SCM_EOF_VAL
;
460 result
= SCM_I_MAKINUM ((unsigned char) c_result
);
466 SCM_DEFINE (scm_r6rs_lookahead_u8
, "lookahead-u8", 1, 0, 0,
468 "Like @code{get-u8} but does not update @var{port} to "
469 "point past the octet.")
470 #define FUNC_NAME s_scm_r6rs_lookahead_u8
474 SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port
);
476 result
= scm_peek_char (port
);
477 if (SCM_CHARP (result
))
478 result
= SCM_I_MAKINUM ((signed char) SCM_CHAR (result
));
480 result
= SCM_EOF_VAL
;
486 SCM_DEFINE (scm_r6rs_get_bytevector_n
, "get-bytevector-n", 2, 0, 0,
487 (SCM port
, SCM count
),
488 "Read @var{count} octets from @var{port}, blocking as "
489 "necessary and return a bytevector containing the octets "
490 "read. If fewer bytes are available, a bytevector smaller "
491 "than @var{count} is returned.")
492 #define FUNC_NAME s_scm_r6rs_get_bytevector_n
499 SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port
);
500 c_count
= scm_to_uint (count
);
502 result
= scm_r6rs_c_make_bytevector (c_count
);
503 c_bv
= (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (result
);
505 if (EXPECT_TRUE (c_count
> 0))
506 /* XXX: `scm_c_read ()' does not update the port position. */
507 c_read
= scm_c_read (port
, c_bv
, c_count
);
509 /* Don't invoke `scm_c_read ()' since it may block. */
512 if ((c_read
== 0) && (c_count
> 0))
514 if (SCM_EOF_OBJECT_P (scm_peek_char (port
)))
515 result
= SCM_EOF_VAL
;
517 result
= scm_r6rs_null_bytevector
;
521 if (c_read
< c_count
)
522 result
= scm_r6rs_c_shrink_bytevector (result
, c_read
);
529 SCM_DEFINE (scm_r6rs_get_bytevector_n_x
, "get-bytevector-n!", 4, 0, 0,
530 (SCM port
, SCM bv
, SCM start
, SCM count
),
531 "Read @var{count} bytes from @var{port} and store them "
532 "in @var{bv} starting at index @var{start}. Return either "
533 "the number of bytes actually read or the end-of-file "
535 #define FUNC_NAME s_scm_r6rs_get_bytevector_n_x
539 unsigned c_start
, c_count
, c_len
;
542 SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port
);
543 SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv
);
544 c_start
= scm_to_uint (start
);
545 c_count
= scm_to_uint (count
);
547 c_bv
= (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
548 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
550 if (EXPECT_FALSE (c_start
+ c_count
> c_len
))
551 scm_out_of_range (FUNC_NAME
, count
);
553 if (EXPECT_TRUE (c_count
> 0))
554 c_read
= scm_c_read (port
, c_bv
+ c_start
, c_count
);
556 /* Don't invoke `scm_c_read ()' since it may block. */
559 if ((c_read
== 0) && (c_count
> 0))
561 if (SCM_EOF_OBJECT_P (scm_peek_char (port
)))
562 result
= SCM_EOF_VAL
;
564 result
= SCM_I_MAKINUM (0);
567 result
= scm_from_size_t (c_read
);
574 SCM_DEFINE (scm_r6rs_get_bytevector_some
, "get-bytevector-some", 1, 0, 0,
576 "Read from @var{port}, blocking as necessary, until data "
577 "are available or and end-of-file is reached. Return either "
578 "a new bytevector containing the data read or the "
579 "end-of-file object.")
580 #define FUNC_NAME s_scm_r6rs_get_bytevector_some
582 /* Read at least one byte, unless the end-of-file is already reached, and
583 read while characters are available (buffered). */
590 SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port
);
593 c_bv
= (char *) scm_gc_malloc (c_len
, SCM_GC_BYTEVECTOR
);
600 if (c_total
+ 1 > c_len
)
602 /* Grow the bytevector. */
603 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_len
* 2,
608 /* We can't use `scm_c_read ()' since it blocks. */
609 c_chr
= scm_getc (port
);
612 c_bv
[c_total
] = (char) c_chr
;
616 while ((scm_is_true (scm_char_ready_p (port
)))
617 && (!SCM_EOF_OBJECT_P (scm_peek_char (port
))));
621 result
= SCM_EOF_VAL
;
622 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
628 /* Shrink the bytevector. */
629 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_total
,
631 c_len
= (unsigned) c_total
;
634 result
= scm_r6rs_c_take_bytevector ((signed char *) c_bv
, c_len
);
641 SCM_DEFINE (scm_r6rs_get_bytevector_all
, "get-bytevector-all", 1, 0, 0,
643 "Read from @var{port}, blocking as necessary, until "
644 "the end-of-file is reached. Return either "
645 "a new bytevector containing the data read or the "
646 "end-of-file object (if no data were available).")
647 #define FUNC_NAME s_scm_r6rs_get_bytevector_all
651 unsigned c_len
, c_count
;
652 size_t c_read
, c_total
;
654 SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port
);
656 c_len
= c_count
= 4096;
657 c_bv
= (char *) scm_gc_malloc (c_len
, SCM_GC_BYTEVECTOR
);
658 c_total
= c_read
= 0;
662 if (c_total
+ c_read
> c_len
)
664 /* Grow the bytevector. */
665 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_len
* 2,
671 /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
673 c_read
= scm_c_read (port
, c_bv
+ c_total
, c_count
);
674 c_total
+= c_read
, c_count
-= c_read
;
676 while (!SCM_EOF_OBJECT_P (scm_peek_char (port
)));
680 result
= SCM_EOF_VAL
;
681 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
687 /* Shrink the bytevector. */
688 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_total
,
690 c_len
= (unsigned) c_total
;
693 result
= scm_r6rs_c_take_bytevector ((signed char *) c_bv
, c_len
);
704 /* We currently don't support specific binary input ports. */
705 #define SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
708 SCM_DEFINE (scm_r6rs_put_u8
, "put-u8", 2, 0, 0,
709 (SCM port
, SCM octet
),
710 "Write @var{octet} to binary port @var{port}.")
711 #define FUNC_NAME s_scm_r6rs_put_u8
715 SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT (1, port
);
716 c_octet
= scm_to_uint8 (octet
);
718 scm_putc ((char) c_octet
, port
);
720 return SCM_UNSPECIFIED
;
724 SCM_DEFINE (scm_r6rs_put_bytevector
, "put-bytevector", 2, 2, 0,
725 (SCM port
, SCM bv
, SCM start
, SCM count
),
726 "Write 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_r6rs_put_bytevector
732 unsigned c_start
, c_count
, c_len
;
734 SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT (1, port
);
735 SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv
);
737 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
738 c_bv
= (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
740 if (start
!= SCM_UNDEFINED
)
742 c_start
= scm_to_uint (start
);
744 if (count
!= SCM_UNDEFINED
)
746 c_count
= scm_to_uint (count
);
747 if (EXPECT_FALSE (c_start
+ c_count
> c_len
))
748 scm_out_of_range (FUNC_NAME
, count
);
752 if (EXPECT_FALSE (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_c_write (port
, c_bv
+ c_start
, c_count
);
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_R6RS_BOP_BUFFER(_port) \
802 ((scm_t_bop_buffer *) SCM_STREAM (_port))
803 #define SCM_R6RS_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 (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 port
= scm_new_port_table_entry (bytevector_output_port_type
);
845 buf
= (scm_t_bop_buffer
*) scm_gc_malloc (sizeof (* buf
), SCM_GC_BOP
);
846 bop_buffer_init (buf
);
848 c_port
= SCM_PTAB_ENTRY (port
);
849 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
850 c_port
->write_buf_size
= 0;
852 SCM_R6RS_SET_BOP_BUFFER (port
, buf
);
854 /* Mark PORT as open and writable. */
855 SCM_SET_CELL_TYPE (port
, bytevector_output_port_type
| mode_bits
);
857 /* Make the bop procedure. */
858 SCM_NEWSMOB (bop_proc
, bytevector_output_port_procedure
,
861 return (scm_values (scm_list_2 (port
, bop_proc
)));
867 /* The port itself is necessarily freed _after_ the bop proc, since the bop
868 proc holds a reference to it. Thus we can safely free the internal
869 buffer when the bop becomes unreferenced. */
870 scm_t_bop_buffer
*buf
;
872 buf
= SCM_R6RS_BOP_BUFFER (port
);
874 scm_gc_free (buf
->buffer
, buf
->total_len
, SCM_GC_BOP
);
876 scm_gc_free (buf
, sizeof (* buf
), SCM_GC_BOP
);
881 /* Write SIZE octets from DATA to PORT. */
883 bop_write (SCM port
, const void *data
, size_t size
)
885 scm_t_bop_buffer
*buf
;
887 buf
= SCM_R6RS_BOP_BUFFER (port
);
889 if (buf
->pos
+ size
> buf
->total_len
)
890 bop_buffer_grow (buf
, buf
->pos
+ size
);
892 memcpy (buf
->buffer
+ buf
->pos
, data
, size
);
894 buf
->len
= (buf
->len
> buf
->pos
) ? buf
->len
: buf
->pos
;
898 bop_seek (SCM port
, off_t offset
, int whence
)
899 #define FUNC_NAME "bop_seek"
901 scm_t_bop_buffer
*buf
;
903 buf
= SCM_R6RS_BOP_BUFFER (port
);
907 offset
+= (off_t
) buf
->pos
;
911 if (offset
> buf
->len
)
912 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
918 if (offset
>= buf
->len
)
919 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
921 buf
->pos
= buf
->len
- offset
;
925 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
926 "invalid `seek' parameter");
933 /* Fetch data from a bop. */
934 SCM_SMOB_APPLY (bytevector_output_port_procedure
,
935 bop_proc_apply
, 0, 0, 0, (SCM bop_proc
))
938 scm_t_bop_buffer
*buf
, result_buf
;
940 port
= SCM_PACK (SCM_SMOB_DATA (bop_proc
));
941 buf
= SCM_R6RS_BOP_BUFFER (port
);
944 bop_buffer_init (buf
);
946 if (result_buf
.len
== 0)
947 bv
= scm_r6rs_c_take_bytevector (NULL
, 0);
950 if (result_buf
.total_len
> result_buf
.len
)
951 /* Shrink the buffer. */
952 result_buf
.buffer
= scm_gc_realloc ((void *) result_buf
.buffer
,
953 result_buf
.total_len
,
957 bv
= scm_r6rs_c_take_bytevector ((signed char *) result_buf
.buffer
,
964 SCM_SMOB_MARK (bytevector_output_port_procedure
, bop_proc_mark
,
967 /* Mark the port associated to BOP_PROC. */
968 return (SCM_PACK (SCM_SMOB_DATA (bop_proc
)));
972 SCM_DEFINE (scm_r6rs_open_bytevector_output_port
,
973 "open-bytevector-output-port", 0, 1, 0,
975 "Return two values: an output port and a procedure. The latter "
976 "should be called with zero arguments to obtain a bytevector "
977 "containing the data accumulated by the port.")
978 #define FUNC_NAME scm_r6rs_open_bytevector_output_port
980 if (transcoder
!= SCM_UNDEFINED
)
981 transcoders_not_implemented ();
983 return (make_bop ());
988 initialize_bytevector_output_ports (void)
990 bytevector_output_port_type
=
991 scm_make_port_type ("r6rs-bytevector-output-port",
994 scm_set_port_seek (bytevector_output_port_type
, bop_seek
);
995 scm_set_port_free (bytevector_output_port_type
, bop_free
);
1000 /* Initialization. */
1003 scm_init_r6rs_ports (void)
1007 initialize_bytevector_input_ports ();
1008 initialize_custom_binary_input_ports ();
1009 initialize_bytevector_output_ports ();
1012 /* arch-tag: c041ffd6-8871-40e8-a25a-d0f8768a71dc