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
, void *data
, size_t size
);
106 scm_make_port_type (char *name
,
107 int (*fill_input
) (SCM port
),
108 void (*write
) (SCM port
, 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)
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
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
325 @deffnx primitive set-current-error-port port
326 Change the ports returned by @code{current-input-port},
327 @code{current-output-port} and @code{current-error-port}, respectively,
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.
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
540 will not necessarily be identical to the modes used when the port was
541 opened, since modes such as \"append\" which are used only during
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
575 closes a port or @code{#f} if it was already
576 closed. An exception may be raised if an error occurs, for example
577 when flushing buffered output.
578 See also @ref{Ports and File Descriptors, close}, for a procedure
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
604 except for those supplied as arguments. This procedure
605 is intended to be used before an exec call to close file descriptors
606 which are not needed in the new process.Close all open file ports used by the interpreter
607 except for those supplied as arguments. This procedure
608 is intended to be used before an exec call to close file descriptors
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_OPPORT(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}
689 is omitted. The current output buffer contents are passed to the
690 underlying port implementation (e.g., in the case of fports, the
691 data will be written to the file and the output buffer will be cleared.)
692 It has no effect on an unbuffered port.
694 The return value is unspecified.")
695 #define FUNC_NAME s_scm_force_output
697 if (SCM_UNBNDP (port
))
701 port
= SCM_COERCE_OUTPORT (port
);
702 SCM_VALIDATE_OPOUTPORT(1,port
);
705 return SCM_UNSPECIFIED
;
709 SCM_DEFINE (scm_flush_all_ports
, "flush-all-ports", 0, 0, 0,
711 "Equivalent to calling @code{force-output} on
712 all open output ports. The return value is unspecified.")
713 #define FUNC_NAME s_scm_flush_all_ports
717 for (i
= 0; i
< scm_port_table_size
; i
++)
719 if (SCM_OPOUTPORTP (scm_port_table
[i
]->port
))
720 scm_flush (scm_port_table
[i
]->port
);
722 return SCM_UNSPECIFIED
;
726 SCM_DEFINE(scm_read_char
, "read-char", 0, 1, 0,
729 #define FUNC_NAME s_scm_read_char
732 if (SCM_UNBNDP (port
))
734 SCM_VALIDATE_OPINPORT(1,port
);
738 return SCM_MAKICHR (c
);
742 /* this should only be called when the read buffer is empty. it
743 tries to refill the read buffer. it returns the first char from
744 the port, which is either EOF or *(pt->read_pos). */
746 scm_fill_input (SCM port
)
748 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
750 if (pt
->read_buf
== pt
->putback_buf
)
752 /* finished reading put-back chars. */
753 pt
->read_buf
= pt
->saved_read_buf
;
754 pt
->read_pos
= pt
->saved_read_pos
;
755 pt
->read_end
= pt
->saved_read_end
;
756 pt
->read_buf_size
= pt
->saved_read_buf_size
;
757 if (pt
->read_pos
< pt
->read_end
)
758 return *(pt
->read_pos
);
760 return scm_ptobs
[SCM_PTOBNUM (port
)].fill_input (port
);
767 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
769 if (pt
->rw_active
== SCM_PORT_WRITE
)
771 /* may be marginally faster than calling scm_flush. */
772 scm_ptobs
[SCM_PTOBNUM (port
)].flush (port
);
776 pt
->rw_active
= SCM_PORT_READ
;
778 if (pt
->read_pos
>= pt
->read_end
)
780 if (scm_fill_input (port
) == EOF
)
784 c
= *(pt
->read_pos
++);
803 scm_putc (char c
, SCM port
)
805 scm_lfwrite (&c
, 1, port
);
809 scm_puts (char *s
, SCM port
)
811 scm_lfwrite (s
, strlen (s
), port
);
815 scm_lfwrite (char *ptr
, scm_sizet size
, SCM port
)
817 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
818 scm_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
820 if (pt
->rw_active
== SCM_PORT_READ
)
821 scm_end_input (port
);
823 ptob
->write (port
, ptr
, size
);
826 pt
->rw_active
= SCM_PORT_WRITE
;
833 scm_sizet i
= SCM_PTOBNUM (port
);
834 (scm_ptobs
[i
].flush
) (port
);
838 scm_end_input (SCM port
)
841 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
843 if (pt
->read_buf
== pt
->putback_buf
)
845 offset
= pt
->read_end
- pt
->read_pos
;
846 pt
->read_buf
= pt
->saved_read_buf
;
847 pt
->read_pos
= pt
->saved_read_pos
;
848 pt
->read_end
= pt
->saved_read_end
;
849 pt
->read_buf_size
= pt
->saved_read_buf_size
;
854 scm_ptobs
[SCM_PTOBNUM (port
)].end_input (port
, offset
);
861 scm_ungetc (int c
, SCM port
)
863 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
865 if (pt
->read_buf
== pt
->putback_buf
)
866 /* already using the put-back buffer. */
868 /* enlarge putback_buf if necessary. */
869 if (pt
->read_end
== pt
->read_buf
+ pt
->read_buf_size
870 && pt
->read_buf
== pt
->read_pos
)
872 int new_size
= pt
->read_buf_size
* 2;
874 (unsigned char *) realloc (pt
->putback_buf
, new_size
);
877 scm_memory_error ("scm_ungetc");
878 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
= tmp
;
879 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
880 pt
->read_buf_size
= pt
->putback_buf_size
= new_size
;
883 /* shift any existing bytes to buffer + 1. */
884 if (pt
->read_pos
== pt
->read_end
)
885 pt
->read_end
= pt
->read_buf
+ 1;
886 else if (pt
->read_pos
!= pt
->read_buf
+ 1)
888 int count
= pt
->read_end
- pt
->read_pos
;
890 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
891 pt
->read_end
= pt
->read_buf
+ 1 + count
;
894 pt
->read_pos
= pt
->read_buf
;
897 /* switch to the put-back buffer. */
899 if (pt
->putback_buf
== NULL
)
901 pt
->putback_buf
= (char *) malloc (SCM_INITIAL_PUTBACK_BUF_SIZE
);
902 if (pt
->putback_buf
== NULL
)
903 scm_memory_error ("scm_ungetc");
904 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
907 pt
->saved_read_buf
= pt
->read_buf
;
908 pt
->saved_read_pos
= pt
->read_pos
;
909 pt
->saved_read_end
= pt
->read_end
;
910 pt
->saved_read_buf_size
= pt
->read_buf_size
;
912 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
913 pt
->read_end
= pt
->read_buf
+ 1;
914 pt
->read_buf_size
= pt
->putback_buf_size
;
920 pt
->rw_active
= SCM_PORT_READ
;
924 /* What should col be in this case?
925 * We'll leave it at -1.
927 SCM_LINUM (port
) -= 1;
935 scm_ungets (char *s
, int n
, SCM port
)
937 /* This is simple minded and inefficient, but unreading strings is
938 * probably not a common operation, and remember that line and
939 * column numbers have to be handled...
941 * Please feel free to write an optimized version!
944 scm_ungetc (s
[n
], port
);
948 SCM_DEFINE(scm_peek_char
, "peek-char", 0, 1, 0,
951 #define FUNC_NAME s_scm_peek_char
954 if (SCM_UNBNDP (port
))
957 SCM_VALIDATE_OPINPORT(1,port
);
961 scm_ungetc (c
, port
);
962 return SCM_MAKICHR (c
);
966 SCM_DEFINE (scm_unread_char
, "unread-char", 2, 0, 0,
967 (SCM cobj
, SCM port
),
968 "Place @var{char} in @var{port} so that it will be read by the
969 next read operation. If called multiple times, the unread characters
970 will be read again in last-in first-out order. If @var{port} is
971 not supplied, the current input port is used.")
972 #define FUNC_NAME s_scm_unread_char
976 SCM_VALIDATE_CHAR(1,cobj
);
977 if (SCM_UNBNDP (port
))
980 SCM_VALIDATE_OPINPORT(2,port
);
984 scm_ungetc (c
, port
);
989 SCM_DEFINE (scm_unread_string
, "unread-string", 2, 0, 0,
991 "Place the string @var{str} in @var{port} so that its characters will be
992 read in subsequent read operations. If called multiple times, the
993 unread characters will be read again in last-in first-out order. If
994 @var{port} is not supplied, the current-input-port is used.")
995 #define FUNC_NAME s_scm_unread_string
997 SCM_VALIDATE_STRING(1,str
);
998 if (SCM_UNBNDP (port
))
1001 SCM_VALIDATE_OPINPORT(2,port
);
1003 scm_ungets (SCM_ROUCHARS (str
), SCM_LENGTH (str
), port
);
1009 SCM_DEFINE (scm_seek
, "seek", 3, 0, 0,
1010 (SCM object
, SCM offset
, SCM whence
),
1011 "Sets the current position of @var{fd/port} to the integer @var{offset},
1012 which is interpreted according to the value of @var{whence}.
1014 One of the following variables should be supplied
1017 Seek from the beginning of the file.
1020 Seek from the current position.
1023 Seek from the end of the file.
1026 If @var{fd/port} is a file descriptor, the underlying system call is
1027 @code{lseek}. @var{port} may be a string port.
1029 The value returned is the new position in the file. This means that
1030 the current position of a port can be obtained using:
1032 (seek port 0 SEEK_CUR)
1034 #define FUNC_NAME s_scm_seek
1040 object
= SCM_COERCE_OUTPORT (object
);
1042 off
= SCM_NUM2LONG (2,offset
);
1043 SCM_VALIDATE_INUM_COPY(3,whence
,how
);
1044 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
1045 SCM_OUT_OF_RANGE (3, whence
);
1046 if (SCM_OPPORTP (object
))
1048 scm_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1051 SCM_MISC_ERROR ("port is not seekable",
1052 scm_cons (object
, SCM_EOL
));
1054 rv
= ptob
->seek (object
, off
, how
);
1056 else /* file descriptor?. */
1058 SCM_VALIDATE_INUM(1,object
);
1059 rv
= lseek (SCM_INUM (object
), off
, how
);
1063 return scm_long2num (rv
);
1067 SCM_DEFINE (scm_truncate_file
, "truncate-file", 1, 1, 0,
1068 (SCM object
, SCM length
),
1069 "Truncates the object referred to by @var{obj} to at most @var{size} bytes.
1070 @var{obj} can be a string containing a file name or an integer file
1071 descriptor or a port. @var{size} may be omitted if @var{obj} is not
1072 a file name, in which case the truncation occurs at the current port.
1075 The return value is unspecified.")
1076 #define FUNC_NAME s_scm_truncate_file
1081 /* object can be a port, fdes or filename. */
1083 if (SCM_UNBNDP (length
))
1085 /* must supply length if object is a filename. */
1086 if (SCM_ROSTRINGP (object
))
1087 scm_wrong_num_args (SCM_FUNC_NAME
);
1089 length
= scm_seek (object
, SCM_INUM0
, SCM_MAKINUM (SEEK_CUR
));
1091 c_length
= SCM_NUM2LONG (2,length
);
1093 SCM_MISC_ERROR ("negative offset", SCM_EOL
);
1095 object
= SCM_COERCE_OUTPORT (object
);
1096 if (SCM_INUMP (object
))
1098 SCM_SYSCALL (rv
= ftruncate (SCM_INUM (object
), c_length
));
1100 else if (SCM_OPOUTPORTP (object
))
1102 scm_port
*pt
= SCM_PTAB_ENTRY (object
);
1103 scm_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1105 if (!ptob
->truncate
)
1106 SCM_MISC_ERROR ("port is not truncatable", SCM_EOL
);
1107 if (pt
->rw_active
== SCM_PORT_READ
)
1108 scm_end_input (object
);
1109 else if (pt
->rw_active
== SCM_PORT_WRITE
)
1110 ptob
->flush (object
);
1112 ptob
->truncate (object
, c_length
);
1117 SCM_VALIDATE_ROSTRING(1,object
);
1118 SCM_COERCE_SUBSTR (object
);
1119 SCM_SYSCALL (rv
= truncate (SCM_ROCHARS (object
), c_length
));
1123 return SCM_UNSPECIFIED
;
1127 SCM_DEFINE (scm_port_line
, "port-line", 1, 0, 0,
1130 #define FUNC_NAME s_scm_port_line
1132 port
= SCM_COERCE_OUTPORT (port
);
1133 SCM_VALIDATE_OPENPORT(1,port
);
1134 return SCM_MAKINUM (SCM_LINUM (port
));
1138 SCM_DEFINE (scm_set_port_line_x
, "set-port-line!", 2, 0, 0,
1139 (SCM port
, SCM line
),
1141 #define FUNC_NAME s_scm_set_port_line_x
1143 port
= SCM_COERCE_OUTPORT (port
);
1144 SCM_VALIDATE_OPENPORT(1,port
);
1145 SCM_VALIDATE_INUM(2,line
);
1146 return SCM_PTAB_ENTRY (port
)->line_number
= SCM_INUM (line
);
1150 SCM_DEFINE (scm_port_column
, "port-column", 1, 0, 0,
1152 "@deffnx primitive port-line [input-port]
1153 Return the current column number or line number of @var{input-port},
1154 using the current input port if none is specified. If the number is
1155 unknown, the result is #f. Otherwise, the result is a 0-origin integer
1156 - i.e. the first character of the first line is line 0, column 0.
1157 (However, when you display a file position, for example in an error
1158 message, we recommand you add 1 to get 1-origin integers. This is
1159 because lines and column numbers traditionally start with 1, and that is
1160 what non-programmers will find most natural.)")
1161 #define FUNC_NAME s_scm_port_column
1163 port
= SCM_COERCE_OUTPORT (port
);
1164 SCM_VALIDATE_OPENPORT(1,port
);
1165 return SCM_MAKINUM (SCM_COL (port
));
1169 SCM_DEFINE (scm_set_port_column_x
, "set-port-column!", 2, 0, 0,
1170 (SCM port
, SCM column
),
1171 "@deffnx primitive set-port-line! [input-port] line
1172 Set the current column or line number of @var{input-port}, using the
1173 current input port if none is specified.")
1174 #define FUNC_NAME s_scm_set_port_column_x
1176 port
= SCM_COERCE_OUTPORT (port
);
1177 SCM_VALIDATE_OPENPORT(1,port
);
1178 SCM_VALIDATE_INUM(2,column
);
1179 return SCM_PTAB_ENTRY (port
)->column_number
= SCM_INUM (column
);
1183 SCM_DEFINE (scm_port_filename
, "port-filename", 1, 0, 0,
1185 "Return the filename associated with @var{port}. This function returns
1186 the strings "standard input
", "standard output
" and "standard error
"
1187 when called on the current input, output and error ports respectively.")
1188 #define FUNC_NAME s_scm_port_filename
1190 port
= SCM_COERCE_OUTPORT (port
);
1191 SCM_VALIDATE_OPENPORT(1,port
);
1192 return SCM_PTAB_ENTRY (port
)->file_name
;
1196 SCM_DEFINE (scm_set_port_filename_x
, "set-port-filename!", 2, 0, 0,
1197 (SCM port
, SCM filename
),
1198 "Change the filename associated with @var{port}, using the current input
1199 port if none is specified. Note that this does not change the port's
1200 source of data, but only the value that is returned by
1201 @code{port-filename} and reported in diagnostic output.")
1202 #define FUNC_NAME s_scm_set_port_filename_x
1204 port
= SCM_COERCE_OUTPORT (port
);
1205 SCM_VALIDATE_OPENPORT(1,port
);
1206 /* We allow the user to set the filename to whatever he likes. */
1207 return SCM_PTAB_ENTRY (port
)->file_name
= filename
;
1212 extern char * ttyname();
1216 scm_print_port_mode (SCM exp
, SCM port
)
1218 scm_puts (SCM_CLOSEDP (exp
)
1220 : (SCM_RDNG
& SCM_CAR (exp
)
1221 ? (SCM_WRTNG
& SCM_CAR (exp
)
1224 : (SCM_WRTNG
& SCM_CAR (exp
)
1231 scm_port_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
1233 char *type
= SCM_PTOBNAME (SCM_PTOBNUM (exp
));
1236 scm_puts ("#<", port
);
1237 scm_print_port_mode (exp
, port
);
1238 scm_puts (type
, port
);
1239 scm_putc (' ', port
);
1240 scm_intprint (SCM_CDR (exp
), 16, port
);
1241 scm_putc ('>', port
);
1245 extern void scm_make_fptob ();
1246 extern void scm_make_stptob ();
1247 extern void scm_make_sfptob ();
1250 scm_ports_prehistory ()
1253 scm_ptobs
= (scm_ptob_descriptor
*) malloc (sizeof (scm_ptob_descriptor
));
1255 /* WARNING: These scm_newptob calls must be done in this order.
1256 * They must agree with the port declarations in tags.h.
1258 /* scm_tc16_fport = */ scm_make_fptob ();
1259 /* scm_tc16_pipe was here */ scm_make_fptob (); /* dummy. */
1260 /* scm_tc16_strport = */ scm_make_stptob ();
1261 /* scm_tc16_sfport = */ scm_make_sfptob ();
1268 long scm_tc16_void_port
= 0;
1271 flush_void_port (SCM port
)
1276 end_input_void_port (SCM port
, int offset
)
1281 write_void_port (SCM port
, void *data
, size_t size
)
1286 scm_void_port (char *mode_str
)
1292 SCM_NEWCELL (answer
);
1294 mode_bits
= scm_mode_bits (mode_str
);
1295 pt
= scm_add_to_port_table (answer
);
1296 SCM_SETPTAB_ENTRY (answer
, pt
);
1297 SCM_SETSTREAM (answer
, 0);
1298 SCM_SETCAR (answer
, scm_tc16_void_port
| mode_bits
);
1304 SCM_DEFINE (scm_sys_make_void_port
, "%make-void-port", 1, 0, 0,
1306 "Create and return a new void port. The @var{mode} argument describes
1307 the input/output modes for this port; for a description, see the
1308 documentation for @code{open-file} in @ref{File Ports}.")
1309 #define FUNC_NAME s_scm_sys_make_void_port
1311 SCM_VALIDATE_ROSTRING(1,mode
);
1312 SCM_COERCE_SUBSTR (mode
);
1313 return scm_void_port (SCM_ROCHARS (mode
));
1318 /* Initialization. */
1323 /* lseek() symbols. */
1324 scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET
));
1325 scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR
));
1326 scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END
));
1328 scm_tc16_void_port
= scm_make_port_type ("void", 0, write_void_port
);