1 /* Copyright (C) 2009, 2010, 2011, 2013 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"
43 /* Unimplemented features. */
46 /* Transoders are currently not implemented since Guile 1.8 is not
47 Unicode-capable. Thus, most of the code here assumes the use of the
50 transcoders_not_implemented (void)
52 fprintf (stderr
, "%s: warning: transcoders not implemented\n",
57 /* End-of-file object. */
59 SCM_DEFINE (scm_eof_object
, "eof-object", 0, 0, 0,
61 "Return the end-of-file object.")
62 #define FUNC_NAME s_scm_eof_object
72 # define MIN(a,b) ((a) < (b) ? (a) : (b))
75 /* Bytevector input ports or "bip" for short. */
76 static scm_t_bits bytevector_input_port_type
= 0;
85 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
;
87 port
= scm_c_make_port_with_encoding (bytevector_input_port_type
,
90 SCM_FAILED_CONVERSION_ERROR
,
93 c_port
= SCM_PTAB_ENTRY (port
);
95 /* Have the port directly access the bytevector. */
96 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
97 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
99 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
100 c_port
->read_end
= (unsigned char *) c_bv
+ c_len
;
101 c_port
->read_buf_size
= c_len
;
107 bip_fill_input (SCM port
)
110 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
112 if (c_port
->read_pos
>= c_port
->read_end
)
115 result
= (int) *c_port
->read_pos
;
121 bip_seek (SCM port
, scm_t_off offset
, int whence
)
122 #define FUNC_NAME "bip_seek"
124 scm_t_off c_result
= 0;
125 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
130 offset
+= c_port
->read_pos
- c_port
->read_buf
;
134 if (c_port
->read_buf
+ offset
<= c_port
->read_end
)
136 c_port
->read_pos
= c_port
->read_buf
+ offset
;
140 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
144 if (c_port
->read_end
- offset
>= c_port
->read_buf
)
146 c_port
->read_pos
= c_port
->read_end
- offset
;
147 c_result
= c_port
->read_pos
- c_port
->read_buf
;
150 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
154 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
155 "invalid `seek' parameter");
163 /* Instantiate the bytevector input port type. */
165 initialize_bytevector_input_ports (void)
167 bytevector_input_port_type
=
168 scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input
,
171 scm_set_port_seek (bytevector_input_port_type
, bip_seek
);
175 SCM_DEFINE (scm_open_bytevector_input_port
,
176 "open-bytevector-input-port", 1, 1, 0,
177 (SCM bv
, SCM transcoder
),
178 "Return an input port whose contents are drawn from "
179 "bytevector @var{bv}.")
180 #define FUNC_NAME s_scm_open_bytevector_input_port
182 SCM_VALIDATE_BYTEVECTOR (1, bv
);
183 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
184 transcoders_not_implemented ();
186 return (make_bip (bv
));
191 /* Custom binary ports. The following routines are shared by input and
192 output custom binary ports. */
194 #define SCM_CBP_GET_POSITION_PROC(_port) \
195 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
196 #define SCM_CBP_SET_POSITION_PROC(_port) \
197 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
198 #define SCM_CBP_CLOSE_PROC(_port) \
199 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
202 cbp_seek (SCM port
, scm_t_off offset
, int whence
)
203 #define FUNC_NAME "cbp_seek"
206 scm_t_off c_result
= 0;
212 SCM get_position_proc
;
214 get_position_proc
= SCM_CBP_GET_POSITION_PROC (port
);
215 if (SCM_LIKELY (scm_is_true (get_position_proc
)))
216 result
= scm_call_0 (get_position_proc
);
218 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
219 "R6RS custom binary port does not "
220 "support `port-position'");
222 offset
+= scm_to_int (result
);
228 SCM set_position_proc
;
230 set_position_proc
= SCM_CBP_SET_POSITION_PROC (port
);
231 if (SCM_LIKELY (scm_is_true (set_position_proc
)))
232 result
= scm_call_1 (set_position_proc
, scm_from_int (offset
));
234 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
235 "R6RS custom binary port does not "
236 "support `set-port-position!'");
238 /* Assuming setting the position succeeded. */
244 /* `SEEK_END' cannot be supported. */
245 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
246 "R6RS custom binary ports do not "
247 "support `SEEK_END'");
259 close_proc
= SCM_CBP_CLOSE_PROC (port
);
260 if (scm_is_true (close_proc
))
261 /* Invoke the `close' thunk. */
262 scm_call_0 (close_proc
);
268 /* Custom binary input port ("cbip" for short). */
270 static scm_t_bits custom_binary_input_port_type
= 0;
272 /* Size of the buffer embedded in custom binary input ports. */
273 #define CBIP_BUFFER_SIZE 4096
275 /* Return the bytevector associated with PORT. */
276 #define SCM_CBIP_BYTEVECTOR(_port) \
277 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
279 /* Return the various procedures of PORT. */
280 #define SCM_CBIP_READ_PROC(_port) \
281 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
285 make_cbip (SCM read_proc
, SCM get_position_proc
,
286 SCM set_position_proc
, SCM close_proc
)
288 SCM port
, bv
, method_vector
;
292 const unsigned long mode_bits
= SCM_OPN
| SCM_RDNG
;
294 /* Use a bytevector as the underlying buffer. */
295 c_len
= CBIP_BUFFER_SIZE
;
296 bv
= scm_c_make_bytevector (c_len
);
297 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
299 /* Store the various methods and bytevector in a vector. */
300 method_vector
= scm_c_make_vector (5, SCM_BOOL_F
);
301 SCM_SIMPLE_VECTOR_SET (method_vector
, 4, bv
);
302 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, read_proc
);
303 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
304 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
305 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
307 port
= scm_c_make_port_with_encoding (custom_binary_input_port_type
,
310 SCM_FAILED_CONVERSION_ERROR
,
311 SCM_UNPACK (method_vector
));
313 c_port
= SCM_PTAB_ENTRY (port
);
315 /* Have the port directly access the buffer (bytevector). */
316 c_port
->read_pos
= c_port
->read_buf
= (unsigned char *) c_bv
;
317 c_port
->read_end
= (unsigned char *) c_bv
;
318 c_port
->read_buf_size
= c_len
;
324 cbip_fill_input (SCM port
)
325 #define FUNC_NAME "cbip_fill_input"
328 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
331 if (c_port
->read_pos
>= c_port
->read_end
)
333 /* Invoke the user's `read!' procedure. */
335 SCM bv
, read_proc
, octets
;
337 /* Use the bytevector associated with PORT as the buffer passed to the
338 `read!' procedure, thereby avoiding additional allocations. */
339 bv
= SCM_CBIP_BYTEVECTOR (port
);
340 read_proc
= SCM_CBIP_READ_PROC (port
);
342 /* The assumption here is that C_PORT's internal buffer wasn't changed
344 assert (c_port
->read_buf
==
345 (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
));
346 assert ((unsigned) c_port
->read_buf_size
347 == SCM_BYTEVECTOR_LENGTH (bv
));
349 octets
= scm_call_3 (read_proc
, bv
, SCM_INUM0
,
350 SCM_I_MAKINUM (CBIP_BUFFER_SIZE
));
351 c_octets
= scm_to_uint (octets
);
353 c_port
->read_pos
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
354 c_port
->read_end
= (unsigned char *) c_port
->read_pos
+ c_octets
;
362 result
= (int) *c_port
->read_pos
;
369 SCM_DEFINE (scm_make_custom_binary_input_port
,
370 "make-custom-binary-input-port", 5, 0, 0,
371 (SCM id
, SCM read_proc
, SCM get_position_proc
,
372 SCM set_position_proc
, SCM close_proc
),
373 "Return a new custom binary input port whose input is drained "
374 "by invoking @var{read_proc} and passing it a bytevector, an "
375 "index where octets should be written, and an octet count.")
376 #define FUNC_NAME s_scm_make_custom_binary_input_port
378 SCM_VALIDATE_STRING (1, id
);
379 SCM_VALIDATE_PROC (2, read_proc
);
381 if (!scm_is_false (get_position_proc
))
382 SCM_VALIDATE_PROC (3, get_position_proc
);
384 if (!scm_is_false (set_position_proc
))
385 SCM_VALIDATE_PROC (4, set_position_proc
);
387 if (!scm_is_false (close_proc
))
388 SCM_VALIDATE_PROC (5, close_proc
);
390 return (make_cbip (read_proc
, get_position_proc
, set_position_proc
,
396 /* Instantiate the custom binary input port type. */
398 initialize_custom_binary_input_ports (void)
400 custom_binary_input_port_type
=
401 scm_make_port_type ("r6rs-custom-binary-input-port",
402 cbip_fill_input
, NULL
);
404 scm_set_port_seek (custom_binary_input_port_type
, cbp_seek
);
405 scm_set_port_close (custom_binary_input_port_type
, cbp_close
);
412 /* We currently don't support specific binary input ports. */
413 #define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
415 SCM_DEFINE (scm_get_u8
, "get-u8", 1, 0, 0,
417 "Read an octet from @var{port}, a binary input port, "
418 "blocking as necessary.")
419 #define FUNC_NAME s_scm_get_u8
424 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
426 c_result
= scm_get_byte_or_eof (port
);
428 result
= SCM_EOF_VAL
;
430 result
= SCM_I_MAKINUM ((unsigned char) c_result
);
436 SCM_DEFINE (scm_lookahead_u8
, "lookahead-u8", 1, 0, 0,
438 "Like @code{get-u8} but does not update @var{port} to "
439 "point past the octet.")
440 #define FUNC_NAME s_scm_lookahead_u8
445 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
447 u8
= scm_peek_byte_or_eof (port
);
449 result
= SCM_EOF_VAL
;
451 result
= SCM_I_MAKINUM ((scm_t_uint8
) u8
);
457 SCM_DEFINE (scm_get_bytevector_n
, "get-bytevector-n", 2, 0, 0,
458 (SCM port
, SCM count
),
459 "Read @var{count} octets from @var{port}, blocking as "
460 "necessary and return a bytevector containing the octets "
461 "read. If fewer bytes are available, a bytevector smaller "
462 "than @var{count} is returned.")
463 #define FUNC_NAME s_scm_get_bytevector_n
470 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
471 c_count
= scm_to_uint (count
);
473 result
= scm_c_make_bytevector (c_count
);
474 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (result
);
476 if (SCM_LIKELY (c_count
> 0))
477 /* XXX: `scm_c_read ()' does not update the port position. */
478 c_read
= scm_c_read_unlocked (port
, c_bv
, c_count
);
480 /* Don't invoke `scm_c_read ()' since it may block. */
483 if (c_read
< c_count
)
486 result
= SCM_EOF_VAL
;
488 result
= scm_c_shrink_bytevector (result
, c_read
);
495 SCM_DEFINE (scm_get_bytevector_n_x
, "get-bytevector-n!", 4, 0, 0,
496 (SCM port
, SCM bv
, SCM start
, SCM count
),
497 "Read @var{count} bytes from @var{port} and store them "
498 "in @var{bv} starting at index @var{start}. Return either "
499 "the number of bytes actually read or the end-of-file "
501 #define FUNC_NAME s_scm_get_bytevector_n_x
505 unsigned c_start
, c_count
, c_len
;
508 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
509 SCM_VALIDATE_BYTEVECTOR (2, bv
);
510 c_start
= scm_to_uint (start
);
511 c_count
= scm_to_uint (count
);
513 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
514 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
516 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
517 scm_out_of_range (FUNC_NAME
, count
);
519 if (SCM_LIKELY (c_count
> 0))
520 c_read
= scm_c_read_unlocked (port
, c_bv
+ c_start
, c_count
);
522 /* Don't invoke `scm_c_read ()' since it may block. */
525 if (c_read
== 0 && c_count
> 0)
526 result
= SCM_EOF_VAL
;
528 result
= scm_from_size_t (c_read
);
535 SCM_DEFINE (scm_get_bytevector_some
, "get-bytevector-some", 1, 0, 0,
537 "Read from @var{port}, blocking as necessary, until bytes "
538 "are available or an end-of-file is reached. Return either "
539 "the end-of-file object or a new bytevector containing some "
540 "of the available bytes (at least one), and update the port "
541 "position to point just past these bytes.")
542 #define FUNC_NAME s_scm_get_bytevector_some
548 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
549 pt
= SCM_PTAB_ENTRY (port
);
551 if (pt
->rw_active
== SCM_PORT_WRITE
)
552 scm_flush_unlocked (port
);
555 pt
->rw_active
= SCM_PORT_READ
;
557 if (pt
->read_pos
>= pt
->read_end
)
559 if (scm_fill_input_unlocked (port
) == EOF
)
563 size
= pt
->read_end
- pt
->read_pos
;
564 if (pt
->read_buf
== pt
->putback_buf
)
565 size
+= pt
->saved_read_end
- pt
->saved_read_pos
;
567 bv
= scm_c_make_bytevector (size
);
568 scm_take_from_input_buffers
569 (port
, (char *) SCM_BYTEVECTOR_CONTENTS (bv
), size
);
575 SCM_DEFINE (scm_get_bytevector_all
, "get-bytevector-all", 1, 0, 0,
577 "Read from @var{port}, blocking as necessary, until "
578 "the end-of-file is reached. Return either "
579 "a new bytevector containing the data read or the "
580 "end-of-file object (if no data were available).")
581 #define FUNC_NAME s_scm_get_bytevector_all
585 unsigned c_len
, c_count
;
586 size_t c_read
, c_total
;
588 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
590 c_len
= c_count
= 4096;
591 c_bv
= (char *) scm_gc_malloc_pointerless (c_len
, SCM_GC_BYTEVECTOR
);
592 c_total
= c_read
= 0;
596 if (c_total
+ c_read
> c_len
)
598 /* Grow the bytevector. */
599 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_len
* 2,
605 /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
607 c_read
= scm_c_read_unlocked (port
, c_bv
+ c_total
, c_count
);
608 c_total
+= c_read
, c_count
-= c_read
;
610 while (c_count
== 0);
614 result
= SCM_EOF_VAL
;
615 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
621 /* Shrink the bytevector. */
622 c_bv
= (char *) scm_gc_realloc (c_bv
, c_len
, c_total
,
624 c_len
= (unsigned) c_total
;
627 result
= scm_c_take_gc_bytevector ((signed char *) c_bv
, c_len
,
639 /* We currently don't support specific binary input ports. */
640 #define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
643 SCM_DEFINE (scm_put_u8
, "put-u8", 2, 0, 0,
644 (SCM port
, SCM octet
),
645 "Write @var{octet} to binary port @var{port}.")
646 #define FUNC_NAME s_scm_put_u8
650 SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port
);
651 c_octet
= scm_to_uint8 (octet
);
653 scm_putc_unlocked ((char) c_octet
, port
);
655 return SCM_UNSPECIFIED
;
659 SCM_DEFINE (scm_put_bytevector
, "put-bytevector", 2, 2, 0,
660 (SCM port
, SCM bv
, SCM start
, SCM count
),
661 "Write the contents of @var{bv} to @var{port}, optionally "
662 "starting at index @var{start} and limiting to @var{count} "
664 #define FUNC_NAME s_scm_put_bytevector
667 unsigned c_start
, c_count
, c_len
;
669 SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port
);
670 SCM_VALIDATE_BYTEVECTOR (2, bv
);
672 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
673 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
675 if (!scm_is_eq (start
, SCM_UNDEFINED
))
677 c_start
= scm_to_uint (start
);
679 if (!scm_is_eq (count
, SCM_UNDEFINED
))
681 c_count
= scm_to_uint (count
);
682 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
683 scm_out_of_range (FUNC_NAME
, count
);
687 if (SCM_UNLIKELY (c_start
>= c_len
))
688 scm_out_of_range (FUNC_NAME
, start
);
690 c_count
= c_len
- c_start
;
694 c_start
= 0, c_count
= c_len
;
696 scm_c_write_unlocked (port
, c_bv
+ c_start
, c_count
);
698 return SCM_UNSPECIFIED
;
702 SCM_DEFINE (scm_unget_bytevector
, "unget-bytevector", 2, 2, 0,
703 (SCM port
, SCM bv
, SCM start
, SCM count
),
704 "Unget the contents of @var{bv} to @var{port}, optionally "
705 "starting at index @var{start} and limiting to @var{count} "
707 #define FUNC_NAME s_scm_unget_bytevector
710 size_t c_start
, c_count
, c_len
;
712 SCM_VALIDATE_BINARY_INPUT_PORT (1, port
);
713 SCM_VALIDATE_BYTEVECTOR (2, bv
);
715 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
716 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
718 if (!scm_is_eq (start
, SCM_UNDEFINED
))
720 c_start
= scm_to_size_t (start
);
722 if (!scm_is_eq (count
, SCM_UNDEFINED
))
724 c_count
= scm_to_size_t (count
);
725 if (SCM_UNLIKELY (c_start
+ c_count
> c_len
))
726 scm_out_of_range (FUNC_NAME
, count
);
730 if (SCM_UNLIKELY (c_start
>= c_len
))
731 scm_out_of_range (FUNC_NAME
, start
);
733 c_count
= c_len
- c_start
;
737 c_start
= 0, c_count
= c_len
;
739 scm_unget_bytes (c_bv
+ c_start
, c_count
, port
);
741 return SCM_UNSPECIFIED
;
747 /* Bytevector output port ("bop" for short). */
749 /* Implementation of "bops".
751 Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
752 it. The procedure returned along with the output port is actually an
753 applicable SMOB. The SMOB holds a reference to the port. When applied,
754 the SMOB swallows the port's internal buffer, turning it into a
755 bytevector, and resets it.
757 XXX: Access to a bop's internal buffer is not thread-safe. */
759 static scm_t_bits bytevector_output_port_type
= 0;
761 SCM_SMOB (bytevector_output_port_procedure
,
762 "r6rs-bytevector-output-port-procedure",
765 #define SCM_GC_BOP "r6rs-bytevector-output-port"
766 #define SCM_BOP_BUFFER_INITIAL_SIZE 4096
768 /* Representation of a bop's internal buffer. */
778 /* Accessing a bop's buffer. */
779 #define SCM_BOP_BUFFER(_port) \
780 ((scm_t_bop_buffer *) SCM_STREAM (_port))
781 #define SCM_SET_BOP_BUFFER(_port, _buf) \
782 (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
786 bop_buffer_init (scm_t_bop_buffer
*buf
)
788 buf
->total_len
= buf
->len
= buf
->pos
= 0;
793 bop_buffer_grow (scm_t_bop_buffer
*buf
, size_t min_size
)
798 for (new_size
= buf
->total_len
799 ? buf
->total_len
: SCM_BOP_BUFFER_INITIAL_SIZE
;
804 new_buf
= scm_gc_realloc ((void *) buf
->buffer
, buf
->total_len
,
805 new_size
, SCM_GC_BOP
);
807 new_buf
= scm_gc_malloc_pointerless (new_size
, SCM_GC_BOP
);
809 buf
->buffer
= new_buf
;
810 buf
->total_len
= new_size
;
818 scm_t_bop_buffer
*buf
;
819 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
821 buf
= (scm_t_bop_buffer
*) scm_gc_malloc (sizeof (* buf
), SCM_GC_BOP
);
822 bop_buffer_init (buf
);
824 port
= scm_c_make_port_with_encoding (bytevector_output_port_type
,
827 SCM_FAILED_CONVERSION_ERROR
,
830 c_port
= SCM_PTAB_ENTRY (port
);
832 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
833 c_port
->write_buf_size
= 0;
835 /* Make the bop procedure. */
836 SCM_NEWSMOB (bop_proc
, bytevector_output_port_procedure
, buf
);
838 return (scm_values (scm_list_2 (port
, bop_proc
)));
841 /* Write SIZE octets from DATA to PORT. */
843 bop_write (SCM port
, const void *data
, size_t size
)
845 scm_t_bop_buffer
*buf
;
847 buf
= SCM_BOP_BUFFER (port
);
849 if (buf
->pos
+ size
> buf
->total_len
)
850 bop_buffer_grow (buf
, buf
->pos
+ size
);
852 memcpy (buf
->buffer
+ buf
->pos
, data
, size
);
854 buf
->len
= (buf
->len
> buf
->pos
) ? buf
->len
: buf
->pos
;
858 bop_seek (SCM port
, scm_t_off offset
, int whence
)
859 #define FUNC_NAME "bop_seek"
861 scm_t_bop_buffer
*buf
;
863 buf
= SCM_BOP_BUFFER (port
);
867 offset
+= (scm_t_off
) buf
->pos
;
871 if (offset
< 0 || (unsigned) offset
> buf
->len
)
872 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
878 if (offset
< 0 || (unsigned) offset
>= buf
->len
)
879 scm_out_of_range (FUNC_NAME
, scm_from_int (offset
));
881 buf
->pos
= buf
->len
- (offset
+ 1);
885 scm_wrong_type_arg_msg (FUNC_NAME
, 0, port
,
886 "invalid `seek' parameter");
893 /* Fetch data from a bop. */
894 SCM_SMOB_APPLY (bytevector_output_port_procedure
,
895 bop_proc_apply
, 0, 0, 0, (SCM bop_proc
))
898 scm_t_bop_buffer
*buf
, result_buf
;
900 buf
= (scm_t_bop_buffer
*) SCM_SMOB_DATA (bop_proc
);
903 bop_buffer_init (buf
);
905 if (result_buf
.len
== 0)
906 bv
= scm_c_take_gc_bytevector (NULL
, 0, SCM_BOOL_F
);
909 if (result_buf
.total_len
> result_buf
.len
)
910 /* Shrink the buffer. */
911 result_buf
.buffer
= scm_gc_realloc ((void *) result_buf
.buffer
,
912 result_buf
.total_len
,
916 bv
= scm_c_take_gc_bytevector ((signed char *) result_buf
.buffer
,
917 result_buf
.len
, SCM_BOOL_F
);
923 SCM_DEFINE (scm_open_bytevector_output_port
,
924 "open-bytevector-output-port", 0, 1, 0,
926 "Return two values: an output port and a procedure. The latter "
927 "should be called with zero arguments to obtain a bytevector "
928 "containing the data accumulated by the port.")
929 #define FUNC_NAME s_scm_open_bytevector_output_port
931 if (!SCM_UNBNDP (transcoder
) && !scm_is_false (transcoder
))
932 transcoders_not_implemented ();
934 return (make_bop ());
939 initialize_bytevector_output_ports (void)
941 bytevector_output_port_type
=
942 scm_make_port_type ("r6rs-bytevector-output-port",
945 scm_set_port_seek (bytevector_output_port_type
, bop_seek
);
949 /* Custom binary output port ("cbop" for short). */
951 static scm_t_bits custom_binary_output_port_type
;
953 /* Return the various procedures of PORT. */
954 #define SCM_CBOP_WRITE_PROC(_port) \
955 SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
959 make_cbop (SCM write_proc
, SCM get_position_proc
,
960 SCM set_position_proc
, SCM close_proc
)
962 SCM port
, method_vector
;
964 const unsigned long mode_bits
= SCM_OPN
| SCM_WRTNG
;
966 /* Store the various methods and bytevector in a vector. */
967 method_vector
= scm_c_make_vector (4, SCM_BOOL_F
);
968 SCM_SIMPLE_VECTOR_SET (method_vector
, 0, write_proc
);
969 SCM_SIMPLE_VECTOR_SET (method_vector
, 1, get_position_proc
);
970 SCM_SIMPLE_VECTOR_SET (method_vector
, 2, set_position_proc
);
971 SCM_SIMPLE_VECTOR_SET (method_vector
, 3, close_proc
);
973 port
= scm_c_make_port_with_encoding (custom_binary_output_port_type
,
976 SCM_FAILED_CONVERSION_ERROR
,
977 SCM_UNPACK (method_vector
));
979 c_port
= SCM_PTAB_ENTRY (port
);
981 /* Have the port directly access the buffer (bytevector). */
982 c_port
->write_buf
= c_port
->write_pos
= c_port
->write_end
= NULL
;
983 c_port
->write_buf_size
= c_port
->read_buf_size
= 0;
988 /* Write SIZE octets from DATA to PORT. */
990 cbop_write (SCM port
, const void *data
, size_t size
)
991 #define FUNC_NAME "cbop_write"
995 SCM bv
, write_proc
, result
;
997 /* XXX: Allocating a new bytevector at each `write' call is inefficient,
998 but necessary since (1) we don't control the lifetime of the buffer
999 pointed to by DATA, and (2) the `write!' procedure could capture the
1000 bytevector it is passed. */
1001 bv
= scm_c_make_bytevector (size
);
1002 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), data
, size
);
1004 write_proc
= SCM_CBOP_WRITE_PROC (port
);
1006 /* Since the `write' procedure of Guile's ports has type `void', it must
1007 try hard to write exactly SIZE bytes, regardless of how many bytes the
1011 c_written
+= c_result
)
1013 result
= scm_call_3 (write_proc
, bv
,
1014 scm_from_size_t (c_written
),
1015 scm_from_size_t (size
- c_written
));
1017 c_result
= scm_to_long (result
);
1018 if (SCM_UNLIKELY (c_result
< 0
1019 || (size_t) c_result
> (size
- c_written
)))
1020 scm_wrong_type_arg_msg (FUNC_NAME
, 0, result
,
1021 "R6RS custom binary output port `write!' "
1022 "returned a incorrect integer");
1028 SCM_DEFINE (scm_make_custom_binary_output_port
,
1029 "make-custom-binary-output-port", 5, 0, 0,
1030 (SCM id
, SCM write_proc
, SCM get_position_proc
,
1031 SCM set_position_proc
, SCM close_proc
),
1032 "Return a new custom binary output port whose output is drained "
1033 "by invoking @var{write_proc} and passing it a bytevector, an "
1034 "index where octets should be written, and an octet count.")
1035 #define FUNC_NAME s_scm_make_custom_binary_output_port
1037 SCM_VALIDATE_STRING (1, id
);
1038 SCM_VALIDATE_PROC (2, write_proc
);
1040 if (!scm_is_false (get_position_proc
))
1041 SCM_VALIDATE_PROC (3, get_position_proc
);
1043 if (!scm_is_false (set_position_proc
))
1044 SCM_VALIDATE_PROC (4, set_position_proc
);
1046 if (!scm_is_false (close_proc
))
1047 SCM_VALIDATE_PROC (5, close_proc
);
1049 return (make_cbop (write_proc
, get_position_proc
, set_position_proc
,
1055 /* Instantiate the custom binary output port type. */
1057 initialize_custom_binary_output_ports (void)
1059 custom_binary_output_port_type
=
1060 scm_make_port_type ("r6rs-custom-binary-output-port",
1063 scm_set_port_seek (custom_binary_output_port_type
, cbp_seek
);
1064 scm_set_port_close (custom_binary_output_port_type
, cbp_close
);
1068 /* Transcoded ports ("tp" for short). */
1069 static scm_t_bits transcoded_port_type
= 0;
1071 #define TP_INPUT_BUFFER_SIZE 4096
1073 #define SCM_TP_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port))
1076 make_tp (SCM binary_port
, unsigned long mode
)
1080 const unsigned long mode_bits
= SCM_OPN
| mode
;
1082 port
= scm_c_make_port (transcoded_port_type
, mode_bits
,
1083 SCM_UNPACK (binary_port
));
1085 if (SCM_INPUT_PORT_P (port
))
1087 c_port
= SCM_PTAB_ENTRY (port
);
1088 c_port
->read_buf
= scm_gc_malloc_pointerless (TP_INPUT_BUFFER_SIZE
,
1090 c_port
->read_pos
= c_port
->read_end
= c_port
->read_buf
;
1091 c_port
->read_buf_size
= TP_INPUT_BUFFER_SIZE
;
1093 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
1100 tp_write (SCM port
, const void *data
, size_t size
)
1102 scm_c_write_unlocked (SCM_TP_BINARY_PORT (port
), data
, size
);
1106 tp_fill_input (SCM port
)
1109 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
1110 SCM bport
= SCM_TP_BINARY_PORT (port
);
1111 scm_t_port
*c_bport
= SCM_PTAB_ENTRY (bport
);
1113 /* We can't use `scm_c_read' here, since it blocks until the whole
1114 block has been read or EOF. */
1116 if (c_bport
->rw_active
== SCM_PORT_WRITE
)
1117 scm_force_output (bport
);
1119 if (c_bport
->read_pos
>= c_bport
->read_end
)
1120 scm_fill_input_unlocked (bport
);
1122 count
= c_bport
->read_end
- c_bport
->read_pos
;
1123 if (count
> c_port
->read_buf_size
)
1124 count
= c_port
->read_buf_size
;
1126 memcpy (c_port
->read_buf
, c_bport
->read_pos
, count
);
1127 c_bport
->read_pos
+= count
;
1129 if (c_bport
->rw_random
)
1130 c_bport
->rw_active
= SCM_PORT_READ
;
1136 c_port
->read_pos
= c_port
->read_buf
;
1137 c_port
->read_end
= c_port
->read_buf
+ count
;
1138 return *c_port
->read_buf
;
1145 SCM binary_port
= SCM_TP_BINARY_PORT (port
);
1146 scm_t_port
*c_port
= SCM_PTAB_ENTRY (port
);
1147 size_t count
= c_port
->write_pos
- c_port
->write_buf
;
1149 /* As the runtime will try to flush all ports upon exit, we test for
1150 the underlying port still being open here. Otherwise, when you
1151 would explicitly close the underlying port and the transcoded port
1152 still had data outstanding, you'd get an exception on Guile exit.
1154 We just throw away the data when the underlying port is closed. */
1156 if (SCM_OPOUTPORTP (binary_port
))
1157 scm_c_write_unlocked (binary_port
, c_port
->write_buf
, count
);
1159 c_port
->write_pos
= c_port
->write_buf
;
1160 c_port
->rw_active
= SCM_PORT_NEITHER
;
1162 if (SCM_OPOUTPORTP (binary_port
))
1163 scm_force_output (binary_port
);
1169 if (SCM_OUTPUT_PORT_P (port
))
1171 return scm_is_true (scm_close_port (SCM_TP_BINARY_PORT (port
))) ? 0 : -1;
1175 initialize_transcoded_ports (void)
1177 transcoded_port_type
=
1178 scm_make_port_type ("r6rs-transcoded-port", tp_fill_input
, tp_write
);
1180 scm_set_port_flush (transcoded_port_type
, tp_flush
);
1181 scm_set_port_close (transcoded_port_type
, tp_close
);
1184 SCM_INTERNAL SCM
scm_i_make_transcoded_port (SCM
);
1186 SCM_DEFINE (scm_i_make_transcoded_port
,
1187 "%make-transcoded-port", 1, 0, 0,
1189 "Return a new port which reads and writes to @var{port}")
1190 #define FUNC_NAME s_scm_i_make_transcoded_port
1193 unsigned long mode
= 0;
1195 SCM_VALIDATE_PORT (SCM_ARG1
, port
);
1197 if (scm_is_true (scm_output_port_p (port
)))
1199 else if (scm_is_true (scm_input_port_p (port
)))
1202 result
= make_tp (port
, mode
);
1204 /* FIXME: We should actually close `port' "in a special way" here,
1205 according to R6RS. As there is no way to do that in Guile without
1206 rendering the underlying port unusable for our purposes as well, we
1207 just leave it open. */
1216 SCM_DEFINE (scm_get_string_n_x
,
1217 "get-string-n!", 4, 0, 0,
1218 (SCM port
, SCM str
, SCM start
, SCM count
),
1219 "Read up to @var{count} characters from @var{port} into "
1220 "@var{str}, starting at @var{start}. If no characters "
1221 "can be read before the end of file is encountered, the end "
1222 "of file object is returned. Otherwise, the number of "
1223 "characters read is returned.")
1224 #define FUNC_NAME s_scm_get_string_n_x
1226 size_t c_start
, c_count
, c_len
, c_end
, j
;
1229 SCM_VALIDATE_OPINPORT (1, port
);
1230 SCM_VALIDATE_STRING (2, str
);
1231 c_len
= scm_c_string_length (str
);
1232 c_start
= scm_to_size_t (start
);
1233 c_count
= scm_to_size_t (count
);
1234 c_end
= c_start
+ c_count
;
1236 if (SCM_UNLIKELY (c_end
> c_len
))
1237 scm_out_of_range (FUNC_NAME
, count
);
1239 for (j
= c_start
; j
< c_end
; j
++)
1241 c
= scm_getc_unlocked (port
);
1244 size_t chars_read
= j
- c_start
;
1245 return chars_read
== 0 ? SCM_EOF_VAL
: scm_from_size_t (chars_read
);
1247 scm_c_string_set_x (str
, j
, SCM_MAKE_CHAR (c
));
1254 /* Initialization. */
1257 scm_register_r6rs_ports (void)
1259 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1260 "scm_init_r6rs_ports",
1261 (scm_t_extension_init_func
) scm_init_r6rs_ports
,
1266 scm_init_r6rs_ports (void)
1268 #include "libguile/r6rs-ports.x"
1270 initialize_bytevector_input_ports ();
1271 initialize_custom_binary_input_ports ();
1272 initialize_bytevector_output_ports ();
1273 initialize_custom_binary_output_ports ();
1274 initialize_transcoded_ports ();