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 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
87 port
= scm_new_port_table_entry (bytevector_input_port_type
);
88 c_port
= SCM_PTAB_ENTRY (port
);
90 /* Match the expectation of `binary-port?'. */
91 c_port
->encoding
= NULL
;
93 /* Prevent BV from being GC'd. */
94 SCM_SETSTREAM (port
, SCM_UNPACK (bv
));
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
;
104 /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
105 SCM_SET_CELL_TYPE (port
, bytevector_input_port_type
| mode_bits
);
107 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
113 bip_fill_input (SCM port
)
116 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
118 if (c_port
->read_pos
>= c_port
->read_end
)
121 result
= (int) *c_port
->read_pos
;
127 bip_seek (SCM port
, scm_t_off offset
, int whence
)
128 #define FUNC_NAME "bip_seek"
130 scm_t_off c_result
= 0;
131 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
136 offset
+= c_port
->read_pos
- c_port
->read_buf
;
140 if (c_port
->read_buf
+ offset
<= c_port
->read_end
)
142 c_port
->read_pos
= c_port
->read_buf
+ offset
;
146 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
150 if (c_port
->read_end
- offset
>= c_port
->read_buf
)
152 c_port
->read_pos
= c_port
->read_end
- offset
;
153 c_result
= c_port
->read_pos
- c_port
->read_buf
;
156 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
160 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
161 "invalid `seek' parameter");
169 /* Instantiate the bytevector input port type. */
171 initialize_bytevector_input_ports (void)
173 bytevector_input_port_type
=
174 scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input
,
177 scm_set_port_seek (bytevector_input_port_type
, bip_seek
);
181 SCM_DEFINE (scm_open_bytevector_input_port
,
182 "open-bytevector-input-port", 1, 1, 0,
183 (SCM bv
, SCM transcoder
),
184 "Return an input port whose contents are drawn from "
185 "bytevector @var{bv}.")
186 #define FUNC_NAME s_scm_open_bytevector_input_port
188 SCM_VALIDATE_BYTEVECTOR (1, bv
);
189 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
190 transcoders_not_implemented ();
192 return (make_bip (bv
));
197 /* Custom binary ports. The following routines are shared by input and
198 output custom binary ports. */
200 #define SCM_CBP_GET_POSITION_PROC(_port) \
201 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
202 #define SCM_CBP_SET_POSITION_PROC(_port) \
203 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
204 #define SCM_CBP_CLOSE_PROC(_port) \
205 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
208 cbp_seek (SCM port
, scm_t_off offset
, int whence
)
209 #define FUNC_NAME "cbp_seek"
212 scm_t_off c_result
= 0;
218 SCM get_position_proc
;
220 get_position_proc
= SCM_CBP_GET_POSITION_PROC (port
);
221 if (SCM_LIKELY (scm_is_true (get_position_proc
)))
222 result
= scm_call_0 (get_position_proc
);
224 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
225 "R6RS custom binary port with "
226 "`port-position' support");
227 c_result
= scm_to_int (result
);
229 /* We just want to know the current position. */
238 SCM set_position_proc
;
240 set_position_proc
= SCM_CBP_SET_POSITION_PROC (port
);
241 if (SCM_LIKELY (scm_is_true (set_position_proc
)))
242 result
= scm_call_1 (set_position_proc
, scm_from_int (offset
));
244 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
245 "seekable R6RS custom binary port");
247 /* Assuming setting the position succeeded. */
253 /* `SEEK_END' cannot be supported. */
254 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
255 "R6RS custom binary ports do not "
256 "support `SEEK_END'");
268 close_proc
= SCM_CBP_CLOSE_PROC (port
);
269 if (scm_is_true (close_proc
))
270 /* Invoke the `close' thunk. */
271 scm_call_0 (close_proc
);
277 /* Custom binary input port ("cbip" for short). */
279 static scm_t_bits custom_binary_input_port_type
= 0;
281 /* Initial size of the buffer embedded in custom binary input ports. */
282 #define CBIP_BUFFER_SIZE 8192
284 /* Return the bytevector associated with PORT. */
285 #define SCM_CBIP_BYTEVECTOR(_port) \
286 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
288 /* Set BV as the bytevector associated with PORT. */
289 #define SCM_SET_CBIP_BYTEVECTOR(_port, _bv) \
290 SCM_SIMPLE_VECTOR_SET (SCM_PACK (SCM_STREAM (_port)), 4, (_bv))
292 /* Return the various procedures of PORT. */
293 #define SCM_CBIP_READ_PROC(_port) \
294 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
297 /* Set PORT's internal buffer according to READ_SIZE. */
299 cbip_setvbuf (SCM port
, long read_size
, long write_size
)
304 pt
= SCM_PTAB_ENTRY (port
);
305 bv
= SCM_CBIP_BYTEVECTOR (port
);
310 /* Unbuffered: keep PORT's bytevector as is (it will be used in
311 future 'scm_c_read' calls), but point to the one-byte buffer. */
312 pt
->read_buf
= &pt
->shortbuf
;
313 pt
->read_buf_size
= 1;
317 /* Preferred size: keep the current bytevector and use it as the
319 pt
->read_buf
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
320 pt
->read_buf_size
= SCM_BYTEVECTOR_LENGTH (bv
);
324 /* Fully buffered: allocate a buffer of READ_SIZE bytes. */
325 bv
= scm_c_make_bytevector (read_size
);
326 SCM_SET_CBIP_BYTEVECTOR (port
, bv
);
327 pt
->read_buf
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
328 pt
->read_buf_size
= read_size
;
331 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
335 make_cbip (SCM read_proc
, SCM get_position_proc
,
336 SCM set_position_proc
, SCM close_proc
)
338 SCM port
, bv
, method_vector
;
342 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
;
344 /* Use a bytevector as the underlying buffer. */
345 c_len
= CBIP_BUFFER_SIZE
;
346 bv
= scm_c_make_bytevector (c_len
);
347 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
349 /* Store the various methods and bytevector in a vector. */
350 method_vector
= scm_c_make_vector (5, SCM_BOOL_F
);
351 SCM_SIMPLE_VECTOR_SET (method_vector
, 4, bv
);
352 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, read_proc
);
353 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
354 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
355 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
357 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
359 port
= scm_new_port_table_entry (custom_binary_input_port_type
);
360 c_port
= SCM_PTAB_ENTRY (port
);
362 /* Match the expectation of `binary-port?'. */
363 c_port
->encoding
= NULL
;
365 /* Attach it the method vector. */
366 SCM_SETSTREAM (port
, SCM_UNPACK (method_vector
));
368 /* Have the port directly access the buffer (bytevector). */
369 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
370 c_port
->read_end
= (unsigned char *) c_bv
;
371 c_port
->read_buf_size
= c_len
;
373 /* 'setvbuf' is supported. */
374 SCM_PORT_GET_INTERNAL (port
)->setvbuf
= cbip_setvbuf
;
376 /* Mark PORT as open and readable. */
377 SCM_SET_CELL_TYPE (port
, custom_binary_input_port_type
| mode_bits
);
379 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
385 cbip_fill_input (SCM port
)
386 #define FUNC_NAME "cbip_fill_input"
389 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
391 if (c_port
->read_pos
>= c_port
->read_end
)
393 /* Invoke the user's `read!' procedure. */
395 size_t c_octets
, c_requested
;
396 SCM bv
, read_proc
, octets
;
398 c_requested
= c_port
->read_buf_size
;
399 read_proc
= SCM_CBIP_READ_PROC (port
);
401 bv
= SCM_CBIP_BYTEVECTOR (port
);
403 (c_port
->read_buf
== (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
));
407 /* Make sure the buffer isn't corrupt. BV can be passed directly
409 assert (c_port
->read_buf_size
== SCM_BYTEVECTOR_LENGTH (bv
));
410 c_port
->read_pos
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
414 /* This is an unbuffered port. When called via the
415 'get-bytevector-*' procedures, and thus via 'scm_c_read', we
416 are passed the caller-provided buffer, so we need to check its
418 if (SCM_BYTEVECTOR_LENGTH (bv
) < c_requested
)
420 /* Bad luck: we have to make another allocation. Save that
421 bytevector for later reuse, in the hope that the application
422 has regular access patterns. */
423 bv
= scm_c_make_bytevector (c_requested
);
424 SCM_SET_CBIP_BYTEVECTOR (port
, bv
);
428 octets
= scm_call_3 (read_proc
, bv
, SCM_INUM0
,
429 scm_from_size_t (c_requested
));
430 c_octets
= scm_to_size_t (octets
);
431 if (SCM_UNLIKELY (c_octets
> c_requested
))
432 scm_out_of_range (FUNC_NAME
, octets
);
435 /* Copy the data back to the internal buffer. */
436 memcpy ((char *) c_port
->read_pos
, SCM_BYTEVECTOR_CONTENTS (bv
),
439 c_port
->read_end
= (unsigned char *) c_port
->read_pos
+ c_octets
;
441 if (c_octets
!= 0 || c_requested
== 0)
442 result
= (int) *c_port
->read_pos
;
447 result
= (int) *c_port
->read_pos
;
454 SCM_DEFINE (scm_make_custom_binary_input_port
,
455 "make-custom-binary-input-port", 5, 0, 0,
456 (SCM id
, SCM read_proc
, SCM get_position_proc
,
457 SCM set_position_proc
, SCM close_proc
),
458 "Return a new custom binary input port whose input is drained "
459 "by invoking @var{read_proc} and passing it a bytevector, an "
460 "index where octets should be written, and an octet count.")
461 #define FUNC_NAME s_scm_make_custom_binary_input_port
463 SCM_VALIDATE_STRING (1, id
);
464 SCM_VALIDATE_PROC (2, read_proc
);
466 if (!scm_is_false (get_position_proc
))
467 SCM_VALIDATE_PROC (3, get_position_proc
);
469 if (!scm_is_false (set_position_proc
))
470 SCM_VALIDATE_PROC (4, set_position_proc
);
472 if (!scm_is_false (close_proc
))
473 SCM_VALIDATE_PROC (5, close_proc
);
475 return (make_cbip (read_proc
, get_position_proc
, set_position_proc
,
481 /* Instantiate the custom binary input port type. */
483 initialize_custom_binary_input_ports (void)
485 custom_binary_input_port_type
=
486 scm_make_port_type ("r6rs-custom-binary-input-port",
487 cbip_fill_input
, NULL
);
489 scm_set_port_seek (custom_binary_input_port_type
, cbp_seek
);
490 scm_set_port_close (custom_binary_input_port_type
, cbp_close
);
497 /* We currently don't support specific binary input ports. */
498 #define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
500 SCM_DEFINE (scm_get_u8
, "get-u8", 1, 0, 0,
502 "Read an octet from @var{port}, a binary input port, "
503 "blocking as necessary.")
504 #define FUNC_NAME s_scm_get_u8
509 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
511 c_result
= scm_get_byte_or_eof (port
);
513 result
= SCM_EOF_VAL
;
515 result
= SCM_I_MAKINUM ((unsigned char) c_result
);
521 SCM_DEFINE (scm_lookahead_u8
, "lookahead-u8", 1, 0, 0,
523 "Like @code{get-u8} but does not update @var{port} to "
524 "point past the octet.")
525 #define FUNC_NAME s_scm_lookahead_u8
530 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
532 u8
= scm_peek_byte_or_eof (port
);
534 result
= SCM_EOF_VAL
;
536 result
= SCM_I_MAKINUM ((scm_t_uint8
) u8
);
542 SCM_DEFINE (scm_get_bytevector_n
, "get-bytevector-n", 2, 0, 0,
543 (SCM port
, SCM count
),
544 "Read @var{count} octets from @var{port}, blocking as "
545 "necessary and return a bytevector containing the octets "
546 "read. If fewer bytes are available, a bytevector smaller "
547 "than @var{count} is returned.")
548 #define FUNC_NAME s_scm_get_bytevector_n
555 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
556 c_count
= scm_to_uint (count
);
558 result
= scm_c_make_bytevector (c_count
);
559 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (result
);
561 if (SCM_LIKELY (c_count
> 0))
562 /* XXX: `scm_c_read ()' does not update the port position. */
563 c_read
= scm_c_read (port
, c_bv
, c_count
);
565 /* Don't invoke `scm_c_read ()' since it may block. */
568 if (c_read
< c_count
)
571 result
= SCM_EOF_VAL
;
573 result
= scm_c_shrink_bytevector (result
, c_read
);
580 SCM_DEFINE (scm_get_bytevector_n_x
, "get-bytevector-n!", 4, 0, 0,
581 (SCM port
, SCM bv
, SCM start
, SCM count
),
582 "Read @var{count} bytes from @var{port} and store them "
583 "in @var{bv} starting at index @var{start}. Return either "
584 "the number of bytes actually read or the end-of-file "
586 #define FUNC_NAME s_scm_get_bytevector_n_x
590 unsigned c_start
, c_count
, c_len
;
593 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
594 SCM_VALIDATE_BYTEVECTOR (2, bv
);
595 c_start
= scm_to_uint (start
);
596 c_count
= scm_to_uint (count
);
598 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
599 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
601 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
602 scm_out_of_range (FUNC_NAME
, count
);
604 if (SCM_LIKELY (c_count
> 0))
605 c_read
= scm_c_read (port
, c_bv
+ c_start
, c_count
);
607 /* Don't invoke `scm_c_read ()' since it may block. */
610 if (c_read
== 0 && c_count
> 0)
611 result
= SCM_EOF_VAL
;
613 result
= scm_from_size_t (c_read
);
620 SCM_DEFINE (scm_get_bytevector_some
, "get-bytevector-some", 1, 0, 0,
622 "Read from @var{port}, blocking as necessary, until bytes "
623 "are available or an end-of-file is reached. Return either "
624 "the end-of-file object or a new bytevector containing some "
625 "of the available bytes (at least one), and update the port "
626 "position to point just past these bytes.")
627 #define FUNC_NAME s_scm_get_bytevector_some
633 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
634 pt
= SCM_PTAB_ENTRY (port
);
636 if (pt
->rw_active
== SCM_PORT_WRITE
)
637 scm_ptobs
[SCM_PTOBNUM (port
)].flush (port
);
640 pt
->rw_active
= SCM_PORT_READ
;
642 if (pt
->read_pos
>= pt
->read_end
)
644 if (scm_fill_input (port
) == EOF
)
648 size
= pt
->read_end
- pt
->read_pos
;
649 if (pt
->read_buf
== pt
->putback_buf
)
650 size
+= pt
->saved_read_end
- pt
->saved_read_pos
;
652 bv
= scm_c_make_bytevector (size
);
653 scm_take_from_input_buffers
654 (port
, (char *) SCM_BYTEVECTOR_CONTENTS (bv
), size
);
660 SCM_DEFINE (scm_get_bytevector_all
, "get-bytevector-all", 1, 0, 0,
662 "Read from @var{port}, blocking as necessary, until "
663 "the end-of-file is reached. Return either "
664 "a new bytevector containing the data read or the "
665 "end-of-file object (if no data were available).")
666 #define FUNC_NAME s_scm_get_bytevector_all
670 unsigned c_len
, c_count
;
671 size_t c_read
, c_total
;
673 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
675 c_len
= c_count
= 4096;
676 c_bv
= (char *) scm_gc_malloc_pointerless (c_len
, SCM_GC_BYTEVECTOR
);
677 c_total
= c_read
= 0;
681 if (c_total
+ c_read
> c_len
)
683 /* Grow the bytevector. */
684 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_len
* 2,
690 /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
692 c_read
= scm_c_read (port
, c_bv
+ c_total
, c_count
);
693 c_total
+= c_read
, c_count
-= c_read
;
695 while (c_count
== 0);
699 result
= SCM_EOF_VAL
;
700 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
706 /* Shrink the bytevector. */
707 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_total
,
709 c_len
= (unsigned) c_total
;
712 result
= scm_c_take_gc_bytevector ((signed char *) c_bv
, c_len
);
723 /* We currently don't support specific binary input ports. */
724 #define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
727 SCM_DEFINE (scm_put_u8
, "put-u8", 2, 0, 0,
728 (SCM port
, SCM octet
),
729 "Write @var{octet} to binary port @var{port}.")
730 #define FUNC_NAME s_scm_put_u8
734 SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port
);
735 c_octet
= scm_to_uint8 (octet
);
737 scm_putc ((char) c_octet
, port
);
739 return SCM_UNSPECIFIED
;
743 SCM_DEFINE (scm_put_bytevector
, "put-bytevector", 2, 2, 0,
744 (SCM port
, SCM bv
, SCM start
, SCM count
),
745 "Write the contents of @var{bv} to @var{port}, optionally "
746 "starting at index @var{start} and limiting to @var{count} "
748 #define FUNC_NAME s_scm_put_bytevector
751 unsigned c_start
, c_count
, c_len
;
753 SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port
);
754 SCM_VALIDATE_BYTEVECTOR (2, bv
);
756 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
757 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
759 if (!scm_is_eq (start
, SCM_UNDEFINED
))
761 c_start
= scm_to_uint (start
);
763 if (!scm_is_eq (count
, SCM_UNDEFINED
))
765 c_count
= scm_to_uint (count
);
766 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
767 scm_out_of_range (FUNC_NAME
, count
);
771 if (SCM_UNLIKELY (c_start
>= c_len
))
772 scm_out_of_range (FUNC_NAME
, start
);
774 c_count
= c_len
- c_start
;
778 c_start
= 0, c_count
= c_len
;
780 scm_c_write (port
, c_bv
+ c_start
, c_count
);
782 return SCM_UNSPECIFIED
;
786 SCM_DEFINE (scm_unget_bytevector
, "unget-bytevector", 2, 2, 0,
787 (SCM port
, SCM bv
, SCM start
, SCM count
),
788 "Unget the contents of @var{bv} to @var{port}, optionally "
789 "starting at index @var{start} and limiting to @var{count} "
791 #define FUNC_NAME s_scm_unget_bytevector
794 size_t c_start
, c_count
, c_len
;
796 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
797 SCM_VALIDATE_BYTEVECTOR (2, bv
);
799 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
800 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
802 if (!scm_is_eq (start
, SCM_UNDEFINED
))
804 c_start
= scm_to_size_t (start
);
806 if (!scm_is_eq (count
, SCM_UNDEFINED
))
808 c_count
= scm_to_size_t (count
);
809 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
810 scm_out_of_range (FUNC_NAME
, count
);
814 if (SCM_UNLIKELY (c_start
>= c_len
))
815 scm_out_of_range (FUNC_NAME
, start
);
817 c_count
= c_len
- c_start
;
821 c_start
= 0, c_count
= c_len
;
823 scm_unget_bytes (c_bv
+ c_start
, c_count
, port
);
825 return SCM_UNSPECIFIED
;
831 /* Bytevector output port ("bop" for short). */
833 /* Implementation of "bops".
835 Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
836 it. The procedure returned along with the output port is actually an
837 applicable SMOB. The SMOB holds a reference to the port. When applied,
838 the SMOB swallows the port's internal buffer, turning it into a
839 bytevector, and resets it.
841 XXX: Access to a bop's internal buffer is not thread-safe. */
843 static scm_t_bits bytevector_output_port_type
= 0;
845 SCM_SMOB (bytevector_output_port_procedure
,
846 "r6rs-bytevector-output-port-procedure",
849 #define SCM_GC_BOP "r6rs-bytevector-output-port"
850 #define SCM_BOP_BUFFER_INITIAL_SIZE 4096
852 /* Representation of a bop's internal buffer. */
862 /* Accessing a bop's buffer. */
863 #define SCM_BOP_BUFFER(_port) \
864 ((scm_t_bop_buffer *) SCM_STREAM (_port))
865 #define SCM_SET_BOP_BUFFER(_port, _buf) \
866 (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
870 bop_buffer_init (scm_t_bop_buffer
*buf
)
872 buf
->total_len
= buf
->len
= buf
->pos
= 0;
877 bop_buffer_grow (scm_t_bop_buffer
*buf
, size_t min_size
)
882 for (new_size
= buf
->total_len
883 ? buf
->total_len
: SCM_BOP_BUFFER_INITIAL_SIZE
;
888 new_buf
= scm_gc_realloc ((void *) buf
->buffer
, buf
->total_len
,
889 new_size
, SCM_GC_BOP
);
891 new_buf
= scm_gc_malloc_pointerless (new_size
, SCM_GC_BOP
);
893 buf
->buffer
= new_buf
;
894 buf
->total_len
= new_size
;
902 scm_t_bop_buffer
*buf
;
903 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
905 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
907 port
= scm_new_port_table_entry (bytevector_output_port_type
);
908 c_port
= SCM_PTAB_ENTRY (port
);
910 /* Match the expectation of `binary-port?'. */
911 c_port
->encoding
= NULL
;
913 buf
= (scm_t_bop_buffer
*) scm_gc_malloc (sizeof (* buf
), SCM_GC_BOP
);
914 bop_buffer_init (buf
);
916 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
917 c_port
->write_buf_size
= 0;
919 SCM_SET_BOP_BUFFER (port
, buf
);
921 /* Mark PORT as open and writable. */
922 SCM_SET_CELL_TYPE (port
, bytevector_output_port_type
| mode_bits
);
924 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
926 /* Make the bop procedure. */
927 SCM_NEWSMOB (bop_proc
, bytevector_output_port_procedure
, buf
);
929 return (scm_values (scm_list_2 (port
, bop_proc
)));
932 /* Write SIZE octets from DATA to PORT. */
934 bop_write (SCM port
, const void *data
, size_t size
)
936 scm_t_bop_buffer
*buf
;
938 buf
= SCM_BOP_BUFFER (port
);
940 if (buf
->pos
+ size
> buf
->total_len
)
941 bop_buffer_grow (buf
, buf
->pos
+ size
);
943 memcpy (buf
->buffer
+ buf
->pos
, data
, size
);
945 buf
->len
= (buf
->len
> buf
->pos
) ? buf
->len
: buf
->pos
;
949 bop_seek (SCM port
, scm_t_off offset
, int whence
)
950 #define FUNC_NAME "bop_seek"
952 scm_t_bop_buffer
*buf
;
954 buf
= SCM_BOP_BUFFER (port
);
958 offset
+= (scm_t_off
) buf
->pos
;
962 if (offset
< 0 || (unsigned) offset
> buf
->len
)
963 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
969 if (offset
< 0 || (unsigned) offset
>= buf
->len
)
970 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
972 buf
->pos
= buf
->len
- (offset
+ 1);
976 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
977 "invalid `seek' parameter");
984 /* Fetch data from a bop. */
985 SCM_SMOB_APPLY (bytevector_output_port_procedure
,
986 bop_proc_apply
, 0, 0, 0, (SCM bop_proc
))
989 scm_t_bop_buffer
*buf
, result_buf
;
991 buf
= (scm_t_bop_buffer
*) SCM_SMOB_DATA (bop_proc
);
994 bop_buffer_init (buf
);
996 if (result_buf
.len
== 0)
997 bv
= scm_c_take_gc_bytevector (NULL
, 0);
1000 if (result_buf
.total_len
> result_buf
.len
)
1001 /* Shrink the buffer. */
1002 result_buf
.buffer
= scm_gc_realloc ((void *) result_buf
.buffer
,
1003 result_buf
.total_len
,
1007 bv
= scm_c_take_gc_bytevector ((signed char *) result_buf
.buffer
,
1014 SCM_DEFINE (scm_open_bytevector_output_port
,
1015 "open-bytevector-output-port", 0, 1, 0,
1017 "Return two values: an output port and a procedure. The latter "
1018 "should be called with zero arguments to obtain a bytevector "
1019 "containing the data accumulated by the port.")
1020 #define FUNC_NAME s_scm_open_bytevector_output_port
1022 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
1023 transcoders_not_implemented ();
1025 return (make_bop ());
1030 initialize_bytevector_output_ports (void)
1032 bytevector_output_port_type
=
1033 scm_make_port_type ("r6rs-bytevector-output-port",
1036 scm_set_port_seek (bytevector_output_port_type
, bop_seek
);
1040 /* Custom binary output port ("cbop" for short). */
1042 static scm_t_bits custom_binary_output_port_type
;
1044 /* Return the various procedures of PORT. */
1045 #define SCM_CBOP_WRITE_PROC(_port) \
1046 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
1050 make_cbop (SCM write_proc
, SCM get_position_proc
,
1051 SCM set_position_proc
, SCM close_proc
)
1053 SCM port
, method_vector
;
1055 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
1057 /* Store the various methods and bytevector in a vector. */
1058 method_vector
= scm_c_make_vector (4, SCM_BOOL_F
);
1059 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, write_proc
);
1060 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
1061 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
1062 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
1064 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
1066 port
= scm_new_port_table_entry (custom_binary_output_port_type
);
1067 c_port
= SCM_PTAB_ENTRY (port
);
1069 /* Match the expectation of `binary-port?'. */
1070 c_port
->encoding
= NULL
;
1072 /* Attach it the method vector. */
1073 SCM_SETSTREAM (port
, SCM_UNPACK (method_vector
));
1075 /* Have the port directly access the buffer (bytevector). */
1076 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
1077 c_port
->write_buf_size
= c_port
->read_buf_size
= 0;
1079 /* Mark PORT as open, writable and unbuffered. */
1080 SCM_SET_CELL_TYPE (port
, custom_binary_output_port_type
| mode_bits
);
1082 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
1087 /* Write SIZE octets from DATA to PORT. */
1089 cbop_write (SCM port
, const void *data
, size_t size
)
1090 #define FUNC_NAME "cbop_write"
1094 SCM bv
, write_proc
, result
;
1096 /* XXX: Allocating a new bytevector at each `write' call is inefficient,
1097 but necessary since (1) we don't control the lifetime of the buffer
1098 pointed to by DATA, and (2) the `write!' procedure could capture the
1099 bytevector it is passed. */
1100 bv
= scm_c_make_bytevector (size
);
1101 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), data
, size
);
1103 write_proc
= SCM_CBOP_WRITE_PROC (port
);
1105 /* Since the `write' procedure of Guile's ports has type `void', it must
1106 try hard to write exactly SIZE bytes, regardless of how many bytes the
1110 c_written
+= c_result
)
1112 result
= scm_call_3 (write_proc
, bv
,
1113 scm_from_size_t (c_written
),
1114 scm_from_size_t (size
- c_written
));
1116 c_result
= scm_to_long (result
);
1117 if (SCM_UNLIKELY (c_result
< 0
1118 || (size_t) c_result
> (size
- c_written
)))
1119 scm_wrong_type_arg_msg (FUNC_NAME
, 0, result
,
1120 "R6RS custom binary output port `write!' "
1121 "returned a incorrect integer");
1127 SCM_DEFINE (scm_make_custom_binary_output_port
,
1128 "make-custom-binary-output-port", 5, 0, 0,
1129 (SCM id
, SCM write_proc
, SCM get_position_proc
,
1130 SCM set_position_proc
, SCM close_proc
),
1131 "Return a new custom binary output port whose output is drained "
1132 "by invoking @var{write_proc} and passing it a bytevector, an "
1133 "index where octets should be written, and an octet count.")
1134 #define FUNC_NAME s_scm_make_custom_binary_output_port
1136 SCM_VALIDATE_STRING (1, id
);
1137 SCM_VALIDATE_PROC (2, write_proc
);
1139 if (!scm_is_false (get_position_proc
))
1140 SCM_VALIDATE_PROC (3, get_position_proc
);
1142 if (!scm_is_false (set_position_proc
))
1143 SCM_VALIDATE_PROC (4, set_position_proc
);
1145 if (!scm_is_false (close_proc
))
1146 SCM_VALIDATE_PROC (5, close_proc
);
1148 return (make_cbop (write_proc
, get_position_proc
, set_position_proc
,
1154 /* Instantiate the custom binary output port type. */
1156 initialize_custom_binary_output_ports (void)
1158 custom_binary_output_port_type
=
1159 scm_make_port_type ("r6rs-custom-binary-output-port",
1162 scm_set_port_seek (custom_binary_output_port_type
, cbp_seek
);
1163 scm_set_port_close (custom_binary_output_port_type
, cbp_close
);
1167 /* Transcoded ports ("tp" for short). */
1168 static scm_t_bits transcoded_port_type
= 0;
1170 #define TP_INPUT_BUFFER_SIZE 4096
1172 #define SCM_TP_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port))
1175 make_tp (SCM binary_port
, unsigned long mode
)
1179 const unsigned long mode_bits
= SCM_OPN
| mode
;
1181 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
1183 port
= scm_new_port_table_entry (transcoded_port_type
);
1185 SCM_SETSTREAM (port
, SCM_UNPACK (binary_port
));
1187 SCM_SET_CELL_TYPE (port
, transcoded_port_type
| mode_bits
);
1189 if (SCM_INPUT_PORT_P (port
))
1191 c_port
= SCM_PTAB_ENTRY (port
);
1192 c_port
->read_buf
= scm_gc_malloc_pointerless (TP_INPUT_BUFFER_SIZE
,
1194 c_port
->read_pos
= c_port
->read_end
= c_port
->read_buf
;
1195 c_port
->read_buf_size
= TP_INPUT_BUFFER_SIZE
;
1197 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
1200 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
1206 tp_write (SCM port
, const void *data
, size_t size
)
1208 scm_c_write (SCM_TP_BINARY_PORT (port
), data
, size
);
1212 tp_fill_input (SCM port
)
1215 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
1216 SCM bport
= SCM_TP_BINARY_PORT (port
);
1217 scm_t_port
*c_bport
= SCM_PTAB_ENTRY (bport
);
1219 /* We can't use `scm_c_read' here, since it blocks until the whole
1220 block has been read or EOF. */
1222 if (c_bport
->rw_active
== SCM_PORT_WRITE
)
1223 scm_force_output (bport
);
1225 if (c_bport
->read_pos
>= c_bport
->read_end
)
1226 scm_fill_input (bport
);
1228 count
= c_bport
->read_end
- c_bport
->read_pos
;
1229 if (count
> c_port
->read_buf_size
)
1230 count
= c_port
->read_buf_size
;
1232 memcpy (c_port
->read_buf
, c_bport
->read_pos
, count
);
1233 c_bport
->read_pos
+= count
;
1235 if (c_bport
->rw_random
)
1236 c_bport
->rw_active
= SCM_PORT_READ
;
1242 c_port
->read_pos
= c_port
->read_buf
;
1243 c_port
->read_end
= c_port
->read_buf
+ count
;
1244 return *c_port
->read_buf
;
1251 SCM binary_port
= SCM_TP_BINARY_PORT (port
);
1252 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
1253 size_t count
= c_port
->write_pos
- c_port
->write_buf
;
1255 /* As the runtime will try to flush all ports upon exit, we test for
1256 the underlying port still being open here. Otherwise, when you
1257 would explicitly close the underlying port and the transcoded port
1258 still had data outstanding, you'd get an exception on Guile exit.
1260 We just throw away the data when the underlying port is closed. */
1262 if (SCM_OPOUTPORTP (binary_port
))
1263 scm_c_write (binary_port
, c_port
->write_buf
, count
);
1265 c_port
->write_pos
= c_port
->write_buf
;
1266 c_port
->rw_active
= SCM_PORT_NEITHER
;
1268 if (SCM_OPOUTPORTP (binary_port
))
1269 scm_force_output (binary_port
);
1275 if (SCM_OUTPUT_PORT_P (port
))
1277 return scm_is_true (scm_close_port (SCM_TP_BINARY_PORT (port
))) ? 0 : -1;
1281 initialize_transcoded_ports (void)
1283 transcoded_port_type
=
1284 scm_make_port_type ("r6rs-transcoded-port", tp_fill_input
, tp_write
);
1286 scm_set_port_flush (transcoded_port_type
, tp_flush
);
1287 scm_set_port_close (transcoded_port_type
, tp_close
);
1290 SCM_DEFINE (scm_i_make_transcoded_port
,
1291 "%make-transcoded-port", 1, 0, 0,
1293 "Return a new port which reads and writes to @var{port}")
1294 #define FUNC_NAME s_scm_i_make_transcoded_port
1297 unsigned long mode
= 0;
1299 SCM_VALIDATE_PORT (SCM_ARG1
, port
);
1301 if (scm_is_true (scm_output_port_p (port
)))
1303 else if (scm_is_true (scm_input_port_p (port
)))
1306 result
= make_tp (port
, mode
);
1308 /* FIXME: We should actually close `port' "in a special way" here,
1309 according to R6RS. As there is no way to do that in Guile without
1310 rendering the underlying port unusable for our purposes as well, we
1311 just leave it open. */
1320 SCM_DEFINE (scm_get_string_n_x
,
1321 "get-string-n!", 4, 0, 0,
1322 (SCM port
, SCM str
, SCM start
, SCM count
),
1323 "Read up to @var{count} characters from @var{port} into "
1324 "@var{str}, starting at @var{start}. If no characters "
1325 "can be read before the end of file is encountered, the end "
1326 "of file object is returned. Otherwise, the number of "
1327 "characters read is returned.")
1328 #define FUNC_NAME s_scm_get_string_n_x
1330 size_t c_start
, c_count
, c_len
, c_end
, j
;
1333 SCM_VALIDATE_OPINPORT (1, port
);
1334 SCM_VALIDATE_STRING (2, str
);
1335 c_len
= scm_c_string_length (str
);
1336 c_start
= scm_to_size_t (start
);
1337 c_count
= scm_to_size_t (count
);
1338 c_end
= c_start
+ c_count
;
1340 if (SCM_UNLIKELY (c_end
> c_len
))
1341 scm_out_of_range (FUNC_NAME
, count
);
1343 for (j
= c_start
; j
< c_end
; j
++)
1345 c
= scm_getc (port
);
1348 size_t chars_read
= j
- c_start
;
1349 return chars_read
== 0 ? SCM_EOF_VAL
: scm_from_size_t (chars_read
);
1351 scm_c_string_set_x (str
, j
, SCM_MAKE_CHAR (c
));
1358 /* Initialization. */
1361 scm_register_r6rs_ports (void)
1363 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1364 "scm_init_r6rs_ports",
1365 (scm_t_extension_init_func
) scm_init_r6rs_ports
,
1370 scm_init_r6rs_ports (void)
1372 #include "libguile/r6rs-ports.x"
1374 initialize_bytevector_input_ports ();
1375 initialize_custom_binary_input_ports ();
1376 initialize_bytevector_output_ports ();
1377 initialize_custom_binary_output_ports ();
1378 initialize_transcoded_ports ();