1 /* Guile-R6RS-Libs --- Implementation of R6RS standard libraries.
2 Copyright (C) 2007, 2008, 2009 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 */
30 #include "bytevector.h"
34 /* Unimplemented features. */
37 /* Transoders are currently not implemented since Guile 1.8 is not
38 Unicode-capable. Thus, most of the code here assumes the use of the
41 transcoders_not_implemented (void)
43 fprintf (stderr
, "%s: warning: transcoders not implemented\n",
48 /* End-of-file object. */
50 SCM_DEFINE (scm_r6rs_eof_object
, "eof-object", 0, 0, 0,
52 "Return the end-of-file object.")
53 #define FUNC_NAME s_scm_r6rs_eof_object
63 # define MIN(a,b) ((a) < (b) ? (a) : (b))
66 /* Bytevector input ports or "bip" for short. */
67 static scm_t_bits bytevector_input_port_type
= 0;
76 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
;
78 port
= scm_new_port_table_entry (bytevector_input_port_type
);
80 /* Prevent BV from being GC'd. */
81 SCM_SETSTREAM (port
, SCM_UNPACK (bv
));
83 /* Have the port directly access the bytevector. */
84 c_bv
= (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
85 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
87 c_port
= SCM_PTAB_ENTRY (port
);
88 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
89 c_port
->read_end
= (unsigned char *) c_bv
+ c_len
;
90 c_port
->read_buf_size
= c_len
;
92 /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
93 SCM_SET_CELL_TYPE (port
, bytevector_input_port_type
| mode_bits
);
101 /* Mark the underlying bytevector. */
102 return (SCM_PACK (SCM_STREAM (port
)));
105 #ifndef HAVE_SCM_SET_PORT_READ
108 bip_fill_input (SCM port
)
111 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
113 if (c_port
->read_pos
>= c_port
->read_end
)
116 result
= (int) *c_port
->read_pos
;
121 #else /* HAVE_SCM_SET_PORT_READ */
124 bip_read (SCM port
, void *buffer
, size_t size
)
126 size_t remaining
, count
;
127 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
129 remaining
= c_port
->read_end
- c_port
->read_pos
;
130 count
= MIN (remaining
, size
);
132 memcpy (buffer
, c_port
->read_pos
, count
);
133 c_port
->read_pos
+= count
;
138 #endif /* HAVE_SCM_SET_PORT_READ */
141 bip_seek (SCM port
, off_t offset
, int whence
)
142 #define FUNC_NAME "bip_seek"
145 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
150 offset
+= c_port
->read_pos
- c_port
->read_buf
;
154 if (c_port
->read_buf
+ offset
< c_port
->read_end
)
156 c_port
->read_pos
= c_port
->read_buf
+ offset
;
160 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
164 if (c_port
->read_end
- offset
>= c_port
->read_buf
)
166 c_port
->read_pos
= c_port
->read_end
- offset
;
167 c_result
= c_port
->read_pos
- c_port
->read_buf
;
170 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
174 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
175 "invalid `seek' parameter");
183 /* Instantiate the bytevector input port type. */
185 initialize_bytevector_input_ports (void)
187 bytevector_input_port_type
=
188 scm_make_port_type ("r6rs-bytevector-input-port",
189 PORT_FILL_INPUT_METHOD (bip_fill_input
),
192 scm_set_port_read (bytevector_input_port_type
, bip_read
);
193 scm_set_port_mark (bytevector_input_port_type
, bip_mark
);
194 scm_set_port_seek (bytevector_input_port_type
, bip_seek
);
198 SCM_DEFINE (scm_r6rs_open_bytevector_input_port
,
199 "open-bytevector-input-port", 1, 1, 0,
200 (SCM bv
, SCM transcoder
),
201 "Return an input port whose contents are drawn from "
202 "bytevector @var{bv}.")
203 #define FUNC_NAME s_scm_r6rs_open_bytevector_input_port
205 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv
);
206 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
207 transcoders_not_implemented ();
209 return (make_bip (bv
));
214 /* Custom binary ports. The following routines are shared by input and
215 output custom binary ports. */
217 #define SCM_R6RS_CBP_GET_POSITION_PROC(_port) \
218 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
219 #define SCM_R6RS_CBP_SET_POSITION_PROC(_port) \
220 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
221 #define SCM_R6RS_CBP_CLOSE_PROC(_port) \
222 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
227 /* Mark the underlying method and object vector. */
228 if (SCM_OPENP (port
))
229 return SCM_PACK (SCM_STREAM (port
));
235 cbp_seek (SCM port
, off_t offset
, int whence
)
236 #define FUNC_NAME "cbp_seek"
245 SCM get_position_proc
;
247 get_position_proc
= SCM_R6RS_CBP_GET_POSITION_PROC (port
);
248 if (SCM_LIKELY (scm_is_true (get_position_proc
)))
249 result
= scm_call_0 (get_position_proc
);
251 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
252 "R6RS custom binary port does not "
253 "support `port-position'");
255 offset
+= scm_to_int (result
);
261 SCM set_position_proc
;
263 set_position_proc
= SCM_R6RS_CBP_SET_POSITION_PROC (port
);
264 if (SCM_LIKELY (scm_is_true (set_position_proc
)))
265 result
= scm_call_1 (set_position_proc
, scm_from_int (offset
));
267 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
268 "R6RS custom binary port does not "
269 "support `set-port-position!'");
271 /* Assuming setting the position succeeded. */
277 /* `SEEK_END' cannot be supported. */
278 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
279 "R6RS custom binary ports do not "
280 "support `SEEK_END'");
292 close_proc
= SCM_R6RS_CBP_CLOSE_PROC (port
);
293 if (scm_is_true (close_proc
))
294 /* Invoke the `close' thunk. */
295 scm_call_0 (close_proc
);
301 /* Custom binary input port ("cbip" for short). */
303 static scm_t_bits custom_binary_input_port_type
= 0;
305 /* Size of the buffer embedded in custom binary input ports. */
306 #define CBIP_BUFFER_SIZE 4096
308 /* Return the bytevector associated with PORT. */
309 #define SCM_R6RS_CBIP_BYTEVECTOR(_port) \
310 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
312 /* Return the various procedures of PORT. */
313 #define SCM_R6RS_CBIP_READ_PROC(_port) \
314 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
318 make_cbip (SCM read_proc
, SCM get_position_proc
,
319 SCM set_position_proc
, SCM close_proc
)
321 SCM port
, bv
, method_vector
;
325 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
;
327 /* Use a bytevector as the underlying buffer. */
328 c_len
= CBIP_BUFFER_SIZE
;
329 bv
= scm_r6rs_c_make_bytevector (c_len
);
330 c_bv
= (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
332 /* Store the various methods and bytevector in a vector. */
333 method_vector
= scm_c_make_vector (5, SCM_BOOL_F
);
334 SCM_SIMPLE_VECTOR_SET (method_vector
, 4, bv
);
335 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, read_proc
);
336 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
337 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
338 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
340 port
= scm_new_port_table_entry (custom_binary_input_port_type
);
342 /* Attach it the method vector. */
343 SCM_SETSTREAM (port
, SCM_UNPACK (method_vector
));
345 /* Have the port directly access the buffer (bytevector). */
346 c_port
= SCM_PTAB_ENTRY (port
);
347 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
348 c_port
->read_end
= (unsigned char *) c_bv
;
349 c_port
->read_buf_size
= c_len
;
351 /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
352 SCM_SET_CELL_TYPE (port
, custom_binary_input_port_type
| mode_bits
);
358 cbip_fill_input (SCM port
)
359 #define FUNC_NAME "cbip_fill_input"
362 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
365 if (c_port
->read_pos
>= c_port
->read_end
)
367 /* Invoke the user's `read!' procedure. */
369 SCM bv
, read_proc
, octets
;
371 /* Use the bytevector associated with PORT as the buffer passed to the
372 `read!' procedure, thereby avoiding additional allocations. */
373 bv
= SCM_R6RS_CBIP_BYTEVECTOR (port
);
374 read_proc
= SCM_R6RS_CBIP_READ_PROC (port
);
376 /* The assumption here is that C_PORT's internal buffer wasn't changed
378 assert (c_port
->read_buf
==
379 (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
));
380 assert ((unsigned) c_port
->read_buf_size
381 == SCM_R6RS_BYTEVECTOR_LENGTH (bv
));
383 octets
= scm_call_3 (read_proc
, bv
, SCM_INUM0
,
384 SCM_I_MAKINUM (CBIP_BUFFER_SIZE
));
385 c_octets
= scm_to_uint (octets
);
387 c_port
->read_pos
= (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
388 c_port
->read_end
= (unsigned char *) c_port
->read_pos
+ c_octets
;
396 result
= (int) *c_port
->read_pos
;
403 SCM_DEFINE (scm_r6rs_make_custom_binary_input_port
,
404 "make-custom-binary-input-port", 5, 0, 0,
405 (SCM id
, SCM read_proc
, SCM get_position_proc
,
406 SCM set_position_proc
, SCM close_proc
),
407 "Return a new custom binary input port whose input is drained "
408 "by invoking @var{read_proc} and passing it a bytevector, an "
409 "index where octets should be written, and an octet count.")
410 #define FUNC_NAME s_scm_r6rs_make_custom_binary_input_port
412 SCM_VALIDATE_STRING (1, id
);
413 SCM_VALIDATE_PROC (2, read_proc
);
415 if (!scm_is_false (get_position_proc
))
416 SCM_VALIDATE_PROC (3, get_position_proc
);
418 if (!scm_is_false (set_position_proc
))
419 SCM_VALIDATE_PROC (4, set_position_proc
);
421 if (!scm_is_false (close_proc
))
422 SCM_VALIDATE_PROC (5, close_proc
);
424 return (make_cbip (read_proc
, get_position_proc
, set_position_proc
,
430 /* Instantiate the custom binary input port type. */
432 initialize_custom_binary_input_ports (void)
434 custom_binary_input_port_type
=
435 scm_make_port_type ("r6rs-custom-binary-input-port",
436 cbip_fill_input
, NULL
);
438 scm_set_port_mark (custom_binary_input_port_type
, cbp_mark
);
439 scm_set_port_seek (custom_binary_input_port_type
, cbp_seek
);
440 scm_set_port_close (custom_binary_input_port_type
, cbp_close
);
447 /* We currently don't support specific binary input ports. */
448 #define SCM_VALIDATE_R6RS_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
450 SCM_DEFINE (scm_r6rs_get_u8
, "get-u8", 1, 0, 0,
452 "Read an octet from @var{port}, a binary input port, "
453 "blocking as necessary.")
454 #define FUNC_NAME s_scm_r6rs_get_u8
459 SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port
);
461 c_result
= scm_getc (port
);
463 result
= SCM_EOF_VAL
;
465 result
= SCM_I_MAKINUM ((unsigned char) c_result
);
471 SCM_DEFINE (scm_r6rs_lookahead_u8
, "lookahead-u8", 1, 0, 0,
473 "Like @code{get-u8} but does not update @var{port} to "
474 "point past the octet.")
475 #define FUNC_NAME s_scm_r6rs_lookahead_u8
479 SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port
);
481 result
= scm_peek_char (port
);
482 if (SCM_CHARP (result
))
483 result
= SCM_I_MAKINUM ((signed char) SCM_CHAR (result
));
485 result
= SCM_EOF_VAL
;
491 SCM_DEFINE (scm_r6rs_get_bytevector_n
, "get-bytevector-n", 2, 0, 0,
492 (SCM port
, SCM count
),
493 "Read @var{count} octets from @var{port}, blocking as "
494 "necessary and return a bytevector containing the octets "
495 "read. If fewer bytes are available, a bytevector smaller "
496 "than @var{count} is returned.")
497 #define FUNC_NAME s_scm_r6rs_get_bytevector_n
504 SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port
);
505 c_count
= scm_to_uint (count
);
507 result
= scm_r6rs_c_make_bytevector (c_count
);
508 c_bv
= (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (result
);
510 if (SCM_LIKELY (c_count
> 0))
511 /* XXX: `scm_c_read ()' does not update the port position. */
512 c_read
= scm_c_read (port
, c_bv
, c_count
);
514 /* Don't invoke `scm_c_read ()' since it may block. */
517 if ((c_read
== 0) && (c_count
> 0))
519 if (SCM_EOF_OBJECT_P (scm_peek_char (port
)))
520 result
= SCM_EOF_VAL
;
522 result
= scm_r6rs_null_bytevector
;
526 if (c_read
< c_count
)
527 result
= scm_r6rs_c_shrink_bytevector (result
, c_read
);
534 SCM_DEFINE (scm_r6rs_get_bytevector_n_x
, "get-bytevector-n!", 4, 0, 0,
535 (SCM port
, SCM bv
, SCM start
, SCM count
),
536 "Read @var{count} bytes from @var{port} and store them "
537 "in @var{bv} starting at index @var{start}. Return either "
538 "the number of bytes actually read or the end-of-file "
540 #define FUNC_NAME s_scm_r6rs_get_bytevector_n_x
544 unsigned c_start
, c_count
, c_len
;
547 SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port
);
548 SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv
);
549 c_start
= scm_to_uint (start
);
550 c_count
= scm_to_uint (count
);
552 c_bv
= (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
553 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
555 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
556 scm_out_of_range (FUNC_NAME
, count
);
558 if (SCM_LIKELY (c_count
> 0))
559 c_read
= scm_c_read (port
, c_bv
+ c_start
, c_count
);
561 /* Don't invoke `scm_c_read ()' since it may block. */
564 if ((c_read
== 0) && (c_count
> 0))
566 if (SCM_EOF_OBJECT_P (scm_peek_char (port
)))
567 result
= SCM_EOF_VAL
;
569 result
= SCM_I_MAKINUM (0);
572 result
= scm_from_size_t (c_read
);
579 SCM_DEFINE (scm_r6rs_get_bytevector_some
, "get-bytevector-some", 1, 0, 0,
581 "Read from @var{port}, blocking as necessary, until data "
582 "are available or and end-of-file is reached. Return either "
583 "a new bytevector containing the data read or the "
584 "end-of-file object.")
585 #define FUNC_NAME s_scm_r6rs_get_bytevector_some
587 /* Read at least one byte, unless the end-of-file is already reached, and
588 read while characters are available (buffered). */
595 SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port
);
598 c_bv
= (char *) scm_gc_malloc (c_len
, SCM_R6RS_GC_BYTEVECTOR
);
605 if (c_total
+ 1 > c_len
)
607 /* Grow the bytevector. */
608 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_len
* 2,
609 SCM_R6RS_GC_BYTEVECTOR
);
613 /* We can't use `scm_c_read ()' since it blocks. */
614 c_chr
= scm_getc (port
);
617 c_bv
[c_total
] = (char) c_chr
;
621 while ((scm_is_true (scm_char_ready_p (port
)))
622 && (!SCM_EOF_OBJECT_P (scm_peek_char (port
))));
626 result
= SCM_EOF_VAL
;
627 scm_gc_free (c_bv
, c_len
, SCM_R6RS_GC_BYTEVECTOR
);
633 /* Shrink the bytevector. */
634 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_total
,
635 SCM_R6RS_GC_BYTEVECTOR
);
636 c_len
= (unsigned) c_total
;
639 result
= scm_r6rs_c_take_bytevector ((signed char *) c_bv
, c_len
);
646 SCM_DEFINE (scm_r6rs_get_bytevector_all
, "get-bytevector-all", 1, 0, 0,
648 "Read from @var{port}, blocking as necessary, until "
649 "the end-of-file is reached. Return either "
650 "a new bytevector containing the data read or the "
651 "end-of-file object (if no data were available).")
652 #define FUNC_NAME s_scm_r6rs_get_bytevector_all
656 unsigned c_len
, c_count
;
657 size_t c_read
, c_total
;
659 SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port
);
661 c_len
= c_count
= 4096;
662 c_bv
= (char *) scm_gc_malloc (c_len
, SCM_R6RS_GC_BYTEVECTOR
);
663 c_total
= c_read
= 0;
667 if (c_total
+ c_read
> c_len
)
669 /* Grow the bytevector. */
670 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_len
* 2,
671 SCM_R6RS_GC_BYTEVECTOR
);
676 /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
678 c_read
= scm_c_read (port
, c_bv
+ c_total
, c_count
);
679 c_total
+= c_read
, c_count
-= c_read
;
681 while (!SCM_EOF_OBJECT_P (scm_peek_char (port
)));
685 result
= SCM_EOF_VAL
;
686 scm_gc_free (c_bv
, c_len
, SCM_R6RS_GC_BYTEVECTOR
);
692 /* Shrink the bytevector. */
693 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_total
,
694 SCM_R6RS_GC_BYTEVECTOR
);
695 c_len
= (unsigned) c_total
;
698 result
= scm_r6rs_c_take_bytevector ((signed char *) c_bv
, c_len
);
709 /* We currently don't support specific binary input ports. */
710 #define SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
713 SCM_DEFINE (scm_r6rs_put_u8
, "put-u8", 2, 0, 0,
714 (SCM port
, SCM octet
),
715 "Write @var{octet} to binary port @var{port}.")
716 #define FUNC_NAME s_scm_r6rs_put_u8
720 SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT (1, port
);
721 c_octet
= scm_to_uint8 (octet
);
723 scm_putc ((char) c_octet
, port
);
725 return SCM_UNSPECIFIED
;
729 SCM_DEFINE (scm_r6rs_put_bytevector
, "put-bytevector", 2, 2, 0,
730 (SCM port
, SCM bv
, SCM start
, SCM count
),
731 "Write the contents of @var{bv} to @var{port}, optionally "
732 "starting at index @var{start} and limiting to @var{count} "
734 #define FUNC_NAME s_scm_r6rs_put_bytevector
737 unsigned c_start
, c_count
, c_len
;
739 SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT (1, port
);
740 SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv
);
742 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
743 c_bv
= (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
745 if (start
!= SCM_UNDEFINED
)
747 c_start
= scm_to_uint (start
);
749 if (count
!= SCM_UNDEFINED
)
751 c_count
= scm_to_uint (count
);
752 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
753 scm_out_of_range (FUNC_NAME
, count
);
757 if (SCM_UNLIKELY (c_start
>= c_len
))
758 scm_out_of_range (FUNC_NAME
, start
);
760 c_count
= c_len
- c_start
;
764 c_start
= 0, c_count
= c_len
;
766 scm_c_write (port
, c_bv
+ c_start
, c_count
);
768 return SCM_UNSPECIFIED
;
774 /* Bytevector output port ("bop" for short). */
776 /* Implementation of "bops".
778 Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
779 it. The procedure returned along with the output port is actually an
780 applicable SMOB. The SMOB holds a reference to the port. When applied,
781 the SMOB swallows the port's internal buffer, turning it into a
782 bytevector, and resets it.
784 XXX: Access to a bop's internal buffer is not thread-safe. */
786 static scm_t_bits bytevector_output_port_type
= 0;
788 SCM_SMOB (bytevector_output_port_procedure
,
789 "r6rs-bytevector-output-port-procedure",
792 #define SCM_GC_BOP "r6rs-bytevector-output-port"
793 #define SCM_BOP_BUFFER_INITIAL_SIZE 4096
795 /* Representation of a bop's internal buffer. */
805 /* Accessing a bop's buffer. */
806 #define SCM_R6RS_BOP_BUFFER(_port) \
807 ((scm_t_bop_buffer *) SCM_STREAM (_port))
808 #define SCM_R6RS_SET_BOP_BUFFER(_port, _buf) \
809 (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
813 bop_buffer_init (scm_t_bop_buffer
*buf
)
815 buf
->total_len
= buf
->len
= buf
->pos
= 0;
820 bop_buffer_grow (scm_t_bop_buffer
*buf
, size_t min_size
)
825 for (new_size
= buf
->total_len
826 ? buf
->total_len
: SCM_BOP_BUFFER_INITIAL_SIZE
;
831 new_buf
= scm_gc_realloc ((void *) buf
->buffer
, buf
->total_len
,
832 new_size
, SCM_GC_BOP
);
834 new_buf
= scm_gc_malloc (new_size
, SCM_GC_BOP
);
836 buf
->buffer
= new_buf
;
837 buf
->total_len
= new_size
;
845 scm_t_bop_buffer
*buf
;
846 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
848 port
= scm_new_port_table_entry (bytevector_output_port_type
);
850 buf
= (scm_t_bop_buffer
*) scm_gc_malloc (sizeof (* buf
), SCM_GC_BOP
);
851 bop_buffer_init (buf
);
853 c_port
= SCM_PTAB_ENTRY (port
);
854 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
855 c_port
->write_buf_size
= 0;
857 SCM_R6RS_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 /* Make the bop procedure. */
863 SCM_NEWSMOB (bop_proc
, bytevector_output_port_procedure
,
866 return (scm_values (scm_list_2 (port
, bop_proc
)));
872 /* The port itself is necessarily freed _after_ the bop proc, since the bop
873 proc holds a reference to it. Thus we can safely free the internal
874 buffer when the bop becomes unreferenced. */
875 scm_t_bop_buffer
*buf
;
877 buf
= SCM_R6RS_BOP_BUFFER (port
);
879 scm_gc_free (buf
->buffer
, buf
->total_len
, SCM_GC_BOP
);
881 scm_gc_free (buf
, sizeof (* buf
), SCM_GC_BOP
);
886 /* Write SIZE octets from DATA to PORT. */
888 bop_write (SCM port
, const void *data
, size_t size
)
890 scm_t_bop_buffer
*buf
;
892 buf
= SCM_R6RS_BOP_BUFFER (port
);
894 if (buf
->pos
+ size
> buf
->total_len
)
895 bop_buffer_grow (buf
, buf
->pos
+ size
);
897 memcpy (buf
->buffer
+ buf
->pos
, data
, size
);
899 buf
->len
= (buf
->len
> buf
->pos
) ? buf
->len
: buf
->pos
;
903 bop_seek (SCM port
, off_t offset
, int whence
)
904 #define FUNC_NAME "bop_seek"
906 scm_t_bop_buffer
*buf
;
908 buf
= SCM_R6RS_BOP_BUFFER (port
);
912 offset
+= (off_t
) buf
->pos
;
916 if (offset
< 0 || (unsigned) offset
> buf
->len
)
917 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
923 if (offset
< 0 || (unsigned) offset
>= buf
->len
)
924 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
926 buf
->pos
= buf
->len
- (offset
+ 1);
930 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
931 "invalid `seek' parameter");
938 /* Fetch data from a bop. */
939 SCM_SMOB_APPLY (bytevector_output_port_procedure
,
940 bop_proc_apply
, 0, 0, 0, (SCM bop_proc
))
943 scm_t_bop_buffer
*buf
, result_buf
;
945 port
= SCM_PACK (SCM_SMOB_DATA (bop_proc
));
946 buf
= SCM_R6RS_BOP_BUFFER (port
);
949 bop_buffer_init (buf
);
951 if (result_buf
.len
== 0)
952 bv
= scm_r6rs_c_take_bytevector (NULL
, 0);
955 if (result_buf
.total_len
> result_buf
.len
)
956 /* Shrink the buffer. */
957 result_buf
.buffer
= scm_gc_realloc ((void *) result_buf
.buffer
,
958 result_buf
.total_len
,
962 bv
= scm_r6rs_c_take_bytevector ((signed char *) result_buf
.buffer
,
969 SCM_SMOB_MARK (bytevector_output_port_procedure
, bop_proc_mark
,
972 /* Mark the port associated with BOP_PROC. */
973 return (SCM_PACK (SCM_SMOB_DATA (bop_proc
)));
977 SCM_DEFINE (scm_r6rs_open_bytevector_output_port
,
978 "open-bytevector-output-port", 0, 1, 0,
980 "Return two values: an output port and a procedure. The latter "
981 "should be called with zero arguments to obtain a bytevector "
982 "containing the data accumulated by the port.")
983 #define FUNC_NAME scm_r6rs_open_bytevector_output_port
985 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
986 transcoders_not_implemented ();
988 return (make_bop ());
993 initialize_bytevector_output_ports (void)
995 bytevector_output_port_type
=
996 scm_make_port_type ("r6rs-bytevector-output-port",
999 scm_set_port_seek (bytevector_output_port_type
, bop_seek
);
1000 scm_set_port_free (bytevector_output_port_type
, bop_free
);
1004 /* Custom binary output port ("cbop" for short). */
1006 static scm_t_bits custom_binary_output_port_type
;
1008 /* Return the various procedures of PORT. */
1009 #define SCM_R6RS_CBOP_WRITE_PROC(_port) \
1010 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
1014 make_cbop (SCM write_proc
, SCM get_position_proc
,
1015 SCM set_position_proc
, SCM close_proc
)
1017 SCM port
, method_vector
;
1019 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
1021 /* Store the various methods and bytevector in a vector. */
1022 method_vector
= scm_c_make_vector (4, SCM_BOOL_F
);
1023 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, write_proc
);
1024 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
1025 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
1026 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
1028 port
= scm_new_port_table_entry (custom_binary_output_port_type
);
1030 /* Attach it the method vector. */
1031 SCM_SETSTREAM (port
, SCM_UNPACK (method_vector
));
1033 /* Have the port directly access the buffer (bytevector). */
1034 c_port
= SCM_PTAB_ENTRY (port
);
1035 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
1036 c_port
->write_buf_size
= c_port
->read_buf_size
= 0;
1038 /* Mark PORT as open, writable and unbuffered. */
1039 SCM_SET_CELL_TYPE (port
, custom_binary_output_port_type
| mode_bits
);
1044 /* Write SIZE octets from DATA to PORT. */
1046 cbop_write (SCM port
, const void *data
, size_t size
)
1047 #define FUNC_NAME "cbop_write"
1051 SCM bv
, write_proc
, result
;
1053 /* XXX: Allocating a new bytevector at each `write' call is inefficient,
1054 but necessary since (1) we don't control the lifetime of the buffer
1055 pointed to by DATA, and (2) the `write!' procedure could capture the
1056 bytevector it is passed. */
1057 bv
= scm_r6rs_c_make_bytevector (size
);
1058 memcpy (SCM_R6RS_BYTEVECTOR_CONTENTS (bv
), data
, size
);
1060 write_proc
= SCM_R6RS_CBOP_WRITE_PROC (port
);
1062 /* Since the `write' procedure of Guile's ports has type `void', it must
1063 try hard to write exactly SIZE bytes, regardless of how many bytes the
1067 c_written
+= c_result
)
1069 result
= scm_call_3 (write_proc
, bv
,
1070 scm_from_size_t (c_written
),
1071 scm_from_size_t (size
- c_written
));
1073 c_result
= scm_to_long (result
);
1074 if (SCM_UNLIKELY (c_result
< 0
1075 || (size_t) c_result
> (size
- c_written
)))
1076 scm_wrong_type_arg_msg (FUNC_NAME
, 0, result
,
1077 "R6RS custom binary output port `write!' "
1078 "returned a incorrect integer");
1084 SCM_DEFINE (scm_r6rs_make_custom_binary_output_port
,
1085 "make-custom-binary-output-port", 5, 0, 0,
1086 (SCM id
, SCM write_proc
, SCM get_position_proc
,
1087 SCM set_position_proc
, SCM close_proc
),
1088 "Return a new custom binary output port whose output is drained "
1089 "by invoking @var{write_proc} and passing it a bytevector, an "
1090 "index where octets should be written, and an octet count.")
1091 #define FUNC_NAME s_scm_r6rs_make_custom_binary_output_port
1093 SCM_VALIDATE_STRING (1, id
);
1094 SCM_VALIDATE_PROC (2, write_proc
);
1096 if (!scm_is_false (get_position_proc
))
1097 SCM_VALIDATE_PROC (3, get_position_proc
);
1099 if (!scm_is_false (set_position_proc
))
1100 SCM_VALIDATE_PROC (4, set_position_proc
);
1102 if (!scm_is_false (close_proc
))
1103 SCM_VALIDATE_PROC (5, close_proc
);
1105 return (make_cbop (write_proc
, get_position_proc
, set_position_proc
,
1111 /* Instantiate the custom binary output port type. */
1113 initialize_custom_binary_output_ports (void)
1115 custom_binary_output_port_type
=
1116 scm_make_port_type ("r6rs-custom-binary-output-port",
1119 scm_set_port_mark (custom_binary_output_port_type
, cbp_mark
);
1120 scm_set_port_seek (custom_binary_output_port_type
, cbp_seek
);
1121 scm_set_port_close (custom_binary_output_port_type
, cbp_close
);
1125 /* Initialization. */
1128 scm_init_r6rs_ports (void)
1132 initialize_bytevector_input_ports ();
1133 initialize_custom_binary_input_ports ();
1134 initialize_bytevector_output_ports ();
1135 initialize_custom_binary_output_ports ();