1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007 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
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but 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 02110-1301 USA
22 #define _LARGEFILE64_SOURCE /* ask for stat64 etc */
30 #include <fcntl.h> /* for chsize on mingw */
34 #include "libguile/_scm.h"
35 #include "libguile/async.h"
36 #include "libguile/eval.h"
37 #include "libguile/fports.h" /* direct access for seek and truncate */
38 #include "libguile/objects.h"
39 #include "libguile/goops.h"
40 #include "libguile/smob.h"
41 #include "libguile/chars.h"
42 #include "libguile/dynwind.h"
44 #include "libguile/keywords.h"
45 #include "libguile/hashtab.h"
46 #include "libguile/root.h"
47 #include "libguile/strings.h"
48 #include "libguile/mallocs.h"
49 #include "libguile/validate.h"
50 #include "libguile/ports.h"
51 #include "libguile/vectors.h"
52 #include "libguile/weaks.h"
53 #include "libguile/fluids.h"
67 #ifdef HAVE_SYS_IOCTL_H
68 #include <sys/ioctl.h>
71 /* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
72 already, but have this code here in case that wasn't so in past versions,
73 or perhaps to help other minimal DOS environments.
75 gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
76 might be possibilities if we've got other systems without ftruncate. */
78 #if HAVE_CHSIZE && ! HAVE_FTRUNCATE
79 #define ftruncate(fd, size) chsize (fd, size)
81 #define HAVE_FTRUNCATE 1
85 /* The port kind table --- a dynamically resized array of port types. */
88 /* scm_ptobs scm_numptob
89 * implement a dynamically resized array of ptob records.
90 * Indexes into this table are used when generating type
91 * tags for smobjects (if you know a tag you can get an index and conversely).
93 scm_t_ptob_descriptor
*scm_ptobs
;
96 /* GC marker for a port with stream of SCM type. */
98 scm_markstream (SCM ptr
)
101 openp
= SCM_CELL_WORD_0 (ptr
) & SCM_OPN
;
103 return SCM_PACK (SCM_STREAM (ptr
));
109 * We choose to use an interface similar to the smob interface with
110 * fill_input and write as standard fields, passed to the port
111 * type constructor, and optional fields set by setters.
115 flush_port_default (SCM port SCM_UNUSED
)
120 end_input_default (SCM port SCM_UNUSED
, int offset SCM_UNUSED
)
125 scm_port_free0 (SCM port
)
131 scm_make_port_type (char *name
,
132 int (*fill_input
) (SCM port
),
133 void (*write
) (SCM port
, const void *data
, size_t size
))
136 if (255 <= scm_numptob
)
138 SCM_CRITICAL_SECTION_START
;
139 tmp
= (char *) scm_gc_realloc ((char *) scm_ptobs
,
140 scm_numptob
* sizeof (scm_t_ptob_descriptor
),
142 * sizeof (scm_t_ptob_descriptor
),
146 scm_ptobs
= (scm_t_ptob_descriptor
*) tmp
;
148 scm_ptobs
[scm_numptob
].name
= name
;
149 scm_ptobs
[scm_numptob
].mark
= 0;
150 scm_ptobs
[scm_numptob
].free
= scm_port_free0
;
151 scm_ptobs
[scm_numptob
].print
= scm_port_print
;
152 scm_ptobs
[scm_numptob
].equalp
= 0;
153 scm_ptobs
[scm_numptob
].close
= 0;
155 scm_ptobs
[scm_numptob
].write
= write
;
156 scm_ptobs
[scm_numptob
].flush
= flush_port_default
;
158 scm_ptobs
[scm_numptob
].end_input
= end_input_default
;
159 scm_ptobs
[scm_numptob
].fill_input
= fill_input
;
160 scm_ptobs
[scm_numptob
].input_waiting
= 0;
162 scm_ptobs
[scm_numptob
].seek
= 0;
163 scm_ptobs
[scm_numptob
].truncate
= 0;
167 SCM_CRITICAL_SECTION_END
;
171 scm_memory_error ("scm_make_port_type");
173 /* Make a class object if Goops is present */
175 scm_make_port_classes (scm_numptob
- 1, SCM_PTOBNAME (scm_numptob
- 1));
176 return scm_tc7_port
+ (scm_numptob
- 1) * 256;
180 scm_set_port_mark (scm_t_bits tc
, SCM (*mark
) (SCM
))
182 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].mark
= mark
;
186 scm_set_port_free (scm_t_bits tc
, size_t (*free
) (SCM
))
188 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].free
= free
;
192 scm_set_port_print (scm_t_bits tc
, int (*print
) (SCM exp
, SCM port
,
193 scm_print_state
*pstate
))
195 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].print
= print
;
199 scm_set_port_equalp (scm_t_bits tc
, SCM (*equalp
) (SCM
, SCM
))
201 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].equalp
= equalp
;
205 scm_set_port_flush (scm_t_bits tc
, void (*flush
) (SCM port
))
207 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].flush
= flush
;
211 scm_set_port_end_input (scm_t_bits tc
, void (*end_input
) (SCM port
, int offset
))
213 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].end_input
= end_input
;
217 scm_set_port_close (scm_t_bits tc
, int (*close
) (SCM
))
219 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].close
= close
;
223 scm_set_port_seek (scm_t_bits tc
, off_t (*seek
) (SCM port
,
227 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].seek
= seek
;
231 scm_set_port_truncate (scm_t_bits tc
, void (*truncate
) (SCM port
, off_t length
))
233 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].truncate
= truncate
;
237 scm_set_port_input_waiting (scm_t_bits tc
, int (*input_waiting
) (SCM
))
239 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].input_waiting
= input_waiting
;
244 SCM_DEFINE (scm_char_ready_p
, "char-ready?", 0, 1, 0,
246 "Return @code{#t} if a character is ready on input @var{port}\n"
247 "and return @code{#f} otherwise. If @code{char-ready?} returns\n"
248 "@code{#t} then the next @code{read-char} operation on\n"
249 "@var{port} is guaranteed not to hang. If @var{port} is a file\n"
250 "port at end of file then @code{char-ready?} returns @code{#t}.\n"
252 "@code{char-ready?} exists to make it possible for a\n"
253 "program to accept characters from interactive ports without\n"
254 "getting stuck waiting for input. Any input editors associated\n"
255 "with such ports must make sure that characters whose existence\n"
256 "has been asserted by @code{char-ready?} cannot be rubbed out.\n"
257 "If @code{char-ready?} were to return @code{#f} at end of file,\n"
258 "a port at end of file would be indistinguishable from an\n"
259 "interactive port that has no ready characters.")
260 #define FUNC_NAME s_scm_char_ready_p
264 if (SCM_UNBNDP (port
))
265 port
= scm_current_input_port ();
267 SCM_VALIDATE_OPINPORT (1, port
);
269 pt
= SCM_PTAB_ENTRY (port
);
271 /* if the current read buffer is filled, or the
272 last pushed-back char has been read and the saved buffer is
273 filled, result is true. */
274 if (pt
->read_pos
< pt
->read_end
275 || (pt
->read_buf
== pt
->putback_buf
276 && pt
->saved_read_pos
< pt
->saved_read_end
))
280 scm_t_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
282 if (ptob
->input_waiting
)
283 return scm_from_bool(ptob
->input_waiting (port
));
290 /* move up to read_len chars from port's putback and/or read buffers
291 into memory starting at dest. returns the number of chars moved. */
292 size_t scm_take_from_input_buffers (SCM port
, char *dest
, size_t read_len
)
294 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
295 size_t chars_read
= 0;
296 size_t from_buf
= min (pt
->read_end
- pt
->read_pos
, read_len
);
300 memcpy (dest
, pt
->read_pos
, from_buf
);
301 pt
->read_pos
+= from_buf
;
302 chars_read
+= from_buf
;
303 read_len
-= from_buf
;
307 /* if putback was active, try the real input buffer too. */
308 if (pt
->read_buf
== pt
->putback_buf
)
310 from_buf
= min (pt
->saved_read_end
- pt
->saved_read_pos
, read_len
);
313 memcpy (dest
, pt
->saved_read_pos
, from_buf
);
314 pt
->saved_read_pos
+= from_buf
;
315 chars_read
+= from_buf
;
321 /* Clear a port's read buffers, returning the contents. */
322 SCM_DEFINE (scm_drain_input
, "drain-input", 1, 0, 0,
324 "This procedure clears a port's input buffers, similar\n"
325 "to the way that force-output clears the output buffer. The\n"
326 "contents of the buffers are returned as a single string, e.g.,\n"
329 "(define p (open-input-file ...))\n"
330 "(drain-input p) => empty string, nothing buffered yet.\n"
331 "(unread-char (read-char p) p)\n"
332 "(drain-input p) => initial chars from p, up to the buffer size.\n"
334 "Draining the buffers may be useful for cleanly finishing\n"
335 "buffered I/O so that the file descriptor can be used directly\n"
336 "for further input.")
337 #define FUNC_NAME s_scm_drain_input
344 SCM_VALIDATE_OPINPORT (1, port
);
345 pt
= SCM_PTAB_ENTRY (port
);
347 count
= pt
->read_end
- pt
->read_pos
;
348 if (pt
->read_buf
== pt
->putback_buf
)
349 count
+= pt
->saved_read_end
- pt
->saved_read_pos
;
351 result
= scm_i_make_string (count
, &data
);
352 scm_take_from_input_buffers (port
, data
, count
);
358 /* Standard ports --- current input, output, error, and more(!). */
360 static SCM cur_inport_fluid
;
361 static SCM cur_outport_fluid
;
362 static SCM cur_errport_fluid
;
363 static SCM cur_loadport_fluid
;
365 SCM_DEFINE (scm_current_input_port
, "current-input-port", 0, 0, 0,
367 "Return the current input port. This is the default port used\n"
368 "by many input procedures. Initially, @code{current-input-port}\n"
369 "returns the @dfn{standard input} in Unix and C terminology.")
370 #define FUNC_NAME s_scm_current_input_port
372 return scm_fluid_ref (cur_inport_fluid
);
376 SCM_DEFINE (scm_current_output_port
, "current-output-port", 0, 0, 0,
378 "Return the current output port. This is the default port used\n"
379 "by many output procedures. Initially,\n"
380 "@code{current-output-port} returns the @dfn{standard output} in\n"
381 "Unix and C terminology.")
382 #define FUNC_NAME s_scm_current_output_port
384 return scm_fluid_ref (cur_outport_fluid
);
388 SCM_DEFINE (scm_current_error_port
, "current-error-port", 0, 0, 0,
390 "Return the port to which errors and warnings should be sent (the\n"
391 "@dfn{standard error} in Unix and C terminology).")
392 #define FUNC_NAME s_scm_current_error_port
394 return scm_fluid_ref (cur_errport_fluid
);
398 SCM_DEFINE (scm_current_load_port
, "current-load-port", 0, 0, 0,
400 "Return the current-load-port.\n"
401 "The load port is used internally by @code{primitive-load}.")
402 #define FUNC_NAME s_scm_current_load_port
404 return scm_fluid_ref (cur_loadport_fluid
);
408 SCM_DEFINE (scm_set_current_input_port
, "set-current-input-port", 1, 0, 0,
410 "@deffnx {Scheme Procedure} set-current-output-port port\n"
411 "@deffnx {Scheme Procedure} set-current-error-port port\n"
412 "Change the ports returned by @code{current-input-port},\n"
413 "@code{current-output-port} and @code{current-error-port}, respectively,\n"
414 "so that they use the supplied @var{port} for input or output.")
415 #define FUNC_NAME s_scm_set_current_input_port
417 SCM oinp
= scm_fluid_ref (cur_inport_fluid
);
418 SCM_VALIDATE_OPINPORT (1, port
);
419 scm_fluid_set_x (cur_inport_fluid
, port
);
425 SCM_DEFINE (scm_set_current_output_port
, "set-current-output-port", 1, 0, 0,
427 "Set the current default output port to @var{port}.")
428 #define FUNC_NAME s_scm_set_current_output_port
430 SCM ooutp
= scm_fluid_ref (cur_outport_fluid
);
431 port
= SCM_COERCE_OUTPORT (port
);
432 SCM_VALIDATE_OPOUTPORT (1, port
);
433 scm_fluid_set_x (cur_outport_fluid
, port
);
439 SCM_DEFINE (scm_set_current_error_port
, "set-current-error-port", 1, 0, 0,
441 "Set the current default error port to @var{port}.")
442 #define FUNC_NAME s_scm_set_current_error_port
444 SCM oerrp
= scm_fluid_ref (cur_errport_fluid
);
445 port
= SCM_COERCE_OUTPORT (port
);
446 SCM_VALIDATE_OPOUTPORT (1, port
);
447 scm_fluid_set_x (cur_errport_fluid
, port
);
453 scm_dynwind_current_input_port (SCM port
)
454 #define FUNC_NAME NULL
456 SCM_VALIDATE_OPINPORT (1, port
);
457 scm_dynwind_fluid (cur_inport_fluid
, port
);
462 scm_dynwind_current_output_port (SCM port
)
463 #define FUNC_NAME NULL
465 port
= SCM_COERCE_OUTPORT (port
);
466 SCM_VALIDATE_OPOUTPORT (1, port
);
467 scm_dynwind_fluid (cur_outport_fluid
, port
);
472 scm_dynwind_current_error_port (SCM port
)
473 #define FUNC_NAME NULL
475 port
= SCM_COERCE_OUTPORT (port
);
476 SCM_VALIDATE_OPOUTPORT (1, port
);
477 scm_dynwind_fluid (cur_errport_fluid
, port
);
482 scm_i_dynwind_current_load_port (SCM port
)
484 scm_dynwind_fluid (cur_loadport_fluid
, port
);
488 /* The port table --- an array of pointers to ports. */
491 We need a global registry of ports to flush them all at exit, and to
492 get all the ports matching a file descriptor.
494 SCM scm_i_port_weak_hash
;
496 scm_i_pthread_mutex_t scm_i_port_table_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
499 /* Port finalization. */
502 static void finalize_port (GC_PTR
, GC_PTR
);
504 /* Register a finalizer for PORT, if needed by its port type. */
505 static SCM_C_INLINE_KEYWORD
void
506 register_finalizer_for_port (SCM port
)
510 port_type
= SCM_TC2PTOBNUM (SCM_CELL_TYPE (port
));
511 if (scm_ptobs
[port_type
].free
)
513 GC_finalization_proc prev_finalizer
;
514 GC_PTR prev_finalization_data
;
516 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (port
), finalize_port
, 0,
518 &prev_finalization_data
);
522 /* Finalize the object (a port) pointed to by PTR. */
524 finalize_port (GC_PTR ptr
, GC_PTR data
)
527 SCM port
= PTR2SCM (ptr
);
529 if (!SCM_PORTP (port
))
532 if (SCM_OPENP (port
))
534 if (SCM_REVEALED (port
) > 0)
535 /* Keep "revealed" ports alive and re-register a finalizer. */
536 register_finalizer_for_port (port
);
539 port_type
= SCM_TC2PTOBNUM (SCM_CELL_TYPE (port
));
540 if (port_type
>= scm_numptob
)
543 if (scm_ptobs
[port_type
].free
)
544 /* Yes, I really do mean `.free' rather than `.close'. `.close'
545 is for explicit `close-port' by user. */
546 scm_ptobs
[port_type
].free (port
);
548 SCM_SETSTREAM (port
, 0);
549 SCM_CLR_PORT_OPEN_FLAG (port
);
550 scm_remove_from_port_table (port
);
552 scm_gc_ports_collected
++;
561 /* This function is not and should not be thread safe. */
563 scm_new_port_table_entry (scm_t_bits tag
)
564 #define FUNC_NAME "scm_new_port_table_entry"
567 We initialize the cell to empty, this is in case scm_gc_calloc
568 triggers GC ; we don't want the GC to scan a half-finished Z.
571 SCM z
= scm_cons (SCM_EOL
, SCM_EOL
);
572 scm_t_port
*entry
= (scm_t_port
*) scm_gc_calloc (sizeof (scm_t_port
), "port");
574 entry
->file_name
= SCM_BOOL_F
;
575 entry
->rw_active
= SCM_PORT_NEITHER
;
578 SCM_SET_CELL_TYPE (z
, tag
);
579 SCM_SETPTAB_ENTRY (z
, entry
);
581 scm_hashq_set_x (scm_i_port_weak_hash
, z
, SCM_BOOL_F
);
583 /* For each new port, register a finalizer so that it port type's free
584 function can be invoked eventually. */
585 register_finalizer_for_port (z
);
591 #if SCM_ENABLE_DEPRECATED==1
593 scm_add_to_port_table (SCM port
)
595 SCM z
= scm_new_port_table_entry (scm_tc7_port
);
596 scm_t_port
* pt
= SCM_PTAB_ENTRY(z
);
599 SCM_SETCAR (z
, SCM_EOL
);
600 SCM_SETCDR (z
, SCM_EOL
);
601 SCM_SETPTAB_ENTRY (port
, pt
);
607 /* Remove a port from the table and destroy it. */
609 /* This function is not and should not be thread safe. */
611 scm_i_remove_port (SCM port
)
612 #define FUNC_NAME "scm_remove_port"
614 scm_t_port
*p
= SCM_PTAB_ENTRY (port
);
616 scm_gc_free (p
->putback_buf
, p
->putback_buf_size
, "putback buffer");
617 scm_gc_free (p
, sizeof (scm_t_port
), "port");
619 SCM_SETPTAB_ENTRY (port
, 0);
620 scm_hashq_remove_x (scm_i_port_weak_hash
, port
);
625 /* Functions for debugging. */
627 SCM_DEFINE (scm_pt_size
, "pt-size", 0, 0, 0,
629 "Return the number of ports in the port table. @code{pt-size}\n"
630 "is only included in @code{--enable-guile-debug} builds.")
631 #define FUNC_NAME s_scm_pt_size
633 return scm_from_int (SCM_HASHTABLE_N_ITEMS (scm_i_port_weak_hash
));
639 scm_port_non_buffer (scm_t_port
*pt
)
641 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
642 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
643 pt
->read_buf_size
= pt
->write_buf_size
= 1;
644 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
648 /* Revealed counts --- an oddity inherited from SCSH. */
650 /* Find a port in the table and return its revealed count.
651 Also used by the garbage collector.
655 scm_revealed_count (SCM port
)
657 return SCM_REVEALED(port
);
662 /* Return the revealed count for a port. */
664 SCM_DEFINE (scm_port_revealed
, "port-revealed", 1, 0, 0,
666 "Return the revealed count for @var{port}.")
667 #define FUNC_NAME s_scm_port_revealed
669 port
= SCM_COERCE_OUTPORT (port
);
670 SCM_VALIDATE_OPENPORT (1, port
);
671 return scm_from_int (scm_revealed_count (port
));
675 /* Set the revealed count for a port. */
676 SCM_DEFINE (scm_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0,
677 (SCM port
, SCM rcount
),
678 "Sets the revealed count for a port to a given value.\n"
679 "The return value is unspecified.")
680 #define FUNC_NAME s_scm_set_port_revealed_x
682 port
= SCM_COERCE_OUTPORT (port
);
683 SCM_VALIDATE_OPENPORT (1, port
);
684 SCM_REVEALED (port
) = scm_to_int (rcount
);
685 return SCM_UNSPECIFIED
;
691 /* Retrieving a port's mode. */
693 /* Return the flags that characterize a port based on the mode
694 * string used to open a file for that port.
696 * See PORT FLAGS in scm.h
700 scm_i_mode_bits_n (const char *modes
, size_t n
)
703 | (memchr (modes
, 'r', n
) || memchr (modes
, '+', n
) ? SCM_RDNG
: 0)
704 | ( memchr (modes
, 'w', n
)
705 || memchr (modes
, 'a', n
)
706 || memchr (modes
, '+', n
) ? SCM_WRTNG
: 0)
707 | (memchr (modes
, '0', n
) ? SCM_BUF0
: 0)
708 | (memchr (modes
, 'l', n
) ? SCM_BUFLINE
: 0));
712 scm_mode_bits (char *modes
)
714 return scm_i_mode_bits_n (modes
, strlen (modes
));
718 scm_i_mode_bits (SCM modes
)
722 if (!scm_is_string (modes
))
723 scm_wrong_type_arg_msg (NULL
, 0, modes
, "string");
725 bits
= scm_i_mode_bits_n (scm_i_string_chars (modes
),
726 scm_i_string_length (modes
));
727 scm_remember_upto_here_1 (modes
);
731 /* Return the mode flags from an open port.
732 * Some modes such as "append" are only used when opening
733 * a file and are not returned here. */
735 SCM_DEFINE (scm_port_mode
, "port-mode", 1, 0, 0,
737 "Return the port modes associated with the open port @var{port}.\n"
738 "These will not necessarily be identical to the modes used when\n"
739 "the port was opened, since modes such as \"append\" which are\n"
740 "used only during port creation are not retained.")
741 #define FUNC_NAME s_scm_port_mode
746 port
= SCM_COERCE_OUTPORT (port
);
747 SCM_VALIDATE_OPPORT (1, port
);
748 if (SCM_CELL_WORD_0 (port
) & SCM_RDNG
) {
749 if (SCM_CELL_WORD_0 (port
) & SCM_WRTNG
)
750 strcpy (modes
, "r+");
754 else if (SCM_CELL_WORD_0 (port
) & SCM_WRTNG
)
756 if (SCM_CELL_WORD_0 (port
) & SCM_BUF0
)
758 return scm_from_locale_string (modes
);
767 * Call the close operation on a port object.
768 * see also scm_close.
770 SCM_DEFINE (scm_close_port
, "close-port", 1, 0, 0,
772 "Close the specified port object. Return @code{#t} if it\n"
773 "successfully closes a port or @code{#f} if it was already\n"
774 "closed. An exception may be raised if an error occurs, for\n"
775 "example when flushing buffered output. See also @ref{Ports and\n"
776 "File Descriptors, close}, for a procedure which can close file\n"
778 #define FUNC_NAME s_scm_close_port
783 port
= SCM_COERCE_OUTPORT (port
);
785 SCM_VALIDATE_PORT (1, port
);
786 if (SCM_CLOSEDP (port
))
788 i
= SCM_PTOBNUM (port
);
789 if (scm_ptobs
[i
].close
)
790 rv
= (scm_ptobs
[i
].close
) (port
);
793 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
794 scm_i_remove_port (port
);
795 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
796 SCM_CLR_PORT_OPEN_FLAG (port
);
797 return scm_from_bool (rv
>= 0);
801 SCM_DEFINE (scm_close_input_port
, "close-input-port", 1, 0, 0,
803 "Close the specified input port object. The routine has no effect if\n"
804 "the file has already been closed. An exception may be raised if an\n"
805 "error occurs. The value returned is unspecified.\n\n"
806 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
807 "which can close file descriptors.")
808 #define FUNC_NAME s_scm_close_input_port
810 SCM_VALIDATE_INPUT_PORT (1, port
);
811 scm_close_port (port
);
812 return SCM_UNSPECIFIED
;
816 SCM_DEFINE (scm_close_output_port
, "close-output-port", 1, 0, 0,
818 "Close the specified output port object. The routine has no effect if\n"
819 "the file has already been closed. An exception may be raised if an\n"
820 "error occurs. The value returned is unspecified.\n\n"
821 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
822 "which can close file descriptors.")
823 #define FUNC_NAME s_scm_close_output_port
825 port
= SCM_COERCE_OUTPORT (port
);
826 SCM_VALIDATE_OUTPUT_PORT (1, port
);
827 scm_close_port (port
);
828 return SCM_UNSPECIFIED
;
833 scm_i_collect_keys_in_vector (void *closure
, SCM key
, SCM value
, SCM result
)
835 int *i
= (int*) closure
;
836 scm_c_vector_set_x (result
, *i
, key
);
843 scm_c_port_for_each (void (*proc
)(void *data
, SCM p
), void *data
)
849 /* Even without pre-emptive multithreading, running arbitrary code
850 while scanning the port table is unsafe because the port table
851 can change arbitrarily (from a GC, for example). So we first
852 collect the ports into a vector. -mvo */
854 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
855 n
= SCM_HASHTABLE_N_ITEMS (scm_i_port_weak_hash
);
856 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
857 ports
= scm_c_make_vector (n
, SCM_BOOL_F
);
859 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
860 ports
= scm_internal_hash_fold (scm_i_collect_keys_in_vector
, &i
,
861 ports
, scm_i_port_weak_hash
);
862 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
864 for (i
= 0; i
< n
; i
++) {
865 SCM p
= SCM_SIMPLE_VECTOR_REF (ports
, i
);
870 scm_remember_upto_here_1 (ports
);
873 SCM_DEFINE (scm_port_for_each
, "port-for-each", 1, 0, 0,
875 "Apply @var{proc} to each port in the Guile port table\n"
876 "in turn. The return value is unspecified. More specifically,\n"
877 "@var{proc} is applied exactly once to every port that exists\n"
878 "in the system at the time @var{port-for-each} is invoked.\n"
879 "Changes to the port table while @var{port-for-each} is running\n"
880 "have no effect as far as @var{port-for-each} is concerned.")
881 #define FUNC_NAME s_scm_port_for_each
883 SCM_VALIDATE_PROC (1, proc
);
885 scm_c_port_for_each ((void (*)(void*,SCM
))scm_call_1
, proc
);
886 return SCM_UNSPECIFIED
;
892 /* Utter miscellany. Gosh, we should clean this up some time. */
894 SCM_DEFINE (scm_input_port_p
, "input-port?", 1, 0, 0,
896 "Return @code{#t} if @var{x} is an input port, otherwise return\n"
897 "@code{#f}. Any object satisfying this predicate also satisfies\n"
899 #define FUNC_NAME s_scm_input_port_p
901 return scm_from_bool (SCM_INPUT_PORT_P (x
));
905 SCM_DEFINE (scm_output_port_p
, "output-port?", 1, 0, 0,
907 "Return @code{#t} if @var{x} is an output port, otherwise return\n"
908 "@code{#f}. Any object satisfying this predicate also satisfies\n"
910 #define FUNC_NAME s_scm_output_port_p
912 x
= SCM_COERCE_OUTPORT (x
);
913 return scm_from_bool (SCM_OUTPUT_PORT_P (x
));
917 SCM_DEFINE (scm_port_p
, "port?", 1, 0, 0,
919 "Return a boolean indicating whether @var{x} is a port.\n"
920 "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
922 #define FUNC_NAME s_scm_port_p
924 return scm_from_bool (SCM_PORTP (x
));
928 SCM_DEFINE (scm_port_closed_p
, "port-closed?", 1, 0, 0,
930 "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
932 #define FUNC_NAME s_scm_port_closed_p
934 SCM_VALIDATE_PORT (1, port
);
935 return scm_from_bool (!SCM_OPPORTP (port
));
939 SCM_DEFINE (scm_eof_object_p
, "eof-object?", 1, 0, 0,
941 "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
943 #define FUNC_NAME s_scm_eof_object_p
945 return scm_from_bool(SCM_EOF_OBJECT_P (x
));
949 SCM_DEFINE (scm_force_output
, "force-output", 0, 1, 0,
951 "Flush the specified output port, or the current output port if @var{port}\n"
952 "is omitted. The current output buffer contents are passed to the\n"
953 "underlying port implementation (e.g., in the case of fports, the\n"
954 "data will be written to the file and the output buffer will be cleared.)\n"
955 "It has no effect on an unbuffered port.\n\n"
956 "The return value is unspecified.")
957 #define FUNC_NAME s_scm_force_output
959 if (SCM_UNBNDP (port
))
960 port
= scm_current_output_port ();
963 port
= SCM_COERCE_OUTPORT (port
);
964 SCM_VALIDATE_OPOUTPORT (1, port
);
967 return SCM_UNSPECIFIED
;
973 flush_output_port (void *closure
, SCM port
)
975 if (SCM_OPOUTPORTP (port
))
979 SCM_DEFINE (scm_flush_all_ports
, "flush-all-ports", 0, 0, 0,
981 "Equivalent to calling @code{force-output} on\n"
982 "all open output ports. The return value is unspecified.")
983 #define FUNC_NAME s_scm_flush_all_ports
985 scm_c_port_for_each (&flush_output_port
, NULL
);
986 return SCM_UNSPECIFIED
;
990 SCM_DEFINE (scm_read_char
, "read-char", 0, 1, 0,
992 "Return the next character available from @var{port}, updating\n"
993 "@var{port} to point to the following character. If no more\n"
994 "characters are available, the end-of-file object is returned.")
995 #define FUNC_NAME s_scm_read_char
998 if (SCM_UNBNDP (port
))
999 port
= scm_current_input_port ();
1000 SCM_VALIDATE_OPINPORT (1, port
);
1001 c
= scm_getc (port
);
1004 return SCM_MAKE_CHAR (c
);
1008 /* this should only be called when the read buffer is empty. it
1009 tries to refill the read buffer. it returns the first char from
1010 the port, which is either EOF or *(pt->read_pos). */
1012 scm_fill_input (SCM port
)
1014 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1016 if (pt
->read_buf
== pt
->putback_buf
)
1018 /* finished reading put-back chars. */
1019 pt
->read_buf
= pt
->saved_read_buf
;
1020 pt
->read_pos
= pt
->saved_read_pos
;
1021 pt
->read_end
= pt
->saved_read_end
;
1022 pt
->read_buf_size
= pt
->saved_read_buf_size
;
1023 if (pt
->read_pos
< pt
->read_end
)
1024 return *(pt
->read_pos
);
1026 return scm_ptobs
[SCM_PTOBNUM (port
)].fill_input (port
);
1033 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1035 if (pt
->rw_active
== SCM_PORT_WRITE
)
1036 /* may be marginally faster than calling scm_flush. */
1037 scm_ptobs
[SCM_PTOBNUM (port
)].flush (port
);
1040 pt
->rw_active
= SCM_PORT_READ
;
1042 if (pt
->read_pos
>= pt
->read_end
)
1044 if (scm_fill_input (port
) == EOF
)
1048 c
= *(pt
->read_pos
++);
1075 scm_putc (char c
, SCM port
)
1077 SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port
), port
, 0, NULL
, "output port");
1078 scm_lfwrite (&c
, 1, port
);
1082 scm_puts (const char *s
, SCM port
)
1084 SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port
), port
, 0, NULL
, "output port");
1085 scm_lfwrite (s
, strlen (s
), port
);
1090 * This function differs from scm_c_write; it updates port line and
1094 scm_lfwrite (const char *ptr
, size_t size
, SCM port
)
1096 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1097 scm_t_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
1099 if (pt
->rw_active
== SCM_PORT_READ
)
1100 scm_end_input (port
);
1102 ptob
->write (port
, ptr
, size
);
1104 for (; size
; ptr
++, size
--) {
1107 else if (*ptr
== '\b') {
1110 else if (*ptr
== '\n') {
1113 else if (*ptr
== '\r') {
1116 else if (*ptr
== '\t') {
1125 pt
->rw_active
= SCM_PORT_WRITE
;
1130 * Used by an application to read arbitrary number of bytes from an
1131 * SCM port. Same semantics as libc read, except that scm_c_read only
1132 * returns less than SIZE bytes if at end-of-file.
1134 * Warning: Doesn't update port line and column counts! */
1137 scm_c_read (SCM port
, void *buffer
, size_t size
)
1139 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1140 size_t n_read
= 0, n_available
;
1142 if (pt
->rw_active
== SCM_PORT_WRITE
)
1143 scm_ptobs
[SCM_PTOBNUM (port
)].flush (port
);
1146 pt
->rw_active
= SCM_PORT_READ
;
1148 if (SCM_READ_BUFFER_EMPTY_P (pt
))
1150 if (scm_fill_input (port
) == EOF
)
1154 n_available
= pt
->read_end
- pt
->read_pos
;
1156 while (n_available
< size
)
1158 memcpy (buffer
, pt
->read_pos
, n_available
);
1159 buffer
= (char *) buffer
+ n_available
;
1160 pt
->read_pos
+= n_available
;
1161 n_read
+= n_available
;
1163 if (SCM_READ_BUFFER_EMPTY_P (pt
))
1165 if (scm_fill_input (port
) == EOF
)
1169 size
-= n_available
;
1170 n_available
= pt
->read_end
- pt
->read_pos
;
1173 memcpy (buffer
, pt
->read_pos
, size
);
1174 pt
->read_pos
+= size
;
1176 return n_read
+ size
;
1181 * Used by an application to write arbitrary number of bytes to an SCM
1182 * port. Similar semantics as libc write. However, unlike libc
1183 * write, scm_c_write writes the requested number of bytes and has no
1186 * Warning: Doesn't update port line and column counts!
1190 scm_c_write (SCM port
, const void *ptr
, size_t size
)
1192 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1193 scm_t_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
1195 if (pt
->rw_active
== SCM_PORT_READ
)
1196 scm_end_input (port
);
1198 ptob
->write (port
, ptr
, size
);
1201 pt
->rw_active
= SCM_PORT_WRITE
;
1205 scm_flush (SCM port
)
1207 long i
= SCM_PTOBNUM (port
);
1208 assert ((i
>= 0) && (i
< scm_i_port_table_size
));
1209 (scm_ptobs
[i
].flush
) (port
);
1213 scm_end_input (SCM port
)
1216 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1218 if (pt
->read_buf
== pt
->putback_buf
)
1220 offset
= pt
->read_end
- pt
->read_pos
;
1221 pt
->read_buf
= pt
->saved_read_buf
;
1222 pt
->read_pos
= pt
->saved_read_pos
;
1223 pt
->read_end
= pt
->saved_read_end
;
1224 pt
->read_buf_size
= pt
->saved_read_buf_size
;
1229 scm_ptobs
[SCM_PTOBNUM (port
)].end_input (port
, offset
);
1236 scm_ungetc (int c
, SCM port
)
1237 #define FUNC_NAME "scm_ungetc"
1239 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1241 if (pt
->read_buf
== pt
->putback_buf
)
1242 /* already using the put-back buffer. */
1244 /* enlarge putback_buf if necessary. */
1245 if (pt
->read_end
== pt
->read_buf
+ pt
->read_buf_size
1246 && pt
->read_buf
== pt
->read_pos
)
1248 size_t new_size
= pt
->read_buf_size
* 2;
1249 unsigned char *tmp
= (unsigned char *)
1250 /* XXX: Can we use `GC_REALLOC' with `GC_MALLOC_ATOMIC'-allocated
1252 scm_gc_realloc (pt
->putback_buf
, pt
->read_buf_size
, new_size
,
1255 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
= tmp
;
1256 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
1257 pt
->read_buf_size
= pt
->putback_buf_size
= new_size
;
1260 /* shift any existing bytes to buffer + 1. */
1261 if (pt
->read_pos
== pt
->read_end
)
1262 pt
->read_end
= pt
->read_buf
+ 1;
1263 else if (pt
->read_pos
!= pt
->read_buf
+ 1)
1265 int count
= pt
->read_end
- pt
->read_pos
;
1267 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
1268 pt
->read_end
= pt
->read_buf
+ 1 + count
;
1271 pt
->read_pos
= pt
->read_buf
;
1274 /* switch to the put-back buffer. */
1276 if (pt
->putback_buf
== NULL
)
1279 = (unsigned char *) scm_gc_malloc_pointerless
1280 (SCM_INITIAL_PUTBACK_BUF_SIZE
, "putback buffer");
1281 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
1284 pt
->saved_read_buf
= pt
->read_buf
;
1285 pt
->saved_read_pos
= pt
->read_pos
;
1286 pt
->saved_read_end
= pt
->read_end
;
1287 pt
->saved_read_buf_size
= pt
->read_buf_size
;
1289 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
1290 pt
->read_end
= pt
->read_buf
+ 1;
1291 pt
->read_buf_size
= pt
->putback_buf_size
;
1297 pt
->rw_active
= SCM_PORT_READ
;
1301 /* What should col be in this case?
1302 * We'll leave it at -1.
1304 SCM_LINUM (port
) -= 1;
1313 scm_ungets (const char *s
, int n
, SCM port
)
1315 /* This is simple minded and inefficient, but unreading strings is
1316 * probably not a common operation, and remember that line and
1317 * column numbers have to be handled...
1319 * Please feel free to write an optimized version!
1322 scm_ungetc (s
[n
], port
);
1326 SCM_DEFINE (scm_peek_char
, "peek-char", 0, 1, 0,
1328 "Return the next character available from @var{port},\n"
1329 "@emph{without} updating @var{port} to point to the following\n"
1330 "character. If no more characters are available, the\n"
1331 "end-of-file object is returned.\n"
1333 "The value returned by\n"
1334 "a call to @code{peek-char} is the same as the value that would\n"
1335 "have been returned by a call to @code{read-char} on the same\n"
1336 "port. The only difference is that the very next call to\n"
1337 "@code{read-char} or @code{peek-char} on that @var{port} will\n"
1338 "return the value returned by the preceding call to\n"
1339 "@code{peek-char}. In particular, a call to @code{peek-char} on\n"
1340 "an interactive port will hang waiting for input whenever a call\n"
1341 "to @code{read-char} would have hung.")
1342 #define FUNC_NAME s_scm_peek_char
1345 if (SCM_UNBNDP (port
))
1346 port
= scm_current_input_port ();
1348 SCM_VALIDATE_OPINPORT (1, port
);
1349 column
= SCM_COL(port
);
1350 c
= scm_getc (port
);
1353 scm_ungetc (c
, port
);
1354 SCM_COL(port
) = column
;
1355 return SCM_MAKE_CHAR (c
);
1359 SCM_DEFINE (scm_unread_char
, "unread-char", 1, 1, 0,
1360 (SCM cobj
, SCM port
),
1361 "Place @var{char} in @var{port} so that it will be read by the\n"
1362 "next read operation. If called multiple times, the unread characters\n"
1363 "will be read again in last-in first-out order. If @var{port} is\n"
1364 "not supplied, the current input port is used.")
1365 #define FUNC_NAME s_scm_unread_char
1369 SCM_VALIDATE_CHAR (1, cobj
);
1370 if (SCM_UNBNDP (port
))
1371 port
= scm_current_input_port ();
1373 SCM_VALIDATE_OPINPORT (2, port
);
1375 c
= SCM_CHAR (cobj
);
1377 scm_ungetc (c
, port
);
1382 SCM_DEFINE (scm_unread_string
, "unread-string", 2, 0, 0,
1383 (SCM str
, SCM port
),
1384 "Place the string @var{str} in @var{port} so that its characters will be\n"
1385 "read in subsequent read operations. If called multiple times, the\n"
1386 "unread characters will be read again in last-in first-out order. If\n"
1387 "@var{port} is not supplied, the current-input-port is used.")
1388 #define FUNC_NAME s_scm_unread_string
1390 SCM_VALIDATE_STRING (1, str
);
1391 if (SCM_UNBNDP (port
))
1392 port
= scm_current_input_port ();
1394 SCM_VALIDATE_OPINPORT (2, port
);
1396 scm_ungets (scm_i_string_chars (str
), scm_i_string_length (str
), port
);
1402 SCM_DEFINE (scm_seek
, "seek", 3, 0, 0,
1403 (SCM fd_port
, SCM offset
, SCM whence
),
1404 "Sets the current position of @var{fd/port} to the integer\n"
1405 "@var{offset}, which is interpreted according to the value of\n"
1408 "One of the following variables should be supplied for\n"
1410 "@defvar SEEK_SET\n"
1411 "Seek from the beginning of the file.\n"
1413 "@defvar SEEK_CUR\n"
1414 "Seek from the current position.\n"
1416 "@defvar SEEK_END\n"
1417 "Seek from the end of the file.\n"
1419 "If @var{fd/port} is a file descriptor, the underlying system\n"
1420 "call is @code{lseek}. @var{port} may be a string port.\n"
1422 "The value returned is the new position in the file. This means\n"
1423 "that the current position of a port can be obtained using:\n"
1425 "(seek port 0 SEEK_CUR)\n"
1427 #define FUNC_NAME s_scm_seek
1431 fd_port
= SCM_COERCE_OUTPORT (fd_port
);
1433 how
= scm_to_int (whence
);
1434 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
1435 SCM_OUT_OF_RANGE (3, whence
);
1437 if (SCM_OPFPORTP (fd_port
))
1439 /* go direct to fport code to allow 64-bit offsets */
1440 return scm_i_fport_seek (fd_port
, offset
, how
);
1442 else if (SCM_OPPORTP (fd_port
))
1444 scm_t_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (fd_port
);
1445 off_t off
= scm_to_off_t (offset
);
1449 SCM_MISC_ERROR ("port is not seekable",
1450 scm_cons (fd_port
, SCM_EOL
));
1452 rv
= ptob
->seek (fd_port
, off
, how
);
1453 return scm_from_off_t (rv
);
1455 else /* file descriptor?. */
1457 off_t_or_off64_t off
= scm_to_off_t_or_off64_t (offset
);
1458 off_t_or_off64_t rv
;
1459 rv
= lseek_or_lseek64 (scm_to_int (fd_port
), off
, how
);
1462 return scm_from_off_t_or_off64_t (rv
);
1471 /* Mingw has ftruncate(), perhaps implemented above using chsize, but
1472 doesn't have the filename version truncate(), hence this code. */
1473 #if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
1475 truncate (const char *file
, off_t length
)
1479 fdes
= open (file
, O_BINARY
| O_WRONLY
);
1483 ret
= ftruncate (fdes
, length
);
1486 int save_errno
= errno
;
1492 return close (fdes
);
1494 #endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
1496 SCM_DEFINE (scm_truncate_file
, "truncate-file", 1, 1, 0,
1497 (SCM object
, SCM length
),
1498 "Truncate @var{file} to @var{length} bytes. @var{file} can be a\n"
1499 "filename string, a port object, or an integer file descriptor.\n"
1500 "The return value is unspecified.\n"
1502 "For a port or file descriptor @var{length} can be omitted, in\n"
1503 "which case the file is truncated at the current position (per\n"
1504 "@code{ftell} above).\n"
1506 "On most systems a file can be extended by giving a length\n"
1507 "greater than the current size, but this is not mandatory in the\n"
1509 #define FUNC_NAME s_scm_truncate_file
1513 /* "object" can be a port, fdes or filename.
1515 Negative "length" makes no sense, but it's left to truncate() or
1516 ftruncate() to give back an error for that (normally EINVAL).
1519 if (SCM_UNBNDP (length
))
1521 /* must supply length if object is a filename. */
1522 if (scm_is_string (object
))
1523 SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL
);
1525 length
= scm_seek (object
, SCM_INUM0
, scm_from_int (SEEK_CUR
));
1528 object
= SCM_COERCE_OUTPORT (object
);
1529 if (scm_is_integer (object
))
1531 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
1532 SCM_SYSCALL (rv
= ftruncate_or_ftruncate64 (scm_to_int (object
),
1535 else if (SCM_OPOUTFPORTP (object
))
1537 /* go direct to fport code to allow 64-bit offsets */
1538 rv
= scm_i_fport_truncate (object
, length
);
1540 else if (SCM_OPOUTPORTP (object
))
1542 off_t c_length
= scm_to_off_t (length
);
1543 scm_t_port
*pt
= SCM_PTAB_ENTRY (object
);
1544 scm_t_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1546 if (!ptob
->truncate
)
1547 SCM_MISC_ERROR ("port is not truncatable", SCM_EOL
);
1548 if (pt
->rw_active
== SCM_PORT_READ
)
1549 scm_end_input (object
);
1550 else if (pt
->rw_active
== SCM_PORT_WRITE
)
1551 ptob
->flush (object
);
1553 ptob
->truncate (object
, c_length
);
1558 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
1559 char *str
= scm_to_locale_string (object
);
1561 SCM_SYSCALL (rv
= truncate_or_truncate64 (str
, c_length
));
1568 return SCM_UNSPECIFIED
;
1572 SCM_DEFINE (scm_port_line
, "port-line", 1, 0, 0,
1574 "Return the current line number for @var{port}.\n"
1576 "The first line of a file is 0. But you might want to add 1\n"
1577 "when printing line numbers, since starting from 1 is\n"
1578 "traditional in error messages, and likely to be more natural to\n"
1580 #define FUNC_NAME s_scm_port_line
1582 port
= SCM_COERCE_OUTPORT (port
);
1583 SCM_VALIDATE_OPENPORT (1, port
);
1584 return scm_from_long (SCM_LINUM (port
));
1588 SCM_DEFINE (scm_set_port_line_x
, "set-port-line!", 2, 0, 0,
1589 (SCM port
, SCM line
),
1590 "Set the current line number for @var{port} to @var{line}. The\n"
1591 "first line of a file is 0.")
1592 #define FUNC_NAME s_scm_set_port_line_x
1594 port
= SCM_COERCE_OUTPORT (port
);
1595 SCM_VALIDATE_OPENPORT (1, port
);
1596 SCM_PTAB_ENTRY (port
)->line_number
= scm_to_long (line
);
1597 return SCM_UNSPECIFIED
;
1601 SCM_DEFINE (scm_port_column
, "port-column", 1, 0, 0,
1603 "Return the current column number of @var{port}.\n"
1604 "If the number is\n"
1605 "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
1606 "- i.e. the first character of the first line is line 0, column 0.\n"
1607 "(However, when you display a file position, for example in an error\n"
1608 "message, we recommend you add 1 to get 1-origin integers. This is\n"
1609 "because lines and column numbers traditionally start with 1, and that is\n"
1610 "what non-programmers will find most natural.)")
1611 #define FUNC_NAME s_scm_port_column
1613 port
= SCM_COERCE_OUTPORT (port
);
1614 SCM_VALIDATE_OPENPORT (1, port
);
1615 return scm_from_int (SCM_COL (port
));
1619 SCM_DEFINE (scm_set_port_column_x
, "set-port-column!", 2, 0, 0,
1620 (SCM port
, SCM column
),
1621 "Set the current column of @var{port}. Before reading the first\n"
1622 "character on a line the column should be 0.")
1623 #define FUNC_NAME s_scm_set_port_column_x
1625 port
= SCM_COERCE_OUTPORT (port
);
1626 SCM_VALIDATE_OPENPORT (1, port
);
1627 SCM_PTAB_ENTRY (port
)->column_number
= scm_to_int (column
);
1628 return SCM_UNSPECIFIED
;
1632 SCM_DEFINE (scm_port_filename
, "port-filename", 1, 0, 0,
1634 "Return the filename associated with @var{port}. This function returns\n"
1635 "the strings \"standard input\", \"standard output\" and \"standard error\"\n"
1636 "when called on the current input, output and error ports respectively.")
1637 #define FUNC_NAME s_scm_port_filename
1639 port
= SCM_COERCE_OUTPORT (port
);
1640 SCM_VALIDATE_OPENPORT (1, port
);
1641 return SCM_FILENAME (port
);
1645 SCM_DEFINE (scm_set_port_filename_x
, "set-port-filename!", 2, 0, 0,
1646 (SCM port
, SCM filename
),
1647 "Change the filename associated with @var{port}, using the current input\n"
1648 "port if none is specified. Note that this does not change the port's\n"
1649 "source of data, but only the value that is returned by\n"
1650 "@code{port-filename} and reported in diagnostic output.")
1651 #define FUNC_NAME s_scm_set_port_filename_x
1653 port
= SCM_COERCE_OUTPORT (port
);
1654 SCM_VALIDATE_OPENPORT (1, port
);
1655 /* We allow the user to set the filename to whatever he likes. */
1656 SCM_SET_FILENAME (port
, filename
);
1657 return SCM_UNSPECIFIED
;
1662 scm_print_port_mode (SCM exp
, SCM port
)
1664 scm_puts (SCM_CLOSEDP (exp
)
1666 : (SCM_RDNG
& SCM_CELL_WORD_0 (exp
)
1667 ? (SCM_WRTNG
& SCM_CELL_WORD_0 (exp
)
1670 : (SCM_WRTNG
& SCM_CELL_WORD_0 (exp
)
1677 scm_port_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1679 char *type
= SCM_PTOBNAME (SCM_PTOBNUM (exp
));
1682 scm_puts ("#<", port
);
1683 scm_print_port_mode (exp
, port
);
1684 scm_puts (type
, port
);
1685 scm_putc (' ', port
);
1686 scm_uintprint (SCM_CELL_WORD_1 (exp
), 16, port
);
1687 scm_putc ('>', port
);
1692 scm_ports_prehistory ()
1697 /* In order for the ports to be collectable, the port table must not be
1698 scanned by the GC. */
1700 scm_gc_malloc_pointerless (scm_i_port_table_room
1701 * sizeof (scm_t_port
*),
1709 scm_t_bits scm_tc16_void_port
= 0;
1711 static int fill_input_void_port (SCM port SCM_UNUSED
)
1717 write_void_port (SCM port SCM_UNUSED
,
1718 const void *data SCM_UNUSED
,
1719 size_t size SCM_UNUSED
)
1724 scm_i_void_port (long mode_bits
)
1726 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
1728 SCM answer
= scm_new_port_table_entry (scm_tc16_void_port
);
1729 scm_t_port
* pt
= SCM_PTAB_ENTRY(answer
);
1731 scm_port_non_buffer (pt
);
1733 SCM_SETSTREAM (answer
, 0);
1734 SCM_SET_CELL_TYPE (answer
, scm_tc16_void_port
| mode_bits
);
1735 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
1741 scm_void_port (char *mode_str
)
1743 return scm_i_void_port (scm_mode_bits (mode_str
));
1746 SCM_DEFINE (scm_sys_make_void_port
, "%make-void-port", 1, 0, 0,
1748 "Create and return a new void port. A void port acts like\n"
1749 "@file{/dev/null}. The @var{mode} argument\n"
1750 "specifies the input/output modes for this port: see the\n"
1751 "documentation for @code{open-file} in @ref{File Ports}.")
1752 #define FUNC_NAME s_scm_sys_make_void_port
1754 return scm_i_void_port (scm_i_mode_bits (mode
));
1759 /* Initialization. */
1764 /* lseek() symbols. */
1765 scm_c_define ("SEEK_SET", scm_from_int (SEEK_SET
));
1766 scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR
));
1767 scm_c_define ("SEEK_END", scm_from_int (SEEK_END
));
1769 scm_tc16_void_port
= scm_make_port_type ("void", fill_input_void_port
,
1772 cur_inport_fluid
= scm_permanent_object (scm_make_fluid ());
1773 cur_outport_fluid
= scm_permanent_object (scm_make_fluid ());
1774 cur_errport_fluid
= scm_permanent_object (scm_make_fluid ());
1775 cur_loadport_fluid
= scm_permanent_object (scm_make_fluid ());
1777 scm_i_port_weak_hash
= scm_permanent_object (scm_make_weak_key_hash_table (SCM_I_MAKINUM(31)));
1779 #include "libguile/ports.x"