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_c_port_type_ref (SCM_TC2PTOBNUM (tc
))->flush
= flush
;
257 scm_set_port_end_input (scm_t_bits tc
, void (*end_input
) (SCM port
, int offset
))
259 scm_c_port_type_ref (SCM_TC2PTOBNUM (tc
))->end_input
= end_input
;
263 scm_set_port_seek (scm_t_bits tc
, scm_t_off (*seek
) (SCM
, scm_t_off
, int))
265 scm_c_port_type_ref (SCM_TC2PTOBNUM (tc
))->seek
= seek
;
269 scm_set_port_truncate (scm_t_bits tc
, void (*truncate
) (SCM
, scm_t_off
))
271 scm_c_port_type_ref (SCM_TC2PTOBNUM (tc
))->truncate
= truncate
;
275 scm_set_port_input_waiting (scm_t_bits tc
, int (*input_waiting
) (SCM
))
277 scm_c_port_type_ref (SCM_TC2PTOBNUM (tc
))->input_waiting
= input_waiting
;
282 /* Standard ports --- current input, output, error, and more(!). */
284 static SCM cur_inport_fluid
= SCM_BOOL_F
;
285 static SCM cur_outport_fluid
= SCM_BOOL_F
;
286 static SCM cur_errport_fluid
= SCM_BOOL_F
;
287 static SCM cur_loadport_fluid
= SCM_BOOL_F
;
289 SCM_DEFINE (scm_current_input_port
, "current-input-port", 0, 0, 0,
291 "Return the current input port. This is the default port used\n"
292 "by many input procedures. Initially, @code{current-input-port}\n"
293 "returns the @dfn{standard input} in Unix and C terminology.")
294 #define FUNC_NAME s_scm_current_input_port
296 if (scm_is_true (cur_inport_fluid
))
297 return scm_fluid_ref (cur_inport_fluid
);
303 SCM_DEFINE (scm_current_output_port
, "current-output-port", 0, 0, 0,
305 "Return the current output port. This is the default port used\n"
306 "by many output procedures. Initially,\n"
307 "@code{current-output-port} returns the @dfn{standard output} in\n"
308 "Unix and C terminology.")
309 #define FUNC_NAME s_scm_current_output_port
311 if (scm_is_true (cur_outport_fluid
))
312 return scm_fluid_ref (cur_outport_fluid
);
318 SCM_DEFINE (scm_current_error_port
, "current-error-port", 0, 0, 0,
320 "Return the port to which errors and warnings should be sent (the\n"
321 "@dfn{standard error} in Unix and C terminology).")
322 #define FUNC_NAME s_scm_current_error_port
324 if (scm_is_true (cur_errport_fluid
))
325 return scm_fluid_ref (cur_errport_fluid
);
332 scm_current_warning_port (void)
334 static SCM cwp_var
= SCM_BOOL_F
;
336 if (scm_is_false (cwp_var
))
337 cwp_var
= scm_c_private_lookup ("guile", "current-warning-port");
339 return scm_call_0 (scm_variable_ref (cwp_var
));
342 SCM_DEFINE (scm_current_load_port
, "current-load-port", 0, 0, 0,
344 "Return the current-load-port.\n"
345 "The load port is used internally by @code{primitive-load}.")
346 #define FUNC_NAME s_scm_current_load_port
348 return scm_fluid_ref (cur_loadport_fluid
);
352 SCM_DEFINE (scm_set_current_input_port
, "set-current-input-port", 1, 0, 0,
354 "@deffnx {Scheme Procedure} set-current-output-port port\n"
355 "@deffnx {Scheme Procedure} set-current-error-port port\n"
356 "Change the ports returned by @code{current-input-port},\n"
357 "@code{current-output-port} and @code{current-error-port}, respectively,\n"
358 "so that they use the supplied @var{port} for input or output.")
359 #define FUNC_NAME s_scm_set_current_input_port
361 SCM oinp
= scm_fluid_ref (cur_inport_fluid
);
362 SCM_VALIDATE_OPINPORT (1, port
);
363 scm_fluid_set_x (cur_inport_fluid
, port
);
369 SCM_DEFINE (scm_set_current_output_port
, "set-current-output-port", 1, 0, 0,
371 "Set the current default output port to @var{port}.")
372 #define FUNC_NAME s_scm_set_current_output_port
374 SCM ooutp
= scm_fluid_ref (cur_outport_fluid
);
375 port
= SCM_COERCE_OUTPORT (port
);
376 SCM_VALIDATE_OPOUTPORT (1, port
);
377 scm_fluid_set_x (cur_outport_fluid
, port
);
383 SCM_DEFINE (scm_set_current_error_port
, "set-current-error-port", 1, 0, 0,
385 "Set the current default error port to @var{port}.")
386 #define FUNC_NAME s_scm_set_current_error_port
388 SCM oerrp
= scm_fluid_ref (cur_errport_fluid
);
389 port
= SCM_COERCE_OUTPORT (port
);
390 SCM_VALIDATE_OPOUTPORT (1, port
);
391 scm_fluid_set_x (cur_errport_fluid
, port
);
398 scm_set_current_warning_port (SCM port
)
400 static SCM cwp_var
= SCM_BOOL_F
;
402 if (scm_is_false (cwp_var
))
403 cwp_var
= scm_c_private_lookup ("guile", "current-warning-port");
405 return scm_call_1 (scm_variable_ref (cwp_var
), port
);
410 scm_dynwind_current_input_port (SCM port
)
411 #define FUNC_NAME NULL
413 SCM_VALIDATE_OPINPORT (1, port
);
414 scm_dynwind_fluid (cur_inport_fluid
, port
);
419 scm_dynwind_current_output_port (SCM port
)
420 #define FUNC_NAME NULL
422 port
= SCM_COERCE_OUTPORT (port
);
423 SCM_VALIDATE_OPOUTPORT (1, port
);
424 scm_dynwind_fluid (cur_outport_fluid
, port
);
429 scm_dynwind_current_error_port (SCM port
)
430 #define FUNC_NAME NULL
432 port
= SCM_COERCE_OUTPORT (port
);
433 SCM_VALIDATE_OPOUTPORT (1, port
);
434 scm_dynwind_fluid (cur_errport_fluid
, port
);
439 scm_i_dynwind_current_load_port (SCM port
)
441 scm_dynwind_fluid (cur_loadport_fluid
, port
);
447 /* Retrieving a port's mode. */
449 /* Return the flags that characterize a port based on the mode
450 * string used to open a file for that port.
452 * See PORT FLAGS in scm.h
456 scm_i_mode_bits_n (SCM modes
)
459 | (scm_i_string_contains_char (modes
, 'r')
460 || scm_i_string_contains_char (modes
, '+') ? SCM_RDNG
: 0)
461 | (scm_i_string_contains_char (modes
, 'w')
462 || scm_i_string_contains_char (modes
, 'a')
463 || scm_i_string_contains_char (modes
, '+') ? SCM_WRTNG
: 0)
464 | (scm_i_string_contains_char (modes
, '0') ? SCM_BUF0
: 0)
465 | (scm_i_string_contains_char (modes
, 'l') ? SCM_BUFLINE
: 0));
469 scm_mode_bits (char *modes
)
471 return scm_i_mode_bits (scm_from_locale_string (modes
));
475 scm_i_mode_bits (SCM modes
)
479 if (!scm_is_string (modes
))
480 scm_wrong_type_arg_msg (NULL
, 0, modes
, "string");
482 bits
= scm_i_mode_bits_n (modes
);
483 scm_remember_upto_here_1 (modes
);
487 /* Return the mode flags from an open port.
488 * Some modes such as "append" are only used when opening
489 * a file and are not returned here. */
491 SCM_DEFINE (scm_port_mode
, "port-mode", 1, 0, 0,
493 "Return the port modes associated with the open port @var{port}.\n"
494 "These will not necessarily be identical to the modes used when\n"
495 "the port was opened, since modes such as \"append\" which are\n"
496 "used only during port creation are not retained.")
497 #define FUNC_NAME s_scm_port_mode
502 port
= SCM_COERCE_OUTPORT (port
);
503 SCM_VALIDATE_OPPORT (1, port
);
504 if (SCM_CELL_WORD_0 (port
) & SCM_RDNG
) {
505 if (SCM_CELL_WORD_0 (port
) & SCM_WRTNG
)
506 strcpy (modes
, "r+");
510 else if (SCM_CELL_WORD_0 (port
) & SCM_WRTNG
)
512 if (SCM_CELL_WORD_0 (port
) & SCM_BUF0
)
515 return scm_from_latin1_string (modes
);
522 /* The port table --- a weak set of all ports.
524 We need a global registry of ports to flush them all at exit, and to
525 get all the ports matching a file descriptor. */
526 SCM scm_i_port_weak_set
;
531 /* Port finalization. */
533 static void finalize_port (GC_PTR
, GC_PTR
);
535 /* Register a finalizer for PORT. */
536 static SCM_C_INLINE_KEYWORD
void
537 register_finalizer_for_port (SCM port
)
539 GC_finalization_proc prev_finalizer
;
540 GC_PTR prev_finalization_data
;
542 /* Register a finalizer for PORT so that its iconv CDs get freed and
543 optionally its type's `free' function gets called. */
544 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (port
), finalize_port
, 0,
546 &prev_finalization_data
);
549 /* Finalize the object (a port) pointed to by PTR. */
551 finalize_port (GC_PTR ptr
, GC_PTR data
)
553 SCM port
= SCM_PACK_POINTER (ptr
);
555 if (!SCM_PORTP (port
))
558 if (SCM_OPENP (port
))
560 if (SCM_REVEALED (port
) > 0)
561 /* Keep "revealed" ports alive and re-register a finalizer. */
562 register_finalizer_for_port (port
);
565 scm_t_ptob_descriptor
*ptob
= SCM_PORT_DESCRIPTOR (port
);
568 /* Yes, I really do mean `free' rather than `close'. `close'
569 is for explicit `close-port' by user. */
572 SCM_SETSTREAM (port
, 0);
573 SCM_CLR_PORT_OPEN_FLAG (port
);
575 scm_gc_ports_collected
++;
584 scm_c_make_port_with_encoding (scm_t_bits tag
, unsigned long mode_bits
,
585 const char *encoding
,
586 scm_t_string_failed_conversion_handler handler
,
591 scm_t_ptob_descriptor
*ptob
;
593 entry
= (scm_t_port
*) scm_gc_calloc (sizeof (scm_t_port
), "port");
594 ptob
= scm_c_port_type_ref (SCM_TC2PTOBNUM (tag
));
596 ret
= scm_words (tag
| mode_bits
, 3);
597 SCM_SET_CELL_WORD_1 (ret
, (scm_t_bits
) entry
);
598 SCM_SET_CELL_WORD_2 (ret
, (scm_t_bits
) ptob
);
600 entry
->lock
= scm_gc_malloc_pointerless (sizeof (*entry
->lock
), "port lock");
601 scm_i_pthread_mutex_init (entry
->lock
, scm_i_pthread_mutexattr_recursive
);
603 entry
->file_name
= SCM_BOOL_F
;
604 entry
->rw_active
= SCM_PORT_NEITHER
;
606 entry
->stream
= stream
;
607 entry
->encoding
= encoding
? scm_gc_strdup (encoding
, "port") : NULL
;
608 if (encoding
&& strcmp (encoding
, "UTF-8") == 0)
609 entry
->encoding_mode
= SCM_PORT_ENCODING_MODE_UTF8
;
611 entry
->encoding_mode
= SCM_PORT_ENCODING_MODE_ICONV
;
612 entry
->ilseq_handler
= handler
;
613 entry
->iconv_descriptors
= NULL
;
615 scm_weak_set_add_x (scm_i_port_weak_set
, ret
);
617 /* For each new port, register a finalizer so that it port type's free
618 function can be invoked eventually. */
619 register_finalizer_for_port (ret
);
625 scm_c_make_port (scm_t_bits tag
, unsigned long mode_bits
, scm_t_bits stream
)
627 return scm_c_make_port_with_encoding (tag
, mode_bits
,
628 scm_i_default_port_encoding (),
629 scm_i_get_conversion_strategy (SCM_BOOL_F
),
634 scm_new_port_table_entry (scm_t_bits tag
)
636 return scm_c_make_port (tag
, 0, 0);
639 /* Remove a port from the table and destroy it. */
641 static void close_iconv_descriptors (scm_t_iconv_descriptors
*id
);
644 scm_i_remove_port (SCM port
)
645 #define FUNC_NAME "scm_remove_port"
649 p
= SCM_PTAB_ENTRY (port
);
650 scm_port_non_buffer (p
);
651 SCM_SETPTAB_ENTRY (port
, 0);
652 scm_weak_set_remove_x (scm_i_port_weak_set
, port
);
654 p
->putback_buf
= NULL
;
655 p
->putback_buf_size
= 0;
657 if (p
->iconv_descriptors
)
659 close_iconv_descriptors (p
->iconv_descriptors
);
660 p
->iconv_descriptors
= NULL
;
670 SCM_DEFINE (scm_port_p
, "port?", 1, 0, 0,
672 "Return a boolean indicating whether @var{x} is a port.\n"
673 "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
675 #define FUNC_NAME s_scm_port_p
677 return scm_from_bool (SCM_PORTP (x
));
681 SCM_DEFINE (scm_input_port_p
, "input-port?", 1, 0, 0,
683 "Return @code{#t} if @var{x} is an input port, otherwise return\n"
684 "@code{#f}. Any object satisfying this predicate also satisfies\n"
686 #define FUNC_NAME s_scm_input_port_p
688 return scm_from_bool (SCM_INPUT_PORT_P (x
));
692 SCM_DEFINE (scm_output_port_p
, "output-port?", 1, 0, 0,
694 "Return @code{#t} if @var{x} is an output port, otherwise return\n"
695 "@code{#f}. Any object satisfying this predicate also satisfies\n"
697 #define FUNC_NAME s_scm_output_port_p
699 x
= SCM_COERCE_OUTPORT (x
);
700 return scm_from_bool (SCM_OUTPUT_PORT_P (x
));
704 SCM_DEFINE (scm_port_closed_p
, "port-closed?", 1, 0, 0,
706 "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
708 #define FUNC_NAME s_scm_port_closed_p
710 SCM_VALIDATE_PORT (1, port
);
711 return scm_from_bool (!SCM_OPPORTP (port
));
715 SCM_DEFINE (scm_eof_object_p
, "eof-object?", 1, 0, 0,
717 "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
719 #define FUNC_NAME s_scm_eof_object_p
721 return scm_from_bool (SCM_EOF_OBJECT_P (x
));
731 * Call the close operation on a port object.
732 * see also scm_close.
734 SCM_DEFINE (scm_close_port
, "close-port", 1, 0, 0,
736 "Close the specified port object. Return @code{#t} if it\n"
737 "successfully closes a port or @code{#f} if it was already\n"
738 "closed. An exception may be raised if an error occurs, for\n"
739 "example when flushing buffered output. See also @ref{Ports and\n"
740 "File Descriptors, close}, for a procedure which can close file\n"
742 #define FUNC_NAME s_scm_close_port
746 port
= SCM_COERCE_OUTPORT (port
);
748 SCM_VALIDATE_PORT (1, port
);
749 if (SCM_CLOSEDP (port
))
751 if (SCM_PORT_DESCRIPTOR (port
)->close
)
752 rv
= SCM_PORT_DESCRIPTOR (port
)->close (port
);
755 scm_i_remove_port (port
);
756 SCM_CLR_PORT_OPEN_FLAG (port
);
757 return scm_from_bool (rv
>= 0);
761 SCM_DEFINE (scm_close_input_port
, "close-input-port", 1, 0, 0,
763 "Close the specified input port object. The routine has no effect if\n"
764 "the file has already been closed. An exception may be raised if an\n"
765 "error occurs. The value returned is unspecified.\n\n"
766 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
767 "which can close file descriptors.")
768 #define FUNC_NAME s_scm_close_input_port
770 SCM_VALIDATE_INPUT_PORT (1, port
);
771 scm_close_port (port
);
772 return SCM_UNSPECIFIED
;
776 SCM_DEFINE (scm_close_output_port
, "close-output-port", 1, 0, 0,
778 "Close the specified output port object. The routine has no effect if\n"
779 "the file has already been closed. An exception may be raised if an\n"
780 "error occurs. The value returned is unspecified.\n\n"
781 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
782 "which can close file descriptors.")
783 #define FUNC_NAME s_scm_close_output_port
785 port
= SCM_COERCE_OUTPORT (port
);
786 SCM_VALIDATE_OUTPUT_PORT (1, port
);
787 scm_close_port (port
);
788 return SCM_UNSPECIFIED
;
795 /* Encoding characters to byte streams, and decoding byte streams to
798 /* A fluid specifying the default encoding for newly created ports. If it is
799 a string, that is the encoding. If it is #f, it is in the "native"
800 (Latin-1) encoding. */
801 SCM_VARIABLE (default_port_encoding_var
, "%default-port-encoding");
803 static int scm_port_encoding_init
= 0;
805 /* Use ENCODING as the default encoding for future ports. */
807 scm_i_set_default_port_encoding (const char *encoding
)
809 if (!scm_port_encoding_init
810 || !scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var
)))
811 scm_misc_error (NULL
, "tried to set port encoding fluid before it is initialized",
815 || !strcmp (encoding
, "ASCII")
816 || !strcmp (encoding
, "ANSI_X3.4-1968")
817 || !strcmp (encoding
, "ISO-8859-1"))
818 scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var
), SCM_BOOL_F
);
820 scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var
),
821 scm_from_locale_string (encoding
));
824 /* Return the name of the default encoding for newly created ports; a
825 return value of NULL means "ISO-8859-1". */
827 scm_i_default_port_encoding (void)
829 if (!scm_port_encoding_init
)
831 else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var
)))
837 encoding
= scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var
));
838 if (!scm_is_string (encoding
))
841 return scm_i_string_chars (encoding
);
846 finalize_iconv_descriptors (GC_PTR ptr
, GC_PTR data
)
848 close_iconv_descriptors (ptr
);
851 static scm_t_iconv_descriptors
*
852 open_iconv_descriptors (const char *encoding
, int reading
, int writing
)
854 scm_t_iconv_descriptors
*id
;
855 iconv_t input_cd
, output_cd
;
857 input_cd
= (iconv_t
) -1;
858 output_cd
= (iconv_t
) -1;
862 /* Open an input iconv conversion descriptor, from ENCODING
863 to UTF-8. We choose UTF-8, not UTF-32, because iconv
864 implementations can typically convert from anything to
865 UTF-8, but not to UTF-32 (see
866 <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00007.html>). */
868 /* Assume opening an iconv descriptor causes about 16 KB of
870 scm_gc_register_allocation (16 * 1024);
872 input_cd
= iconv_open ("UTF-8", encoding
);
873 if (input_cd
== (iconv_t
) -1)
874 goto invalid_encoding
;
879 /* Assume opening an iconv descriptor causes about 16 KB of
881 scm_gc_register_allocation (16 * 1024);
883 output_cd
= iconv_open (encoding
, "UTF-8");
884 if (output_cd
== (iconv_t
) -1)
886 if (input_cd
!= (iconv_t
) -1)
887 iconv_close (input_cd
);
888 goto invalid_encoding
;
892 id
= scm_gc_malloc_pointerless (sizeof (*id
), "iconv descriptors");
893 id
->input_cd
= input_cd
;
894 id
->output_cd
= output_cd
;
897 GC_finalization_proc prev_finalizer
;
898 GC_PTR prev_finalization_data
;
900 /* Register a finalizer to close the descriptors. */
901 GC_REGISTER_FINALIZER_NO_ORDER (id
, finalize_iconv_descriptors
, 0,
902 &prev_finalizer
, &prev_finalization_data
);
910 err
= scm_from_locale_string (encoding
);
911 scm_misc_error ("open_iconv_descriptors",
912 "invalid or unknown character encoding ~s",
918 close_iconv_descriptors (scm_t_iconv_descriptors
*id
)
920 if (id
->input_cd
!= (iconv_t
) -1)
921 iconv_close (id
->input_cd
);
922 if (id
->output_cd
!= (iconv_t
) -1)
923 iconv_close (id
->output_cd
);
924 id
->input_cd
= (void *) -1;
925 id
->output_cd
= (void *) -1;
928 scm_t_iconv_descriptors
*
929 scm_i_port_iconv_descriptors (SCM port
)
933 pt
= SCM_PTAB_ENTRY (port
);
935 assert (pt
->encoding_mode
== SCM_PORT_ENCODING_MODE_ICONV
);
937 if (!pt
->iconv_descriptors
)
940 pt
->encoding
= "ISO-8859-1";
941 pt
->iconv_descriptors
=
942 open_iconv_descriptors (pt
->encoding
,
943 SCM_INPUT_PORT_P (port
),
944 SCM_OUTPUT_PORT_P (port
));
947 return pt
->iconv_descriptors
;
951 scm_i_set_port_encoding_x (SCM port
, const char *encoding
)
954 scm_t_iconv_descriptors
*prev
;
956 /* Set the character encoding for this port. */
957 pt
= SCM_PTAB_ENTRY (port
);
958 prev
= pt
->iconv_descriptors
;
960 if (encoding
== NULL
)
961 encoding
= "ISO-8859-1";
963 if (strcmp (encoding
, "UTF-8") == 0)
965 pt
->encoding
= "UTF-8";
966 pt
->encoding_mode
= SCM_PORT_ENCODING_MODE_UTF8
;
967 pt
->iconv_descriptors
= NULL
;
971 /* Open descriptors before mutating the port. */
972 pt
->iconv_descriptors
=
973 open_iconv_descriptors (encoding
,
974 SCM_INPUT_PORT_P (port
),
975 SCM_OUTPUT_PORT_P (port
));
976 pt
->encoding
= scm_gc_strdup (encoding
, "port");
977 pt
->encoding_mode
= SCM_PORT_ENCODING_MODE_ICONV
;
981 close_iconv_descriptors (prev
);
984 SCM_DEFINE (scm_port_encoding
, "port-encoding", 1, 0, 0,
986 "Returns, as a string, the character encoding that @var{port}\n"
987 "uses to interpret its input and output.\n")
988 #define FUNC_NAME s_scm_port_encoding
993 SCM_VALIDATE_PORT (1, port
);
995 pt
= SCM_PTAB_ENTRY (port
);
998 return scm_from_locale_string (pt
->encoding
);
1004 SCM_DEFINE (scm_set_port_encoding_x
, "set-port-encoding!", 2, 0, 0,
1005 (SCM port
, SCM enc
),
1006 "Sets the character encoding that will be used to interpret all\n"
1007 "port I/O. New ports are created with the encoding\n"
1008 "appropriate for the current locale if @code{setlocale} has \n"
1009 "been called or ISO-8859-1 otherwise\n"
1010 "and this procedure can be used to modify that encoding.\n")
1011 #define FUNC_NAME s_scm_set_port_encoding_x
1015 SCM_VALIDATE_PORT (1, port
);
1016 SCM_VALIDATE_STRING (2, enc
);
1018 enc_str
= scm_to_locale_string (enc
);
1019 scm_i_set_port_encoding_x (port
, enc_str
);
1022 return SCM_UNSPECIFIED
;
1027 /* This determines how conversions handle unconvertible characters. */
1028 SCM_GLOBAL_VARIABLE (scm_conversion_strategy
, "%port-conversion-strategy");
1029 static int scm_conversion_strategy_init
= 0;
1031 scm_t_string_failed_conversion_handler
1032 scm_i_get_conversion_strategy (SCM port
)
1036 if (scm_is_false (port
))
1038 if (!scm_conversion_strategy_init
1039 || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy
)))
1040 return SCM_FAILED_CONVERSION_QUESTION_MARK
;
1043 encoding
= scm_fluid_ref (SCM_VARIABLE_REF (scm_conversion_strategy
));
1044 if (scm_is_false (encoding
))
1045 return SCM_FAILED_CONVERSION_QUESTION_MARK
;
1047 return (scm_t_string_failed_conversion_handler
) scm_to_int (encoding
);
1053 pt
= SCM_PTAB_ENTRY (port
);
1054 return pt
->ilseq_handler
;
1060 scm_i_set_conversion_strategy_x (SCM port
,
1061 scm_t_string_failed_conversion_handler handler
)
1066 strategy
= scm_from_int ((int) handler
);
1068 if (scm_is_false (port
))
1070 /* Set the default encoding for future ports. */
1071 if (!scm_conversion_strategy_init
1072 || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy
)))
1073 scm_misc_error (NULL
, "tried to set conversion strategy fluid before it is initialized",
1075 scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy
), strategy
);
1079 /* Set the character encoding for this port. */
1080 pt
= SCM_PTAB_ENTRY (port
);
1081 pt
->ilseq_handler
= handler
;
1085 SCM_DEFINE (scm_port_conversion_strategy
, "port-conversion-strategy",
1086 1, 0, 0, (SCM port
),
1087 "Returns the behavior of the port when handling a character that\n"
1088 "is not representable in the port's current encoding.\n"
1089 "It returns the symbol @code{error} if unrepresentable characters\n"
1090 "should cause exceptions, @code{substitute} if the port should\n"
1091 "try to replace unrepresentable characters with question marks or\n"
1092 "approximate characters, or @code{escape} if unrepresentable\n"
1093 "characters should be converted to string escapes.\n"
1095 "If @var{port} is @code{#f}, then the current default behavior\n"
1096 "will be returned. New ports will have this default behavior\n"
1097 "when they are created.\n")
1098 #define FUNC_NAME s_scm_port_conversion_strategy
1100 scm_t_string_failed_conversion_handler h
;
1102 SCM_VALIDATE_OPPORT (1, port
);
1104 if (!scm_is_false (port
))
1106 SCM_VALIDATE_OPPORT (1, port
);
1109 h
= scm_i_get_conversion_strategy (port
);
1110 if (h
== SCM_FAILED_CONVERSION_ERROR
)
1111 return scm_from_latin1_symbol ("error");
1112 else if (h
== SCM_FAILED_CONVERSION_QUESTION_MARK
)
1113 return scm_from_latin1_symbol ("substitute");
1114 else if (h
== SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE
)
1115 return scm_from_latin1_symbol ("escape");
1119 /* Never gets here. */
1120 return SCM_UNDEFINED
;
1124 SCM_DEFINE (scm_set_port_conversion_strategy_x
, "set-port-conversion-strategy!",
1126 (SCM port
, SCM sym
),
1127 "Sets the behavior of the interpreter when outputting a character\n"
1128 "that is not representable in the port's current encoding.\n"
1129 "@var{sym} can be either @code{'error}, @code{'substitute}, or\n"
1130 "@code{'escape}. If it is @code{'error}, an error will be thrown\n"
1131 "when an unconvertible character is encountered. If it is\n"
1132 "@code{'substitute}, then unconvertible characters will \n"
1133 "be replaced with approximate characters, or with question marks\n"
1134 "if no approximately correct character is available.\n"
1135 "If it is @code{'escape},\n"
1136 "it will appear as a hex escape when output.\n"
1138 "If @var{port} is an open port, the conversion error behavior\n"
1139 "is set for that port. If it is @code{#f}, it is set as the\n"
1140 "default behavior for any future ports that get created in\n"
1142 #define FUNC_NAME s_scm_set_port_conversion_strategy_x
1148 if (!scm_is_false (port
))
1150 SCM_VALIDATE_OPPORT (1, port
);
1153 err
= scm_from_latin1_symbol ("error");
1154 if (scm_is_true (scm_eqv_p (sym
, err
)))
1156 scm_i_set_conversion_strategy_x (port
, SCM_FAILED_CONVERSION_ERROR
);
1157 return SCM_UNSPECIFIED
;
1160 qm
= scm_from_latin1_symbol ("substitute");
1161 if (scm_is_true (scm_eqv_p (sym
, qm
)))
1163 scm_i_set_conversion_strategy_x (port
,
1164 SCM_FAILED_CONVERSION_QUESTION_MARK
);
1165 return SCM_UNSPECIFIED
;
1168 esc
= scm_from_latin1_symbol ("escape");
1169 if (scm_is_true (scm_eqv_p (sym
, esc
)))
1171 scm_i_set_conversion_strategy_x (port
,
1172 SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE
);
1173 return SCM_UNSPECIFIED
;
1176 SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym
));
1178 return SCM_UNSPECIFIED
;
1185 /* The port lock. */
1188 lock_port (void *mutex
)
1190 scm_i_pthread_mutex_lock (mutex
);
1194 unlock_port (void *mutex
)
1196 scm_i_pthread_mutex_unlock (mutex
);
1200 scm_dynwind_lock_port (SCM port
)
1201 #define FUNC_NAME "dynwind-lock-port"
1203 scm_i_pthread_mutex_t
*lock
;
1204 SCM_VALIDATE_OPPORT (SCM_ARG1
, port
);
1205 scm_c_lock_port (port
, &lock
);
1208 scm_dynwind_unwind_handler (unlock_port
, lock
, SCM_F_WIND_EXPLICITLY
);
1209 scm_dynwind_rewind_handler (lock_port
, lock
, 0);
1217 /* Revealed counts --- an oddity inherited from SCSH. */
1219 /* Find a port in the table and return its revealed count.
1220 Also used by the garbage collector.
1223 scm_revealed_count (SCM port
)
1225 scm_i_pthread_mutex_t
*lock
;
1228 scm_c_lock_port (port
, &lock
);
1229 ret
= SCM_REVEALED (port
);
1231 scm_i_pthread_mutex_unlock (lock
);
1236 SCM_DEFINE (scm_port_revealed
, "port-revealed", 1, 0, 0,
1238 "Return the revealed count for @var{port}.")
1239 #define FUNC_NAME s_scm_port_revealed
1241 port
= SCM_COERCE_OUTPORT (port
);
1242 SCM_VALIDATE_OPENPORT (1, port
);
1243 return scm_from_int (scm_revealed_count (port
));
1247 /* Set the revealed count for a port. */
1248 SCM_DEFINE (scm_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0,
1249 (SCM port
, SCM rcount
),
1250 "Sets the revealed count for a port to a given value.\n"
1251 "The return value is unspecified.")
1252 #define FUNC_NAME s_scm_set_port_revealed_x
1255 scm_i_pthread_mutex_t
*lock
;
1257 port
= SCM_COERCE_OUTPORT (port
);
1258 SCM_VALIDATE_OPENPORT (1, port
);
1259 r
= scm_to_int (rcount
);
1260 scm_c_lock_port (port
, &lock
);
1261 SCM_REVEALED (port
) = r
;
1263 scm_i_pthread_mutex_unlock (lock
);
1264 return SCM_UNSPECIFIED
;
1268 /* Set the revealed count for a port. */
1269 SCM_DEFINE (scm_adjust_port_revealed_x
, "adjust-port-revealed!", 2, 0, 0,
1270 (SCM port
, SCM addend
),
1271 "Add @var{addend} to the revealed count of @var{port}.\n"
1272 "The return value is unspecified.")
1273 #define FUNC_NAME s_scm_adjust_port_revealed_x
1275 scm_i_pthread_mutex_t
*lock
;
1277 port
= SCM_COERCE_OUTPORT (port
);
1278 SCM_VALIDATE_OPENPORT (1, port
);
1279 a
= scm_to_int (addend
);
1280 scm_c_lock_port (port
, &lock
);
1281 SCM_REVEALED (port
) += a
;
1283 scm_i_pthread_mutex_unlock (lock
);
1284 return SCM_UNSPECIFIED
;
1294 scm_get_byte_or_eof (SCM port
)
1296 scm_i_pthread_mutex_t
*lock
;
1299 scm_c_lock_port (port
, &lock
);
1300 ret
= scm_get_byte_or_eof_unlocked (port
);
1302 scm_i_pthread_mutex_unlock (lock
);
1308 scm_peek_byte_or_eof (SCM port
)
1310 scm_i_pthread_mutex_t
*lock
;
1313 scm_c_lock_port (port
, &lock
);
1314 ret
= scm_peek_byte_or_eof_unlocked (port
);
1316 scm_i_pthread_mutex_unlock (lock
);
1323 * Used by an application to read arbitrary number of bytes from an
1324 * SCM port. Same semantics as libc read, except that scm_c_read only
1325 * returns less than SIZE bytes if at end-of-file.
1327 * Warning: Doesn't update port line and column counts! */
1329 /* This structure, and the following swap_buffer function, are used
1330 for temporarily swapping a port's own read buffer, and the buffer
1331 that the caller of scm_c_read provides. */
1332 struct port_and_swap_buffer
1335 unsigned char *buffer
;
1340 swap_buffer (void *data
)
1342 struct port_and_swap_buffer
*psb
= (struct port_and_swap_buffer
*) data
;
1343 unsigned char *old_buf
= psb
->pt
->read_buf
;
1344 size_t old_size
= psb
->pt
->read_buf_size
;
1346 /* Make the port use (buffer, size) from the struct. */
1347 psb
->pt
->read_pos
= psb
->pt
->read_buf
= psb
->pt
->read_end
= psb
->buffer
;
1348 psb
->pt
->read_buf_size
= psb
->size
;
1350 /* Save the port's old (buffer, size) in the struct. */
1351 psb
->buffer
= old_buf
;
1352 psb
->size
= old_size
;
1356 scm_c_read_unlocked (SCM port
, void *buffer
, size_t size
)
1357 #define FUNC_NAME "scm_c_read"
1360 size_t n_read
= 0, n_available
;
1361 struct port_and_swap_buffer psb
;
1363 SCM_VALIDATE_OPINPORT (1, port
);
1365 pt
= SCM_PTAB_ENTRY (port
);
1366 if (pt
->rw_active
== SCM_PORT_WRITE
)
1367 SCM_PORT_DESCRIPTOR (port
)->flush (port
);
1370 pt
->rw_active
= SCM_PORT_READ
;
1372 /* Take bytes first from the port's read buffer. */
1373 if (pt
->read_pos
< pt
->read_end
)
1375 n_available
= min (size
, pt
->read_end
- pt
->read_pos
);
1376 memcpy (buffer
, pt
->read_pos
, n_available
);
1377 buffer
= (char *) buffer
+ n_available
;
1378 pt
->read_pos
+= n_available
;
1379 n_read
+= n_available
;
1380 size
-= n_available
;
1383 /* Avoid the scm_dynwind_* costs if we now have enough data. */
1387 /* Now we will call scm_fill_input repeatedly until we have read the
1388 requested number of bytes. (Note that a single scm_fill_input
1389 call does not guarantee to fill the whole of the port's read
1391 if (pt
->read_buf_size
<= 1 && pt
->encoding
== NULL
)
1393 /* The port that we are reading from is unbuffered - i.e. does
1394 not have its own persistent buffer - but we have a buffer,
1395 provided by our caller, that is the right size for the data
1396 that is wanted. For the following scm_fill_input calls,
1397 therefore, we use the buffer in hand as the port's read
1400 We need to make sure that the port's normal (1 byte) buffer
1401 is reinstated in case one of the scm_fill_input () calls
1402 throws an exception; we use the scm_dynwind_* API to achieve
1405 A consequence of this optimization is that the fill_input
1406 functions can't unget characters. That'll push data to the
1407 pushback buffer instead of this psb buffer. */
1409 unsigned char *pback
= pt
->putback_buf
;
1412 psb
.buffer
= buffer
;
1414 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1415 scm_dynwind_rewind_handler (swap_buffer
, &psb
, SCM_F_WIND_EXPLICITLY
);
1416 scm_dynwind_unwind_handler (swap_buffer
, &psb
, SCM_F_WIND_EXPLICITLY
);
1418 /* Call scm_fill_input until we have all the bytes that we need,
1420 while (pt
->read_buf_size
&& (scm_fill_input_unlocked (port
) != EOF
))
1422 pt
->read_buf_size
-= (pt
->read_end
- pt
->read_pos
);
1423 pt
->read_pos
= pt
->read_buf
= pt
->read_end
;
1426 if (pback
!= pt
->putback_buf
1427 || pt
->read_buf
- (unsigned char *) buffer
< 0)
1428 scm_misc_error (FUNC_NAME
,
1429 "scm_c_read must not call a fill function that pushes "
1430 "back characters onto an unbuffered port", SCM_EOL
);
1432 n_read
+= pt
->read_buf
- (unsigned char *) buffer
;
1434 /* Reinstate the port's normal buffer. */
1439 /* The port has its own buffer. It is important that we use it,
1440 even if it happens to be smaller than our caller's buffer, so
1441 that a custom port implementation's entry points (in
1442 particular, fill_input) can rely on the buffer always being
1443 the same as they first set up. */
1444 while (size
&& (scm_fill_input_unlocked (port
) != EOF
))
1446 n_available
= min (size
, pt
->read_end
- pt
->read_pos
);
1447 memcpy (buffer
, pt
->read_pos
, n_available
);
1448 buffer
= (char *) buffer
+ n_available
;
1449 pt
->read_pos
+= n_available
;
1450 n_read
+= n_available
;
1451 size
-= n_available
;
1460 scm_c_read (SCM port
, void *buffer
, size_t size
)
1462 scm_i_pthread_mutex_t
*lock
;
1465 scm_c_lock_port (port
, &lock
);
1466 ret
= scm_c_read_unlocked (port
, buffer
, size
);
1468 scm_i_pthread_mutex_unlock (lock
);
1474 /* Update the line and column number of PORT after consumption of C. */
1476 update_port_lf (scm_t_wchar c
, SCM port
)
1501 #define SCM_MBCHAR_BUF_SIZE (4)
1503 /* Convert the SIZE-byte UTF-8 sequence in UTF8_BUF to a codepoint.
1504 UTF8_BUF is assumed to contain a valid UTF-8 sequence. */
1506 utf8_to_codepoint (const scm_t_uint8
*utf8_buf
, size_t size
)
1508 scm_t_wchar codepoint
;
1510 if (utf8_buf
[0] <= 0x7f)
1513 codepoint
= utf8_buf
[0];
1515 else if ((utf8_buf
[0] & 0xe0) == 0xc0)
1518 codepoint
= ((scm_t_wchar
) utf8_buf
[0] & 0x1f) << 6UL
1519 | (utf8_buf
[1] & 0x3f);
1521 else if ((utf8_buf
[0] & 0xf0) == 0xe0)
1524 codepoint
= ((scm_t_wchar
) utf8_buf
[0] & 0x0f) << 12UL
1525 | ((scm_t_wchar
) utf8_buf
[1] & 0x3f) << 6UL
1526 | (utf8_buf
[2] & 0x3f);
1531 codepoint
= ((scm_t_wchar
) utf8_buf
[0] & 0x07) << 18UL
1532 | ((scm_t_wchar
) utf8_buf
[1] & 0x3f) << 12UL
1533 | ((scm_t_wchar
) utf8_buf
[2] & 0x3f) << 6UL
1534 | (utf8_buf
[3] & 0x3f);
1540 /* Read a UTF-8 sequence from PORT. On success, return 0 and set
1541 *CODEPOINT to the codepoint that was read, fill BUF with its UTF-8
1542 representation, and set *LEN to the length in bytes. Return
1543 `EILSEQ' on error. */
1545 get_utf8_codepoint (SCM port
, scm_t_wchar
*codepoint
,
1546 scm_t_uint8 buf
[SCM_MBCHAR_BUF_SIZE
], size_t *len
)
1548 #define ASSERT_NOT_EOF(b) \
1549 if (SCM_UNLIKELY ((b) == EOF)) \
1551 #define CONSUME_PEEKED_BYTE() \
1558 pt
= SCM_PTAB_ENTRY (port
);
1560 byte
= scm_get_byte_or_eof_unlocked (port
);
1567 buf
[0] = (scm_t_uint8
) byte
;
1572 *codepoint
= buf
[0];
1573 else if (buf
[0] >= 0xc2 && buf
[0] <= 0xdf)
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
[1] = (scm_t_uint8
) byte
;
1586 *codepoint
= ((scm_t_wchar
) buf
[0] & 0x1f) << 6UL
1589 else if ((buf
[0] & 0xf0) == 0xe0)
1592 byte
= scm_peek_byte_or_eof_unlocked (port
);
1593 ASSERT_NOT_EOF (byte
);
1595 if (SCM_UNLIKELY ((byte
& 0xc0) != 0x80
1596 || (buf
[0] == 0xe0 && byte
< 0xa0)
1597 || (buf
[0] == 0xed && byte
> 0x9f)))
1600 CONSUME_PEEKED_BYTE ();
1601 buf
[1] = (scm_t_uint8
) byte
;
1604 byte
= scm_peek_byte_or_eof_unlocked (port
);
1605 ASSERT_NOT_EOF (byte
);
1607 if (SCM_UNLIKELY ((byte
& 0xc0) != 0x80))
1610 CONSUME_PEEKED_BYTE ();
1611 buf
[2] = (scm_t_uint8
) byte
;
1614 *codepoint
= ((scm_t_wchar
) buf
[0] & 0x0f) << 12UL
1615 | ((scm_t_wchar
) buf
[1] & 0x3f) << 6UL
1618 else if (buf
[0] >= 0xf0 && buf
[0] <= 0xf4)
1621 byte
= scm_peek_byte_or_eof_unlocked (port
);
1622 ASSERT_NOT_EOF (byte
);
1624 if (SCM_UNLIKELY (((byte
& 0xc0) != 0x80)
1625 || (buf
[0] == 0xf0 && byte
< 0x90)
1626 || (buf
[0] == 0xf4 && byte
> 0x8f)))
1629 CONSUME_PEEKED_BYTE ();
1630 buf
[1] = (scm_t_uint8
) byte
;
1633 byte
= scm_peek_byte_or_eof_unlocked (port
);
1634 ASSERT_NOT_EOF (byte
);
1636 if (SCM_UNLIKELY ((byte
& 0xc0) != 0x80))
1639 CONSUME_PEEKED_BYTE ();
1640 buf
[2] = (scm_t_uint8
) byte
;
1643 byte
= scm_peek_byte_or_eof_unlocked (port
);
1644 ASSERT_NOT_EOF (byte
);
1646 if (SCM_UNLIKELY ((byte
& 0xc0) != 0x80))
1649 CONSUME_PEEKED_BYTE ();
1650 buf
[3] = (scm_t_uint8
) byte
;
1653 *codepoint
= ((scm_t_wchar
) buf
[0] & 0x07) << 18UL
1654 | ((scm_t_wchar
) buf
[1] & 0x3f) << 12UL
1655 | ((scm_t_wchar
) buf
[2] & 0x3f) << 6UL
1664 /* Here we could choose the consume the faulty byte when it's not a
1665 valid starting byte, but it's not a requirement. What Section 3.9
1666 of Unicode 6.0.0 mandates, though, is to not consume a byte that
1667 would otherwise be a valid starting byte. */
1671 #undef CONSUME_PEEKED_BYTE
1672 #undef ASSERT_NOT_EOF
1675 /* Likewise, read a byte sequence from PORT, passing it through its
1676 input conversion descriptor. */
1678 get_iconv_codepoint (SCM port
, scm_t_wchar
*codepoint
,
1679 char buf
[SCM_MBCHAR_BUF_SIZE
], size_t *len
)
1681 scm_t_iconv_descriptors
*id
;
1683 size_t bytes_consumed
, output_size
;
1685 scm_t_uint8 utf8_buf
[SCM_MBCHAR_BUF_SIZE
];
1687 id
= scm_i_port_iconv_descriptors (port
);
1689 for (output_size
= 0, output
= (char *) utf8_buf
,
1690 bytes_consumed
= 0, err
= 0;
1691 err
== 0 && output_size
== 0
1692 && (bytes_consumed
== 0 || byte_read
!= EOF
);
1696 size_t input_left
, output_left
, done
;
1698 byte_read
= scm_get_byte_or_eof_unlocked (port
);
1699 if (byte_read
== EOF
)
1701 if (bytes_consumed
== 0)
1703 *codepoint
= (scm_t_wchar
) EOF
;
1711 buf
[bytes_consumed
] = byte_read
;
1714 input_left
= bytes_consumed
+ 1;
1715 output_left
= sizeof (utf8_buf
);
1717 done
= iconv (id
->input_cd
, &input
, &input_left
, &output
, &output_left
);
1718 if (done
== (size_t) -1)
1722 /* Missing input: keep trying. */
1726 output_size
= sizeof (utf8_buf
) - output_left
;
1729 if (SCM_UNLIKELY (output_size
== 0))
1730 /* An unterminated sequence. */
1732 else if (SCM_LIKELY (err
== 0))
1734 /* Convert the UTF8_BUF sequence to a Unicode code point. */
1735 *codepoint
= utf8_to_codepoint (utf8_buf
, output_size
);
1736 *len
= bytes_consumed
;
1742 /* Read a codepoint from PORT and return it in *CODEPOINT. Fill BUF
1743 with the byte representation of the codepoint in PORT's encoding, and
1744 set *LEN to the length in bytes of that representation. Return 0 on
1745 success and an errno value on error. */
1747 get_codepoint (SCM port
, scm_t_wchar
*codepoint
,
1748 char buf
[SCM_MBCHAR_BUF_SIZE
], size_t *len
)
1751 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1753 if (pt
->encoding_mode
== SCM_PORT_ENCODING_MODE_UTF8
)
1754 err
= get_utf8_codepoint (port
, codepoint
, (scm_t_uint8
*) buf
, len
);
1756 err
= get_iconv_codepoint (port
, codepoint
, buf
, len
);
1758 if (SCM_LIKELY (err
== 0))
1759 update_port_lf (*codepoint
, port
);
1760 else if (pt
->ilseq_handler
== SCM_ICONVEH_QUESTION_MARK
)
1764 update_port_lf (*codepoint
, port
);
1770 /* Read a codepoint from PORT and return it. */
1772 scm_getc_unlocked (SCM port
)
1773 #define FUNC_NAME "scm_getc"
1777 scm_t_wchar codepoint
;
1778 char buf
[SCM_MBCHAR_BUF_SIZE
];
1780 err
= get_codepoint (port
, &codepoint
, buf
, &len
);
1781 if (SCM_UNLIKELY (err
!= 0))
1782 /* At this point PORT should point past the invalid encoding, as per
1783 R6RS-lib Section 8.2.4. */
1784 scm_decoding_error (FUNC_NAME
, err
, "input decoding error", port
);
1793 scm_i_pthread_mutex_t
*lock
;
1796 scm_c_lock_port (port
, &lock
);
1797 ret
= scm_getc_unlocked (port
);
1799 scm_i_pthread_mutex_unlock (lock
);
1805 SCM_DEFINE (scm_read_char
, "read-char", 0, 1, 0,
1807 "Return the next character available from @var{port}, updating\n"
1808 "@var{port} to point to the following character. If no more\n"
1809 "characters are available, the end-of-file object is returned.\n"
1811 "When @var{port}'s data cannot be decoded according to its\n"
1812 "character encoding, a @code{decoding-error} is raised and\n"
1813 "@var{port} points past the erroneous byte sequence.\n")
1814 #define FUNC_NAME s_scm_read_char
1817 if (SCM_UNBNDP (port
))
1818 port
= scm_current_input_port ();
1819 SCM_VALIDATE_OPINPORT (1, port
);
1820 c
= scm_getc_unlocked (port
);
1823 return SCM_MAKE_CHAR (c
);
1833 scm_unget_byte_unlocked (int c
, SCM port
)
1834 #define FUNC_NAME "scm_unget_byte"
1836 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1838 if (pt
->read_buf
== pt
->putback_buf
)
1839 /* already using the put-back buffer. */
1841 /* enlarge putback_buf if necessary. */
1842 if (pt
->read_end
== pt
->read_buf
+ pt
->read_buf_size
1843 && pt
->read_buf
== pt
->read_pos
)
1845 size_t new_size
= pt
->read_buf_size
* 2;
1846 unsigned char *tmp
= (unsigned char *)
1847 scm_gc_realloc (pt
->putback_buf
, pt
->read_buf_size
, new_size
,
1850 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
= tmp
;
1851 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
1852 pt
->read_buf_size
= pt
->putback_buf_size
= new_size
;
1855 /* shift any existing bytes to buffer + 1. */
1856 if (pt
->read_pos
== pt
->read_end
)
1857 pt
->read_end
= pt
->read_buf
+ 1;
1858 else if (pt
->read_pos
!= pt
->read_buf
+ 1)
1860 int count
= pt
->read_end
- pt
->read_pos
;
1862 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
1863 pt
->read_end
= pt
->read_buf
+ 1 + count
;
1866 pt
->read_pos
= pt
->read_buf
;
1869 /* switch to the put-back buffer. */
1871 if (pt
->putback_buf
== NULL
)
1874 = (unsigned char *) scm_gc_malloc_pointerless
1875 (SCM_INITIAL_PUTBACK_BUF_SIZE
, "putback buffer");
1876 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
1879 pt
->saved_read_buf
= pt
->read_buf
;
1880 pt
->saved_read_pos
= pt
->read_pos
;
1881 pt
->saved_read_end
= pt
->read_end
;
1882 pt
->saved_read_buf_size
= pt
->read_buf_size
;
1884 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
1885 pt
->read_end
= pt
->read_buf
+ 1;
1886 pt
->read_buf_size
= pt
->putback_buf_size
;
1892 pt
->rw_active
= SCM_PORT_READ
;
1897 scm_unget_byte (int c
, SCM port
)
1899 scm_i_pthread_mutex_t
*lock
;
1900 scm_c_lock_port (port
, &lock
);
1901 scm_unget_byte_unlocked (c
, port
);
1903 scm_i_pthread_mutex_unlock (lock
);
1908 scm_ungetc_unlocked (scm_t_wchar c
, SCM port
)
1909 #define FUNC_NAME "scm_ungetc"
1911 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1913 char result_buf
[10];
1914 const char *encoding
;
1918 if (pt
->encoding
!= NULL
)
1919 encoding
= pt
->encoding
;
1921 encoding
= "ISO-8859-1";
1923 len
= sizeof (result_buf
);
1924 result
= u32_conv_to_encoding (encoding
,
1925 (enum iconv_ilseq_handler
) pt
->ilseq_handler
,
1926 (uint32_t *) &c
, 1, NULL
,
1929 if (SCM_UNLIKELY (result
== NULL
|| len
== 0))
1930 scm_encoding_error (FUNC_NAME
, errno
,
1931 "conversion to port encoding failed",
1932 SCM_BOOL_F
, SCM_MAKE_CHAR (c
));
1934 for (i
= len
- 1; i
>= 0; i
--)
1935 scm_unget_byte_unlocked (result
[i
], port
);
1937 if (SCM_UNLIKELY (result
!= result_buf
))
1942 /* What should col be in this case?
1943 * We'll leave it at -1.
1945 SCM_LINUM (port
) -= 1;
1953 scm_ungetc (scm_t_wchar c
, SCM port
)
1955 scm_i_pthread_mutex_t
*lock
;
1956 scm_c_lock_port (port
, &lock
);
1957 scm_ungetc_unlocked (c
, port
);
1959 scm_i_pthread_mutex_unlock (lock
);
1964 scm_ungets_unlocked (const char *s
, int n
, SCM port
)
1966 /* This is simple minded and inefficient, but unreading strings is
1967 * probably not a common operation, and remember that line and
1968 * column numbers have to be handled...
1970 * Please feel free to write an optimized version!
1973 scm_ungetc_unlocked (s
[n
], port
);
1977 scm_ungets (const char *s
, int n
, SCM port
)
1979 scm_i_pthread_mutex_t
*lock
;
1980 scm_c_lock_port (port
, &lock
);
1981 scm_ungets_unlocked (s
, n
, port
);
1983 scm_i_pthread_mutex_unlock (lock
);
1987 SCM_DEFINE (scm_peek_char
, "peek-char", 0, 1, 0,
1989 "Return the next character available from @var{port},\n"
1990 "@emph{without} updating @var{port} to point to the following\n"
1991 "character. If no more characters are available, the\n"
1992 "end-of-file object is returned.\n"
1994 "The value returned by\n"
1995 "a call to @code{peek-char} is the same as the value that would\n"
1996 "have been returned by a call to @code{read-char} on the same\n"
1997 "port. The only difference is that the very next call to\n"
1998 "@code{read-char} or @code{peek-char} on that @var{port} will\n"
1999 "return the value returned by the preceding call to\n"
2000 "@code{peek-char}. In particular, a call to @code{peek-char} on\n"
2001 "an interactive port will hang waiting for input whenever a call\n"
2002 "to @code{read-char} would have hung.\n"
2004 "As for @code{read-char}, a @code{decoding-error} may be raised\n"
2005 "if such a situation occurs. However, unlike with @code{read-char},\n"
2006 "@var{port} still points at the beginning of the erroneous byte\n"
2007 "sequence when the error is raised.\n")
2008 #define FUNC_NAME s_scm_peek_char
2013 char bytes
[SCM_MBCHAR_BUF_SIZE
];
2014 long column
, line
, i
;
2017 if (SCM_UNBNDP (port
))
2018 port
= scm_current_input_port ();
2019 SCM_VALIDATE_OPINPORT (1, port
);
2021 column
= SCM_COL (port
);
2022 line
= SCM_LINUM (port
);
2024 err
= get_codepoint (port
, &c
, bytes
, &len
);
2026 for (i
= len
- 1; i
>= 0; i
--)
2027 scm_unget_byte_unlocked (bytes
[i
], port
);
2029 SCM_COL (port
) = column
;
2030 SCM_LINUM (port
) = line
;
2032 if (SCM_UNLIKELY (err
!= 0))
2034 scm_decoding_error (FUNC_NAME
, err
, "input decoding error", port
);
2036 /* Shouldn't happen since `catch' always aborts to prompt. */
2037 result
= SCM_BOOL_F
;
2040 result
= SCM_EOF_VAL
;
2042 result
= SCM_MAKE_CHAR (c
);
2048 SCM_DEFINE (scm_unread_char
, "unread-char", 1, 1, 0,
2049 (SCM cobj
, SCM port
),
2050 "Place character @var{cobj} in @var{port} so that it will be\n"
2051 "read by the next read operation. If called multiple times, the\n"
2052 "unread characters will be read again in last-in first-out\n"
2053 "order. If @var{port} is not supplied, the current input port\n"
2055 #define FUNC_NAME s_scm_unread_char
2059 SCM_VALIDATE_CHAR (1, cobj
);
2060 if (SCM_UNBNDP (port
))
2061 port
= scm_current_input_port ();
2062 SCM_VALIDATE_OPINPORT (2, port
);
2064 c
= SCM_CHAR (cobj
);
2066 scm_ungetc_unlocked (c
, port
);
2071 SCM_DEFINE (scm_unread_string
, "unread-string", 2, 0, 0,
2072 (SCM str
, SCM port
),
2073 "Place the string @var{str} in @var{port} so that its characters will be\n"
2074 "read in subsequent read operations. If called multiple times, the\n"
2075 "unread characters will be read again in last-in first-out order. If\n"
2076 "@var{port} is not supplied, the current-input-port is used.")
2077 #define FUNC_NAME s_scm_unread_string
2080 SCM_VALIDATE_STRING (1, str
);
2081 if (SCM_UNBNDP (port
))
2082 port
= scm_current_input_port ();
2083 SCM_VALIDATE_OPINPORT (2, port
);
2085 n
= scm_i_string_length (str
);
2088 scm_ungetc_unlocked (scm_i_string_ref (str
, n
), port
);
2097 /* Manipulating the buffers. */
2099 /* This routine does not take any locks, as it is usually called as part
2100 of a port implementation. */
2102 scm_port_non_buffer (scm_t_port
*pt
)
2104 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
2105 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
2106 pt
->read_buf_size
= pt
->write_buf_size
= 1;
2107 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
2110 /* this should only be called when the read buffer is empty. it
2111 tries to refill the read buffer. it returns the first char from
2112 the port, which is either EOF or *(pt->read_pos). */
2114 scm_fill_input_unlocked (SCM port
)
2116 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2118 assert (pt
->read_pos
== pt
->read_end
);
2120 if (pt
->read_buf
== pt
->putback_buf
)
2122 /* finished reading put-back chars. */
2123 pt
->read_buf
= pt
->saved_read_buf
;
2124 pt
->read_pos
= pt
->saved_read_pos
;
2125 pt
->read_end
= pt
->saved_read_end
;
2126 pt
->read_buf_size
= pt
->saved_read_buf_size
;
2127 if (pt
->read_pos
< pt
->read_end
)
2128 return *(pt
->read_pos
);
2130 return SCM_PORT_DESCRIPTOR (port
)->fill_input (port
);
2134 scm_fill_input (SCM port
)
2136 scm_i_pthread_mutex_t
*lock
;
2139 scm_c_lock_port (port
, &lock
);
2140 ret
= scm_fill_input_unlocked (port
);
2142 scm_i_pthread_mutex_unlock (lock
);
2148 /* move up to read_len chars from port's putback and/or read buffers
2149 into memory starting at dest. returns the number of chars moved. */
2151 scm_take_from_input_buffers (SCM port
, char *dest
, size_t read_len
)
2153 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2154 size_t chars_read
= 0;
2155 size_t from_buf
= min (pt
->read_end
- pt
->read_pos
, read_len
);
2159 memcpy (dest
, pt
->read_pos
, from_buf
);
2160 pt
->read_pos
+= from_buf
;
2161 chars_read
+= from_buf
;
2162 read_len
-= from_buf
;
2166 /* if putback was active, try the real input buffer too. */
2167 if (pt
->read_buf
== pt
->putback_buf
)
2169 from_buf
= min (pt
->saved_read_end
- pt
->saved_read_pos
, read_len
);
2172 memcpy (dest
, pt
->saved_read_pos
, from_buf
);
2173 pt
->saved_read_pos
+= from_buf
;
2174 chars_read
+= from_buf
;
2180 /* Clear a port's read buffers, returning the contents. */
2181 SCM_DEFINE (scm_drain_input
, "drain-input", 1, 0, 0,
2183 "This procedure clears a port's input buffers, similar\n"
2184 "to the way that force-output clears the output buffer. The\n"
2185 "contents of the buffers are returned as a single string, e.g.,\n"
2188 "(define p (open-input-file ...))\n"
2189 "(drain-input p) => empty string, nothing buffered yet.\n"
2190 "(unread-char (read-char p) p)\n"
2191 "(drain-input p) => initial chars from p, up to the buffer size.\n"
2193 "Draining the buffers may be useful for cleanly finishing\n"
2194 "buffered I/O so that the file descriptor can be used directly\n"
2195 "for further input.")
2196 #define FUNC_NAME s_scm_drain_input
2203 SCM_VALIDATE_OPINPORT (1, port
);
2204 pt
= SCM_PTAB_ENTRY (port
);
2206 count
= pt
->read_end
- pt
->read_pos
;
2207 if (pt
->read_buf
== pt
->putback_buf
)
2208 count
+= pt
->saved_read_end
- pt
->saved_read_pos
;
2212 result
= scm_i_make_string (count
, &data
, 0);
2213 scm_take_from_input_buffers (port
, data
, count
);
2216 result
= scm_nullstr
;
2223 scm_end_input_unlocked (SCM port
)
2226 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2228 if (pt
->read_buf
== pt
->putback_buf
)
2230 offset
= pt
->read_end
- pt
->read_pos
;
2231 pt
->read_buf
= pt
->saved_read_buf
;
2232 pt
->read_pos
= pt
->saved_read_pos
;
2233 pt
->read_end
= pt
->saved_read_end
;
2234 pt
->read_buf_size
= pt
->saved_read_buf_size
;
2239 SCM_PORT_DESCRIPTOR (port
)->end_input (port
, offset
);
2243 scm_end_input (SCM port
)
2245 scm_i_pthread_mutex_t
*lock
;
2246 scm_c_lock_port (port
, &lock
);
2247 scm_end_input_unlocked (port
);
2249 scm_i_pthread_mutex_unlock (lock
);
2253 SCM_DEFINE (scm_force_output
, "force-output", 0, 1, 0,
2255 "Flush the specified output port, or the current output port if @var{port}\n"
2256 "is omitted. The current output buffer contents are passed to the\n"
2257 "underlying port implementation (e.g., in the case of fports, the\n"
2258 "data will be written to the file and the output buffer will be cleared.)\n"
2259 "It has no effect on an unbuffered port.\n\n"
2260 "The return value is unspecified.")
2261 #define FUNC_NAME s_scm_force_output
2263 if (SCM_UNBNDP (port
))
2264 port
= scm_current_output_port ();
2267 port
= SCM_COERCE_OUTPORT (port
);
2268 SCM_VALIDATE_OPOUTPORT (1, port
);
2270 scm_flush_unlocked (port
);
2271 return SCM_UNSPECIFIED
;
2276 scm_flush_unlocked (SCM port
)
2278 SCM_PORT_DESCRIPTOR (port
)->flush (port
);
2282 scm_flush (SCM port
)
2284 scm_i_pthread_mutex_t
*lock
;
2285 scm_c_lock_port (port
, &lock
);
2286 scm_flush_unlocked (port
);
2288 scm_i_pthread_mutex_unlock (lock
);
2298 scm_putc (char c
, SCM port
)
2300 scm_i_pthread_mutex_t
*lock
;
2301 scm_c_lock_port (port
, &lock
);
2302 scm_putc_unlocked (c
, port
);
2304 scm_i_pthread_mutex_unlock (lock
);
2309 scm_puts (const char *s
, SCM port
)
2311 scm_i_pthread_mutex_t
*lock
;
2312 scm_c_lock_port (port
, &lock
);
2313 scm_puts_unlocked (s
, port
);
2315 scm_i_pthread_mutex_unlock (lock
);
2321 * Used by an application to write arbitrary number of bytes to an SCM
2322 * port. Similar semantics as libc write. However, unlike libc
2323 * write, scm_c_write writes the requested number of bytes and has no
2326 * Warning: Doesn't update port line and column counts!
2329 scm_c_write_unlocked (SCM port
, const void *ptr
, size_t size
)
2330 #define FUNC_NAME "scm_c_write"
2333 scm_t_ptob_descriptor
*ptob
;
2335 SCM_VALIDATE_OPOUTPORT (1, port
);
2337 pt
= SCM_PTAB_ENTRY (port
);
2338 ptob
= SCM_PORT_DESCRIPTOR (port
);
2340 if (pt
->rw_active
== SCM_PORT_READ
)
2341 scm_end_input_unlocked (port
);
2343 ptob
->write (port
, ptr
, size
);
2346 pt
->rw_active
= SCM_PORT_WRITE
;
2351 scm_c_write (SCM port
, const void *ptr
, size_t size
)
2353 scm_i_pthread_mutex_t
*lock
;
2354 scm_c_lock_port (port
, &lock
);
2355 scm_c_write_unlocked (port
, ptr
, size
);
2357 scm_i_pthread_mutex_unlock (lock
);
2363 * This function differs from scm_c_write; it updates port line and
2366 scm_lfwrite_unlocked (const char *ptr
, size_t size
, SCM port
)
2368 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2369 scm_t_ptob_descriptor
*ptob
= SCM_PORT_DESCRIPTOR (port
);
2371 if (pt
->rw_active
== SCM_PORT_READ
)
2372 scm_end_input_unlocked (port
);
2374 ptob
->write (port
, ptr
, size
);
2376 for (; size
; ptr
++, size
--)
2377 update_port_lf ((scm_t_wchar
) (unsigned char) *ptr
, port
);
2380 pt
->rw_active
= SCM_PORT_WRITE
;
2384 scm_lfwrite (const char *ptr
, size_t size
, SCM port
)
2386 scm_i_pthread_mutex_t
*lock
;
2387 scm_c_lock_port (port
, &lock
);
2388 scm_lfwrite_unlocked (ptr
, size
, port
);
2390 scm_i_pthread_mutex_unlock (lock
);
2394 /* Write STR to PORT from START inclusive to END exclusive. */
2396 scm_lfwrite_substr (SCM str
, size_t start
, size_t end
, SCM port
)
2398 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2400 if (pt
->rw_active
== SCM_PORT_READ
)
2401 scm_end_input_unlocked (port
);
2403 if (end
== (size_t) -1)
2404 end
= scm_i_string_length (str
);
2406 scm_display (scm_c_substring (str
, start
, end
), port
);
2409 pt
->rw_active
= SCM_PORT_WRITE
;
2415 /* Querying and setting positions, and character availability. */
2417 SCM_DEFINE (scm_char_ready_p
, "char-ready?", 0, 1, 0,
2419 "Return @code{#t} if a character is ready on input @var{port}\n"
2420 "and return @code{#f} otherwise. If @code{char-ready?} returns\n"
2421 "@code{#t} then the next @code{read-char} operation on\n"
2422 "@var{port} is guaranteed not to hang. If @var{port} is a file\n"
2423 "port at end of file then @code{char-ready?} returns @code{#t}.\n"
2425 "@code{char-ready?} exists to make it possible for a\n"
2426 "program to accept characters from interactive ports without\n"
2427 "getting stuck waiting for input. Any input editors associated\n"
2428 "with such ports must make sure that characters whose existence\n"
2429 "has been asserted by @code{char-ready?} cannot be rubbed out.\n"
2430 "If @code{char-ready?} were to return @code{#f} at end of file,\n"
2431 "a port at end of file would be indistinguishable from an\n"
2432 "interactive port that has no ready characters.")
2433 #define FUNC_NAME s_scm_char_ready_p
2437 if (SCM_UNBNDP (port
))
2438 port
= scm_current_input_port ();
2439 /* It's possible to close the current input port, so validate even in
2441 SCM_VALIDATE_OPINPORT (1, port
);
2443 pt
= SCM_PTAB_ENTRY (port
);
2445 /* if the current read buffer is filled, or the
2446 last pushed-back char has been read and the saved buffer is
2447 filled, result is true. */
2448 if (pt
->read_pos
< pt
->read_end
2449 || (pt
->read_buf
== pt
->putback_buf
2450 && pt
->saved_read_pos
< pt
->saved_read_end
))
2454 scm_t_ptob_descriptor
*ptob
= SCM_PORT_DESCRIPTOR (port
);
2456 if (ptob
->input_waiting
)
2457 return scm_from_bool(ptob
->input_waiting (port
));
2464 SCM_DEFINE (scm_seek
, "seek", 3, 0, 0,
2465 (SCM fd_port
, SCM offset
, SCM whence
),
2466 "Sets the current position of @var{fd_port} to the integer\n"
2467 "@var{offset}, which is interpreted according to the value of\n"
2470 "One of the following variables should be supplied for\n"
2472 "@defvar SEEK_SET\n"
2473 "Seek from the beginning of the file.\n"
2475 "@defvar SEEK_CUR\n"
2476 "Seek from the current position.\n"
2478 "@defvar SEEK_END\n"
2479 "Seek from the end of the file.\n"
2481 "If @var{fd_port} is a file descriptor, the underlying system\n"
2482 "call is @code{lseek}. @var{port} may be a string port.\n"
2484 "The value returned is the new position in the file. This means\n"
2485 "that the current position of a port can be obtained using:\n"
2487 "(seek port 0 SEEK_CUR)\n"
2489 #define FUNC_NAME s_scm_seek
2493 fd_port
= SCM_COERCE_OUTPORT (fd_port
);
2495 how
= scm_to_int (whence
);
2496 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
2497 SCM_OUT_OF_RANGE (3, whence
);
2499 if (SCM_OPPORTP (fd_port
))
2501 scm_t_ptob_descriptor
*ptob
= SCM_PORT_DESCRIPTOR (fd_port
);
2502 off_t_or_off64_t off
= scm_to_off_t_or_off64_t (offset
);
2503 off_t_or_off64_t rv
;
2506 SCM_MISC_ERROR ("port is not seekable",
2507 scm_cons (fd_port
, SCM_EOL
));
2509 rv
= ptob
->seek (fd_port
, off
, how
);
2510 return scm_from_off_t_or_off64_t (rv
);
2512 else /* file descriptor?. */
2514 off_t_or_off64_t off
= scm_to_off_t_or_off64_t (offset
);
2515 off_t_or_off64_t rv
;
2516 rv
= lseek_or_lseek64 (scm_to_int (fd_port
), off
, how
);
2519 return scm_from_off_t_or_off64_t (rv
);
2528 /* Mingw has ftruncate(), perhaps implemented above using chsize, but
2529 doesn't have the filename version truncate(), hence this code. */
2530 #if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
2532 truncate (const char *file
, off_t length
)
2536 fdes
= open (file
, O_BINARY
| O_WRONLY
);
2540 ret
= ftruncate (fdes
, length
);
2543 int save_errno
= errno
;
2549 return close (fdes
);
2551 #endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
2553 SCM_DEFINE (scm_truncate_file
, "truncate-file", 1, 1, 0,
2554 (SCM object
, SCM length
),
2555 "Truncate file @var{object} to @var{length} bytes. @var{object}\n"
2556 "can be a filename string, a port object, or an integer file\n"
2558 "The return value is unspecified.\n"
2560 "For a port or file descriptor @var{length} can be omitted, in\n"
2561 "which case the file is truncated at the current position (per\n"
2562 "@code{ftell} above).\n"
2564 "On most systems a file can be extended by giving a length\n"
2565 "greater than the current size, but this is not mandatory in the\n"
2567 #define FUNC_NAME s_scm_truncate_file
2571 /* "object" can be a port, fdes or filename.
2573 Negative "length" makes no sense, but it's left to truncate() or
2574 ftruncate() to give back an error for that (normally EINVAL).
2577 if (SCM_UNBNDP (length
))
2579 /* must supply length if object is a filename. */
2580 if (scm_is_string (object
))
2581 SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL
);
2583 length
= scm_seek (object
, SCM_INUM0
, scm_from_int (SEEK_CUR
));
2586 object
= SCM_COERCE_OUTPORT (object
);
2587 if (scm_is_integer (object
))
2589 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
2590 SCM_SYSCALL (rv
= ftruncate_or_ftruncate64 (scm_to_int (object
),
2593 else if (SCM_OPOUTPORTP (object
))
2595 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
2596 scm_t_port
*pt
= SCM_PTAB_ENTRY (object
);
2597 scm_t_ptob_descriptor
*ptob
= SCM_PORT_DESCRIPTOR (object
);
2599 if (!ptob
->truncate
)
2600 SCM_MISC_ERROR ("port is not truncatable", SCM_EOL
);
2601 if (pt
->rw_active
== SCM_PORT_READ
)
2602 scm_end_input_unlocked (object
);
2603 else if (pt
->rw_active
== SCM_PORT_WRITE
)
2604 ptob
->flush (object
);
2606 ptob
->truncate (object
, c_length
);
2611 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
2612 char *str
= scm_to_locale_string (object
);
2614 SCM_SYSCALL (rv
= truncate_or_truncate64 (str
, c_length
));
2621 return SCM_UNSPECIFIED
;
2625 SCM_DEFINE (scm_port_line
, "port-line", 1, 0, 0,
2627 "Return the current line number for @var{port}.\n"
2629 "The first line of a file is 0. But you might want to add 1\n"
2630 "when printing line numbers, since starting from 1 is\n"
2631 "traditional in error messages, and likely to be more natural to\n"
2633 #define FUNC_NAME s_scm_port_line
2635 port
= SCM_COERCE_OUTPORT (port
);
2636 SCM_VALIDATE_OPENPORT (1, port
);
2637 return scm_from_long (SCM_LINUM (port
));
2641 SCM_DEFINE (scm_set_port_line_x
, "set-port-line!", 2, 0, 0,
2642 (SCM port
, SCM line
),
2643 "Set the current line number for @var{port} to @var{line}. The\n"
2644 "first line of a file is 0.")
2645 #define FUNC_NAME s_scm_set_port_line_x
2647 port
= SCM_COERCE_OUTPORT (port
);
2648 SCM_VALIDATE_OPENPORT (1, port
);
2649 SCM_PTAB_ENTRY (port
)->line_number
= scm_to_long (line
);
2650 return SCM_UNSPECIFIED
;
2654 SCM_DEFINE (scm_port_column
, "port-column", 1, 0, 0,
2656 "Return the current column number of @var{port}.\n"
2657 "If the number is\n"
2658 "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
2659 "- i.e. the first character of the first line is line 0, column 0.\n"
2660 "(However, when you display a file position, for example in an error\n"
2661 "message, we recommend you add 1 to get 1-origin integers. This is\n"
2662 "because lines and column numbers traditionally start with 1, and that is\n"
2663 "what non-programmers will find most natural.)")
2664 #define FUNC_NAME s_scm_port_column
2666 port
= SCM_COERCE_OUTPORT (port
);
2667 SCM_VALIDATE_OPENPORT (1, port
);
2668 return scm_from_int (SCM_COL (port
));
2672 SCM_DEFINE (scm_set_port_column_x
, "set-port-column!", 2, 0, 0,
2673 (SCM port
, SCM column
),
2674 "Set the current column of @var{port}. Before reading the first\n"
2675 "character on a line the column should be 0.")
2676 #define FUNC_NAME s_scm_set_port_column_x
2678 port
= SCM_COERCE_OUTPORT (port
);
2679 SCM_VALIDATE_OPENPORT (1, port
);
2680 SCM_PTAB_ENTRY (port
)->column_number
= scm_to_int (column
);
2681 return SCM_UNSPECIFIED
;
2685 SCM_DEFINE (scm_port_filename
, "port-filename", 1, 0, 0,
2687 "Return the filename associated with @var{port}, or @code{#f}\n"
2688 "if no filename is associated with the port.")
2689 #define FUNC_NAME s_scm_port_filename
2691 port
= SCM_COERCE_OUTPORT (port
);
2692 SCM_VALIDATE_OPENPORT (1, port
);
2693 return SCM_FILENAME (port
);
2697 SCM_DEFINE (scm_set_port_filename_x
, "set-port-filename!", 2, 0, 0,
2698 (SCM port
, SCM filename
),
2699 "Change the filename associated with @var{port}, using the current input\n"
2700 "port if none is specified. Note that this does not change the port's\n"
2701 "source of data, but only the value that is returned by\n"
2702 "@code{port-filename} and reported in diagnostic output.")
2703 #define FUNC_NAME s_scm_set_port_filename_x
2705 port
= SCM_COERCE_OUTPORT (port
);
2706 SCM_VALIDATE_OPENPORT (1, port
);
2707 /* We allow the user to set the filename to whatever he likes. */
2708 SCM_SET_FILENAME (port
, filename
);
2709 return SCM_UNSPECIFIED
;
2716 /* Implementation helpers for port printing functions. */
2719 scm_print_port_mode (SCM exp
, SCM port
)
2721 scm_puts_unlocked (SCM_CLOSEDP (exp
)
2723 : (SCM_RDNG
& SCM_CELL_WORD_0 (exp
)
2724 ? (SCM_WRTNG
& SCM_CELL_WORD_0 (exp
)
2727 : (SCM_WRTNG
& SCM_CELL_WORD_0 (exp
)
2734 scm_port_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2736 char *type
= SCM_PTOBNAME (SCM_PTOBNUM (exp
));
2739 scm_puts_unlocked ("#<", port
);
2740 scm_print_port_mode (exp
, port
);
2741 scm_puts_unlocked (type
, port
);
2742 scm_putc_unlocked (' ', port
);
2743 scm_uintprint (SCM_CELL_WORD_1 (exp
), 16, port
);
2744 scm_putc_unlocked ('>', port
);
2751 /* Iterating over all ports. */
2753 struct for_each_data
2755 void (*proc
) (void *data
, SCM p
);
2760 for_each_trampoline (void *data
, SCM port
, SCM result
)
2762 struct for_each_data
*d
= data
;
2764 d
->proc (d
->data
, port
);
2770 scm_c_port_for_each (void (*proc
)(void *data
, SCM p
), void *data
)
2772 struct for_each_data d
;
2777 scm_c_weak_set_fold (for_each_trampoline
, &d
, SCM_EOL
,
2778 scm_i_port_weak_set
);
2782 scm_for_each_trampoline (void *data
, SCM port
)
2784 scm_call_1 (SCM_PACK_POINTER (data
), port
);
2787 SCM_DEFINE (scm_port_for_each
, "port-for-each", 1, 0, 0,
2789 "Apply @var{proc} to each port in the Guile port table\n"
2790 "in turn. The return value is unspecified. More specifically,\n"
2791 "@var{proc} is applied exactly once to every port that exists\n"
2792 "in the system at the time @code{port-for-each} is invoked.\n"
2793 "Changes to the port table while @code{port-for-each} is running\n"
2794 "have no effect as far as @code{port-for-each} is concerned.")
2795 #define FUNC_NAME s_scm_port_for_each
2797 SCM_VALIDATE_PROC (1, proc
);
2799 scm_c_port_for_each (scm_for_each_trampoline
, SCM_UNPACK_POINTER (proc
));
2801 return SCM_UNSPECIFIED
;
2806 flush_output_port (void *closure
, SCM port
)
2808 if (SCM_OPOUTPORTP (port
))
2809 scm_flush_unlocked (port
);
2812 SCM_DEFINE (scm_flush_all_ports
, "flush-all-ports", 0, 0, 0,
2814 "Equivalent to calling @code{force-output} on\n"
2815 "all open output ports. The return value is unspecified.")
2816 #define FUNC_NAME s_scm_flush_all_ports
2818 scm_c_port_for_each (&flush_output_port
, NULL
);
2819 return SCM_UNSPECIFIED
;
2828 scm_t_bits scm_tc16_void_port
= 0;
2830 static int fill_input_void_port (SCM port SCM_UNUSED
)
2836 write_void_port (SCM port SCM_UNUSED
,
2837 const void *data SCM_UNUSED
,
2838 size_t size SCM_UNUSED
)
2843 scm_i_void_port (long mode_bits
)
2847 ret
= scm_c_make_port (scm_tc16_void_port
, mode_bits
, 0);
2849 scm_port_non_buffer (SCM_PTAB_ENTRY (ret
));
2855 scm_void_port (char *mode_str
)
2857 return scm_i_void_port (scm_mode_bits (mode_str
));
2860 SCM_DEFINE (scm_sys_make_void_port
, "%make-void-port", 1, 0, 0,
2862 "Create and return a new void port. A void port acts like\n"
2863 "@file{/dev/null}. The @var{mode} argument\n"
2864 "specifies the input/output modes for this port: see the\n"
2865 "documentation for @code{open-file} in @ref{File Ports}.")
2866 #define FUNC_NAME s_scm_sys_make_void_port
2868 return scm_i_void_port (scm_i_mode_bits (mode
));
2875 /* Initialization. */
2880 /* lseek() symbols. */
2881 scm_c_define ("SEEK_SET", scm_from_int (SEEK_SET
));
2882 scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR
));
2883 scm_c_define ("SEEK_END", scm_from_int (SEEK_END
));
2885 scm_tc16_void_port
= scm_make_port_type ("void", fill_input_void_port
,
2888 cur_inport_fluid
= scm_make_fluid ();
2889 cur_outport_fluid
= scm_make_fluid ();
2890 cur_errport_fluid
= scm_make_fluid ();
2891 cur_loadport_fluid
= scm_make_fluid ();
2893 scm_i_port_weak_set
= scm_c_make_weak_set (31);
2895 #include "libguile/ports.x"
2897 /* Use Latin-1 as the default port encoding. */
2898 SCM_VARIABLE_SET (default_port_encoding_var
,
2899 scm_make_fluid_with_default (SCM_BOOL_F
));
2900 scm_port_encoding_init
= 1;
2902 SCM_VARIABLE_SET (scm_conversion_strategy
,
2903 scm_make_fluid_with_default
2904 (scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK
)));
2905 scm_conversion_strategy_init
= 1;
2907 /* These bindings are used when boot-9 turns `current-input-port' et
2908 al into parameters. They are then removed from the guile module. */
2909 scm_c_define ("%current-input-port-fluid", cur_inport_fluid
);
2910 scm_c_define ("%current-output-port-fluid", cur_outport_fluid
);
2911 scm_c_define ("%current-error-port-fluid", cur_errport_fluid
);