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
--;
337 /* Undocumented functions for debugging. */
338 /* Return the number of ports in the table. */
340 SCM_PROC(s_pt_size
, "pt-size", 0, 0, 0, scm_pt_size
);
344 return SCM_MAKINUM (scm_port_table_size
);
347 /* Return the ith member of the port table. */
348 SCM_PROC(s_pt_member
, "pt-member", 1, 0, 0, scm_pt_member
);
350 scm_pt_member (member
)
354 SCM_ASSERT (SCM_INUMP (member
), member
, SCM_ARG1
, s_pt_member
);
355 i
= SCM_INUM (member
);
356 if (i
< 0 || i
>= scm_port_table_size
)
359 return scm_port_table
[i
]->port
;
365 /* Revealed counts --- an oddity inherited from SCSH. */
367 /* Find a port in the table and return its revealed count.
368 Also used by the garbage collector.
372 scm_revealed_count (port
)
375 return SCM_REVEALED(port
);
380 /* Return the revealed count for a port. */
382 SCM_PROC(s_port_revealed
, "port-revealed", 1, 0, 0, scm_port_revealed
);
385 scm_port_revealed (port
)
388 port
= SCM_COERCE_OUTPORT (port
);
389 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
), port
, SCM_ARG1
, s_port_revealed
);
390 return SCM_MAKINUM (scm_revealed_count (port
));
393 /* Set the revealed count for a port. */
394 SCM_PROC(s_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x
);
397 scm_set_port_revealed_x (port
, rcount
)
401 port
= SCM_COERCE_OUTPORT (port
);
402 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
), port
, SCM_ARG1
, s_set_port_revealed_x
);
403 SCM_ASSERT (SCM_INUMP (rcount
), rcount
, SCM_ARG2
, s_set_port_revealed_x
);
404 SCM_REVEALED (port
) = SCM_INUM (rcount
);
405 return SCM_UNSPECIFIED
;
410 /* Retrieving a port's mode. */
412 /* Return the flags that characterize a port based on the mode
413 * string used to open a file for that port.
415 * See PORT FLAGS in scm.h
419 scm_mode_bits (modes
)
423 | (strchr (modes
, 'r') || strchr (modes
, '+') ? SCM_RDNG
: 0)
424 | ( strchr (modes
, 'w')
425 || strchr (modes
, 'a')
426 || strchr (modes
, '+') ? SCM_WRTNG
: 0)
427 | (strchr (modes
, '0') ? SCM_BUF0
: 0)
428 | (strchr (modes
, 'l') ? SCM_BUFLINE
: 0));
432 /* Return the mode flags from an open port.
433 * Some modes such as "append" are only used when opening
434 * a file and are not returned here. */
436 SCM_PROC(s_port_mode
, "port-mode", 1, 0, 0, scm_port_mode
);
445 port
= SCM_COERCE_OUTPORT (port
);
446 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPPORTP (port
), port
, SCM_ARG1
, s_port_mode
);
447 if (SCM_CAR (port
) & SCM_RDNG
) {
448 if (SCM_CAR (port
) & SCM_WRTNG
)
449 strcpy (modes
, "r+");
453 else if (SCM_CAR (port
) & SCM_WRTNG
)
455 if (SCM_CAR (port
) & SCM_BUF0
)
457 return scm_makfromstr (modes
, strlen (modes
), 0);
465 * Call the close operation on a port object.
466 * see also scm_close.
468 SCM_PROC(s_close_port
, "close-port", 1, 0, 0, scm_close_port
);
471 scm_close_port (port
)
477 port
= SCM_COERCE_OUTPORT (port
);
479 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
), port
, SCM_ARG1
,
481 if (SCM_CLOSEDP (port
))
483 i
= SCM_PTOBNUM (port
);
484 if (scm_ptobs
[i
].fclose
)
485 rv
= (scm_ptobs
[i
].fclose
) (port
);
488 scm_remove_from_port_table (port
);
489 SCM_SETAND_CAR (port
, ~SCM_OPN
);
490 return (rv
< 0) ? SCM_BOOL_F
: SCM_BOOL_T
;
493 SCM_PROC(s_close_all_ports_except
, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except
);
496 scm_close_all_ports_except (ports
)
500 SCM_ASSERT (SCM_NIMP (ports
) && SCM_CONSP (ports
), ports
, SCM_ARG1
, s_close_all_ports_except
);
501 while (i
< scm_port_table_size
)
503 SCM thisport
= scm_port_table
[i
]->port
;
505 SCM ports_ptr
= ports
;
507 while (SCM_NNULLP (ports_ptr
))
509 SCM port
= SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr
));
511 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPPORTP (port
), port
, SCM_ARG1
, s_close_all_ports_except
);
512 if (port
== thisport
)
514 ports_ptr
= SCM_CDR (ports_ptr
);
519 /* i is not to be incremented here. */
520 scm_close_port (thisport
);
522 return SCM_UNSPECIFIED
;
527 /* Utter miscellany. Gosh, we should clean this up some time. */
529 SCM_PROC(s_input_port_p
, "input-port?", 1, 0, 0, scm_input_port_p
);
537 return SCM_INPORTP (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
540 SCM_PROC(s_output_port_p
, "output-port?", 1, 0, 0, scm_output_port_p
);
543 scm_output_port_p (x
)
548 return SCM_OUTPORTP (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
552 SCM_PROC(s_eof_object_p
, "eof-object?", 1, 0, 0, scm_eof_object_p
);
558 return SCM_EOF_OBJECT_P (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
561 SCM_PROC(s_force_output
, "force-output", 0, 1, 0, scm_force_output
);
564 scm_force_output (port
)
567 if (SCM_UNBNDP (port
))
571 port
= SCM_COERCE_OUTPORT (port
);
572 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
), port
, SCM_ARG1
,
576 return SCM_UNSPECIFIED
;
579 SCM_PROC (s_flush_all_ports
, "flush-all-ports", 0, 0, 0, scm_flush_all_ports
);
581 scm_flush_all_ports (void)
585 for (i
= 0; i
< scm_port_table_size
; i
++)
587 if (SCM_OPOUTPORTP (scm_port_table
[i
]->port
))
588 scm_fflush (scm_port_table
[i
]->port
);
590 return SCM_UNSPECIFIED
;
593 SCM_PROC(s_read_char
, "read-char", 0, 1, 0, scm_read_char
);
600 if (SCM_UNBNDP (port
))
603 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
, s_read_char
);
607 return SCM_MAKICHR (c
);
610 /* this should only be called when the read buffer is empty. it
611 tries to refill the buffer. it returns the first char from
612 the port, which is either EOF or *(pt->read_pos). */
614 scm_fill_buffer (SCM port
)
616 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
618 if (pt
->read_buf
== pt
->putback_buf
)
620 /* finished reading put-back chars. */
621 pt
->read_buf
= pt
->saved_read_buf
;
622 pt
->read_pos
= pt
->saved_read_pos
;
623 pt
->read_end
= pt
->saved_read_end
;
624 pt
->read_buf_size
= pt
->saved_read_buf_size
;
625 if (pt
->read_pos
< pt
->read_end
)
626 return *(pt
->read_pos
);
628 return scm_ptobs
[SCM_PTOBNUM (port
)].fill_buffer (port
);
636 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
638 if (pt
->rw_active
== SCM_PORT_WRITE
)
640 /* may be marginally faster than calling scm_fflush. */
641 scm_ptobs
[SCM_PTOBNUM (port
)].fflush (port
);
645 pt
->rw_active
= SCM_PORT_READ
;
647 if (pt
->read_pos
>= pt
->read_end
)
649 if (scm_fill_buffer (port
) == EOF
)
653 c
= *(pt
->read_pos
++);
676 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
677 scm_ptobfuns
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
679 if (pt
->rw_active
== SCM_PORT_READ
)
680 scm_read_flush (port
);
682 *(pt
->write_pos
++) = (char) c
;
684 if (pt
->write_pos
== pt
->write_end
)
688 pt
->rw_active
= SCM_PORT_WRITE
;
696 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
697 scm_ptobfuns
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
699 if (pt
->rw_active
== SCM_PORT_READ
)
700 scm_read_flush (port
);
704 *pt
->write_pos
++ = *s
++;
705 if (pt
->write_pos
== pt
->write_end
)
708 /* If the port is line-buffered, flush it. */
709 if ((SCM_CAR (port
) & SCM_BUFLINE
)
710 && memchr (pt
->write_buf
, '\n', pt
->write_pos
- pt
->write_buf
))
714 pt
->rw_active
= SCM_PORT_WRITE
;
718 scm_lfwrite (ptr
, size
, port
)
723 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
724 scm_ptobfuns
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
726 if (pt
->rw_active
== SCM_PORT_READ
)
727 scm_read_flush (port
);
731 int space
= pt
->write_end
- pt
->write_pos
;
732 int write_len
= (size
> space
) ? space
: size
;
734 strncpy (pt
->write_pos
, ptr
, write_len
);
735 pt
->write_pos
+= write_len
;
738 if (write_len
== space
)
741 /* If the port is line-buffered, flush it. */
742 if ((SCM_CAR (port
) & SCM_BUFLINE
)
743 && memchr (pt
->write_buf
, '\n', pt
->write_pos
- pt
->write_buf
))
744 (ptob
->fflush
) (port
);
747 pt
->rw_active
= SCM_PORT_WRITE
;
755 scm_sizet i
= SCM_PTOBNUM (port
);
756 (scm_ptobs
[i
].fflush
) (port
);
760 scm_read_flush (port
)
764 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
766 if (pt
->read_buf
== pt
->putback_buf
)
768 offset
= pt
->read_end
- pt
->read_pos
;
769 pt
->read_buf
= pt
->saved_read_buf
;
770 pt
->read_pos
= pt
->saved_read_pos
;
771 pt
->read_end
= pt
->saved_read_end
;
772 pt
->read_buf_size
= pt
->saved_read_buf_size
;
777 scm_ptobs
[SCM_PTOBNUM (port
)].read_flush (port
, offset
);
788 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
790 if (pt
->read_buf
== pt
->putback_buf
)
791 /* already using the put-back buffer. */
793 /* enlarge putback_buf if necessary. */
794 if (pt
->read_end
== pt
->read_buf
+ pt
->read_buf_size
795 && pt
->read_buf
== pt
->read_pos
)
797 int new_size
= pt
->read_buf_size
* 2;
799 (unsigned char *) realloc (pt
->putback_buf
, new_size
);
802 scm_memory_error ("scm_ungetc");
803 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
= tmp
;
804 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
805 pt
->read_buf_size
= pt
->putback_buf_size
= new_size
;
808 /* shift any existing bytes to buffer + 1. */
809 if (pt
->read_pos
== pt
->read_end
)
810 pt
->read_end
= pt
->read_buf
+ 1;
811 else if (pt
->read_pos
!= pt
->read_buf
+ 1)
813 int count
= pt
->read_end
- pt
->read_pos
;
815 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
816 pt
->read_end
= pt
->read_buf
+ 1 + count
;
819 pt
->read_pos
= pt
->read_buf
;
822 /* switch to the put-back buffer. */
824 if (pt
->putback_buf
== NULL
)
826 pt
->putback_buf
= (char *) malloc (pt
->putback_buf_size
);
827 if (pt
->putback_buf
== NULL
)
828 scm_memory_error ("scm_ungetc");
829 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
832 pt
->saved_read_buf
= pt
->read_buf
;
833 pt
->saved_read_pos
= pt
->read_pos
;
834 pt
->saved_read_end
= pt
->read_end
;
835 pt
->saved_read_buf_size
= pt
->read_buf_size
;
837 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
838 pt
->read_end
= pt
->read_buf
+ 1;
839 pt
->read_buf_size
= pt
->putback_buf_size
;
845 pt
->rw_active
= SCM_PORT_READ
;
849 /* What should col be in this case?
850 * We'll leave it at -1.
852 SCM_LINUM (port
) -= 1;
860 scm_ungets (s
, n
, port
)
865 /* This is simple minded and inefficient, but unreading strings is
866 * probably not a common operation, and remember that line and
867 * column numbers have to be handled...
869 * Please feel free to write an optimized version!
872 scm_ungetc (s
[n
], port
);
876 SCM_PROC(s_peek_char
, "peek-char", 0, 1, 0, scm_peek_char
);
883 if (SCM_UNBNDP (port
))
886 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
, s_peek_char
);
890 scm_ungetc (c
, port
);
891 return SCM_MAKICHR (c
);
894 SCM_PROC (s_unread_char
, "unread-char", 2, 0, 0, scm_unread_char
);
897 scm_unread_char (cobj
, port
)
903 SCM_ASSERT (SCM_ICHRP (cobj
), cobj
, SCM_ARG1
, s_unread_char
);
905 if (SCM_UNBNDP (port
))
908 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG2
, s_unread_char
);
913 scm_ungetc (c
, port
);
917 SCM_PROC (s_unread_string
, "unread-string", 2, 0, 0, scm_unread_string
);
920 scm_unread_string (str
, port
)
924 SCM_ASSERT (SCM_NIMP (str
) && SCM_STRINGP (str
),
925 str
, SCM_ARG1
, s_unread_string
);
927 if (SCM_UNBNDP (port
))
930 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
),
931 port
, SCM_ARG2
, s_unread_string
);
933 scm_ungets (SCM_ROUCHARS (str
), SCM_LENGTH (str
), port
);
938 SCM_PROC (s_lseek
, "lseek", 3, 0, 0, scm_lseek
);
940 scm_lseek (SCM object
, SCM offset
, SCM whence
)
946 object
= SCM_COERCE_OUTPORT (object
);
948 off
= scm_num2long (offset
, (char *)SCM_ARG2
, s_lseek
);
949 SCM_ASSERT (SCM_INUMP (whence
), whence
, SCM_ARG3
, s_lseek
);
950 how
= SCM_INUM (whence
);
951 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
952 scm_out_of_range (s_lseek
, whence
);
953 if (SCM_NIMP (object
) && SCM_OPPORTP (object
))
955 scm_port
*pt
= SCM_PTAB_ENTRY (object
);
956 scm_ptobfuns
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
959 scm_misc_error (s_lseek
, "port is not seekable",
960 scm_cons (object
, SCM_EOL
));
963 if (pt
->rw_active
== SCM_PORT_READ
)
964 scm_read_flush (object
);
965 else if (pt
->rw_active
== SCM_PORT_WRITE
)
966 ptob
->fflush (object
);
968 rv
= ptob
->seek (object
, off
, how
);
971 else /* file descriptor?. */
973 SCM_ASSERT (SCM_INUMP (object
), object
, SCM_ARG1
, s_lseek
);
974 rv
= lseek (SCM_INUM (object
), off
, how
);
976 scm_syserror (s_lseek
);
978 return scm_long2num (rv
);
981 SCM_PROC (s_truncate_file
, "truncate-file", 1, 1, 0, scm_truncate_file
);
984 scm_truncate_file (SCM object
, SCM length
)
989 /* object can be a port, fdes or filename. */
991 if (SCM_UNBNDP (length
))
993 /* must supply length if object is a filename. */
994 if (SCM_NIMP (object
) && SCM_ROSTRINGP (object
))
995 scm_wrong_num_args (scm_makfrom0str (s_truncate_file
));
997 length
= scm_lseek (object
, SCM_INUM0
, SCM_MAKINUM (SEEK_CUR
));
999 c_length
= scm_num2long (length
, (char *)SCM_ARG2
, s_truncate_file
);
1001 scm_misc_error (s_truncate_file
, "negative offset", SCM_EOL
);
1003 object
= SCM_COERCE_OUTPORT (object
);
1004 if (SCM_INUMP (object
))
1006 SCM_SYSCALL (rv
= ftruncate (SCM_INUM (object
), c_length
));
1008 else if (SCM_NIMP (object
) && SCM_OPOUTPORTP (object
))
1010 scm_port
*pt
= SCM_PTAB_ENTRY (object
);
1011 scm_ptobfuns
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1013 if (!ptob
->ftruncate
)
1014 scm_misc_error (s_truncate_file
, "port is not truncatable", SCM_EOL
);
1015 if (pt
->rw_active
== SCM_PORT_READ
)
1016 scm_read_flush (object
);
1017 else if (pt
->rw_active
== SCM_PORT_WRITE
)
1018 ptob
->fflush (object
);
1020 ptob
->ftruncate (object
, c_length
);
1025 SCM_ASSERT (SCM_NIMP (object
) && SCM_ROSTRINGP (object
),
1026 object
, SCM_ARG1
, s_truncate_file
);
1027 SCM_COERCE_SUBSTR (object
);
1028 SCM_SYSCALL (rv
= truncate (SCM_ROCHARS (object
), c_length
));
1031 scm_syserror (s_truncate_file
);
1032 return SCM_UNSPECIFIED
;
1035 SCM_PROC (s_port_line
, "port-line", 1, 0, 0, scm_port_line
);
1038 scm_port_line (port
)
1041 port
= SCM_COERCE_OUTPORT (port
);
1042 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1046 return SCM_MAKINUM (SCM_LINUM (port
));
1049 SCM_PROC (s_set_port_line_x
, "set-port-line!", 2, 0, 0, scm_set_port_line_x
);
1052 scm_set_port_line_x (port
, line
)
1056 port
= SCM_COERCE_OUTPORT (port
);
1057 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1061 SCM_ASSERT (SCM_INUMP (line
), line
, SCM_ARG2
, s_set_port_line_x
);
1062 return SCM_PTAB_ENTRY (port
)->line_number
= SCM_INUM (line
);
1065 SCM_PROC (s_port_column
, "port-column", 1, 0, 0, scm_port_column
);
1068 scm_port_column (port
)
1071 port
= SCM_COERCE_OUTPORT (port
);
1072 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1076 return SCM_MAKINUM (SCM_COL (port
));
1079 SCM_PROC (s_set_port_column_x
, "set-port-column!", 2, 0, 0, scm_set_port_column_x
);
1082 scm_set_port_column_x (port
, column
)
1086 port
= SCM_COERCE_OUTPORT (port
);
1087 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1090 s_set_port_column_x
);
1091 SCM_ASSERT (SCM_INUMP (column
), column
, SCM_ARG2
, s_set_port_column_x
);
1092 return SCM_PTAB_ENTRY (port
)->column_number
= SCM_INUM (column
);
1095 SCM_PROC (s_port_filename
, "port-filename", 1, 0, 0, scm_port_filename
);
1098 scm_port_filename (port
)
1101 port
= SCM_COERCE_OUTPORT (port
);
1102 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1106 return SCM_PTAB_ENTRY (port
)->file_name
;
1109 SCM_PROC (s_set_port_filename_x
, "set-port-filename!", 2, 0, 0, scm_set_port_filename_x
);
1112 scm_set_port_filename_x (port
, filename
)
1116 port
= SCM_COERCE_OUTPORT (port
);
1117 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1120 s_set_port_filename_x
);
1121 /* We allow the user to set the filename to whatever he likes. */
1122 return SCM_PTAB_ENTRY (port
)->file_name
= filename
;
1126 extern char * ttyname();
1131 scm_prinport (exp
, port
, type
)
1136 scm_puts ("#<", port
);
1137 if (SCM_CLOSEDP (exp
))
1138 scm_puts ("closed: ", port
);
1141 if (SCM_RDNG
& SCM_CAR (exp
))
1142 scm_puts ("input: ", port
);
1143 if (SCM_WRTNG
& SCM_CAR (exp
))
1144 scm_puts ("output: ", port
);
1146 scm_puts (type
, port
);
1147 scm_putc (' ', port
);
1148 if (SCM_OPFPORTP (exp
))
1150 int fdes
= (SCM_FSTREAM (exp
))->fdes
;
1153 scm_puts (ttyname (fdes
), port
);
1155 scm_intprint (fdes
, 10, port
);
1159 scm_intprint (SCM_CDR (exp
), 16, port
);
1161 scm_putc ('>', port
);
1166 scm_ports_prehistory ()
1169 scm_ptobs
= (scm_ptobfuns
*) malloc (sizeof (scm_ptobfuns
));
1171 /* WARNING: These scm_newptob calls must be done in this order.
1172 * They must agree with the port declarations in tags.h.
1174 /* scm_tc16_fport = */ scm_newptob (&scm_fptob
);
1175 /* scm_tc16_pipe was here */ scm_newptob (&scm_fptob
); /* dummy. */
1176 /* scm_tc16_strport = */ scm_newptob (&scm_stptob
);
1177 /* scm_tc16_sfport = */ scm_newptob (&scm_sfptob
);
1184 int scm_tc16_void_port
= 0;
1187 print_void_port (SCM exp
, SCM port
, scm_print_state
*pstate
)
1189 scm_prinport (exp
, port
, "void");
1194 flush_void_port (SCM port
)
1199 read_flush_void_port (SCM port
, int offset
)
1204 close_void_port (SCM port
)
1206 return 0; /* this is ignored by scm_close_port. */
1218 static struct scm_ptobfuns void_port_ptob
=
1225 read_flush_void_port
,
1234 scm_void_port (mode_str
)
1241 SCM_NEWCELL (answer
);
1243 mode_bits
= scm_mode_bits (mode_str
);
1244 pt
= scm_add_to_port_table (answer
);
1245 SCM_SETPTAB_ENTRY (answer
, pt
);
1246 SCM_SETSTREAM (answer
, 0);
1247 SCM_SETCAR (answer
, scm_tc16_void_port
| mode_bits
);
1253 SCM_PROC (s_sys_make_void_port
, "%make-void-port", 1, 0, 0, scm_sys_make_void_port
);
1256 scm_sys_make_void_port (mode
)
1259 SCM_ASSERT (SCM_NIMP (mode
) && SCM_ROSTRINGP (mode
), mode
,
1260 SCM_ARG1
, s_sys_make_void_port
);
1262 SCM_COERCE_SUBSTR (mode
);
1263 return scm_void_port (SCM_ROCHARS (mode
));
1267 /* Initialization. */
1272 /* lseek() symbols. */
1273 scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET
));
1274 scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR
));
1275 scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END
));
1277 scm_tc16_void_port
= scm_newptob (&void_port_ptob
);