1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
23 #define _LARGEFILE64_SOURCE /* ask for stat64 etc */
31 #include <fcntl.h> /* for chsize on mingw */
35 #include <striconveh.h>
39 #include "libguile/_scm.h"
40 #include "libguile/async.h"
41 #include "libguile/eval.h"
42 #include "libguile/fports.h" /* direct access for seek and truncate */
43 #include "libguile/goops.h"
44 #include "libguile/smob.h"
45 #include "libguile/chars.h"
46 #include "libguile/dynwind.h"
48 #include "libguile/keywords.h"
49 #include "libguile/hashtab.h"
50 #include "libguile/root.h"
51 #include "libguile/strings.h"
52 #include "libguile/mallocs.h"
53 #include "libguile/validate.h"
54 #include "libguile/ports.h"
55 #include "libguile/vectors.h"
56 #include "libguile/weaks.h"
57 #include "libguile/fluids.h"
58 #include "libguile/eq.h"
72 #ifdef HAVE_SYS_IOCTL_H
73 #include <sys/ioctl.h>
76 /* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
77 already, but have this code here in case that wasn't so in past versions,
78 or perhaps to help other minimal DOS environments.
80 gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
81 might be possibilities if we've got other systems without ftruncate. */
83 #if defined HAVE_CHSIZE && ! defined HAVE_FTRUNCATE
84 #define ftruncate(fd, size) chsize (fd, size)
86 #define HAVE_FTRUNCATE 1
90 /* The port kind table --- a dynamically resized array of port types. */
93 /* scm_ptobs scm_numptob
94 * implement a dynamically resized array of ptob records.
95 * Indexes into this table are used when generating type
96 * tags for smobjects (if you know a tag you can get an index and conversely).
98 scm_t_ptob_descriptor
*scm_ptobs
= NULL
;
101 /* GC marker for a port with stream of SCM type. */
103 scm_markstream (SCM ptr
)
106 openp
= SCM_CELL_WORD_0 (ptr
) & SCM_OPN
;
108 return SCM_PACK (SCM_STREAM (ptr
));
114 * We choose to use an interface similar to the smob interface with
115 * fill_input and write as standard fields, passed to the port
116 * type constructor, and optional fields set by setters.
120 flush_port_default (SCM port SCM_UNUSED
)
125 end_input_default (SCM port SCM_UNUSED
, int offset SCM_UNUSED
)
130 scm_make_port_type (char *name
,
131 int (*fill_input
) (SCM port
),
132 void (*write
) (SCM port
, const void *data
, size_t size
))
135 if (SCM_I_MAX_PORT_TYPE_COUNT
- 1 <= scm_numptob
)
137 SCM_CRITICAL_SECTION_START
;
138 tmp
= (char *) scm_gc_realloc ((char *) scm_ptobs
,
139 scm_numptob
* sizeof (scm_t_ptob_descriptor
),
141 * sizeof (scm_t_ptob_descriptor
),
145 scm_ptobs
= (scm_t_ptob_descriptor
*) tmp
;
147 scm_ptobs
[scm_numptob
].name
= name
;
148 scm_ptobs
[scm_numptob
].mark
= 0;
149 scm_ptobs
[scm_numptob
].free
= NULL
;
150 scm_ptobs
[scm_numptob
].print
= scm_port_print
;
151 scm_ptobs
[scm_numptob
].equalp
= 0;
152 scm_ptobs
[scm_numptob
].close
= 0;
154 scm_ptobs
[scm_numptob
].write
= write
;
155 scm_ptobs
[scm_numptob
].flush
= flush_port_default
;
157 scm_ptobs
[scm_numptob
].end_input
= end_input_default
;
158 scm_ptobs
[scm_numptob
].fill_input
= fill_input
;
159 scm_ptobs
[scm_numptob
].input_waiting
= 0;
161 scm_ptobs
[scm_numptob
].seek
= 0;
162 scm_ptobs
[scm_numptob
].truncate
= 0;
166 SCM_CRITICAL_SECTION_END
;
170 scm_memory_error ("scm_make_port_type");
172 /* Make a class object if Goops is present */
173 if (SCM_UNPACK (scm_port_class
[0]) != 0)
174 scm_make_port_classes (scm_numptob
- 1, SCM_PTOBNAME (scm_numptob
- 1));
175 return scm_tc7_port
+ (scm_numptob
- 1) * 256;
179 scm_set_port_mark (scm_t_bits tc
, SCM (*mark
) (SCM
))
181 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].mark
= mark
;
185 scm_set_port_free (scm_t_bits tc
, size_t (*free
) (SCM
))
187 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].free
= free
;
191 scm_set_port_print (scm_t_bits tc
, int (*print
) (SCM exp
, SCM port
,
192 scm_print_state
*pstate
))
194 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].print
= print
;
198 scm_set_port_equalp (scm_t_bits tc
, SCM (*equalp
) (SCM
, SCM
))
200 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].equalp
= equalp
;
204 scm_set_port_flush (scm_t_bits tc
, void (*flush
) (SCM port
))
206 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].flush
= flush
;
210 scm_set_port_end_input (scm_t_bits tc
, void (*end_input
) (SCM port
, int offset
))
212 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].end_input
= end_input
;
216 scm_set_port_close (scm_t_bits tc
, int (*close
) (SCM
))
218 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].close
= close
;
222 scm_set_port_seek (scm_t_bits tc
,
223 scm_t_off (*seek
) (SCM
, scm_t_off
, int))
225 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].seek
= seek
;
229 scm_set_port_truncate (scm_t_bits tc
, void (*truncate
) (SCM
, scm_t_off
))
231 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].truncate
= truncate
;
235 scm_set_port_input_waiting (scm_t_bits tc
, int (*input_waiting
) (SCM
))
237 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].input_waiting
= input_waiting
;
242 SCM_DEFINE (scm_char_ready_p
, "char-ready?", 0, 1, 0,
244 "Return @code{#t} if a character is ready on input @var{port}\n"
245 "and return @code{#f} otherwise. If @code{char-ready?} returns\n"
246 "@code{#t} then the next @code{read-char} operation on\n"
247 "@var{port} is guaranteed not to hang. If @var{port} is a file\n"
248 "port at end of file then @code{char-ready?} returns @code{#t}.\n"
250 "@code{char-ready?} exists to make it possible for a\n"
251 "program to accept characters from interactive ports without\n"
252 "getting stuck waiting for input. Any input editors associated\n"
253 "with such ports must make sure that characters whose existence\n"
254 "has been asserted by @code{char-ready?} cannot be rubbed out.\n"
255 "If @code{char-ready?} were to return @code{#f} at end of file,\n"
256 "a port at end of file would be indistinguishable from an\n"
257 "interactive port that has no ready characters.")
258 #define FUNC_NAME s_scm_char_ready_p
262 if (SCM_UNBNDP (port
))
263 port
= scm_current_input_port ();
264 /* It's possible to close the current input port, so validate even in
266 SCM_VALIDATE_OPINPORT (1, port
);
268 pt
= SCM_PTAB_ENTRY (port
);
270 /* if the current read buffer is filled, or the
271 last pushed-back char has been read and the saved buffer is
272 filled, result is true. */
273 if (pt
->read_pos
< pt
->read_end
274 || (pt
->read_buf
== pt
->putback_buf
275 && pt
->saved_read_pos
< pt
->saved_read_end
))
279 scm_t_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
281 if (ptob
->input_waiting
)
282 return scm_from_bool(ptob
->input_waiting (port
));
289 /* move up to read_len chars from port's putback and/or read buffers
290 into memory starting at dest. returns the number of chars moved. */
291 size_t scm_take_from_input_buffers (SCM port
, char *dest
, size_t read_len
)
293 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
294 size_t chars_read
= 0;
295 size_t from_buf
= min (pt
->read_end
- pt
->read_pos
, read_len
);
299 memcpy (dest
, pt
->read_pos
, from_buf
);
300 pt
->read_pos
+= from_buf
;
301 chars_read
+= from_buf
;
302 read_len
-= from_buf
;
306 /* if putback was active, try the real input buffer too. */
307 if (pt
->read_buf
== pt
->putback_buf
)
309 from_buf
= min (pt
->saved_read_end
- pt
->saved_read_pos
, read_len
);
312 memcpy (dest
, pt
->saved_read_pos
, from_buf
);
313 pt
->saved_read_pos
+= from_buf
;
314 chars_read
+= from_buf
;
320 /* Clear a port's read buffers, returning the contents. */
321 SCM_DEFINE (scm_drain_input
, "drain-input", 1, 0, 0,
323 "This procedure clears a port's input buffers, similar\n"
324 "to the way that force-output clears the output buffer. The\n"
325 "contents of the buffers are returned as a single string, e.g.,\n"
328 "(define p (open-input-file ...))\n"
329 "(drain-input p) => empty string, nothing buffered yet.\n"
330 "(unread-char (read-char p) p)\n"
331 "(drain-input p) => initial chars from p, up to the buffer size.\n"
333 "Draining the buffers may be useful for cleanly finishing\n"
334 "buffered I/O so that the file descriptor can be used directly\n"
335 "for further input.")
336 #define FUNC_NAME s_scm_drain_input
343 SCM_VALIDATE_OPINPORT (1, port
);
344 pt
= SCM_PTAB_ENTRY (port
);
346 count
= pt
->read_end
- pt
->read_pos
;
347 if (pt
->read_buf
== pt
->putback_buf
)
348 count
+= pt
->saved_read_end
- pt
->saved_read_pos
;
352 result
= scm_i_make_string (count
, &data
);
353 scm_take_from_input_buffers (port
, data
, count
);
356 result
= scm_nullstr
;
363 /* Standard ports --- current input, output, error, and more(!). */
365 static SCM cur_inport_fluid
= 0;
366 static SCM cur_outport_fluid
= 0;
367 static SCM cur_errport_fluid
= 0;
368 static SCM cur_loadport_fluid
= 0;
370 SCM_DEFINE (scm_current_input_port
, "current-input-port", 0, 0, 0,
372 "Return the current input port. This is the default port used\n"
373 "by many input procedures. Initially, @code{current-input-port}\n"
374 "returns the @dfn{standard input} in Unix and C terminology.")
375 #define FUNC_NAME s_scm_current_input_port
377 if (cur_inport_fluid
)
378 return scm_fluid_ref (cur_inport_fluid
);
384 SCM_DEFINE (scm_current_output_port
, "current-output-port", 0, 0, 0,
386 "Return the current output port. This is the default port used\n"
387 "by many output procedures. Initially,\n"
388 "@code{current-output-port} returns the @dfn{standard output} in\n"
389 "Unix and C terminology.")
390 #define FUNC_NAME s_scm_current_output_port
392 if (cur_outport_fluid
)
393 return scm_fluid_ref (cur_outport_fluid
);
399 SCM_DEFINE (scm_current_error_port
, "current-error-port", 0, 0, 0,
401 "Return the port to which errors and warnings should be sent (the\n"
402 "@dfn{standard error} in Unix and C terminology).")
403 #define FUNC_NAME s_scm_current_error_port
405 if (cur_errport_fluid
)
406 return scm_fluid_ref (cur_errport_fluid
);
412 SCM_DEFINE (scm_current_load_port
, "current-load-port", 0, 0, 0,
414 "Return the current-load-port.\n"
415 "The load port is used internally by @code{primitive-load}.")
416 #define FUNC_NAME s_scm_current_load_port
418 return scm_fluid_ref (cur_loadport_fluid
);
422 SCM_DEFINE (scm_set_current_input_port
, "set-current-input-port", 1, 0, 0,
424 "@deffnx {Scheme Procedure} set-current-output-port port\n"
425 "@deffnx {Scheme Procedure} set-current-error-port port\n"
426 "Change the ports returned by @code{current-input-port},\n"
427 "@code{current-output-port} and @code{current-error-port}, respectively,\n"
428 "so that they use the supplied @var{port} for input or output.")
429 #define FUNC_NAME s_scm_set_current_input_port
431 SCM oinp
= scm_fluid_ref (cur_inport_fluid
);
432 SCM_VALIDATE_OPINPORT (1, port
);
433 scm_fluid_set_x (cur_inport_fluid
, port
);
439 SCM_DEFINE (scm_set_current_output_port
, "set-current-output-port", 1, 0, 0,
441 "Set the current default output port to @var{port}.")
442 #define FUNC_NAME s_scm_set_current_output_port
444 SCM ooutp
= scm_fluid_ref (cur_outport_fluid
);
445 port
= SCM_COERCE_OUTPORT (port
);
446 SCM_VALIDATE_OPOUTPORT (1, port
);
447 scm_fluid_set_x (cur_outport_fluid
, port
);
453 SCM_DEFINE (scm_set_current_error_port
, "set-current-error-port", 1, 0, 0,
455 "Set the current default error port to @var{port}.")
456 #define FUNC_NAME s_scm_set_current_error_port
458 SCM oerrp
= scm_fluid_ref (cur_errport_fluid
);
459 port
= SCM_COERCE_OUTPORT (port
);
460 SCM_VALIDATE_OPOUTPORT (1, port
);
461 scm_fluid_set_x (cur_errport_fluid
, port
);
467 scm_dynwind_current_input_port (SCM port
)
468 #define FUNC_NAME NULL
470 SCM_VALIDATE_OPINPORT (1, port
);
471 scm_dynwind_fluid (cur_inport_fluid
, port
);
476 scm_dynwind_current_output_port (SCM port
)
477 #define FUNC_NAME NULL
479 port
= SCM_COERCE_OUTPORT (port
);
480 SCM_VALIDATE_OPOUTPORT (1, port
);
481 scm_dynwind_fluid (cur_outport_fluid
, port
);
486 scm_dynwind_current_error_port (SCM port
)
487 #define FUNC_NAME NULL
489 port
= SCM_COERCE_OUTPORT (port
);
490 SCM_VALIDATE_OPOUTPORT (1, port
);
491 scm_dynwind_fluid (cur_errport_fluid
, port
);
496 scm_i_dynwind_current_load_port (SCM port
)
498 scm_dynwind_fluid (cur_loadport_fluid
, port
);
502 /* The port table --- an array of pointers to ports. */
505 We need a global registry of ports to flush them all at exit, and to
506 get all the ports matching a file descriptor.
508 SCM scm_i_port_weak_hash
;
510 scm_i_pthread_mutex_t scm_i_port_table_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
513 /* Port finalization. */
516 static void finalize_port (GC_PTR
, GC_PTR
);
518 /* Register a finalizer for PORT, if needed by its port type. */
519 static SCM_C_INLINE_KEYWORD
void
520 register_finalizer_for_port (SCM port
)
524 port_type
= SCM_TC2PTOBNUM (SCM_CELL_TYPE (port
));
525 if (scm_ptobs
[port_type
].free
)
527 GC_finalization_proc prev_finalizer
;
528 GC_PTR prev_finalization_data
;
530 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (port
), finalize_port
, 0,
532 &prev_finalization_data
);
536 /* Finalize the object (a port) pointed to by PTR. */
538 finalize_port (GC_PTR ptr
, GC_PTR data
)
541 SCM port
= PTR2SCM (ptr
);
543 if (!SCM_PORTP (port
))
546 if (SCM_OPENP (port
))
548 if (SCM_REVEALED (port
) > 0)
549 /* Keep "revealed" ports alive and re-register a finalizer. */
550 register_finalizer_for_port (port
);
553 port_type
= SCM_TC2PTOBNUM (SCM_CELL_TYPE (port
));
554 if (port_type
>= scm_numptob
)
557 if (scm_ptobs
[port_type
].free
)
558 /* Yes, I really do mean `.free' rather than `.close'. `.close'
559 is for explicit `close-port' by user. */
560 scm_ptobs
[port_type
].free (port
);
562 SCM_SETSTREAM (port
, 0);
563 SCM_CLR_PORT_OPEN_FLAG (port
);
565 scm_gc_ports_collected
++;
574 /* This function is not and should not be thread safe. */
576 scm_new_port_table_entry (scm_t_bits tag
)
577 #define FUNC_NAME "scm_new_port_table_entry"
580 We initialize the cell to empty, this is in case scm_gc_calloc
581 triggers GC ; we don't want the GC to scan a half-finished Z.
584 SCM z
= scm_cons (SCM_EOL
, SCM_EOL
);
585 scm_t_port
*entry
= (scm_t_port
*) scm_gc_calloc (sizeof (scm_t_port
), "port");
588 entry
->file_name
= SCM_BOOL_F
;
589 entry
->rw_active
= SCM_PORT_NEITHER
;
591 /* Initialize this port with the thread's current default
593 if ((enc
= scm_i_get_port_encoding (SCM_BOOL_F
)) == NULL
)
594 entry
->encoding
= NULL
;
596 entry
->encoding
= scm_gc_strdup (enc
, "port");
597 entry
->ilseq_handler
= scm_i_get_conversion_strategy (SCM_BOOL_F
);
599 SCM_SET_CELL_TYPE (z
, tag
);
600 SCM_SETPTAB_ENTRY (z
, entry
);
602 scm_hashq_set_x (scm_i_port_weak_hash
, z
, SCM_BOOL_F
);
604 /* For each new port, register a finalizer so that it port type's free
605 function can be invoked eventually. */
606 register_finalizer_for_port (z
);
612 #if SCM_ENABLE_DEPRECATED==1
614 scm_add_to_port_table (SCM port
)
616 SCM z
= scm_new_port_table_entry (scm_tc7_port
);
617 scm_t_port
* pt
= SCM_PTAB_ENTRY(z
);
620 SCM_SETCAR (z
, SCM_EOL
);
621 SCM_SETCDR (z
, SCM_EOL
);
622 SCM_SETPTAB_ENTRY (port
, pt
);
628 /* Remove a port from the table and destroy it. */
630 /* This function is not and should not be thread safe. */
632 scm_i_remove_port (SCM port
)
633 #define FUNC_NAME "scm_remove_port"
635 scm_t_port
*p
= SCM_PTAB_ENTRY (port
);
637 scm_port_non_buffer (p
);
639 p
->putback_buf
= NULL
;
640 p
->putback_buf_size
= 0;
642 SCM_SETPTAB_ENTRY (port
, 0);
643 scm_hashq_remove_x (scm_i_port_weak_hash
, port
);
648 /* Functions for debugging. */
650 SCM_DEFINE (scm_pt_size
, "pt-size", 0, 0, 0,
652 "Return the number of ports in the port table. @code{pt-size}\n"
653 "is only included in @code{--enable-guile-debug} builds.")
654 #define FUNC_NAME s_scm_pt_size
656 return scm_from_int (SCM_HASHTABLE_N_ITEMS (scm_i_port_weak_hash
));
662 scm_port_non_buffer (scm_t_port
*pt
)
664 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
665 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
666 pt
->read_buf_size
= pt
->write_buf_size
= 1;
667 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
671 /* Revealed counts --- an oddity inherited from SCSH. */
673 /* Find a port in the table and return its revealed count.
674 Also used by the garbage collector.
678 scm_revealed_count (SCM port
)
680 return SCM_REVEALED(port
);
685 /* Return the revealed count for a port. */
687 SCM_DEFINE (scm_port_revealed
, "port-revealed", 1, 0, 0,
689 "Return the revealed count for @var{port}.")
690 #define FUNC_NAME s_scm_port_revealed
692 port
= SCM_COERCE_OUTPORT (port
);
693 SCM_VALIDATE_OPENPORT (1, port
);
694 return scm_from_int (scm_revealed_count (port
));
698 /* Set the revealed count for a port. */
699 SCM_DEFINE (scm_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0,
700 (SCM port
, SCM rcount
),
701 "Sets the revealed count for a port to a given value.\n"
702 "The return value is unspecified.")
703 #define FUNC_NAME s_scm_set_port_revealed_x
705 port
= SCM_COERCE_OUTPORT (port
);
706 SCM_VALIDATE_OPENPORT (1, port
);
707 SCM_REVEALED (port
) = scm_to_int (rcount
);
708 return SCM_UNSPECIFIED
;
714 /* Retrieving a port's mode. */
716 /* Return the flags that characterize a port based on the mode
717 * string used to open a file for that port.
719 * See PORT FLAGS in scm.h
723 scm_i_mode_bits_n (SCM modes
)
726 | (scm_i_string_contains_char (modes
, 'r')
727 || scm_i_string_contains_char (modes
, '+') ? SCM_RDNG
: 0)
728 | (scm_i_string_contains_char (modes
, 'w')
729 || scm_i_string_contains_char (modes
, 'a')
730 || scm_i_string_contains_char (modes
, '+') ? SCM_WRTNG
: 0)
731 | (scm_i_string_contains_char (modes
, '0') ? SCM_BUF0
: 0)
732 | (scm_i_string_contains_char (modes
, 'l') ? SCM_BUFLINE
: 0));
736 scm_mode_bits (char *modes
)
738 return scm_i_mode_bits (scm_from_locale_string (modes
));
742 scm_i_mode_bits (SCM modes
)
746 if (!scm_is_string (modes
))
747 scm_wrong_type_arg_msg (NULL
, 0, modes
, "string");
749 bits
= scm_i_mode_bits_n (modes
);
750 scm_remember_upto_here_1 (modes
);
754 /* Return the mode flags from an open port.
755 * Some modes such as "append" are only used when opening
756 * a file and are not returned here. */
758 SCM_DEFINE (scm_port_mode
, "port-mode", 1, 0, 0,
760 "Return the port modes associated with the open port @var{port}.\n"
761 "These will not necessarily be identical to the modes used when\n"
762 "the port was opened, since modes such as \"append\" which are\n"
763 "used only during port creation are not retained.")
764 #define FUNC_NAME s_scm_port_mode
769 port
= SCM_COERCE_OUTPORT (port
);
770 SCM_VALIDATE_OPPORT (1, port
);
771 if (SCM_CELL_WORD_0 (port
) & SCM_RDNG
) {
772 if (SCM_CELL_WORD_0 (port
) & SCM_WRTNG
)
773 strcpy (modes
, "r+");
777 else if (SCM_CELL_WORD_0 (port
) & SCM_WRTNG
)
779 if (SCM_CELL_WORD_0 (port
) & SCM_BUF0
)
781 return scm_from_locale_string (modes
);
790 * Call the close operation on a port object.
791 * see also scm_close.
793 SCM_DEFINE (scm_close_port
, "close-port", 1, 0, 0,
795 "Close the specified port object. Return @code{#t} if it\n"
796 "successfully closes a port or @code{#f} if it was already\n"
797 "closed. An exception may be raised if an error occurs, for\n"
798 "example when flushing buffered output. See also @ref{Ports and\n"
799 "File Descriptors, close}, for a procedure which can close file\n"
801 #define FUNC_NAME s_scm_close_port
806 port
= SCM_COERCE_OUTPORT (port
);
808 SCM_VALIDATE_PORT (1, port
);
809 if (SCM_CLOSEDP (port
))
811 i
= SCM_PTOBNUM (port
);
812 if (scm_ptobs
[i
].close
)
813 rv
= (scm_ptobs
[i
].close
) (port
);
816 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
817 scm_i_remove_port (port
);
818 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
819 SCM_CLR_PORT_OPEN_FLAG (port
);
820 return scm_from_bool (rv
>= 0);
824 SCM_DEFINE (scm_close_input_port
, "close-input-port", 1, 0, 0,
826 "Close the specified input port object. The routine has no effect if\n"
827 "the file has already been closed. An exception may be raised if an\n"
828 "error occurs. The value returned is unspecified.\n\n"
829 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
830 "which can close file descriptors.")
831 #define FUNC_NAME s_scm_close_input_port
833 SCM_VALIDATE_INPUT_PORT (1, port
);
834 scm_close_port (port
);
835 return SCM_UNSPECIFIED
;
839 SCM_DEFINE (scm_close_output_port
, "close-output-port", 1, 0, 0,
841 "Close the specified output port object. The routine has no effect if\n"
842 "the file has already been closed. An exception may be raised if an\n"
843 "error occurs. The value returned is unspecified.\n\n"
844 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
845 "which can close file descriptors.")
846 #define FUNC_NAME s_scm_close_output_port
848 port
= SCM_COERCE_OUTPORT (port
);
849 SCM_VALIDATE_OUTPUT_PORT (1, port
);
850 scm_close_port (port
);
851 return SCM_UNSPECIFIED
;
856 scm_i_collect_keys_in_vector (void *closure
, SCM key
, SCM value
, SCM result
)
858 int *i
= (int*) closure
;
859 scm_c_vector_set_x (result
, *i
, key
);
866 scm_c_port_for_each (void (*proc
)(void *data
, SCM p
), void *data
)
872 /* Even without pre-emptive multithreading, running arbitrary code
873 while scanning the port table is unsafe because the port table
874 can change arbitrarily (from a GC, for example). So we first
875 collect the ports into a vector. -mvo */
877 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
878 n
= SCM_HASHTABLE_N_ITEMS (scm_i_port_weak_hash
);
879 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
880 ports
= scm_c_make_vector (n
, SCM_BOOL_F
);
882 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
883 ports
= scm_internal_hash_fold (scm_i_collect_keys_in_vector
, &i
,
884 ports
, scm_i_port_weak_hash
);
885 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
887 for (i
= 0; i
< n
; i
++) {
888 SCM p
= SCM_SIMPLE_VECTOR_REF (ports
, i
);
893 scm_remember_upto_here_1 (ports
);
896 SCM_DEFINE (scm_port_for_each
, "port-for-each", 1, 0, 0,
898 "Apply @var{proc} to each port in the Guile port table\n"
899 "in turn. The return value is unspecified. More specifically,\n"
900 "@var{proc} is applied exactly once to every port that exists\n"
901 "in the system at the time @var{port-for-each} is invoked.\n"
902 "Changes to the port table while @var{port-for-each} is running\n"
903 "have no effect as far as @var{port-for-each} is concerned.")
904 #define FUNC_NAME s_scm_port_for_each
906 SCM_VALIDATE_PROC (1, proc
);
908 scm_c_port_for_each ((void (*)(void*,SCM
))scm_call_1
, proc
);
909 return SCM_UNSPECIFIED
;
915 /* Utter miscellany. Gosh, we should clean this up some time. */
917 SCM_DEFINE (scm_input_port_p
, "input-port?", 1, 0, 0,
919 "Return @code{#t} if @var{x} is an input port, otherwise return\n"
920 "@code{#f}. Any object satisfying this predicate also satisfies\n"
922 #define FUNC_NAME s_scm_input_port_p
924 return scm_from_bool (SCM_INPUT_PORT_P (x
));
928 SCM_DEFINE (scm_output_port_p
, "output-port?", 1, 0, 0,
930 "Return @code{#t} if @var{x} is an output port, otherwise return\n"
931 "@code{#f}. Any object satisfying this predicate also satisfies\n"
933 #define FUNC_NAME s_scm_output_port_p
935 x
= SCM_COERCE_OUTPORT (x
);
936 return scm_from_bool (SCM_OUTPUT_PORT_P (x
));
940 SCM_DEFINE (scm_port_p
, "port?", 1, 0, 0,
942 "Return a boolean indicating whether @var{x} is a port.\n"
943 "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
945 #define FUNC_NAME s_scm_port_p
947 return scm_from_bool (SCM_PORTP (x
));
951 SCM_DEFINE (scm_port_closed_p
, "port-closed?", 1, 0, 0,
953 "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
955 #define FUNC_NAME s_scm_port_closed_p
957 SCM_VALIDATE_PORT (1, port
);
958 return scm_from_bool (!SCM_OPPORTP (port
));
962 SCM_DEFINE (scm_eof_object_p
, "eof-object?", 1, 0, 0,
964 "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
966 #define FUNC_NAME s_scm_eof_object_p
968 return scm_from_bool(SCM_EOF_OBJECT_P (x
));
972 SCM_DEFINE (scm_force_output
, "force-output", 0, 1, 0,
974 "Flush the specified output port, or the current output port if @var{port}\n"
975 "is omitted. The current output buffer contents are passed to the\n"
976 "underlying port implementation (e.g., in the case of fports, the\n"
977 "data will be written to the file and the output buffer will be cleared.)\n"
978 "It has no effect on an unbuffered port.\n\n"
979 "The return value is unspecified.")
980 #define FUNC_NAME s_scm_force_output
982 if (SCM_UNBNDP (port
))
983 port
= scm_current_output_port ();
986 port
= SCM_COERCE_OUTPORT (port
);
987 SCM_VALIDATE_OPOUTPORT (1, port
);
990 return SCM_UNSPECIFIED
;
996 flush_output_port (void *closure
, SCM port
)
998 if (SCM_OPOUTPORTP (port
))
1002 SCM_DEFINE (scm_flush_all_ports
, "flush-all-ports", 0, 0, 0,
1004 "Equivalent to calling @code{force-output} on\n"
1005 "all open output ports. The return value is unspecified.")
1006 #define FUNC_NAME s_scm_flush_all_ports
1008 scm_c_port_for_each (&flush_output_port
, NULL
);
1009 return SCM_UNSPECIFIED
;
1013 SCM_DEFINE (scm_read_char
, "read-char", 0, 1, 0,
1015 "Return the next character available from @var{port}, updating\n"
1016 "@var{port} to point to the following character. If no more\n"
1017 "characters are available, the end-of-file object is returned.")
1018 #define FUNC_NAME s_scm_read_char
1021 if (SCM_UNBNDP (port
))
1022 port
= scm_current_input_port ();
1023 SCM_VALIDATE_OPINPORT (1, port
);
1024 c
= scm_getc (port
);
1027 return SCM_MAKE_CHAR (c
);
1031 #define SCM_MBCHAR_BUF_SIZE (4)
1033 /* Read a codepoint from PORT and return it. Fill BUF with the byte
1034 representation of the codepoint in PORT's encoding, and set *LEN to
1035 the length in bytes of that representation. Raise an error on
1038 get_codepoint (SCM port
, char buf
[SCM_MBCHAR_BUF_SIZE
], size_t *len
)
1041 size_t bufcount
= 0;
1042 scm_t_uint32 result_buf
;
1043 scm_t_wchar codepoint
= 0;
1046 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1048 c
= scm_get_byte_or_eof (port
);
1050 return (scm_t_wchar
) EOF
;
1055 if (pt
->encoding
== NULL
)
1057 /* The encoding is Latin-1: bytes are characters. */
1058 codepoint
= (unsigned char) buf
[0];
1064 u32len
= sizeof (result_buf
) / sizeof (scm_t_uint32
);
1065 u32
= u32_conv_from_encoding (pt
->encoding
,
1066 (enum iconv_ilseq_handler
) pt
->ilseq_handler
,
1067 buf
, bufcount
, NULL
, &result_buf
, &u32len
);
1068 if (u32
== NULL
|| u32len
== 0)
1070 if (errno
== ENOMEM
)
1071 scm_memory_error ("Input decoding");
1073 /* Otherwise errno is EILSEQ or EINVAL, so perhaps more
1074 bytes are needed. Keep looping. */
1078 /* Complete codepoint found. */
1081 if (SCM_UNLIKELY (u32
!= &result_buf
))
1082 /* libunistring up to 0.9.3 (included) would always heap-allocate
1083 the result even when a large-enough RESULT_BUF is supplied, see
1084 <http://lists.gnu.org/archive/html/bug-libunistring/2010-07/msg00003.html>. */
1090 if (bufcount
== SCM_MBCHAR_BUF_SIZE
)
1092 /* We've read several bytes and didn't find a good
1093 codepoint. Give up. */
1097 c
= scm_get_byte_or_eof (port
);
1101 /* EOF before a complete character was read. Push it all
1102 back and return EOF. */
1103 while (bufcount
> 0)
1105 /* FIXME: this will probably cause errors in the port column. */
1106 scm_unget_byte (buf
[bufcount
-1], port
);
1114 /* It is always invalid to have EOL in the middle of a
1115 multibyte character. */
1116 scm_unget_byte ('\n', port
);
1120 buf
[bufcount
++] = c
;
1152 SCM err_str
= scm_i_make_string (bufcount
, &err_buf
);
1153 memcpy (err_buf
, buf
, bufcount
);
1155 if (errno
== EILSEQ
)
1156 scm_misc_error (NULL
, "input encoding error for ~s: ~s",
1157 scm_list_2 (scm_from_locale_string (scm_i_get_port_encoding (port
)),
1160 scm_misc_error (NULL
, "input encoding error (invalid) for ~s: ~s\n",
1161 scm_list_2 (scm_from_locale_string (scm_i_get_port_encoding (port
)),
1165 /* Never gets here. */
1169 /* Read a codepoint from PORT and return it. */
1174 char buf
[SCM_MBCHAR_BUF_SIZE
];
1176 return get_codepoint (port
, buf
, &len
);
1179 /* this should only be called when the read buffer is empty. it
1180 tries to refill the read buffer. it returns the first char from
1181 the port, which is either EOF or *(pt->read_pos). */
1183 scm_fill_input (SCM port
)
1185 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1187 assert (pt
->read_pos
== pt
->read_end
);
1189 if (pt
->read_buf
== pt
->putback_buf
)
1191 /* finished reading put-back chars. */
1192 pt
->read_buf
= pt
->saved_read_buf
;
1193 pt
->read_pos
= pt
->saved_read_pos
;
1194 pt
->read_end
= pt
->saved_read_end
;
1195 pt
->read_buf_size
= pt
->saved_read_buf_size
;
1196 if (pt
->read_pos
< pt
->read_end
)
1197 return *(pt
->read_pos
);
1199 return scm_ptobs
[SCM_PTOBNUM (port
)].fill_input (port
);
1205 * This function differs from scm_c_write; it updates port line and
1209 update_port_lf (scm_t_wchar c
, SCM port
)
1226 scm_lfwrite (const char *ptr
, size_t size
, SCM port
)
1228 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1229 scm_t_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
1231 if (pt
->rw_active
== SCM_PORT_READ
)
1232 scm_end_input (port
);
1234 ptob
->write (port
, ptr
, size
);
1236 for (; size
; ptr
++, size
--)
1237 update_port_lf ((scm_t_wchar
) (unsigned char) *ptr
, port
);
1240 pt
->rw_active
= SCM_PORT_WRITE
;
1243 /* Write a scheme string STR to PORT from START inclusive to END
1246 scm_lfwrite_substr (SCM str
, size_t start
, size_t end
, SCM port
)
1248 size_t i
, size
= scm_i_string_length (str
);
1249 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1250 scm_t_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
1255 if (pt
->rw_active
== SCM_PORT_READ
)
1256 scm_end_input (port
);
1258 if (end
== (size_t) (-1))
1262 /* Note that making a substring will likely take the
1263 stringbuf_write_mutex. So, one shouldn't use scm_lfwrite_substr
1264 if the stringbuf write mutex may still be held elsewhere. */
1265 buf
= scm_to_stringn (scm_c_substring (str
, start
, end
), &len
,
1266 pt
->encoding
, pt
->ilseq_handler
);
1267 ptob
->write (port
, buf
, len
);
1270 for (i
= 0; i
< size
; i
++)
1272 p
= scm_i_string_ref (str
, i
+ start
);
1273 update_port_lf (p
, port
);
1277 pt
->rw_active
= SCM_PORT_WRITE
;
1280 /* Write a scheme string STR to PORT. */
1282 scm_lfwrite_str (SCM str
, SCM port
)
1284 size_t i
, size
= scm_i_string_length (str
);
1285 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1286 scm_t_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
1291 if (pt
->rw_active
== SCM_PORT_READ
)
1292 scm_end_input (port
);
1294 buf
= scm_to_stringn (str
, &len
,
1295 pt
->encoding
, pt
->ilseq_handler
);
1296 ptob
->write (port
, buf
, len
);
1299 for (i
= 0; i
< size
; i
++)
1301 p
= scm_i_string_ref (str
, i
);
1302 update_port_lf (p
, port
);
1306 pt
->rw_active
= SCM_PORT_WRITE
;
1311 * Used by an application to read arbitrary number of bytes from an
1312 * SCM port. Same semantics as libc read, except that scm_c_read only
1313 * returns less than SIZE bytes if at end-of-file.
1315 * Warning: Doesn't update port line and column counts! */
1317 /* This structure, and the following swap_buffer function, are used
1318 for temporarily swapping a port's own read buffer, and the buffer
1319 that the caller of scm_c_read provides. */
1320 struct port_and_swap_buffer
1323 unsigned char *buffer
;
1328 swap_buffer (void *data
)
1330 struct port_and_swap_buffer
*psb
= (struct port_and_swap_buffer
*) data
;
1331 unsigned char *old_buf
= psb
->pt
->read_buf
;
1332 size_t old_size
= psb
->pt
->read_buf_size
;
1334 /* Make the port use (buffer, size) from the struct. */
1335 psb
->pt
->read_pos
= psb
->pt
->read_buf
= psb
->pt
->read_end
= psb
->buffer
;
1336 psb
->pt
->read_buf_size
= psb
->size
;
1338 /* Save the port's old (buffer, size) in the struct. */
1339 psb
->buffer
= old_buf
;
1340 psb
->size
= old_size
;
1344 scm_c_read (SCM port
, void *buffer
, size_t size
)
1345 #define FUNC_NAME "scm_c_read"
1348 size_t n_read
= 0, n_available
;
1349 struct port_and_swap_buffer psb
;
1351 SCM_VALIDATE_OPINPORT (1, port
);
1353 pt
= SCM_PTAB_ENTRY (port
);
1354 if (pt
->rw_active
== SCM_PORT_WRITE
)
1355 scm_ptobs
[SCM_PTOBNUM (port
)].flush (port
);
1358 pt
->rw_active
= SCM_PORT_READ
;
1360 /* Take bytes first from the port's read buffer. */
1361 if (pt
->read_pos
< pt
->read_end
)
1363 n_available
= min (size
, pt
->read_end
- pt
->read_pos
);
1364 memcpy (buffer
, pt
->read_pos
, n_available
);
1365 buffer
= (char *) buffer
+ n_available
;
1366 pt
->read_pos
+= n_available
;
1367 n_read
+= n_available
;
1368 size
-= n_available
;
1371 /* Avoid the scm_dynwind_* costs if we now have enough data. */
1375 /* Now we will call scm_fill_input repeatedly until we have read the
1376 requested number of bytes. (Note that a single scm_fill_input
1377 call does not guarantee to fill the whole of the port's read
1379 if (pt
->read_buf_size
<= 1 && pt
->encoding
== NULL
)
1381 /* The port that we are reading from is unbuffered - i.e. does
1382 not have its own persistent buffer - but we have a buffer,
1383 provided by our caller, that is the right size for the data
1384 that is wanted. For the following scm_fill_input calls,
1385 therefore, we use the buffer in hand as the port's read
1388 We need to make sure that the port's normal (1 byte) buffer
1389 is reinstated in case one of the scm_fill_input () calls
1390 throws an exception; we use the scm_dynwind_* API to achieve
1393 A consequence of this optimization is that the fill_input
1394 functions can't unget characters. That'll push data to the
1395 pushback buffer instead of this psb buffer. */
1397 unsigned char *pback
= pt
->putback_buf
;
1400 psb
.buffer
= buffer
;
1402 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1403 scm_dynwind_rewind_handler (swap_buffer
, &psb
, SCM_F_WIND_EXPLICITLY
);
1404 scm_dynwind_unwind_handler (swap_buffer
, &psb
, SCM_F_WIND_EXPLICITLY
);
1406 /* Call scm_fill_input until we have all the bytes that we need,
1408 while (pt
->read_buf_size
&& (scm_fill_input (port
) != EOF
))
1410 pt
->read_buf_size
-= (pt
->read_end
- pt
->read_pos
);
1411 pt
->read_pos
= pt
->read_buf
= pt
->read_end
;
1414 if (pback
!= pt
->putback_buf
1415 || pt
->read_buf
- (unsigned char *) buffer
< 0)
1416 scm_misc_error (FUNC_NAME
,
1417 "scm_c_read must not call a fill function that pushes "
1418 "back characters onto an unbuffered port", SCM_EOL
);
1420 n_read
+= pt
->read_buf
- (unsigned char *) buffer
;
1422 /* Reinstate the port's normal buffer. */
1427 /* The port has its own buffer. It is important that we use it,
1428 even if it happens to be smaller than our caller's buffer, so
1429 that a custom port implementation's entry points (in
1430 particular, fill_input) can rely on the buffer always being
1431 the same as they first set up. */
1432 while (size
&& (scm_fill_input (port
) != EOF
))
1434 n_available
= min (size
, pt
->read_end
- pt
->read_pos
);
1435 memcpy (buffer
, pt
->read_pos
, n_available
);
1436 buffer
= (char *) buffer
+ n_available
;
1437 pt
->read_pos
+= n_available
;
1438 n_read
+= n_available
;
1439 size
-= n_available
;
1449 * Used by an application to write arbitrary number of bytes to an SCM
1450 * port. Similar semantics as libc write. However, unlike libc
1451 * write, scm_c_write writes the requested number of bytes and has no
1454 * Warning: Doesn't update port line and column counts!
1458 scm_c_write (SCM port
, const void *ptr
, size_t size
)
1459 #define FUNC_NAME "scm_c_write"
1462 scm_t_ptob_descriptor
*ptob
;
1464 SCM_VALIDATE_OPOUTPORT (1, port
);
1466 pt
= SCM_PTAB_ENTRY (port
);
1467 ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
1469 if (pt
->rw_active
== SCM_PORT_READ
)
1470 scm_end_input (port
);
1472 ptob
->write (port
, ptr
, size
);
1475 pt
->rw_active
= SCM_PORT_WRITE
;
1480 scm_flush (SCM port
)
1482 long i
= SCM_PTOBNUM (port
);
1484 (scm_ptobs
[i
].flush
) (port
);
1488 scm_end_input (SCM port
)
1491 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1493 if (pt
->read_buf
== pt
->putback_buf
)
1495 offset
= pt
->read_end
- pt
->read_pos
;
1496 pt
->read_buf
= pt
->saved_read_buf
;
1497 pt
->read_pos
= pt
->saved_read_pos
;
1498 pt
->read_end
= pt
->saved_read_end
;
1499 pt
->read_buf_size
= pt
->saved_read_buf_size
;
1504 scm_ptobs
[SCM_PTOBNUM (port
)].end_input (port
, offset
);
1511 scm_unget_byte (int c
, SCM port
)
1512 #define FUNC_NAME "scm_unget_byte"
1514 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1516 if (pt
->read_buf
== pt
->putback_buf
)
1517 /* already using the put-back buffer. */
1519 /* enlarge putback_buf if necessary. */
1520 if (pt
->read_end
== pt
->read_buf
+ pt
->read_buf_size
1521 && pt
->read_buf
== pt
->read_pos
)
1523 size_t new_size
= pt
->read_buf_size
* 2;
1524 unsigned char *tmp
= (unsigned char *)
1525 scm_gc_realloc (pt
->putback_buf
, pt
->read_buf_size
, new_size
,
1528 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
= tmp
;
1529 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
1530 pt
->read_buf_size
= pt
->putback_buf_size
= new_size
;
1533 /* shift any existing bytes to buffer + 1. */
1534 if (pt
->read_pos
== pt
->read_end
)
1535 pt
->read_end
= pt
->read_buf
+ 1;
1536 else if (pt
->read_pos
!= pt
->read_buf
+ 1)
1538 int count
= pt
->read_end
- pt
->read_pos
;
1540 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
1541 pt
->read_end
= pt
->read_buf
+ 1 + count
;
1544 pt
->read_pos
= pt
->read_buf
;
1547 /* switch to the put-back buffer. */
1549 if (pt
->putback_buf
== NULL
)
1552 = (unsigned char *) scm_gc_malloc_pointerless
1553 (SCM_INITIAL_PUTBACK_BUF_SIZE
, "putback buffer");
1554 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
1557 pt
->saved_read_buf
= pt
->read_buf
;
1558 pt
->saved_read_pos
= pt
->read_pos
;
1559 pt
->saved_read_end
= pt
->read_end
;
1560 pt
->saved_read_buf_size
= pt
->read_buf_size
;
1562 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
1563 pt
->read_end
= pt
->read_buf
+ 1;
1564 pt
->read_buf_size
= pt
->putback_buf_size
;
1570 pt
->rw_active
= SCM_PORT_READ
;
1575 scm_ungetc (scm_t_wchar c
, SCM port
)
1576 #define FUNC_NAME "scm_ungetc"
1578 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1580 char result_buf
[10];
1581 const char *encoding
;
1585 if (pt
->encoding
!= NULL
)
1586 encoding
= pt
->encoding
;
1588 encoding
= "ISO-8859-1";
1590 len
= sizeof (result_buf
);
1591 result
= u32_conv_to_encoding (encoding
,
1592 (enum iconv_ilseq_handler
) pt
->ilseq_handler
,
1593 (uint32_t *) &c
, 1, NULL
,
1596 if (SCM_UNLIKELY (result
== NULL
|| len
== 0))
1600 chr
= scm_integer_to_char (scm_from_uint32 (c
));
1601 scm_encoding_error (FUNC_NAME
, errno
,
1602 "conversion to port encoding failed",
1604 scm_string (scm_list_1 (chr
)));
1607 for (i
= len
- 1; i
>= 0; i
--)
1608 scm_unget_byte (result
[i
], port
);
1610 if (SCM_UNLIKELY (result
!= result_buf
))
1615 /* What should col be in this case?
1616 * We'll leave it at -1.
1618 SCM_LINUM (port
) -= 1;
1627 scm_ungets (const char *s
, int n
, SCM port
)
1629 /* This is simple minded and inefficient, but unreading strings is
1630 * probably not a common operation, and remember that line and
1631 * column numbers have to be handled...
1633 * Please feel free to write an optimized version!
1636 scm_ungetc (s
[n
], port
);
1640 SCM_DEFINE (scm_peek_char
, "peek-char", 0, 1, 0,
1642 "Return the next character available from @var{port},\n"
1643 "@emph{without} updating @var{port} to point to the following\n"
1644 "character. If no more characters are available, the\n"
1645 "end-of-file object is returned.\n"
1647 "The value returned by\n"
1648 "a call to @code{peek-char} is the same as the value that would\n"
1649 "have been returned by a call to @code{read-char} on the same\n"
1650 "port. The only difference is that the very next call to\n"
1651 "@code{read-char} or @code{peek-char} on that @var{port} will\n"
1652 "return the value returned by the preceding call to\n"
1653 "@code{peek-char}. In particular, a call to @code{peek-char} on\n"
1654 "an interactive port will hang waiting for input whenever a call\n"
1655 "to @code{read-char} would have hung.")
1656 #define FUNC_NAME s_scm_peek_char
1660 char bytes
[SCM_MBCHAR_BUF_SIZE
];
1664 if (SCM_UNBNDP (port
))
1665 port
= scm_current_input_port ();
1666 SCM_VALIDATE_OPINPORT (1, port
);
1668 column
= SCM_COL (port
);
1669 line
= SCM_LINUM (port
);
1671 c
= get_codepoint (port
, bytes
, &len
);
1673 result
= SCM_EOF_VAL
;
1678 result
= SCM_MAKE_CHAR (c
);
1680 for (i
= len
- 1; i
>= 0; i
--)
1681 scm_unget_byte (bytes
[i
], port
);
1683 SCM_COL (port
) = column
;
1684 SCM_LINUM (port
) = line
;
1691 SCM_DEFINE (scm_unread_char
, "unread-char", 1, 1, 0,
1692 (SCM cobj
, SCM port
),
1693 "Place @var{char} in @var{port} so that it will be read by the\n"
1694 "next read operation. If called multiple times, the unread characters\n"
1695 "will be read again in last-in first-out order. If @var{port} is\n"
1696 "not supplied, the current input port is used.")
1697 #define FUNC_NAME s_scm_unread_char
1701 SCM_VALIDATE_CHAR (1, cobj
);
1702 if (SCM_UNBNDP (port
))
1703 port
= scm_current_input_port ();
1704 SCM_VALIDATE_OPINPORT (2, port
);
1706 c
= SCM_CHAR (cobj
);
1708 scm_ungetc (c
, port
);
1713 SCM_DEFINE (scm_unread_string
, "unread-string", 2, 0, 0,
1714 (SCM str
, SCM port
),
1715 "Place the string @var{str} in @var{port} so that its characters will be\n"
1716 "read in subsequent read operations. If called multiple times, the\n"
1717 "unread characters will be read again in last-in first-out order. If\n"
1718 "@var{port} is not supplied, the current-input-port is used.")
1719 #define FUNC_NAME s_scm_unread_string
1722 SCM_VALIDATE_STRING (1, str
);
1723 if (SCM_UNBNDP (port
))
1724 port
= scm_current_input_port ();
1725 SCM_VALIDATE_OPINPORT (2, port
);
1727 n
= scm_i_string_length (str
);
1730 scm_ungetc (scm_i_string_ref (str
, n
), port
);
1736 SCM_DEFINE (scm_seek
, "seek", 3, 0, 0,
1737 (SCM fd_port
, SCM offset
, SCM whence
),
1738 "Sets the current position of @var{fd/port} to the integer\n"
1739 "@var{offset}, which is interpreted according to the value of\n"
1742 "One of the following variables should be supplied for\n"
1744 "@defvar SEEK_SET\n"
1745 "Seek from the beginning of the file.\n"
1747 "@defvar SEEK_CUR\n"
1748 "Seek from the current position.\n"
1750 "@defvar SEEK_END\n"
1751 "Seek from the end of the file.\n"
1753 "If @var{fd/port} is a file descriptor, the underlying system\n"
1754 "call is @code{lseek}. @var{port} may be a string port.\n"
1756 "The value returned is the new position in the file. This means\n"
1757 "that the current position of a port can be obtained using:\n"
1759 "(seek port 0 SEEK_CUR)\n"
1761 #define FUNC_NAME s_scm_seek
1765 fd_port
= SCM_COERCE_OUTPORT (fd_port
);
1767 how
= scm_to_int (whence
);
1768 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
1769 SCM_OUT_OF_RANGE (3, whence
);
1771 if (SCM_OPPORTP (fd_port
))
1773 scm_t_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (fd_port
);
1774 off_t_or_off64_t off
= scm_to_off_t_or_off64_t (offset
);
1775 off_t_or_off64_t rv
;
1778 SCM_MISC_ERROR ("port is not seekable",
1779 scm_cons (fd_port
, SCM_EOL
));
1781 rv
= ptob
->seek (fd_port
, off
, how
);
1782 return scm_from_off_t_or_off64_t (rv
);
1784 else /* file descriptor?. */
1786 off_t_or_off64_t off
= scm_to_off_t_or_off64_t (offset
);
1787 off_t_or_off64_t rv
;
1788 rv
= lseek_or_lseek64 (scm_to_int (fd_port
), off
, how
);
1791 return scm_from_off_t_or_off64_t (rv
);
1800 /* Mingw has ftruncate(), perhaps implemented above using chsize, but
1801 doesn't have the filename version truncate(), hence this code. */
1802 #if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
1804 truncate (const char *file
, off_t length
)
1808 fdes
= open (file
, O_BINARY
| O_WRONLY
);
1812 ret
= ftruncate (fdes
, length
);
1815 int save_errno
= errno
;
1821 return close (fdes
);
1823 #endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
1825 SCM_DEFINE (scm_truncate_file
, "truncate-file", 1, 1, 0,
1826 (SCM object
, SCM length
),
1827 "Truncate @var{file} to @var{length} bytes. @var{file} can be a\n"
1828 "filename string, a port object, or an integer file descriptor.\n"
1829 "The return value is unspecified.\n"
1831 "For a port or file descriptor @var{length} can be omitted, in\n"
1832 "which case the file is truncated at the current position (per\n"
1833 "@code{ftell} above).\n"
1835 "On most systems a file can be extended by giving a length\n"
1836 "greater than the current size, but this is not mandatory in the\n"
1838 #define FUNC_NAME s_scm_truncate_file
1842 /* "object" can be a port, fdes or filename.
1844 Negative "length" makes no sense, but it's left to truncate() or
1845 ftruncate() to give back an error for that (normally EINVAL).
1848 if (SCM_UNBNDP (length
))
1850 /* must supply length if object is a filename. */
1851 if (scm_is_string (object
))
1852 SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL
);
1854 length
= scm_seek (object
, SCM_INUM0
, scm_from_int (SEEK_CUR
));
1857 object
= SCM_COERCE_OUTPORT (object
);
1858 if (scm_is_integer (object
))
1860 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
1861 SCM_SYSCALL (rv
= ftruncate_or_ftruncate64 (scm_to_int (object
),
1864 else if (SCM_OPOUTPORTP (object
))
1866 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
1867 scm_t_port
*pt
= SCM_PTAB_ENTRY (object
);
1868 scm_t_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1870 if (!ptob
->truncate
)
1871 SCM_MISC_ERROR ("port is not truncatable", SCM_EOL
);
1872 if (pt
->rw_active
== SCM_PORT_READ
)
1873 scm_end_input (object
);
1874 else if (pt
->rw_active
== SCM_PORT_WRITE
)
1875 ptob
->flush (object
);
1877 ptob
->truncate (object
, c_length
);
1882 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
1883 char *str
= scm_to_locale_string (object
);
1885 SCM_SYSCALL (rv
= truncate_or_truncate64 (str
, c_length
));
1892 return SCM_UNSPECIFIED
;
1896 SCM_DEFINE (scm_port_line
, "port-line", 1, 0, 0,
1898 "Return the current line number for @var{port}.\n"
1900 "The first line of a file is 0. But you might want to add 1\n"
1901 "when printing line numbers, since starting from 1 is\n"
1902 "traditional in error messages, and likely to be more natural to\n"
1904 #define FUNC_NAME s_scm_port_line
1906 port
= SCM_COERCE_OUTPORT (port
);
1907 SCM_VALIDATE_OPENPORT (1, port
);
1908 return scm_from_long (SCM_LINUM (port
));
1912 SCM_DEFINE (scm_set_port_line_x
, "set-port-line!", 2, 0, 0,
1913 (SCM port
, SCM line
),
1914 "Set the current line number for @var{port} to @var{line}. The\n"
1915 "first line of a file is 0.")
1916 #define FUNC_NAME s_scm_set_port_line_x
1918 port
= SCM_COERCE_OUTPORT (port
);
1919 SCM_VALIDATE_OPENPORT (1, port
);
1920 SCM_PTAB_ENTRY (port
)->line_number
= scm_to_long (line
);
1921 return SCM_UNSPECIFIED
;
1925 SCM_DEFINE (scm_port_column
, "port-column", 1, 0, 0,
1927 "Return the current column number of @var{port}.\n"
1928 "If the number is\n"
1929 "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
1930 "- i.e. the first character of the first line is line 0, column 0.\n"
1931 "(However, when you display a file position, for example in an error\n"
1932 "message, we recommend you add 1 to get 1-origin integers. This is\n"
1933 "because lines and column numbers traditionally start with 1, and that is\n"
1934 "what non-programmers will find most natural.)")
1935 #define FUNC_NAME s_scm_port_column
1937 port
= SCM_COERCE_OUTPORT (port
);
1938 SCM_VALIDATE_OPENPORT (1, port
);
1939 return scm_from_int (SCM_COL (port
));
1943 SCM_DEFINE (scm_set_port_column_x
, "set-port-column!", 2, 0, 0,
1944 (SCM port
, SCM column
),
1945 "Set the current column of @var{port}. Before reading the first\n"
1946 "character on a line the column should be 0.")
1947 #define FUNC_NAME s_scm_set_port_column_x
1949 port
= SCM_COERCE_OUTPORT (port
);
1950 SCM_VALIDATE_OPENPORT (1, port
);
1951 SCM_PTAB_ENTRY (port
)->column_number
= scm_to_int (column
);
1952 return SCM_UNSPECIFIED
;
1956 SCM_DEFINE (scm_port_filename
, "port-filename", 1, 0, 0,
1958 "Return the filename associated with @var{port}. This function returns\n"
1959 "the strings \"standard input\", \"standard output\" and \"standard error\"\n"
1960 "when called on the current input, output and error ports respectively.")
1961 #define FUNC_NAME s_scm_port_filename
1963 port
= SCM_COERCE_OUTPORT (port
);
1964 SCM_VALIDATE_OPENPORT (1, port
);
1965 return SCM_FILENAME (port
);
1969 SCM_DEFINE (scm_set_port_filename_x
, "set-port-filename!", 2, 0, 0,
1970 (SCM port
, SCM filename
),
1971 "Change the filename associated with @var{port}, using the current input\n"
1972 "port if none is specified. Note that this does not change the port's\n"
1973 "source of data, but only the value that is returned by\n"
1974 "@code{port-filename} and reported in diagnostic output.")
1975 #define FUNC_NAME s_scm_set_port_filename_x
1977 port
= SCM_COERCE_OUTPORT (port
);
1978 SCM_VALIDATE_OPENPORT (1, port
);
1979 /* We allow the user to set the filename to whatever he likes. */
1980 SCM_SET_FILENAME (port
, filename
);
1981 return SCM_UNSPECIFIED
;
1985 /* A fluid specifying the default encoding for newly created ports. If it is
1986 a string, that is the encoding. If it is #f, it is in the "native"
1987 (Latin-1) encoding. */
1988 SCM_VARIABLE (default_port_encoding_var
, "%default-port-encoding");
1990 static int scm_port_encoding_init
= 0;
1992 /* Return a C string representation of the current encoding. */
1994 scm_i_get_port_encoding (SCM port
)
1998 if (scm_is_false (port
))
2000 if (!scm_port_encoding_init
)
2002 else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var
)))
2006 encoding
= scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var
));
2007 if (!scm_is_string (encoding
))
2010 return scm_i_string_chars (encoding
);
2016 pt
= SCM_PTAB_ENTRY (port
);
2018 return pt
->encoding
;
2024 /* Returns ENC if it is a recognized encoding. If it isn't, it tries
2025 to find an alias of ENC that is valid. Otherwise, it returns
2028 find_valid_encoding (const char *enc
)
2031 const char str
[] = " ";
2032 scm_t_uint32 result_buf
;
2036 u32len
= sizeof (result_buf
) / sizeof (scm_t_uint32
);
2037 u32
= u32_conv_from_encoding (enc
, iconveh_error
, str
, 1,
2038 NULL
, &result_buf
, &u32len
);
2039 isvalid
= (u32
!= NULL
);
2041 if (SCM_UNLIKELY (u32
!= &result_buf
))
2051 scm_i_set_port_encoding_x (SCM port
, const char *enc
)
2053 const char *valid_enc
;
2056 /* Null is shorthand for the native, Latin-1 encoding. */
2061 valid_enc
= find_valid_encoding (enc
);
2062 if (valid_enc
== NULL
)
2065 err
= scm_from_locale_string (enc
);
2066 scm_misc_error (NULL
, "invalid or unknown character encoding ~s",
2071 if (scm_is_false (port
))
2073 /* Set the default encoding for future ports. */
2074 if (!scm_port_encoding_init
2075 || !scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var
)))
2076 scm_misc_error (NULL
, "tried to set port encoding fluid before it is initialized",
2079 if (valid_enc
== NULL
2080 || !strcmp (valid_enc
, "ASCII")
2081 || !strcmp (valid_enc
, "ANSI_X3.4-1968")
2082 || !strcmp (valid_enc
, "ISO-8859-1"))
2083 scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var
), SCM_BOOL_F
);
2085 scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var
),
2086 scm_from_locale_string (valid_enc
));
2090 /* Set the character encoding for this port. */
2091 pt
= SCM_PTAB_ENTRY (port
);
2092 if (valid_enc
== NULL
)
2093 pt
->encoding
= NULL
;
2095 pt
->encoding
= scm_gc_strdup (valid_enc
, "port");
2099 SCM_DEFINE (scm_port_encoding
, "port-encoding", 1, 0, 0,
2101 "Returns, as a string, the character encoding that @var{port}\n"
2102 "uses to interpret its input and output.\n")
2103 #define FUNC_NAME s_scm_port_encoding
2108 SCM_VALIDATE_PORT (1, port
);
2110 pt
= SCM_PTAB_ENTRY (port
);
2111 enc
= scm_i_get_port_encoding (port
);
2113 return scm_from_locale_string (pt
->encoding
);
2119 SCM_DEFINE (scm_set_port_encoding_x
, "set-port-encoding!", 2, 0, 0,
2120 (SCM port
, SCM enc
),
2121 "Sets the character encoding that will be used to interpret all\n"
2122 "port I/O. New ports are created with the encoding\n"
2123 "appropriate for the current locale if @code{setlocale} has \n"
2124 "been called or ISO-8859-1 otherwise\n"
2125 "and this procedure can be used to modify that encoding.\n")
2126 #define FUNC_NAME s_scm_set_port_encoding_x
2129 const char *valid_enc_str
;
2131 SCM_VALIDATE_PORT (1, port
);
2132 SCM_VALIDATE_STRING (2, enc
);
2134 enc_str
= scm_to_locale_string (enc
);
2135 valid_enc_str
= find_valid_encoding (enc_str
);
2136 if (valid_enc_str
== NULL
)
2139 scm_misc_error (FUNC_NAME
, "invalid or unknown character encoding ~s",
2144 scm_i_set_port_encoding_x (port
, valid_enc_str
);
2147 return SCM_UNSPECIFIED
;
2152 /* This determines how conversions handle unconvertible characters. */
2153 SCM_GLOBAL_VARIABLE (scm_conversion_strategy
, "%port-conversion-strategy");
2154 static int scm_conversion_strategy_init
= 0;
2156 scm_t_string_failed_conversion_handler
2157 scm_i_get_conversion_strategy (SCM port
)
2161 if (scm_is_false (port
))
2163 if (!scm_conversion_strategy_init
2164 || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy
)))
2165 return SCM_FAILED_CONVERSION_QUESTION_MARK
;
2168 encoding
= scm_fluid_ref (SCM_VARIABLE_REF (scm_conversion_strategy
));
2169 if (scm_is_false (encoding
))
2170 return SCM_FAILED_CONVERSION_QUESTION_MARK
;
2172 return (scm_t_string_failed_conversion_handler
) scm_to_int (encoding
);
2178 pt
= SCM_PTAB_ENTRY (port
);
2179 return pt
->ilseq_handler
;
2185 scm_i_set_conversion_strategy_x (SCM port
,
2186 scm_t_string_failed_conversion_handler handler
)
2191 strategy
= scm_from_int ((int) handler
);
2193 if (scm_is_false (port
))
2195 /* Set the default encoding for future ports. */
2196 if (!scm_conversion_strategy
2197 || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy
)))
2198 scm_misc_error (NULL
, "tried to set conversion strategy fluid before it is initialized",
2200 scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy
), strategy
);
2204 /* Set the character encoding for this port. */
2205 pt
= SCM_PTAB_ENTRY (port
);
2206 pt
->ilseq_handler
= handler
;
2210 SCM_DEFINE (scm_port_conversion_strategy
, "port-conversion-strategy",
2211 1, 0, 0, (SCM port
),
2212 "Returns the behavior of the port when handling a character that\n"
2213 "is not representable in the port's current encoding.\n"
2214 "It returns the symbol @code{error} if unrepresentable characters\n"
2215 "should cause exceptions, @code{substitute} if the port should\n"
2216 "try to replace unrepresentable characters with question marks or\n"
2217 "approximate characters, or @code{escape} if unrepresentable\n"
2218 "characters should be converted to string escapes.\n"
2220 "If @var{port} is @code{#f}, then the current default behavior\n"
2221 "will be returned. New ports will have this default behavior\n"
2222 "when they are created.\n")
2223 #define FUNC_NAME s_scm_port_conversion_strategy
2225 scm_t_string_failed_conversion_handler h
;
2227 SCM_VALIDATE_OPPORT (1, port
);
2229 if (!scm_is_false (port
))
2231 SCM_VALIDATE_OPPORT (1, port
);
2234 h
= scm_i_get_conversion_strategy (port
);
2235 if (h
== SCM_FAILED_CONVERSION_ERROR
)
2236 return scm_from_latin1_symbol ("error");
2237 else if (h
== SCM_FAILED_CONVERSION_QUESTION_MARK
)
2238 return scm_from_latin1_symbol ("substitute");
2239 else if (h
== SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE
)
2240 return scm_from_latin1_symbol ("escape");
2244 /* Never gets here. */
2245 return SCM_UNDEFINED
;
2249 SCM_DEFINE (scm_set_port_conversion_strategy_x
, "set-port-conversion-strategy!",
2251 (SCM port
, SCM sym
),
2252 "Sets the behavior of the interpreter when outputting a character\n"
2253 "that is not representable in the port's current encoding.\n"
2254 "@var{sym} can be either @code{'error}, @code{'substitute}, or\n"
2255 "@code{'escape}. If it is @code{'error}, an error will be thrown\n"
2256 "when an unconvertible character is encountered. If it is\n"
2257 "@code{'substitute}, then unconvertible characters will \n"
2258 "be replaced with approximate characters, or with question marks\n"
2259 "if no approximately correct character is available.\n"
2260 "If it is @code{'escape},\n"
2261 "it will appear as a hex escape when output.\n"
2263 "If @var{port} is an open port, the conversion error behavior\n"
2264 "is set for that port. If it is @code{#f}, it is set as the\n"
2265 "default behavior for any future ports that get created in\n"
2267 #define FUNC_NAME s_scm_set_port_conversion_strategy_x
2273 if (!scm_is_false (port
))
2275 SCM_VALIDATE_OPPORT (1, port
);
2278 err
= scm_from_latin1_symbol ("error");
2279 if (scm_is_true (scm_eqv_p (sym
, err
)))
2281 scm_i_set_conversion_strategy_x (port
, SCM_FAILED_CONVERSION_ERROR
);
2282 return SCM_UNSPECIFIED
;
2285 qm
= scm_from_latin1_symbol ("substitute");
2286 if (scm_is_true (scm_eqv_p (sym
, qm
)))
2288 scm_i_set_conversion_strategy_x (port
,
2289 SCM_FAILED_CONVERSION_QUESTION_MARK
);
2290 return SCM_UNSPECIFIED
;
2293 esc
= scm_from_latin1_symbol ("escape");
2294 if (scm_is_true (scm_eqv_p (sym
, esc
)))
2296 scm_i_set_conversion_strategy_x (port
,
2297 SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE
);
2298 return SCM_UNSPECIFIED
;
2301 SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym
));
2303 return SCM_UNSPECIFIED
;
2310 scm_print_port_mode (SCM exp
, SCM port
)
2312 scm_puts (SCM_CLOSEDP (exp
)
2314 : (SCM_RDNG
& SCM_CELL_WORD_0 (exp
)
2315 ? (SCM_WRTNG
& SCM_CELL_WORD_0 (exp
)
2318 : (SCM_WRTNG
& SCM_CELL_WORD_0 (exp
)
2325 scm_port_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2327 char *type
= SCM_PTOBNAME (SCM_PTOBNUM (exp
));
2330 scm_puts ("#<", port
);
2331 scm_print_port_mode (exp
, port
);
2332 scm_puts (type
, port
);
2333 scm_putc (' ', port
);
2334 scm_uintprint (SCM_CELL_WORD_1 (exp
), 16, port
);
2335 scm_putc ('>', port
);
2343 scm_t_bits scm_tc16_void_port
= 0;
2345 static int fill_input_void_port (SCM port SCM_UNUSED
)
2351 write_void_port (SCM port SCM_UNUSED
,
2352 const void *data SCM_UNUSED
,
2353 size_t size SCM_UNUSED
)
2358 scm_i_void_port (long mode_bits
)
2360 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
2362 SCM answer
= scm_new_port_table_entry (scm_tc16_void_port
);
2363 scm_t_port
* pt
= SCM_PTAB_ENTRY(answer
);
2365 scm_port_non_buffer (pt
);
2367 SCM_SETSTREAM (answer
, 0);
2368 SCM_SET_CELL_TYPE (answer
, scm_tc16_void_port
| mode_bits
);
2369 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
2375 scm_void_port (char *mode_str
)
2377 return scm_i_void_port (scm_mode_bits (mode_str
));
2380 SCM_DEFINE (scm_sys_make_void_port
, "%make-void-port", 1, 0, 0,
2382 "Create and return a new void port. A void port acts like\n"
2383 "@file{/dev/null}. The @var{mode} argument\n"
2384 "specifies the input/output modes for this port: see the\n"
2385 "documentation for @code{open-file} in @ref{File Ports}.")
2386 #define FUNC_NAME s_scm_sys_make_void_port
2388 return scm_i_void_port (scm_i_mode_bits (mode
));
2393 /* Initialization. */
2398 /* lseek() symbols. */
2399 scm_c_define ("SEEK_SET", scm_from_int (SEEK_SET
));
2400 scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR
));
2401 scm_c_define ("SEEK_END", scm_from_int (SEEK_END
));
2403 scm_tc16_void_port
= scm_make_port_type ("void", fill_input_void_port
,
2406 cur_inport_fluid
= scm_make_fluid ();
2407 cur_outport_fluid
= scm_make_fluid ();
2408 cur_errport_fluid
= scm_make_fluid ();
2409 cur_loadport_fluid
= scm_make_fluid ();
2411 scm_i_port_weak_hash
= scm_make_weak_key_hash_table (SCM_I_MAKINUM(31));
2413 #include "libguile/ports.x"
2415 /* Use Latin-1 as the default port encoding. */
2416 SCM_VARIABLE_SET (default_port_encoding_var
, scm_make_fluid ());
2417 scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var
), SCM_BOOL_F
);
2418 scm_port_encoding_init
= 1;
2420 SCM_VARIABLE_SET (scm_conversion_strategy
, scm_make_fluid ());
2421 scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy
),
2422 scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK
));
2423 scm_conversion_strategy_init
= 1;