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 return scm_i_mode_bits (scm_from_locale_string (modes
));
477 scm_i_mode_bits (SCM modes
)
481 if (!scm_is_string (modes
))
482 scm_wrong_type_arg_msg (NULL
, 0, modes
, "string");
484 bits
= scm_i_mode_bits_n (modes
);
485 scm_remember_upto_here_1 (modes
);
489 /* Return the mode flags from an open port.
490 * Some modes such as "append" are only used when opening
491 * a file and are not returned here. */
493 SCM_DEFINE (scm_port_mode
, "port-mode", 1, 0, 0,
495 "Return the port modes associated with the open port @var{port}.\n"
496 "These will not necessarily be identical to the modes used when\n"
497 "the port was opened, since modes such as \"append\" which are\n"
498 "used only during port creation are not retained.")
499 #define FUNC_NAME s_scm_port_mode
504 port
= SCM_COERCE_OUTPORT (port
);
505 SCM_VALIDATE_OPPORT (1, port
);
506 if (SCM_CELL_WORD_0 (port
) & SCM_RDNG
) {
507 if (SCM_CELL_WORD_0 (port
) & SCM_WRTNG
)
508 strcpy (modes
, "r+");
512 else if (SCM_CELL_WORD_0 (port
) & SCM_WRTNG
)
514 if (SCM_CELL_WORD_0 (port
) & SCM_BUF0
)
517 return scm_from_latin1_string (modes
);
524 /* The port table --- a weak set of all ports.
526 We need a global registry of ports to flush them all at exit, and to
527 get all the ports matching a file descriptor. */
528 SCM scm_i_port_weak_set
;
533 /* Port finalization. */
537 scm_t_ptob_descriptor
*ptob
;
542 do_free (void *body_data
)
544 struct do_free_data
*data
= body_data
;
546 /* `close' is for explicit `close-port' by user. `free' is for this
547 purpose: ports collected by the GC. */
548 data
->ptob
->free (data
->port
);
553 /* Finalize the object (a port) pointed to by PTR. */
555 finalize_port (GC_PTR ptr
, GC_PTR data
)
557 SCM port
= SCM_PACK_POINTER (ptr
);
559 if (!SCM_PORTP (port
))
562 if (SCM_OPENP (port
))
564 struct do_free_data data
;
566 SCM_CLR_PORT_OPEN_FLAG (port
);
568 data
.ptob
= SCM_PORT_DESCRIPTOR (port
);
571 scm_internal_catch (SCM_BOOL_T
, do_free
, &data
,
572 scm_handle_by_message_noexit
, NULL
);
574 scm_gc_ports_collected
++;
582 scm_c_make_port_with_encoding (scm_t_bits tag
, unsigned long mode_bits
,
583 const char *encoding
,
584 scm_t_string_failed_conversion_handler handler
,
589 scm_t_ptob_descriptor
*ptob
;
591 entry
= (scm_t_port
*) scm_gc_calloc (sizeof (scm_t_port
), "port");
592 ptob
= scm_c_port_type_ref (SCM_TC2PTOBNUM (tag
));
594 ret
= scm_words (tag
| mode_bits
, 3);
595 SCM_SET_CELL_WORD_1 (ret
, (scm_t_bits
) entry
);
596 SCM_SET_CELL_WORD_2 (ret
, (scm_t_bits
) ptob
);
598 entry
->lock
= scm_gc_malloc_pointerless (sizeof (*entry
->lock
), "port lock");
599 scm_i_pthread_mutex_init (entry
->lock
, scm_i_pthread_mutexattr_recursive
);
601 entry
->file_name
= SCM_BOOL_F
;
602 entry
->rw_active
= SCM_PORT_NEITHER
;
604 entry
->stream
= stream
;
605 entry
->encoding
= encoding
? scm_gc_strdup (encoding
, "port") : NULL
;
606 if (encoding
&& strcmp (encoding
, "UTF-8") == 0)
607 entry
->encoding_mode
= SCM_PORT_ENCODING_MODE_UTF8
;
609 entry
->encoding_mode
= SCM_PORT_ENCODING_MODE_ICONV
;
610 entry
->ilseq_handler
= handler
;
611 entry
->iconv_descriptors
= NULL
;
613 if (SCM_PORT_DESCRIPTOR (ret
)->free
)
614 scm_i_set_finalizer (SCM2PTR (ret
), finalize_port
, NULL
);
616 if (SCM_PORT_DESCRIPTOR (ret
)->flags
& SCM_PORT_TYPE_HAS_FLUSH
)
617 scm_weak_set_add_x (scm_i_port_weak_set
, ret
);
623 scm_c_make_port (scm_t_bits tag
, unsigned long mode_bits
, scm_t_bits stream
)
625 return scm_c_make_port_with_encoding (tag
, mode_bits
,
626 scm_i_default_port_encoding (),
627 scm_i_get_conversion_strategy (SCM_BOOL_F
),
632 scm_new_port_table_entry (scm_t_bits tag
)
634 return scm_c_make_port (tag
, 0, 0);
641 SCM_DEFINE (scm_port_p
, "port?", 1, 0, 0,
643 "Return a boolean indicating whether @var{x} is a port.\n"
644 "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
646 #define FUNC_NAME s_scm_port_p
648 return scm_from_bool (SCM_PORTP (x
));
652 SCM_DEFINE (scm_input_port_p
, "input-port?", 1, 0, 0,
654 "Return @code{#t} if @var{x} is an input port, otherwise return\n"
655 "@code{#f}. Any object satisfying this predicate also satisfies\n"
657 #define FUNC_NAME s_scm_input_port_p
659 return scm_from_bool (SCM_INPUT_PORT_P (x
));
663 SCM_DEFINE (scm_output_port_p
, "output-port?", 1, 0, 0,
665 "Return @code{#t} if @var{x} is an output port, otherwise return\n"
666 "@code{#f}. Any object satisfying this predicate also satisfies\n"
668 #define FUNC_NAME s_scm_output_port_p
670 x
= SCM_COERCE_OUTPORT (x
);
671 return scm_from_bool (SCM_OUTPUT_PORT_P (x
));
675 SCM_DEFINE (scm_port_closed_p
, "port-closed?", 1, 0, 0,
677 "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
679 #define FUNC_NAME s_scm_port_closed_p
681 SCM_VALIDATE_PORT (1, port
);
682 return scm_from_bool (!SCM_OPPORTP (port
));
686 SCM_DEFINE (scm_eof_object_p
, "eof-object?", 1, 0, 0,
688 "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
690 #define FUNC_NAME s_scm_eof_object_p
692 return scm_from_bool (SCM_EOF_OBJECT_P (x
));
701 static void close_iconv_descriptors (scm_t_iconv_descriptors
*id
);
704 * Call the close operation on a port object.
705 * see also scm_close.
707 SCM_DEFINE (scm_close_port
, "close-port", 1, 0, 0,
709 "Close the specified port object. Return @code{#t} if it\n"
710 "successfully closes a port or @code{#f} if it was already\n"
711 "closed. An exception may be raised if an error occurs, for\n"
712 "example when flushing buffered output. See also @ref{Ports and\n"
713 "File Descriptors, close}, for a procedure which can close file\n"
715 #define FUNC_NAME s_scm_close_port
720 port
= SCM_COERCE_OUTPORT (port
);
722 SCM_VALIDATE_PORT (1, port
);
723 if (SCM_CLOSEDP (port
))
726 p
= SCM_PTAB_ENTRY (port
);
727 SCM_CLR_PORT_OPEN_FLAG (port
);
729 if (SCM_PORT_DESCRIPTOR (port
)->flags
& SCM_PORT_TYPE_HAS_FLUSH
)
730 scm_weak_set_remove_x (scm_i_port_weak_set
, port
);
732 if (SCM_PORT_DESCRIPTOR (port
)->close
)
733 /* Note! This may throw an exception. Anything after this point
734 should be resilient to non-local exits. */
735 rv
= SCM_PORT_DESCRIPTOR (port
)->close (port
);
739 if (p
->iconv_descriptors
)
741 /* If we don't get here, the iconv_descriptors finalizer will
743 close_iconv_descriptors (p
->iconv_descriptors
);
744 p
->iconv_descriptors
= NULL
;
747 return scm_from_bool (rv
>= 0);
751 SCM_DEFINE (scm_close_input_port
, "close-input-port", 1, 0, 0,
753 "Close the specified input port object. The routine has no effect if\n"
754 "the file has already been closed. An exception may be raised if an\n"
755 "error occurs. The value returned is unspecified.\n\n"
756 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
757 "which can close file descriptors.")
758 #define FUNC_NAME s_scm_close_input_port
760 SCM_VALIDATE_INPUT_PORT (1, port
);
761 scm_close_port (port
);
762 return SCM_UNSPECIFIED
;
766 SCM_DEFINE (scm_close_output_port
, "close-output-port", 1, 0, 0,
768 "Close the specified output port object. The routine has no effect if\n"
769 "the file has already been closed. An exception may be raised if an\n"
770 "error occurs. The value returned is unspecified.\n\n"
771 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
772 "which can close file descriptors.")
773 #define FUNC_NAME s_scm_close_output_port
775 port
= SCM_COERCE_OUTPORT (port
);
776 SCM_VALIDATE_OUTPUT_PORT (1, port
);
777 scm_close_port (port
);
778 return SCM_UNSPECIFIED
;
785 /* Encoding characters to byte streams, and decoding byte streams to
788 /* A fluid specifying the default encoding for newly created ports. If it is
789 a string, that is the encoding. If it is #f, it is in the "native"
790 (Latin-1) encoding. */
791 SCM_VARIABLE (default_port_encoding_var
, "%default-port-encoding");
793 static int scm_port_encoding_init
= 0;
795 /* Use ENCODING as the default encoding for future ports. */
797 scm_i_set_default_port_encoding (const char *encoding
)
799 if (!scm_port_encoding_init
800 || !scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var
)))
801 scm_misc_error (NULL
, "tried to set port encoding fluid before it is initialized",
805 || !strcmp (encoding
, "ASCII")
806 || !strcmp (encoding
, "ANSI_X3.4-1968")
807 || !strcmp (encoding
, "ISO-8859-1"))
808 scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var
), SCM_BOOL_F
);
810 scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var
),
811 scm_from_locale_string (encoding
));
814 /* Return the name of the default encoding for newly created ports; a
815 return value of NULL means "ISO-8859-1". */
817 scm_i_default_port_encoding (void)
819 if (!scm_port_encoding_init
)
821 else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var
)))
827 encoding
= scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var
));
828 if (!scm_is_string (encoding
))
831 return scm_i_string_chars (encoding
);
836 finalize_iconv_descriptors (GC_PTR ptr
, GC_PTR data
)
838 close_iconv_descriptors (ptr
);
841 static scm_t_iconv_descriptors
*
842 open_iconv_descriptors (const char *encoding
, int reading
, int writing
)
844 scm_t_iconv_descriptors
*id
;
845 iconv_t input_cd
, output_cd
;
847 input_cd
= (iconv_t
) -1;
848 output_cd
= (iconv_t
) -1;
852 /* Open an input iconv conversion descriptor, from ENCODING
853 to UTF-8. We choose UTF-8, not UTF-32, because iconv
854 implementations can typically convert from anything to
855 UTF-8, but not to UTF-32 (see
856 <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00007.html>). */
858 /* Assume opening an iconv descriptor causes about 16 KB of
860 scm_gc_register_allocation (16 * 1024);
862 input_cd
= iconv_open ("UTF-8", encoding
);
863 if (input_cd
== (iconv_t
) -1)
864 goto invalid_encoding
;
869 /* Assume opening an iconv descriptor causes about 16 KB of
871 scm_gc_register_allocation (16 * 1024);
873 output_cd
= iconv_open (encoding
, "UTF-8");
874 if (output_cd
== (iconv_t
) -1)
876 if (input_cd
!= (iconv_t
) -1)
877 iconv_close (input_cd
);
878 goto invalid_encoding
;
882 id
= scm_gc_malloc_pointerless (sizeof (*id
), "iconv descriptors");
883 id
->input_cd
= input_cd
;
884 id
->output_cd
= output_cd
;
886 /* Register a finalizer to close the descriptors. */
887 scm_i_set_finalizer (id
, finalize_iconv_descriptors
, NULL
);
894 err
= scm_from_locale_string (encoding
);
895 scm_misc_error ("open_iconv_descriptors",
896 "invalid or unknown character encoding ~s",
902 close_iconv_descriptors (scm_t_iconv_descriptors
*id
)
904 if (id
->input_cd
!= (iconv_t
) -1)
905 iconv_close (id
->input_cd
);
906 if (id
->output_cd
!= (iconv_t
) -1)
907 iconv_close (id
->output_cd
);
908 id
->input_cd
= (void *) -1;
909 id
->output_cd
= (void *) -1;
912 scm_t_iconv_descriptors
*
913 scm_i_port_iconv_descriptors (SCM port
)
917 pt
= SCM_PTAB_ENTRY (port
);
919 assert (pt
->encoding_mode
== SCM_PORT_ENCODING_MODE_ICONV
);
921 if (!pt
->iconv_descriptors
)
924 pt
->encoding
= "ISO-8859-1";
925 pt
->iconv_descriptors
=
926 open_iconv_descriptors (pt
->encoding
,
927 SCM_INPUT_PORT_P (port
),
928 SCM_OUTPUT_PORT_P (port
));
931 return pt
->iconv_descriptors
;
935 scm_i_set_port_encoding_x (SCM port
, const char *encoding
)
938 scm_t_iconv_descriptors
*prev
;
940 /* Set the character encoding for this port. */
941 pt
= SCM_PTAB_ENTRY (port
);
942 prev
= pt
->iconv_descriptors
;
944 if (encoding
== NULL
)
945 encoding
= "ISO-8859-1";
947 if (strcmp (encoding
, "UTF-8") == 0)
949 pt
->encoding
= "UTF-8";
950 pt
->encoding_mode
= SCM_PORT_ENCODING_MODE_UTF8
;
951 pt
->iconv_descriptors
= NULL
;
955 /* Open descriptors before mutating the port. */
956 pt
->iconv_descriptors
=
957 open_iconv_descriptors (encoding
,
958 SCM_INPUT_PORT_P (port
),
959 SCM_OUTPUT_PORT_P (port
));
960 pt
->encoding
= scm_gc_strdup (encoding
, "port");
961 pt
->encoding_mode
= SCM_PORT_ENCODING_MODE_ICONV
;
965 close_iconv_descriptors (prev
);
968 SCM_DEFINE (scm_port_encoding
, "port-encoding", 1, 0, 0,
970 "Returns, as a string, the character encoding that @var{port}\n"
971 "uses to interpret its input and output.\n")
972 #define FUNC_NAME s_scm_port_encoding
977 SCM_VALIDATE_PORT (1, port
);
979 pt
= SCM_PTAB_ENTRY (port
);
982 return scm_from_locale_string (pt
->encoding
);
988 SCM_DEFINE (scm_set_port_encoding_x
, "set-port-encoding!", 2, 0, 0,
990 "Sets the character encoding that will be used to interpret all\n"
991 "port I/O. New ports are created with the encoding\n"
992 "appropriate for the current locale if @code{setlocale} has \n"
993 "been called or ISO-8859-1 otherwise\n"
994 "and this procedure can be used to modify that encoding.\n")
995 #define FUNC_NAME s_scm_set_port_encoding_x
999 SCM_VALIDATE_PORT (1, port
);
1000 SCM_VALIDATE_STRING (2, enc
);
1002 enc_str
= scm_to_locale_string (enc
);
1003 scm_i_set_port_encoding_x (port
, enc_str
);
1006 return SCM_UNSPECIFIED
;
1011 /* This determines how conversions handle unconvertible characters. */
1012 SCM_GLOBAL_VARIABLE (scm_conversion_strategy
, "%port-conversion-strategy");
1013 static int scm_conversion_strategy_init
= 0;
1015 scm_t_string_failed_conversion_handler
1016 scm_i_get_conversion_strategy (SCM port
)
1020 if (scm_is_false (port
))
1022 if (!scm_conversion_strategy_init
1023 || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy
)))
1024 return SCM_FAILED_CONVERSION_QUESTION_MARK
;
1027 encoding
= scm_fluid_ref (SCM_VARIABLE_REF (scm_conversion_strategy
));
1028 if (scm_is_false (encoding
))
1029 return SCM_FAILED_CONVERSION_QUESTION_MARK
;
1031 return (scm_t_string_failed_conversion_handler
) scm_to_int (encoding
);
1037 pt
= SCM_PTAB_ENTRY (port
);
1038 return pt
->ilseq_handler
;
1044 scm_i_set_conversion_strategy_x (SCM port
,
1045 scm_t_string_failed_conversion_handler handler
)
1050 strategy
= scm_from_int ((int) handler
);
1052 if (scm_is_false (port
))
1054 /* Set the default encoding for future ports. */
1055 if (!scm_conversion_strategy_init
1056 || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy
)))
1057 scm_misc_error (NULL
, "tried to set conversion strategy fluid before it is initialized",
1059 scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy
), strategy
);
1063 /* Set the character encoding for this port. */
1064 pt
= SCM_PTAB_ENTRY (port
);
1065 pt
->ilseq_handler
= handler
;
1069 SCM_DEFINE (scm_port_conversion_strategy
, "port-conversion-strategy",
1070 1, 0, 0, (SCM port
),
1071 "Returns the behavior of the port when handling a character that\n"
1072 "is not representable in the port's current encoding.\n"
1073 "It returns the symbol @code{error} if unrepresentable characters\n"
1074 "should cause exceptions, @code{substitute} if the port should\n"
1075 "try to replace unrepresentable characters with question marks or\n"
1076 "approximate characters, or @code{escape} if unrepresentable\n"
1077 "characters should be converted to string escapes.\n"
1079 "If @var{port} is @code{#f}, then the current default behavior\n"
1080 "will be returned. New ports will have this default behavior\n"
1081 "when they are created.\n")
1082 #define FUNC_NAME s_scm_port_conversion_strategy
1084 scm_t_string_failed_conversion_handler h
;
1086 SCM_VALIDATE_OPPORT (1, port
);
1088 if (!scm_is_false (port
))
1090 SCM_VALIDATE_OPPORT (1, port
);
1093 h
= scm_i_get_conversion_strategy (port
);
1094 if (h
== SCM_FAILED_CONVERSION_ERROR
)
1095 return scm_from_latin1_symbol ("error");
1096 else if (h
== SCM_FAILED_CONVERSION_QUESTION_MARK
)
1097 return scm_from_latin1_symbol ("substitute");
1098 else if (h
== SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE
)
1099 return scm_from_latin1_symbol ("escape");
1103 /* Never gets here. */
1104 return SCM_UNDEFINED
;
1108 SCM_DEFINE (scm_set_port_conversion_strategy_x
, "set-port-conversion-strategy!",
1110 (SCM port
, SCM sym
),
1111 "Sets the behavior of the interpreter when outputting a character\n"
1112 "that is not representable in the port's current encoding.\n"
1113 "@var{sym} can be either @code{'error}, @code{'substitute}, or\n"
1114 "@code{'escape}. If it is @code{'error}, an error will be thrown\n"
1115 "when an unconvertible character is encountered. If it is\n"
1116 "@code{'substitute}, then unconvertible characters will \n"
1117 "be replaced with approximate characters, or with question marks\n"
1118 "if no approximately correct character is available.\n"
1119 "If it is @code{'escape},\n"
1120 "it will appear as a hex escape when output.\n"
1122 "If @var{port} is an open port, the conversion error behavior\n"
1123 "is set for that port. If it is @code{#f}, it is set as the\n"
1124 "default behavior for any future ports that get created in\n"
1126 #define FUNC_NAME s_scm_set_port_conversion_strategy_x
1132 if (!scm_is_false (port
))
1134 SCM_VALIDATE_OPPORT (1, port
);
1137 err
= scm_from_latin1_symbol ("error");
1138 if (scm_is_true (scm_eqv_p (sym
, err
)))
1140 scm_i_set_conversion_strategy_x (port
, SCM_FAILED_CONVERSION_ERROR
);
1141 return SCM_UNSPECIFIED
;
1144 qm
= scm_from_latin1_symbol ("substitute");
1145 if (scm_is_true (scm_eqv_p (sym
, qm
)))
1147 scm_i_set_conversion_strategy_x (port
,
1148 SCM_FAILED_CONVERSION_QUESTION_MARK
);
1149 return SCM_UNSPECIFIED
;
1152 esc
= scm_from_latin1_symbol ("escape");
1153 if (scm_is_true (scm_eqv_p (sym
, esc
)))
1155 scm_i_set_conversion_strategy_x (port
,
1156 SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE
);
1157 return SCM_UNSPECIFIED
;
1160 SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym
));
1162 return SCM_UNSPECIFIED
;
1169 /* The port lock. */
1172 lock_port (void *mutex
)
1174 scm_i_pthread_mutex_lock (mutex
);
1178 unlock_port (void *mutex
)
1180 scm_i_pthread_mutex_unlock (mutex
);
1184 scm_dynwind_lock_port (SCM port
)
1185 #define FUNC_NAME "dynwind-lock-port"
1187 scm_i_pthread_mutex_t
*lock
;
1188 SCM_VALIDATE_OPPORT (SCM_ARG1
, port
);
1189 scm_c_lock_port (port
, &lock
);
1192 scm_dynwind_unwind_handler (unlock_port
, lock
, SCM_F_WIND_EXPLICITLY
);
1193 scm_dynwind_rewind_handler (lock_port
, lock
, 0);
1204 scm_get_byte_or_eof (SCM port
)
1206 scm_i_pthread_mutex_t
*lock
;
1209 scm_c_lock_port (port
, &lock
);
1210 ret
= scm_get_byte_or_eof_unlocked (port
);
1212 scm_i_pthread_mutex_unlock (lock
);
1218 scm_peek_byte_or_eof (SCM port
)
1220 scm_i_pthread_mutex_t
*lock
;
1223 scm_c_lock_port (port
, &lock
);
1224 ret
= scm_peek_byte_or_eof_unlocked (port
);
1226 scm_i_pthread_mutex_unlock (lock
);
1233 * Used by an application to read arbitrary number of bytes from an
1234 * SCM port. Same semantics as libc read, except that scm_c_read only
1235 * returns less than SIZE bytes if at end-of-file.
1237 * Warning: Doesn't update port line and column counts! */
1239 /* This structure, and the following swap_buffer function, are used
1240 for temporarily swapping a port's own read buffer, and the buffer
1241 that the caller of scm_c_read provides. */
1242 struct port_and_swap_buffer
1245 unsigned char *buffer
;
1250 swap_buffer (void *data
)
1252 struct port_and_swap_buffer
*psb
= (struct port_and_swap_buffer
*) data
;
1253 unsigned char *old_buf
= psb
->pt
->read_buf
;
1254 size_t old_size
= psb
->pt
->read_buf_size
;
1256 /* Make the port use (buffer, size) from the struct. */
1257 psb
->pt
->read_pos
= psb
->pt
->read_buf
= psb
->pt
->read_end
= psb
->buffer
;
1258 psb
->pt
->read_buf_size
= psb
->size
;
1260 /* Save the port's old (buffer, size) in the struct. */
1261 psb
->buffer
= old_buf
;
1262 psb
->size
= old_size
;
1266 scm_c_read_unlocked (SCM port
, void *buffer
, size_t size
)
1267 #define FUNC_NAME "scm_c_read"
1270 size_t n_read
= 0, n_available
;
1271 struct port_and_swap_buffer psb
;
1273 SCM_VALIDATE_OPINPORT (1, port
);
1275 pt
= SCM_PTAB_ENTRY (port
);
1276 if (pt
->rw_active
== SCM_PORT_WRITE
)
1277 SCM_PORT_DESCRIPTOR (port
)->flush (port
);
1280 pt
->rw_active
= SCM_PORT_READ
;
1282 /* Take bytes first from the port's read buffer. */
1283 if (pt
->read_pos
< pt
->read_end
)
1285 n_available
= min (size
, pt
->read_end
- pt
->read_pos
);
1286 memcpy (buffer
, pt
->read_pos
, n_available
);
1287 buffer
= (char *) buffer
+ n_available
;
1288 pt
->read_pos
+= n_available
;
1289 n_read
+= n_available
;
1290 size
-= n_available
;
1293 /* Avoid the scm_dynwind_* costs if we now have enough data. */
1297 /* Now we will call scm_fill_input repeatedly until we have read the
1298 requested number of bytes. (Note that a single scm_fill_input
1299 call does not guarantee to fill the whole of the port's read
1301 if (pt
->read_buf_size
<= 1 && pt
->encoding
== NULL
)
1303 /* The port that we are reading from is unbuffered - i.e. does
1304 not have its own persistent buffer - but we have a buffer,
1305 provided by our caller, that is the right size for the data
1306 that is wanted. For the following scm_fill_input calls,
1307 therefore, we use the buffer in hand as the port's read
1310 We need to make sure that the port's normal (1 byte) buffer
1311 is reinstated in case one of the scm_fill_input () calls
1312 throws an exception; we use the scm_dynwind_* API to achieve
1315 A consequence of this optimization is that the fill_input
1316 functions can't unget characters. That'll push data to the
1317 pushback buffer instead of this psb buffer. */
1319 unsigned char *pback
= pt
->putback_buf
;
1322 psb
.buffer
= buffer
;
1324 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1325 scm_dynwind_rewind_handler (swap_buffer
, &psb
, SCM_F_WIND_EXPLICITLY
);
1326 scm_dynwind_unwind_handler (swap_buffer
, &psb
, SCM_F_WIND_EXPLICITLY
);
1328 /* Call scm_fill_input until we have all the bytes that we need,
1330 while (pt
->read_buf_size
&& (scm_fill_input_unlocked (port
) != EOF
))
1332 pt
->read_buf_size
-= (pt
->read_end
- pt
->read_pos
);
1333 pt
->read_pos
= pt
->read_buf
= pt
->read_end
;
1336 if (pback
!= pt
->putback_buf
1337 || pt
->read_buf
- (unsigned char *) buffer
< 0)
1338 scm_misc_error (FUNC_NAME
,
1339 "scm_c_read must not call a fill function that pushes "
1340 "back characters onto an unbuffered port", SCM_EOL
);
1342 n_read
+= pt
->read_buf
- (unsigned char *) buffer
;
1344 /* Reinstate the port's normal buffer. */
1349 /* The port has its own buffer. It is important that we use it,
1350 even if it happens to be smaller than our caller's buffer, so
1351 that a custom port implementation's entry points (in
1352 particular, fill_input) can rely on the buffer always being
1353 the same as they first set up. */
1354 while (size
&& (scm_fill_input_unlocked (port
) != EOF
))
1356 n_available
= min (size
, pt
->read_end
- pt
->read_pos
);
1357 memcpy (buffer
, pt
->read_pos
, n_available
);
1358 buffer
= (char *) buffer
+ n_available
;
1359 pt
->read_pos
+= n_available
;
1360 n_read
+= n_available
;
1361 size
-= n_available
;
1370 scm_c_read (SCM port
, void *buffer
, size_t size
)
1372 scm_i_pthread_mutex_t
*lock
;
1375 scm_c_lock_port (port
, &lock
);
1376 ret
= scm_c_read_unlocked (port
, buffer
, size
);
1378 scm_i_pthread_mutex_unlock (lock
);
1384 /* Update the line and column number of PORT after consumption of C. */
1386 update_port_lf (scm_t_wchar c
, SCM port
)
1411 #define SCM_MBCHAR_BUF_SIZE (4)
1413 /* Convert the SIZE-byte UTF-8 sequence in UTF8_BUF to a codepoint.
1414 UTF8_BUF is assumed to contain a valid UTF-8 sequence. */
1416 utf8_to_codepoint (const scm_t_uint8
*utf8_buf
, size_t size
)
1418 scm_t_wchar codepoint
;
1420 if (utf8_buf
[0] <= 0x7f)
1423 codepoint
= utf8_buf
[0];
1425 else if ((utf8_buf
[0] & 0xe0) == 0xc0)
1428 codepoint
= ((scm_t_wchar
) utf8_buf
[0] & 0x1f) << 6UL
1429 | (utf8_buf
[1] & 0x3f);
1431 else if ((utf8_buf
[0] & 0xf0) == 0xe0)
1434 codepoint
= ((scm_t_wchar
) utf8_buf
[0] & 0x0f) << 12UL
1435 | ((scm_t_wchar
) utf8_buf
[1] & 0x3f) << 6UL
1436 | (utf8_buf
[2] & 0x3f);
1441 codepoint
= ((scm_t_wchar
) utf8_buf
[0] & 0x07) << 18UL
1442 | ((scm_t_wchar
) utf8_buf
[1] & 0x3f) << 12UL
1443 | ((scm_t_wchar
) utf8_buf
[2] & 0x3f) << 6UL
1444 | (utf8_buf
[3] & 0x3f);
1450 /* Read a UTF-8 sequence from PORT. On success, return 0 and set
1451 *CODEPOINT to the codepoint that was read, fill BUF with its UTF-8
1452 representation, and set *LEN to the length in bytes. Return
1453 `EILSEQ' on error. */
1455 get_utf8_codepoint (SCM port
, scm_t_wchar
*codepoint
,
1456 scm_t_uint8 buf
[SCM_MBCHAR_BUF_SIZE
], size_t *len
)
1458 #define ASSERT_NOT_EOF(b) \
1459 if (SCM_UNLIKELY ((b) == EOF)) \
1461 #define CONSUME_PEEKED_BYTE() \
1468 pt
= SCM_PTAB_ENTRY (port
);
1470 byte
= scm_get_byte_or_eof_unlocked (port
);
1477 buf
[0] = (scm_t_uint8
) byte
;
1482 *codepoint
= buf
[0];
1483 else if (buf
[0] >= 0xc2 && buf
[0] <= 0xdf)
1486 byte
= scm_peek_byte_or_eof_unlocked (port
);
1487 ASSERT_NOT_EOF (byte
);
1489 if (SCM_UNLIKELY ((byte
& 0xc0) != 0x80))
1492 CONSUME_PEEKED_BYTE ();
1493 buf
[1] = (scm_t_uint8
) byte
;
1496 *codepoint
= ((scm_t_wchar
) buf
[0] & 0x1f) << 6UL
1499 else if ((buf
[0] & 0xf0) == 0xe0)
1502 byte
= scm_peek_byte_or_eof_unlocked (port
);
1503 ASSERT_NOT_EOF (byte
);
1505 if (SCM_UNLIKELY ((byte
& 0xc0) != 0x80
1506 || (buf
[0] == 0xe0 && byte
< 0xa0)
1507 || (buf
[0] == 0xed && byte
> 0x9f)))
1510 CONSUME_PEEKED_BYTE ();
1511 buf
[1] = (scm_t_uint8
) byte
;
1514 byte
= scm_peek_byte_or_eof_unlocked (port
);
1515 ASSERT_NOT_EOF (byte
);
1517 if (SCM_UNLIKELY ((byte
& 0xc0) != 0x80))
1520 CONSUME_PEEKED_BYTE ();
1521 buf
[2] = (scm_t_uint8
) byte
;
1524 *codepoint
= ((scm_t_wchar
) buf
[0] & 0x0f) << 12UL
1525 | ((scm_t_wchar
) buf
[1] & 0x3f) << 6UL
1528 else if (buf
[0] >= 0xf0 && buf
[0] <= 0xf4)
1531 byte
= scm_peek_byte_or_eof_unlocked (port
);
1532 ASSERT_NOT_EOF (byte
);
1534 if (SCM_UNLIKELY (((byte
& 0xc0) != 0x80)
1535 || (buf
[0] == 0xf0 && byte
< 0x90)
1536 || (buf
[0] == 0xf4 && byte
> 0x8f)))
1539 CONSUME_PEEKED_BYTE ();
1540 buf
[1] = (scm_t_uint8
) byte
;
1543 byte
= scm_peek_byte_or_eof_unlocked (port
);
1544 ASSERT_NOT_EOF (byte
);
1546 if (SCM_UNLIKELY ((byte
& 0xc0) != 0x80))
1549 CONSUME_PEEKED_BYTE ();
1550 buf
[2] = (scm_t_uint8
) byte
;
1553 byte
= scm_peek_byte_or_eof_unlocked (port
);
1554 ASSERT_NOT_EOF (byte
);
1556 if (SCM_UNLIKELY ((byte
& 0xc0) != 0x80))
1559 CONSUME_PEEKED_BYTE ();
1560 buf
[3] = (scm_t_uint8
) byte
;
1563 *codepoint
= ((scm_t_wchar
) buf
[0] & 0x07) << 18UL
1564 | ((scm_t_wchar
) buf
[1] & 0x3f) << 12UL
1565 | ((scm_t_wchar
) buf
[2] & 0x3f) << 6UL
1574 /* Here we could choose the consume the faulty byte when it's not a
1575 valid starting byte, but it's not a requirement. What Section 3.9
1576 of Unicode 6.0.0 mandates, though, is to not consume a byte that
1577 would otherwise be a valid starting byte. */
1581 #undef CONSUME_PEEKED_BYTE
1582 #undef ASSERT_NOT_EOF
1585 /* Likewise, read a byte sequence from PORT, passing it through its
1586 input conversion descriptor. */
1588 get_iconv_codepoint (SCM port
, scm_t_wchar
*codepoint
,
1589 char buf
[SCM_MBCHAR_BUF_SIZE
], size_t *len
)
1591 scm_t_iconv_descriptors
*id
;
1593 size_t bytes_consumed
, output_size
;
1595 scm_t_uint8 utf8_buf
[SCM_MBCHAR_BUF_SIZE
];
1597 id
= scm_i_port_iconv_descriptors (port
);
1599 for (output_size
= 0, output
= (char *) utf8_buf
,
1600 bytes_consumed
= 0, err
= 0;
1601 err
== 0 && output_size
== 0
1602 && (bytes_consumed
== 0 || byte_read
!= EOF
);
1606 size_t input_left
, output_left
, done
;
1608 byte_read
= scm_get_byte_or_eof_unlocked (port
);
1609 if (byte_read
== EOF
)
1611 if (bytes_consumed
== 0)
1613 *codepoint
= (scm_t_wchar
) EOF
;
1621 buf
[bytes_consumed
] = byte_read
;
1624 input_left
= bytes_consumed
+ 1;
1625 output_left
= sizeof (utf8_buf
);
1627 done
= iconv (id
->input_cd
, &input
, &input_left
, &output
, &output_left
);
1628 if (done
== (size_t) -1)
1632 /* Missing input: keep trying. */
1636 output_size
= sizeof (utf8_buf
) - output_left
;
1639 if (SCM_UNLIKELY (output_size
== 0))
1640 /* An unterminated sequence. */
1642 else if (SCM_LIKELY (err
== 0))
1644 /* Convert the UTF8_BUF sequence to a Unicode code point. */
1645 *codepoint
= utf8_to_codepoint (utf8_buf
, output_size
);
1646 *len
= bytes_consumed
;
1652 /* Read a codepoint from PORT and return it in *CODEPOINT. Fill BUF
1653 with the byte representation of the codepoint in PORT's encoding, and
1654 set *LEN to the length in bytes of that representation. Return 0 on
1655 success and an errno value on error. */
1657 get_codepoint (SCM port
, scm_t_wchar
*codepoint
,
1658 char buf
[SCM_MBCHAR_BUF_SIZE
], size_t *len
)
1661 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1663 if (pt
->encoding_mode
== SCM_PORT_ENCODING_MODE_UTF8
)
1664 err
= get_utf8_codepoint (port
, codepoint
, (scm_t_uint8
*) buf
, len
);
1666 err
= get_iconv_codepoint (port
, codepoint
, buf
, len
);
1668 if (SCM_LIKELY (err
== 0))
1669 update_port_lf (*codepoint
, port
);
1670 else if (pt
->ilseq_handler
== SCM_ICONVEH_QUESTION_MARK
)
1674 update_port_lf (*codepoint
, port
);
1680 /* Read a codepoint from PORT and return it. */
1682 scm_getc_unlocked (SCM port
)
1683 #define FUNC_NAME "scm_getc"
1687 scm_t_wchar codepoint
;
1688 char buf
[SCM_MBCHAR_BUF_SIZE
];
1690 err
= get_codepoint (port
, &codepoint
, buf
, &len
);
1691 if (SCM_UNLIKELY (err
!= 0))
1692 /* At this point PORT should point past the invalid encoding, as per
1693 R6RS-lib Section 8.2.4. */
1694 scm_decoding_error (FUNC_NAME
, err
, "input decoding error", port
);
1703 scm_i_pthread_mutex_t
*lock
;
1706 scm_c_lock_port (port
, &lock
);
1707 ret
= scm_getc_unlocked (port
);
1709 scm_i_pthread_mutex_unlock (lock
);
1715 SCM_DEFINE (scm_read_char
, "read-char", 0, 1, 0,
1717 "Return the next character available from @var{port}, updating\n"
1718 "@var{port} to point to the following character. If no more\n"
1719 "characters are available, the end-of-file object is returned.\n"
1721 "When @var{port}'s data cannot be decoded according to its\n"
1722 "character encoding, a @code{decoding-error} is raised and\n"
1723 "@var{port} points past the erroneous byte sequence.\n")
1724 #define FUNC_NAME s_scm_read_char
1727 if (SCM_UNBNDP (port
))
1728 port
= scm_current_input_port ();
1729 SCM_VALIDATE_OPINPORT (1, port
);
1730 c
= scm_getc_unlocked (port
);
1733 return SCM_MAKE_CHAR (c
);
1743 scm_unget_byte_unlocked (int c
, SCM port
)
1744 #define FUNC_NAME "scm_unget_byte"
1746 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1748 if (pt
->read_buf
== pt
->putback_buf
)
1749 /* already using the put-back buffer. */
1751 /* enlarge putback_buf if necessary. */
1752 if (pt
->read_end
== pt
->read_buf
+ pt
->read_buf_size
1753 && pt
->read_buf
== pt
->read_pos
)
1755 size_t new_size
= pt
->read_buf_size
* 2;
1756 unsigned char *tmp
= (unsigned char *)
1757 scm_gc_realloc (pt
->putback_buf
, pt
->read_buf_size
, new_size
,
1760 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
= tmp
;
1761 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
1762 pt
->read_buf_size
= pt
->putback_buf_size
= new_size
;
1765 /* shift any existing bytes to buffer + 1. */
1766 if (pt
->read_pos
== pt
->read_end
)
1767 pt
->read_end
= pt
->read_buf
+ 1;
1768 else if (pt
->read_pos
!= pt
->read_buf
+ 1)
1770 int count
= pt
->read_end
- pt
->read_pos
;
1772 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
1773 pt
->read_end
= pt
->read_buf
+ 1 + count
;
1776 pt
->read_pos
= pt
->read_buf
;
1779 /* switch to the put-back buffer. */
1781 if (pt
->putback_buf
== NULL
)
1784 = (unsigned char *) scm_gc_malloc_pointerless
1785 (SCM_INITIAL_PUTBACK_BUF_SIZE
, "putback buffer");
1786 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
1789 pt
->saved_read_buf
= pt
->read_buf
;
1790 pt
->saved_read_pos
= pt
->read_pos
;
1791 pt
->saved_read_end
= pt
->read_end
;
1792 pt
->saved_read_buf_size
= pt
->read_buf_size
;
1794 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
1795 pt
->read_end
= pt
->read_buf
+ 1;
1796 pt
->read_buf_size
= pt
->putback_buf_size
;
1802 pt
->rw_active
= SCM_PORT_READ
;
1807 scm_unget_byte (int c
, SCM port
)
1809 scm_i_pthread_mutex_t
*lock
;
1810 scm_c_lock_port (port
, &lock
);
1811 scm_unget_byte_unlocked (c
, port
);
1813 scm_i_pthread_mutex_unlock (lock
);
1818 scm_ungetc_unlocked (scm_t_wchar c
, SCM port
)
1819 #define FUNC_NAME "scm_ungetc"
1821 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1823 char result_buf
[10];
1824 const char *encoding
;
1828 if (pt
->encoding
!= NULL
)
1829 encoding
= pt
->encoding
;
1831 encoding
= "ISO-8859-1";
1833 len
= sizeof (result_buf
);
1834 result
= u32_conv_to_encoding (encoding
,
1835 (enum iconv_ilseq_handler
) pt
->ilseq_handler
,
1836 (uint32_t *) &c
, 1, NULL
,
1839 if (SCM_UNLIKELY (result
== NULL
|| len
== 0))
1840 scm_encoding_error (FUNC_NAME
, errno
,
1841 "conversion to port encoding failed",
1842 SCM_BOOL_F
, SCM_MAKE_CHAR (c
));
1844 for (i
= len
- 1; i
>= 0; i
--)
1845 scm_unget_byte_unlocked (result
[i
], port
);
1847 if (SCM_UNLIKELY (result
!= result_buf
))
1852 /* What should col be in this case?
1853 * We'll leave it at -1.
1855 SCM_LINUM (port
) -= 1;
1863 scm_ungetc (scm_t_wchar c
, SCM port
)
1865 scm_i_pthread_mutex_t
*lock
;
1866 scm_c_lock_port (port
, &lock
);
1867 scm_ungetc_unlocked (c
, port
);
1869 scm_i_pthread_mutex_unlock (lock
);
1874 scm_ungets_unlocked (const char *s
, int n
, SCM port
)
1876 /* This is simple minded and inefficient, but unreading strings is
1877 * probably not a common operation, and remember that line and
1878 * column numbers have to be handled...
1880 * Please feel free to write an optimized version!
1883 scm_ungetc_unlocked (s
[n
], port
);
1887 scm_ungets (const char *s
, int n
, SCM port
)
1889 scm_i_pthread_mutex_t
*lock
;
1890 scm_c_lock_port (port
, &lock
);
1891 scm_ungets_unlocked (s
, n
, port
);
1893 scm_i_pthread_mutex_unlock (lock
);
1897 SCM_DEFINE (scm_peek_char
, "peek-char", 0, 1, 0,
1899 "Return the next character available from @var{port},\n"
1900 "@emph{without} updating @var{port} to point to the following\n"
1901 "character. If no more characters are available, the\n"
1902 "end-of-file object is returned.\n"
1904 "The value returned by\n"
1905 "a call to @code{peek-char} is the same as the value that would\n"
1906 "have been returned by a call to @code{read-char} on the same\n"
1907 "port. The only difference is that the very next call to\n"
1908 "@code{read-char} or @code{peek-char} on that @var{port} will\n"
1909 "return the value returned by the preceding call to\n"
1910 "@code{peek-char}. In particular, a call to @code{peek-char} on\n"
1911 "an interactive port will hang waiting for input whenever a call\n"
1912 "to @code{read-char} would have hung.\n"
1914 "As for @code{read-char}, a @code{decoding-error} may be raised\n"
1915 "if such a situation occurs. However, unlike with @code{read-char},\n"
1916 "@var{port} still points at the beginning of the erroneous byte\n"
1917 "sequence when the error is raised.\n")
1918 #define FUNC_NAME s_scm_peek_char
1923 char bytes
[SCM_MBCHAR_BUF_SIZE
];
1924 long column
, line
, i
;
1927 if (SCM_UNBNDP (port
))
1928 port
= scm_current_input_port ();
1929 SCM_VALIDATE_OPINPORT (1, port
);
1931 column
= SCM_COL (port
);
1932 line
= SCM_LINUM (port
);
1934 err
= get_codepoint (port
, &c
, bytes
, &len
);
1936 for (i
= len
- 1; i
>= 0; i
--)
1937 scm_unget_byte_unlocked (bytes
[i
], port
);
1939 SCM_COL (port
) = column
;
1940 SCM_LINUM (port
) = line
;
1942 if (SCM_UNLIKELY (err
!= 0))
1944 scm_decoding_error (FUNC_NAME
, err
, "input decoding error", port
);
1946 /* Shouldn't happen since `catch' always aborts to prompt. */
1947 result
= SCM_BOOL_F
;
1950 result
= SCM_EOF_VAL
;
1952 result
= SCM_MAKE_CHAR (c
);
1958 SCM_DEFINE (scm_unread_char
, "unread-char", 1, 1, 0,
1959 (SCM cobj
, SCM port
),
1960 "Place character @var{cobj} in @var{port} so that it will be\n"
1961 "read by the next read operation. If called multiple times, the\n"
1962 "unread characters will be read again in last-in first-out\n"
1963 "order. If @var{port} is not supplied, the current input port\n"
1965 #define FUNC_NAME s_scm_unread_char
1969 SCM_VALIDATE_CHAR (1, cobj
);
1970 if (SCM_UNBNDP (port
))
1971 port
= scm_current_input_port ();
1972 SCM_VALIDATE_OPINPORT (2, port
);
1974 c
= SCM_CHAR (cobj
);
1976 scm_ungetc_unlocked (c
, port
);
1981 SCM_DEFINE (scm_unread_string
, "unread-string", 2, 0, 0,
1982 (SCM str
, SCM port
),
1983 "Place the string @var{str} in @var{port} so that its characters will be\n"
1984 "read in subsequent read operations. If called multiple times, the\n"
1985 "unread characters will be read again in last-in first-out order. If\n"
1986 "@var{port} is not supplied, the current-input-port is used.")
1987 #define FUNC_NAME s_scm_unread_string
1990 SCM_VALIDATE_STRING (1, str
);
1991 if (SCM_UNBNDP (port
))
1992 port
= scm_current_input_port ();
1993 SCM_VALIDATE_OPINPORT (2, port
);
1995 n
= scm_i_string_length (str
);
1998 scm_ungetc_unlocked (scm_i_string_ref (str
, n
), port
);
2007 /* Manipulating the buffers. */
2009 /* This routine does not take any locks, as it is usually called as part
2010 of a port implementation. */
2012 scm_port_non_buffer (scm_t_port
*pt
)
2014 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
2015 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
2016 pt
->read_buf_size
= pt
->write_buf_size
= 1;
2017 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
2020 /* this should only be called when the read buffer is empty. it
2021 tries to refill the read buffer. it returns the first char from
2022 the port, which is either EOF or *(pt->read_pos). */
2024 scm_fill_input_unlocked (SCM port
)
2026 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2028 assert (pt
->read_pos
== pt
->read_end
);
2030 if (pt
->read_buf
== pt
->putback_buf
)
2032 /* finished reading put-back chars. */
2033 pt
->read_buf
= pt
->saved_read_buf
;
2034 pt
->read_pos
= pt
->saved_read_pos
;
2035 pt
->read_end
= pt
->saved_read_end
;
2036 pt
->read_buf_size
= pt
->saved_read_buf_size
;
2037 if (pt
->read_pos
< pt
->read_end
)
2038 return *(pt
->read_pos
);
2040 return SCM_PORT_DESCRIPTOR (port
)->fill_input (port
);
2044 scm_fill_input (SCM port
)
2046 scm_i_pthread_mutex_t
*lock
;
2049 scm_c_lock_port (port
, &lock
);
2050 ret
= scm_fill_input_unlocked (port
);
2052 scm_i_pthread_mutex_unlock (lock
);
2058 /* move up to read_len chars from port's putback and/or read buffers
2059 into memory starting at dest. returns the number of chars moved. */
2061 scm_take_from_input_buffers (SCM port
, char *dest
, size_t read_len
)
2063 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2064 size_t chars_read
= 0;
2065 size_t from_buf
= min (pt
->read_end
- pt
->read_pos
, read_len
);
2069 memcpy (dest
, pt
->read_pos
, from_buf
);
2070 pt
->read_pos
+= from_buf
;
2071 chars_read
+= from_buf
;
2072 read_len
-= from_buf
;
2076 /* if putback was active, try the real input buffer too. */
2077 if (pt
->read_buf
== pt
->putback_buf
)
2079 from_buf
= min (pt
->saved_read_end
- pt
->saved_read_pos
, read_len
);
2082 memcpy (dest
, pt
->saved_read_pos
, from_buf
);
2083 pt
->saved_read_pos
+= from_buf
;
2084 chars_read
+= from_buf
;
2090 /* Clear a port's read buffers, returning the contents. */
2091 SCM_DEFINE (scm_drain_input
, "drain-input", 1, 0, 0,
2093 "This procedure clears a port's input buffers, similar\n"
2094 "to the way that force-output clears the output buffer. The\n"
2095 "contents of the buffers are returned as a single string, e.g.,\n"
2098 "(define p (open-input-file ...))\n"
2099 "(drain-input p) => empty string, nothing buffered yet.\n"
2100 "(unread-char (read-char p) p)\n"
2101 "(drain-input p) => initial chars from p, up to the buffer size.\n"
2103 "Draining the buffers may be useful for cleanly finishing\n"
2104 "buffered I/O so that the file descriptor can be used directly\n"
2105 "for further input.")
2106 #define FUNC_NAME s_scm_drain_input
2113 SCM_VALIDATE_OPINPORT (1, port
);
2114 pt
= SCM_PTAB_ENTRY (port
);
2116 count
= pt
->read_end
- pt
->read_pos
;
2117 if (pt
->read_buf
== pt
->putback_buf
)
2118 count
+= pt
->saved_read_end
- pt
->saved_read_pos
;
2122 result
= scm_i_make_string (count
, &data
, 0);
2123 scm_take_from_input_buffers (port
, data
, count
);
2126 result
= scm_nullstr
;
2133 scm_end_input_unlocked (SCM port
)
2136 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2138 if (pt
->read_buf
== pt
->putback_buf
)
2140 offset
= pt
->read_end
- pt
->read_pos
;
2141 pt
->read_buf
= pt
->saved_read_buf
;
2142 pt
->read_pos
= pt
->saved_read_pos
;
2143 pt
->read_end
= pt
->saved_read_end
;
2144 pt
->read_buf_size
= pt
->saved_read_buf_size
;
2149 SCM_PORT_DESCRIPTOR (port
)->end_input (port
, offset
);
2153 scm_end_input (SCM port
)
2155 scm_i_pthread_mutex_t
*lock
;
2156 scm_c_lock_port (port
, &lock
);
2157 scm_end_input_unlocked (port
);
2159 scm_i_pthread_mutex_unlock (lock
);
2163 SCM_DEFINE (scm_force_output
, "force-output", 0, 1, 0,
2165 "Flush the specified output port, or the current output port if @var{port}\n"
2166 "is omitted. The current output buffer contents are passed to the\n"
2167 "underlying port implementation (e.g., in the case of fports, the\n"
2168 "data will be written to the file and the output buffer will be cleared.)\n"
2169 "It has no effect on an unbuffered port.\n\n"
2170 "The return value is unspecified.")
2171 #define FUNC_NAME s_scm_force_output
2173 if (SCM_UNBNDP (port
))
2174 port
= scm_current_output_port ();
2177 port
= SCM_COERCE_OUTPORT (port
);
2178 SCM_VALIDATE_OPOUTPORT (1, port
);
2180 scm_flush_unlocked (port
);
2181 return SCM_UNSPECIFIED
;
2186 scm_flush_unlocked (SCM port
)
2188 SCM_PORT_DESCRIPTOR (port
)->flush (port
);
2192 scm_flush (SCM port
)
2194 scm_i_pthread_mutex_t
*lock
;
2195 scm_c_lock_port (port
, &lock
);
2196 scm_flush_unlocked (port
);
2198 scm_i_pthread_mutex_unlock (lock
);
2208 scm_putc (char c
, SCM port
)
2210 scm_i_pthread_mutex_t
*lock
;
2211 scm_c_lock_port (port
, &lock
);
2212 scm_putc_unlocked (c
, port
);
2214 scm_i_pthread_mutex_unlock (lock
);
2219 scm_puts (const char *s
, SCM port
)
2221 scm_i_pthread_mutex_t
*lock
;
2222 scm_c_lock_port (port
, &lock
);
2223 scm_puts_unlocked (s
, port
);
2225 scm_i_pthread_mutex_unlock (lock
);
2231 * Used by an application to write arbitrary number of bytes to an SCM
2232 * port. Similar semantics as libc write. However, unlike libc
2233 * write, scm_c_write writes the requested number of bytes and has no
2236 * Warning: Doesn't update port line and column counts!
2239 scm_c_write_unlocked (SCM port
, const void *ptr
, size_t size
)
2240 #define FUNC_NAME "scm_c_write"
2243 scm_t_ptob_descriptor
*ptob
;
2245 SCM_VALIDATE_OPOUTPORT (1, port
);
2247 pt
= SCM_PTAB_ENTRY (port
);
2248 ptob
= SCM_PORT_DESCRIPTOR (port
);
2250 if (pt
->rw_active
== SCM_PORT_READ
)
2251 scm_end_input_unlocked (port
);
2253 ptob
->write (port
, ptr
, size
);
2256 pt
->rw_active
= SCM_PORT_WRITE
;
2261 scm_c_write (SCM port
, const void *ptr
, size_t size
)
2263 scm_i_pthread_mutex_t
*lock
;
2264 scm_c_lock_port (port
, &lock
);
2265 scm_c_write_unlocked (port
, ptr
, size
);
2267 scm_i_pthread_mutex_unlock (lock
);
2273 * This function differs from scm_c_write; it updates port line and
2276 scm_lfwrite_unlocked (const char *ptr
, size_t size
, SCM port
)
2278 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2279 scm_t_ptob_descriptor
*ptob
= SCM_PORT_DESCRIPTOR (port
);
2281 if (pt
->rw_active
== SCM_PORT_READ
)
2282 scm_end_input_unlocked (port
);
2284 ptob
->write (port
, ptr
, size
);
2286 for (; size
; ptr
++, size
--)
2287 update_port_lf ((scm_t_wchar
) (unsigned char) *ptr
, port
);
2290 pt
->rw_active
= SCM_PORT_WRITE
;
2294 scm_lfwrite (const char *ptr
, size_t size
, SCM port
)
2296 scm_i_pthread_mutex_t
*lock
;
2297 scm_c_lock_port (port
, &lock
);
2298 scm_lfwrite_unlocked (ptr
, size
, port
);
2300 scm_i_pthread_mutex_unlock (lock
);
2304 /* Write STR to PORT from START inclusive to END exclusive. */
2306 scm_lfwrite_substr (SCM str
, size_t start
, size_t end
, SCM port
)
2308 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
2310 if (pt
->rw_active
== SCM_PORT_READ
)
2311 scm_end_input_unlocked (port
);
2313 if (end
== (size_t) -1)
2314 end
= scm_i_string_length (str
);
2316 scm_display (scm_c_substring (str
, start
, end
), port
);
2319 pt
->rw_active
= SCM_PORT_WRITE
;
2325 /* Querying and setting positions, and character availability. */
2327 SCM_DEFINE (scm_char_ready_p
, "char-ready?", 0, 1, 0,
2329 "Return @code{#t} if a character is ready on input @var{port}\n"
2330 "and return @code{#f} otherwise. If @code{char-ready?} returns\n"
2331 "@code{#t} then the next @code{read-char} operation on\n"
2332 "@var{port} is guaranteed not to hang. If @var{port} is a file\n"
2333 "port at end of file then @code{char-ready?} returns @code{#t}.\n"
2335 "@code{char-ready?} exists to make it possible for a\n"
2336 "program to accept characters from interactive ports without\n"
2337 "getting stuck waiting for input. Any input editors associated\n"
2338 "with such ports must make sure that characters whose existence\n"
2339 "has been asserted by @code{char-ready?} cannot be rubbed out.\n"
2340 "If @code{char-ready?} were to return @code{#f} at end of file,\n"
2341 "a port at end of file would be indistinguishable from an\n"
2342 "interactive port that has no ready characters.")
2343 #define FUNC_NAME s_scm_char_ready_p
2347 if (SCM_UNBNDP (port
))
2348 port
= scm_current_input_port ();
2349 /* It's possible to close the current input port, so validate even in
2351 SCM_VALIDATE_OPINPORT (1, port
);
2353 pt
= SCM_PTAB_ENTRY (port
);
2355 /* if the current read buffer is filled, or the
2356 last pushed-back char has been read and the saved buffer is
2357 filled, result is true. */
2358 if (pt
->read_pos
< pt
->read_end
2359 || (pt
->read_buf
== pt
->putback_buf
2360 && pt
->saved_read_pos
< pt
->saved_read_end
))
2364 scm_t_ptob_descriptor
*ptob
= SCM_PORT_DESCRIPTOR (port
);
2366 if (ptob
->input_waiting
)
2367 return scm_from_bool(ptob
->input_waiting (port
));
2374 SCM_DEFINE (scm_seek
, "seek", 3, 0, 0,
2375 (SCM fd_port
, SCM offset
, SCM whence
),
2376 "Sets the current position of @var{fd_port} to the integer\n"
2377 "@var{offset}, which is interpreted according to the value of\n"
2380 "One of the following variables should be supplied for\n"
2382 "@defvar SEEK_SET\n"
2383 "Seek from the beginning of the file.\n"
2385 "@defvar SEEK_CUR\n"
2386 "Seek from the current position.\n"
2388 "@defvar SEEK_END\n"
2389 "Seek from the end of the file.\n"
2391 "If @var{fd_port} is a file descriptor, the underlying system\n"
2392 "call is @code{lseek}. @var{port} may be a string port.\n"
2394 "The value returned is the new position in the file. This means\n"
2395 "that the current position of a port can be obtained using:\n"
2397 "(seek port 0 SEEK_CUR)\n"
2399 #define FUNC_NAME s_scm_seek
2403 fd_port
= SCM_COERCE_OUTPORT (fd_port
);
2405 how
= scm_to_int (whence
);
2406 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
2407 SCM_OUT_OF_RANGE (3, whence
);
2409 if (SCM_OPPORTP (fd_port
))
2411 scm_t_ptob_descriptor
*ptob
= SCM_PORT_DESCRIPTOR (fd_port
);
2412 off_t_or_off64_t off
= scm_to_off_t_or_off64_t (offset
);
2413 off_t_or_off64_t rv
;
2416 SCM_MISC_ERROR ("port is not seekable",
2417 scm_cons (fd_port
, SCM_EOL
));
2419 rv
= ptob
->seek (fd_port
, off
, how
);
2420 return scm_from_off_t_or_off64_t (rv
);
2422 else /* file descriptor?. */
2424 off_t_or_off64_t off
= scm_to_off_t_or_off64_t (offset
);
2425 off_t_or_off64_t rv
;
2426 rv
= lseek_or_lseek64 (scm_to_int (fd_port
), off
, how
);
2429 return scm_from_off_t_or_off64_t (rv
);
2438 /* Mingw has ftruncate(), perhaps implemented above using chsize, but
2439 doesn't have the filename version truncate(), hence this code. */
2440 #if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
2442 truncate (const char *file
, off_t length
)
2446 fdes
= open (file
, O_BINARY
| O_WRONLY
);
2450 ret
= ftruncate (fdes
, length
);
2453 int save_errno
= errno
;
2459 return close (fdes
);
2461 #endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
2463 SCM_DEFINE (scm_truncate_file
, "truncate-file", 1, 1, 0,
2464 (SCM object
, SCM length
),
2465 "Truncate file @var{object} to @var{length} bytes. @var{object}\n"
2466 "can be a filename string, a port object, or an integer file\n"
2468 "The return value is unspecified.\n"
2470 "For a port or file descriptor @var{length} can be omitted, in\n"
2471 "which case the file is truncated at the current position (per\n"
2472 "@code{ftell} above).\n"
2474 "On most systems a file can be extended by giving a length\n"
2475 "greater than the current size, but this is not mandatory in the\n"
2477 #define FUNC_NAME s_scm_truncate_file
2481 /* "object" can be a port, fdes or filename.
2483 Negative "length" makes no sense, but it's left to truncate() or
2484 ftruncate() to give back an error for that (normally EINVAL).
2487 if (SCM_UNBNDP (length
))
2489 /* must supply length if object is a filename. */
2490 if (scm_is_string (object
))
2491 SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL
);
2493 length
= scm_seek (object
, SCM_INUM0
, scm_from_int (SEEK_CUR
));
2496 object
= SCM_COERCE_OUTPORT (object
);
2497 if (scm_is_integer (object
))
2499 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
2500 SCM_SYSCALL (rv
= ftruncate_or_ftruncate64 (scm_to_int (object
),
2503 else if (SCM_OPOUTPORTP (object
))
2505 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
2506 scm_t_port
*pt
= SCM_PTAB_ENTRY (object
);
2507 scm_t_ptob_descriptor
*ptob
= SCM_PORT_DESCRIPTOR (object
);
2509 if (!ptob
->truncate
)
2510 SCM_MISC_ERROR ("port is not truncatable", SCM_EOL
);
2511 if (pt
->rw_active
== SCM_PORT_READ
)
2512 scm_end_input_unlocked (object
);
2513 else if (pt
->rw_active
== SCM_PORT_WRITE
)
2514 ptob
->flush (object
);
2516 ptob
->truncate (object
, c_length
);
2521 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
2522 char *str
= scm_to_locale_string (object
);
2524 SCM_SYSCALL (rv
= truncate_or_truncate64 (str
, c_length
));
2531 return SCM_UNSPECIFIED
;
2535 SCM_DEFINE (scm_port_line
, "port-line", 1, 0, 0,
2537 "Return the current line number for @var{port}.\n"
2539 "The first line of a file is 0. But you might want to add 1\n"
2540 "when printing line numbers, since starting from 1 is\n"
2541 "traditional in error messages, and likely to be more natural to\n"
2543 #define FUNC_NAME s_scm_port_line
2545 port
= SCM_COERCE_OUTPORT (port
);
2546 SCM_VALIDATE_OPENPORT (1, port
);
2547 return scm_from_long (SCM_LINUM (port
));
2551 SCM_DEFINE (scm_set_port_line_x
, "set-port-line!", 2, 0, 0,
2552 (SCM port
, SCM line
),
2553 "Set the current line number for @var{port} to @var{line}. The\n"
2554 "first line of a file is 0.")
2555 #define FUNC_NAME s_scm_set_port_line_x
2557 port
= SCM_COERCE_OUTPORT (port
);
2558 SCM_VALIDATE_OPENPORT (1, port
);
2559 SCM_PTAB_ENTRY (port
)->line_number
= scm_to_long (line
);
2560 return SCM_UNSPECIFIED
;
2564 SCM_DEFINE (scm_port_column
, "port-column", 1, 0, 0,
2566 "Return the current column number of @var{port}.\n"
2567 "If the number is\n"
2568 "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
2569 "- i.e. the first character of the first line is line 0, column 0.\n"
2570 "(However, when you display a file position, for example in an error\n"
2571 "message, we recommend you add 1 to get 1-origin integers. This is\n"
2572 "because lines and column numbers traditionally start with 1, and that is\n"
2573 "what non-programmers will find most natural.)")
2574 #define FUNC_NAME s_scm_port_column
2576 port
= SCM_COERCE_OUTPORT (port
);
2577 SCM_VALIDATE_OPENPORT (1, port
);
2578 return scm_from_int (SCM_COL (port
));
2582 SCM_DEFINE (scm_set_port_column_x
, "set-port-column!", 2, 0, 0,
2583 (SCM port
, SCM column
),
2584 "Set the current column of @var{port}. Before reading the first\n"
2585 "character on a line the column should be 0.")
2586 #define FUNC_NAME s_scm_set_port_column_x
2588 port
= SCM_COERCE_OUTPORT (port
);
2589 SCM_VALIDATE_OPENPORT (1, port
);
2590 SCM_PTAB_ENTRY (port
)->column_number
= scm_to_int (column
);
2591 return SCM_UNSPECIFIED
;
2595 SCM_DEFINE (scm_port_filename
, "port-filename", 1, 0, 0,
2597 "Return the filename associated with @var{port}, or @code{#f}\n"
2598 "if no filename is associated with the port.")
2599 #define FUNC_NAME s_scm_port_filename
2601 port
= SCM_COERCE_OUTPORT (port
);
2602 SCM_VALIDATE_OPENPORT (1, port
);
2603 return SCM_FILENAME (port
);
2607 SCM_DEFINE (scm_set_port_filename_x
, "set-port-filename!", 2, 0, 0,
2608 (SCM port
, SCM filename
),
2609 "Change the filename associated with @var{port}, using the current input\n"
2610 "port if none is specified. Note that this does not change the port's\n"
2611 "source of data, but only the value that is returned by\n"
2612 "@code{port-filename} and reported in diagnostic output.")
2613 #define FUNC_NAME s_scm_set_port_filename_x
2615 port
= SCM_COERCE_OUTPORT (port
);
2616 SCM_VALIDATE_OPENPORT (1, port
);
2617 /* We allow the user to set the filename to whatever he likes. */
2618 SCM_SET_FILENAME (port
, filename
);
2619 return SCM_UNSPECIFIED
;
2626 /* Implementation helpers for port printing functions. */
2629 scm_print_port_mode (SCM exp
, SCM port
)
2631 scm_puts_unlocked (SCM_CLOSEDP (exp
)
2633 : (SCM_RDNG
& SCM_CELL_WORD_0 (exp
)
2634 ? (SCM_WRTNG
& SCM_CELL_WORD_0 (exp
)
2637 : (SCM_WRTNG
& SCM_CELL_WORD_0 (exp
)
2644 scm_port_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2646 char *type
= SCM_PTOBNAME (SCM_PTOBNUM (exp
));
2649 scm_puts_unlocked ("#<", port
);
2650 scm_print_port_mode (exp
, port
);
2651 scm_puts_unlocked (type
, port
);
2652 scm_putc_unlocked (' ', port
);
2653 scm_uintprint (SCM_CELL_WORD_1 (exp
), 16, port
);
2654 scm_putc_unlocked ('>', port
);
2661 /* Iterating over all ports. */
2663 struct for_each_data
2665 void (*proc
) (void *data
, SCM p
);
2670 for_each_trampoline (void *data
, SCM port
, SCM result
)
2672 struct for_each_data
*d
= data
;
2674 d
->proc (d
->data
, port
);
2680 scm_c_port_for_each (void (*proc
)(void *data
, SCM p
), void *data
)
2682 struct for_each_data d
;
2687 scm_c_weak_set_fold (for_each_trampoline
, &d
, SCM_EOL
,
2688 scm_i_port_weak_set
);
2692 scm_for_each_trampoline (void *data
, SCM port
)
2694 scm_call_1 (SCM_PACK_POINTER (data
), port
);
2697 SCM_DEFINE (scm_port_for_each
, "port-for-each", 1, 0, 0,
2699 "Apply @var{proc} to each port in the Guile port table\n"
2700 "in turn. The return value is unspecified. More specifically,\n"
2701 "@var{proc} is applied exactly once to every port that exists\n"
2702 "in the system at the time @code{port-for-each} is invoked.\n"
2703 "Changes to the port table while @code{port-for-each} is running\n"
2704 "have no effect as far as @code{port-for-each} is concerned.")
2705 #define FUNC_NAME s_scm_port_for_each
2707 SCM_VALIDATE_PROC (1, proc
);
2709 scm_c_port_for_each (scm_for_each_trampoline
, SCM_UNPACK_POINTER (proc
));
2711 return SCM_UNSPECIFIED
;
2716 flush_output_port (void *closure
, SCM port
)
2718 if (SCM_OPOUTPORTP (port
))
2719 scm_flush_unlocked (port
);
2722 SCM_DEFINE (scm_flush_all_ports
, "flush-all-ports", 0, 0, 0,
2724 "Equivalent to calling @code{force-output} on\n"
2725 "all open output ports. The return value is unspecified.")
2726 #define FUNC_NAME s_scm_flush_all_ports
2728 scm_c_port_for_each (&flush_output_port
, NULL
);
2729 return SCM_UNSPECIFIED
;
2738 scm_t_bits scm_tc16_void_port
= 0;
2740 static int fill_input_void_port (SCM port SCM_UNUSED
)
2746 write_void_port (SCM port SCM_UNUSED
,
2747 const void *data SCM_UNUSED
,
2748 size_t size SCM_UNUSED
)
2753 scm_i_void_port (long mode_bits
)
2757 ret
= scm_c_make_port (scm_tc16_void_port
, mode_bits
, 0);
2759 scm_port_non_buffer (SCM_PTAB_ENTRY (ret
));
2765 scm_void_port (char *mode_str
)
2767 return scm_i_void_port (scm_mode_bits (mode_str
));
2770 SCM_DEFINE (scm_sys_make_void_port
, "%make-void-port", 1, 0, 0,
2772 "Create and return a new void port. A void port acts like\n"
2773 "@file{/dev/null}. The @var{mode} argument\n"
2774 "specifies the input/output modes for this port: see the\n"
2775 "documentation for @code{open-file} in @ref{File Ports}.")
2776 #define FUNC_NAME s_scm_sys_make_void_port
2778 return scm_i_void_port (scm_i_mode_bits (mode
));
2785 /* Initialization. */
2790 /* lseek() symbols. */
2791 scm_c_define ("SEEK_SET", scm_from_int (SEEK_SET
));
2792 scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR
));
2793 scm_c_define ("SEEK_END", scm_from_int (SEEK_END
));
2795 scm_tc16_void_port
= scm_make_port_type ("void", fill_input_void_port
,
2798 cur_inport_fluid
= scm_make_fluid ();
2799 cur_outport_fluid
= scm_make_fluid ();
2800 cur_errport_fluid
= scm_make_fluid ();
2801 cur_loadport_fluid
= scm_make_fluid ();
2803 scm_i_port_weak_set
= scm_c_make_weak_set (31);
2805 #include "libguile/ports.x"
2807 /* Use Latin-1 as the default port encoding. */
2808 SCM_VARIABLE_SET (default_port_encoding_var
,
2809 scm_make_fluid_with_default (SCM_BOOL_F
));
2810 scm_port_encoding_init
= 1;
2812 SCM_VARIABLE_SET (scm_conversion_strategy
,
2813 scm_make_fluid_with_default
2814 (scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK
)));
2815 scm_conversion_strategy_init
= 1;
2817 /* These bindings are used when boot-9 turns `current-input-port' et
2818 al into parameters. They are then removed from the guile module. */
2819 scm_c_define ("%current-input-port-fluid", cur_inport_fluid
);
2820 scm_c_define ("%current-output-port-fluid", cur_outport_fluid
);
2821 scm_c_define ("%current-error-port-fluid", cur_errport_fluid
);