1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program 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
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
49 #include "libguile/_scm.h"
50 #include "libguile/eval.h"
51 #include "libguile/objects.h"
52 #include "libguile/smob.h"
53 #include "libguile/chars.h"
55 #include "libguile/keywords.h"
56 #include "libguile/root.h"
57 #include "libguile/strings.h"
59 #include "libguile/validate.h"
60 #include "libguile/ports.h"
74 #ifdef HAVE_SYS_IOCTL_H
75 #include <sys/ioctl.h>
80 #define ftruncate(fd, size) chsize (fd, size)
84 /* The port kind table --- a dynamically resized array of port types. */
87 /* scm_ptobs scm_numptob
88 * implement a dynamicly resized array of ptob records.
89 * Indexes into this table are used when generating type
90 * tags for smobjects (if you know a tag you can get an index and conversely).
92 scm_t_ptob_descriptor
*scm_ptobs
;
95 /* GC marker for a port with stream of SCM type. */
97 scm_markstream (SCM ptr
)
100 openp
= SCM_CELL_WORD_0 (ptr
) & SCM_OPN
;
102 return SCM_PACK (SCM_STREAM (ptr
));
108 * We choose to use an interface similar to the smob interface with
109 * fill_input and write as standard fields, passed to the port
110 * type constructor, and optional fields set by setters.
114 flush_port_default (SCM port SCM_UNUSED
)
119 end_input_default (SCM port SCM_UNUSED
, int offset SCM_UNUSED
)
124 scm_make_port_type (char *name
,
125 int (*fill_input
) (SCM port
),
126 void (*write
) (SCM port
, const void *data
, size_t size
))
129 if (255 <= scm_numptob
)
132 SCM_SYSCALL (tmp
= (char *) realloc ((char *) scm_ptobs
,
134 * sizeof (scm_t_ptob_descriptor
)));
137 scm_ptobs
= (scm_t_ptob_descriptor
*) tmp
;
139 scm_ptobs
[scm_numptob
].name
= name
;
140 scm_ptobs
[scm_numptob
].mark
= 0;
141 scm_ptobs
[scm_numptob
].free
= scm_free0
;
142 scm_ptobs
[scm_numptob
].print
= scm_port_print
;
143 scm_ptobs
[scm_numptob
].equalp
= 0;
144 scm_ptobs
[scm_numptob
].close
= 0;
146 scm_ptobs
[scm_numptob
].write
= write
;
147 scm_ptobs
[scm_numptob
].flush
= flush_port_default
;
149 scm_ptobs
[scm_numptob
].end_input
= end_input_default
;
150 scm_ptobs
[scm_numptob
].fill_input
= fill_input
;
151 scm_ptobs
[scm_numptob
].input_waiting
= 0;
153 scm_ptobs
[scm_numptob
].seek
= 0;
154 scm_ptobs
[scm_numptob
].truncate
= 0;
162 scm_memory_error ("scm_make_port_type");
164 /* Make a class object if Goops is present */
166 scm_make_port_classes (scm_numptob
- 1, SCM_PTOBNAME (scm_numptob
- 1));
167 return scm_tc7_port
+ (scm_numptob
- 1) * 256;
171 scm_set_port_mark (long tc
, SCM (*mark
) (SCM
))
173 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].mark
= mark
;
177 scm_set_port_free (long tc
, size_t (*free
) (SCM
))
179 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].free
= free
;
183 scm_set_port_print (long tc
, int (*print
) (SCM exp
, SCM port
,
184 scm_print_state
*pstate
))
186 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].print
= print
;
190 scm_set_port_equalp (long tc
, SCM (*equalp
) (SCM
, SCM
))
192 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].equalp
= equalp
;
196 scm_set_port_flush (long tc
, void (*flush
) (SCM port
))
198 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].flush
= flush
;
202 scm_set_port_end_input (long tc
, void (*end_input
) (SCM port
, int offset
))
204 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].end_input
= end_input
;
208 scm_set_port_close (long tc
, int (*close
) (SCM
))
210 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].close
= close
;
214 scm_set_port_seek (long tc
, off_t (*seek
) (SCM port
,
218 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].seek
= seek
;
222 scm_set_port_truncate (long tc
, void (*truncate
) (SCM port
, off_t length
))
224 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].truncate
= truncate
;
228 scm_set_port_input_waiting (long tc
, int (*input_waiting
) (SCM
))
230 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].input_waiting
= input_waiting
;
235 SCM_DEFINE (scm_char_ready_p
, "char-ready?", 0, 1, 0,
237 "Return @code{#t} if a character is ready on input @var{port}\n"
238 "and return @code{#f} otherwise. If @code{char-ready?} returns\n"
239 "@code{#t} then the next @code{read-char} operation on\n"
240 "@var{port} is guaranteed not to hang. If @var{port} is a file\n"
241 "port at end of file then @code{char-ready?} returns @code{#t}.\n"
242 "@footnote{@code{char-ready?} exists to make it possible for a\n"
243 "program to accept characters from interactive ports without\n"
244 "getting stuck waiting for input. Any input editors associated\n"
245 "with such ports must make sure that characters whose existence\n"
246 "has been asserted by @code{char-ready?} cannot be rubbed out.\n"
247 "If @code{char-ready?} were to return @code{#f} at end of file,\n"
248 "a port at end of file would be indistinguishable from an\n"
249 "interactive port that has no ready characters.}")
250 #define FUNC_NAME s_scm_char_ready_p
254 if (SCM_UNBNDP (port
))
257 SCM_VALIDATE_OPINPORT (1,port
);
259 pt
= SCM_PTAB_ENTRY (port
);
261 /* if the current read buffer is filled, or the
262 last pushed-back char has been read and the saved buffer is
263 filled, result is true. */
264 if (pt
->read_pos
< pt
->read_end
265 || (pt
->read_buf
== pt
->putback_buf
266 && pt
->saved_read_pos
< pt
->saved_read_end
))
270 scm_t_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
272 if (ptob
->input_waiting
)
273 return SCM_BOOL(ptob
->input_waiting (port
));
280 /* move up to read_len chars from port's putback and/or read buffers
281 into memory starting at dest. returns the number of chars moved. */
282 size_t scm_take_from_input_buffers (SCM port
, char *dest
, size_t read_len
)
284 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
285 size_t chars_read
= 0;
286 size_t from_buf
= min (pt
->read_end
- pt
->read_pos
, read_len
);
290 memcpy (dest
, pt
->read_pos
, from_buf
);
291 pt
->read_pos
+= from_buf
;
292 chars_read
+= from_buf
;
293 read_len
-= from_buf
;
297 /* if putback was active, try the real input buffer too. */
298 if (pt
->read_buf
== pt
->putback_buf
)
300 from_buf
= min (pt
->saved_read_end
- pt
->saved_read_pos
, read_len
);
303 memcpy (dest
, pt
->saved_read_pos
, from_buf
);
304 pt
->saved_read_pos
+= from_buf
;
305 chars_read
+= from_buf
;
311 /* Clear a port's read buffers, returning the contents. */
312 SCM_DEFINE (scm_drain_input
, "drain-input", 1, 0, 0,
314 "Drain @var{port}'s read buffers (including any pushed-back\n"
315 "characters) and return the content as a single string.")
316 #define FUNC_NAME s_scm_drain_input
319 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
322 SCM_VALIDATE_OPINPORT (1,port
);
324 count
= pt
->read_end
- pt
->read_pos
;
325 if (pt
->read_buf
== pt
->putback_buf
)
326 count
+= pt
->saved_read_end
- pt
->saved_read_pos
;
328 result
= scm_allocate_string (count
);
329 scm_take_from_input_buffers (port
, SCM_STRING_CHARS (result
), count
);
336 /* Standard ports --- current input, output, error, and more(!). */
338 SCM_DEFINE (scm_current_input_port
, "current-input-port", 0, 0, 0,
340 "Return the current input port. This is the default port used\n"
341 "by many input procedures. Initially, @code{current-input-port}\n"
342 "returns the @dfn{standard input} in Unix and C terminology.")
343 #define FUNC_NAME s_scm_current_input_port
349 SCM_DEFINE (scm_current_output_port
, "current-output-port", 0, 0, 0,
351 "Return the current output port. This is the default port used\n"
352 "by many output procedures. Initially, \n"
353 "@code{current-output-port} returns the @dfn{standard output} in\n"
354 "Unix and C terminology.")
355 #define FUNC_NAME s_scm_current_output_port
361 SCM_DEFINE (scm_current_error_port
, "current-error-port", 0, 0, 0,
363 "Return the port to which errors and warnings should be sent (the\n"
364 "@dfn{standard error} in Unix and C terminology).")
365 #define FUNC_NAME s_scm_current_error_port
371 SCM_DEFINE (scm_current_load_port
, "current-load-port", 0, 0, 0,
373 "Return the current-load-port.\n"
374 "The load port is used internally by @code{primitive-load}.")
375 #define FUNC_NAME s_scm_current_load_port
377 return scm_cur_loadp
;
381 SCM_DEFINE (scm_set_current_input_port
, "set-current-input-port", 1, 0, 0,
383 "@deffnx primitive set-current-output-port port\n"
384 "@deffnx primitive set-current-error-port port\n"
385 "Change the ports returned by @code{current-input-port},\n"
386 "@code{current-output-port} and @code{current-error-port}, respectively,\n"
387 "so that they use the supplied @var{port} for input or output.")
388 #define FUNC_NAME s_scm_set_current_input_port
390 SCM oinp
= scm_cur_inp
;
391 SCM_VALIDATE_OPINPORT (1,port
);
398 SCM_DEFINE (scm_set_current_output_port
, "set-current-output-port", 1, 0, 0,
400 "Set the current default output port to @var{port}.")
401 #define FUNC_NAME s_scm_set_current_output_port
403 SCM ooutp
= scm_cur_outp
;
404 port
= SCM_COERCE_OUTPORT (port
);
405 SCM_VALIDATE_OPOUTPORT (1,port
);
412 SCM_DEFINE (scm_set_current_error_port
, "set-current-error-port", 1, 0, 0,
414 "Set the current default error port to @var{port}.")
415 #define FUNC_NAME s_scm_set_current_error_port
417 SCM oerrp
= scm_cur_errp
;
418 port
= SCM_COERCE_OUTPORT (port
);
419 SCM_VALIDATE_OPOUTPORT (1,port
);
426 /* The port table --- an array of pointers to ports. */
428 scm_t_port
**scm_port_table
;
430 long scm_port_table_size
= 0; /* Number of ports in scm_port_table. */
431 long scm_port_table_room
= 20; /* Size of the array. */
433 /* Add a port to the table. */
436 scm_add_to_port_table (SCM port
)
437 #define FUNC_NAME "scm_add_to_port_table"
441 if (scm_port_table_size
== scm_port_table_room
)
443 /* initial malloc is in gc.c. this doesn't use scm_must_malloc etc.,
444 since it can never be freed during gc. */
445 void *newt
= realloc ((char *) scm_port_table
,
446 (size_t) (sizeof (scm_t_port
*)
447 * scm_port_table_room
* 2));
449 scm_memory_error ("scm_add_to_port_table");
450 scm_port_table
= (scm_t_port
**) newt
;
451 scm_port_table_room
*= 2;
453 entry
= (scm_t_port
*) scm_must_malloc (sizeof (scm_t_port
), FUNC_NAME
);
456 entry
->entry
= scm_port_table_size
;
459 entry
->file_name
= SCM_BOOL_F
;
460 entry
->line_number
= 0;
461 entry
->column_number
= 0;
462 entry
->putback_buf
= 0;
463 entry
->putback_buf_size
= 0;
464 entry
->rw_active
= SCM_PORT_NEITHER
;
465 entry
->rw_random
= 0;
467 scm_port_table
[scm_port_table_size
] = entry
;
468 scm_port_table_size
++;
474 /* Remove a port from the table and destroy it. */
477 scm_remove_from_port_table (SCM port
)
478 #define FUNC_NAME "scm_remove_from_port_table"
480 scm_t_port
*p
= SCM_PTAB_ENTRY (port
);
483 if (i
>= scm_port_table_size
)
484 SCM_MISC_ERROR ("Port not in table: ~S", scm_list_1 (port
));
486 scm_must_free (p
->putback_buf
);
488 /* Since we have just freed slot i we can shrink the table by moving
489 the last entry to that slot... */
490 if (i
< scm_port_table_size
- 1)
492 scm_port_table
[i
] = scm_port_table
[scm_port_table_size
- 1];
493 scm_port_table
[i
]->entry
= i
;
495 SCM_SETPTAB_ENTRY (port
, 0);
496 scm_port_table_size
--;
502 /* Functions for debugging. */
504 SCM_DEFINE (scm_pt_size
, "pt-size", 0, 0, 0,
506 "Return the number of ports in the port table. @code{pt-size}\n"
507 "is only included in @code{--enable-guile-debug} builds.")
508 #define FUNC_NAME s_scm_pt_size
510 return SCM_MAKINUM (scm_port_table_size
);
514 SCM_DEFINE (scm_pt_member
, "pt-member", 1, 0, 0,
516 "Return the port at @var{index} in the port table.\n"
517 "@code{pt-member} is only included in\n"
518 "@code{--enable-guile-debug} builds.")
519 #define FUNC_NAME s_scm_pt_member
522 SCM_VALIDATE_INUM_COPY (1,index
,i
);
523 if (i
< 0 || i
>= scm_port_table_size
)
526 return scm_port_table
[i
]->port
;
532 scm_port_non_buffer (scm_t_port
*pt
)
534 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
535 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
536 pt
->read_buf_size
= pt
->write_buf_size
= 1;
537 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
541 /* Revealed counts --- an oddity inherited from SCSH. */
543 /* Find a port in the table and return its revealed count.
544 Also used by the garbage collector.
548 scm_revealed_count (SCM port
)
550 return SCM_REVEALED(port
);
555 /* Return the revealed count for a port. */
557 SCM_DEFINE (scm_port_revealed
, "port-revealed", 1, 0, 0,
559 "Return the revealed count for @var{port}.")
560 #define FUNC_NAME s_scm_port_revealed
562 port
= SCM_COERCE_OUTPORT (port
);
563 SCM_VALIDATE_OPENPORT (1,port
);
564 return SCM_MAKINUM (scm_revealed_count (port
));
568 /* Set the revealed count for a port. */
569 SCM_DEFINE (scm_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0,
570 (SCM port
, SCM rcount
),
571 "Sets the revealed count for a port to a given value.\n"
572 "The return value is unspecified.")
573 #define FUNC_NAME s_scm_set_port_revealed_x
575 port
= SCM_COERCE_OUTPORT (port
);
576 SCM_VALIDATE_OPENPORT (1,port
);
577 SCM_VALIDATE_INUM (2,rcount
);
578 SCM_REVEALED (port
) = SCM_INUM (rcount
);
579 return SCM_UNSPECIFIED
;
585 /* Retrieving a port's mode. */
587 /* Return the flags that characterize a port based on the mode
588 * string used to open a file for that port.
590 * See PORT FLAGS in scm.h
594 scm_mode_bits (char *modes
)
597 | (strchr (modes
, 'r') || strchr (modes
, '+') ? SCM_RDNG
: 0)
598 | ( strchr (modes
, 'w')
599 || strchr (modes
, 'a')
600 || strchr (modes
, '+') ? SCM_WRTNG
: 0)
601 | (strchr (modes
, '0') ? SCM_BUF0
: 0)
602 | (strchr (modes
, 'l') ? SCM_BUFLINE
: 0));
606 /* Return the mode flags from an open port.
607 * Some modes such as "append" are only used when opening
608 * a file and are not returned here. */
610 SCM_DEFINE (scm_port_mode
, "port-mode", 1, 0, 0,
612 "Return the port modes associated with the open port @var{port}.\n"
613 "These will not necessarily be identical to the modes used when\n"
614 "the port was opened, since modes such as \"append\" which are\n"
615 "used only during port creation are not retained.")
616 #define FUNC_NAME s_scm_port_mode
621 port
= SCM_COERCE_OUTPORT (port
);
622 SCM_VALIDATE_OPPORT (1,port
);
623 if (SCM_CELL_WORD_0 (port
) & SCM_RDNG
) {
624 if (SCM_CELL_WORD_0 (port
) & SCM_WRTNG
)
625 strcpy (modes
, "r+");
629 else if (SCM_CELL_WORD_0 (port
) & SCM_WRTNG
)
631 if (SCM_CELL_WORD_0 (port
) & SCM_BUF0
)
633 return scm_mem2string (modes
, strlen (modes
));
642 * Call the close operation on a port object.
643 * see also scm_close.
645 SCM_DEFINE (scm_close_port
, "close-port", 1, 0, 0,
647 "Close the specified port object. Return @code{#t} if it\n"
648 "successfully closes a port or @code{#f} if it was already\n"
649 "closed. An exception may be raised if an error occurs, for\n"
650 "example when flushing buffered output. See also @ref{Ports and\n"
651 "File Descriptors, close}, for a procedure which can close file\n"
653 #define FUNC_NAME s_scm_close_port
658 port
= SCM_COERCE_OUTPORT (port
);
660 SCM_VALIDATE_PORT (1, port
);
661 if (SCM_CLOSEDP (port
))
663 i
= SCM_PTOBNUM (port
);
664 if (scm_ptobs
[i
].close
)
665 rv
= (scm_ptobs
[i
].close
) (port
);
668 scm_remove_from_port_table (port
);
669 SCM_CLR_PORT_OPEN_FLAG (port
);
670 return SCM_BOOL (rv
>= 0);
674 SCM_DEFINE (scm_close_input_port
, "close-input-port", 1, 0, 0,
676 "Close the specified input port object. The routine has no effect if\n"
677 "the file has already been closed. An exception may be raised if an\n"
678 "error occurs. The value returned is unspecified.\n\n"
679 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
680 "which can close file descriptors.")
681 #define FUNC_NAME s_scm_close_input_port
683 SCM_VALIDATE_INPUT_PORT (1, port
);
684 scm_close_port (port
);
685 return SCM_UNSPECIFIED
;
689 SCM_DEFINE (scm_close_output_port
, "close-output-port", 1, 0, 0,
691 "Close the specified output port object. The routine has no effect if\n"
692 "the file has already been closed. An exception may be raised if an\n"
693 "error occurs. The value returned is unspecified.\n\n"
694 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
695 "which can close file descriptors.")
696 #define FUNC_NAME s_scm_close_output_port
698 port
= SCM_COERCE_OUTPORT (port
);
699 SCM_VALIDATE_OUTPUT_PORT (1, port
);
700 scm_close_port (port
);
701 return SCM_UNSPECIFIED
;
705 SCM_DEFINE (scm_port_for_each
, "port-for-each", 1, 0, 0,
707 "Apply @var{proc} to each port in the Guile port table\n"
708 "in turn. The return value is unspecified. More specifically,\n"
709 "@var{proc} is applied exactly once to every port that exists\n"
710 "in the system at the time @var{port-for-each} is invoked.\n"
711 "Changes to the port table while @var{port-for-each} is running\n"
712 "have no effect as far as @var{port-for-each} is concerned.\n")
713 #define FUNC_NAME s_scm_port_for_each
718 SCM_VALIDATE_PROC (1, proc
);
720 /* when pre-emptive multithreading is supported, access to the port
721 table will need to be controlled by a mutex. */
723 /* Even without pre-emptive multithreading, running arbitrary code
724 while scanning the port table is unsafe because the port table
725 can change arbitrarily (from a GC, for example). So we build a
726 list in advance while blocking the GC. -mvo */
731 for (i
= 0; i
< scm_port_table_size
; i
++)
732 ports
= scm_cons (scm_port_table
[i
]->port
, ports
);
736 while (ports
!= SCM_EOL
)
738 scm_call_1 (proc
, SCM_CAR (ports
));
739 ports
= SCM_CDR (ports
);
742 return SCM_UNSPECIFIED
;
747 /* Utter miscellany. Gosh, we should clean this up some time. */
749 SCM_DEFINE (scm_input_port_p
, "input-port?", 1, 0, 0,
751 "Return @code{#t} if @var{x} is an input port, otherwise return\n"
752 "@code{#f}. Any object satisfying this predicate also satisfies\n"
754 #define FUNC_NAME s_scm_input_port_p
756 return SCM_BOOL (SCM_INPUT_PORT_P (x
));
760 SCM_DEFINE (scm_output_port_p
, "output-port?", 1, 0, 0,
762 "Return @code{#t} if @var{x} is an output port, otherwise return\n"
763 "@code{#f}. Any object satisfying this predicate also satisfies\n"
765 #define FUNC_NAME s_scm_output_port_p
767 x
= SCM_COERCE_OUTPORT (x
);
768 return SCM_BOOL (SCM_OUTPUT_PORT_P (x
));
772 SCM_DEFINE (scm_port_p
, "port?", 1, 0, 0,
774 "Return a boolean indicating whether @var{x} is a port.\n"
775 "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
777 #define FUNC_NAME s_scm_port_p
779 return SCM_BOOL (SCM_PORTP (x
));
783 SCM_DEFINE (scm_port_closed_p
, "port-closed?", 1, 0, 0,
785 "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
787 #define FUNC_NAME s_scm_port_closed_p
789 SCM_VALIDATE_PORT (1,port
);
790 return SCM_BOOL (!SCM_OPPORTP (port
));
794 SCM_DEFINE (scm_eof_object_p
, "eof-object?", 1, 0, 0,
796 "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
798 #define FUNC_NAME s_scm_eof_object_p
800 return SCM_BOOL(SCM_EOF_OBJECT_P (x
));
804 SCM_DEFINE (scm_force_output
, "force-output", 0, 1, 0,
806 "Flush the specified output port, or the current output port if @var{port}\n"
807 "is omitted. The current output buffer contents are passed to the \n"
808 "underlying port implementation (e.g., in the case of fports, the\n"
809 "data will be written to the file and the output buffer will be cleared.)\n"
810 "It has no effect on an unbuffered port.\n\n"
811 "The return value is unspecified.")
812 #define FUNC_NAME s_scm_force_output
814 if (SCM_UNBNDP (port
))
818 port
= SCM_COERCE_OUTPORT (port
);
819 SCM_VALIDATE_OPOUTPORT (1,port
);
822 return SCM_UNSPECIFIED
;
826 SCM_DEFINE (scm_flush_all_ports
, "flush-all-ports", 0, 0, 0,
828 "Equivalent to calling @code{force-output} on\n"
829 "all open output ports. The return value is unspecified.")
830 #define FUNC_NAME s_scm_flush_all_ports
834 for (i
= 0; i
< scm_port_table_size
; i
++)
836 if (SCM_OPOUTPORTP (scm_port_table
[i
]->port
))
837 scm_flush (scm_port_table
[i
]->port
);
839 return SCM_UNSPECIFIED
;
843 SCM_DEFINE (scm_read_char
, "read-char", 0, 1, 0,
845 "Return the next character available from @var{port}, updating\n"
846 "@var{port} to point to the following character. If no more\n"
847 "characters are available, the end-of-file object is returned.")
848 #define FUNC_NAME s_scm_read_char
851 if (SCM_UNBNDP (port
))
853 SCM_VALIDATE_OPINPORT (1,port
);
857 return SCM_MAKE_CHAR (c
);
861 /* this should only be called when the read buffer is empty. it
862 tries to refill the read buffer. it returns the first char from
863 the port, which is either EOF or *(pt->read_pos). */
865 scm_fill_input (SCM port
)
867 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
869 if (pt
->read_buf
== pt
->putback_buf
)
871 /* finished reading put-back chars. */
872 pt
->read_buf
= pt
->saved_read_buf
;
873 pt
->read_pos
= pt
->saved_read_pos
;
874 pt
->read_end
= pt
->saved_read_end
;
875 pt
->read_buf_size
= pt
->saved_read_buf_size
;
876 if (pt
->read_pos
< pt
->read_end
)
877 return *(pt
->read_pos
);
879 return scm_ptobs
[SCM_PTOBNUM (port
)].fill_input (port
);
886 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
888 if (pt
->rw_active
== SCM_PORT_WRITE
)
890 /* may be marginally faster than calling scm_flush. */
891 scm_ptobs
[SCM_PTOBNUM (port
)].flush (port
);
895 pt
->rw_active
= SCM_PORT_READ
;
897 if (pt
->read_pos
>= pt
->read_end
)
899 if (scm_fill_input (port
) == EOF
)
903 c
= *(pt
->read_pos
++);
922 scm_putc (char c
, SCM port
)
924 scm_lfwrite (&c
, 1, port
);
928 scm_puts (const char *s
, SCM port
)
930 scm_lfwrite (s
, strlen (s
), port
);
935 * This function differs from scm_c_write; it updates port line and
939 scm_lfwrite (const char *ptr
, size_t size
, SCM port
)
941 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
942 scm_t_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
944 if (pt
->rw_active
== SCM_PORT_READ
)
945 scm_end_input (port
);
947 ptob
->write (port
, ptr
, size
);
949 for (; size
; ptr
++, size
--) {
953 else if (*ptr
== '\t') {
962 pt
->rw_active
= SCM_PORT_WRITE
;
967 * Used by an application to read arbitrary number of bytes from an
968 * SCM port. Same semantics as libc read, except that scm_c_read only
969 * returns less than SIZE bytes if at end-of-file.
971 * Warning: Doesn't update port line and column counts! */
974 scm_c_read (SCM port
, void *buffer
, size_t size
)
976 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
977 size_t n_read
= 0, n_available
;
979 if (pt
->rw_active
== SCM_PORT_WRITE
)
980 scm_ptobs
[SCM_PTOBNUM (port
)].flush (port
);
983 pt
->rw_active
= SCM_PORT_READ
;
985 if (SCM_READ_BUFFER_EMPTY_P (pt
))
987 if (scm_fill_input (port
) == EOF
)
991 n_available
= pt
->read_end
- pt
->read_pos
;
993 while (n_available
< size
)
995 memcpy (buffer
, pt
->read_pos
, n_available
);
996 buffer
= (char *) buffer
+ n_available
;
997 pt
->read_pos
+= n_available
;
998 n_read
+= n_available
;
1000 if (SCM_READ_BUFFER_EMPTY_P (pt
))
1002 if (scm_fill_input (port
) == EOF
)
1006 size
-= n_available
;
1007 n_available
= pt
->read_end
- pt
->read_pos
;
1010 memcpy (buffer
, pt
->read_pos
, size
);
1011 pt
->read_pos
+= size
;
1013 return n_read
+ size
;
1018 * Used by an application to write arbitrary number of bytes to an SCM
1019 * port. Similar semantics as libc write. However, unlike libc
1020 * write, scm_c_write writes the requested number of bytes and has no
1023 * Warning: Doesn't update port line and column counts!
1027 scm_c_write (SCM port
, const void *ptr
, size_t size
)
1029 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1030 scm_t_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
1032 if (pt
->rw_active
== SCM_PORT_READ
)
1033 scm_end_input (port
);
1035 ptob
->write (port
, ptr
, size
);
1038 pt
->rw_active
= SCM_PORT_WRITE
;
1042 scm_flush (SCM port
)
1044 long i
= SCM_PTOBNUM (port
);
1045 (scm_ptobs
[i
].flush
) (port
);
1049 scm_end_input (SCM port
)
1052 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1054 if (pt
->read_buf
== pt
->putback_buf
)
1056 offset
= pt
->read_end
- pt
->read_pos
;
1057 pt
->read_buf
= pt
->saved_read_buf
;
1058 pt
->read_pos
= pt
->saved_read_pos
;
1059 pt
->read_end
= pt
->saved_read_end
;
1060 pt
->read_buf_size
= pt
->saved_read_buf_size
;
1065 scm_ptobs
[SCM_PTOBNUM (port
)].end_input (port
, offset
);
1072 scm_ungetc (int c
, SCM port
)
1073 #define FUNC_NAME "scm_ungetc"
1075 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
1077 if (pt
->read_buf
== pt
->putback_buf
)
1078 /* already using the put-back buffer. */
1080 /* enlarge putback_buf if necessary. */
1081 if (pt
->read_end
== pt
->read_buf
+ pt
->read_buf_size
1082 && pt
->read_buf
== pt
->read_pos
)
1084 size_t new_size
= pt
->read_buf_size
* 2;
1085 unsigned char *tmp
= (unsigned char *)
1086 scm_must_realloc (pt
->putback_buf
, pt
->read_buf_size
, new_size
,
1089 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
= tmp
;
1090 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
1091 pt
->read_buf_size
= pt
->putback_buf_size
= new_size
;
1094 /* shift any existing bytes to buffer + 1. */
1095 if (pt
->read_pos
== pt
->read_end
)
1096 pt
->read_end
= pt
->read_buf
+ 1;
1097 else if (pt
->read_pos
!= pt
->read_buf
+ 1)
1099 int count
= pt
->read_end
- pt
->read_pos
;
1101 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
1102 pt
->read_end
= pt
->read_buf
+ 1 + count
;
1105 pt
->read_pos
= pt
->read_buf
;
1108 /* switch to the put-back buffer. */
1110 if (pt
->putback_buf
== NULL
)
1113 = (unsigned char *) scm_must_malloc (SCM_INITIAL_PUTBACK_BUF_SIZE
,
1115 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
1118 pt
->saved_read_buf
= pt
->read_buf
;
1119 pt
->saved_read_pos
= pt
->read_pos
;
1120 pt
->saved_read_end
= pt
->read_end
;
1121 pt
->saved_read_buf_size
= pt
->read_buf_size
;
1123 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
1124 pt
->read_end
= pt
->read_buf
+ 1;
1125 pt
->read_buf_size
= pt
->putback_buf_size
;
1131 pt
->rw_active
= SCM_PORT_READ
;
1135 /* What should col be in this case?
1136 * We'll leave it at -1.
1138 SCM_LINUM (port
) -= 1;
1147 scm_ungets (const char *s
, int n
, SCM port
)
1149 /* This is simple minded and inefficient, but unreading strings is
1150 * probably not a common operation, and remember that line and
1151 * column numbers have to be handled...
1153 * Please feel free to write an optimized version!
1156 scm_ungetc (s
[n
], port
);
1160 SCM_DEFINE (scm_peek_char
, "peek-char", 0, 1, 0,
1162 "Return the next character available from @var{port},\n"
1163 "@emph{without} updating @var{port} to point to the following\n"
1164 "character. If no more characters are available, the\n"
1165 "end-of-file object is returned.@footnote{The value returned by\n"
1166 "a call to @code{peek-char} is the same as the value that would\n"
1167 "have been returned by a call to @code{read-char} on the same\n"
1168 "port. The only difference is that the very next call to\n"
1169 "@code{read-char} or @code{peek-char} on that @var{port} will\n"
1170 "return the value returned by the preceding call to\n"
1171 "@code{peek-char}. In particular, a call to @code{peek-char} on\n"
1172 "an interactive port will hang waiting for input whenever a call\n"
1173 "to @code{read-char} would have hung.}")
1174 #define FUNC_NAME s_scm_peek_char
1177 if (SCM_UNBNDP (port
))
1180 SCM_VALIDATE_OPINPORT (1,port
);
1181 c
= scm_getc (port
);
1184 scm_ungetc (c
, port
);
1185 return SCM_MAKE_CHAR (c
);
1189 SCM_DEFINE (scm_unread_char
, "unread-char", 1, 1, 0,
1190 (SCM cobj
, SCM port
),
1191 "Place @var{char} in @var{port} so that it will be read by the\n"
1192 "next read operation. If called multiple times, the unread characters\n"
1193 "will be read again in last-in first-out order. If @var{port} is\n"
1194 "not supplied, the current input port is used.")
1195 #define FUNC_NAME s_scm_unread_char
1199 SCM_VALIDATE_CHAR (1,cobj
);
1200 if (SCM_UNBNDP (port
))
1203 SCM_VALIDATE_OPINPORT (2,port
);
1205 c
= SCM_CHAR (cobj
);
1207 scm_ungetc (c
, port
);
1212 SCM_DEFINE (scm_unread_string
, "unread-string", 2, 0, 0,
1213 (SCM str
, SCM port
),
1214 "Place the string @var{str} in @var{port} so that its characters will be\n"
1215 "read in subsequent read operations. If called multiple times, the\n"
1216 "unread characters will be read again in last-in first-out order. If\n"
1217 "@var{port} is not supplied, the current-input-port is used.")
1218 #define FUNC_NAME s_scm_unread_string
1220 SCM_VALIDATE_STRING (1,str
);
1221 if (SCM_UNBNDP (port
))
1224 SCM_VALIDATE_OPINPORT (2,port
);
1226 scm_ungets (SCM_STRING_CHARS (str
), SCM_STRING_LENGTH (str
), port
);
1232 SCM_DEFINE (scm_seek
, "seek", 3, 0, 0,
1233 (SCM fd_port
, SCM offset
, SCM whence
),
1234 "Sets the current position of @var{fd/port} to the integer\n"
1235 "@var{offset}, which is interpreted according to the value of\n"
1238 "One of the following variables should be supplied for\n"
1240 "@defvar SEEK_SET\n"
1241 "Seek from the beginning of the file.\n"
1243 "@defvar SEEK_CUR\n"
1244 "Seek from the current position.\n"
1246 "@defvar SEEK_END\n"
1247 "Seek from the end of the file.\n"
1249 "If @var{fd/port} is a file descriptor, the underlying system\n"
1250 "call is @code{lseek}. @var{port} may be a string port.\n"
1252 "The value returned is the new position in the file. This means\n"
1253 "that the current position of a port can be obtained using:\n"
1255 "(seek port 0 SEEK_CUR)\n"
1257 #define FUNC_NAME s_scm_seek
1263 fd_port
= SCM_COERCE_OUTPORT (fd_port
);
1265 off
= SCM_NUM2LONG (2, offset
);
1266 SCM_VALIDATE_INUM_COPY (3, whence
, how
);
1267 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
1268 SCM_OUT_OF_RANGE (3, whence
);
1269 if (SCM_OPPORTP (fd_port
))
1271 scm_t_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (fd_port
);
1274 SCM_MISC_ERROR ("port is not seekable",
1275 scm_cons (fd_port
, SCM_EOL
));
1277 rv
= ptob
->seek (fd_port
, off
, how
);
1279 else /* file descriptor?. */
1281 SCM_VALIDATE_INUM (1,fd_port
);
1282 rv
= lseek (SCM_INUM (fd_port
), off
, how
);
1286 return scm_long2num (rv
);
1291 /* Define this function since it is not supported under Windows. */
1292 static int truncate (char *file
, int length
)
1295 if ((fdes
= open (file
, O_BINARY
| O_WRONLY
)) != -1)
1297 ret
= chsize (fdes
, length
);
1302 #endif /* __MINGW32__ */
1304 SCM_DEFINE (scm_truncate_file
, "truncate-file", 1, 1, 0,
1305 (SCM object
, SCM length
),
1306 "Truncates the object referred to by @var{object} to at most\n"
1307 "@var{length} bytes. @var{object} can be a string containing a\n"
1308 "file name or an integer file descriptor or a port.\n"
1309 "@var{length} may be omitted if @var{object} is not a file name,\n"
1310 "in which case the truncation occurs at the current port.\n"
1311 "position. The return value is unspecified.")
1312 #define FUNC_NAME s_scm_truncate_file
1317 /* object can be a port, fdes or filename. */
1319 if (SCM_UNBNDP (length
))
1321 /* must supply length if object is a filename. */
1322 if (SCM_STRINGP (object
))
1323 SCM_MISC_ERROR("must supply length if OBJECT is a filename",SCM_EOL
);
1325 length
= scm_seek (object
, SCM_INUM0
, SCM_MAKINUM (SEEK_CUR
));
1327 c_length
= SCM_NUM2LONG (2,length
);
1329 SCM_MISC_ERROR ("negative offset", SCM_EOL
);
1331 object
= SCM_COERCE_OUTPORT (object
);
1332 if (SCM_INUMP (object
))
1334 SCM_SYSCALL (rv
= ftruncate (SCM_INUM (object
), c_length
));
1336 else if (SCM_OPOUTPORTP (object
))
1338 scm_t_port
*pt
= SCM_PTAB_ENTRY (object
);
1339 scm_t_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1341 if (!ptob
->truncate
)
1342 SCM_MISC_ERROR ("port is not truncatable", SCM_EOL
);
1343 if (pt
->rw_active
== SCM_PORT_READ
)
1344 scm_end_input (object
);
1345 else if (pt
->rw_active
== SCM_PORT_WRITE
)
1346 ptob
->flush (object
);
1348 ptob
->truncate (object
, c_length
);
1353 SCM_VALIDATE_STRING (1, object
);
1354 SCM_SYSCALL (rv
= truncate (SCM_STRING_CHARS (object
), c_length
));
1358 return SCM_UNSPECIFIED
;
1362 SCM_DEFINE (scm_port_line
, "port-line", 1, 0, 0,
1364 "Return the current line number for @var{port}.")
1365 #define FUNC_NAME s_scm_port_line
1367 port
= SCM_COERCE_OUTPORT (port
);
1368 SCM_VALIDATE_OPENPORT (1,port
);
1369 return SCM_MAKINUM (SCM_LINUM (port
));
1373 SCM_DEFINE (scm_set_port_line_x
, "set-port-line!", 2, 0, 0,
1374 (SCM port
, SCM line
),
1375 "Set the current line number for @var{port} to @var{line}.")
1376 #define FUNC_NAME s_scm_set_port_line_x
1378 port
= SCM_COERCE_OUTPORT (port
);
1379 SCM_VALIDATE_OPENPORT (1,port
);
1380 SCM_VALIDATE_INUM (2,line
);
1381 SCM_PTAB_ENTRY (port
)->line_number
= SCM_INUM (line
);
1382 return SCM_UNSPECIFIED
;
1386 SCM_DEFINE (scm_port_column
, "port-column", 1, 0, 0,
1388 "@deffnx primitive port-line port\n"
1389 "Return the current column number or line number of @var{port},\n"
1390 "using the current input port if none is specified. If the number is\n"
1391 "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
1392 "- i.e. the first character of the first line is line 0, column 0.\n"
1393 "(However, when you display a file position, for example in an error\n"
1394 "message, we recommend you add 1 to get 1-origin integers. This is\n"
1395 "because lines and column numbers traditionally start with 1, and that is\n"
1396 "what non-programmers will find most natural.)")
1397 #define FUNC_NAME s_scm_port_column
1399 port
= SCM_COERCE_OUTPORT (port
);
1400 SCM_VALIDATE_OPENPORT (1,port
);
1401 return SCM_MAKINUM (SCM_COL (port
));
1405 SCM_DEFINE (scm_set_port_column_x
, "set-port-column!", 2, 0, 0,
1406 (SCM port
, SCM column
),
1407 "@deffnx primitive set-port-line! port line\n"
1408 "Set the current column or line number of @var{port}, using the\n"
1409 "current input port if none is specified.")
1410 #define FUNC_NAME s_scm_set_port_column_x
1412 port
= SCM_COERCE_OUTPORT (port
);
1413 SCM_VALIDATE_OPENPORT (1,port
);
1414 SCM_VALIDATE_INUM (2,column
);
1415 SCM_PTAB_ENTRY (port
)->column_number
= SCM_INUM (column
);
1416 return SCM_UNSPECIFIED
;
1420 SCM_DEFINE (scm_port_filename
, "port-filename", 1, 0, 0,
1422 "Return the filename associated with @var{port}. This function returns\n"
1423 "the strings \"standard input\", \"standard output\" and \"standard error\"\n"
1424 "when called on the current input, output and error ports respectively.")
1425 #define FUNC_NAME s_scm_port_filename
1427 port
= SCM_COERCE_OUTPORT (port
);
1428 SCM_VALIDATE_OPENPORT (1,port
);
1429 return SCM_FILENAME (port
);
1433 SCM_DEFINE (scm_set_port_filename_x
, "set-port-filename!", 2, 0, 0,
1434 (SCM port
, SCM filename
),
1435 "Change the filename associated with @var{port}, using the current input\n"
1436 "port if none is specified. Note that this does not change the port's\n"
1437 "source of data, but only the value that is returned by\n"
1438 "@code{port-filename} and reported in diagnostic output.")
1439 #define FUNC_NAME s_scm_set_port_filename_x
1441 port
= SCM_COERCE_OUTPORT (port
);
1442 SCM_VALIDATE_OPENPORT (1,port
);
1443 /* We allow the user to set the filename to whatever he likes. */
1444 SCM_SET_FILENAME (port
, filename
);
1445 return SCM_UNSPECIFIED
;
1450 extern char * ttyname();
1454 scm_print_port_mode (SCM exp
, SCM port
)
1456 scm_puts (SCM_CLOSEDP (exp
)
1458 : (SCM_RDNG
& SCM_CELL_WORD_0 (exp
)
1459 ? (SCM_WRTNG
& SCM_CELL_WORD_0 (exp
)
1462 : (SCM_WRTNG
& SCM_CELL_WORD_0 (exp
)
1469 scm_port_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1471 char *type
= SCM_PTOBNAME (SCM_PTOBNUM (exp
));
1474 scm_puts ("#<", port
);
1475 scm_print_port_mode (exp
, port
);
1476 scm_puts (type
, port
);
1477 scm_putc (' ', port
);
1478 scm_intprint (SCM_CELL_WORD_1 (exp
), 16, port
);
1479 scm_putc ('>', port
);
1484 scm_ports_prehistory ()
1487 scm_ptobs
= (scm_t_ptob_descriptor
*) malloc (sizeof (scm_t_ptob_descriptor
));
1494 scm_t_bits scm_tc16_void_port
= 0;
1496 static int fill_input_void_port (SCM port SCM_UNUSED
)
1502 write_void_port (SCM port SCM_UNUSED
,
1503 const void *data SCM_UNUSED
,
1504 size_t size SCM_UNUSED
)
1509 scm_void_port (char *mode_str
)
1515 SCM_NEWCELL (answer
);
1517 mode_bits
= scm_mode_bits (mode_str
);
1518 pt
= scm_add_to_port_table (answer
);
1519 scm_port_non_buffer (pt
);
1520 SCM_SETPTAB_ENTRY (answer
, pt
);
1521 SCM_SETSTREAM (answer
, 0);
1522 SCM_SET_CELL_TYPE (answer
, scm_tc16_void_port
| mode_bits
);
1527 SCM_DEFINE (scm_sys_make_void_port
, "%make-void-port", 1, 0, 0,
1529 "Create and return a new void port. A void port acts like\n"
1530 "/dev/null. The @var{mode} argument\n"
1531 "specifies the input/output modes for this port: see the\n"
1532 "documentation for @code{open-file} in @ref{File Ports}.")
1533 #define FUNC_NAME s_scm_sys_make_void_port
1535 SCM_VALIDATE_STRING (1, mode
);
1536 return scm_void_port (SCM_STRING_CHARS (mode
));
1541 /* Initialization. */
1546 /* lseek() symbols. */
1547 scm_c_define ("SEEK_SET", SCM_MAKINUM (SEEK_SET
));
1548 scm_c_define ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR
));
1549 scm_c_define ("SEEK_END", SCM_MAKINUM (SEEK_END
));
1551 scm_tc16_void_port
= scm_make_port_type ("void", fill_input_void_port
,
1553 #ifndef SCM_MAGIC_SNARFER
1554 #include "libguile/ports.x"