1 /* Copyright (C) 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
28 #include "libguile/_scm.h"
29 #include "libguile/bytevectors.h"
30 #include "libguile/chars.h"
31 #include "libguile/eval.h"
32 #include "libguile/r6rs-ports.h"
33 #include "libguile/strings.h"
34 #include "libguile/validate.h"
35 #include "libguile/values.h"
36 #include "libguile/vectors.h"
37 #include "libguile/ports-internal.h"
41 /* Unimplemented features. */
44 /* Transoders are currently not implemented since Guile 1.8 is not
45 Unicode-capable. Thus, most of the code here assumes the use of the
48 transcoders_not_implemented (void)
50 fprintf (stderr
, "%s: warning: transcoders not implemented\n",
55 /* End-of-file object. */
57 SCM_DEFINE (scm_eof_object
, "eof-object", 0, 0, 0,
59 "Return the end-of-file object.")
60 #define FUNC_NAME s_scm_eof_object
70 # define MIN(a,b) ((a) < (b) ? (a) : (b))
73 /* Bytevector input ports or "bip" for short. */
74 static scm_t_bits bytevector_input_port_type
= 0;
83 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
;
85 port
= scm_c_make_port_with_encoding (bytevector_input_port_type
,
88 SCM_FAILED_CONVERSION_ERROR
,
91 c_port
= SCM_PTAB_ENTRY (port
);
93 /* Have the port directly access the bytevector. */
94 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
95 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
97 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
98 c_port
->read_end
= (unsigned char *) c_bv
+ c_len
;
99 c_port
->read_buf_size
= c_len
;
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
;
119 bip_seek (SCM port
, scm_t_off offset
, int whence
)
120 #define FUNC_NAME "bip_seek"
122 scm_t_off c_result
= 0;
123 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
128 offset
+= c_port
->read_pos
- c_port
->read_buf
;
132 if (c_port
->read_buf
+ offset
<= c_port
->read_end
)
134 c_port
->read_pos
= c_port
->read_buf
+ offset
;
138 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
142 if (c_port
->read_end
- offset
>= c_port
->read_buf
)
144 c_port
->read_pos
= c_port
->read_end
- offset
;
145 c_result
= c_port
->read_pos
- c_port
->read_buf
;
148 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
152 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
153 "invalid `seek' parameter");
161 /* Instantiate the bytevector input port type. */
163 initialize_bytevector_input_ports (void)
165 bytevector_input_port_type
=
166 scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input
,
169 scm_set_port_seek (bytevector_input_port_type
, bip_seek
);
173 SCM_DEFINE (scm_open_bytevector_input_port
,
174 "open-bytevector-input-port", 1, 1, 0,
175 (SCM bv
, SCM transcoder
),
176 "Return an input port whose contents are drawn from "
177 "bytevector @var{bv}.")
178 #define FUNC_NAME s_scm_open_bytevector_input_port
180 SCM_VALIDATE_BYTEVECTOR (1, bv
);
181 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
182 transcoders_not_implemented ();
184 return (make_bip (bv
));
189 /* Custom binary ports. The following routines are shared by input and
190 output custom binary ports. */
192 #define SCM_CBP_GET_POSITION_PROC(_port) \
193 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
194 #define SCM_CBP_SET_POSITION_PROC(_port) \
195 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
196 #define SCM_CBP_CLOSE_PROC(_port) \
197 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
200 cbp_seek (SCM port
, scm_t_off offset
, int whence
)
201 #define FUNC_NAME "cbp_seek"
204 scm_t_off c_result
= 0;
210 SCM get_position_proc
;
212 get_position_proc
= SCM_CBP_GET_POSITION_PROC (port
);
213 if (SCM_LIKELY (scm_is_true (get_position_proc
)))
214 result
= scm_call_0 (get_position_proc
);
216 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
217 "R6RS custom binary port with "
218 "`port-position' support");
219 c_result
= scm_to_int (result
);
221 /* We just want to know the current position. */
230 SCM set_position_proc
;
232 set_position_proc
= SCM_CBP_SET_POSITION_PROC (port
);
233 if (SCM_LIKELY (scm_is_true (set_position_proc
)))
234 result
= scm_call_1 (set_position_proc
, scm_from_int (offset
));
236 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
237 "seekable R6RS custom binary port");
239 /* Assuming setting the position succeeded. */
245 /* `SEEK_END' cannot be supported. */
246 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
247 "R6RS custom binary ports do not "
248 "support `SEEK_END'");
260 close_proc
= SCM_CBP_CLOSE_PROC (port
);
261 if (scm_is_true (close_proc
))
262 /* Invoke the `close' thunk. */
263 scm_call_0 (close_proc
);
269 /* Custom binary input port ("cbip" for short). */
271 static scm_t_bits custom_binary_input_port_type
= 0;
273 /* Initial size of the buffer embedded in custom binary input ports. */
274 #define CBIP_BUFFER_SIZE 8192
276 /* Return the bytevector associated with PORT. */
277 #define SCM_CBIP_BYTEVECTOR(_port) \
278 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
280 /* Set BV as the bytevector associated with PORT. */
281 #define SCM_SET_CBIP_BYTEVECTOR(_port, _bv) \
282 SCM_SIMPLE_VECTOR_SET (SCM_PACK (SCM_STREAM (_port)), 4, (_bv))
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)
289 /* Set PORT's internal buffer according to READ_SIZE. */
291 cbip_setvbuf (SCM port
, long read_size
, long write_size
)
296 pt
= SCM_PTAB_ENTRY (port
);
297 bv
= SCM_CBIP_BYTEVECTOR (port
);
302 /* Unbuffered: keep PORT's bytevector as is (it will be used in
303 future 'scm_c_read' calls), but point to the one-byte buffer. */
304 pt
->read_buf
= &pt
->shortbuf
;
305 pt
->read_buf_size
= 1;
309 /* Preferred size: keep the current bytevector and use it as the
311 pt
->read_buf
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
312 pt
->read_buf_size
= SCM_BYTEVECTOR_LENGTH (bv
);
316 /* Fully buffered: allocate a buffer of READ_SIZE bytes. */
317 bv
= scm_c_make_bytevector (read_size
);
318 SCM_SET_CBIP_BYTEVECTOR (port
, bv
);
319 pt
->read_buf
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
320 pt
->read_buf_size
= read_size
;
323 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
327 make_cbip (SCM read_proc
, SCM get_position_proc
,
328 SCM set_position_proc
, SCM close_proc
)
330 SCM port
, bv
, method_vector
;
334 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
;
336 /* Use a bytevector as the underlying buffer. */
337 c_len
= CBIP_BUFFER_SIZE
;
338 bv
= scm_c_make_bytevector (c_len
);
339 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
341 /* Store the various methods and bytevector in a vector. */
342 method_vector
= scm_c_make_vector (5, SCM_BOOL_F
);
343 SCM_SIMPLE_VECTOR_SET (method_vector
, 4, bv
);
344 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, read_proc
);
345 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
346 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
347 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
349 port
= scm_c_make_port_with_encoding (custom_binary_input_port_type
,
352 SCM_FAILED_CONVERSION_ERROR
,
353 SCM_UNPACK (method_vector
));
355 c_port
= SCM_PTAB_ENTRY (port
);
357 /* Have the port directly access the buffer (bytevector). */
358 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
359 c_port
->read_end
= (unsigned char *) c_bv
;
360 c_port
->read_buf_size
= c_len
;
366 cbip_fill_input (SCM port
)
367 #define FUNC_NAME "cbip_fill_input"
370 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
372 if (c_port
->read_pos
>= c_port
->read_end
)
374 /* Invoke the user's `read!' procedure. */
376 size_t c_octets
, c_requested
;
377 SCM bv
, read_proc
, octets
;
379 c_requested
= c_port
->read_buf_size
;
380 read_proc
= SCM_CBIP_READ_PROC (port
);
382 bv
= SCM_CBIP_BYTEVECTOR (port
);
384 (c_port
->read_buf
== (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
));
388 /* Make sure the buffer isn't corrupt. BV can be passed directly
390 assert (c_port
->read_buf_size
== SCM_BYTEVECTOR_LENGTH (bv
));
391 c_port
->read_pos
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
395 /* This is an unbuffered port. When called via the
396 'get-bytevector-*' procedures, and thus via 'scm_c_read', we
397 are passed the caller-provided buffer, so we need to check its
399 if (SCM_BYTEVECTOR_LENGTH (bv
) < c_requested
)
401 /* Bad luck: we have to make another allocation. Save that
402 bytevector for later reuse, in the hope that the application
403 has regular access patterns. */
404 bv
= scm_c_make_bytevector (c_requested
);
405 SCM_SET_CBIP_BYTEVECTOR (port
, bv
);
409 octets
= scm_call_3 (read_proc
, bv
, SCM_INUM0
,
410 scm_from_size_t (c_requested
));
411 c_octets
= scm_to_size_t (octets
);
412 if (SCM_UNLIKELY (c_octets
> c_requested
))
413 scm_out_of_range (FUNC_NAME
, octets
);
416 /* Copy the data back to the internal buffer. */
417 memcpy ((char *) c_port
->read_pos
, SCM_BYTEVECTOR_CONTENTS (bv
),
420 c_port
->read_end
= (unsigned char *) c_port
->read_pos
+ c_octets
;
422 if (c_octets
!= 0 || c_requested
== 0)
423 result
= (int) *c_port
->read_pos
;
428 result
= (int) *c_port
->read_pos
;
435 SCM_DEFINE (scm_make_custom_binary_input_port
,
436 "make-custom-binary-input-port", 5, 0, 0,
437 (SCM id
, SCM read_proc
, SCM get_position_proc
,
438 SCM set_position_proc
, SCM close_proc
),
439 "Return a new custom binary input port whose input is drained "
440 "by invoking @var{read_proc} and passing it a bytevector, an "
441 "index where octets should be written, and an octet count.")
442 #define FUNC_NAME s_scm_make_custom_binary_input_port
444 SCM_VALIDATE_STRING (1, id
);
445 SCM_VALIDATE_PROC (2, read_proc
);
447 if (!scm_is_false (get_position_proc
))
448 SCM_VALIDATE_PROC (3, get_position_proc
);
450 if (!scm_is_false (set_position_proc
))
451 SCM_VALIDATE_PROC (4, set_position_proc
);
453 if (!scm_is_false (close_proc
))
454 SCM_VALIDATE_PROC (5, close_proc
);
456 return (make_cbip (read_proc
, get_position_proc
, set_position_proc
,
462 /* Instantiate the custom binary input port type. */
464 initialize_custom_binary_input_ports (void)
466 custom_binary_input_port_type
=
467 scm_make_port_type ("r6rs-custom-binary-input-port",
468 cbip_fill_input
, NULL
);
470 scm_set_port_seek (custom_binary_input_port_type
, cbp_seek
);
471 scm_set_port_close (custom_binary_input_port_type
, cbp_close
);
472 scm_set_port_setvbuf (custom_binary_input_port_type
, cbip_setvbuf
);
479 /* We currently don't support specific binary input ports. */
480 #define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
482 SCM_DEFINE (scm_get_u8
, "get-u8", 1, 0, 0,
484 "Read an octet from @var{port}, a binary input port, "
485 "blocking as necessary.")
486 #define FUNC_NAME s_scm_get_u8
491 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
493 c_result
= scm_get_byte_or_eof (port
);
495 result
= SCM_EOF_VAL
;
497 result
= SCM_I_MAKINUM ((unsigned char) c_result
);
503 SCM_DEFINE (scm_lookahead_u8
, "lookahead-u8", 1, 0, 0,
505 "Like @code{get-u8} but does not update @var{port} to "
506 "point past the octet.")
507 #define FUNC_NAME s_scm_lookahead_u8
512 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
514 u8
= scm_peek_byte_or_eof (port
);
516 result
= SCM_EOF_VAL
;
518 result
= SCM_I_MAKINUM ((scm_t_uint8
) u8
);
524 SCM_DEFINE (scm_get_bytevector_n
, "get-bytevector-n", 2, 0, 0,
525 (SCM port
, SCM count
),
526 "Read @var{count} octets from @var{port}, blocking as "
527 "necessary and return a bytevector containing the octets "
528 "read. If fewer bytes are available, a bytevector smaller "
529 "than @var{count} is returned.")
530 #define FUNC_NAME s_scm_get_bytevector_n
537 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
538 c_count
= scm_to_uint (count
);
540 result
= scm_c_make_bytevector (c_count
);
541 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (result
);
543 if (SCM_LIKELY (c_count
> 0))
544 /* XXX: `scm_c_read ()' does not update the port position. */
545 c_read
= scm_c_read_unlocked (port
, c_bv
, c_count
);
547 /* Don't invoke `scm_c_read ()' since it may block. */
550 if (c_read
< c_count
)
553 result
= SCM_EOF_VAL
;
555 result
= scm_c_shrink_bytevector (result
, c_read
);
562 SCM_DEFINE (scm_get_bytevector_n_x
, "get-bytevector-n!", 4, 0, 0,
563 (SCM port
, SCM bv
, SCM start
, SCM count
),
564 "Read @var{count} bytes from @var{port} and store them "
565 "in @var{bv} starting at index @var{start}. Return either "
566 "the number of bytes actually read or the end-of-file "
568 #define FUNC_NAME s_scm_get_bytevector_n_x
572 unsigned c_start
, c_count
, c_len
;
575 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
576 SCM_VALIDATE_BYTEVECTOR (2, bv
);
577 c_start
= scm_to_uint (start
);
578 c_count
= scm_to_uint (count
);
580 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
581 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
583 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
584 scm_out_of_range (FUNC_NAME
, count
);
586 if (SCM_LIKELY (c_count
> 0))
587 c_read
= scm_c_read_unlocked (port
, c_bv
+ c_start
, c_count
);
589 /* Don't invoke `scm_c_read ()' since it may block. */
592 if (c_read
== 0 && c_count
> 0)
593 result
= SCM_EOF_VAL
;
595 result
= scm_from_size_t (c_read
);
602 SCM_DEFINE (scm_get_bytevector_some
, "get-bytevector-some", 1, 0, 0,
604 "Read from @var{port}, blocking as necessary, until bytes "
605 "are available or an end-of-file is reached. Return either "
606 "the end-of-file object or a new bytevector containing some "
607 "of the available bytes (at least one), and update the port "
608 "position to point just past these bytes.")
609 #define FUNC_NAME s_scm_get_bytevector_some
615 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
616 pt
= SCM_PTAB_ENTRY (port
);
618 if (pt
->rw_active
== SCM_PORT_WRITE
)
619 scm_flush_unlocked (port
);
622 pt
->rw_active
= SCM_PORT_READ
;
624 if (pt
->read_pos
>= pt
->read_end
)
626 if (scm_fill_input_unlocked (port
) == EOF
)
630 size
= pt
->read_end
- pt
->read_pos
;
631 if (pt
->read_buf
== pt
->putback_buf
)
632 size
+= pt
->saved_read_end
- pt
->saved_read_pos
;
634 bv
= scm_c_make_bytevector (size
);
635 scm_take_from_input_buffers
636 (port
, (char *) SCM_BYTEVECTOR_CONTENTS (bv
), size
);
642 SCM_DEFINE (scm_get_bytevector_all
, "get-bytevector-all", 1, 0, 0,
644 "Read from @var{port}, blocking as necessary, until "
645 "the end-of-file is reached. Return either "
646 "a new bytevector containing the data read or the "
647 "end-of-file object (if no data were available).")
648 #define FUNC_NAME s_scm_get_bytevector_all
652 unsigned c_len
, c_count
;
653 size_t c_read
, c_total
;
655 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
657 c_len
= c_count
= 4096;
658 c_bv
= (char *) scm_gc_malloc_pointerless (c_len
, SCM_GC_BYTEVECTOR
);
659 c_total
= c_read
= 0;
663 if (c_total
+ c_read
> c_len
)
665 /* Grow the bytevector. */
666 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_len
* 2,
672 /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
674 c_read
= scm_c_read_unlocked (port
, c_bv
+ c_total
, c_count
);
675 c_total
+= c_read
, c_count
-= c_read
;
677 while (c_count
== 0);
681 result
= SCM_EOF_VAL
;
682 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
688 /* Shrink the bytevector. */
689 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_total
,
691 c_len
= (unsigned) c_total
;
694 result
= scm_c_take_gc_bytevector ((signed char *) c_bv
, c_len
,
706 /* We currently don't support specific binary input ports. */
707 #define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
710 SCM_DEFINE (scm_put_u8
, "put-u8", 2, 0, 0,
711 (SCM port
, SCM octet
),
712 "Write @var{octet} to binary port @var{port}.")
713 #define FUNC_NAME s_scm_put_u8
717 SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port
);
718 c_octet
= scm_to_uint8 (octet
);
720 scm_putc_unlocked ((char) c_octet
, port
);
722 return SCM_UNSPECIFIED
;
726 SCM_DEFINE (scm_put_bytevector
, "put-bytevector", 2, 2, 0,
727 (SCM port
, SCM bv
, SCM start
, SCM count
),
728 "Write the contents of @var{bv} to @var{port}, optionally "
729 "starting at index @var{start} and limiting to @var{count} "
731 #define FUNC_NAME s_scm_put_bytevector
734 unsigned c_start
, c_count
, c_len
;
736 SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port
);
737 SCM_VALIDATE_BYTEVECTOR (2, bv
);
739 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
740 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
742 if (!scm_is_eq (start
, SCM_UNDEFINED
))
744 c_start
= scm_to_uint (start
);
746 if (!scm_is_eq (count
, SCM_UNDEFINED
))
748 c_count
= scm_to_uint (count
);
749 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
750 scm_out_of_range (FUNC_NAME
, count
);
754 if (SCM_UNLIKELY (c_start
>= c_len
))
755 scm_out_of_range (FUNC_NAME
, start
);
757 c_count
= c_len
- c_start
;
761 c_start
= 0, c_count
= c_len
;
763 scm_c_write_unlocked (port
, c_bv
+ c_start
, c_count
);
765 return SCM_UNSPECIFIED
;
769 SCM_DEFINE (scm_unget_bytevector
, "unget-bytevector", 2, 2, 0,
770 (SCM port
, SCM bv
, SCM start
, SCM count
),
771 "Unget the contents of @var{bv} to @var{port}, optionally "
772 "starting at index @var{start} and limiting to @var{count} "
774 #define FUNC_NAME s_scm_unget_bytevector
777 size_t c_start
, c_count
, c_len
;
779 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
780 SCM_VALIDATE_BYTEVECTOR (2, bv
);
782 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
783 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
785 if (!scm_is_eq (start
, SCM_UNDEFINED
))
787 c_start
= scm_to_size_t (start
);
789 if (!scm_is_eq (count
, SCM_UNDEFINED
))
791 c_count
= scm_to_size_t (count
);
792 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
793 scm_out_of_range (FUNC_NAME
, count
);
797 if (SCM_UNLIKELY (c_start
>= c_len
))
798 scm_out_of_range (FUNC_NAME
, start
);
800 c_count
= c_len
- c_start
;
804 c_start
= 0, c_count
= c_len
;
806 scm_unget_bytes (c_bv
+ c_start
, c_count
, port
);
808 return SCM_UNSPECIFIED
;
814 /* Bytevector output port ("bop" for short). */
816 /* Implementation of "bops".
818 Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
819 it. The procedure returned along with the output port is actually an
820 applicable SMOB. The SMOB holds a reference to the port. When applied,
821 the SMOB swallows the port's internal buffer, turning it into a
822 bytevector, and resets it.
824 XXX: Access to a bop's internal buffer is not thread-safe. */
826 static scm_t_bits bytevector_output_port_type
= 0;
828 SCM_SMOB (bytevector_output_port_procedure
,
829 "r6rs-bytevector-output-port-procedure",
832 #define SCM_GC_BOP "r6rs-bytevector-output-port"
833 #define SCM_BOP_BUFFER_INITIAL_SIZE 4096
835 /* Representation of a bop's internal buffer. */
845 /* Accessing a bop's buffer. */
846 #define SCM_BOP_BUFFER(_port) \
847 ((scm_t_bop_buffer *) SCM_STREAM (_port))
848 #define SCM_SET_BOP_BUFFER(_port, _buf) \
849 (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
853 bop_buffer_init (scm_t_bop_buffer
*buf
)
855 buf
->total_len
= buf
->len
= buf
->pos
= 0;
860 bop_buffer_grow (scm_t_bop_buffer
*buf
, size_t min_size
)
865 for (new_size
= buf
->total_len
866 ? buf
->total_len
: SCM_BOP_BUFFER_INITIAL_SIZE
;
871 new_buf
= scm_gc_realloc ((void *) buf
->buffer
, buf
->total_len
,
872 new_size
, SCM_GC_BOP
);
874 new_buf
= scm_gc_malloc_pointerless (new_size
, SCM_GC_BOP
);
876 buf
->buffer
= new_buf
;
877 buf
->total_len
= new_size
;
885 scm_t_bop_buffer
*buf
;
886 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
888 buf
= (scm_t_bop_buffer
*) scm_gc_malloc (sizeof (* buf
), SCM_GC_BOP
);
889 bop_buffer_init (buf
);
891 port
= scm_c_make_port_with_encoding (bytevector_output_port_type
,
894 SCM_FAILED_CONVERSION_ERROR
,
897 c_port
= SCM_PTAB_ENTRY (port
);
899 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
900 c_port
->write_buf_size
= 0;
902 /* Make the bop procedure. */
903 SCM_NEWSMOB (bop_proc
, bytevector_output_port_procedure
, buf
);
905 return (scm_values (scm_list_2 (port
, bop_proc
)));
908 /* Write SIZE octets from DATA to PORT. */
910 bop_write (SCM port
, const void *data
, size_t size
)
912 scm_t_bop_buffer
*buf
;
914 buf
= SCM_BOP_BUFFER (port
);
916 if (buf
->pos
+ size
> buf
->total_len
)
917 bop_buffer_grow (buf
, buf
->pos
+ size
);
919 memcpy (buf
->buffer
+ buf
->pos
, data
, size
);
921 buf
->len
= (buf
->len
> buf
->pos
) ? buf
->len
: buf
->pos
;
925 bop_seek (SCM port
, scm_t_off offset
, int whence
)
926 #define FUNC_NAME "bop_seek"
928 scm_t_bop_buffer
*buf
;
930 buf
= SCM_BOP_BUFFER (port
);
934 offset
+= (scm_t_off
) buf
->pos
;
938 if (offset
< 0 || (unsigned) offset
> buf
->len
)
939 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
945 if (offset
< 0 || (unsigned) offset
>= buf
->len
)
946 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
948 buf
->pos
= buf
->len
- (offset
+ 1);
952 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
953 "invalid `seek' parameter");
960 /* Fetch data from a bop. */
961 SCM_SMOB_APPLY (bytevector_output_port_procedure
,
962 bop_proc_apply
, 0, 0, 0, (SCM bop_proc
))
965 scm_t_bop_buffer
*buf
, result_buf
;
967 buf
= (scm_t_bop_buffer
*) SCM_SMOB_DATA (bop_proc
);
970 bop_buffer_init (buf
);
972 if (result_buf
.len
== 0)
973 bv
= scm_c_take_gc_bytevector (NULL
, 0, SCM_BOOL_F
);
976 if (result_buf
.total_len
> result_buf
.len
)
977 /* Shrink the buffer. */
978 result_buf
.buffer
= scm_gc_realloc ((void *) result_buf
.buffer
,
979 result_buf
.total_len
,
983 bv
= scm_c_take_gc_bytevector ((signed char *) result_buf
.buffer
,
984 result_buf
.len
, SCM_BOOL_F
);
990 SCM_DEFINE (scm_open_bytevector_output_port
,
991 "open-bytevector-output-port", 0, 1, 0,
993 "Return two values: an output port and a procedure. The latter "
994 "should be called with zero arguments to obtain a bytevector "
995 "containing the data accumulated by the port.")
996 #define FUNC_NAME s_scm_open_bytevector_output_port
998 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
999 transcoders_not_implemented ();
1001 return (make_bop ());
1006 initialize_bytevector_output_ports (void)
1008 bytevector_output_port_type
=
1009 scm_make_port_type ("r6rs-bytevector-output-port",
1012 scm_set_port_seek (bytevector_output_port_type
, bop_seek
);
1016 /* Custom binary output port ("cbop" for short). */
1018 static scm_t_bits custom_binary_output_port_type
;
1020 /* Return the various procedures of PORT. */
1021 #define SCM_CBOP_WRITE_PROC(_port) \
1022 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
1026 make_cbop (SCM write_proc
, SCM get_position_proc
,
1027 SCM set_position_proc
, SCM close_proc
)
1029 SCM port
, method_vector
;
1031 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
1033 /* Store the various methods and bytevector in a vector. */
1034 method_vector
= scm_c_make_vector (4, SCM_BOOL_F
);
1035 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, write_proc
);
1036 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
1037 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
1038 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
1040 port
= scm_c_make_port_with_encoding (custom_binary_output_port_type
,
1042 NULL
, /* encoding */
1043 SCM_FAILED_CONVERSION_ERROR
,
1044 SCM_UNPACK (method_vector
));
1046 c_port
= SCM_PTAB_ENTRY (port
);
1048 /* Have the port directly access the buffer (bytevector). */
1049 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
1050 c_port
->write_buf_size
= c_port
->read_buf_size
= 0;
1055 /* Write SIZE octets from DATA to PORT. */
1057 cbop_write (SCM port
, const void *data
, size_t size
)
1058 #define FUNC_NAME "cbop_write"
1062 SCM bv
, write_proc
, result
;
1064 /* XXX: Allocating a new bytevector at each `write' call is inefficient,
1065 but necessary since (1) we don't control the lifetime of the buffer
1066 pointed to by DATA, and (2) the `write!' procedure could capture the
1067 bytevector it is passed. */
1068 bv
= scm_c_make_bytevector (size
);
1069 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), data
, size
);
1071 write_proc
= SCM_CBOP_WRITE_PROC (port
);
1073 /* Since the `write' procedure of Guile's ports has type `void', it must
1074 try hard to write exactly SIZE bytes, regardless of how many bytes the
1078 c_written
+= c_result
)
1080 result
= scm_call_3 (write_proc
, bv
,
1081 scm_from_size_t (c_written
),
1082 scm_from_size_t (size
- c_written
));
1084 c_result
= scm_to_long (result
);
1085 if (SCM_UNLIKELY (c_result
< 0
1086 || (size_t) c_result
> (size
- c_written
)))
1087 scm_wrong_type_arg_msg (FUNC_NAME
, 0, result
,
1088 "R6RS custom binary output port `write!' "
1089 "returned a incorrect integer");
1095 SCM_DEFINE (scm_make_custom_binary_output_port
,
1096 "make-custom-binary-output-port", 5, 0, 0,
1097 (SCM id
, SCM write_proc
, SCM get_position_proc
,
1098 SCM set_position_proc
, SCM close_proc
),
1099 "Return a new custom binary output port whose output is drained "
1100 "by invoking @var{write_proc} and passing it a bytevector, an "
1101 "index where octets should be written, and an octet count.")
1102 #define FUNC_NAME s_scm_make_custom_binary_output_port
1104 SCM_VALIDATE_STRING (1, id
);
1105 SCM_VALIDATE_PROC (2, write_proc
);
1107 if (!scm_is_false (get_position_proc
))
1108 SCM_VALIDATE_PROC (3, get_position_proc
);
1110 if (!scm_is_false (set_position_proc
))
1111 SCM_VALIDATE_PROC (4, set_position_proc
);
1113 if (!scm_is_false (close_proc
))
1114 SCM_VALIDATE_PROC (5, close_proc
);
1116 return (make_cbop (write_proc
, get_position_proc
, set_position_proc
,
1122 /* Instantiate the custom binary output port type. */
1124 initialize_custom_binary_output_ports (void)
1126 custom_binary_output_port_type
=
1127 scm_make_port_type ("r6rs-custom-binary-output-port",
1130 scm_set_port_seek (custom_binary_output_port_type
, cbp_seek
);
1131 scm_set_port_close (custom_binary_output_port_type
, cbp_close
);
1135 /* Transcoded ports ("tp" for short). */
1136 static scm_t_bits transcoded_port_type
= 0;
1138 #define TP_INPUT_BUFFER_SIZE 4096
1140 #define SCM_TP_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port))
1143 make_tp (SCM binary_port
, unsigned long mode
)
1147 const unsigned long mode_bits
= SCM_OPN
| mode
;
1149 port
= scm_c_make_port (transcoded_port_type
, mode_bits
,
1150 SCM_UNPACK (binary_port
));
1152 if (SCM_INPUT_PORT_P (port
))
1154 c_port
= SCM_PTAB_ENTRY (port
);
1155 c_port
->read_buf
= scm_gc_malloc_pointerless (TP_INPUT_BUFFER_SIZE
,
1157 c_port
->read_pos
= c_port
->read_end
= c_port
->read_buf
;
1158 c_port
->read_buf_size
= TP_INPUT_BUFFER_SIZE
;
1160 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
1167 tp_write (SCM port
, const void *data
, size_t size
)
1169 scm_c_write_unlocked (SCM_TP_BINARY_PORT (port
), data
, size
);
1173 tp_fill_input (SCM port
)
1176 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
1177 SCM bport
= SCM_TP_BINARY_PORT (port
);
1178 scm_t_port
*c_bport
= SCM_PTAB_ENTRY (bport
);
1180 /* We can't use `scm_c_read' here, since it blocks until the whole
1181 block has been read or EOF. */
1183 if (c_bport
->rw_active
== SCM_PORT_WRITE
)
1184 scm_force_output (bport
);
1186 if (c_bport
->read_pos
>= c_bport
->read_end
)
1187 scm_fill_input_unlocked (bport
);
1189 count
= c_bport
->read_end
- c_bport
->read_pos
;
1190 if (count
> c_port
->read_buf_size
)
1191 count
= c_port
->read_buf_size
;
1193 memcpy (c_port
->read_buf
, c_bport
->read_pos
, count
);
1194 c_bport
->read_pos
+= count
;
1196 if (c_bport
->rw_random
)
1197 c_bport
->rw_active
= SCM_PORT_READ
;
1203 c_port
->read_pos
= c_port
->read_buf
;
1204 c_port
->read_end
= c_port
->read_buf
+ count
;
1205 return *c_port
->read_buf
;
1212 SCM binary_port
= SCM_TP_BINARY_PORT (port
);
1213 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
1214 size_t count
= c_port
->write_pos
- c_port
->write_buf
;
1216 /* As the runtime will try to flush all ports upon exit, we test for
1217 the underlying port still being open here. Otherwise, when you
1218 would explicitly close the underlying port and the transcoded port
1219 still had data outstanding, you'd get an exception on Guile exit.
1221 We just throw away the data when the underlying port is closed. */
1223 if (SCM_OPOUTPORTP (binary_port
))
1224 scm_c_write_unlocked (binary_port
, c_port
->write_buf
, count
);
1226 c_port
->write_pos
= c_port
->write_buf
;
1227 c_port
->rw_active
= SCM_PORT_NEITHER
;
1229 if (SCM_OPOUTPORTP (binary_port
))
1230 scm_force_output (binary_port
);
1236 if (SCM_OUTPUT_PORT_P (port
))
1238 return scm_is_true (scm_close_port (SCM_TP_BINARY_PORT (port
))) ? 0 : -1;
1242 initialize_transcoded_ports (void)
1244 transcoded_port_type
=
1245 scm_make_port_type ("r6rs-transcoded-port", tp_fill_input
, tp_write
);
1247 scm_set_port_flush (transcoded_port_type
, tp_flush
);
1248 scm_set_port_close (transcoded_port_type
, tp_close
);
1251 SCM_INTERNAL SCM
scm_i_make_transcoded_port (SCM
);
1253 SCM_DEFINE (scm_i_make_transcoded_port
,
1254 "%make-transcoded-port", 1, 0, 0,
1256 "Return a new port which reads and writes to @var{port}")
1257 #define FUNC_NAME s_scm_i_make_transcoded_port
1260 unsigned long mode
= 0;
1262 SCM_VALIDATE_PORT (SCM_ARG1
, port
);
1264 if (scm_is_true (scm_output_port_p (port
)))
1266 else if (scm_is_true (scm_input_port_p (port
)))
1269 result
= make_tp (port
, mode
);
1271 /* FIXME: We should actually close `port' "in a special way" here,
1272 according to R6RS. As there is no way to do that in Guile without
1273 rendering the underlying port unusable for our purposes as well, we
1274 just leave it open. */
1283 SCM_DEFINE (scm_get_string_n_x
,
1284 "get-string-n!", 4, 0, 0,
1285 (SCM port
, SCM str
, SCM start
, SCM count
),
1286 "Read up to @var{count} characters from @var{port} into "
1287 "@var{str}, starting at @var{start}. If no characters "
1288 "can be read before the end of file is encountered, the end "
1289 "of file object is returned. Otherwise, the number of "
1290 "characters read is returned.")
1291 #define FUNC_NAME s_scm_get_string_n_x
1293 size_t c_start
, c_count
, c_len
, c_end
, j
;
1296 SCM_VALIDATE_OPINPORT (1, port
);
1297 SCM_VALIDATE_STRING (2, str
);
1298 c_len
= scm_c_string_length (str
);
1299 c_start
= scm_to_size_t (start
);
1300 c_count
= scm_to_size_t (count
);
1301 c_end
= c_start
+ c_count
;
1303 if (SCM_UNLIKELY (c_end
> c_len
))
1304 scm_out_of_range (FUNC_NAME
, count
);
1306 for (j
= c_start
; j
< c_end
; j
++)
1308 c
= scm_getc_unlocked (port
);
1311 size_t chars_read
= j
- c_start
;
1312 return chars_read
== 0 ? SCM_EOF_VAL
: scm_from_size_t (chars_read
);
1314 scm_c_string_set_x (str
, j
, SCM_MAKE_CHAR (c
));
1321 /* Initialization. */
1324 scm_register_r6rs_ports (void)
1326 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1327 "scm_init_r6rs_ports",
1328 (scm_t_extension_init_func
) scm_init_r6rs_ports
,
1333 scm_init_r6rs_ports (void)
1335 #include "libguile/r6rs-ports.x"
1337 initialize_bytevector_input_ports ();
1338 initialize_custom_binary_input_ports ();
1339 initialize_bytevector_output_ports ();
1340 initialize_custom_binary_output_ports ();
1341 initialize_transcoded_ports ();