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. */
62 #ifdef HAVE_SYS_IOCTL_H
63 #include <sys/ioctl.h>
67 /* The port kind table --- a dynamically resized array of port types. */
70 /* scm_ptobs scm_numptob
71 * implement a dynamicly resized array of ptob records.
72 * Indexes into this table are used when generating type
73 * tags for smobjects (if you know a tag you can get an index and conversely).
75 scm_ptob_descriptor
*scm_ptobs
;
78 /* GC marker for a port with stream of SCM type. */
84 openp
= SCM_CAR (ptr
) & SCM_OPN
;
86 return SCM_STREAM (ptr
);
92 * We choose to use an interface similar to the smob interface with
93 * fill_input and write as standard fields, passed to the port
94 * type constructor, and optional fields set by setters.
97 static void flush_void_port (SCM port
);
98 static void end_input_void_port (SCM port
, int offset
);
99 static void write_void_port (SCM port
, void *data
, size_t size
);
102 scm_make_port_type (char *name
,
103 int (*fill_input
) (SCM port
),
104 void (*write
) (SCM port
, void *data
, size_t size
))
107 if (255 <= scm_numptob
)
110 SCM_SYSCALL (tmp
= (char *) realloc ((char *) scm_ptobs
,
112 * sizeof (scm_ptob_descriptor
)));
115 scm_ptobs
= (scm_ptob_descriptor
*) tmp
;
117 scm_ptobs
[scm_numptob
].name
= name
;
118 scm_ptobs
[scm_numptob
].mark
= 0;
119 scm_ptobs
[scm_numptob
].free
= scm_free0
;
120 scm_ptobs
[scm_numptob
].print
= scm_port_print
;
121 scm_ptobs
[scm_numptob
].equalp
= 0;
122 scm_ptobs
[scm_numptob
].close
= 0;
124 scm_ptobs
[scm_numptob
].write
= write
;
125 scm_ptobs
[scm_numptob
].flush
= flush_void_port
;
127 scm_ptobs
[scm_numptob
].end_input
= end_input_void_port
;
128 scm_ptobs
[scm_numptob
].fill_input
= fill_input
;
129 scm_ptobs
[scm_numptob
].input_waiting
= 0;
131 scm_ptobs
[scm_numptob
].seek
= 0;
132 scm_ptobs
[scm_numptob
].truncate
= 0;
138 ptoberr
:scm_wta (SCM_MAKINUM ((long) scm_numptob
),
139 (char *) SCM_NALLOC
, "scm_make_port_type");
140 /* Make a class object if Goops is present */
142 scm_make_port_classes (scm_numptob
- 1, SCM_PTOBNAME (scm_numptob
- 1));
143 return scm_tc7_port
+ (scm_numptob
- 1) * 256;
147 scm_set_port_mark (long tc
, SCM (*mark
) (SCM
))
149 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].mark
= mark
;
153 scm_set_port_free (long tc
, scm_sizet (*free
) (SCM
))
155 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].free
= free
;
159 scm_set_port_print (long tc
, int (*print
) (SCM exp
, SCM port
,
160 scm_print_state
*pstate
))
162 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].print
= print
;
166 scm_set_port_equalp (long tc
, SCM (*equalp
) (SCM
, SCM
))
168 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].equalp
= equalp
;
172 scm_set_port_flush (long tc
, void (*flush
) (SCM port
))
174 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].flush
= flush
;
178 scm_set_port_end_input (long tc
, void (*end_input
) (SCM port
, int offset
))
180 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].end_input
= end_input
;
184 scm_set_port_close (long tc
, int (*close
) (SCM
))
186 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].close
= close
;
190 scm_set_port_seek (long tc
, off_t (*seek
) (SCM port
,
194 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].seek
= seek
;
198 scm_set_port_truncate (long tc
, void (*truncate
) (SCM port
, off_t length
))
200 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].truncate
= truncate
;
204 scm_set_port_input_waiting (long tc
, int (*input_waiting
) (SCM
))
206 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].input_waiting
= input_waiting
;
211 SCM_PROC(s_char_ready_p
, "char-ready?", 0, 1, 0, scm_char_ready_p
);
214 scm_char_ready_p (port
)
219 if (SCM_UNBNDP (port
))
222 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
,
225 pt
= SCM_PTAB_ENTRY (port
);
227 /* if the current read buffer is filled, or the
228 last pushed-back char has been read and the saved buffer is
229 filled, result is true. */
230 if (pt
->read_pos
< pt
->read_end
231 || (pt
->read_buf
== pt
->putback_buf
232 && pt
->saved_read_pos
< pt
->saved_read_end
))
236 scm_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
238 if (ptob
->input_waiting
)
239 return (ptob
->input_waiting (port
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
245 /* Clear a port's read buffers, returning the contents. */
246 SCM_PROC (s_drain_input
, "drain-input", 1, 0, 0, scm_drain_input
);
248 scm_drain_input (SCM port
)
251 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
255 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
,
258 count
= pt
->read_end
- pt
->read_pos
;
259 if (pt
->read_buf
== pt
->putback_buf
)
260 count
+= pt
->saved_read_end
- pt
->saved_read_pos
;
262 result
= scm_makstr (count
, 0);
263 dst
= SCM_CHARS (result
);
265 while (pt
->read_pos
< pt
->read_end
)
266 *dst
++ = *(pt
->read_pos
++);
268 if (pt
->read_buf
== pt
->putback_buf
)
270 while (pt
->saved_read_pos
< pt
->saved_read_end
)
271 *dst
++ = *(pt
->saved_read_pos
++);
278 /* Standard ports --- current input, output, error, and more(!). */
280 SCM_PROC(s_current_input_port
, "current-input-port", 0, 0, 0, scm_current_input_port
);
283 scm_current_input_port ()
288 SCM_PROC(s_current_output_port
, "current-output-port", 0, 0, 0, scm_current_output_port
);
291 scm_current_output_port ()
296 SCM_PROC(s_current_error_port
, "current-error-port", 0, 0, 0, scm_current_error_port
);
299 scm_current_error_port ()
304 SCM_PROC(s_current_load_port
, "current-load-port", 0, 0, 0, scm_current_load_port
);
307 scm_current_load_port ()
309 return scm_cur_loadp
;
312 SCM_PROC(s_set_current_input_port
, "set-current-input-port", 1, 0, 0, scm_set_current_input_port
);
315 scm_set_current_input_port (port
)
318 SCM oinp
= scm_cur_inp
;
319 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
, s_set_current_input_port
);
325 SCM_PROC(s_set_current_output_port
, "set-current-output-port", 1, 0, 0, scm_set_current_output_port
);
328 scm_set_current_output_port (port
)
331 SCM ooutp
= scm_cur_outp
;
332 port
= SCM_COERCE_OUTPORT (port
);
333 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
), port
, SCM_ARG1
, s_set_current_output_port
);
339 SCM_PROC(s_set_current_error_port
, "set-current-error-port", 1, 0, 0, scm_set_current_error_port
);
342 scm_set_current_error_port (port
)
345 SCM oerrp
= scm_cur_errp
;
346 port
= SCM_COERCE_OUTPORT (port
);
347 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
), port
, SCM_ARG1
, s_set_current_error_port
);
353 /* The port table --- an array of pointers to ports. */
355 scm_port
**scm_port_table
;
357 int scm_port_table_size
= 0; /* Number of ports in scm_port_table. */
358 int scm_port_table_room
= 20; /* Size of the array. */
360 /* Add a port to the table. */
363 scm_add_to_port_table (port
)
368 if (scm_port_table_size
== scm_port_table_room
)
370 void *newt
= realloc ((char *) scm_port_table
,
371 (scm_sizet
) (sizeof (scm_port
*)
372 * scm_port_table_room
* 2));
374 scm_memory_error ("scm_add_to_port_table");
375 scm_port_table
= (scm_port
**) newt
;
376 scm_port_table_room
*= 2;
378 entry
= (scm_port
*) malloc (sizeof (scm_port
));
380 scm_memory_error ("scm_add_to_port_table");
383 entry
->entry
= scm_port_table_size
;
386 entry
->file_name
= SCM_BOOL_F
;
387 entry
->line_number
= 0;
388 entry
->column_number
= 0;
389 entry
->putback_buf
= 0;
390 entry
->putback_buf_size
= 0;
391 entry
->rw_active
= SCM_PORT_NEITHER
;
393 scm_port_table
[scm_port_table_size
] = entry
;
394 scm_port_table_size
++;
399 /* Remove a port from the table and destroy it. */
402 scm_remove_from_port_table (port
)
405 scm_port
*p
= SCM_PTAB_ENTRY (port
);
408 if (i
>= scm_port_table_size
)
409 scm_wta (port
, "Port not in table", "scm_remove_from_port_table");
411 free (p
->putback_buf
);
413 /* Since we have just freed slot i we can shrink the table by moving
414 the last entry to that slot... */
415 if (i
< scm_port_table_size
- 1)
417 scm_port_table
[i
] = scm_port_table
[scm_port_table_size
- 1];
418 scm_port_table
[i
]->entry
= i
;
420 SCM_SETPTAB_ENTRY (port
, 0);
421 scm_port_table_size
--;
425 /* Undocumented functions for debugging. */
426 /* Return the number of ports in the table. */
428 SCM_PROC(s_pt_size
, "pt-size", 0, 0, 0, scm_pt_size
);
432 return SCM_MAKINUM (scm_port_table_size
);
435 /* Return the ith member of the port table. */
436 SCM_PROC(s_pt_member
, "pt-member", 1, 0, 0, scm_pt_member
);
438 scm_pt_member (member
)
442 SCM_ASSERT (SCM_INUMP (member
), member
, SCM_ARG1
, s_pt_member
);
443 i
= SCM_INUM (member
);
444 if (i
< 0 || i
>= scm_port_table_size
)
447 return scm_port_table
[i
]->port
;
453 /* Revealed counts --- an oddity inherited from SCSH. */
455 /* Find a port in the table and return its revealed count.
456 Also used by the garbage collector.
460 scm_revealed_count (port
)
463 return SCM_REVEALED(port
);
468 /* Return the revealed count for a port. */
470 SCM_PROC(s_port_revealed
, "port-revealed", 1, 0, 0, scm_port_revealed
);
473 scm_port_revealed (port
)
476 port
= SCM_COERCE_OUTPORT (port
);
477 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
), port
, SCM_ARG1
, s_port_revealed
);
478 return SCM_MAKINUM (scm_revealed_count (port
));
481 /* Set the revealed count for a port. */
482 SCM_PROC(s_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x
);
485 scm_set_port_revealed_x (port
, rcount
)
489 port
= SCM_COERCE_OUTPORT (port
);
490 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
), port
, SCM_ARG1
, s_set_port_revealed_x
);
491 SCM_ASSERT (SCM_INUMP (rcount
), rcount
, SCM_ARG2
, s_set_port_revealed_x
);
492 SCM_REVEALED (port
) = SCM_INUM (rcount
);
493 return SCM_UNSPECIFIED
;
498 /* Retrieving a port's mode. */
500 /* Return the flags that characterize a port based on the mode
501 * string used to open a file for that port.
503 * See PORT FLAGS in scm.h
507 scm_mode_bits (modes
)
511 | (strchr (modes
, 'r') || strchr (modes
, '+') ? SCM_RDNG
: 0)
512 | ( strchr (modes
, 'w')
513 || strchr (modes
, 'a')
514 || strchr (modes
, '+') ? SCM_WRTNG
: 0)
515 | (strchr (modes
, '0') ? SCM_BUF0
: 0)
516 | (strchr (modes
, 'l') ? SCM_BUFLINE
: 0));
520 /* Return the mode flags from an open port.
521 * Some modes such as "append" are only used when opening
522 * a file and are not returned here. */
524 SCM_PROC(s_port_mode
, "port-mode", 1, 0, 0, scm_port_mode
);
533 port
= SCM_COERCE_OUTPORT (port
);
534 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPPORTP (port
), port
, SCM_ARG1
, s_port_mode
);
535 if (SCM_CAR (port
) & SCM_RDNG
) {
536 if (SCM_CAR (port
) & SCM_WRTNG
)
537 strcpy (modes
, "r+");
541 else if (SCM_CAR (port
) & SCM_WRTNG
)
543 if (SCM_CAR (port
) & SCM_BUF0
)
545 return scm_makfromstr (modes
, strlen (modes
), 0);
553 * Call the close operation on a port object.
554 * see also scm_close.
556 SCM_PROC(s_close_port
, "close-port", 1, 0, 0, scm_close_port
);
559 scm_close_port (port
)
565 port
= SCM_COERCE_OUTPORT (port
);
567 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
), port
, SCM_ARG1
,
569 if (SCM_CLOSEDP (port
))
571 i
= SCM_PTOBNUM (port
);
572 if (scm_ptobs
[i
].close
)
573 rv
= (scm_ptobs
[i
].close
) (port
);
576 scm_remove_from_port_table (port
);
577 SCM_SETAND_CAR (port
, ~SCM_OPN
);
578 return (rv
< 0) ? SCM_BOOL_F
: SCM_BOOL_T
;
581 SCM_PROC(s_close_all_ports_except
, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except
);
584 scm_close_all_ports_except (ports
)
588 SCM_ASSERT (SCM_NIMP (ports
) && SCM_CONSP (ports
), ports
, SCM_ARG1
, s_close_all_ports_except
);
589 while (i
< scm_port_table_size
)
591 SCM thisport
= scm_port_table
[i
]->port
;
593 SCM ports_ptr
= ports
;
595 while (SCM_NNULLP (ports_ptr
))
597 SCM port
= SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr
));
599 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPPORTP (port
), port
, SCM_ARG1
, s_close_all_ports_except
);
600 if (port
== thisport
)
602 ports_ptr
= SCM_CDR (ports_ptr
);
607 /* i is not to be incremented here. */
608 scm_close_port (thisport
);
610 return SCM_UNSPECIFIED
;
615 /* Utter miscellany. Gosh, we should clean this up some time. */
617 SCM_PROC(s_input_port_p
, "input-port?", 1, 0, 0, scm_input_port_p
);
625 return SCM_INPORTP (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
628 SCM_PROC(s_output_port_p
, "output-port?", 1, 0, 0, scm_output_port_p
);
631 scm_output_port_p (x
)
636 if (SCM_PORT_WITH_PS_P (x
))
637 x
= SCM_PORT_WITH_PS_PORT (x
);
638 return SCM_OUTPORTP (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
642 SCM_PROC(s_eof_object_p
, "eof-object?", 1, 0, 0, scm_eof_object_p
);
648 return SCM_EOF_OBJECT_P (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
651 SCM_PROC(s_force_output
, "force-output", 0, 1, 0, scm_force_output
);
654 scm_force_output (port
)
657 if (SCM_UNBNDP (port
))
661 port
= SCM_COERCE_OUTPORT (port
);
662 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
), port
, SCM_ARG1
,
666 return SCM_UNSPECIFIED
;
669 SCM_PROC (s_flush_all_ports
, "flush-all-ports", 0, 0, 0, scm_flush_all_ports
);
671 scm_flush_all_ports (void)
675 for (i
= 0; i
< scm_port_table_size
; i
++)
677 if (SCM_OPOUTPORTP (scm_port_table
[i
]->port
))
678 scm_flush (scm_port_table
[i
]->port
);
680 return SCM_UNSPECIFIED
;
683 SCM_PROC(s_read_char
, "read-char", 0, 1, 0, scm_read_char
);
690 if (SCM_UNBNDP (port
))
693 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
, s_read_char
);
697 return SCM_MAKICHR (c
);
700 /* this should only be called when the read buffer is empty. it
701 tries to refill the read buffer. it returns the first char from
702 the port, which is either EOF or *(pt->read_pos). */
704 scm_fill_input (SCM port
)
706 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
708 if (pt
->read_buf
== pt
->putback_buf
)
710 /* finished reading put-back chars. */
711 pt
->read_buf
= pt
->saved_read_buf
;
712 pt
->read_pos
= pt
->saved_read_pos
;
713 pt
->read_end
= pt
->saved_read_end
;
714 pt
->read_buf_size
= pt
->saved_read_buf_size
;
715 if (pt
->read_pos
< pt
->read_end
)
716 return *(pt
->read_pos
);
718 return scm_ptobs
[SCM_PTOBNUM (port
)].fill_input (port
);
726 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
728 if (pt
->rw_active
== SCM_PORT_WRITE
)
730 /* may be marginally faster than calling scm_flush. */
731 scm_ptobs
[SCM_PTOBNUM (port
)].flush (port
);
735 pt
->rw_active
= SCM_PORT_READ
;
737 if (pt
->read_pos
>= pt
->read_end
)
739 if (scm_fill_input (port
) == EOF
)
743 c
= *(pt
->read_pos
++);
766 scm_lfwrite (&c
, 1, port
);
774 scm_lfwrite (s
, strlen (s
), port
);
778 scm_lfwrite (ptr
, size
, port
)
783 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
784 scm_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
786 if (pt
->rw_active
== SCM_PORT_READ
)
787 scm_end_input (port
);
789 ptob
->write (port
, ptr
, size
);
792 pt
->rw_active
= SCM_PORT_WRITE
;
800 scm_sizet i
= SCM_PTOBNUM (port
);
801 (scm_ptobs
[i
].flush
) (port
);
809 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
811 if (pt
->read_buf
== pt
->putback_buf
)
813 offset
= pt
->read_end
- pt
->read_pos
;
814 pt
->read_buf
= pt
->saved_read_buf
;
815 pt
->read_pos
= pt
->saved_read_pos
;
816 pt
->read_end
= pt
->saved_read_end
;
817 pt
->read_buf_size
= pt
->saved_read_buf_size
;
822 scm_ptobs
[SCM_PTOBNUM (port
)].end_input (port
, offset
);
833 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
835 if (pt
->read_buf
== pt
->putback_buf
)
836 /* already using the put-back buffer. */
838 /* enlarge putback_buf if necessary. */
839 if (pt
->read_end
== pt
->read_buf
+ pt
->read_buf_size
840 && pt
->read_buf
== pt
->read_pos
)
842 int new_size
= pt
->read_buf_size
* 2;
844 (unsigned char *) realloc (pt
->putback_buf
, new_size
);
847 scm_memory_error ("scm_ungetc");
848 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
= tmp
;
849 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
850 pt
->read_buf_size
= pt
->putback_buf_size
= new_size
;
853 /* shift any existing bytes to buffer + 1. */
854 if (pt
->read_pos
== pt
->read_end
)
855 pt
->read_end
= pt
->read_buf
+ 1;
856 else if (pt
->read_pos
!= pt
->read_buf
+ 1)
858 int count
= pt
->read_end
- pt
->read_pos
;
860 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
861 pt
->read_end
= pt
->read_buf
+ 1 + count
;
864 pt
->read_pos
= pt
->read_buf
;
867 /* switch to the put-back buffer. */
869 if (pt
->putback_buf
== NULL
)
871 pt
->putback_buf
= (char *) malloc (pt
->putback_buf_size
);
872 if (pt
->putback_buf
== NULL
)
873 scm_memory_error ("scm_ungetc");
874 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
877 pt
->saved_read_buf
= pt
->read_buf
;
878 pt
->saved_read_pos
= pt
->read_pos
;
879 pt
->saved_read_end
= pt
->read_end
;
880 pt
->saved_read_buf_size
= pt
->read_buf_size
;
882 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
883 pt
->read_end
= pt
->read_buf
+ 1;
884 pt
->read_buf_size
= pt
->putback_buf_size
;
890 pt
->rw_active
= SCM_PORT_READ
;
894 /* What should col be in this case?
895 * We'll leave it at -1.
897 SCM_LINUM (port
) -= 1;
905 scm_ungets (s
, n
, port
)
910 /* This is simple minded and inefficient, but unreading strings is
911 * probably not a common operation, and remember that line and
912 * column numbers have to be handled...
914 * Please feel free to write an optimized version!
917 scm_ungetc (s
[n
], port
);
921 SCM_PROC(s_peek_char
, "peek-char", 0, 1, 0, scm_peek_char
);
928 if (SCM_UNBNDP (port
))
931 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
, s_peek_char
);
935 scm_ungetc (c
, port
);
936 return SCM_MAKICHR (c
);
939 SCM_PROC (s_unread_char
, "unread-char", 2, 0, 0, scm_unread_char
);
942 scm_unread_char (cobj
, port
)
948 SCM_ASSERT (SCM_ICHRP (cobj
), cobj
, SCM_ARG1
, s_unread_char
);
950 if (SCM_UNBNDP (port
))
953 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG2
, s_unread_char
);
958 scm_ungetc (c
, port
);
962 SCM_PROC (s_unread_string
, "unread-string", 2, 0, 0, scm_unread_string
);
965 scm_unread_string (str
, port
)
969 SCM_ASSERT (SCM_NIMP (str
) && SCM_STRINGP (str
),
970 str
, SCM_ARG1
, s_unread_string
);
972 if (SCM_UNBNDP (port
))
975 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
),
976 port
, SCM_ARG2
, s_unread_string
);
978 scm_ungets (SCM_ROUCHARS (str
), SCM_LENGTH (str
), port
);
983 SCM_PROC (s_seek
, "seek", 3, 0, 0, scm_seek
);
985 scm_seek (SCM object
, SCM offset
, SCM whence
)
991 object
= SCM_COERCE_OUTPORT (object
);
993 off
= scm_num2long (offset
, (char *)SCM_ARG2
, s_seek
);
994 SCM_ASSERT (SCM_INUMP (whence
), whence
, SCM_ARG3
, s_seek
);
995 how
= SCM_INUM (whence
);
996 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
997 scm_out_of_range (s_seek
, whence
);
998 if (SCM_NIMP (object
) && SCM_OPPORTP (object
))
1000 scm_port
*pt
= SCM_PTAB_ENTRY (object
);
1001 scm_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1004 scm_misc_error (s_seek
, "port is not seekable",
1005 scm_cons (object
, SCM_EOL
));
1008 if (pt
->rw_active
== SCM_PORT_READ
)
1009 scm_end_input (object
);
1010 else if (pt
->rw_active
== SCM_PORT_WRITE
)
1011 ptob
->flush (object
);
1013 rv
= ptob
->seek (object
, off
, how
);
1016 else /* file descriptor?. */
1018 SCM_ASSERT (SCM_INUMP (object
), object
, SCM_ARG1
, s_seek
);
1019 rv
= lseek (SCM_INUM (object
), off
, how
);
1021 scm_syserror (s_seek
);
1023 return scm_long2num (rv
);
1026 SCM_PROC (s_truncate_file
, "truncate-file", 1, 1, 0, scm_truncate_file
);
1029 scm_truncate_file (SCM object
, SCM length
)
1034 /* object can be a port, fdes or filename. */
1036 if (SCM_UNBNDP (length
))
1038 /* must supply length if object is a filename. */
1039 if (SCM_NIMP (object
) && SCM_ROSTRINGP (object
))
1040 scm_wrong_num_args (scm_makfrom0str (s_truncate_file
));
1042 length
= scm_seek (object
, SCM_INUM0
, SCM_MAKINUM (SEEK_CUR
));
1044 c_length
= scm_num2long (length
, (char *)SCM_ARG2
, s_truncate_file
);
1046 scm_misc_error (s_truncate_file
, "negative offset", SCM_EOL
);
1048 object
= SCM_COERCE_OUTPORT (object
);
1049 if (SCM_INUMP (object
))
1051 SCM_SYSCALL (rv
= ftruncate (SCM_INUM (object
), c_length
));
1053 else if (SCM_NIMP (object
) && SCM_OPOUTPORTP (object
))
1055 scm_port
*pt
= SCM_PTAB_ENTRY (object
);
1056 scm_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1058 if (!ptob
->truncate
)
1059 scm_misc_error (s_truncate_file
, "port is not truncatable", SCM_EOL
);
1060 if (pt
->rw_active
== SCM_PORT_READ
)
1061 scm_end_input (object
);
1062 else if (pt
->rw_active
== SCM_PORT_WRITE
)
1063 ptob
->flush (object
);
1065 ptob
->truncate (object
, c_length
);
1070 SCM_ASSERT (SCM_NIMP (object
) && SCM_ROSTRINGP (object
),
1071 object
, SCM_ARG1
, s_truncate_file
);
1072 SCM_COERCE_SUBSTR (object
);
1073 SCM_SYSCALL (rv
= truncate (SCM_ROCHARS (object
), c_length
));
1076 scm_syserror (s_truncate_file
);
1077 return SCM_UNSPECIFIED
;
1080 SCM_PROC (s_port_line
, "port-line", 1, 0, 0, scm_port_line
);
1083 scm_port_line (port
)
1086 port
= SCM_COERCE_OUTPORT (port
);
1087 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1091 return SCM_MAKINUM (SCM_LINUM (port
));
1094 SCM_PROC (s_set_port_line_x
, "set-port-line!", 2, 0, 0, scm_set_port_line_x
);
1097 scm_set_port_line_x (port
, line
)
1101 port
= SCM_COERCE_OUTPORT (port
);
1102 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1106 SCM_ASSERT (SCM_INUMP (line
), line
, SCM_ARG2
, s_set_port_line_x
);
1107 return SCM_PTAB_ENTRY (port
)->line_number
= SCM_INUM (line
);
1110 SCM_PROC (s_port_column
, "port-column", 1, 0, 0, scm_port_column
);
1113 scm_port_column (port
)
1116 port
= SCM_COERCE_OUTPORT (port
);
1117 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1121 return SCM_MAKINUM (SCM_COL (port
));
1124 SCM_PROC (s_set_port_column_x
, "set-port-column!", 2, 0, 0, scm_set_port_column_x
);
1127 scm_set_port_column_x (port
, column
)
1131 port
= SCM_COERCE_OUTPORT (port
);
1132 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1135 s_set_port_column_x
);
1136 SCM_ASSERT (SCM_INUMP (column
), column
, SCM_ARG2
, s_set_port_column_x
);
1137 return SCM_PTAB_ENTRY (port
)->column_number
= SCM_INUM (column
);
1140 SCM_PROC (s_port_filename
, "port-filename", 1, 0, 0, scm_port_filename
);
1143 scm_port_filename (port
)
1146 port
= SCM_COERCE_OUTPORT (port
);
1147 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1151 return SCM_PTAB_ENTRY (port
)->file_name
;
1154 SCM_PROC (s_set_port_filename_x
, "set-port-filename!", 2, 0, 0, scm_set_port_filename_x
);
1157 scm_set_port_filename_x (port
, filename
)
1161 port
= SCM_COERCE_OUTPORT (port
);
1162 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1165 s_set_port_filename_x
);
1166 /* We allow the user to set the filename to whatever he likes. */
1167 return SCM_PTAB_ENTRY (port
)->file_name
= filename
;
1171 extern char * ttyname();
1175 scm_print_port_mode (SCM exp
, SCM port
)
1177 scm_puts (SCM_CLOSEDP (exp
)
1179 : (SCM_RDNG
& SCM_CAR (exp
)
1180 ? (SCM_WRTNG
& SCM_CAR (exp
)
1183 : (SCM_WRTNG
& SCM_CAR (exp
)
1190 scm_port_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
1192 char *type
= SCM_PTOBNAME (SCM_PTOBNUM (exp
));
1195 scm_puts ("#<", port
);
1196 scm_print_port_mode (exp
, port
);
1197 scm_puts (type
, port
);
1198 scm_putc (' ', port
);
1199 scm_intprint (SCM_CDR (exp
), 16, port
);
1200 scm_putc ('>', port
);
1204 extern void scm_make_fptob ();
1205 extern void scm_make_stptob ();
1206 extern void scm_make_sfptob ();
1209 scm_ports_prehistory ()
1212 scm_ptobs
= (scm_ptob_descriptor
*) malloc (sizeof (scm_ptob_descriptor
));
1214 /* WARNING: These scm_newptob calls must be done in this order.
1215 * They must agree with the port declarations in tags.h.
1217 /* scm_tc16_fport = */ scm_make_fptob ();
1218 /* scm_tc16_pipe was here */ scm_make_fptob (); /* dummy. */
1219 /* scm_tc16_strport = */ scm_make_stptob ();
1220 /* scm_tc16_sfport = */ scm_make_sfptob ();
1227 long scm_tc16_void_port
= 0;
1230 flush_void_port (SCM port
)
1235 end_input_void_port (SCM port
, int offset
)
1240 write_void_port (SCM port
, void *data
, size_t size
)
1245 scm_void_port (mode_str
)
1252 SCM_NEWCELL (answer
);
1254 mode_bits
= scm_mode_bits (mode_str
);
1255 pt
= scm_add_to_port_table (answer
);
1256 SCM_SETPTAB_ENTRY (answer
, pt
);
1257 SCM_SETSTREAM (answer
, 0);
1258 SCM_SETCAR (answer
, scm_tc16_void_port
| mode_bits
);
1264 SCM_PROC (s_sys_make_void_port
, "%make-void-port", 1, 0, 0, scm_sys_make_void_port
);
1267 scm_sys_make_void_port (mode
)
1270 SCM_ASSERT (SCM_NIMP (mode
) && SCM_ROSTRINGP (mode
), mode
,
1271 SCM_ARG1
, s_sys_make_void_port
);
1273 SCM_COERCE_SUBSTR (mode
);
1274 return scm_void_port (SCM_ROCHARS (mode
));
1278 /* Initialization. */
1283 /* lseek() symbols. */
1284 scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET
));
1285 scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR
));
1286 scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END
));
1288 scm_tc16_void_port
= scm_make_port_type ("void", 0, write_void_port
);