1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008 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 */
32 #include "libguile/_scm.h"
33 #include "libguile/async.h"
34 #include "libguile/eval.h"
35 #include "libguile/fports.h" /* direct access for seek and truncate */
36 #include "libguile/objects.h"
37 #include "libguile/goops.h"
38 #include "libguile/smob.h"
39 #include "libguile/chars.h"
40 #include "libguile/dynwind.h"
42 #include "libguile/keywords.h"
43 #include "libguile/hashtab.h"
44 #include "libguile/root.h"
45 #include "libguile/strings.h"
46 #include "libguile/mallocs.h"
47 #include "libguile/validate.h"
48 #include "libguile/ports.h"
49 #include "libguile/vectors.h"
50 #include "libguile/weaks.h"
51 #include "libguile/fluids.h"
69 #ifdef HAVE_SYS_IOCTL_H
70 #include <sys/ioctl.h>
73 /* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
74 already, but have this code here in case that wasn't so in past versions,
75 or perhaps to help other minimal DOS environments.
77 gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
78 might be possibilities if we've got other systems without ftruncate. */
80 #if HAVE_CHSIZE && ! HAVE_FTRUNCATE
81 #define ftruncate(fd, size) chsize (fd, size)
83 #define HAVE_FTRUNCATE 1
87 /* The port kind table --- a dynamically resized array of port types. */
90 /* scm_ptobs scm_numptob
91 * implement a dynamically resized array of ptob records.
92 * Indexes into this table are used when generating type
93 * tags for smobjects (if you know a tag you can get an index and conversely).
95 scm_t_ptob_descriptor
*scm_ptobs
;
98 /* GC marker for a port with stream of SCM type. */
100 scm_markstream (SCM ptr
)
103 openp
= SCM_CELL_WORD_0 (ptr
) & SCM_OPN
;
105 return SCM_PACK (SCM_STREAM (ptr
));
111 * We choose to use an interface similar to the smob interface with
112 * fill_input and write as standard fields, passed to the port
113 * type constructor, and optional fields set by setters.
117 flush_port_default (SCM port SCM_UNUSED
)
122 end_input_default (SCM port SCM_UNUSED
, int offset SCM_UNUSED
)
127 scm_port_free0 (SCM port
)
133 scm_make_port_type (char *name
,
134 int (*fill_input
) (SCM port
),
135 void (*write
) (SCM port
, const void *data
, size_t size
))
138 if (255 <= scm_numptob
)
140 SCM_CRITICAL_SECTION_START
;
141 SCM_SYSCALL (tmp
= (char *) realloc ((char *) scm_ptobs
,
143 * 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
;
498 /* This function is not and should not be thread safe. */
501 scm_new_port_table_entry (scm_t_bits tag
)
502 #define FUNC_NAME "scm_new_port_table_entry"
505 We initialize the cell to empty, this is in case scm_gc_calloc
506 triggers GC ; we don't want the GC to scan a half-finished Z.
509 SCM z
= scm_cons (SCM_EOL
, SCM_EOL
);
510 scm_t_port
*entry
= (scm_t_port
*) scm_gc_calloc (sizeof (scm_t_port
), "port");
512 entry
->file_name
= SCM_BOOL_F
;
513 entry
->rw_active
= SCM_PORT_NEITHER
;
516 SCM_SET_CELL_TYPE (z
, tag
);
517 SCM_SETPTAB_ENTRY (z
, entry
);
519 scm_hashq_set_x (scm_i_port_weak_hash
, z
, SCM_BOOL_F
);
525 #if SCM_ENABLE_DEPRECATED==1
527 scm_add_to_port_table (SCM port
)
529 SCM z
= scm_new_port_table_entry (scm_tc7_port
);
530 scm_t_port
* pt
= SCM_PTAB_ENTRY(z
);
533 SCM_SETCAR (z
, SCM_EOL
);
534 SCM_SETCDR (z
, SCM_EOL
);
535 SCM_SETPTAB_ENTRY (port
, pt
);
541 /* Remove a port from the table and destroy it. */
543 /* This function is not and should not be thread safe. */
545 scm_i_remove_port (SCM port
)
546 #define FUNC_NAME "scm_remove_port"
548 scm_t_port
*p
= SCM_PTAB_ENTRY (port
);
550 scm_gc_free (p
->putback_buf
, p
->putback_buf_size
, "putback buffer");
551 scm_gc_free (p
, sizeof (scm_t_port
), "port");
553 SCM_SETPTAB_ENTRY (port
, 0);
554 scm_hashq_remove_x (scm_i_port_weak_hash
, port
);
559 /* Functions for debugging. */
561 SCM_DEFINE (scm_pt_size
, "pt-size", 0, 0, 0,
563 "Return the number of ports in the port table. @code{pt-size}\n"
564 "is only included in @code{--enable-guile-debug} builds.")
565 #define FUNC_NAME s_scm_pt_size
567 return scm_from_int (SCM_HASHTABLE_N_ITEMS (scm_i_port_weak_hash
));
573 scm_port_non_buffer (scm_t_port
*pt
)
575 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
576 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
577 pt
->read_buf_size
= pt
->write_buf_size
= 1;
578 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
582 /* Revealed counts --- an oddity inherited from SCSH. */
584 /* Find a port in the table and return its revealed count.
585 Also used by the garbage collector.
589 scm_revealed_count (SCM port
)
591 return SCM_REVEALED(port
);
596 /* Return the revealed count for a port. */
598 SCM_DEFINE (scm_port_revealed
, "port-revealed", 1, 0, 0,
600 "Return the revealed count for @var{port}.")
601 #define FUNC_NAME s_scm_port_revealed
603 port
= SCM_COERCE_OUTPORT (port
);
604 SCM_VALIDATE_OPENPORT (1, port
);
605 return scm_from_int (scm_revealed_count (port
));
609 /* Set the revealed count for a port. */
610 SCM_DEFINE (scm_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0,
611 (SCM port
, SCM rcount
),
612 "Sets the revealed count for a port to a given value.\n"
613 "The return value is unspecified.")
614 #define FUNC_NAME s_scm_set_port_revealed_x
616 port
= SCM_COERCE_OUTPORT (port
);
617 SCM_VALIDATE_OPENPORT (1, port
);
618 SCM_REVEALED (port
) = scm_to_int (rcount
);
619 return SCM_UNSPECIFIED
;
625 /* Retrieving a port's mode. */
627 /* Return the flags that characterize a port based on the mode
628 * string used to open a file for that port.
630 * See PORT FLAGS in scm.h
634 scm_i_mode_bits_n (const char *modes
, size_t n
)
637 | (memchr (modes
, 'r', n
) || memchr (modes
, '+', n
) ? SCM_RDNG
: 0)
638 | ( memchr (modes
, 'w', n
)
639 || memchr (modes
, 'a', n
)
640 || memchr (modes
, '+', n
) ? SCM_WRTNG
: 0)
641 | (memchr (modes
, '0', n
) ? SCM_BUF0
: 0)
642 | (memchr (modes
, 'l', n
) ? SCM_BUFLINE
: 0));
646 scm_mode_bits (char *modes
)
648 return scm_i_mode_bits_n (modes
, strlen (modes
));
652 scm_i_mode_bits (SCM modes
)
656 if (!scm_is_string (modes
))
657 scm_wrong_type_arg_msg (NULL
, 0, modes
, "string");
659 bits
= scm_i_mode_bits_n (scm_i_string_chars (modes
),
660 scm_i_string_length (modes
));
661 scm_remember_upto_here_1 (modes
);
665 /* Return the mode flags from an open port.
666 * Some modes such as "append" are only used when opening
667 * a file and are not returned here. */
669 SCM_DEFINE (scm_port_mode
, "port-mode", 1, 0, 0,
671 "Return the port modes associated with the open port @var{port}.\n"
672 "These will not necessarily be identical to the modes used when\n"
673 "the port was opened, since modes such as \"append\" which are\n"
674 "used only during port creation are not retained.")
675 #define FUNC_NAME s_scm_port_mode
680 port
= SCM_COERCE_OUTPORT (port
);
681 SCM_VALIDATE_OPPORT (1, port
);
682 if (SCM_CELL_WORD_0 (port
) & SCM_RDNG
) {
683 if (SCM_CELL_WORD_0 (port
) & SCM_WRTNG
)
684 strcpy (modes
, "r+");
688 else if (SCM_CELL_WORD_0 (port
) & SCM_WRTNG
)
690 if (SCM_CELL_WORD_0 (port
) & SCM_BUF0
)
692 return scm_from_locale_string (modes
);
701 * Call the close operation on a port object.
702 * see also scm_close.
704 SCM_DEFINE (scm_close_port
, "close-port", 1, 0, 0,
706 "Close the specified port object. Return @code{#t} if it\n"
707 "successfully closes a port or @code{#f} if it was already\n"
708 "closed. An exception may be raised if an error occurs, for\n"
709 "example when flushing buffered output. See also @ref{Ports and\n"
710 "File Descriptors, close}, for a procedure which can close file\n"
712 #define FUNC_NAME s_scm_close_port
717 port
= SCM_COERCE_OUTPORT (port
);
719 SCM_VALIDATE_PORT (1, port
);
720 if (SCM_CLOSEDP (port
))
722 i
= SCM_PTOBNUM (port
);
723 if (scm_ptobs
[i
].close
)
724 rv
= (scm_ptobs
[i
].close
) (port
);
727 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
728 scm_i_remove_port (port
);
729 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
730 SCM_CLR_PORT_OPEN_FLAG (port
);
731 return scm_from_bool (rv
>= 0);
735 SCM_DEFINE (scm_close_input_port
, "close-input-port", 1, 0, 0,
737 "Close the specified input port object. The routine has no effect if\n"
738 "the file has already been closed. An exception may be raised if an\n"
739 "error occurs. The value returned is unspecified.\n\n"
740 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
741 "which can close file descriptors.")
742 #define FUNC_NAME s_scm_close_input_port
744 SCM_VALIDATE_INPUT_PORT (1, port
);
745 scm_close_port (port
);
746 return SCM_UNSPECIFIED
;
750 SCM_DEFINE (scm_close_output_port
, "close-output-port", 1, 0, 0,
752 "Close the specified output port object. The routine has no effect if\n"
753 "the file has already been closed. An exception may be raised if an\n"
754 "error occurs. The value returned is unspecified.\n\n"
755 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
756 "which can close file descriptors.")
757 #define FUNC_NAME s_scm_close_output_port
759 port
= SCM_COERCE_OUTPORT (port
);
760 SCM_VALIDATE_OUTPUT_PORT (1, port
);
761 scm_close_port (port
);
762 return SCM_UNSPECIFIED
;
767 scm_i_collect_keys_in_vector (void *closure
, SCM key
, SCM value
, SCM result
)
769 int *i
= (int*) closure
;
770 scm_c_vector_set_x (result
, *i
, key
);
777 scm_c_port_for_each (void (*proc
)(void *data
, SCM p
), void *data
)
783 /* Even without pre-emptive multithreading, running arbitrary code
784 while scanning the port table is unsafe because the port table
785 can change arbitrarily (from a GC, for example). So we first
786 collect the ports into a vector. -mvo */
788 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
789 n
= SCM_HASHTABLE_N_ITEMS (scm_i_port_weak_hash
);
790 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
791 ports
= scm_c_make_vector (n
, SCM_BOOL_F
);
793 scm_i_pthread_mutex_lock (&scm_i_port_table_mutex
);
794 ports
= scm_internal_hash_fold (scm_i_collect_keys_in_vector
, &i
,
795 ports
, scm_i_port_weak_hash
);
796 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
798 for (i
= 0; i
< n
; i
++) {
799 SCM p
= SCM_SIMPLE_VECTOR_REF (ports
, i
);
804 scm_remember_upto_here_1 (ports
);
807 SCM_DEFINE (scm_port_for_each
, "port-for-each", 1, 0, 0,
809 "Apply @var{proc} to each port in the Guile port table\n"
810 "in turn. The return value is unspecified. More specifically,\n"
811 "@var{proc} is applied exactly once to every port that exists\n"
812 "in the system at the time @var{port-for-each} is invoked.\n"
813 "Changes to the port table while @var{port-for-each} is running\n"
814 "have no effect as far as @var{port-for-each} is concerned.")
815 #define FUNC_NAME s_scm_port_for_each
817 SCM_VALIDATE_PROC (1, proc
);
819 scm_c_port_for_each ((void (*)(void*,SCM
))scm_call_1
, proc
);
820 return SCM_UNSPECIFIED
;
826 /* Utter miscellany. Gosh, we should clean this up some time. */
828 SCM_DEFINE (scm_input_port_p
, "input-port?", 1, 0, 0,
830 "Return @code{#t} if @var{x} is an input port, otherwise return\n"
831 "@code{#f}. Any object satisfying this predicate also satisfies\n"
833 #define FUNC_NAME s_scm_input_port_p
835 return scm_from_bool (SCM_INPUT_PORT_P (x
));
839 SCM_DEFINE (scm_output_port_p
, "output-port?", 1, 0, 0,
841 "Return @code{#t} if @var{x} is an output port, otherwise return\n"
842 "@code{#f}. Any object satisfying this predicate also satisfies\n"
844 #define FUNC_NAME s_scm_output_port_p
846 x
= SCM_COERCE_OUTPORT (x
);
847 return scm_from_bool (SCM_OUTPUT_PORT_P (x
));
851 SCM_DEFINE (scm_port_p
, "port?", 1, 0, 0,
853 "Return a boolean indicating whether @var{x} is a port.\n"
854 "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
856 #define FUNC_NAME s_scm_port_p
858 return scm_from_bool (SCM_PORTP (x
));
862 SCM_DEFINE (scm_port_closed_p
, "port-closed?", 1, 0, 0,
864 "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
866 #define FUNC_NAME s_scm_port_closed_p
868 SCM_VALIDATE_PORT (1, port
);
869 return scm_from_bool (!SCM_OPPORTP (port
));
873 SCM_DEFINE (scm_eof_object_p
, "eof-object?", 1, 0, 0,
875 "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
877 #define FUNC_NAME s_scm_eof_object_p
879 return scm_from_bool(SCM_EOF_OBJECT_P (x
));
883 SCM_DEFINE (scm_force_output
, "force-output", 0, 1, 0,
885 "Flush the specified output port, or the current output port if @var{port}\n"
886 "is omitted. The current output buffer contents are passed to the\n"
887 "underlying port implementation (e.g., in the case of fports, the\n"
888 "data will be written to the file and the output buffer will be cleared.)\n"
889 "It has no effect on an unbuffered port.\n\n"
890 "The return value is unspecified.")
891 #define FUNC_NAME s_scm_force_output
893 if (SCM_UNBNDP (port
))
894 port
= scm_current_output_port ();
897 port
= SCM_COERCE_OUTPORT (port
);
898 SCM_VALIDATE_OPOUTPORT (1, port
);
901 return SCM_UNSPECIFIED
;
907 flush_output_port (void *closure
, SCM port
)
909 if (SCM_OPOUTPORTP (port
))
913 SCM_DEFINE (scm_flush_all_ports
, "flush-all-ports", 0, 0, 0,
915 "Equivalent to calling @code{force-output} on\n"
916 "all open output ports. The return value is unspecified.")
917 #define FUNC_NAME s_scm_flush_all_ports
919 scm_c_port_for_each (&flush_output_port
, NULL
);
920 return SCM_UNSPECIFIED
;
924 SCM_DEFINE (scm_read_char
, "read-char", 0, 1, 0,
926 "Return the next character available from @var{port}, updating\n"
927 "@var{port} to point to the following character. If no more\n"
928 "characters are available, the end-of-file object is returned.")
929 #define FUNC_NAME s_scm_read_char
932 if (SCM_UNBNDP (port
))
933 port
= scm_current_input_port ();
934 SCM_VALIDATE_OPINPORT (1, port
);
938 return SCM_MAKE_CHAR (c
);
942 /* this should only be called when the read buffer is empty. it
943 tries to refill the read buffer. it returns the first char from
944 the port, which is either EOF or *(pt->read_pos). */
946 scm_fill_input (SCM port
)
948 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
950 if (pt
->read_buf
== pt
->putback_buf
)
952 /* finished reading put-back chars. */
953 pt
->read_buf
= pt
->saved_read_buf
;
954 pt
->read_pos
= pt
->saved_read_pos
;
955 pt
->read_end
= pt
->saved_read_end
;
956 pt
->read_buf_size
= pt
->saved_read_buf_size
;
957 if (pt
->read_pos
< pt
->read_end
)
958 return *(pt
->read_pos
);
960 return scm_ptobs
[SCM_PTOBNUM (port
)].fill_input (port
);
966 * This function differs from scm_c_write; it updates port line and
970 scm_lfwrite (const char *ptr
, size_t size
, SCM port
)
972 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
973 scm_t_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
975 if (pt
->rw_active
== SCM_PORT_READ
)
976 scm_end_input (port
);
978 ptob
->write (port
, ptr
, size
);
980 for (; size
; ptr
++, size
--) {
983 else if (*ptr
== '\b') {
986 else if (*ptr
== '\n') {
989 else if (*ptr
== '\r') {
992 else if (*ptr
== '\t') {
1001 pt
->rw_active
= SCM_PORT_WRITE
;
1006 * Used by an application to read arbitrary number of bytes from an
1007 * SCM port. Same semantics as libc read, except that scm_c_read only
1008 * returns less than SIZE bytes if at end-of-file.
1010 * Warning: Doesn't update port line and column counts! */
1013 scm_c_read (SCM port
, void *buffer
, size_t size
)
1014 #define FUNC_NAME "scm_c_read"
1017 size_t n_read
= 0, n_available
;
1019 SCM_VALIDATE_OPINPORT (1, port
);
1021 pt
= SCM_PTAB_ENTRY (port
);
1022 if (pt
->rw_active
== SCM_PORT_WRITE
)
1023 scm_ptobs
[SCM_PTOBNUM (port
)].flush (port
);
1026 pt
->rw_active
= SCM_PORT_READ
;
1028 if (SCM_READ_BUFFER_EMPTY_P (pt
))
1030 if (scm_fill_input (port
) == EOF
)
1034 n_available
= pt
->read_end
- pt
->read_pos
;
1036 while (n_available
< size
)
1038 memcpy (buffer
, pt
->read_pos
, n_available
);
1039 buffer
= (char *) buffer
+ n_available
;
1040 pt
->read_pos
+= n_available
;
1041 n_read
+= n_available
;
1043 if (SCM_READ_BUFFER_EMPTY_P (pt
))
1045 if (scm_fill_input (port
) == EOF
)
1049 size
-= n_available
;
1050 n_available
= pt
->read_end
- pt
->read_pos
;
1053 memcpy (buffer
, pt
->read_pos
, size
);
1054 pt
->read_pos
+= size
;
1056 return n_read
+ size
;
1062 * Used by an application to write arbitrary number of bytes to an SCM
1063 * port. Similar semantics as libc write. However, unlike libc
1064 * write, scm_c_write writes the requested number of bytes and has no
1067 * Warning: Doesn't update port line and column counts!
1071 scm_c_write (SCM port
, const void *ptr
, size_t size
)
1072 #define FUNC_NAME "scm_c_write"
1075 scm_t_ptob_descriptor
*ptob
;
1077 SCM_VALIDATE_OPOUTPORT (1, port
);
1079 pt
= SCM_PTAB_ENTRY (port
);
1080 ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
1082 if (pt
->rw_active
== SCM_PORT_READ
)
1083 scm_end_input (port
);
1085 ptob
->write (port
, ptr
, size
);
1088 pt
->rw_active
= SCM_PORT_WRITE
;
1093 scm_flush (SCM port
)
1095 long i
= SCM_PTOBNUM (port
);
1096 (scm_ptobs
[i
].flush
) (port
);
1100 scm_end_input (SCM port
)
1103 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1105 if (pt
->read_buf
== pt
->putback_buf
)
1107 offset
= pt
->read_end
- pt
->read_pos
;
1108 pt
->read_buf
= pt
->saved_read_buf
;
1109 pt
->read_pos
= pt
->saved_read_pos
;
1110 pt
->read_end
= pt
->saved_read_end
;
1111 pt
->read_buf_size
= pt
->saved_read_buf_size
;
1116 scm_ptobs
[SCM_PTOBNUM (port
)].end_input (port
, offset
);
1123 scm_ungetc (int c
, SCM port
)
1124 #define FUNC_NAME "scm_ungetc"
1126 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1128 if (pt
->read_buf
== pt
->putback_buf
)
1129 /* already using the put-back buffer. */
1131 /* enlarge putback_buf if necessary. */
1132 if (pt
->read_end
== pt
->read_buf
+ pt
->read_buf_size
1133 && pt
->read_buf
== pt
->read_pos
)
1135 size_t new_size
= pt
->read_buf_size
* 2;
1136 unsigned char *tmp
= (unsigned char *)
1137 scm_gc_realloc (pt
->putback_buf
, pt
->read_buf_size
, new_size
,
1140 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
= tmp
;
1141 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
1142 pt
->read_buf_size
= pt
->putback_buf_size
= new_size
;
1145 /* shift any existing bytes to buffer + 1. */
1146 if (pt
->read_pos
== pt
->read_end
)
1147 pt
->read_end
= pt
->read_buf
+ 1;
1148 else if (pt
->read_pos
!= pt
->read_buf
+ 1)
1150 int count
= pt
->read_end
- pt
->read_pos
;
1152 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
1153 pt
->read_end
= pt
->read_buf
+ 1 + count
;
1156 pt
->read_pos
= pt
->read_buf
;
1159 /* switch to the put-back buffer. */
1161 if (pt
->putback_buf
== NULL
)
1164 = (unsigned char *) scm_gc_malloc (SCM_INITIAL_PUTBACK_BUF_SIZE
,
1166 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
1169 pt
->saved_read_buf
= pt
->read_buf
;
1170 pt
->saved_read_pos
= pt
->read_pos
;
1171 pt
->saved_read_end
= pt
->read_end
;
1172 pt
->saved_read_buf_size
= pt
->read_buf_size
;
1174 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
1175 pt
->read_end
= pt
->read_buf
+ 1;
1176 pt
->read_buf_size
= pt
->putback_buf_size
;
1182 pt
->rw_active
= SCM_PORT_READ
;
1186 /* What should col be in this case?
1187 * We'll leave it at -1.
1189 SCM_LINUM (port
) -= 1;
1198 scm_ungets (const char *s
, int n
, SCM port
)
1200 /* This is simple minded and inefficient, but unreading strings is
1201 * probably not a common operation, and remember that line and
1202 * column numbers have to be handled...
1204 * Please feel free to write an optimized version!
1207 scm_ungetc (s
[n
], port
);
1211 SCM_DEFINE (scm_peek_char
, "peek-char", 0, 1, 0,
1213 "Return the next character available from @var{port},\n"
1214 "@emph{without} updating @var{port} to point to the following\n"
1215 "character. If no more characters are available, the\n"
1216 "end-of-file object is returned.\n"
1218 "The value returned by\n"
1219 "a call to @code{peek-char} is the same as the value that would\n"
1220 "have been returned by a call to @code{read-char} on the same\n"
1221 "port. The only difference is that the very next call to\n"
1222 "@code{read-char} or @code{peek-char} on that @var{port} will\n"
1223 "return the value returned by the preceding call to\n"
1224 "@code{peek-char}. In particular, a call to @code{peek-char} on\n"
1225 "an interactive port will hang waiting for input whenever a call\n"
1226 "to @code{read-char} would have hung.")
1227 #define FUNC_NAME s_scm_peek_char
1230 if (SCM_UNBNDP (port
))
1231 port
= scm_current_input_port ();
1233 SCM_VALIDATE_OPINPORT (1, port
);
1234 column
= SCM_COL(port
);
1235 c
= scm_getc (port
);
1238 scm_ungetc (c
, port
);
1239 SCM_COL(port
) = column
;
1240 return SCM_MAKE_CHAR (c
);
1244 SCM_DEFINE (scm_unread_char
, "unread-char", 1, 1, 0,
1245 (SCM cobj
, SCM port
),
1246 "Place @var{char} in @var{port} so that it will be read by the\n"
1247 "next read operation. If called multiple times, the unread characters\n"
1248 "will be read again in last-in first-out order. If @var{port} is\n"
1249 "not supplied, the current input port is used.")
1250 #define FUNC_NAME s_scm_unread_char
1254 SCM_VALIDATE_CHAR (1, cobj
);
1255 if (SCM_UNBNDP (port
))
1256 port
= scm_current_input_port ();
1258 SCM_VALIDATE_OPINPORT (2, port
);
1260 c
= SCM_CHAR (cobj
);
1262 scm_ungetc (c
, port
);
1267 SCM_DEFINE (scm_unread_string
, "unread-string", 2, 0, 0,
1268 (SCM str
, SCM port
),
1269 "Place the string @var{str} in @var{port} so that its characters will be\n"
1270 "read in subsequent read operations. If called multiple times, the\n"
1271 "unread characters will be read again in last-in first-out order. If\n"
1272 "@var{port} is not supplied, the current-input-port is used.")
1273 #define FUNC_NAME s_scm_unread_string
1275 SCM_VALIDATE_STRING (1, str
);
1276 if (SCM_UNBNDP (port
))
1277 port
= scm_current_input_port ();
1279 SCM_VALIDATE_OPINPORT (2, port
);
1281 scm_ungets (scm_i_string_chars (str
), scm_i_string_length (str
), port
);
1287 SCM_DEFINE (scm_seek
, "seek", 3, 0, 0,
1288 (SCM fd_port
, SCM offset
, SCM whence
),
1289 "Sets the current position of @var{fd/port} to the integer\n"
1290 "@var{offset}, which is interpreted according to the value of\n"
1293 "One of the following variables should be supplied for\n"
1295 "@defvar SEEK_SET\n"
1296 "Seek from the beginning of the file.\n"
1298 "@defvar SEEK_CUR\n"
1299 "Seek from the current position.\n"
1301 "@defvar SEEK_END\n"
1302 "Seek from the end of the file.\n"
1304 "If @var{fd/port} is a file descriptor, the underlying system\n"
1305 "call is @code{lseek}. @var{port} may be a string port.\n"
1307 "The value returned is the new position in the file. This means\n"
1308 "that the current position of a port can be obtained using:\n"
1310 "(seek port 0 SEEK_CUR)\n"
1312 #define FUNC_NAME s_scm_seek
1316 fd_port
= SCM_COERCE_OUTPORT (fd_port
);
1318 how
= scm_to_int (whence
);
1319 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
1320 SCM_OUT_OF_RANGE (3, whence
);
1322 if (SCM_OPFPORTP (fd_port
))
1324 /* go direct to fport code to allow 64-bit offsets */
1325 return scm_i_fport_seek (fd_port
, offset
, how
);
1327 else if (SCM_OPPORTP (fd_port
))
1329 scm_t_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (fd_port
);
1330 off_t off
= scm_to_off_t (offset
);
1334 SCM_MISC_ERROR ("port is not seekable",
1335 scm_cons (fd_port
, SCM_EOL
));
1337 rv
= ptob
->seek (fd_port
, off
, how
);
1338 return scm_from_off_t (rv
);
1340 else /* file descriptor?. */
1342 off_t_or_off64_t off
= scm_to_off_t_or_off64_t (offset
);
1343 off_t_or_off64_t rv
;
1344 rv
= lseek_or_lseek64 (scm_to_int (fd_port
), off
, how
);
1347 return scm_from_off_t_or_off64_t (rv
);
1356 /* Mingw has ftruncate(), perhaps implemented above using chsize, but
1357 doesn't have the filename version truncate(), hence this code. */
1358 #if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
1360 truncate (const char *file
, off_t length
)
1364 fdes
= open (file
, O_BINARY
| O_WRONLY
);
1368 ret
= ftruncate (fdes
, length
);
1371 int save_errno
= errno
;
1377 return close (fdes
);
1379 #endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
1381 SCM_DEFINE (scm_truncate_file
, "truncate-file", 1, 1, 0,
1382 (SCM object
, SCM length
),
1383 "Truncate @var{file} to @var{length} bytes. @var{file} can be a\n"
1384 "filename string, a port object, or an integer file descriptor.\n"
1385 "The return value is unspecified.\n"
1387 "For a port or file descriptor @var{length} can be omitted, in\n"
1388 "which case the file is truncated at the current position (per\n"
1389 "@code{ftell} above).\n"
1391 "On most systems a file can be extended by giving a length\n"
1392 "greater than the current size, but this is not mandatory in the\n"
1394 #define FUNC_NAME s_scm_truncate_file
1398 /* "object" can be a port, fdes or filename.
1400 Negative "length" makes no sense, but it's left to truncate() or
1401 ftruncate() to give back an error for that (normally EINVAL).
1404 if (SCM_UNBNDP (length
))
1406 /* must supply length if object is a filename. */
1407 if (scm_is_string (object
))
1408 SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL
);
1410 length
= scm_seek (object
, SCM_INUM0
, scm_from_int (SEEK_CUR
));
1413 object
= SCM_COERCE_OUTPORT (object
);
1414 if (scm_is_integer (object
))
1416 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
1417 SCM_SYSCALL (rv
= ftruncate_or_ftruncate64 (scm_to_int (object
),
1420 else if (SCM_OPOUTFPORTP (object
))
1422 /* go direct to fport code to allow 64-bit offsets */
1423 rv
= scm_i_fport_truncate (object
, length
);
1425 else if (SCM_OPOUTPORTP (object
))
1427 off_t c_length
= scm_to_off_t (length
);
1428 scm_t_port
*pt
= SCM_PTAB_ENTRY (object
);
1429 scm_t_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1431 if (!ptob
->truncate
)
1432 SCM_MISC_ERROR ("port is not truncatable", SCM_EOL
);
1433 if (pt
->rw_active
== SCM_PORT_READ
)
1434 scm_end_input (object
);
1435 else if (pt
->rw_active
== SCM_PORT_WRITE
)
1436 ptob
->flush (object
);
1438 ptob
->truncate (object
, c_length
);
1443 off_t_or_off64_t c_length
= scm_to_off_t_or_off64_t (length
);
1444 char *str
= scm_to_locale_string (object
);
1446 SCM_SYSCALL (rv
= truncate_or_truncate64 (str
, c_length
));
1453 return SCM_UNSPECIFIED
;
1457 SCM_DEFINE (scm_port_line
, "port-line", 1, 0, 0,
1459 "Return the current line number for @var{port}.\n"
1461 "The first line of a file is 0. But you might want to add 1\n"
1462 "when printing line numbers, since starting from 1 is\n"
1463 "traditional in error messages, and likely to be more natural to\n"
1465 #define FUNC_NAME s_scm_port_line
1467 port
= SCM_COERCE_OUTPORT (port
);
1468 SCM_VALIDATE_OPENPORT (1, port
);
1469 return scm_from_long (SCM_LINUM (port
));
1473 SCM_DEFINE (scm_set_port_line_x
, "set-port-line!", 2, 0, 0,
1474 (SCM port
, SCM line
),
1475 "Set the current line number for @var{port} to @var{line}. The\n"
1476 "first line of a file is 0.")
1477 #define FUNC_NAME s_scm_set_port_line_x
1479 port
= SCM_COERCE_OUTPORT (port
);
1480 SCM_VALIDATE_OPENPORT (1, port
);
1481 SCM_PTAB_ENTRY (port
)->line_number
= scm_to_long (line
);
1482 return SCM_UNSPECIFIED
;
1486 SCM_DEFINE (scm_port_column
, "port-column", 1, 0, 0,
1488 "Return the current column number of @var{port}.\n"
1489 "If the number is\n"
1490 "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
1491 "- i.e. the first character of the first line is line 0, column 0.\n"
1492 "(However, when you display a file position, for example in an error\n"
1493 "message, we recommend you add 1 to get 1-origin integers. This is\n"
1494 "because lines and column numbers traditionally start with 1, and that is\n"
1495 "what non-programmers will find most natural.)")
1496 #define FUNC_NAME s_scm_port_column
1498 port
= SCM_COERCE_OUTPORT (port
);
1499 SCM_VALIDATE_OPENPORT (1, port
);
1500 return scm_from_int (SCM_COL (port
));
1504 SCM_DEFINE (scm_set_port_column_x
, "set-port-column!", 2, 0, 0,
1505 (SCM port
, SCM column
),
1506 "Set the current column of @var{port}. Before reading the first\n"
1507 "character on a line the column should be 0.")
1508 #define FUNC_NAME s_scm_set_port_column_x
1510 port
= SCM_COERCE_OUTPORT (port
);
1511 SCM_VALIDATE_OPENPORT (1, port
);
1512 SCM_PTAB_ENTRY (port
)->column_number
= scm_to_int (column
);
1513 return SCM_UNSPECIFIED
;
1517 SCM_DEFINE (scm_port_filename
, "port-filename", 1, 0, 0,
1519 "Return the filename associated with @var{port}. This function returns\n"
1520 "the strings \"standard input\", \"standard output\" and \"standard error\"\n"
1521 "when called on the current input, output and error ports respectively.")
1522 #define FUNC_NAME s_scm_port_filename
1524 port
= SCM_COERCE_OUTPORT (port
);
1525 SCM_VALIDATE_OPENPORT (1, port
);
1526 return SCM_FILENAME (port
);
1530 SCM_DEFINE (scm_set_port_filename_x
, "set-port-filename!", 2, 0, 0,
1531 (SCM port
, SCM filename
),
1532 "Change the filename associated with @var{port}, using the current input\n"
1533 "port if none is specified. Note that this does not change the port's\n"
1534 "source of data, but only the value that is returned by\n"
1535 "@code{port-filename} and reported in diagnostic output.")
1536 #define FUNC_NAME s_scm_set_port_filename_x
1538 port
= SCM_COERCE_OUTPORT (port
);
1539 SCM_VALIDATE_OPENPORT (1, port
);
1540 /* We allow the user to set the filename to whatever he likes. */
1541 SCM_SET_FILENAME (port
, filename
);
1542 return SCM_UNSPECIFIED
;
1547 scm_print_port_mode (SCM exp
, SCM port
)
1549 scm_puts (SCM_CLOSEDP (exp
)
1551 : (SCM_RDNG
& SCM_CELL_WORD_0 (exp
)
1552 ? (SCM_WRTNG
& SCM_CELL_WORD_0 (exp
)
1555 : (SCM_WRTNG
& SCM_CELL_WORD_0 (exp
)
1562 scm_port_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1564 char *type
= SCM_PTOBNAME (SCM_PTOBNUM (exp
));
1567 scm_puts ("#<", port
);
1568 scm_print_port_mode (exp
, port
);
1569 scm_puts (type
, port
);
1570 scm_putc (' ', port
);
1571 scm_uintprint (SCM_CELL_WORD_1 (exp
), 16, port
);
1572 scm_putc ('>', port
);
1577 scm_ports_prehistory ()
1580 scm_ptobs
= (scm_t_ptob_descriptor
*) scm_malloc (sizeof (scm_t_ptob_descriptor
));
1587 scm_t_bits scm_tc16_void_port
= 0;
1589 static int fill_input_void_port (SCM port SCM_UNUSED
)
1595 write_void_port (SCM port SCM_UNUSED
,
1596 const void *data SCM_UNUSED
,
1597 size_t size SCM_UNUSED
)
1602 scm_i_void_port (long mode_bits
)
1604 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
1606 SCM answer
= scm_new_port_table_entry (scm_tc16_void_port
);
1607 scm_t_port
* pt
= SCM_PTAB_ENTRY(answer
);
1609 scm_port_non_buffer (pt
);
1611 SCM_SETSTREAM (answer
, 0);
1612 SCM_SET_CELL_TYPE (answer
, scm_tc16_void_port
| mode_bits
);
1613 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
1619 scm_void_port (char *mode_str
)
1621 return scm_i_void_port (scm_mode_bits (mode_str
));
1624 SCM_DEFINE (scm_sys_make_void_port
, "%make-void-port", 1, 0, 0,
1626 "Create and return a new void port. A void port acts like\n"
1627 "@file{/dev/null}. The @var{mode} argument\n"
1628 "specifies the input/output modes for this port: see the\n"
1629 "documentation for @code{open-file} in @ref{File Ports}.")
1630 #define FUNC_NAME s_scm_sys_make_void_port
1632 return scm_i_void_port (scm_i_mode_bits (mode
));
1637 /* Initialization. */
1642 /* lseek() symbols. */
1643 scm_c_define ("SEEK_SET", scm_from_int (SEEK_SET
));
1644 scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR
));
1645 scm_c_define ("SEEK_END", scm_from_int (SEEK_END
));
1647 scm_tc16_void_port
= scm_make_port_type ("void", fill_input_void_port
,
1650 cur_inport_fluid
= scm_permanent_object (scm_make_fluid ());
1651 cur_outport_fluid
= scm_permanent_object (scm_make_fluid ());
1652 cur_errport_fluid
= scm_permanent_object (scm_make_fluid ());
1653 cur_loadport_fluid
= scm_permanent_object (scm_make_fluid ());
1655 scm_i_port_weak_hash
= scm_permanent_object (scm_make_weak_key_hash_table (SCM_I_MAKINUM(31)));
1657 #include "libguile/ports.x"