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
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"
40 #include "libguile/ports-internal.h"
44 /* Unimplemented features. */
47 /* Transoders are currently not implemented since Guile 1.8 is not
48 Unicode-capable. Thus, most of the code here assumes the use of the
51 transcoders_not_implemented (void)
53 fprintf (stderr
, "%s: warning: transcoders not implemented\n",
58 /* End-of-file object. */
60 SCM_DEFINE (scm_eof_object
, "eof-object", 0, 0, 0,
62 "Return the end-of-file object.")
63 #define FUNC_NAME s_scm_eof_object
73 # define MIN(a,b) ((a) < (b) ? (a) : (b))
76 /* Bytevector input ports or "bip" for short. */
77 static scm_t_bits bytevector_input_port_type
= 0;
86 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
;
88 port
= scm_c_make_port_with_encoding (bytevector_input_port_type
,
91 SCM_FAILED_CONVERSION_ERROR
,
94 c_port
= SCM_PTAB_ENTRY (port
);
96 /* Have the port directly access the bytevector. */
97 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
98 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
100 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
101 c_port
->read_end
= (unsigned char *) c_bv
+ c_len
;
102 c_port
->read_buf_size
= c_len
;
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
;
122 bip_seek (SCM port
, scm_t_off offset
, int whence
)
123 #define FUNC_NAME "bip_seek"
125 scm_t_off c_result
= 0;
126 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
131 offset
+= c_port
->read_pos
- c_port
->read_buf
;
135 if (c_port
->read_buf
+ offset
<= c_port
->read_end
)
137 c_port
->read_pos
= c_port
->read_buf
+ offset
;
141 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
145 if (c_port
->read_end
- offset
>= c_port
->read_buf
)
147 c_port
->read_pos
= c_port
->read_end
- offset
;
148 c_result
= c_port
->read_pos
- c_port
->read_buf
;
151 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
155 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
156 "invalid `seek' parameter");
164 /* Instantiate the bytevector input port type. */
166 initialize_bytevector_input_ports (void)
168 bytevector_input_port_type
=
169 scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input
,
172 scm_set_port_seek (bytevector_input_port_type
, bip_seek
);
176 SCM_DEFINE (scm_open_bytevector_input_port
,
177 "open-bytevector-input-port", 1, 1, 0,
178 (SCM bv
, SCM transcoder
),
179 "Return an input port whose contents are drawn from "
180 "bytevector @var{bv}.")
181 #define FUNC_NAME s_scm_open_bytevector_input_port
183 SCM_VALIDATE_BYTEVECTOR (1, bv
);
184 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
185 transcoders_not_implemented ();
187 return (make_bip (bv
));
192 /* Custom binary ports. The following routines are shared by input and
193 output custom binary ports. */
195 #define SCM_CBP_GET_POSITION_PROC(_port) \
196 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
197 #define SCM_CBP_SET_POSITION_PROC(_port) \
198 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
199 #define SCM_CBP_CLOSE_PROC(_port) \
200 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
203 cbp_seek (SCM port
, scm_t_off offset
, int whence
)
204 #define FUNC_NAME "cbp_seek"
207 scm_t_off c_result
= 0;
213 SCM get_position_proc
;
215 get_position_proc
= SCM_CBP_GET_POSITION_PROC (port
);
216 if (SCM_LIKELY (scm_is_true (get_position_proc
)))
217 result
= scm_call_0 (get_position_proc
);
219 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
220 "R6RS custom binary port with "
221 "`port-position' support");
222 c_result
= scm_to_int (result
);
224 /* We just want to know the current position. */
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 "seekable R6RS custom binary port");
242 /* Assuming setting the position succeeded. */
248 /* `SEEK_END' cannot be supported. */
249 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
250 "R6RS custom binary ports do not "
251 "support `SEEK_END'");
263 close_proc
= SCM_CBP_CLOSE_PROC (port
);
264 if (scm_is_true (close_proc
))
265 /* Invoke the `close' thunk. */
266 scm_call_0 (close_proc
);
272 /* Custom binary input port ("cbip" for short). */
274 static scm_t_bits custom_binary_input_port_type
= 0;
276 /* Initial size of the buffer embedded in custom binary input ports. */
277 #define CBIP_BUFFER_SIZE 8192
279 /* Return the bytevector associated with PORT. */
280 #define SCM_CBIP_BYTEVECTOR(_port) \
281 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
283 /* Set BV as the bytevector associated with PORT. */
284 #define SCM_SET_CBIP_BYTEVECTOR(_port, _bv) \
285 SCM_SIMPLE_VECTOR_SET (SCM_PACK (SCM_STREAM (_port)), 4, (_bv))
287 /* Return the various procedures of PORT. */
288 #define SCM_CBIP_READ_PROC(_port) \
289 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
292 /* Set PORT's internal buffer according to READ_SIZE. */
294 cbip_setvbuf (SCM port
, long read_size
, long write_size
)
299 pt
= SCM_PTAB_ENTRY (port
);
300 bv
= SCM_CBIP_BYTEVECTOR (port
);
305 /* Unbuffered: keep PORT's bytevector as is (it will be used in
306 future 'scm_c_read' calls), but point to the one-byte buffer. */
307 pt
->read_buf
= &pt
->shortbuf
;
308 pt
->read_buf_size
= 1;
312 /* Preferred size: keep the current bytevector and use it as the
314 pt
->read_buf
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
315 pt
->read_buf_size
= SCM_BYTEVECTOR_LENGTH (bv
);
319 /* Fully buffered: allocate a buffer of READ_SIZE bytes. */
320 bv
= scm_c_make_bytevector (read_size
);
321 SCM_SET_CBIP_BYTEVECTOR (port
, bv
);
322 pt
->read_buf
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
323 pt
->read_buf_size
= read_size
;
326 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
330 make_cbip (SCM read_proc
, SCM get_position_proc
,
331 SCM set_position_proc
, SCM close_proc
)
333 SCM port
, bv
, method_vector
;
337 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
;
339 /* Use a bytevector as the underlying buffer. */
340 c_len
= CBIP_BUFFER_SIZE
;
341 bv
= scm_c_make_bytevector (c_len
);
342 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
344 /* Store the various methods and bytevector in a vector. */
345 method_vector
= scm_c_make_vector (5, SCM_BOOL_F
);
346 SCM_SIMPLE_VECTOR_SET (method_vector
, 4, bv
);
347 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, read_proc
);
348 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
349 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
350 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
352 port
= scm_c_make_port_with_encoding (custom_binary_input_port_type
,
355 SCM_FAILED_CONVERSION_ERROR
,
356 SCM_UNPACK (method_vector
));
358 c_port
= SCM_PTAB_ENTRY (port
);
360 /* Have the port directly access the buffer (bytevector). */
361 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
362 c_port
->read_end
= (unsigned char *) c_bv
;
363 c_port
->read_buf_size
= c_len
;
369 cbip_fill_input (SCM port
)
370 #define FUNC_NAME "cbip_fill_input"
373 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
375 if (c_port
->read_pos
>= c_port
->read_end
)
377 /* Invoke the user's `read!' procedure. */
379 size_t c_octets
, c_requested
;
380 SCM bv
, read_proc
, octets
;
382 c_requested
= c_port
->read_buf_size
;
383 read_proc
= SCM_CBIP_READ_PROC (port
);
385 bv
= SCM_CBIP_BYTEVECTOR (port
);
387 (c_port
->read_buf
== (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
));
391 /* Make sure the buffer isn't corrupt. BV can be passed directly
393 assert (c_port
->read_buf_size
== SCM_BYTEVECTOR_LENGTH (bv
));
394 c_port
->read_pos
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
398 /* This is an unbuffered port. When called via the
399 'get-bytevector-*' procedures, and thus via 'scm_c_read', we
400 are passed the caller-provided buffer, so we need to check its
402 if (SCM_BYTEVECTOR_LENGTH (bv
) < c_requested
)
404 /* Bad luck: we have to make another allocation. Save that
405 bytevector for later reuse, in the hope that the application
406 has regular access patterns. */
407 bv
= scm_c_make_bytevector (c_requested
);
408 SCM_SET_CBIP_BYTEVECTOR (port
, bv
);
412 octets
= scm_call_3 (read_proc
, bv
, SCM_INUM0
,
413 scm_from_size_t (c_requested
));
414 c_octets
= scm_to_size_t (octets
);
415 if (SCM_UNLIKELY (c_octets
> c_requested
))
416 scm_out_of_range (FUNC_NAME
, octets
);
419 /* Copy the data back to the internal buffer. */
420 memcpy ((char *) c_port
->read_pos
, SCM_BYTEVECTOR_CONTENTS (bv
),
423 c_port
->read_end
= (unsigned char *) c_port
->read_pos
+ c_octets
;
425 if (c_octets
!= 0 || c_requested
== 0)
426 result
= (int) *c_port
->read_pos
;
431 result
= (int) *c_port
->read_pos
;
438 SCM_DEFINE (scm_make_custom_binary_input_port
,
439 "make-custom-binary-input-port", 5, 0, 0,
440 (SCM id
, SCM read_proc
, SCM get_position_proc
,
441 SCM set_position_proc
, SCM close_proc
),
442 "Return a new custom binary input port whose input is drained "
443 "by invoking @var{read_proc} and passing it a bytevector, an "
444 "index where octets should be written, and an octet count.")
445 #define FUNC_NAME s_scm_make_custom_binary_input_port
447 SCM_VALIDATE_STRING (1, id
);
448 SCM_VALIDATE_PROC (2, read_proc
);
450 if (!scm_is_false (get_position_proc
))
451 SCM_VALIDATE_PROC (3, get_position_proc
);
453 if (!scm_is_false (set_position_proc
))
454 SCM_VALIDATE_PROC (4, set_position_proc
);
456 if (!scm_is_false (close_proc
))
457 SCM_VALIDATE_PROC (5, close_proc
);
459 return (make_cbip (read_proc
, get_position_proc
, set_position_proc
,
465 /* Instantiate the custom binary input port type. */
467 initialize_custom_binary_input_ports (void)
469 custom_binary_input_port_type
=
470 scm_make_port_type ("r6rs-custom-binary-input-port",
471 cbip_fill_input
, NULL
);
473 scm_set_port_seek (custom_binary_input_port_type
, cbp_seek
);
474 scm_set_port_close (custom_binary_input_port_type
, cbp_close
);
475 scm_set_port_setvbuf (custom_binary_input_port_type
, cbip_setvbuf
);
482 /* We currently don't support specific binary input ports. */
483 #define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
485 SCM_DEFINE (scm_get_u8
, "get-u8", 1, 0, 0,
487 "Read an octet from @var{port}, a binary input port, "
488 "blocking as necessary.")
489 #define FUNC_NAME s_scm_get_u8
494 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
496 c_result
= scm_get_byte_or_eof (port
);
498 result
= SCM_EOF_VAL
;
500 result
= SCM_I_MAKINUM ((unsigned char) c_result
);
506 SCM_DEFINE (scm_lookahead_u8
, "lookahead-u8", 1, 0, 0,
508 "Like @code{get-u8} but does not update @var{port} to "
509 "point past the octet.")
510 #define FUNC_NAME s_scm_lookahead_u8
515 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
517 u8
= scm_peek_byte_or_eof (port
);
519 result
= SCM_EOF_VAL
;
521 result
= SCM_I_MAKINUM ((scm_t_uint8
) u8
);
527 SCM_DEFINE (scm_get_bytevector_n
, "get-bytevector-n", 2, 0, 0,
528 (SCM port
, SCM count
),
529 "Read @var{count} octets from @var{port}, blocking as "
530 "necessary and return a bytevector containing the octets "
531 "read. If fewer bytes are available, a bytevector smaller "
532 "than @var{count} is returned.")
533 #define FUNC_NAME s_scm_get_bytevector_n
540 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
541 c_count
= scm_to_uint (count
);
543 result
= scm_c_make_bytevector (c_count
);
544 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (result
);
546 if (SCM_LIKELY (c_count
> 0))
547 /* XXX: `scm_c_read ()' does not update the port position. */
548 c_read
= scm_c_read_unlocked (port
, c_bv
, c_count
);
550 /* Don't invoke `scm_c_read ()' since it may block. */
553 if (c_read
< c_count
)
556 result
= SCM_EOF_VAL
;
558 result
= scm_c_shrink_bytevector (result
, c_read
);
565 SCM_DEFINE (scm_get_bytevector_n_x
, "get-bytevector-n!", 4, 0, 0,
566 (SCM port
, SCM bv
, SCM start
, SCM count
),
567 "Read @var{count} bytes from @var{port} and store them "
568 "in @var{bv} starting at index @var{start}. Return either "
569 "the number of bytes actually read or the end-of-file "
571 #define FUNC_NAME s_scm_get_bytevector_n_x
575 unsigned c_start
, c_count
, c_len
;
578 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
579 SCM_VALIDATE_BYTEVECTOR (2, bv
);
580 c_start
= scm_to_uint (start
);
581 c_count
= scm_to_uint (count
);
583 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
584 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
586 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
587 scm_out_of_range (FUNC_NAME
, count
);
589 if (SCM_LIKELY (c_count
> 0))
590 c_read
= scm_c_read_unlocked (port
, c_bv
+ c_start
, c_count
);
592 /* Don't invoke `scm_c_read ()' since it may block. */
595 if (c_read
== 0 && c_count
> 0)
596 result
= SCM_EOF_VAL
;
598 result
= scm_from_size_t (c_read
);
605 SCM_DEFINE (scm_get_bytevector_some
, "get-bytevector-some", 1, 0, 0,
607 "Read from @var{port}, blocking as necessary, until bytes "
608 "are available or an end-of-file is reached. Return either "
609 "the end-of-file object or a new bytevector containing some "
610 "of the available bytes (at least one), and update the port "
611 "position to point just past these bytes.")
612 #define FUNC_NAME s_scm_get_bytevector_some
618 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
619 pt
= SCM_PTAB_ENTRY (port
);
621 if (pt
->rw_active
== SCM_PORT_WRITE
)
622 scm_flush_unlocked (port
);
625 pt
->rw_active
= SCM_PORT_READ
;
627 if (pt
->read_pos
>= pt
->read_end
)
629 if (scm_fill_input_unlocked (port
) == EOF
)
633 size
= pt
->read_end
- pt
->read_pos
;
634 if (pt
->read_buf
== pt
->putback_buf
)
635 size
+= pt
->saved_read_end
- pt
->saved_read_pos
;
637 bv
= scm_c_make_bytevector (size
);
638 scm_take_from_input_buffers
639 (port
, (char *) SCM_BYTEVECTOR_CONTENTS (bv
), size
);
645 SCM_DEFINE (scm_get_bytevector_all
, "get-bytevector-all", 1, 0, 0,
647 "Read from @var{port}, blocking as necessary, until "
648 "the end-of-file is reached. Return either "
649 "a new bytevector containing the data read or the "
650 "end-of-file object (if no data were available).")
651 #define FUNC_NAME s_scm_get_bytevector_all
655 unsigned c_len
, c_count
;
656 size_t c_read
, c_total
;
658 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
660 c_len
= c_count
= 4096;
661 c_bv
= (char *) scm_gc_malloc_pointerless (c_len
, SCM_GC_BYTEVECTOR
);
662 c_total
= c_read
= 0;
666 if (c_total
+ c_read
> c_len
)
668 /* Grow the bytevector. */
669 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_len
* 2,
675 /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
677 c_read
= scm_c_read_unlocked (port
, c_bv
+ c_total
, c_count
);
678 c_total
+= c_read
, c_count
-= c_read
;
680 while (c_count
== 0);
684 result
= SCM_EOF_VAL
;
685 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
691 /* Shrink the bytevector. */
692 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_total
,
694 c_len
= (unsigned) c_total
;
697 result
= scm_c_take_gc_bytevector ((signed char *) c_bv
, c_len
,
709 /* We currently don't support specific binary input ports. */
710 #define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
713 SCM_DEFINE (scm_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_put_u8
720 SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port
);
721 c_octet
= scm_to_uint8 (octet
);
723 scm_putc_unlocked ((char) c_octet
, port
);
725 return SCM_UNSPECIFIED
;
729 SCM_DEFINE (scm_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_put_bytevector
737 unsigned c_start
, c_count
, c_len
;
739 SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port
);
740 SCM_VALIDATE_BYTEVECTOR (2, bv
);
742 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
743 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
745 if (!scm_is_eq (start
, SCM_UNDEFINED
))
747 c_start
= scm_to_uint (start
);
749 if (!scm_is_eq (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_unlocked (port
, c_bv
+ c_start
, c_count
);
768 return SCM_UNSPECIFIED
;
772 SCM_DEFINE (scm_unget_bytevector
, "unget-bytevector", 2, 2, 0,
773 (SCM port
, SCM bv
, SCM start
, SCM count
),
774 "Unget the contents of @var{bv} to @var{port}, optionally "
775 "starting at index @var{start} and limiting to @var{count} "
777 #define FUNC_NAME s_scm_unget_bytevector
780 size_t c_start
, c_count
, c_len
;
782 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
783 SCM_VALIDATE_BYTEVECTOR (2, bv
);
785 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
786 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
788 if (!scm_is_eq (start
, SCM_UNDEFINED
))
790 c_start
= scm_to_size_t (start
);
792 if (!scm_is_eq (count
, SCM_UNDEFINED
))
794 c_count
= scm_to_size_t (count
);
795 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
796 scm_out_of_range (FUNC_NAME
, count
);
800 if (SCM_UNLIKELY (c_start
>= c_len
))
801 scm_out_of_range (FUNC_NAME
, start
);
803 c_count
= c_len
- c_start
;
807 c_start
= 0, c_count
= c_len
;
809 scm_unget_bytes (c_bv
+ c_start
, c_count
, port
);
811 return SCM_UNSPECIFIED
;
817 /* Bytevector output port ("bop" for short). */
819 /* Implementation of "bops".
821 Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
822 it. The procedure returned along with the output port is actually an
823 applicable SMOB. The SMOB holds a reference to the port. When applied,
824 the SMOB swallows the port's internal buffer, turning it into a
825 bytevector, and resets it.
827 XXX: Access to a bop's internal buffer is not thread-safe. */
829 static scm_t_bits bytevector_output_port_type
= 0;
831 SCM_SMOB (bytevector_output_port_procedure
,
832 "r6rs-bytevector-output-port-procedure",
835 #define SCM_GC_BOP "r6rs-bytevector-output-port"
836 #define SCM_BOP_BUFFER_INITIAL_SIZE 4096
838 /* Representation of a bop's internal buffer. */
848 /* Accessing a bop's buffer. */
849 #define SCM_BOP_BUFFER(_port) \
850 ((scm_t_bop_buffer *) SCM_STREAM (_port))
851 #define SCM_SET_BOP_BUFFER(_port, _buf) \
852 (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
856 bop_buffer_init (scm_t_bop_buffer
*buf
)
858 buf
->total_len
= buf
->len
= buf
->pos
= 0;
863 bop_buffer_grow (scm_t_bop_buffer
*buf
, size_t min_size
)
868 for (new_size
= buf
->total_len
869 ? buf
->total_len
: SCM_BOP_BUFFER_INITIAL_SIZE
;
874 new_buf
= scm_gc_realloc ((void *) buf
->buffer
, buf
->total_len
,
875 new_size
, SCM_GC_BOP
);
877 new_buf
= scm_gc_malloc_pointerless (new_size
, SCM_GC_BOP
);
879 buf
->buffer
= new_buf
;
880 buf
->total_len
= new_size
;
888 scm_t_bop_buffer
*buf
;
889 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
891 buf
= (scm_t_bop_buffer
*) scm_gc_malloc (sizeof (* buf
), SCM_GC_BOP
);
892 bop_buffer_init (buf
);
894 port
= scm_c_make_port_with_encoding (bytevector_output_port_type
,
897 SCM_FAILED_CONVERSION_ERROR
,
900 c_port
= SCM_PTAB_ENTRY (port
);
902 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
903 c_port
->write_buf_size
= 0;
905 /* Make the bop procedure. */
906 SCM_NEWSMOB (bop_proc
, bytevector_output_port_procedure
, buf
);
908 return (scm_values (scm_list_2 (port
, bop_proc
)));
911 /* Write SIZE octets from DATA to PORT. */
913 bop_write (SCM port
, const void *data
, size_t size
)
915 scm_t_bop_buffer
*buf
;
917 buf
= SCM_BOP_BUFFER (port
);
919 if (buf
->pos
+ size
> buf
->total_len
)
920 bop_buffer_grow (buf
, buf
->pos
+ size
);
922 memcpy (buf
->buffer
+ buf
->pos
, data
, size
);
924 buf
->len
= (buf
->len
> buf
->pos
) ? buf
->len
: buf
->pos
;
928 bop_seek (SCM port
, scm_t_off offset
, int whence
)
929 #define FUNC_NAME "bop_seek"
931 scm_t_bop_buffer
*buf
;
933 buf
= SCM_BOP_BUFFER (port
);
937 offset
+= (scm_t_off
) buf
->pos
;
941 if (offset
< 0 || (unsigned) offset
> buf
->len
)
942 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
948 if (offset
< 0 || (unsigned) offset
>= buf
->len
)
949 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
951 buf
->pos
= buf
->len
- (offset
+ 1);
955 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
956 "invalid `seek' parameter");
963 /* Fetch data from a bop. */
964 SCM_SMOB_APPLY (bytevector_output_port_procedure
,
965 bop_proc_apply
, 0, 0, 0, (SCM bop_proc
))
968 scm_t_bop_buffer
*buf
, result_buf
;
970 buf
= (scm_t_bop_buffer
*) SCM_SMOB_DATA (bop_proc
);
973 bop_buffer_init (buf
);
975 if (result_buf
.len
== 0)
976 bv
= scm_c_take_gc_bytevector (NULL
, 0, SCM_BOOL_F
);
979 if (result_buf
.total_len
> result_buf
.len
)
980 /* Shrink the buffer. */
981 result_buf
.buffer
= scm_gc_realloc ((void *) result_buf
.buffer
,
982 result_buf
.total_len
,
986 bv
= scm_c_take_gc_bytevector ((signed char *) result_buf
.buffer
,
987 result_buf
.len
, SCM_BOOL_F
);
993 SCM_DEFINE (scm_open_bytevector_output_port
,
994 "open-bytevector-output-port", 0, 1, 0,
996 "Return two values: an output port and a procedure. The latter "
997 "should be called with zero arguments to obtain a bytevector "
998 "containing the data accumulated by the port.")
999 #define FUNC_NAME s_scm_open_bytevector_output_port
1001 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
1002 transcoders_not_implemented ();
1004 return (make_bop ());
1009 initialize_bytevector_output_ports (void)
1011 bytevector_output_port_type
=
1012 scm_make_port_type ("r6rs-bytevector-output-port",
1015 scm_set_port_seek (bytevector_output_port_type
, bop_seek
);
1019 /* Custom binary output port ("cbop" for short). */
1021 static scm_t_bits custom_binary_output_port_type
;
1023 /* Return the various procedures of PORT. */
1024 #define SCM_CBOP_WRITE_PROC(_port) \
1025 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
1029 make_cbop (SCM write_proc
, SCM get_position_proc
,
1030 SCM set_position_proc
, SCM close_proc
)
1032 SCM port
, method_vector
;
1034 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
1036 /* Store the various methods and bytevector in a vector. */
1037 method_vector
= scm_c_make_vector (4, SCM_BOOL_F
);
1038 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, write_proc
);
1039 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
1040 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
1041 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
1043 port
= scm_c_make_port_with_encoding (custom_binary_output_port_type
,
1045 NULL
, /* encoding */
1046 SCM_FAILED_CONVERSION_ERROR
,
1047 SCM_UNPACK (method_vector
));
1049 c_port
= SCM_PTAB_ENTRY (port
);
1051 /* Have the port directly access the buffer (bytevector). */
1052 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
1053 c_port
->write_buf_size
= c_port
->read_buf_size
= 0;
1058 /* Write SIZE octets from DATA to PORT. */
1060 cbop_write (SCM port
, const void *data
, size_t size
)
1061 #define FUNC_NAME "cbop_write"
1065 SCM bv
, write_proc
, result
;
1067 /* XXX: Allocating a new bytevector at each `write' call is inefficient,
1068 but necessary since (1) we don't control the lifetime of the buffer
1069 pointed to by DATA, and (2) the `write!' procedure could capture the
1070 bytevector it is passed. */
1071 bv
= scm_c_make_bytevector (size
);
1072 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), data
, size
);
1074 write_proc
= SCM_CBOP_WRITE_PROC (port
);
1076 /* Since the `write' procedure of Guile's ports has type `void', it must
1077 try hard to write exactly SIZE bytes, regardless of how many bytes the
1081 c_written
+= c_result
)
1083 result
= scm_call_3 (write_proc
, bv
,
1084 scm_from_size_t (c_written
),
1085 scm_from_size_t (size
- c_written
));
1087 c_result
= scm_to_long (result
);
1088 if (SCM_UNLIKELY (c_result
< 0
1089 || (size_t) c_result
> (size
- c_written
)))
1090 scm_wrong_type_arg_msg (FUNC_NAME
, 0, result
,
1091 "R6RS custom binary output port `write!' "
1092 "returned a incorrect integer");
1098 SCM_DEFINE (scm_make_custom_binary_output_port
,
1099 "make-custom-binary-output-port", 5, 0, 0,
1100 (SCM id
, SCM write_proc
, SCM get_position_proc
,
1101 SCM set_position_proc
, SCM close_proc
),
1102 "Return a new custom binary output port whose output is drained "
1103 "by invoking @var{write_proc} and passing it a bytevector, an "
1104 "index where octets should be written, and an octet count.")
1105 #define FUNC_NAME s_scm_make_custom_binary_output_port
1107 SCM_VALIDATE_STRING (1, id
);
1108 SCM_VALIDATE_PROC (2, write_proc
);
1110 if (!scm_is_false (get_position_proc
))
1111 SCM_VALIDATE_PROC (3, get_position_proc
);
1113 if (!scm_is_false (set_position_proc
))
1114 SCM_VALIDATE_PROC (4, set_position_proc
);
1116 if (!scm_is_false (close_proc
))
1117 SCM_VALIDATE_PROC (5, close_proc
);
1119 return (make_cbop (write_proc
, get_position_proc
, set_position_proc
,
1125 /* Instantiate the custom binary output port type. */
1127 initialize_custom_binary_output_ports (void)
1129 custom_binary_output_port_type
=
1130 scm_make_port_type ("r6rs-custom-binary-output-port",
1133 scm_set_port_seek (custom_binary_output_port_type
, cbp_seek
);
1134 scm_set_port_close (custom_binary_output_port_type
, cbp_close
);
1138 /* Transcoded ports ("tp" for short). */
1139 static scm_t_bits transcoded_port_type
= 0;
1141 #define TP_INPUT_BUFFER_SIZE 4096
1143 #define SCM_TP_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port))
1146 make_tp (SCM binary_port
, unsigned long mode
)
1150 const unsigned long mode_bits
= SCM_OPN
| mode
;
1152 port
= scm_c_make_port (transcoded_port_type
, mode_bits
,
1153 SCM_UNPACK (binary_port
));
1155 if (SCM_INPUT_PORT_P (port
))
1157 c_port
= SCM_PTAB_ENTRY (port
);
1158 c_port
->read_buf
= scm_gc_malloc_pointerless (TP_INPUT_BUFFER_SIZE
,
1160 c_port
->read_pos
= c_port
->read_end
= c_port
->read_buf
;
1161 c_port
->read_buf_size
= TP_INPUT_BUFFER_SIZE
;
1163 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
1170 tp_write (SCM port
, const void *data
, size_t size
)
1172 scm_c_write_unlocked (SCM_TP_BINARY_PORT (port
), data
, size
);
1176 tp_fill_input (SCM port
)
1179 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
1180 SCM bport
= SCM_TP_BINARY_PORT (port
);
1181 scm_t_port
*c_bport
= SCM_PTAB_ENTRY (bport
);
1183 /* We can't use `scm_c_read' here, since it blocks until the whole
1184 block has been read or EOF. */
1186 if (c_bport
->rw_active
== SCM_PORT_WRITE
)
1187 scm_force_output (bport
);
1189 if (c_bport
->read_pos
>= c_bport
->read_end
)
1190 scm_fill_input_unlocked (bport
);
1192 count
= c_bport
->read_end
- c_bport
->read_pos
;
1193 if (count
> c_port
->read_buf_size
)
1194 count
= c_port
->read_buf_size
;
1196 memcpy (c_port
->read_buf
, c_bport
->read_pos
, count
);
1197 c_bport
->read_pos
+= count
;
1199 if (c_bport
->rw_random
)
1200 c_bport
->rw_active
= SCM_PORT_READ
;
1206 c_port
->read_pos
= c_port
->read_buf
;
1207 c_port
->read_end
= c_port
->read_buf
+ count
;
1208 return *c_port
->read_buf
;
1215 SCM binary_port
= SCM_TP_BINARY_PORT (port
);
1216 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
1217 size_t count
= c_port
->write_pos
- c_port
->write_buf
;
1219 /* As the runtime will try to flush all ports upon exit, we test for
1220 the underlying port still being open here. Otherwise, when you
1221 would explicitly close the underlying port and the transcoded port
1222 still had data outstanding, you'd get an exception on Guile exit.
1224 We just throw away the data when the underlying port is closed. */
1226 if (SCM_OPOUTPORTP (binary_port
))
1227 scm_c_write_unlocked (binary_port
, c_port
->write_buf
, count
);
1229 c_port
->write_pos
= c_port
->write_buf
;
1230 c_port
->rw_active
= SCM_PORT_NEITHER
;
1232 if (SCM_OPOUTPORTP (binary_port
))
1233 scm_force_output (binary_port
);
1239 if (SCM_OUTPUT_PORT_P (port
))
1241 return scm_is_true (scm_close_port (SCM_TP_BINARY_PORT (port
))) ? 0 : -1;
1245 initialize_transcoded_ports (void)
1247 transcoded_port_type
=
1248 scm_make_port_type ("r6rs-transcoded-port", tp_fill_input
, tp_write
);
1250 scm_set_port_flush (transcoded_port_type
, tp_flush
);
1251 scm_set_port_close (transcoded_port_type
, tp_close
);
1254 SCM_INTERNAL SCM
scm_i_make_transcoded_port (SCM
);
1256 SCM_DEFINE (scm_i_make_transcoded_port
,
1257 "%make-transcoded-port", 1, 0, 0,
1259 "Return a new port which reads and writes to @var{port}")
1260 #define FUNC_NAME s_scm_i_make_transcoded_port
1263 unsigned long mode
= 0;
1265 SCM_VALIDATE_PORT (SCM_ARG1
, port
);
1267 if (scm_is_true (scm_output_port_p (port
)))
1269 else if (scm_is_true (scm_input_port_p (port
)))
1272 result
= make_tp (port
, mode
);
1274 /* FIXME: We should actually close `port' "in a special way" here,
1275 according to R6RS. As there is no way to do that in Guile without
1276 rendering the underlying port unusable for our purposes as well, we
1277 just leave it open. */
1286 SCM_DEFINE (scm_get_string_n_x
,
1287 "get-string-n!", 4, 0, 0,
1288 (SCM port
, SCM str
, SCM start
, SCM count
),
1289 "Read up to @var{count} characters from @var{port} into "
1290 "@var{str}, starting at @var{start}. If no characters "
1291 "can be read before the end of file is encountered, the end "
1292 "of file object is returned. Otherwise, the number of "
1293 "characters read is returned.")
1294 #define FUNC_NAME s_scm_get_string_n_x
1296 size_t c_start
, c_count
, c_len
, c_end
, j
;
1299 SCM_VALIDATE_OPINPORT (1, port
);
1300 SCM_VALIDATE_STRING (2, str
);
1301 c_len
= scm_c_string_length (str
);
1302 c_start
= scm_to_size_t (start
);
1303 c_count
= scm_to_size_t (count
);
1304 c_end
= c_start
+ c_count
;
1306 if (SCM_UNLIKELY (c_end
> c_len
))
1307 scm_out_of_range (FUNC_NAME
, count
);
1309 for (j
= c_start
; j
< c_end
; j
++)
1311 c
= scm_getc_unlocked (port
);
1314 size_t chars_read
= j
- c_start
;
1315 return chars_read
== 0 ? SCM_EOF_VAL
: scm_from_size_t (chars_read
);
1317 scm_c_string_set_x (str
, j
, SCM_MAKE_CHAR (c
));
1324 /* Initialization. */
1327 scm_register_r6rs_ports (void)
1329 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1330 "scm_init_r6rs_ports",
1331 (scm_t_extension_init_func
) scm_init_r6rs_ports
,
1336 scm_init_r6rs_ports (void)
1338 #include "libguile/r6rs-ports.x"
1340 initialize_bytevector_input_ports ();
1341 initialize_custom_binary_input_ports ();
1342 initialize_bytevector_output_ports ();
1343 initialize_custom_binary_output_ports ();
1344 initialize_transcoded_ports ();