1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004,
2 * 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24 #define _LARGEFILE64_SOURCE /* ask for stat64 etc */
32 #include <fcntl.h> /* for chsize on mingw */
37 #include <striconveh.h>
41 #include "libguile/_scm.h"
42 #include "libguile/async.h"
43 #include "libguile/deprecation.h"
44 #include "libguile/eval.h"
45 #include "libguile/fports.h" /* direct access for seek and truncate */
46 #include "libguile/goops.h"
47 #include "libguile/smob.h"
48 #include "libguile/chars.h"
49 #include "libguile/dynwind.h"
51 #include "libguile/keywords.h"
52 #include "libguile/hashtab.h"
53 #include "libguile/root.h"
54 #include "libguile/strings.h"
55 #include "libguile/mallocs.h"
56 #include "libguile/validate.h"
57 #include "libguile/ports.h"
58 #include "libguile/vectors.h"
59 #include "libguile/weak-set.h"
60 #include "libguile/fluids.h"
61 #include "libguile/eq.h"
75 #ifdef HAVE_SYS_IOCTL_H
76 #include <sys/ioctl.h>
79 /* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
80 already, but have this code here in case that wasn't so in past versions,
81 or perhaps to help other minimal DOS environments.
83 gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
84 might be possibilities if we've got other systems without ftruncate. */
86 #if defined HAVE_CHSIZE && ! defined HAVE_FTRUNCATE
87 #define ftruncate(fd, size) chsize (fd, size)
89 #define HAVE_FTRUNCATE 1
93 /* The port kind table --- a dynamically resized array of port types. */
96 /* scm_ptobs scm_numptob
97 * implement a dynamically resized array of ptob records.
98 * Indexes into this table are used when generating type
99 * tags for smobjects (if you know a tag you can get an index and conversely).
101 static scm_t_ptob_descriptor
**scm_ptobs
= NULL
;
102 static long scm_numptob
= 0; /* Number of port types. */
103 static long scm_ptobs_size
= 0; /* Number of slots in the port type
105 static scm_i_pthread_mutex_t scm_ptobs_lock
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
108 scm_c_num_port_types (void)
112 scm_i_pthread_mutex_lock (&scm_ptobs_lock
);
114 scm_i_pthread_mutex_unlock (&scm_ptobs_lock
);
119 scm_t_ptob_descriptor
*
120 scm_c_port_type_ref (long ptobnum
)
122 scm_t_ptob_descriptor
*ret
= NULL
;
124 scm_i_pthread_mutex_lock (&scm_ptobs_lock
);
126 if (0 <= ptobnum
&& ptobnum
< scm_numptob
)
127 ret
= scm_ptobs
[ptobnum
];
129 scm_i_pthread_mutex_unlock (&scm_ptobs_lock
);
132 scm_out_of_range ("scm_c_port_type_ref", scm_from_long (ptobnum
));
138 scm_c_port_type_add_x (scm_t_ptob_descriptor
*desc
)
142 scm_i_pthread_mutex_lock (&scm_ptobs_lock
);
144 if (scm_numptob
+ 1 < SCM_I_MAX_PORT_TYPE_COUNT
)
146 if (scm_numptob
== scm_ptobs_size
)
148 unsigned long old_size
= scm_ptobs_size
;
149 scm_t_ptob_descriptor
**old_ptobs
= scm_ptobs
;
151 /* Currently there are only 9 predefined port types, so one
152 resize will cover it. */
153 scm_ptobs_size
= old_size
+ 10;
155 if (scm_ptobs_size
>= SCM_I_MAX_PORT_TYPE_COUNT
)
156 scm_ptobs_size
= SCM_I_MAX_PORT_TYPE_COUNT
;
158 scm_ptobs
= scm_gc_malloc (sizeof (*scm_ptobs
) * scm_ptobs_size
,
161 memcpy (scm_ptobs
, old_ptobs
, sizeof (*scm_ptobs
) * scm_numptob
);
165 scm_ptobs
[ret
] = desc
;
168 scm_i_pthread_mutex_unlock (&scm_ptobs_lock
);
171 scm_out_of_range ("scm_c_port_type_add_x", scm_from_long (scm_numptob
));
177 * We choose to use an interface similar to the smob interface with
178 * fill_input and write as standard fields, passed to the port
179 * type constructor, and optional fields set by setters.
183 flush_port_default (SCM port SCM_UNUSED
)
188 end_input_default (SCM port SCM_UNUSED
, int offset SCM_UNUSED
)
193 scm_make_port_type (char *name
,
194 int (*fill_input
) (SCM port
),
195 void (*write
) (SCM port
, const void *data
, size_t size
))
197 scm_t_ptob_descriptor
*desc
;
200 desc
= scm_gc_malloc_pointerless (sizeof (*desc
), "port-type");
201 memset (desc
, 0, sizeof (*desc
));
204 desc
->print
= scm_port_print
;
206 desc
->flush
= flush_port_default
;
207 desc
->end_input
= end_input_default
;
208 desc
->fill_input
= fill_input
;
210 ptobnum
= scm_c_port_type_add_x (desc
);
212 /* Make a class object if GOOPS is present. */
213 if (SCM_UNPACK (scm_port_class
[0]) != 0)
214 scm_make_port_classes (ptobnum
, name
);
216 return scm_tc7_port
+ ptobnum
* 256;
220 scm_set_port_mark (scm_t_bits tc
, SCM (*mark
) (SCM
))
222 scm_c_port_type_ref (SCM_TC2PTOBNUM (tc
))->mark
= mark
;
226 scm_set_port_free (scm_t_bits tc
, size_t (*free
) (SCM
))
228 scm_c_port_type_ref (SCM_TC2PTOBNUM (tc
))->free
= free
;
232 scm_set_port_print (scm_t_bits tc
, int (*print
) (SCM exp
, SCM port
,
233 scm_print_state
*pstate
))
235 scm_c_port_type_ref (SCM_TC2PTOBNUM (tc
))->print
= print
;
239 scm_set_port_equalp (scm_t_bits tc
, SCM (*equalp
) (SCM
, SCM
))
241 scm_c_port_type_ref (SCM_TC2PTOBNUM (tc
))->equalp
= equalp
;
245 scm_set_port_close (scm_t_bits tc
, int (*close
) (SCM
))
247 scm_c_port_type_ref (SCM_TC2PTOBNUM (tc
))->close
= close
;
251 scm_set_port_flush (scm_t_bits tc
, void (*flush
) (SCM port
))
253 scm_t_ptob_descriptor
*ptob
= scm_c_port_type_ref (SCM_TC2PTOBNUM (tc
));
255 ptob
->flags
|= SCM_PORT_TYPE_HAS_FLUSH
;
259 scm_set_port_end_input (scm_t_bits tc
, void (*end_input
) (SCM port
, int offset
))
261 scm_c_port_type_ref (SCM_TC2PTOBNUM (tc
))->end_input
= end_input
;
265 scm_set_port_seek (scm_t_bits tc
, scm_t_off (*seek
) (SCM
, scm_t_off
, int))
267 scm_c_port_type_ref (SCM_TC2PTOBNUM (tc
))->seek
= seek
;
271 scm_set_port_truncate (scm_t_bits tc
, void (*truncate
) (SCM
, scm_t_off
))
273 scm_c_port_type_ref (SCM_TC2PTOBNUM (tc
))->truncate
= truncate
;
277 scm_set_port_input_waiting (scm_t_bits tc
, int (*input_waiting
) (SCM
))
279 scm_c_port_type_ref (SCM_TC2PTOBNUM (tc
))->input_waiting
= input_waiting
;
284 /* Standard ports --- current input, output, error, and more(!). */
286 static SCM cur_inport_fluid
= SCM_BOOL_F
;
287 static SCM cur_outport_fluid
= SCM_BOOL_F
;
288 static SCM cur_errport_fluid
= SCM_BOOL_F
;
289 static SCM cur_loadport_fluid
= SCM_BOOL_F
;
291 SCM_DEFINE (scm_current_input_port
, "current-input-port", 0, 0, 0,
293 "Return the current input port. This is the default port used\n"
294 "by many input procedures. Initially, @code{current-input-port}\n"
295 "returns the @dfn{standard input} in Unix and C terminology.")
296 #define FUNC_NAME s_scm_current_input_port
298 if (scm_is_true (cur_inport_fluid
))
299 return scm_fluid_ref (cur_inport_fluid
);
305 SCM_DEFINE (scm_current_output_port
, "current-output-port", 0, 0, 0,
307 "Return the current output port. This is the default port used\n"
308 "by many output procedures. Initially,\n"
309 "@code{current-output-port} returns the @dfn{standard output} in\n"
310 "Unix and C terminology.")
311 #define FUNC_NAME s_scm_current_output_port
313 if (scm_is_true (cur_outport_fluid
))
314 return scm_fluid_ref (cur_outport_fluid
);
320 SCM_DEFINE (scm_current_error_port
, "current-error-port", 0, 0, 0,
322 "Return the port to which errors and warnings should be sent (the\n"
323 "@dfn{standard error} in Unix and C terminology).")
324 #define FUNC_NAME s_scm_current_error_port
326 if (scm_is_true (cur_errport_fluid
))
327 return scm_fluid_ref (cur_errport_fluid
);
334 scm_current_warning_port (void)
336 static SCM cwp_var
= SCM_BOOL_F
;
338 if (scm_is_false (cwp_var
))
339 cwp_var
= scm_c_private_lookup ("guile", "current-warning-port");
341 return scm_call_0 (scm_variable_ref (cwp_var
));
344 SCM_DEFINE (scm_current_load_port
, "current-load-port", 0, 0, 0,
346 "Return the current-load-port.\n"
347 "The load port is used internally by @code{primitive-load}.")
348 #define FUNC_NAME s_scm_current_load_port
350 return scm_fluid_ref (cur_loadport_fluid
);
354 SCM_DEFINE (scm_set_current_input_port
, "set-current-input-port", 1, 0, 0,
356 "@deffnx {Scheme Procedure} set-current-output-port port\n"
357 "@deffnx {Scheme Procedure} set-current-error-port port\n"
358 "Change the ports returned by @code{current-input-port},\n"
359 "@code{current-output-port} and @code{current-error-port}, respectively,\n"
360 "so that they use the supplied @var{port} for input or output.")
361 #define FUNC_NAME s_scm_set_current_input_port
363 SCM oinp
= scm_fluid_ref (cur_inport_fluid
);
364 SCM_VALIDATE_OPINPORT (1, port
);
365 scm_fluid_set_x (cur_inport_fluid
, port
);
371 SCM_DEFINE (scm_set_current_output_port
, "set-current-output-port", 1, 0, 0,
373 "Set the current default output port to @var{port}.")
374 #define FUNC_NAME s_scm_set_current_output_port
376 SCM ooutp
= scm_fluid_ref (cur_outport_fluid
);
377 port
= SCM_COERCE_OUTPORT (port
);
378 SCM_VALIDATE_OPOUTPORT (1, port
);
379 scm_fluid_set_x (cur_outport_fluid
, port
);
385 SCM_DEFINE (scm_set_current_error_port
, "set-current-error-port", 1, 0, 0,
387 "Set the current default error port to @var{port}.")
388 #define FUNC_NAME s_scm_set_current_error_port
390 SCM oerrp
= scm_fluid_ref (cur_errport_fluid
);
391 port
= SCM_COERCE_OUTPORT (port
);
392 SCM_VALIDATE_OPOUTPORT (1, port
);
393 scm_fluid_set_x (cur_errport_fluid
, port
);
400 scm_set_current_warning_port (SCM port
)
402 static SCM cwp_var
= SCM_BOOL_F
;
404 if (scm_is_false (cwp_var
))
405 cwp_var
= scm_c_private_lookup ("guile", "current-warning-port");
407 return scm_call_1 (scm_variable_ref (cwp_var
), port
);
412 scm_dynwind_current_input_port (SCM port
)
413 #define FUNC_NAME NULL
415 SCM_VALIDATE_OPINPORT (1, port
);
416 scm_dynwind_fluid (cur_inport_fluid
, port
);
421 scm_dynwind_current_output_port (SCM port
)
422 #define FUNC_NAME NULL
424 port
= SCM_COERCE_OUTPORT (port
);
425 SCM_VALIDATE_OPOUTPORT (1, port
);
426 scm_dynwind_fluid (cur_outport_fluid
, port
);
431 scm_dynwind_current_error_port (SCM port
)
432 #define FUNC_NAME NULL
434 port
= SCM_COERCE_OUTPORT (port
);
435 SCM_VALIDATE_OPOUTPORT (1, port
);
436 scm_dynwind_fluid (cur_errport_fluid
, port
);
441 scm_i_dynwind_current_load_port (SCM port
)
443 scm_dynwind_fluid (cur_loadport_fluid
, port
);
449 /* Retrieving a port's mode. */
451 /* Return the flags that characterize a port based on the mode
452 * string used to open a file for that port.
454 * See PORT FLAGS in scm.h
458 scm_i_mode_bits_n (SCM modes
)
461 | (scm_i_string_contains_char (modes
, 'r')
462 || scm_i_string_contains_char (modes
, '+') ? SCM_RDNG
: 0)
463 | (scm_i_string_contains_char (modes
, 'w')
464 || scm_i_string_contains_char (modes
, 'a')
465 || scm_i_string_contains_char (modes
, '+') ? SCM_WRTNG
: 0)
466 | (scm_i_string_contains_char (modes
, '0') ? SCM_BUF0
: 0)
467 | (scm_i_string_contains_char (modes
, 'l') ? SCM_BUFLINE
: 0));
471 scm_mode_bits (char *modes
)
473 /* Valid characters are rw+a0l. So, use latin1. */
474 return scm_i_mode_bits (scm_from_latin1_string (modes
));
478 scm_i_mode_bits (SCM modes
)
482 if (!scm_is_string (modes
))
483 scm_wrong_type_arg_msg (NULL
, 0, modes
, "string");
485 bits
= scm_i_mode_bits_n (modes
);
486 scm_remember_upto_here_1 (modes
);
490 /* Return the mode flags from an open port.
491 * Some modes such as "append" are only used when opening
492 * a file and are not returned here. */
494 SCM_DEFINE (scm_port_mode
, "port-mode", 1, 0, 0,
496 "Return the port modes associated with the open port @var{port}.\n"
497 "These will not necessarily be identical to the modes used when\n"
498 "the port was opened, since modes such as \"append\" which are\n"
499 "used only during port creation are not retained.")
500 #define FUNC_NAME s_scm_port_mode
505 port
= SCM_COERCE_OUTPORT (port
);
506 SCM_VALIDATE_OPPORT (1, port
);
507 if (SCM_CELL_WORD_0 (port
) & SCM_RDNG
) {
508 if (SCM_CELL_WORD_0 (port
) & SCM_WRTNG
)
509 strcpy (modes
, "r+");
513 else if (SCM_CELL_WORD_0 (port
) & SCM_WRTNG
)
515 if (SCM_CELL_WORD_0 (port
) & SCM_BUF0
)
518 return scm_from_latin1_string (modes
);
525 /* The port table --- a weak set of all ports.
527 We need a global registry of ports to flush them all at exit, and to
528 get all the ports matching a file descriptor. */
529 SCM scm_i_port_weak_set
;
534 /* Port finalization. */
538 scm_t_ptob_descriptor
*ptob
;
543 do_free (void *body_data
)
545 struct do_free_data
*data
= body_data
;
547 /* `close' is for explicit `close-port' by user. `free' is for this
548 purpose: ports collected by the GC. */
549 data
->ptob
->free (data
->port
);
554 /* Finalize the object (a port) pointed to by PTR. */
556 finalize_port (void *ptr
, void *data
)
558 SCM port
= SCM_PACK_POINTER (ptr
);
560 if (!SCM_PORTP (port
))
563 if (SCM_OPENP (port
))
565 struct do_free_data data
;
567 SCM_CLR_PORT_OPEN_FLAG (port
);
569 data
.ptob
= SCM_PORT_DESCRIPTOR (port
);
572 scm_internal_catch (SCM_BOOL_T
, do_free
, &data
,
573 scm_handle_by_message_noexit
, NULL
);
575 scm_gc_ports_collected
++;
583 scm_c_make_port_with_encoding (scm_t_bits tag
, unsigned long mode_bits
,
584 const char *encoding
,
585 scm_t_string_failed_conversion_handler handler
,
590 scm_t_ptob_descriptor
*ptob
;
592 entry
= (scm_t_port
*) scm_gc_calloc (sizeof (scm_t_port
), "port");
593 ptob
= scm_c_port_type_ref (SCM_TC2PTOBNUM (tag
));
595 ret
= scm_words (tag
| mode_bits
, 3);
596 SCM_SET_CELL_WORD_1 (ret
, (scm_t_bits
) entry
);
597 SCM_SET_CELL_WORD_2 (ret
, (scm_t_bits
) ptob
);
599 entry
->lock
= scm_gc_malloc_pointerless (sizeof (*entry
->lock
), "port lock");
600 scm_i_pthread_mutex_init (entry
->lock
, scm_i_pthread_mutexattr_recursive
);
602 entry
->file_name
= SCM_BOOL_F
;
603 entry
->rw_active
= SCM_PORT_NEITHER
;
605 entry
->stream
= stream
;
606 entry
->encoding
= encoding
? scm_gc_strdup (encoding
, "port") : NULL
;
607 if (encoding
&& strcmp (encoding
, "UTF-8") == 0)
608 entry
->encoding_mode
= SCM_PORT_ENCODING_MODE_UTF8
;
609 else if (!encoding
|| strcmp (encoding
, "ISO-8859-1") == 0)
610 entry
->encoding_mode
= SCM_PORT_ENCODING_MODE_LATIN1
;
612 entry
->encoding_mode
= SCM_PORT_ENCODING_MODE_ICONV
;
613 entry
->ilseq_handler
= handler
;
614 entry
->iconv_descriptors
= NULL
;
616 if (SCM_PORT_DESCRIPTOR (ret
)->free
)
617 scm_i_set_finalizer (SCM2PTR (ret
), finalize_port
, NULL
);
619 if (SCM_PORT_DESCRIPTOR (ret
)->flags
& SCM_PORT_TYPE_HAS_FLUSH
)
620 scm_weak_set_add_x (scm_i_port_weak_set
, ret
);
626 scm_c_make_port (scm_t_bits tag
, unsigned long mode_bits
, scm_t_bits stream
)
628 return scm_c_make_port_with_encoding (tag
, mode_bits
,
629 scm_i_default_port_encoding (),
630 scm_i_default_port_conversion_handler (),
635 scm_new_port_table_entry (scm_t_bits tag
)
637 return scm_c_make_port (tag
, 0, 0);
644 SCM_DEFINE (scm_port_p
, "port?", 1, 0, 0,
646 "Return a boolean indicating whether @var{x} is a port.\n"
647 "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
649 #define FUNC_NAME s_scm_port_p
651 return scm_from_bool (SCM_PORTP (x
));
655 SCM_DEFINE (scm_input_port_p
, "input-port?", 1, 0, 0,
657 "Return @code{#t} if @var{x} is an input port, otherwise return\n"
658 "@code{#f}. Any object satisfying this predicate also satisfies\n"
660 #define FUNC_NAME s_scm_input_port_p
662 return scm_from_bool (SCM_INPUT_PORT_P (x
));
666 SCM_DEFINE (scm_output_port_p
, "output-port?", 1, 0, 0,
668 "Return @code{#t} if @var{x} is an output port, otherwise return\n"
669 "@code{#f}. Any object satisfying this predicate also satisfies\n"
671 #define FUNC_NAME s_scm_output_port_p
673 x
= SCM_COERCE_OUTPORT (x
);
674 return scm_from_bool (SCM_OUTPUT_PORT_P (x
));
678 SCM_DEFINE (scm_port_closed_p
, "port-closed?", 1, 0, 0,
680 "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
682 #define FUNC_NAME s_scm_port_closed_p
684 SCM_VALIDATE_PORT (1, port
);
685 return scm_from_bool (!SCM_OPPORTP (port
));
689 SCM_DEFINE (scm_eof_object_p
, "eof-object?", 1, 0, 0,
691 "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
693 #define FUNC_NAME s_scm_eof_object_p
695 return scm_from_bool (SCM_EOF_OBJECT_P (x
));
704 static void close_iconv_descriptors (scm_t_iconv_descriptors
*id
);
707 * Call the close operation on a port object.
708 * see also scm_close.
710 SCM_DEFINE (scm_close_port
, "close-port", 1, 0, 0,
712 "Close the specified port object. Return @code{#t} if it\n"
713 "successfully closes a port or @code{#f} if it was already\n"
714 "closed. An exception may be raised if an error occurs, for\n"
715 "example when flushing buffered output. See also @ref{Ports and\n"
716 "File Descriptors, close}, for a procedure which can close file\n"
718 #define FUNC_NAME s_scm_close_port
723 port
= SCM_COERCE_OUTPORT (port
);
725 SCM_VALIDATE_PORT (1, port
);
726 if (SCM_CLOSEDP (port
))
729 p
= SCM_PTAB_ENTRY (port
);
730 SCM_CLR_PORT_OPEN_FLAG (port
);
732 if (SCM_PORT_DESCRIPTOR (port
)->flags
& SCM_PORT_TYPE_HAS_FLUSH
)
733 scm_weak_set_remove_x (scm_i_port_weak_set
, port
);
735 if (SCM_PORT_DESCRIPTOR (port
)->close
)
736 /* Note! This may throw an exception. Anything after this point
737 should be resilient to non-local exits. */
738 rv
= SCM_PORT_DESCRIPTOR (port
)->close (port
);
742 if (p
->iconv_descriptors
)
744 /* If we don't get here, the iconv_descriptors finalizer will
746 close_iconv_descriptors (p
->iconv_descriptors
);
747 p
->iconv_descriptors
= NULL
;
750 return scm_from_bool (rv
>= 0);
754 SCM_DEFINE (scm_close_input_port
, "close-input-port", 1, 0, 0,
756 "Close the specified input port object. The routine has no effect if\n"
757 "the file has already been closed. An exception may be raised if an\n"
758 "error occurs. The value returned is unspecified.\n\n"
759 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
760 "which can close file descriptors.")
761 #define FUNC_NAME s_scm_close_input_port
763 SCM_VALIDATE_INPUT_PORT (1, port
);
764 scm_close_port (port
);
765 return SCM_UNSPECIFIED
;
769 SCM_DEFINE (scm_close_output_port
, "close-output-port", 1, 0, 0,
771 "Close the specified output port object. The routine has no effect if\n"
772 "the file has already been closed. An exception may be raised if an\n"
773 "error occurs. The value returned is unspecified.\n\n"
774 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
775 "which can close file descriptors.")
776 #define FUNC_NAME s_scm_close_output_port
778 port
= SCM_COERCE_OUTPORT (port
);
779 SCM_VALIDATE_OUTPUT_PORT (1, port
);
780 scm_close_port (port
);
781 return SCM_UNSPECIFIED
;
788 /* Encoding characters to byte streams, and decoding byte streams to
791 /* A fluid specifying the default encoding for newly created ports. If it is
792 a string, that is the encoding. If it is #f, it is in the "native"
793 (Latin-1) encoding. */
794 SCM_VARIABLE (default_port_encoding_var
, "%default-port-encoding");
796 static int scm_port_encoding_init
= 0;
798 /* Use ENCODING as the default encoding for future ports. */
800 scm_i_set_default_port_encoding (const char *encoding
)
802 if (!scm_port_encoding_init
803 || !scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var
)))
804 scm_misc_error (NULL
, "tried to set port encoding fluid before it is initialized",
808 || !strcmp (encoding
, "ASCII")
809 || !strcmp (encoding
, "ANSI_X3.4-1968")
810 || !strcmp (encoding
, "ISO-8859-1"))
811 scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var
), SCM_BOOL_F
);
817 str
= scm_from_latin1_string (encoding
);
819 /* Restrict to ASCII. */
820 for (i
= 0; encoding
[i
]; i
++)
821 if (encoding
[i
] > 127)
822 scm_misc_error ("scm_i_set_default_port_encoding",
823 "invalid character encoding ~s", scm_list_1 (str
));
825 scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var
), str
);
829 /* Return the name of the default encoding for newly created ports; a
830 return value of NULL means "ISO-8859-1". */
832 scm_i_default_port_encoding (void)
834 if (!scm_port_encoding_init
)
836 else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var
)))
842 encoding
= scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var
));
843 if (!scm_is_string (encoding
))
846 return scm_i_string_chars (encoding
);
850 /* A fluid specifying the default conversion handler for newly created
851 ports. Its value should be one of the symbols below. */
852 SCM_VARIABLE (default_conversion_strategy_var
,
853 "%default-port-conversion-strategy");
855 /* Whether the above fluid is initialized. */
856 static int scm_conversion_strategy_init
= 0;
858 /* The possible conversion strategies. */
859 SCM_SYMBOL (sym_error
, "error");
860 SCM_SYMBOL (sym_substitute
, "substitute");
861 SCM_SYMBOL (sym_escape
, "escape");
863 /* Return the default failed encoding conversion policy for new created
865 scm_t_string_failed_conversion_handler
866 scm_i_default_port_conversion_handler (void)
868 scm_t_string_failed_conversion_handler handler
;
870 if (!scm_conversion_strategy_init
871 || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var
)))
872 handler
= SCM_FAILED_CONVERSION_QUESTION_MARK
;
877 fluid
= SCM_VARIABLE_REF (default_conversion_strategy_var
);
878 value
= scm_fluid_ref (fluid
);
880 if (scm_is_eq (sym_substitute
, value
))
881 handler
= SCM_FAILED_CONVERSION_QUESTION_MARK
;
882 else if (scm_is_eq (sym_escape
, value
))
883 handler
= SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE
;
885 /* Default to 'error also when the fluid's value is not one of
886 the valid symbols. */
887 handler
= SCM_FAILED_CONVERSION_ERROR
;
893 /* Use HANDLER as the default conversion strategy for future ports. */
895 scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handler
900 if (!scm_conversion_strategy_init
901 || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var
)))
902 scm_misc_error (NULL
, "tried to set conversion strategy fluid before it is initialized",
907 case SCM_FAILED_CONVERSION_ERROR
:
908 strategy
= sym_error
;
911 case SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE
:
912 strategy
= sym_escape
;
915 case SCM_FAILED_CONVERSION_QUESTION_MARK
:
916 strategy
= sym_substitute
;
923 scm_fluid_set_x (SCM_VARIABLE_REF (default_conversion_strategy_var
),
928 finalize_iconv_descriptors (void *ptr
, void *data
)
930 close_iconv_descriptors (ptr
);
933 static scm_t_iconv_descriptors
*
934 open_iconv_descriptors (const char *encoding
, int reading
, int writing
)
936 scm_t_iconv_descriptors
*id
;
937 iconv_t input_cd
, output_cd
;
940 input_cd
= (iconv_t
) -1;
941 output_cd
= (iconv_t
) -1;
943 for (i
= 0; encoding
[i
]; i
++)
944 if (encoding
[i
] > 127)
945 goto invalid_encoding
;
949 /* Open an input iconv conversion descriptor, from ENCODING
950 to UTF-8. We choose UTF-8, not UTF-32, because iconv
951 implementations can typically convert from anything to
952 UTF-8, but not to UTF-32 (see
953 <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00007.html>). */
955 /* Assume opening an iconv descriptor causes about 16 KB of
957 scm_gc_register_allocation (16 * 1024);
959 input_cd
= iconv_open ("UTF-8", encoding
);
960 if (input_cd
== (iconv_t
) -1)
961 goto invalid_encoding
;
966 /* Assume opening an iconv descriptor causes about 16 KB of
968 scm_gc_register_allocation (16 * 1024);
970 output_cd
= iconv_open (encoding
, "UTF-8");
971 if (output_cd
== (iconv_t
) -1)
973 if (input_cd
!= (iconv_t
) -1)
974 iconv_close (input_cd
);
975 goto invalid_encoding
;
979 id
= scm_gc_malloc_pointerless (sizeof (*id
), "iconv descriptors");
980 id
->input_cd
= input_cd
;
981 id
->output_cd
= output_cd
;
983 /* Register a finalizer to close the descriptors. */
984 scm_i_set_finalizer (id
, finalize_iconv_descriptors
, NULL
);
991 err
= scm_from_latin1_string (encoding
);
992 scm_misc_error ("open_iconv_descriptors",
993 "invalid or unknown character encoding ~s",
999 close_iconv_descriptors (scm_t_iconv_descriptors
*id
)
1001 if (id
->input_cd
!= (iconv_t
) -1)
1002 iconv_close (id
->input_cd
);
1003 if (id
->output_cd
!= (iconv_t
) -1)
1004 iconv_close (id
->output_cd
);
1005 id
->input_cd
= (void *) -1;
1006 id
->output_cd
= (void *) -1;
1009 scm_t_iconv_descriptors
*
1010 scm_i_port_iconv_descriptors (SCM port
)
1014 pt
= SCM_PTAB_ENTRY (port
);
1016 assert (pt
->encoding_mode
== SCM_PORT_ENCODING_MODE_ICONV
);
1018 if (!pt
->iconv_descriptors
)
1021 pt
->encoding
= "ISO-8859-1";
1022 pt
->iconv_descriptors
=
1023 open_iconv_descriptors (pt
->encoding
,
1024 SCM_INPUT_PORT_P (port
),
1025 SCM_OUTPUT_PORT_P (port
));
1028 return pt
->iconv_descriptors
;
1031 /* The name of the encoding is itself encoded in ASCII. */
1033 scm_i_set_port_encoding_x (SCM port
, const char *encoding
)
1036 scm_t_iconv_descriptors
*prev
;
1038 /* Set the character encoding for this port. */
1039 pt
= SCM_PTAB_ENTRY (port
);
1040 prev
= pt
->iconv_descriptors
;
1042 if (encoding
&& strcmp (encoding
, "UTF-8") == 0)
1044 pt
->encoding
= "UTF-8";
1045 pt
->encoding_mode
= SCM_PORT_ENCODING_MODE_UTF8
;
1046 pt
->iconv_descriptors
= NULL
;
1048 else if (!encoding
|| strcmp (encoding
, "ISO-8859-1") == 0)
1050 pt
->encoding
= "ISO-8859-1";
1051 pt
->encoding_mode
= SCM_PORT_ENCODING_MODE_LATIN1
;
1052 pt
->iconv_descriptors
= NULL
;
1056 /* Open descriptors before mutating the port. */
1057 pt
->iconv_descriptors
=
1058 open_iconv_descriptors (encoding
,
1059 SCM_INPUT_PORT_P (port
),
1060 SCM_OUTPUT_PORT_P (port
));
1061 pt
->encoding
= scm_gc_strdup (encoding
, "port");
1062 pt
->encoding_mode
= SCM_PORT_ENCODING_MODE_ICONV
;
1066 close_iconv_descriptors (prev
);
1069 SCM_DEFINE (scm_port_encoding
, "port-encoding", 1, 0, 0,
1071 "Returns, as a string, the character encoding that @var{port}\n"
1072 "uses to interpret its input and output.\n")
1073 #define FUNC_NAME s_scm_port_encoding
1078 SCM_VALIDATE_PORT (1, port
);
1080 pt
= SCM_PTAB_ENTRY (port
);
1083 return scm_from_latin1_string (pt
->encoding
);
1089 SCM_DEFINE (scm_set_port_encoding_x
, "set-port-encoding!", 2, 0, 0,
1090 (SCM port
, SCM enc
),
1091 "Sets the character encoding that will be used to interpret all\n"
1092 "port I/O. New ports are created with the encoding\n"
1093 "appropriate for the current locale if @code{setlocale} has \n"
1094 "been called or ISO-8859-1 otherwise\n"
1095 "and this procedure can be used to modify that encoding.\n")
1096 #define FUNC_NAME s_scm_set_port_encoding_x
1100 SCM_VALIDATE_PORT (1, port
);
1101 SCM_VALIDATE_STRING (2, enc
);
1103 enc_str
= scm_to_latin1_string (enc
);
1104 scm_i_set_port_encoding_x (port
, enc_str
);
1107 return SCM_UNSPECIFIED
;
1111 SCM_DEFINE (scm_port_conversion_strategy
, "port-conversion-strategy",
1112 1, 0, 0, (SCM port
),
1113 "Returns the behavior of the port when handling a character that\n"
1114 "is not representable in the port's current encoding.\n"
1115 "It returns the symbol @code{error} if unrepresentable characters\n"
1116 "should cause exceptions, @code{substitute} if the port should\n"
1117 "try to replace unrepresentable characters with question marks or\n"
1118 "approximate characters, or @code{escape} if unrepresentable\n"
1119 "characters should be converted to string escapes.\n"
1121 "If @var{port} is @code{#f}, then the current default behavior\n"
1122 "will be returned. New ports will have this default behavior\n"
1123 "when they are created.\n")
1124 #define FUNC_NAME s_scm_port_conversion_strategy
1126 scm_t_string_failed_conversion_handler h
;
1128 SCM_VALIDATE_OPPORT (1, port
);
1130 if (scm_is_false (port
))
1131 h
= scm_i_default_port_conversion_handler ();
1136 SCM_VALIDATE_OPPORT (1, port
);
1137 pt
= SCM_PTAB_ENTRY (port
);
1139 h
= pt
->ilseq_handler
;
1142 if (h
== SCM_FAILED_CONVERSION_ERROR
)
1143 return scm_from_latin1_symbol ("error");
1144 else if (h
== SCM_FAILED_CONVERSION_QUESTION_MARK
)
1145 return scm_from_latin1_symbol ("substitute");
1146 else if (h
== SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE
)
1147 return scm_from_latin1_symbol ("escape");
1151 /* Never gets here. */
1152 return SCM_UNDEFINED
;
1156 SCM_DEFINE (scm_set_port_conversion_strategy_x
, "set-port-conversion-strategy!",
1158 (SCM port
, SCM sym
),
1159 "Sets the behavior of the interpreter when outputting a character\n"
1160 "that is not representable in the port's current encoding.\n"
1161 "@var{sym} can be either @code{'error}, @code{'substitute}, or\n"
1162 "@code{'escape}. If it is @code{'error}, an error will be thrown\n"
1163 "when an unconvertible character is encountered. If it is\n"
1164 "@code{'substitute}, then unconvertible characters will \n"
1165 "be replaced with approximate characters, or with question marks\n"
1166 "if no approximately correct character is available.\n"
1167 "If it is @code{'escape},\n"
1168 "it will appear as a hex escape when output.\n"
1170 "If @var{port} is an open port, the conversion error behavior\n"
1171 "is set for that port. If it is @code{#f}, it is set as the\n"
1172 "default behavior for any future ports that get created in\n"
1174 #define FUNC_NAME s_scm_set_port_conversion_strategy_x
1176 scm_t_string_failed_conversion_handler handler
;
1178 if (scm_is_eq (sym
, sym_error
))
1179 handler
= SCM_FAILED_CONVERSION_ERROR
;
1180 else if (scm_is_eq (sym
, sym_substitute
))
1181 handler
= SCM_FAILED_CONVERSION_QUESTION_MARK
;
1182 else if (scm_is_eq (sym
, sym_escape
))
1183 handler
= SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE
;
1185 SCM_MISC_ERROR ("unknown conversion strategy ~s", scm_list_1 (sym
));
1187 if (scm_is_false (port
))
1188 scm_i_set_default_port_conversion_handler (handler
);
1191 SCM_VALIDATE_OPPORT (1, port
);
1192 SCM_PTAB_ENTRY (port
)->ilseq_handler
= handler
;
1195 return SCM_UNSPECIFIED
;
1202 /* The port lock. */
1205 lock_port (void *mutex
)
1207 scm_i_pthread_mutex_lock (mutex
);
1211 unlock_port (void *mutex
)
1213 scm_i_pthread_mutex_unlock (mutex
);
1217 scm_dynwind_lock_port (SCM port
)
1218 #define FUNC_NAME "dynwind-lock-port"
1220 scm_i_pthread_mutex_t
*lock
;
1221 SCM_VALIDATE_OPPORT (SCM_ARG1
, port
);
1222 scm_c_lock_port (port
, &lock
);
1225 scm_dynwind_unwind_handler (unlock_port
, lock
, SCM_F_WIND_EXPLICITLY
);
1226 scm_dynwind_rewind_handler (lock_port
, lock
, 0);
1237 scm_get_byte_or_eof (SCM port
)
1239 scm_i_pthread_mutex_t
*lock
;
1242 scm_c_lock_port (port
, &lock
);
1243 ret
= scm_get_byte_or_eof_unlocked (port
);
1245 scm_i_pthread_mutex_unlock (lock
);
1251 scm_peek_byte_or_eof (SCM port
)
1253 scm_i_pthread_mutex_t
*lock
;
1256 scm_c_lock_port (port
, &lock
);
1257 ret
= scm_peek_byte_or_eof_unlocked (port
);
1259 scm_i_pthread_mutex_unlock (lock
);
1266 * Used by an application to read arbitrary number of bytes from an
1267 * SCM port. Same semantics as libc read, except that scm_c_read only
1268 * returns less than SIZE bytes if at end-of-file.
1270 * Warning: Doesn't update port line and column counts! */
1272 /* This structure, and the following swap_buffer function, are used
1273 for temporarily swapping a port's own read buffer, and the buffer
1274 that the caller of scm_c_read provides. */
1275 struct port_and_swap_buffer
1278 unsigned char *buffer
;
1283 swap_buffer (void *data
)
1285 struct port_and_swap_buffer
*psb
= (struct port_and_swap_buffer
*) data
;
1286 unsigned char *old_buf
= psb
->pt
->read_buf
;
1287 size_t old_size
= psb
->pt
->read_buf_size
;
1289 /* Make the port use (buffer, size) from the struct. */
1290 psb
->pt
->read_pos
= psb
->pt
->read_buf
= psb
->pt
->read_end
= psb
->buffer
;
1291 psb
->pt
->read_buf_size
= psb
->size
;
1293 /* Save the port's old (buffer, size) in the struct. */
1294 psb
->buffer
= old_buf
;
1295 psb
->size
= old_size
;
1299 scm_c_read_unlocked (SCM port
, void *buffer
, size_t size
)
1300 #define FUNC_NAME "scm_c_read"
1303 size_t n_read
= 0, n_available
;
1304 struct port_and_swap_buffer psb
;
1306 SCM_VALIDATE_OPINPORT (1, port
);
1308 pt
= SCM_PTAB_ENTRY (port
);
1309 if (pt
->rw_active
== SCM_PORT_WRITE
)
1310 SCM_PORT_DESCRIPTOR (port
)->flush (port
);
1313 pt
->rw_active
= SCM_PORT_READ
;
1315 /* Take bytes first from the port's read buffer. */
1316 if (pt
->read_pos
< pt
->read_end
)
1318 n_available
= min (size
, pt
->read_end
- pt
->read_pos
);
1319 memcpy (buffer
, pt
->read_pos
, n_available
);
1320 buffer
= (char *) buffer
+ n_available
;
1321 pt
->read_pos
+= n_available
;
1322 n_read
+= n_available
;
1323 size
-= n_available
;
1326 /* Avoid the scm_dynwind_* costs if we now have enough data. */
1330 /* Now we will call scm_fill_input repeatedly until we have read the
1331 requested number of bytes. (Note that a single scm_fill_input
1332 call does not guarantee to fill the whole of the port's read
1334 if (pt
->read_buf_size
<= 1 && pt
->encoding
== NULL
)
1336 /* The port that we are reading from is unbuffered - i.e. does
1337 not have its own persistent buffer - but we have a buffer,
1338 provided by our caller, that is the right size for the data
1339 that is wanted. For the following scm_fill_input calls,
1340 therefore, we use the buffer in hand as the port's read
1343 We need to make sure that the port's normal (1 byte) buffer
1344 is reinstated in case one of the scm_fill_input () calls
1345 throws an exception; we use the scm_dynwind_* API to achieve
1348 A consequence of this optimization is that the fill_input
1349 functions can't unget characters. That'll push data to the
1350 pushback buffer instead of this psb buffer. */
1352 unsigned char *pback
= pt
->putback_buf
;
1355 psb
.buffer
= buffer
;
1357 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1358 scm_dynwind_rewind_handler (swap_buffer
, &psb
, SCM_F_WIND_EXPLICITLY
);
1359 scm_dynwind_unwind_handler (swap_buffer
, &psb
, SCM_F_WIND_EXPLICITLY
);
1361 /* Call scm_fill_input until we have all the bytes that we need,
1363 while (pt
->read_buf_size
&& (scm_fill_input_unlocked (port
) != EOF
))
1365 pt
->read_buf_size
-= (pt
->read_end
- pt
->read_pos
);
1366 pt
->read_pos
= pt
->read_buf
= pt
->read_end
;
1369 if (pback
!= pt
->putback_buf
1370 || pt
->read_buf
- (unsigned char *) buffer
< 0)
1371 scm_misc_error (FUNC_NAME
,
1372 "scm_c_read must not call a fill function that pushes "
1373 "back characters onto an unbuffered port", SCM_EOL
);
1375 n_read
+= pt
->read_buf
- (unsigned char *) buffer
;
1377 /* Reinstate the port's normal buffer. */
1382 /* The port has its own buffer. It is important that we use it,
1383 even if it happens to be smaller than our caller's buffer, so
1384 that a custom port implementation's entry points (in
1385 particular, fill_input) can rely on the buffer always being
1386 the same as they first set up. */
1387 while (size
&& (scm_fill_input_unlocked (port
) != EOF
))
1389 n_available
= min (size
, pt
->read_end
- pt
->read_pos
);
1390 memcpy (buffer
, pt
->read_pos
, n_available
);
1391 buffer
= (char *) buffer
+ n_available
;
1392 pt
->read_pos
+= n_available
;
1393 n_read
+= n_available
;
1394 size
-= n_available
;
1403 scm_c_read (SCM port
, void *buffer
, size_t size
)
1405 scm_i_pthread_mutex_t
*lock
;
1408 scm_c_lock_port (port
, &lock
);
1409 ret
= scm_c_read_unlocked (port
, buffer
, size
);
1411 scm_i_pthread_mutex_unlock (lock
);
1417 /* Update the line and column number of PORT after consumption of C. */
1419 update_port_lf (scm_t_wchar c
, SCM port
)
1444 #define SCM_MBCHAR_BUF_SIZE (4)
1446 /* Convert the SIZE-byte UTF-8 sequence in UTF8_BUF to a codepoint.
1447 UTF8_BUF is assumed to contain a valid UTF-8 sequence. */
1449 utf8_to_codepoint (const scm_t_uint8
*utf8_buf
, size_t size
)
1451 scm_t_wchar codepoint
;
1453 if (utf8_buf
[0] <= 0x7f)
1456 codepoint
= utf8_buf
[0];
1458 else if ((utf8_buf
[0] & 0xe0) == 0xc0)
1461 codepoint
= ((scm_t_wchar
) utf8_buf
[0] & 0x1f) << 6UL
1462 | (utf8_buf
[1] & 0x3f);
1464 else if ((utf8_buf
[0] & 0xf0) == 0xe0)
1467 codepoint
= ((scm_t_wchar
) utf8_buf
[0] & 0x0f) << 12UL
1468 | ((scm_t_wchar
) utf8_buf
[1] & 0x3f) << 6UL
1469 | (utf8_buf
[2] & 0x3f);
1474 codepoint
= ((scm_t_wchar
) utf8_buf
[0] & 0x07) << 18UL
1475 | ((scm_t_wchar
) utf8_buf
[1] & 0x3f) << 12UL
1476 | ((scm_t_wchar
) utf8_buf
[2] & 0x3f) << 6UL
1477 | (utf8_buf
[3] & 0x3f);
1483 /* Read a UTF-8 sequence from PORT. On success, return 0 and set
1484 *CODEPOINT to the codepoint that was read, fill BUF with its UTF-8
1485 representation, and set *LEN to the length in bytes. Return
1486 `EILSEQ' on error. */
1488 get_utf8_codepoint (SCM port
, scm_t_wchar
*codepoint
,
1489 scm_t_uint8 buf
[SCM_MBCHAR_BUF_SIZE
], size_t *len
)
1491 #define ASSERT_NOT_EOF(b) \
1492 if (SCM_UNLIKELY ((b) == EOF)) \
1494 #define CONSUME_PEEKED_BYTE() \
1501 pt
= SCM_PTAB_ENTRY (port
);
1503 byte
= scm_get_byte_or_eof_unlocked (port
);
1510 buf
[0] = (scm_t_uint8
) byte
;
1515 *codepoint
= buf
[0];
1516 else if (buf
[0] >= 0xc2 && buf
[0] <= 0xdf)
1519 byte
= scm_peek_byte_or_eof_unlocked (port
);
1520 ASSERT_NOT_EOF (byte
);
1522 if (SCM_UNLIKELY ((byte
& 0xc0) != 0x80))
1525 CONSUME_PEEKED_BYTE ();
1526 buf
[1] = (scm_t_uint8
) byte
;
1529 *codepoint
= ((scm_t_wchar
) buf
[0] & 0x1f) << 6UL
1532 else if ((buf
[0] & 0xf0) == 0xe0)
1535 byte
= scm_peek_byte_or_eof_unlocked (port
);
1536 ASSERT_NOT_EOF (byte
);
1538 if (SCM_UNLIKELY ((byte
& 0xc0) != 0x80
1539 || (buf
[0] == 0xe0 && byte
< 0xa0)
1540 || (buf
[0] == 0xed && byte
> 0x9f)))
1543 CONSUME_PEEKED_BYTE ();
1544 buf
[1] = (scm_t_uint8
) byte
;
1547 byte
= scm_peek_byte_or_eof_unlocked (port
);
1548 ASSERT_NOT_EOF (byte
);
1550 if (SCM_UNLIKELY ((byte
& 0xc0) != 0x80))
1553 CONSUME_PEEKED_BYTE ();
1554 buf
[2] = (scm_t_uint8
) byte
;
1557 *codepoint
= ((scm_t_wchar
) buf
[0] & 0x0f) << 12UL
1558 | ((scm_t_wchar
) buf
[1] & 0x3f) << 6UL
1561 else if (buf
[0] >= 0xf0 && buf
[0] <= 0xf4)
1564 byte
= scm_peek_byte_or_eof_unlocked (port
);
1565 ASSERT_NOT_EOF (byte
);
1567 if (SCM_UNLIKELY (((byte
& 0xc0) != 0x80)
1568 || (buf
[0] == 0xf0 && byte
< 0x90)
1569 || (buf
[0] == 0xf4 && byte
> 0x8f)))
1572 CONSUME_PEEKED_BYTE ();
1573 buf
[1] = (scm_t_uint8
) byte
;
1576 byte
= scm_peek_byte_or_eof_unlocked (port
);
1577 ASSERT_NOT_EOF (byte
);
1579 if (SCM_UNLIKELY ((byte
& 0xc0) != 0x80))
1582 CONSUME_PEEKED_BYTE ();
1583 buf
[2] = (scm_t_uint8
) byte
;
1586 byte
= scm_peek_byte_or_eof_unlocked (port
);
1587 ASSERT_NOT_EOF (byte
);
1589 if (SCM_UNLIKELY ((byte
& 0xc0) != 0x80))
1592 CONSUME_PEEKED_BYTE ();
1593 buf
[3] = (scm_t_uint8
) byte
;
1596 *codepoint
= ((scm_t_wchar
) buf
[0] & 0x07) << 18UL
1597 | ((scm_t_wchar
) buf
[1] & 0x3f) << 12UL
1598 | ((scm_t_wchar
) buf
[2] & 0x3f) << 6UL
1607 /* Here we could choose the consume the faulty byte when it's not a
1608 valid starting byte, but it's not a requirement. What Section 3.9
1609 of Unicode 6.0.0 mandates, though, is to not consume a byte that
1610 would otherwise be a valid starting byte. */
1614 #undef CONSUME_PEEKED_BYTE
1615 #undef ASSERT_NOT_EOF
1618 /* Read an ISO-8859-1 codepoint (a byte) from PORT. On success, return
1619 0 and set *CODEPOINT to the codepoint that was read, fill BUF with
1620 its UTF-8 representation, and set *LEN to the length in bytes.
1621 Return `EILSEQ' on error. */
1623 get_latin1_codepoint (SCM port
, scm_t_wchar
*codepoint
,
1624 char buf
[SCM_MBCHAR_BUF_SIZE
], size_t *len
)
1626 *codepoint
= scm_get_byte_or_eof_unlocked (port
);
1628 if (*codepoint
== EOF
)
1633 buf
[0] = *codepoint
;
1638 /* Likewise, read a byte sequence from PORT, passing it through its
1639 input conversion descriptor. */
1641 get_iconv_codepoint (SCM port
, scm_t_wchar
*codepoint
,
1642 char buf
[SCM_MBCHAR_BUF_SIZE
], size_t *len
)
1644 scm_t_iconv_descriptors
*id
;
1646 size_t bytes_consumed
, output_size
;
1648 scm_t_uint8 utf8_buf
[SCM_MBCHAR_BUF_SIZE
];
1650 id
= scm_i_port_iconv_descriptors (port
);
1652 for (output_size
= 0, output
= (char *) utf8_buf
,
1653 bytes_consumed
= 0, err
= 0;
1654 err
== 0 && output_size
== 0
1655 && (bytes_consumed
== 0 || byte_read
!= EOF
);
1659 size_t input_left
, output_left
, done
;
1661 byte_read
= scm_get_byte_or_eof_unlocked (port
);
1662 if (byte_read
== EOF
)
1664 if (bytes_consumed
== 0)
1666 *codepoint
= (scm_t_wchar
) EOF
;
1674 buf
[bytes_consumed
] = byte_read
;
1677 input_left
= bytes_consumed
+ 1;
1678 output_left
= sizeof (utf8_buf
);
1680 done
= iconv (id
->input_cd
, &input
, &input_left
, &output
, &output_left
);
1681 if (done
== (size_t) -1)
1685 /* Missing input: keep trying. */
1689 output_size
= sizeof (utf8_buf
) - output_left
;
1692 if (SCM_UNLIKELY (output_size
== 0))
1693 /* An unterminated sequence. */
1695 else if (SCM_LIKELY (err
== 0))
1697 /* Convert the UTF8_BUF sequence to a Unicode code point. */
1698 *codepoint
= utf8_to_codepoint (utf8_buf
, output_size
);
1699 *len
= bytes_consumed
;
1705 /* Read a codepoint from PORT and return it in *CODEPOINT. Fill BUF
1706 with the byte representation of the codepoint in PORT's encoding, and
1707 set *LEN to the length in bytes of that representation. Return 0 on
1708 success and an errno value on error. */
1709 static SCM_C_INLINE
int
1710 get_codepoint (SCM port
, scm_t_wchar
*codepoint
,
1711 char buf
[SCM_MBCHAR_BUF_SIZE
], size_t *len
)
1714 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1716 if (pt
->encoding_mode
== SCM_PORT_ENCODING_MODE_UTF8
)
1717 err
= get_utf8_codepoint (port
, codepoint
, (scm_t_uint8
*) buf
, len
);
1718 else if (pt
->encoding_mode
== SCM_PORT_ENCODING_MODE_LATIN1
)
1719 err
= get_latin1_codepoint (port
, codepoint
, buf
, len
);
1721 err
= get_iconv_codepoint (port
, codepoint
, buf
, len
);
1723 if (SCM_LIKELY (err
== 0))
1724 update_port_lf (*codepoint
, port
);
1725 else if (pt
->ilseq_handler
== SCM_ICONVEH_QUESTION_MARK
)
1729 update_port_lf (*codepoint
, port
);
1735 /* Read a codepoint from PORT and return it. */
1737 scm_getc_unlocked (SCM port
)
1738 #define FUNC_NAME "scm_getc"
1742 scm_t_wchar codepoint
;
1743 char buf
[SCM_MBCHAR_BUF_SIZE
];
1745 err
= get_codepoint (port
, &codepoint
, buf
, &len
);
1746 if (SCM_UNLIKELY (err
!= 0))
1747 /* At this point PORT should point past the invalid encoding, as per
1748 R6RS-lib Section 8.2.4. */
1749 scm_decoding_error (FUNC_NAME
, err
, "input decoding error", port
);
1758 scm_i_pthread_mutex_t
*lock
;
1761 scm_c_lock_port (port
, &lock
);
1762 ret
= scm_getc_unlocked (port
);
1764 scm_i_pthread_mutex_unlock (lock
);
1770 SCM_DEFINE (scm_read_char
, "read-char", 0, 1, 0,
1772 "Return the next character available from @var{port}, updating\n"
1773 "@var{port} to point to the following character. If no more\n"
1774 "characters are available, the end-of-file object is returned.\n"
1776 "When @var{port}'s data cannot be decoded according to its\n"
1777 "character encoding, a @code{decoding-error} is raised and\n"
1778 "@var{port} points past the erroneous byte sequence.\n")
1779 #define FUNC_NAME s_scm_read_char
1782 if (SCM_UNBNDP (port
))
1783 port
= scm_current_input_port ();
1784 SCM_VALIDATE_OPINPORT (1, port
);
1785 c
= scm_getc_unlocked (port
);
1788 return SCM_MAKE_CHAR (c
);
1798 scm_unget_byte_unlocked (int c
, SCM port
)
1799 #define FUNC_NAME "scm_unget_byte"
1801 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1803 if (pt
->read_buf
== pt
->putback_buf
)
1804 /* already using the put-back buffer. */
1806 /* enlarge putback_buf if necessary. */
1807 if (pt
->read_end
== pt
->read_buf
+ pt
->read_buf_size
1808 && pt
->read_buf
== pt
->read_pos
)
1810 size_t new_size
= pt
->read_buf_size
* 2;
1811 unsigned char *tmp
= (unsigned char *)
1812 scm_gc_realloc (pt
->putback_buf
, pt
->read_buf_size
, new_size
,
1815 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
= tmp
;
1816 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
1817 pt
->read_buf_size
= pt
->putback_buf_size
= new_size
;
1820 /* shift any existing bytes to buffer + 1. */
1821 if (pt
->read_pos
== pt
->read_end
)
1822 pt
->read_end
= pt
->read_buf
+ 1;
1823 else if (pt
->read_pos
!= pt
->read_buf
+ 1)
1825 int count
= pt
->read_end
- pt
->read_pos
;
1827 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
1828 pt
->read_end
= pt
->read_buf
+ 1 + count
;
1831 pt
->read_pos
= pt
->read_buf
;
1834 /* switch to the put-back buffer. */
1836 if (pt
->putback_buf
== NULL
)
1839 = (unsigned char *) scm_gc_malloc_pointerless
1840 (SCM_INITIAL_PUTBACK_BUF_SIZE
, "putback buffer");
1841 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
1844 pt
->saved_read_buf
= pt
->read_buf
;
1845 pt
->saved_read_pos
= pt
->read_pos
;
1846 pt
->saved_read_end
= pt
->read_end
;
1847 pt
->saved_read_buf_size
= pt
->read_buf_size
;
1849 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
1850 pt
->read_end
= pt
->read_buf
+ 1;
1851 pt
->read_buf_size
= pt
->putback_buf_size
;
1857 pt
->rw_active
= SCM_PORT_READ
;
1862 scm_unget_byte (int c
, SCM port
)
1864 scm_i_pthread_mutex_t
*lock
;
1865 scm_c_lock_port (port
, &lock
);
1866 scm_unget_byte_unlocked (c
, port
);
1868 scm_i_pthread_mutex_unlock (lock
);
1873 scm_ungetc_unlocked (scm_t_wchar c
, SCM port
)
1874 #define FUNC_NAME "scm_ungetc"
1876 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1878 char result_buf
[10];
1879 const char *encoding
;
1883 if (pt
->encoding
!= NULL
)
1884 encoding
= pt
->encoding
;
1886 encoding
= "ISO-8859-1";
1888 len
= sizeof (result_buf
);
1889 result
= u32_conv_to_encoding (encoding
,
1890 (enum iconv_ilseq_handler
) pt
->ilseq_handler
,
1891 (uint32_t *) &c
, 1, NULL
,
1894 if (SCM_UNLIKELY (result
== NULL
|| len
== 0))
1895 scm_encoding_error (FUNC_NAME
, errno
,
1896 "conversion to port encoding failed",
1897 SCM_BOOL_F
, SCM_MAKE_CHAR (c
));
1899 for (i
= len
- 1; i
>= 0; i
--)
1900 scm_unget_byte_unlocked (result
[i
], port
);
1902 if (SCM_UNLIKELY (result
!= result_buf
))
1907 /* What should col be in this case?
1908 * We'll leave it at -1.
1910 SCM_LINUM (port
) -= 1;
1918 scm_ungetc (scm_t_wchar c
, SCM port
)
1920 scm_i_pthread_mutex_t
*lock
;
1921 scm_c_lock_port (port
, &lock
);
1922 scm_ungetc_unlocked (c
, port
);
1924 scm_i_pthread_mutex_unlock (lock
);
1929 scm_ungets_unlocked (const char *s
, int n
, SCM port
)
1931 /* This is simple minded and inefficient, but unreading strings is
1932 * probably not a common operation, and remember that line and
1933 * column numbers have to be handled...
1935 * Please feel free to write an optimized version!
1938 scm_ungetc_unlocked (s
[n
], port
);
1942 scm_ungets (const char *s
, int n
, SCM port
)
1944 scm_i_pthread_mutex_t
*lock
;
1945 scm_c_lock_port (port
, &lock
);
1946 scm_ungets_unlocked (s
, n
, port
);
1948 scm_i_pthread_mutex_unlock (lock
);
1952 SCM_DEFINE (scm_peek_char
, "peek-char", 0, 1, 0,
1954 "Return the next character available from @var{port},\n"
1955 "@emph{without} updating @var{port} to point to the following\n"
1956 "character. If no more characters are available, the\n"
1957 "end-of-file object is returned.\n"
1959 "The value returned by\n"
1960 "a call to @code{peek-char} is the same as the value that would\n"
1961 "have been returned by a call to @code{read-char} on the same\n"
1962 "port. The only difference is that the very next call to\n"
1963 "@code{read-char} or @code{peek-char} on that @var{port} will\n"
1964 "return the value returned by the preceding call to\n"
1965 "@code{peek-char}. In particular, a call to @code{peek-char} on\n"
1966 "an interactive port will hang waiting for input whenever a call\n"
1967 "to @code{read-char} would have hung.\n"
1969 "As for @code{read-char}, a @code{decoding-error} may be raised\n"
1970 "if such a situation occurs. However, unlike with @code{read-char},\n"
1971 "@var{port} still points at the beginning of the erroneous byte\n"
1972 "sequence when the error is raised.\n")
1973 #define FUNC_NAME s_scm_peek_char
1978 char bytes
[SCM_MBCHAR_BUF_SIZE
];
1979 long column
, line
, i
;
1982 if (SCM_UNBNDP (port
))
1983 port
= scm_current_input_port ();
1984 SCM_VALIDATE_OPINPORT (1, port
);
1986 column
= SCM_COL (port
);
1987 line
= SCM_LINUM (port
);
1989 err
= get_codepoint (port
, &c
, bytes
, &len
);
1991 for (i
= len
- 1; i
>= 0; i
--)
1992 scm_unget_byte_unlocked (bytes
[i
], port
);
1994 SCM_COL (port
) = column
;
1995 SCM_LINUM (port
) = line
;
1997 if (SCM_UNLIKELY (err
!= 0))
1999 scm_decoding_error (FUNC_NAME
, err
, "input decoding error", port
);
2001 /* Shouldn't happen since `catch' always aborts to prompt. */
2002 result
= SCM_BOOL_F
;
2005 result
= SCM_EOF_VAL
;
2007 result
= SCM_MAKE_CHAR (c
);
2013 SCM_DEFINE (scm_unread_char
, "unread-char", 1, 1, 0,
2014 (SCM cobj
, SCM port
),
2015 "Place character @var{cobj} in @var{port} so that it will be\n"
2016 "read by the next read operation. If called multiple times, the\n"
2017 "unread characters will be read again in last-in first-out\n"
2018 "order. If @var{port} is not supplied, the current input port\n"
2020 #define FUNC_NAME s_scm_unread_char
2024 SCM_VALIDATE_CHAR (1, cobj
);
2025 if (SCM_UNBNDP (port
))
2026 port
= scm_current_input_port ();
2027 SCM_VALIDATE_OPINPORT (2, port
);
2029 c
= SCM_CHAR (cobj
);
2031 scm_ungetc_unlocked (c
, port
);
2036 SCM_DEFINE (scm_unread_string
, "unread-string", 2, 0, 0,
2037 (SCM str
, SCM port
),
2038 "Place the string @var{str} in @var{port} so that its characters will be\n"
2039 "read in subsequent read operations. If called multiple times, the\n"
2040 "unread characters will be read again in last-in first-out order. If\n"
2041 "@var{port} is not supplied, the current-input-port is used.")
2042 #define FUNC_NAME s_scm_unread_string
2045 SCM_VALIDATE_STRING (1, str
);
2046 if (SCM_UNBNDP (port
))
2047 port
= scm_current_input_port ();
2048 SCM_VALIDATE_OPINPORT (2, port
);
2050 n
= scm_i_string_length (str
);
2053 scm_ungetc_unlocked (scm_i_string_ref (str
, n
), port
);
2062 /* Manipulating the buffers. */
2064 /* This routine does not take any locks, as it is usually called as part
2065 of a port implementation. */
2067 scm_port_non_buffer (scm_t_port
*pt
)
2069 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
2070 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
2071 pt
->read_buf_size
= pt
->write_buf_size
= 1;
2072 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
2075 /* this should only be called when the read buffer is empty. it
2076 tries to refill the read buffer. it returns the first char from
2077 the port, which is either EOF or *(pt->read_pos). */
2079 scm_fill_input_unlocked (SCM port
)
2081 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2083 assert (pt
->read_pos
== pt
->read_end
);
2085 if (pt
->read_buf
== pt
->putback_buf
)
2087 /* finished reading put-back chars. */
2088 pt
->read_buf
= pt
->saved_read_buf
;
2089 pt
->read_pos
= pt
->saved_read_pos
;
2090 pt
->read_end
= pt
->saved_read_end
;
2091 pt
->read_buf_size
= pt
->saved_read_buf_size
;
2092 if (pt
->read_pos
< pt
->read_end
)
2093 return *(pt
->read_pos
);
2095 return SCM_PORT_DESCRIPTOR (port
)->fill_input (port
);
2099 scm_fill_input (SCM port
)
2101 scm_i_pthread_mutex_t
*lock
;
2104 scm_c_lock_port (port
, &lock
);
2105 ret
= scm_fill_input_unlocked (port
);
2107 scm_i_pthread_mutex_unlock (lock
);
2113 /* Move up to READ_LEN bytes from PORT's putback and/or read buffers
2114 into memory starting at DEST. Return the number of bytes moved.
2115 PORT's line/column numbers are left unchanged. */
2117 scm_take_from_input_buffers (SCM port
, char *dest
, size_t read_len
)
2119 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2120 size_t bytes_read
= 0;
2121 size_t from_buf
= min (pt
->read_end
- pt
->read_pos
, read_len
);
2125 memcpy (dest
, pt
->read_pos
, from_buf
);
2126 pt
->read_pos
+= from_buf
;
2127 bytes_read
+= from_buf
;
2128 read_len
-= from_buf
;
2132 /* if putback was active, try the real input buffer too. */
2133 if (pt
->read_buf
== pt
->putback_buf
)
2135 from_buf
= min (pt
->saved_read_end
- pt
->saved_read_pos
, read_len
);
2138 memcpy (dest
, pt
->saved_read_pos
, from_buf
);
2139 pt
->saved_read_pos
+= from_buf
;
2140 bytes_read
+= from_buf
;
2147 /* Clear a port's read buffers, returning the contents. */
2148 SCM_DEFINE (scm_drain_input
, "drain-input", 1, 0, 0,
2150 "This procedure clears a port's input buffers, similar\n"
2151 "to the way that force-output clears the output buffer. The\n"
2152 "contents of the buffers are returned as a single string, e.g.,\n"
2155 "(define p (open-input-file ...))\n"
2156 "(drain-input p) => empty string, nothing buffered yet.\n"
2157 "(unread-char (read-char p) p)\n"
2158 "(drain-input p) => initial chars from p, up to the buffer size.\n"
2160 "Draining the buffers may be useful for cleanly finishing\n"
2161 "buffered I/O so that the file descriptor can be used directly\n"
2162 "for further input.")
2163 #define FUNC_NAME s_scm_drain_input
2170 SCM_VALIDATE_OPINPORT (1, port
);
2171 pt
= SCM_PTAB_ENTRY (port
);
2173 count
= pt
->read_end
- pt
->read_pos
;
2174 if (pt
->read_buf
== pt
->putback_buf
)
2175 count
+= pt
->saved_read_end
- pt
->saved_read_pos
;
2179 result
= scm_i_make_string (count
, &data
, 0);
2180 scm_take_from_input_buffers (port
, data
, count
);
2183 result
= scm_nullstr
;
2190 scm_end_input_unlocked (SCM port
)
2193 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2195 if (pt
->read_buf
== pt
->putback_buf
)
2197 offset
= pt
->read_end
- pt
->read_pos
;
2198 pt
->read_buf
= pt
->saved_read_buf
;
2199 pt
->read_pos
= pt
->saved_read_pos
;
2200 pt
->read_end
= pt
->saved_read_end
;
2201 pt
->read_buf_size
= pt
->saved_read_buf_size
;
2206 SCM_PORT_DESCRIPTOR (port
)->end_input (port
, offset
);
2210 scm_end_input (SCM port
)
2212 scm_i_pthread_mutex_t
*lock
;
2213 scm_c_lock_port (port
, &lock
);
2214 scm_end_input_unlocked (port
);
2216 scm_i_pthread_mutex_unlock (lock
);
2220 SCM_DEFINE (scm_force_output
, "force-output", 0, 1, 0,
2222 "Flush the specified output port, or the current output port if @var{port}\n"
2223 "is omitted. The current output buffer contents are passed to the\n"
2224 "underlying port implementation (e.g., in the case of fports, the\n"
2225 "data will be written to the file and the output buffer will be cleared.)\n"
2226 "It has no effect on an unbuffered port.\n\n"
2227 "The return value is unspecified.")
2228 #define FUNC_NAME s_scm_force_output
2230 if (SCM_UNBNDP (port
))
2231 port
= scm_current_output_port ();
2234 port
= SCM_COERCE_OUTPORT (port
);
2235 SCM_VALIDATE_OPOUTPORT (1, port
);
2237 scm_flush_unlocked (port
);
2238 return SCM_UNSPECIFIED
;
2243 scm_flush_unlocked (SCM port
)
2245 SCM_PORT_DESCRIPTOR (port
)->flush (port
);
2249 scm_flush (SCM port
)
2251 scm_i_pthread_mutex_t
*lock
;
2252 scm_c_lock_port (port
, &lock
);
2253 scm_flush_unlocked (port
);
2255 scm_i_pthread_mutex_unlock (lock
);
2265 scm_putc (char c
, SCM port
)
2267 scm_i_pthread_mutex_t
*lock
;
2268 scm_c_lock_port (port
, &lock
);
2269 scm_putc_unlocked (c
, port
);
2271 scm_i_pthread_mutex_unlock (lock
);
2276 scm_puts (const char *s
, SCM port
)
2278 scm_i_pthread_mutex_t
*lock
;
2279 scm_c_lock_port (port
, &lock
);
2280 scm_puts_unlocked (s
, port
);
2282 scm_i_pthread_mutex_unlock (lock
);
2288 * Used by an application to write arbitrary number of bytes to an SCM
2289 * port. Similar semantics as libc write. However, unlike libc
2290 * write, scm_c_write writes the requested number of bytes and has no
2293 * Warning: Doesn't update port line and column counts!
2296 scm_c_write_unlocked (SCM port
, const void *ptr
, size_t size
)
2297 #define FUNC_NAME "scm_c_write"
2300 scm_t_ptob_descriptor
*ptob
;
2302 SCM_VALIDATE_OPOUTPORT (1, port
);
2304 pt
= SCM_PTAB_ENTRY (port
);
2305 ptob
= SCM_PORT_DESCRIPTOR (port
);
2307 if (pt
->rw_active
== SCM_PORT_READ
)
2308 scm_end_input_unlocked (port
);
2310 ptob
->write (port
, ptr
, size
);
2313 pt
->rw_active
= SCM_PORT_WRITE
;
2318 scm_c_write (SCM port
, const void *ptr
, size_t size
)
2320 scm_i_pthread_mutex_t
*lock
;
2321 scm_c_lock_port (port
, &lock
);
2322 scm_c_write_unlocked (port
, ptr
, size
);
2324 scm_i_pthread_mutex_unlock (lock
);
2330 * This function differs from scm_c_write; it updates port line and
2333 scm_lfwrite_unlocked (const char *ptr
, size_t size
, SCM port
)
2335 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2336 scm_t_ptob_descriptor
*ptob
= SCM_PORT_DESCRIPTOR (port
);
2338 if (pt
->rw_active
== SCM_PORT_READ
)
2339 scm_end_input_unlocked (port
);
2341 ptob
->write (port
, ptr
, size
);
2343 for (; size
; ptr
++, size
--)
2344 update_port_lf ((scm_t_wchar
) (unsigned char) *ptr
, port
);
2347 pt
->rw_active
= SCM_PORT_WRITE
;
2351 scm_lfwrite (const char *ptr
, size_t size
, SCM port
)
2353 scm_i_pthread_mutex_t
*lock
;
2354 scm_c_lock_port (port
, &lock
);
2355 scm_lfwrite_unlocked (ptr
, size
, port
);
2357 scm_i_pthread_mutex_unlock (lock
);
2361 /* Write STR to PORT from START inclusive to END exclusive. */
2363 scm_lfwrite_substr (SCM str
, size_t start
, size_t end
, SCM port
)
2365 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2367 if (pt
->rw_active
== SCM_PORT_READ
)
2368 scm_end_input_unlocked (port
);
2370 if (end
== (size_t) -1)
2371 end
= scm_i_string_length (str
);
2373 scm_display (scm_c_substring (str
, start
, end
), port
);
2376 pt
->rw_active
= SCM_PORT_WRITE
;
2382 /* Querying and setting positions, and character availability. */
2384 SCM_DEFINE (scm_char_ready_p
, "char-ready?", 0, 1, 0,
2386 "Return @code{#t} if a character is ready on input @var{port}\n"
2387 "and return @code{#f} otherwise. If @code{char-ready?} returns\n"
2388 "@code{#t} then the next @code{read-char} operation on\n"
2389 "@var{port} is guaranteed not to hang. If @var{port} is a file\n"
2390 "port at end of file then @code{char-ready?} returns @code{#t}.\n"
2392 "@code{char-ready?} exists to make it possible for a\n"
2393 "program to accept characters from interactive ports without\n"
2394 "getting stuck waiting for input. Any input editors associated\n"
2395 "with such ports must make sure that characters whose existence\n"
2396 "has been asserted by @code{char-ready?} cannot be rubbed out.\n"
2397 "If @code{char-ready?} were to return @code{#f} at end of file,\n"
2398 "a port at end of file would be indistinguishable from an\n"
2399 "interactive port that has no ready characters.")
2400 #define FUNC_NAME s_scm_char_ready_p
2404 if (SCM_UNBNDP (port
))
2405 port
= scm_current_input_port ();
2406 /* It's possible to close the current input port, so validate even in
2408 SCM_VALIDATE_OPINPORT (1, port
);
2410 pt
= SCM_PTAB_ENTRY (port
);
2412 /* if the current read buffer is filled, or the
2413 last pushed-back char has been read and the saved buffer is
2414 filled, result is true. */
2415 if (pt
->read_pos
< pt
->read_end
2416 || (pt
->read_buf
== pt
->putback_buf
2417 && pt
->saved_read_pos
< pt
->saved_read_end
))
2421 scm_t_ptob_descriptor
*ptob
= SCM_PORT_DESCRIPTOR (port
);
2423 if (ptob
->input_waiting
)
2424 return scm_from_bool(ptob
->input_waiting (port
));
2431 SCM_DEFINE (scm_seek
, "seek", 3, 0, 0,
2432 (SCM fd_port
, SCM offset
, SCM whence
),
2433 "Sets the current position of @var{fd_port} to the integer\n"
2434 "@var{offset}, which is interpreted according to the value of\n"
2437 "One of the following variables should be supplied for\n"
2439 "@defvar SEEK_SET\n"
2440 "Seek from the beginning of the file.\n"
2442 "@defvar SEEK_CUR\n"
2443 "Seek from the current position.\n"
2445 "@defvar SEEK_END\n"
2446 "Seek from the end of the file.\n"
2448 "If @var{fd_port} is a file descriptor, the underlying system\n"
2449 "call is @code{lseek}. @var{port} may be a string port.\n"
2451 "The value returned is the new position in the file. This means\n"
2452 "that the current position of a port can be obtained using:\n"
2454 "(seek port 0 SEEK_CUR)\n"
2456 #define FUNC_NAME s_scm_seek
2460 fd_port
= SCM_COERCE_OUTPORT (fd_port
);
2462 how
= scm_to_int (whence
);
2463 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
2464 SCM_OUT_OF_RANGE (3, whence
);
2466 if (SCM_OPPORTP (fd_port
))
2468 scm_t_ptob_descriptor
*ptob
= SCM_PORT_DESCRIPTOR (fd_port
);
2469 off_t_or_off64_t off
= scm_to_off_t_or_off64_t (offset
);
2470 off_t_or_off64_t rv
;
2473 SCM_MISC_ERROR ("port is not seekable",
2474 scm_cons (fd_port
, SCM_EOL
));
2476 rv
= ptob
->seek (fd_port
, off
, how
);
2477 return scm_from_off_t_or_off64_t (rv
);
2479 else /* file descriptor?. */
2481 off_t_or_off64_t off
= scm_to_off_t_or_off64_t (offset
);
2482 off_t_or_off64_t rv
;
2483 rv
= lseek_or_lseek64 (scm_to_int (fd_port
), off
, how
);
2486 return scm_from_off_t_or_off64_t (rv
);
2495 /* Mingw has ftruncate(), perhaps implemented above using chsize, but
2496 doesn't have the filename version truncate(), hence this code. */
2497 #if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
2499 truncate (const char *file
, off_t length
)
2503 fdes
= open (file
, O_BINARY
| O_WRONLY
);
2507 ret
= ftruncate (fdes
, length
);
2510 int save_errno
= errno
;
2516 return close (fdes
);
2518 #endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
2520 SCM_DEFINE (scm_truncate_file
, "truncate-file", 1, 1, 0,
2521 (SCM object
, SCM length
),
2522 "Truncate file @var{object} to @var{length} bytes. @var{object}\n"
2523 "can be a filename string, a port object, or an integer file\n"
2525 "The return value is unspecified.\n"
2527 "For a port or file descriptor @var{length} can be omitted, in\n"
2528 "which case the file is truncated at the current position (per\n"
2529 "@code{ftell} above).\n"
2531 "On most systems a file can be extended by giving a length\n"
2532 "greater than the current size, but this is not mandatory in the\n"
2534 #define FUNC_NAME s_scm_truncate_file
2538 /* "object" can be a port, fdes or filename.
2540 Negative "length" makes no sense, but it's left to truncate() or
2541 ftruncate() to give back an error for that (normally EINVAL).
2544 if (SCM_UNBNDP (length
))
2546 /* must supply length if object is a filename. */
2547 if (scm_is_string (object
))
2548 SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL
);
2550 length
= scm_seek (object
, SCM_INUM0
, scm_from_int (SEEK_CUR
));
2553 object
= SCM_COERCE_OUTPORT (object
);
2554 if (scm_is_integer (object
))
2556 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
2557 SCM_SYSCALL (rv
= ftruncate_or_ftruncate64 (scm_to_int (object
),
2560 else if (SCM_OPOUTPORTP (object
))
2562 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
2563 scm_t_port
*pt
= SCM_PTAB_ENTRY (object
);
2564 scm_t_ptob_descriptor
*ptob
= SCM_PORT_DESCRIPTOR (object
);
2566 if (!ptob
->truncate
)
2567 SCM_MISC_ERROR ("port is not truncatable", SCM_EOL
);
2568 if (pt
->rw_active
== SCM_PORT_READ
)
2569 scm_end_input_unlocked (object
);
2570 else if (pt
->rw_active
== SCM_PORT_WRITE
)
2571 ptob
->flush (object
);
2573 ptob
->truncate (object
, c_length
);
2578 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
2579 char *str
= scm_to_locale_string (object
);
2581 SCM_SYSCALL (rv
= truncate_or_truncate64 (str
, c_length
));
2588 return SCM_UNSPECIFIED
;
2592 SCM_DEFINE (scm_port_line
, "port-line", 1, 0, 0,
2594 "Return the current line number for @var{port}.\n"
2596 "The first line of a file is 0. But you might want to add 1\n"
2597 "when printing line numbers, since starting from 1 is\n"
2598 "traditional in error messages, and likely to be more natural to\n"
2600 #define FUNC_NAME s_scm_port_line
2602 port
= SCM_COERCE_OUTPORT (port
);
2603 SCM_VALIDATE_OPENPORT (1, port
);
2604 return scm_from_long (SCM_LINUM (port
));
2608 SCM_DEFINE (scm_set_port_line_x
, "set-port-line!", 2, 0, 0,
2609 (SCM port
, SCM line
),
2610 "Set the current line number for @var{port} to @var{line}. The\n"
2611 "first line of a file is 0.")
2612 #define FUNC_NAME s_scm_set_port_line_x
2614 port
= SCM_COERCE_OUTPORT (port
);
2615 SCM_VALIDATE_OPENPORT (1, port
);
2616 SCM_PTAB_ENTRY (port
)->line_number
= scm_to_long (line
);
2617 return SCM_UNSPECIFIED
;
2621 SCM_DEFINE (scm_port_column
, "port-column", 1, 0, 0,
2623 "Return the current column number of @var{port}.\n"
2624 "If the number is\n"
2625 "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
2626 "- i.e. the first character of the first line is line 0, column 0.\n"
2627 "(However, when you display a file position, for example in an error\n"
2628 "message, we recommend you add 1 to get 1-origin integers. This is\n"
2629 "because lines and column numbers traditionally start with 1, and that is\n"
2630 "what non-programmers will find most natural.)")
2631 #define FUNC_NAME s_scm_port_column
2633 port
= SCM_COERCE_OUTPORT (port
);
2634 SCM_VALIDATE_OPENPORT (1, port
);
2635 return scm_from_int (SCM_COL (port
));
2639 SCM_DEFINE (scm_set_port_column_x
, "set-port-column!", 2, 0, 0,
2640 (SCM port
, SCM column
),
2641 "Set the current column of @var{port}. Before reading the first\n"
2642 "character on a line the column should be 0.")
2643 #define FUNC_NAME s_scm_set_port_column_x
2645 port
= SCM_COERCE_OUTPORT (port
);
2646 SCM_VALIDATE_OPENPORT (1, port
);
2647 SCM_PTAB_ENTRY (port
)->column_number
= scm_to_int (column
);
2648 return SCM_UNSPECIFIED
;
2652 SCM_DEFINE (scm_port_filename
, "port-filename", 1, 0, 0,
2654 "Return the filename associated with @var{port}, or @code{#f}\n"
2655 "if no filename is associated with the port.")
2656 #define FUNC_NAME s_scm_port_filename
2658 port
= SCM_COERCE_OUTPORT (port
);
2659 SCM_VALIDATE_OPENPORT (1, port
);
2660 return SCM_FILENAME (port
);
2664 SCM_DEFINE (scm_set_port_filename_x
, "set-port-filename!", 2, 0, 0,
2665 (SCM port
, SCM filename
),
2666 "Change the filename associated with @var{port}, using the current input\n"
2667 "port if none is specified. Note that this does not change the port's\n"
2668 "source of data, but only the value that is returned by\n"
2669 "@code{port-filename} and reported in diagnostic output.")
2670 #define FUNC_NAME s_scm_set_port_filename_x
2672 port
= SCM_COERCE_OUTPORT (port
);
2673 SCM_VALIDATE_OPENPORT (1, port
);
2674 /* We allow the user to set the filename to whatever he likes. */
2675 SCM_SET_FILENAME (port
, filename
);
2676 return SCM_UNSPECIFIED
;
2683 /* Implementation helpers for port printing functions. */
2686 scm_print_port_mode (SCM exp
, SCM port
)
2688 scm_puts_unlocked (SCM_CLOSEDP (exp
)
2690 : (SCM_RDNG
& SCM_CELL_WORD_0 (exp
)
2691 ? (SCM_WRTNG
& SCM_CELL_WORD_0 (exp
)
2694 : (SCM_WRTNG
& SCM_CELL_WORD_0 (exp
)
2701 scm_port_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2703 char *type
= SCM_PTOBNAME (SCM_PTOBNUM (exp
));
2706 scm_puts_unlocked ("#<", port
);
2707 scm_print_port_mode (exp
, port
);
2708 scm_puts_unlocked (type
, port
);
2709 scm_putc_unlocked (' ', port
);
2710 scm_uintprint (SCM_CELL_WORD_1 (exp
), 16, port
);
2711 scm_putc_unlocked ('>', port
);
2718 /* Iterating over all ports. */
2720 struct for_each_data
2722 void (*proc
) (void *data
, SCM p
);
2727 for_each_trampoline (void *data
, SCM port
, SCM result
)
2729 struct for_each_data
*d
= data
;
2731 d
->proc (d
->data
, port
);
2737 scm_c_port_for_each (void (*proc
)(void *data
, SCM p
), void *data
)
2739 struct for_each_data d
;
2744 scm_c_weak_set_fold (for_each_trampoline
, &d
, SCM_EOL
,
2745 scm_i_port_weak_set
);
2749 scm_for_each_trampoline (void *data
, SCM port
)
2751 scm_call_1 (SCM_PACK_POINTER (data
), port
);
2754 SCM_DEFINE (scm_port_for_each
, "port-for-each", 1, 0, 0,
2756 "Apply @var{proc} to each port in the Guile port table\n"
2757 "in turn. The return value is unspecified. More specifically,\n"
2758 "@var{proc} is applied exactly once to every port that exists\n"
2759 "in the system at the time @code{port-for-each} is invoked.\n"
2760 "Changes to the port table while @code{port-for-each} is running\n"
2761 "have no effect as far as @code{port-for-each} is concerned.")
2762 #define FUNC_NAME s_scm_port_for_each
2764 SCM_VALIDATE_PROC (1, proc
);
2766 scm_c_port_for_each (scm_for_each_trampoline
, SCM_UNPACK_POINTER (proc
));
2768 return SCM_UNSPECIFIED
;
2773 flush_output_port (void *closure
, SCM port
)
2775 if (SCM_OPOUTPORTP (port
))
2776 scm_flush_unlocked (port
);
2779 SCM_DEFINE (scm_flush_all_ports
, "flush-all-ports", 0, 0, 0,
2781 "Equivalent to calling @code{force-output} on\n"
2782 "all open output ports. The return value is unspecified.")
2783 #define FUNC_NAME s_scm_flush_all_ports
2785 scm_c_port_for_each (&flush_output_port
, NULL
);
2786 return SCM_UNSPECIFIED
;
2795 scm_t_bits scm_tc16_void_port
= 0;
2797 static int fill_input_void_port (SCM port SCM_UNUSED
)
2803 write_void_port (SCM port SCM_UNUSED
,
2804 const void *data SCM_UNUSED
,
2805 size_t size SCM_UNUSED
)
2810 scm_i_void_port (long mode_bits
)
2814 ret
= scm_c_make_port (scm_tc16_void_port
, mode_bits
, 0);
2816 scm_port_non_buffer (SCM_PTAB_ENTRY (ret
));
2822 scm_void_port (char *mode_str
)
2824 return scm_i_void_port (scm_mode_bits (mode_str
));
2827 SCM_DEFINE (scm_sys_make_void_port
, "%make-void-port", 1, 0, 0,
2829 "Create and return a new void port. A void port acts like\n"
2830 "@file{/dev/null}. The @var{mode} argument\n"
2831 "specifies the input/output modes for this port: see the\n"
2832 "documentation for @code{open-file} in @ref{File Ports}.")
2833 #define FUNC_NAME s_scm_sys_make_void_port
2835 return scm_i_void_port (scm_i_mode_bits (mode
));
2842 /* Initialization. */
2847 /* lseek() symbols. */
2848 scm_c_define ("SEEK_SET", scm_from_int (SEEK_SET
));
2849 scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR
));
2850 scm_c_define ("SEEK_END", scm_from_int (SEEK_END
));
2852 scm_tc16_void_port
= scm_make_port_type ("void", fill_input_void_port
,
2855 cur_inport_fluid
= scm_make_fluid ();
2856 cur_outport_fluid
= scm_make_fluid ();
2857 cur_errport_fluid
= scm_make_fluid ();
2858 cur_loadport_fluid
= scm_make_fluid ();
2860 scm_i_port_weak_set
= scm_c_make_weak_set (31);
2862 #include "libguile/ports.x"
2864 /* Use Latin-1 as the default port encoding. */
2865 SCM_VARIABLE_SET (default_port_encoding_var
,
2866 scm_make_fluid_with_default (SCM_BOOL_F
));
2867 scm_port_encoding_init
= 1;
2869 SCM_VARIABLE_SET (default_conversion_strategy_var
,
2870 scm_make_fluid_with_default (sym_substitute
));
2871 scm_conversion_strategy_init
= 1;
2873 /* These bindings are used when boot-9 turns `current-input-port' et
2874 al into parameters. They are then removed from the guile module. */
2875 scm_c_define ("%current-input-port-fluid", cur_inport_fluid
);
2876 scm_c_define ("%current-output-port-fluid", cur_outport_fluid
);
2877 scm_c_define ("%current-error-port-fluid", cur_errport_fluid
);