1 /* Copyright (C) 1995,1996,1997,1998,1999 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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
56 #include "scm_validate.h"
67 #ifdef HAVE_SYS_IOCTL_H
68 #include <sys/ioctl.h>
72 /* The port kind table --- a dynamically resized array of port types. */
75 /* scm_ptobs scm_numptob
76 * implement a dynamicly resized array of ptob records.
77 * Indexes into this table are used when generating type
78 * tags for smobjects (if you know a tag you can get an index and conversely).
80 scm_ptob_descriptor
*scm_ptobs
;
83 /* GC marker for a port with stream of SCM type. */
85 scm_markstream (SCM ptr
)
88 openp
= SCM_CAR (ptr
) & SCM_OPN
;
90 return SCM_STREAM (ptr
);
96 * We choose to use an interface similar to the smob interface with
97 * fill_input and write as standard fields, passed to the port
98 * type constructor, and optional fields set by setters.
101 static void flush_void_port (SCM port
);
102 static void end_input_void_port (SCM port
, int offset
);
103 static void write_void_port (SCM port
, const void *data
, size_t size
);
106 scm_make_port_type (char *name
,
107 int (*fill_input
) (SCM port
),
108 void (*write
) (SCM port
, const void *data
, size_t size
))
111 if (255 <= scm_numptob
)
114 SCM_SYSCALL (tmp
= (char *) realloc ((char *) scm_ptobs
,
116 * sizeof (scm_ptob_descriptor
)));
119 scm_ptobs
= (scm_ptob_descriptor
*) tmp
;
121 scm_ptobs
[scm_numptob
].name
= name
;
122 scm_ptobs
[scm_numptob
].mark
= 0;
123 scm_ptobs
[scm_numptob
].free
= scm_free0
;
124 scm_ptobs
[scm_numptob
].print
= scm_port_print
;
125 scm_ptobs
[scm_numptob
].equalp
= 0;
126 scm_ptobs
[scm_numptob
].close
= 0;
128 scm_ptobs
[scm_numptob
].write
= write
;
129 scm_ptobs
[scm_numptob
].flush
= flush_void_port
;
131 scm_ptobs
[scm_numptob
].end_input
= end_input_void_port
;
132 scm_ptobs
[scm_numptob
].fill_input
= fill_input
;
133 scm_ptobs
[scm_numptob
].input_waiting
= 0;
135 scm_ptobs
[scm_numptob
].seek
= 0;
136 scm_ptobs
[scm_numptob
].truncate
= 0;
142 ptoberr
:scm_wta (SCM_MAKINUM ((long) scm_numptob
),
143 (char *) SCM_NALLOC
, "scm_make_port_type");
144 /* Make a class object if Goops is present */
146 scm_make_port_classes (scm_numptob
- 1, SCM_PTOBNAME (scm_numptob
- 1));
147 return scm_tc7_port
+ (scm_numptob
- 1) * 256;
151 scm_set_port_mark (long tc
, SCM (*mark
) (SCM
))
153 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].mark
= mark
;
157 scm_set_port_free (long tc
, scm_sizet (*free
) (SCM
))
159 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].free
= free
;
163 scm_set_port_print (long tc
, int (*print
) (SCM exp
, SCM port
,
164 scm_print_state
*pstate
))
166 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].print
= print
;
170 scm_set_port_equalp (long tc
, SCM (*equalp
) (SCM
, SCM
))
172 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].equalp
= equalp
;
176 scm_set_port_flush (long tc
, void (*flush
) (SCM port
))
178 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].flush
= flush
;
182 scm_set_port_end_input (long tc
, void (*end_input
) (SCM port
, int offset
))
184 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].end_input
= end_input
;
188 scm_set_port_close (long tc
, int (*close
) (SCM
))
190 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].close
= close
;
194 scm_set_port_seek (long tc
, off_t (*seek
) (SCM port
,
198 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].seek
= seek
;
202 scm_set_port_truncate (long tc
, void (*truncate
) (SCM port
, off_t length
))
204 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].truncate
= truncate
;
208 scm_set_port_input_waiting (long tc
, int (*input_waiting
) (SCM
))
210 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].input_waiting
= input_waiting
;
215 SCM_DEFINE (scm_char_ready_p
, "char-ready?", 0, 1, 0,
218 #define FUNC_NAME s_scm_char_ready_p
222 if (SCM_UNBNDP (port
))
225 SCM_VALIDATE_OPINPORT (1,port
);
227 pt
= SCM_PTAB_ENTRY (port
);
229 /* if the current read buffer is filled, or the
230 last pushed-back char has been read and the saved buffer is
231 filled, result is true. */
232 if (pt
->read_pos
< pt
->read_end
233 || (pt
->read_buf
== pt
->putback_buf
234 && pt
->saved_read_pos
< pt
->saved_read_end
))
238 scm_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
240 if (ptob
->input_waiting
)
241 return SCM_BOOL(ptob
->input_waiting (port
));
248 /* Clear a port's read buffers, returning the contents. */
249 SCM_DEFINE (scm_drain_input
, "drain-input", 1, 0, 0,
251 "Drains @var{PORT}'s read buffers (including any pushed-back characters)\n"
252 "and returns the contents as a single string.")
253 #define FUNC_NAME s_scm_drain_input
256 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
260 SCM_VALIDATE_OPINPORT (1,port
);
262 count
= pt
->read_end
- pt
->read_pos
;
263 if (pt
->read_buf
== pt
->putback_buf
)
264 count
+= pt
->saved_read_end
- pt
->saved_read_pos
;
266 result
= scm_makstr (count
, 0);
267 dst
= SCM_CHARS (result
);
269 while (pt
->read_pos
< pt
->read_end
)
270 *dst
++ = *(pt
->read_pos
++);
272 if (pt
->read_buf
== pt
->putback_buf
)
274 while (pt
->saved_read_pos
< pt
->saved_read_end
)
275 *dst
++ = *(pt
->saved_read_pos
++);
283 /* Standard ports --- current input, output, error, and more(!). */
285 SCM_DEFINE (scm_current_input_port
, "current-input-port", 0, 0, 0,
288 #define FUNC_NAME s_scm_current_input_port
294 SCM_DEFINE (scm_current_output_port
, "current-output-port", 0, 0, 0,
297 #define FUNC_NAME s_scm_current_output_port
303 SCM_DEFINE (scm_current_error_port
, "current-error-port", 0, 0, 0,
305 "Return the port to which errors and warnings should be sent (the\n"
306 "@dfn{standard error} in Unix and C terminology).")
307 #define FUNC_NAME s_scm_current_error_port
313 SCM_DEFINE (scm_current_load_port
, "current-load-port", 0, 0, 0,
316 #define FUNC_NAME s_scm_current_load_port
318 return scm_cur_loadp
;
322 SCM_DEFINE (scm_set_current_input_port
, "set-current-input-port", 1, 0, 0,
324 "@deffnx primitive set-current-output-port port\n"
325 "@deffnx primitive set-current-error-port port\n"
326 "Change the ports returned by @code{current-input-port},\n"
327 "@code{current-output-port} and @code{current-error-port}, respectively,\n"
328 "so that they use the supplied @var{port} for input or output.")
329 #define FUNC_NAME s_scm_set_current_input_port
331 SCM oinp
= scm_cur_inp
;
332 SCM_VALIDATE_OPINPORT (1,port
);
339 SCM_DEFINE (scm_set_current_output_port
, "set-current-output-port", 1, 0, 0,
342 #define FUNC_NAME s_scm_set_current_output_port
344 SCM ooutp
= scm_cur_outp
;
345 port
= SCM_COERCE_OUTPORT (port
);
346 SCM_VALIDATE_OPOUTPORT (1,port
);
353 SCM_DEFINE (scm_set_current_error_port
, "set-current-error-port", 1, 0, 0,
356 #define FUNC_NAME s_scm_set_current_error_port
358 SCM oerrp
= scm_cur_errp
;
359 port
= SCM_COERCE_OUTPORT (port
);
360 SCM_VALIDATE_OPOUTPORT (1,port
);
367 /* The port table --- an array of pointers to ports. */
369 scm_port
**scm_port_table
;
371 int scm_port_table_size
= 0; /* Number of ports in scm_port_table. */
372 int scm_port_table_room
= 20; /* Size of the array. */
374 /* Add a port to the table. */
377 scm_add_to_port_table (SCM port
)
381 if (scm_port_table_size
== scm_port_table_room
)
383 void *newt
= realloc ((char *) scm_port_table
,
384 (scm_sizet
) (sizeof (scm_port
*)
385 * scm_port_table_room
* 2));
387 scm_memory_error ("scm_add_to_port_table");
388 scm_port_table
= (scm_port
**) newt
;
389 scm_port_table_room
*= 2;
391 entry
= (scm_port
*) malloc (sizeof (scm_port
));
393 scm_memory_error ("scm_add_to_port_table");
396 entry
->entry
= scm_port_table_size
;
399 entry
->file_name
= SCM_BOOL_F
;
400 entry
->line_number
= 0;
401 entry
->column_number
= 0;
402 entry
->putback_buf
= 0;
403 entry
->putback_buf_size
= 0;
404 entry
->rw_active
= SCM_PORT_NEITHER
;
405 entry
->rw_random
= 0;
407 scm_port_table
[scm_port_table_size
] = entry
;
408 scm_port_table_size
++;
413 /* Remove a port from the table and destroy it. */
416 scm_remove_from_port_table (SCM port
)
418 scm_port
*p
= SCM_PTAB_ENTRY (port
);
421 if (i
>= scm_port_table_size
)
422 scm_wta (port
, "Port not in table", "scm_remove_from_port_table");
424 free (p
->putback_buf
);
426 /* Since we have just freed slot i we can shrink the table by moving
427 the last entry to that slot... */
428 if (i
< scm_port_table_size
- 1)
430 scm_port_table
[i
] = scm_port_table
[scm_port_table_size
- 1];
431 scm_port_table
[i
]->entry
= i
;
433 SCM_SETPTAB_ENTRY (port
, 0);
434 scm_port_table_size
--;
438 /* Undocumented functions for debugging. */
439 /* Return the number of ports in the table. */
441 SCM_DEFINE (scm_pt_size
, "pt-size", 0, 0, 0,
444 #define FUNC_NAME s_scm_pt_size
446 return SCM_MAKINUM (scm_port_table_size
);
450 /* Return the ith member of the port table. */
451 SCM_DEFINE (scm_pt_member
, "pt-member", 1, 0, 0,
454 #define FUNC_NAME s_scm_pt_member
457 SCM_VALIDATE_INUM_COPY (1,member
,i
);
458 if (i
< 0 || i
>= scm_port_table_size
)
461 return scm_port_table
[i
]->port
;
468 /* Revealed counts --- an oddity inherited from SCSH. */
470 /* Find a port in the table and return its revealed count.
471 Also used by the garbage collector.
475 scm_revealed_count (SCM port
)
477 return SCM_REVEALED(port
);
482 /* Return the revealed count for a port. */
484 SCM_DEFINE (scm_port_revealed
, "port-revealed", 1, 0, 0,
486 "Returns the revealed count for @var{port}.")
487 #define FUNC_NAME s_scm_port_revealed
489 port
= SCM_COERCE_OUTPORT (port
);
490 SCM_VALIDATE_PORT (1,port
);
491 return SCM_MAKINUM (scm_revealed_count (port
));
495 /* Set the revealed count for a port. */
496 SCM_DEFINE (scm_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0,
497 (SCM port
, SCM rcount
),
498 "Sets the revealed count for a port to a given value. \n"
499 "The return value is unspecified.")
500 #define FUNC_NAME s_scm_set_port_revealed_x
502 port
= SCM_COERCE_OUTPORT (port
);
503 SCM_VALIDATE_PORT (1,port
);
504 SCM_VALIDATE_INUM (2,rcount
);
505 SCM_REVEALED (port
) = SCM_INUM (rcount
);
506 return SCM_UNSPECIFIED
;
512 /* Retrieving a port's mode. */
514 /* Return the flags that characterize a port based on the mode
515 * string used to open a file for that port.
517 * See PORT FLAGS in scm.h
521 scm_mode_bits (char *modes
)
524 | (strchr (modes
, 'r') || strchr (modes
, '+') ? SCM_RDNG
: 0)
525 | ( strchr (modes
, 'w')
526 || strchr (modes
, 'a')
527 || strchr (modes
, '+') ? SCM_WRTNG
: 0)
528 | (strchr (modes
, '0') ? SCM_BUF0
: 0)
529 | (strchr (modes
, 'l') ? SCM_BUFLINE
: 0));
533 /* Return the mode flags from an open port.
534 * Some modes such as "append" are only used when opening
535 * a file and are not returned here. */
537 SCM_DEFINE (scm_port_mode
, "port-mode", 1, 0, 0,
539 "Returns the port modes associated with the open port @var{port}. These\n"
540 "will not necessarily be identical to the modes used when the port was\n"
541 "opened, since modes such as \"append\" which are used only during\n"
542 "port creation are not retained.")
543 #define FUNC_NAME s_scm_port_mode
548 port
= SCM_COERCE_OUTPORT (port
);
549 SCM_VALIDATE_OPPORT (1,port
);
550 if (SCM_CAR (port
) & SCM_RDNG
) {
551 if (SCM_CAR (port
) & SCM_WRTNG
)
552 strcpy (modes
, "r+");
556 else if (SCM_CAR (port
) & SCM_WRTNG
)
558 if (SCM_CAR (port
) & SCM_BUF0
)
560 return scm_makfromstr (modes
, strlen (modes
), 0);
569 * Call the close operation on a port object.
570 * see also scm_close.
572 SCM_DEFINE (scm_close_port
, "close-port", 1, 0, 0,
574 "Close the specified port object. Returns @code{#t} if it successfully\n"
575 "closes a port or @code{#f} if it was already\n"
576 "closed. An exception may be raised if an error occurs, for example\n"
577 "when flushing buffered output.\n"
578 "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
579 "which can close file descriptors.")
580 #define FUNC_NAME s_scm_close_port
585 port
= SCM_COERCE_OUTPORT (port
);
587 SCM_VALIDATE_PORT (1,port
);
588 if (SCM_CLOSEDP (port
))
590 i
= SCM_PTOBNUM (port
);
591 if (scm_ptobs
[i
].close
)
592 rv
= (scm_ptobs
[i
].close
) (port
);
595 scm_remove_from_port_table (port
);
596 SCM_SETAND_CAR (port
, ~SCM_OPN
);
597 return SCM_NEGATE_BOOL(rv
< 0);
601 SCM_DEFINE (scm_close_all_ports_except
, "close-all-ports-except", 0, 0, 1,
603 "Close all open file ports used by the interpreter\n"
604 "except for those supplied as arguments. This procedure\n"
605 "is intended to be used before an exec call to close file descriptors\n"
606 "which are not needed in the new process.Close all open file ports used by the interpreter\n"
607 "except for those supplied as arguments. This procedure\n"
608 "is intended to be used before an exec call to close file descriptors\n"
609 "which are not needed in the new process.")
610 #define FUNC_NAME s_scm_close_all_ports_except
613 SCM_VALIDATE_CONS (1,ports
);
614 while (i
< scm_port_table_size
)
616 SCM thisport
= scm_port_table
[i
]->port
;
618 SCM ports_ptr
= ports
;
620 while (SCM_NNULLP (ports_ptr
))
622 SCM port
= SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr
));
624 SCM_VALIDATE_OPPORT (SCM_ARG1
,port
);
625 if (port
== thisport
)
627 ports_ptr
= SCM_CDR (ports_ptr
);
632 /* i is not to be incremented here. */
633 scm_close_port (thisport
);
635 return SCM_UNSPECIFIED
;
641 /* Utter miscellany. Gosh, we should clean this up some time. */
643 SCM_DEFINE (scm_input_port_p
, "input-port?", 1, 0, 0,
646 #define FUNC_NAME s_scm_input_port_p
650 return SCM_BOOL(SCM_INPORTP (x
));
654 SCM_DEFINE (scm_output_port_p
, "output-port?", 1, 0, 0,
657 #define FUNC_NAME s_scm_output_port_p
661 if (SCM_PORT_WITH_PS_P (x
))
662 x
= SCM_PORT_WITH_PS_PORT (x
);
663 return SCM_BOOL(SCM_OUTPORTP (x
));
667 SCM_DEFINE (scm_port_closed_p
, "port-closed?", 1, 0, 0,
669 "Returns @code{#t} if @var{port} is closed or @code{#f} if it is open.")
670 #define FUNC_NAME s_scm_port_closed_p
672 SCM_VALIDATE_PORT (1,port
);
673 return SCM_NEGATE_BOOL(SCM_OPPORTP (port
));
677 SCM_DEFINE (scm_eof_object_p
, "eof-object?", 1, 0, 0,
680 #define FUNC_NAME s_scm_eof_object_p
682 return SCM_BOOL(SCM_EOF_OBJECT_P (x
));
686 SCM_DEFINE (scm_force_output
, "force-output", 0, 1, 0,
688 "Flush the specified output port, or the current output port if @var{port}\n"
689 "is omitted. The current output buffer contents are passed to the \n"
690 "underlying port implementation (e.g., in the case of fports, the\n"
691 "data will be written to the file and the output buffer will be cleared.)\n"
692 "It has no effect on an unbuffered port.\n\n"
693 "The return value is unspecified.")
694 #define FUNC_NAME s_scm_force_output
696 if (SCM_UNBNDP (port
))
700 port
= SCM_COERCE_OUTPORT (port
);
701 SCM_VALIDATE_OPOUTPORT (1,port
);
704 return SCM_UNSPECIFIED
;
708 SCM_DEFINE (scm_flush_all_ports
, "flush-all-ports", 0, 0, 0,
710 "Equivalent to calling @code{force-output} on\n"
711 "all open output ports. The return value is unspecified.")
712 #define FUNC_NAME s_scm_flush_all_ports
716 for (i
= 0; i
< scm_port_table_size
; i
++)
718 if (SCM_OPOUTPORTP (scm_port_table
[i
]->port
))
719 scm_flush (scm_port_table
[i
]->port
);
721 return SCM_UNSPECIFIED
;
725 SCM_DEFINE (scm_read_char
, "read-char", 0, 1, 0,
728 #define FUNC_NAME s_scm_read_char
731 if (SCM_UNBNDP (port
))
733 SCM_VALIDATE_OPINPORT (1,port
);
737 return SCM_MAKICHR (c
);
741 /* this should only be called when the read buffer is empty. it
742 tries to refill the read buffer. it returns the first char from
743 the port, which is either EOF or *(pt->read_pos). */
745 scm_fill_input (SCM port
)
747 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
749 if (pt
->read_buf
== pt
->putback_buf
)
751 /* finished reading put-back chars. */
752 pt
->read_buf
= pt
->saved_read_buf
;
753 pt
->read_pos
= pt
->saved_read_pos
;
754 pt
->read_end
= pt
->saved_read_end
;
755 pt
->read_buf_size
= pt
->saved_read_buf_size
;
756 if (pt
->read_pos
< pt
->read_end
)
757 return *(pt
->read_pos
);
759 return scm_ptobs
[SCM_PTOBNUM (port
)].fill_input (port
);
766 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
768 if (pt
->rw_active
== SCM_PORT_WRITE
)
770 /* may be marginally faster than calling scm_flush. */
771 scm_ptobs
[SCM_PTOBNUM (port
)].flush (port
);
775 pt
->rw_active
= SCM_PORT_READ
;
777 if (pt
->read_pos
>= pt
->read_end
)
779 if (scm_fill_input (port
) == EOF
)
783 c
= *(pt
->read_pos
++);
802 scm_putc (char c
, SCM port
)
804 scm_lfwrite (&c
, 1, port
);
808 scm_puts (const char *s
, SCM port
)
810 scm_lfwrite (s
, strlen (s
), port
);
814 scm_lfwrite (const char *ptr
, scm_sizet size
, SCM port
)
816 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
817 scm_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
819 if (pt
->rw_active
== SCM_PORT_READ
)
820 scm_end_input (port
);
822 ptob
->write (port
, ptr
, size
);
825 pt
->rw_active
= SCM_PORT_WRITE
;
832 scm_sizet i
= SCM_PTOBNUM (port
);
833 (scm_ptobs
[i
].flush
) (port
);
837 scm_end_input (SCM port
)
840 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
842 if (pt
->read_buf
== pt
->putback_buf
)
844 offset
= pt
->read_end
- pt
->read_pos
;
845 pt
->read_buf
= pt
->saved_read_buf
;
846 pt
->read_pos
= pt
->saved_read_pos
;
847 pt
->read_end
= pt
->saved_read_end
;
848 pt
->read_buf_size
= pt
->saved_read_buf_size
;
853 scm_ptobs
[SCM_PTOBNUM (port
)].end_input (port
, offset
);
860 scm_ungetc (int c
, SCM port
)
862 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
864 if (pt
->read_buf
== pt
->putback_buf
)
865 /* already using the put-back buffer. */
867 /* enlarge putback_buf if necessary. */
868 if (pt
->read_end
== pt
->read_buf
+ pt
->read_buf_size
869 && pt
->read_buf
== pt
->read_pos
)
871 int new_size
= pt
->read_buf_size
* 2;
873 (unsigned char *) realloc (pt
->putback_buf
, new_size
);
876 scm_memory_error ("scm_ungetc");
877 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
= tmp
;
878 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
879 pt
->read_buf_size
= pt
->putback_buf_size
= new_size
;
882 /* shift any existing bytes to buffer + 1. */
883 if (pt
->read_pos
== pt
->read_end
)
884 pt
->read_end
= pt
->read_buf
+ 1;
885 else if (pt
->read_pos
!= pt
->read_buf
+ 1)
887 int count
= pt
->read_end
- pt
->read_pos
;
889 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
890 pt
->read_end
= pt
->read_buf
+ 1 + count
;
893 pt
->read_pos
= pt
->read_buf
;
896 /* switch to the put-back buffer. */
898 if (pt
->putback_buf
== NULL
)
900 pt
->putback_buf
= (char *) malloc (SCM_INITIAL_PUTBACK_BUF_SIZE
);
901 if (pt
->putback_buf
== NULL
)
902 scm_memory_error ("scm_ungetc");
903 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
906 pt
->saved_read_buf
= pt
->read_buf
;
907 pt
->saved_read_pos
= pt
->read_pos
;
908 pt
->saved_read_end
= pt
->read_end
;
909 pt
->saved_read_buf_size
= pt
->read_buf_size
;
911 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
912 pt
->read_end
= pt
->read_buf
+ 1;
913 pt
->read_buf_size
= pt
->putback_buf_size
;
919 pt
->rw_active
= SCM_PORT_READ
;
923 /* What should col be in this case?
924 * We'll leave it at -1.
926 SCM_LINUM (port
) -= 1;
934 scm_ungets (const char *s
, int n
, SCM port
)
936 /* This is simple minded and inefficient, but unreading strings is
937 * probably not a common operation, and remember that line and
938 * column numbers have to be handled...
940 * Please feel free to write an optimized version!
943 scm_ungetc (s
[n
], port
);
947 SCM_DEFINE (scm_peek_char
, "peek-char", 0, 1, 0,
950 #define FUNC_NAME s_scm_peek_char
953 if (SCM_UNBNDP (port
))
956 SCM_VALIDATE_OPINPORT (1,port
);
960 scm_ungetc (c
, port
);
961 return SCM_MAKICHR (c
);
965 SCM_DEFINE (scm_unread_char
, "unread-char", 2, 0, 0,
966 (SCM cobj
, SCM port
),
967 "Place @var{char} in @var{port} so that it will be read by the\n"
968 "next read operation. If called multiple times, the unread characters\n"
969 "will be read again in last-in first-out order. If @var{port} is\n"
970 "not supplied, the current input port is used.")
971 #define FUNC_NAME s_scm_unread_char
975 SCM_VALIDATE_ICHR (1,cobj
);
976 if (SCM_UNBNDP (port
))
979 SCM_VALIDATE_OPINPORT (2,port
);
983 scm_ungetc (c
, port
);
988 SCM_DEFINE (scm_unread_string
, "unread-string", 2, 0, 0,
990 "Place the string @var{str} in @var{port} so that its characters will be\n"
991 "read in subsequent read operations. If called multiple times, the\n"
992 "unread characters will be read again in last-in first-out order. If\n"
993 "@var{port} is not supplied, the current-input-port is used.")
994 #define FUNC_NAME s_scm_unread_string
996 SCM_VALIDATE_STRING (1,str
);
997 if (SCM_UNBNDP (port
))
1000 SCM_VALIDATE_OPINPORT (2,port
);
1002 scm_ungets (SCM_ROUCHARS (str
), SCM_LENGTH (str
), port
);
1008 SCM_DEFINE (scm_seek
, "seek", 3, 0, 0,
1009 (SCM object
, SCM offset
, SCM whence
),
1010 "Sets the current position of @var{fd/port} to the integer @var{offset},\n"
1011 "which is interpreted according to the value of @var{whence}.\n\n"
1012 "One of the following variables should be supplied\n"
1013 "for @var{whence}:\n"
1014 "@defvar SEEK_SET\n"
1015 "Seek from the beginning of the file.\n"
1017 "@defvar SEEK_CUR\n"
1018 "Seek from the current position.\n"
1020 "@defvar SEEK_END\n"
1021 "Seek from the end of the file.\n"
1023 "If @var{fd/port} is a file descriptor, the underlying system call is\n"
1024 "@code{lseek}. @var{port} may be a string port.\n\n"
1025 "The value returned is the new position in the file. This means that\n"
1026 "the current position of a port can be obtained using:\n"
1028 "(seek port 0 SEEK_CUR)\n"
1030 #define FUNC_NAME s_scm_seek
1036 object
= SCM_COERCE_OUTPORT (object
);
1038 off
= SCM_NUM2LONG (2,offset
);
1039 SCM_VALIDATE_INUM_COPY (3,whence
,how
);
1040 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
1041 SCM_OUT_OF_RANGE (3, whence
);
1042 if (SCM_OPPORTP (object
))
1044 scm_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1047 SCM_MISC_ERROR ("port is not seekable",
1048 scm_cons (object
, SCM_EOL
));
1050 rv
= ptob
->seek (object
, off
, how
);
1052 else /* file descriptor?. */
1054 SCM_VALIDATE_INUM (1,object
);
1055 rv
= lseek (SCM_INUM (object
), off
, how
);
1059 return scm_long2num (rv
);
1063 SCM_DEFINE (scm_truncate_file
, "truncate-file", 1, 1, 0,
1064 (SCM object
, SCM length
),
1065 "Truncates the object referred to by @var{obj} to at most @var{size} bytes.\n"
1066 "@var{obj} can be a string containing a file name or an integer file\n"
1067 "descriptor or a port. @var{size} may be omitted if @var{obj} is not\n"
1068 "a file name, in which case the truncation occurs at the current port.\n"
1070 "The return value is unspecified.")
1071 #define FUNC_NAME s_scm_truncate_file
1076 /* object can be a port, fdes or filename. */
1078 if (SCM_UNBNDP (length
))
1080 /* must supply length if object is a filename. */
1081 if (SCM_ROSTRINGP (object
))
1082 SCM_MISC_ERROR("must supply length if OBJECT is a filename",SCM_EOL
);
1084 length
= scm_seek (object
, SCM_INUM0
, SCM_MAKINUM (SEEK_CUR
));
1086 c_length
= SCM_NUM2LONG (2,length
);
1088 SCM_MISC_ERROR ("negative offset", SCM_EOL
);
1090 object
= SCM_COERCE_OUTPORT (object
);
1091 if (SCM_INUMP (object
))
1093 SCM_SYSCALL (rv
= ftruncate (SCM_INUM (object
), c_length
));
1095 else if (SCM_OPOUTPORTP (object
))
1097 scm_port
*pt
= SCM_PTAB_ENTRY (object
);
1098 scm_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1100 if (!ptob
->truncate
)
1101 SCM_MISC_ERROR ("port is not truncatable", SCM_EOL
);
1102 if (pt
->rw_active
== SCM_PORT_READ
)
1103 scm_end_input (object
);
1104 else if (pt
->rw_active
== SCM_PORT_WRITE
)
1105 ptob
->flush (object
);
1107 ptob
->truncate (object
, c_length
);
1112 SCM_VALIDATE_ROSTRING (1,object
);
1113 SCM_COERCE_SUBSTR (object
);
1114 SCM_SYSCALL (rv
= truncate (SCM_ROCHARS (object
), c_length
));
1118 return SCM_UNSPECIFIED
;
1122 SCM_DEFINE (scm_port_line
, "port-line", 1, 0, 0,
1125 #define FUNC_NAME s_scm_port_line
1127 port
= SCM_COERCE_OUTPORT (port
);
1128 SCM_VALIDATE_OPENPORT (1,port
);
1129 return SCM_MAKINUM (SCM_LINUM (port
));
1133 SCM_DEFINE (scm_set_port_line_x
, "set-port-line!", 2, 0, 0,
1134 (SCM port
, SCM line
),
1136 #define FUNC_NAME s_scm_set_port_line_x
1138 port
= SCM_COERCE_OUTPORT (port
);
1139 SCM_VALIDATE_OPENPORT (1,port
);
1140 SCM_VALIDATE_INUM (2,line
);
1141 return SCM_PTAB_ENTRY (port
)->line_number
= SCM_INUM (line
);
1145 SCM_DEFINE (scm_port_column
, "port-column", 1, 0, 0,
1147 "@deffnx primitive port-line [input-port]\n"
1148 "Return the current column number or line number of @var{input-port},\n"
1149 "using the current input port if none is specified. If the number is\n"
1150 "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
1151 "- i.e. the first character of the first line is line 0, column 0.\n"
1152 "(However, when you display a file position, for example in an error\n"
1153 "message, we recommand you add 1 to get 1-origin integers. This is\n"
1154 "because lines and column numbers traditionally start with 1, and that is\n"
1155 "what non-programmers will find most natural.)")
1156 #define FUNC_NAME s_scm_port_column
1158 port
= SCM_COERCE_OUTPORT (port
);
1159 SCM_VALIDATE_OPENPORT (1,port
);
1160 return SCM_MAKINUM (SCM_COL (port
));
1164 SCM_DEFINE (scm_set_port_column_x
, "set-port-column!", 2, 0, 0,
1165 (SCM port
, SCM column
),
1166 "@deffnx primitive set-port-line! [input-port] line\n"
1167 "Set the current column or line number of @var{input-port}, using the\n"
1168 "current input port if none is specified.")
1169 #define FUNC_NAME s_scm_set_port_column_x
1171 port
= SCM_COERCE_OUTPORT (port
);
1172 SCM_VALIDATE_OPENPORT (1,port
);
1173 SCM_VALIDATE_INUM (2,column
);
1174 return SCM_PTAB_ENTRY (port
)->column_number
= SCM_INUM (column
);
1178 SCM_DEFINE (scm_port_filename
, "port-filename", 1, 0, 0,
1180 "Return the filename associated with @var{port}. This function returns\n"
1181 "the strings "standard input
", "standard output
" and "standard error
"
1182 when called on the current input, output and error ports respectively.")
1183 #define FUNC_NAME s_scm_port_filename
1185 port
= SCM_COERCE_OUTPORT (port
);
1186 SCM_VALIDATE_OPENPORT (1,port
);
1187 return SCM_PTAB_ENTRY (port
)->file_name
;
1191 SCM_DEFINE (scm_set_port_filename_x
, "set-port-filename!", 2, 0, 0,
1192 (SCM port
, SCM filename
),
1193 "Change the filename associated with @var{port}, using the current input\n"
1194 "port if none is specified. Note that this does not change the port's\n"
1195 "source of data, but only the value that is returned by\n"
1196 "@code{port-filename} and reported in diagnostic output.")
1197 #define FUNC_NAME s_scm_set_port_filename_x
1199 port
= SCM_COERCE_OUTPORT (port
);
1200 SCM_VALIDATE_OPENPORT (1,port
);
1201 /* We allow the user to set the filename to whatever he likes. */
1202 return SCM_PTAB_ENTRY (port
)->file_name
= filename
;
1207 extern char * ttyname();
1211 scm_print_port_mode (SCM exp
, SCM port
)
1213 scm_puts (SCM_CLOSEDP (exp
)
1215 : (SCM_RDNG
& SCM_CAR (exp
)
1216 ? (SCM_WRTNG
& SCM_CAR (exp
)
1219 : (SCM_WRTNG
& SCM_CAR (exp
)
1226 scm_port_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
1228 char *type
= SCM_PTOBNAME (SCM_PTOBNUM (exp
));
1231 scm_puts ("#<", port
);
1232 scm_print_port_mode (exp
, port
);
1233 scm_puts (type
, port
);
1234 scm_putc (' ', port
);
1235 scm_intprint (SCM_CDR (exp
), 16, port
);
1236 scm_putc ('>', port
);
1240 extern void scm_make_fptob ();
1241 extern void scm_make_stptob ();
1242 extern void scm_make_sfptob ();
1245 scm_ports_prehistory ()
1248 scm_ptobs
= (scm_ptob_descriptor
*) malloc (sizeof (scm_ptob_descriptor
));
1250 /* WARNING: These scm_newptob calls must be done in this order.
1251 * They must agree with the port declarations in tags.h.
1253 /* scm_tc16_fport = */ scm_make_fptob ();
1254 /* scm_tc16_pipe was here */ scm_make_fptob (); /* dummy. */
1255 /* scm_tc16_strport = */ scm_make_stptob ();
1256 /* scm_tc16_sfport = */ scm_make_sfptob ();
1263 long scm_tc16_void_port
= 0;
1266 flush_void_port (SCM port
)
1271 end_input_void_port (SCM port
, int offset
)
1276 write_void_port (SCM port
, const void *data
, size_t size
)
1281 scm_void_port (char *mode_str
)
1287 SCM_NEWCELL (answer
);
1289 mode_bits
= scm_mode_bits (mode_str
);
1290 pt
= scm_add_to_port_table (answer
);
1291 SCM_SETPTAB_ENTRY (answer
, pt
);
1292 SCM_SETSTREAM (answer
, 0);
1293 SCM_SETCAR (answer
, scm_tc16_void_port
| mode_bits
);
1299 SCM_DEFINE (scm_sys_make_void_port
, "%make-void-port", 1, 0, 0,
1301 "Create and return a new void port. The @var{mode} argument describes\n"
1302 "the input/output modes for this port; for a description, see the\n"
1303 "documentation for @code{open-file} in @ref{File Ports}.")
1304 #define FUNC_NAME s_scm_sys_make_void_port
1306 SCM_VALIDATE_ROSTRING (1,mode
);
1307 SCM_COERCE_SUBSTR (mode
);
1308 return scm_void_port (SCM_ROCHARS (mode
));
1313 /* Initialization. */
1318 /* lseek() symbols. */
1319 scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET
));
1320 scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR
));
1321 scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END
));
1323 scm_tc16_void_port
= scm_make_port_type ("void", 0, write_void_port
);