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. */
64 #ifdef HAVE_SYS_IOCTL_H
65 #include <sys/ioctl.h>
69 /* The port kind table --- a dynamically resized array of port types. */
72 /* scm_ptobs scm_numptob
73 * implement a dynamicly resized array of ptob records.
74 * Indexes into this table are used when generating type
75 * tags for smobjects (if you know a tag you can get an index and conversely).
77 scm_ptobfuns
*scm_ptobs
;
80 /* GC marker for a port with stream of SCM type. */
86 openp
= SCM_CAR (ptr
) & SCM_OPN
;
88 return SCM_STREAM (ptr
);
99 if (255 <= scm_numptob
)
101 tmp
= (char *) realloc ((char *) scm_ptobs
, (1 + scm_numptob
) * sizeof (scm_ptobfuns
));
104 scm_ptobs
= (scm_ptobfuns
*) tmp
;
105 scm_ptobs
[scm_numptob
].mark
= ptob
->mark
;
106 scm_ptobs
[scm_numptob
].free
= ptob
->free
;
107 scm_ptobs
[scm_numptob
].print
= ptob
->print
;
108 scm_ptobs
[scm_numptob
].equalp
= ptob
->equalp
;
109 scm_ptobs
[scm_numptob
].fflush
= ptob
->fflush
;
110 scm_ptobs
[scm_numptob
].read_flush
= ptob
->read_flush
;
111 scm_ptobs
[scm_numptob
].fclose
= ptob
->fclose
;
112 scm_ptobs
[scm_numptob
].fill_buffer
= ptob
->fill_buffer
;
113 scm_ptobs
[scm_numptob
].seek
= ptob
->seek
;
114 scm_ptobs
[scm_numptob
].ftruncate
= ptob
->ftruncate
;
115 scm_ptobs
[scm_numptob
].input_waiting_p
= ptob
->input_waiting_p
;
119 ptoberr
:scm_wta (SCM_MAKINUM ((long) scm_numptob
), (char *) SCM_NALLOC
, "newptob");
120 return scm_tc7_port
+ (scm_numptob
- 1) * 256;
125 SCM_PROC(s_char_ready_p
, "char-ready?", 0, 1, 0, scm_char_ready_p
);
128 scm_char_ready_p (port
)
131 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
133 if (SCM_UNBNDP (port
))
136 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
,
139 /* if the current read buffer is filled, or the
140 last pushed-back char has been read and the saved buffer is
141 filled, result is true. */
142 if (pt
->read_pos
< pt
->read_end
143 || (pt
->read_buf
== pt
->putback_buf
144 && pt
->saved_read_pos
< pt
->saved_read_end
))
148 scm_ptobfuns
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
150 if (ptob
->input_waiting_p
)
151 return (ptob
->input_waiting_p (port
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
157 /* Clear a port's read buffers, returning the contents. */
158 SCM_PROC (s_drain_input
, "drain-input", 1, 0, 0, scm_drain_input
);
160 scm_drain_input (SCM port
)
163 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
167 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
,
170 count
= pt
->read_end
- pt
->read_pos
;
171 if (pt
->read_buf
== pt
->putback_buf
)
172 count
+= pt
->saved_read_end
- pt
->saved_read_pos
;
174 result
= scm_makstr (count
, 0);
175 dst
= SCM_CHARS (result
);
177 while (pt
->read_pos
< pt
->read_end
)
178 *dst
++ = *(pt
->read_pos
++);
180 if (pt
->read_buf
== pt
->putback_buf
)
182 while (pt
->saved_read_pos
< pt
->saved_read_end
)
183 *dst
++ = *(pt
->saved_read_pos
++);
190 /* Standard ports --- current input, output, error, and more(!). */
192 SCM_PROC(s_current_input_port
, "current-input-port", 0, 0, 0, scm_current_input_port
);
195 scm_current_input_port ()
200 SCM_PROC(s_current_output_port
, "current-output-port", 0, 0, 0, scm_current_output_port
);
203 scm_current_output_port ()
208 SCM_PROC(s_current_error_port
, "current-error-port", 0, 0, 0, scm_current_error_port
);
211 scm_current_error_port ()
216 SCM_PROC(s_current_load_port
, "current-load-port", 0, 0, 0, scm_current_load_port
);
219 scm_current_load_port ()
221 return scm_cur_loadp
;
224 SCM_PROC(s_set_current_input_port
, "set-current-input-port", 1, 0, 0, scm_set_current_input_port
);
227 scm_set_current_input_port (port
)
230 SCM oinp
= scm_cur_inp
;
231 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
, s_set_current_input_port
);
237 SCM_PROC(s_set_current_output_port
, "set-current-output-port", 1, 0, 0, scm_set_current_output_port
);
240 scm_set_current_output_port (port
)
243 SCM ooutp
= scm_cur_outp
;
244 port
= SCM_COERCE_OUTPORT (port
);
245 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
), port
, SCM_ARG1
, s_set_current_output_port
);
251 SCM_PROC(s_set_current_error_port
, "set-current-error-port", 1, 0, 0, scm_set_current_error_port
);
254 scm_set_current_error_port (port
)
257 SCM oerrp
= scm_cur_errp
;
258 port
= SCM_COERCE_OUTPORT (port
);
259 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
), port
, SCM_ARG1
, s_set_current_error_port
);
265 /* The port table --- an array of pointers to ports. */
267 scm_port
**scm_port_table
;
269 int scm_port_table_size
= 0; /* Number of ports in scm_port_table. */
270 int scm_port_table_room
= 20; /* Size of the array. */
272 /* Add a port to the table. */
275 scm_add_to_port_table (port
)
280 if (scm_port_table_size
== scm_port_table_room
)
282 void *newt
= realloc ((char *) scm_port_table
,
283 (scm_sizet
) (sizeof (scm_port
*)
284 * scm_port_table_room
* 2));
286 scm_memory_error ("scm_add_to_port_table");
287 scm_port_table
= (scm_port
**) newt
;
288 scm_port_table_room
*= 2;
290 entry
= (scm_port
*) malloc (sizeof (scm_port
));
292 scm_memory_error ("scm_add_to_port_table");
295 entry
->entry
= scm_port_table_size
;
298 entry
->file_name
= SCM_BOOL_F
;
299 entry
->line_number
= 0;
300 entry
->column_number
= 0;
301 entry
->putback_buf
= 0;
302 entry
->putback_buf_size
= 0;
303 entry
->rw_active
= 0;
305 scm_port_table
[scm_port_table_size
] = entry
;
306 scm_port_table_size
++;
311 /* Remove a port from the table and destroy it. */
314 scm_remove_from_port_table (port
)
317 scm_port
*p
= SCM_PTAB_ENTRY (port
);
320 if (i
>= scm_port_table_size
)
321 scm_wta (port
, "Port not in table", "scm_remove_from_port_table");
323 free (p
->putback_buf
);
325 /* Since we have just freed slot i we can shrink the table by moving
326 the last entry to that slot... */
327 if (i
< scm_port_table_size
- 1)
329 scm_port_table
[i
] = scm_port_table
[scm_port_table_size
- 1];
330 scm_port_table
[i
]->entry
= i
;
332 SCM_SETPTAB_ENTRY (port
, 0);
333 scm_port_table_size
--;
338 scm_grow_port_cbuf (port
, requested
)
342 scm_port
*p
= SCM_PTAB_ENTRY (port
);
343 int size
= p
->cbufend
- p
->cbuf
;
344 int new_size
= size
* 3 / 2;
345 int count
= p
->cp
- p
->cbuf
;
347 if (new_size
< requested
)
348 new_size
= requested
;
349 p
= realloc (p
, sizeof (*p
) - SCM_INITIAL_CBUF_SIZE
+ new_size
);
350 p
->cp
= p
->cbuf
+ count
;
351 p
->bufend
= p
->cbuf
+ new_size
;
352 scm_port_table
[p
->entry
] = p
;
353 SCM_SETPTAB_ENTRY (port
, p
);
358 /* Undocumented functions for debugging. */
359 /* Return the number of ports in the table. */
361 SCM_PROC(s_pt_size
, "pt-size", 0, 0, 0, scm_pt_size
);
365 return SCM_MAKINUM (scm_port_table_size
);
368 /* Return the ith member of the port table. */
369 SCM_PROC(s_pt_member
, "pt-member", 1, 0, 0, scm_pt_member
);
371 scm_pt_member (member
)
375 SCM_ASSERT (SCM_INUMP (member
), member
, SCM_ARG1
, s_pt_member
);
376 i
= SCM_INUM (member
);
377 if (i
< 0 || i
>= scm_port_table_size
)
380 return scm_port_table
[i
]->port
;
386 /* Revealed counts --- an oddity inherited from SCSH. */
388 /* Find a port in the table and return its revealed count.
389 Also used by the garbage collector.
393 scm_revealed_count (port
)
396 return SCM_REVEALED(port
);
401 /* Return the revealed count for a port. */
403 SCM_PROC(s_port_revealed
, "port-revealed", 1, 0, 0, scm_port_revealed
);
406 scm_port_revealed (port
)
409 port
= SCM_COERCE_OUTPORT (port
);
410 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
), port
, SCM_ARG1
, s_port_revealed
);
411 return SCM_MAKINUM (scm_revealed_count (port
));
414 /* Set the revealed count for a port. */
415 SCM_PROC(s_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x
);
418 scm_set_port_revealed_x (port
, rcount
)
422 port
= SCM_COERCE_OUTPORT (port
);
423 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
), port
, SCM_ARG1
, s_set_port_revealed_x
);
424 SCM_ASSERT (SCM_INUMP (rcount
), rcount
, SCM_ARG2
, s_set_port_revealed_x
);
425 SCM_REVEALED (port
) = SCM_INUM (rcount
);
426 return SCM_UNSPECIFIED
;
431 /* Retrieving a port's mode. */
433 /* Return the flags that characterize a port based on the mode
434 * string used to open a file for that port.
436 * See PORT FLAGS in scm.h
440 scm_mode_bits (modes
)
444 | (strchr (modes
, 'r') || strchr (modes
, '+') ? SCM_RDNG
: 0)
445 | ( strchr (modes
, 'w')
446 || strchr (modes
, 'a')
447 || strchr (modes
, '+') ? SCM_WRTNG
: 0)
448 | (strchr (modes
, '0') ? SCM_BUF0
: 0)
449 | (strchr (modes
, 'l') ? SCM_BUFLINE
: 0));
453 /* Return the mode flags from an open port.
454 * Some modes such as "append" are only used when opening
455 * a file and are not returned here. */
457 SCM_PROC(s_port_mode
, "port-mode", 1, 0, 0, scm_port_mode
);
466 port
= SCM_COERCE_OUTPORT (port
);
467 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPPORTP (port
), port
, SCM_ARG1
, s_port_mode
);
468 if (SCM_CAR (port
) & SCM_RDNG
) {
469 if (SCM_CAR (port
) & SCM_WRTNG
)
470 strcpy (modes
, "r+");
474 else if (SCM_CAR (port
) & SCM_WRTNG
)
476 if (SCM_CAR (port
) & SCM_BUF0
)
478 return scm_makfromstr (modes
, strlen (modes
), 0);
486 * Call the close operation on a port object.
487 * see also scm_close.
489 SCM_PROC(s_close_port
, "close-port", 1, 0, 0, scm_close_port
);
492 scm_close_port (port
)
498 port
= SCM_COERCE_OUTPORT (port
);
500 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
), port
, SCM_ARG1
,
502 if (SCM_CLOSEDP (port
))
504 i
= SCM_PTOBNUM (port
);
505 if (scm_ptobs
[i
].fclose
)
506 rv
= (scm_ptobs
[i
].fclose
) (port
);
509 scm_remove_from_port_table (port
);
510 SCM_SETAND_CAR (port
, ~SCM_OPN
);
511 return (rv
< 0) ? SCM_BOOL_F
: SCM_BOOL_T
;
514 SCM_PROC(s_close_all_ports_except
, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except
);
517 scm_close_all_ports_except (ports
)
521 SCM_ASSERT (SCM_NIMP (ports
) && SCM_CONSP (ports
), ports
, SCM_ARG1
, s_close_all_ports_except
);
522 while (i
< scm_port_table_size
)
524 SCM thisport
= scm_port_table
[i
]->port
;
526 SCM ports_ptr
= ports
;
528 while (SCM_NNULLP (ports_ptr
))
530 SCM port
= SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr
));
532 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPPORTP (port
), port
, SCM_ARG1
, s_close_all_ports_except
);
533 if (port
== thisport
)
535 ports_ptr
= SCM_CDR (ports_ptr
);
540 /* i is not to be incremented here. */
541 scm_close_port (thisport
);
543 return SCM_UNSPECIFIED
;
548 /* Utter miscellany. Gosh, we should clean this up some time. */
550 SCM_PROC(s_input_port_p
, "input-port?", 1, 0, 0, scm_input_port_p
);
558 return SCM_INPORTP (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
561 SCM_PROC(s_output_port_p
, "output-port?", 1, 0, 0, scm_output_port_p
);
564 scm_output_port_p (x
)
569 return SCM_OUTPORTP (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
573 SCM_PROC(s_eof_object_p
, "eof-object?", 1, 0, 0, scm_eof_object_p
);
579 return SCM_EOF_OBJECT_P (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
582 SCM_PROC(s_force_output
, "force-output", 0, 1, 0, scm_force_output
);
585 scm_force_output (port
)
588 if (SCM_UNBNDP (port
))
592 port
= SCM_COERCE_OUTPORT (port
);
593 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
), port
, SCM_ARG1
,
597 return SCM_UNSPECIFIED
;
600 SCM_PROC (s_flush_all_ports
, "flush-all-ports", 0, 0, 0, scm_flush_all_ports
);
602 scm_flush_all_ports (void)
606 for (i
= 0; i
< scm_port_table_size
; i
++)
608 if (SCM_OPOUTPORTP (scm_port_table
[i
]->port
))
609 scm_fflush (scm_port_table
[i
]->port
);
611 return SCM_UNSPECIFIED
;
614 SCM_PROC(s_read_char
, "read-char", 0, 1, 0, scm_read_char
);
621 if (SCM_UNBNDP (port
))
624 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
, s_read_char
);
628 return SCM_MAKICHR (c
);
632 scm_fill_buffer (SCM port
)
634 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
636 if (pt
->read_buf
== pt
->putback_buf
)
638 /* finished reading put-back chars. */
639 pt
->read_buf
= pt
->saved_read_buf
;
640 pt
->read_pos
= pt
->saved_read_pos
;
641 pt
->read_end
= pt
->saved_read_end
;
642 pt
->read_buf_size
= pt
->saved_read_buf_size
;
643 if (pt
->read_pos
< pt
->read_end
)
644 return *(pt
->read_pos
++);
646 return scm_ptobs
[SCM_PTOBNUM (port
)].fill_buffer (port
);
654 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
656 if (pt
->rw_active
== SCM_PORT_WRITE
)
658 /* may be marginally faster than calling scm_fflush. */
659 scm_ptobs
[SCM_PTOBNUM (port
)].fflush (port
);
662 if (pt
->read_pos
< pt
->read_end
)
664 c
= *(pt
->read_pos
++);
668 c
= scm_fill_buffer (port
);
672 pt
->rw_active
= SCM_PORT_READ
;
695 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
696 scm_ptobfuns
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
698 if (pt
->rw_active
== SCM_PORT_READ
)
699 scm_read_flush (port
);
701 *(pt
->write_pos
++) = (char) c
;
703 if (pt
->write_pos
== pt
->write_end
)
707 pt
->rw_active
= SCM_PORT_WRITE
;
715 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
716 scm_ptobfuns
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
718 if (pt
->rw_active
== SCM_PORT_READ
)
719 scm_read_flush (port
);
723 *pt
->write_pos
++ = *s
++;
724 if (pt
->write_pos
== pt
->write_end
)
727 /* If the port is line-buffered, flush it. */
728 if ((SCM_CAR (port
) & SCM_BUFLINE
)
729 && memchr (pt
->write_buf
, '\n', pt
->write_pos
- pt
->write_buf
))
733 pt
->rw_active
= SCM_PORT_WRITE
;
737 scm_lfwrite (ptr
, size
, port
)
742 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
743 scm_ptobfuns
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
745 if (pt
->rw_active
== SCM_PORT_READ
)
746 scm_read_flush (port
);
750 int space
= pt
->write_end
- pt
->write_pos
;
751 int write_len
= (size
> space
) ? space
: size
;
753 strncpy (pt
->write_pos
, ptr
, write_len
);
754 pt
->write_pos
+= write_len
;
757 if (write_len
== space
)
760 /* If the port is line-buffered, flush it. */
761 if ((SCM_CAR (port
) & SCM_BUFLINE
)
762 && memchr (pt
->write_buf
, '\n', pt
->write_pos
- pt
->write_buf
))
763 (ptob
->fflush
) (port
);
766 pt
->rw_active
= SCM_PORT_WRITE
;
774 scm_sizet i
= SCM_PTOBNUM (port
);
775 (scm_ptobs
[i
].fflush
) (port
);
779 scm_read_flush (port
)
783 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
785 if (pt
->read_buf
== pt
->putback_buf
)
787 offset
= pt
->read_end
- pt
->read_pos
;
788 pt
->read_buf
= pt
->saved_read_buf
;
789 pt
->read_pos
= pt
->saved_read_pos
;
790 pt
->read_end
= pt
->saved_read_end
;
791 pt
->read_buf_size
= pt
->saved_read_buf_size
;
796 scm_ptobs
[SCM_PTOBNUM (port
)].read_flush (port
, offset
);
807 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
809 if (pt
->read_buf
== pt
->putback_buf
)
810 /* already using the put-back buffer. */
812 /* enlarge putback_buf if necessary. */
813 if (pt
->read_end
== pt
->read_buf
+ pt
->read_buf_size
814 && pt
->read_buf
== pt
->read_pos
)
816 int new_size
= pt
->read_buf_size
* 2;
818 (unsigned char *) realloc (pt
->putback_buf
, new_size
);
821 scm_memory_error ("scm_ungetc");
822 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
= tmp
;
823 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
824 pt
->read_buf_size
= pt
->putback_buf_size
= new_size
;
827 /* shift any existing bytes to buffer + 1. */
828 if (pt
->read_pos
== pt
->read_end
)
829 pt
->read_end
= pt
->read_buf
+ 1;
830 else if (pt
->read_pos
!= pt
->read_buf
+ 1)
832 int count
= pt
->read_end
- pt
->read_pos
;
834 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
835 pt
->read_end
= pt
->read_buf
+ 1 + count
;
838 pt
->read_pos
= pt
->read_buf
;
841 /* switch to the put-back buffer. */
843 if (pt
->putback_buf
== NULL
)
845 pt
->putback_buf
= (char *) malloc (pt
->putback_buf_size
);
846 if (pt
->putback_buf
== NULL
)
847 scm_memory_error ("scm_ungetc");
848 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
851 pt
->saved_read_buf
= pt
->read_buf
;
852 pt
->saved_read_pos
= pt
->read_pos
;
853 pt
->saved_read_end
= pt
->read_end
;
854 pt
->saved_read_buf_size
= pt
->read_buf_size
;
856 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
857 pt
->read_end
= pt
->read_buf
+ 1;
858 pt
->read_buf_size
= pt
->putback_buf_size
;
864 pt
->rw_active
= SCM_PORT_READ
;
868 /* What should col be in this case?
869 * We'll leave it at -1.
871 SCM_LINUM (port
) -= 1;
879 scm_ungets (s
, n
, port
)
884 /* This is simple minded and inefficient, but unreading strings is
885 * probably not a common operation, and remember that line and
886 * column numbers have to be handled...
888 * Please feel free to write an optimized version!
891 scm_ungetc (s
[n
], port
);
895 SCM_PROC(s_peek_char
, "peek-char", 0, 1, 0, scm_peek_char
);
902 if (SCM_UNBNDP (port
))
905 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
, s_peek_char
);
909 scm_ungetc (c
, port
);
910 return SCM_MAKICHR (c
);
913 SCM_PROC (s_unread_char
, "unread-char", 2, 0, 0, scm_unread_char
);
916 scm_unread_char (cobj
, port
)
922 SCM_ASSERT (SCM_ICHRP (cobj
), cobj
, SCM_ARG1
, s_unread_char
);
924 if (SCM_UNBNDP (port
))
927 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG2
, s_unread_char
);
932 scm_ungetc (c
, port
);
936 SCM_PROC (s_unread_string
, "unread-string", 2, 0, 0, scm_unread_string
);
939 scm_unread_string (str
, port
)
943 SCM_ASSERT (SCM_NIMP (str
) && SCM_STRINGP (str
),
944 str
, SCM_ARG1
, s_unread_string
);
946 if (SCM_UNBNDP (port
))
949 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
),
950 port
, SCM_ARG2
, s_unread_string
);
952 scm_ungets (SCM_ROUCHARS (str
), SCM_LENGTH (str
), port
);
957 SCM_PROC (s_lseek
, "lseek", 3, 0, 0, scm_lseek
);
959 scm_lseek (SCM object
, SCM offset
, SCM whence
)
965 object
= SCM_COERCE_OUTPORT (object
);
967 off
= scm_num2long (offset
, (char *)SCM_ARG2
, s_lseek
);
968 SCM_ASSERT (SCM_INUMP (whence
), whence
, SCM_ARG3
, s_lseek
);
969 how
= SCM_INUM (whence
);
970 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
971 scm_out_of_range (s_lseek
, whence
);
972 if (SCM_NIMP (object
) && SCM_OPPORTP (object
))
974 scm_port
*pt
= SCM_PTAB_ENTRY (object
);
975 scm_ptobfuns
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
978 scm_misc_error (s_lseek
, "port is not seekable",
979 scm_cons (object
, SCM_EOL
));
982 if (pt
->rw_active
== SCM_PORT_READ
)
983 scm_read_flush (object
);
984 else if (pt
->rw_active
== SCM_PORT_WRITE
)
985 ptob
->fflush (object
);
987 rv
= ptob
->seek (object
, off
, how
);
990 else /* file descriptor?. */
992 SCM_ASSERT (SCM_INUMP (object
), object
, SCM_ARG1
, s_lseek
);
993 rv
= lseek (SCM_INUM (object
), off
, how
);
995 scm_syserror (s_lseek
);
997 return scm_long2num (rv
);
1000 SCM_PROC (s_ftruncate
, "ftruncate", 1, 1, 0, scm_ftruncate
);
1003 scm_ftruncate (SCM port
, SCM length
)
1008 port
= SCM_COERCE_OUTPORT (port
);
1009 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
), port
, SCM_ARG1
,
1011 pt
= SCM_PTAB_ENTRY (port
);
1012 ptob
= scm_ptobs
+ SCM_PTOBNUM (port
);
1013 if (!ptob
->ftruncate
)
1014 scm_misc_error (s_ftruncate
, "port is not truncatable",
1015 scm_cons (port
, SCM_EOL
));
1016 if (SCM_UNBNDP (length
))
1018 length
= scm_lseek (port
, SCM_INUM0
, SCM_MAKINUM (SEEK_CUR
));
1020 if (pt
->rw_active
== SCM_PORT_READ
)
1021 scm_read_flush (port
);
1022 else if (pt
->rw_active
== SCM_PORT_WRITE
)
1023 ptob
->fflush (port
);
1026 off_t c_length
= scm_num2long (length
, (char *)SCM_ARG2
, s_ftruncate
);
1029 scm_misc_error (s_ftruncate
, "negative offset",
1030 scm_cons (length
, SCM_EOL
));
1032 ptob
->ftruncate (port
, c_length
);
1034 return SCM_UNSPECIFIED
;
1037 SCM_PROC (s_port_line
, "port-line", 1, 0, 0, scm_port_line
);
1040 scm_port_line (port
)
1043 port
= SCM_COERCE_OUTPORT (port
);
1044 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1048 return SCM_MAKINUM (SCM_LINUM (port
));
1051 SCM_PROC (s_set_port_line_x
, "set-port-line!", 2, 0, 0, scm_set_port_line_x
);
1054 scm_set_port_line_x (port
, line
)
1058 port
= SCM_COERCE_OUTPORT (port
);
1059 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1063 SCM_ASSERT (SCM_INUMP (line
), line
, SCM_ARG2
, s_set_port_line_x
);
1064 return SCM_PTAB_ENTRY (port
)->line_number
= SCM_INUM (line
);
1067 SCM_PROC (s_port_column
, "port-column", 1, 0, 0, scm_port_column
);
1070 scm_port_column (port
)
1073 port
= SCM_COERCE_OUTPORT (port
);
1074 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1078 return SCM_MAKINUM (SCM_COL (port
));
1081 SCM_PROC (s_set_port_column_x
, "set-port-column!", 2, 0, 0, scm_set_port_column_x
);
1084 scm_set_port_column_x (port
, column
)
1088 port
= SCM_COERCE_OUTPORT (port
);
1089 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1092 s_set_port_column_x
);
1093 SCM_ASSERT (SCM_INUMP (column
), column
, SCM_ARG2
, s_set_port_column_x
);
1094 return SCM_PTAB_ENTRY (port
)->column_number
= SCM_INUM (column
);
1097 SCM_PROC (s_port_filename
, "port-filename", 1, 0, 0, scm_port_filename
);
1100 scm_port_filename (port
)
1103 port
= SCM_COERCE_OUTPORT (port
);
1104 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1108 return SCM_PTAB_ENTRY (port
)->file_name
;
1111 SCM_PROC (s_set_port_filename_x
, "set-port-filename!", 2, 0, 0, scm_set_port_filename_x
);
1114 scm_set_port_filename_x (port
, filename
)
1118 port
= SCM_COERCE_OUTPORT (port
);
1119 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1122 s_set_port_filename_x
);
1123 /* We allow the user to set the filename to whatever he likes. */
1124 return SCM_PTAB_ENTRY (port
)->file_name
= filename
;
1128 extern char * ttyname();
1133 scm_prinport (exp
, port
, type
)
1138 scm_puts ("#<", port
);
1139 if (SCM_CLOSEDP (exp
))
1140 scm_puts ("closed: ", port
);
1143 if (SCM_RDNG
& SCM_CAR (exp
))
1144 scm_puts ("input: ", port
);
1145 if (SCM_WRTNG
& SCM_CAR (exp
))
1146 scm_puts ("output: ", port
);
1148 scm_puts (type
, port
);
1149 scm_putc (' ', port
);
1150 if (SCM_OPFPORTP (exp
))
1152 int fdes
= (SCM_FSTREAM (exp
))->fdes
;
1155 scm_puts (ttyname (fdes
), port
);
1157 scm_intprint (fdes
, 10, port
);
1161 scm_intprint (SCM_CDR (exp
), 16, port
);
1163 scm_putc ('>', port
);
1168 scm_ports_prehistory ()
1171 scm_ptobs
= (scm_ptobfuns
*) malloc (sizeof (scm_ptobfuns
));
1173 /* WARNING: These scm_newptob calls must be done in this order.
1174 * They must agree with the port declarations in tags.h.
1176 /* scm_tc16_fport = */ scm_newptob (&scm_fptob
);
1177 /* scm_tc16_pipe was here */ scm_newptob (&scm_fptob
); /* dummy. */
1178 /* scm_tc16_strport = */ scm_newptob (&scm_stptob
);
1179 /* scm_tc16_sfport = */ scm_newptob (&scm_sfptob
);
1186 int scm_tc16_void_port
= 0;
1189 print_void_port (SCM exp
, SCM port
, scm_print_state
*pstate
)
1191 scm_prinport (exp
, port
, "void");
1196 flush_void_port (SCM port
)
1201 read_flush_void_port (SCM port
, int offset
)
1206 close_void_port (SCM port
)
1208 return 0; /* this is ignored by scm_close_port. */
1220 static struct scm_ptobfuns void_port_ptob
=
1227 read_flush_void_port
,
1236 scm_void_port (mode_str
)
1243 SCM_NEWCELL (answer
);
1245 mode_bits
= scm_mode_bits (mode_str
);
1246 pt
= scm_add_to_port_table (answer
);
1247 SCM_SETPTAB_ENTRY (answer
, pt
);
1248 SCM_SETSTREAM (answer
, 0);
1249 SCM_SETCAR (answer
, scm_tc16_void_port
| mode_bits
);
1255 SCM_PROC (s_sys_make_void_port
, "%make-void-port", 1, 0, 0, scm_sys_make_void_port
);
1258 scm_sys_make_void_port (mode
)
1261 SCM_ASSERT (SCM_NIMP (mode
) && SCM_ROSTRINGP (mode
), mode
,
1262 SCM_ARG1
, s_sys_make_void_port
);
1264 SCM_COERCE_SUBSTR (mode
);
1265 return scm_void_port (SCM_ROCHARS (mode
));
1269 /* Initialization. */
1274 /* lseek() symbols. */
1275 scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET
));
1276 scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR
));
1277 scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END
));
1279 scm_tc16_void_port
= scm_newptob (&void_port_ptob
);