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. */
80 scm_markstream (SCM ptr
)
83 openp
= SCM_CAR (ptr
) & SCM_OPN
;
85 return SCM_STREAM (ptr
);
91 * We choose to use an interface similar to the smob interface with
92 * fill_input and write as standard fields, passed to the port
93 * type constructor, and optional fields set by setters.
96 static void flush_void_port (SCM port
);
97 static void end_input_void_port (SCM port
, int offset
);
98 static void write_void_port (SCM port
, void *data
, size_t size
);
101 scm_make_port_type (char *name
,
102 int (*fill_input
) (SCM port
),
103 void (*write
) (SCM port
, void *data
, size_t size
))
106 if (255 <= scm_numptob
)
109 SCM_SYSCALL (tmp
= (char *) realloc ((char *) scm_ptobs
,
111 * sizeof (scm_ptob_descriptor
)));
114 scm_ptobs
= (scm_ptob_descriptor
*) tmp
;
116 scm_ptobs
[scm_numptob
].name
= name
;
117 scm_ptobs
[scm_numptob
].mark
= 0;
118 scm_ptobs
[scm_numptob
].free
= scm_free0
;
119 scm_ptobs
[scm_numptob
].print
= scm_port_print
;
120 scm_ptobs
[scm_numptob
].equalp
= 0;
121 scm_ptobs
[scm_numptob
].close
= 0;
123 scm_ptobs
[scm_numptob
].write
= write
;
124 scm_ptobs
[scm_numptob
].flush
= flush_void_port
;
126 scm_ptobs
[scm_numptob
].end_input
= end_input_void_port
;
127 scm_ptobs
[scm_numptob
].fill_input
= fill_input
;
128 scm_ptobs
[scm_numptob
].input_waiting
= 0;
130 scm_ptobs
[scm_numptob
].seek
= 0;
131 scm_ptobs
[scm_numptob
].truncate
= 0;
137 ptoberr
:scm_wta (SCM_MAKINUM ((long) scm_numptob
),
138 (char *) SCM_NALLOC
, "scm_make_port_type");
139 /* Make a class object if Goops is present */
141 scm_make_port_classes (scm_numptob
- 1, SCM_PTOBNAME (scm_numptob
- 1));
142 return scm_tc7_port
+ (scm_numptob
- 1) * 256;
146 scm_set_port_mark (long tc
, SCM (*mark
) (SCM
))
148 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].mark
= mark
;
152 scm_set_port_free (long tc
, scm_sizet (*free
) (SCM
))
154 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].free
= free
;
158 scm_set_port_print (long tc
, int (*print
) (SCM exp
, SCM port
,
159 scm_print_state
*pstate
))
161 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].print
= print
;
165 scm_set_port_equalp (long tc
, SCM (*equalp
) (SCM
, SCM
))
167 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].equalp
= equalp
;
171 scm_set_port_flush (long tc
, void (*flush
) (SCM port
))
173 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].flush
= flush
;
177 scm_set_port_end_input (long tc
, void (*end_input
) (SCM port
, int offset
))
179 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].end_input
= end_input
;
183 scm_set_port_close (long tc
, int (*close
) (SCM
))
185 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].close
= close
;
189 scm_set_port_seek (long tc
, off_t (*seek
) (SCM port
,
193 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].seek
= seek
;
197 scm_set_port_truncate (long tc
, void (*truncate
) (SCM port
, off_t length
))
199 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].truncate
= truncate
;
203 scm_set_port_input_waiting (long tc
, int (*input_waiting
) (SCM
))
205 scm_ptobs
[SCM_TC2PTOBNUM (tc
)].input_waiting
= input_waiting
;
210 SCM_PROC(s_char_ready_p
, "char-ready?", 0, 1, 0, scm_char_ready_p
);
213 scm_char_ready_p (SCM port
)
217 if (SCM_UNBNDP (port
))
220 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
,
223 pt
= SCM_PTAB_ENTRY (port
);
225 /* if the current read buffer is filled, or the
226 last pushed-back char has been read and the saved buffer is
227 filled, result is true. */
228 if (pt
->read_pos
< pt
->read_end
229 || (pt
->read_buf
== pt
->putback_buf
230 && pt
->saved_read_pos
< pt
->saved_read_end
))
234 scm_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
236 if (ptob
->input_waiting
)
237 return (ptob
->input_waiting (port
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
243 /* Clear a port's read buffers, returning the contents. */
244 SCM_PROC (s_drain_input
, "drain-input", 1, 0, 0, scm_drain_input
);
246 scm_drain_input (SCM port
)
249 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
253 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
,
256 count
= pt
->read_end
- pt
->read_pos
;
257 if (pt
->read_buf
== pt
->putback_buf
)
258 count
+= pt
->saved_read_end
- pt
->saved_read_pos
;
260 result
= scm_makstr (count
, 0);
261 dst
= SCM_CHARS (result
);
263 while (pt
->read_pos
< pt
->read_end
)
264 *dst
++ = *(pt
->read_pos
++);
266 if (pt
->read_buf
== pt
->putback_buf
)
268 while (pt
->saved_read_pos
< pt
->saved_read_end
)
269 *dst
++ = *(pt
->saved_read_pos
++);
276 /* Standard ports --- current input, output, error, and more(!). */
278 SCM_PROC(s_current_input_port
, "current-input-port", 0, 0, 0, scm_current_input_port
);
281 scm_current_input_port ()
286 SCM_PROC(s_current_output_port
, "current-output-port", 0, 0, 0, scm_current_output_port
);
289 scm_current_output_port ()
294 SCM_PROC(s_current_error_port
, "current-error-port", 0, 0, 0, scm_current_error_port
);
297 scm_current_error_port ()
302 SCM_PROC(s_current_load_port
, "current-load-port", 0, 0, 0, scm_current_load_port
);
305 scm_current_load_port ()
307 return scm_cur_loadp
;
310 SCM_PROC(s_set_current_input_port
, "set-current-input-port", 1, 0, 0, scm_set_current_input_port
);
313 scm_set_current_input_port (SCM port
)
315 SCM oinp
= scm_cur_inp
;
316 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
, s_set_current_input_port
);
322 SCM_PROC(s_set_current_output_port
, "set-current-output-port", 1, 0, 0, scm_set_current_output_port
);
325 scm_set_current_output_port (SCM port
)
327 SCM ooutp
= scm_cur_outp
;
328 port
= SCM_COERCE_OUTPORT (port
);
329 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
), port
, SCM_ARG1
, s_set_current_output_port
);
335 SCM_PROC(s_set_current_error_port
, "set-current-error-port", 1, 0, 0, scm_set_current_error_port
);
338 scm_set_current_error_port (SCM port
)
340 SCM oerrp
= scm_cur_errp
;
341 port
= SCM_COERCE_OUTPORT (port
);
342 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
), port
, SCM_ARG1
, s_set_current_error_port
);
348 /* The port table --- an array of pointers to ports. */
350 scm_port
**scm_port_table
;
352 int scm_port_table_size
= 0; /* Number of ports in scm_port_table. */
353 int scm_port_table_room
= 20; /* Size of the array. */
355 /* Add a port to the table. */
358 scm_add_to_port_table (SCM port
)
362 if (scm_port_table_size
== scm_port_table_room
)
364 void *newt
= realloc ((char *) scm_port_table
,
365 (scm_sizet
) (sizeof (scm_port
*)
366 * scm_port_table_room
* 2));
368 scm_memory_error ("scm_add_to_port_table");
369 scm_port_table
= (scm_port
**) newt
;
370 scm_port_table_room
*= 2;
372 entry
= (scm_port
*) malloc (sizeof (scm_port
));
374 scm_memory_error ("scm_add_to_port_table");
377 entry
->entry
= scm_port_table_size
;
380 entry
->file_name
= SCM_BOOL_F
;
381 entry
->line_number
= 0;
382 entry
->column_number
= 0;
383 entry
->putback_buf
= 0;
384 entry
->putback_buf_size
= 0;
385 entry
->rw_active
= SCM_PORT_NEITHER
;
386 entry
->rw_random
= 0;
388 scm_port_table
[scm_port_table_size
] = entry
;
389 scm_port_table_size
++;
394 /* Remove a port from the table and destroy it. */
397 scm_remove_from_port_table (SCM port
)
399 scm_port
*p
= SCM_PTAB_ENTRY (port
);
402 if (i
>= scm_port_table_size
)
403 scm_wta (port
, "Port not in table", "scm_remove_from_port_table");
405 free (p
->putback_buf
);
407 /* Since we have just freed slot i we can shrink the table by moving
408 the last entry to that slot... */
409 if (i
< scm_port_table_size
- 1)
411 scm_port_table
[i
] = scm_port_table
[scm_port_table_size
- 1];
412 scm_port_table
[i
]->entry
= i
;
414 SCM_SETPTAB_ENTRY (port
, 0);
415 scm_port_table_size
--;
419 /* Undocumented functions for debugging. */
420 /* Return the number of ports in the table. */
422 SCM_PROC(s_pt_size
, "pt-size", 0, 0, 0, scm_pt_size
);
426 return SCM_MAKINUM (scm_port_table_size
);
429 /* Return the ith member of the port table. */
430 SCM_PROC(s_pt_member
, "pt-member", 1, 0, 0, scm_pt_member
);
432 scm_pt_member (SCM member
)
435 SCM_ASSERT (SCM_INUMP (member
), member
, SCM_ARG1
, s_pt_member
);
436 i
= SCM_INUM (member
);
437 if (i
< 0 || i
>= scm_port_table_size
)
440 return scm_port_table
[i
]->port
;
446 /* Revealed counts --- an oddity inherited from SCSH. */
448 /* Find a port in the table and return its revealed count.
449 Also used by the garbage collector.
453 scm_revealed_count (SCM port
)
455 return SCM_REVEALED(port
);
460 /* Return the revealed count for a port. */
462 SCM_PROC(s_port_revealed
, "port-revealed", 1, 0, 0, scm_port_revealed
);
465 scm_port_revealed (SCM port
)
467 port
= SCM_COERCE_OUTPORT (port
);
468 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
), port
, SCM_ARG1
, s_port_revealed
);
469 return SCM_MAKINUM (scm_revealed_count (port
));
472 /* Set the revealed count for a port. */
473 SCM_PROC(s_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x
);
476 scm_set_port_revealed_x (SCM port
, SCM rcount
)
478 port
= SCM_COERCE_OUTPORT (port
);
479 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
),
480 port
, SCM_ARG1
, s_set_port_revealed_x
);
481 SCM_ASSERT (SCM_INUMP (rcount
), rcount
, SCM_ARG2
, s_set_port_revealed_x
);
482 SCM_REVEALED (port
) = SCM_INUM (rcount
);
483 return SCM_UNSPECIFIED
;
488 /* Retrieving a port's mode. */
490 /* Return the flags that characterize a port based on the mode
491 * string used to open a file for that port.
493 * See PORT FLAGS in scm.h
497 scm_mode_bits (char *modes
)
500 | (strchr (modes
, 'r') || strchr (modes
, '+') ? SCM_RDNG
: 0)
501 | ( strchr (modes
, 'w')
502 || strchr (modes
, 'a')
503 || strchr (modes
, '+') ? SCM_WRTNG
: 0)
504 | (strchr (modes
, '0') ? SCM_BUF0
: 0)
505 | (strchr (modes
, 'l') ? SCM_BUFLINE
: 0));
509 /* Return the mode flags from an open port.
510 * Some modes such as "append" are only used when opening
511 * a file and are not returned here. */
513 SCM_PROC(s_port_mode
, "port-mode", 1, 0, 0, scm_port_mode
);
516 scm_port_mode (SCM port
)
521 port
= SCM_COERCE_OUTPORT (port
);
522 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPPORTP (port
), port
, SCM_ARG1
, s_port_mode
);
523 if (SCM_CAR (port
) & SCM_RDNG
) {
524 if (SCM_CAR (port
) & SCM_WRTNG
)
525 strcpy (modes
, "r+");
529 else if (SCM_CAR (port
) & SCM_WRTNG
)
531 if (SCM_CAR (port
) & SCM_BUF0
)
533 return scm_makfromstr (modes
, strlen (modes
), 0);
541 * Call the close operation on a port object.
542 * see also scm_close.
544 SCM_PROC(s_close_port
, "close-port", 1, 0, 0, scm_close_port
);
547 scm_close_port (SCM port
)
552 port
= SCM_COERCE_OUTPORT (port
);
554 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
), port
, SCM_ARG1
,
556 if (SCM_CLOSEDP (port
))
558 i
= SCM_PTOBNUM (port
);
559 if (scm_ptobs
[i
].close
)
560 rv
= (scm_ptobs
[i
].close
) (port
);
563 scm_remove_from_port_table (port
);
564 SCM_SETAND_CAR (port
, ~SCM_OPN
);
565 return (rv
< 0) ? SCM_BOOL_F
: SCM_BOOL_T
;
568 SCM_PROC(s_close_all_ports_except
, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except
);
571 scm_close_all_ports_except (SCM ports
)
574 SCM_ASSERT (SCM_NIMP (ports
) && SCM_CONSP (ports
), ports
, SCM_ARG1
, s_close_all_ports_except
);
575 while (i
< scm_port_table_size
)
577 SCM thisport
= scm_port_table
[i
]->port
;
579 SCM ports_ptr
= ports
;
581 while (SCM_NNULLP (ports_ptr
))
583 SCM port
= SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr
));
585 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPPORTP (port
), port
, SCM_ARG1
, s_close_all_ports_except
);
586 if (port
== thisport
)
588 ports_ptr
= SCM_CDR (ports_ptr
);
593 /* i is not to be incremented here. */
594 scm_close_port (thisport
);
596 return SCM_UNSPECIFIED
;
601 /* Utter miscellany. Gosh, we should clean this up some time. */
603 SCM_PROC(s_input_port_p
, "input-port?", 1, 0, 0, scm_input_port_p
);
606 scm_input_port_p (SCM x
)
610 return SCM_INPORTP (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
613 SCM_PROC(s_output_port_p
, "output-port?", 1, 0, 0, scm_output_port_p
);
616 scm_output_port_p (SCM x
)
620 if (SCM_PORT_WITH_PS_P (x
))
621 x
= SCM_PORT_WITH_PS_PORT (x
);
622 return SCM_OUTPORTP (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
626 SCM_PROC(s_eof_object_p
, "eof-object?", 1, 0, 0, scm_eof_object_p
);
629 scm_eof_object_p (SCM x
)
631 return SCM_EOF_OBJECT_P (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
634 SCM_PROC(s_force_output
, "force-output", 0, 1, 0, scm_force_output
);
637 scm_force_output (SCM port
)
639 if (SCM_UNBNDP (port
))
643 port
= SCM_COERCE_OUTPORT (port
);
644 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
), port
, SCM_ARG1
,
648 return SCM_UNSPECIFIED
;
651 SCM_PROC (s_flush_all_ports
, "flush-all-ports", 0, 0, 0, scm_flush_all_ports
);
653 scm_flush_all_ports ()
657 for (i
= 0; i
< scm_port_table_size
; i
++)
659 if (SCM_OPOUTPORTP (scm_port_table
[i
]->port
))
660 scm_flush (scm_port_table
[i
]->port
);
662 return SCM_UNSPECIFIED
;
665 SCM_PROC(s_read_char
, "read-char", 0, 1, 0, scm_read_char
);
668 scm_read_char (SCM port
)
671 if (SCM_UNBNDP (port
))
673 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
, s_read_char
);
677 return SCM_MAKICHR (c
);
680 /* this should only be called when the read buffer is empty. it
681 tries to refill the read buffer. it returns the first char from
682 the port, which is either EOF or *(pt->read_pos). */
684 scm_fill_input (SCM port
)
686 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
688 if (pt
->read_buf
== pt
->putback_buf
)
690 /* finished reading put-back chars. */
691 pt
->read_buf
= pt
->saved_read_buf
;
692 pt
->read_pos
= pt
->saved_read_pos
;
693 pt
->read_end
= pt
->saved_read_end
;
694 pt
->read_buf_size
= pt
->saved_read_buf_size
;
695 if (pt
->read_pos
< pt
->read_end
)
696 return *(pt
->read_pos
);
698 return scm_ptobs
[SCM_PTOBNUM (port
)].fill_input (port
);
705 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
707 if (pt
->rw_active
== SCM_PORT_WRITE
)
709 /* may be marginally faster than calling scm_flush. */
710 scm_ptobs
[SCM_PTOBNUM (port
)].flush (port
);
714 pt
->rw_active
= SCM_PORT_READ
;
716 if (pt
->read_pos
>= pt
->read_end
)
718 if (scm_fill_input (port
) == EOF
)
722 c
= *(pt
->read_pos
++);
741 scm_putc (char c
, SCM port
)
743 scm_lfwrite (&c
, 1, port
);
747 scm_puts (char *s
, SCM port
)
749 scm_lfwrite (s
, strlen (s
), port
);
753 scm_lfwrite (char *ptr
, scm_sizet size
, SCM port
)
755 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
756 scm_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
758 if (pt
->rw_active
== SCM_PORT_READ
)
759 scm_end_input (port
);
761 ptob
->write (port
, ptr
, size
);
764 pt
->rw_active
= SCM_PORT_WRITE
;
771 scm_sizet i
= SCM_PTOBNUM (port
);
772 (scm_ptobs
[i
].flush
) (port
);
776 scm_end_input (SCM port
)
779 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
781 if (pt
->read_buf
== pt
->putback_buf
)
783 offset
= pt
->read_end
- pt
->read_pos
;
784 pt
->read_buf
= pt
->saved_read_buf
;
785 pt
->read_pos
= pt
->saved_read_pos
;
786 pt
->read_end
= pt
->saved_read_end
;
787 pt
->read_buf_size
= pt
->saved_read_buf_size
;
792 scm_ptobs
[SCM_PTOBNUM (port
)].end_input (port
, offset
);
799 scm_ungetc (int c
, SCM port
)
801 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
803 if (pt
->read_buf
== pt
->putback_buf
)
804 /* already using the put-back buffer. */
806 /* enlarge putback_buf if necessary. */
807 if (pt
->read_end
== pt
->read_buf
+ pt
->read_buf_size
808 && pt
->read_buf
== pt
->read_pos
)
810 int new_size
= pt
->read_buf_size
* 2;
812 (unsigned char *) realloc (pt
->putback_buf
, new_size
);
815 scm_memory_error ("scm_ungetc");
816 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
= tmp
;
817 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
818 pt
->read_buf_size
= pt
->putback_buf_size
= new_size
;
821 /* shift any existing bytes to buffer + 1. */
822 if (pt
->read_pos
== pt
->read_end
)
823 pt
->read_end
= pt
->read_buf
+ 1;
824 else if (pt
->read_pos
!= pt
->read_buf
+ 1)
826 int count
= pt
->read_end
- pt
->read_pos
;
828 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
829 pt
->read_end
= pt
->read_buf
+ 1 + count
;
832 pt
->read_pos
= pt
->read_buf
;
835 /* switch to the put-back buffer. */
837 if (pt
->putback_buf
== NULL
)
839 pt
->putback_buf
= (char *) malloc (SCM_INITIAL_PUTBACK_BUF_SIZE
);
840 if (pt
->putback_buf
== NULL
)
841 scm_memory_error ("scm_ungetc");
842 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
845 pt
->saved_read_buf
= pt
->read_buf
;
846 pt
->saved_read_pos
= pt
->read_pos
;
847 pt
->saved_read_end
= pt
->read_end
;
848 pt
->saved_read_buf_size
= pt
->read_buf_size
;
850 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
851 pt
->read_end
= pt
->read_buf
+ 1;
852 pt
->read_buf_size
= pt
->putback_buf_size
;
858 pt
->rw_active
= SCM_PORT_READ
;
862 /* What should col be in this case?
863 * We'll leave it at -1.
865 SCM_LINUM (port
) -= 1;
873 scm_ungets (char *s
, int n
, SCM port
)
875 /* This is simple minded and inefficient, but unreading strings is
876 * probably not a common operation, and remember that line and
877 * column numbers have to be handled...
879 * Please feel free to write an optimized version!
882 scm_ungetc (s
[n
], port
);
886 SCM_PROC(s_peek_char
, "peek-char", 0, 1, 0, scm_peek_char
);
889 scm_peek_char (SCM port
)
892 if (SCM_UNBNDP (port
))
895 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
, s_peek_char
);
899 scm_ungetc (c
, port
);
900 return SCM_MAKICHR (c
);
903 SCM_PROC (s_unread_char
, "unread-char", 2, 0, 0, scm_unread_char
);
906 scm_unread_char (SCM cobj
, SCM port
)
910 SCM_ASSERT (SCM_ICHRP (cobj
), cobj
, SCM_ARG1
, s_unread_char
);
912 if (SCM_UNBNDP (port
))
915 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG2
, s_unread_char
);
920 scm_ungetc (c
, port
);
924 SCM_PROC (s_unread_string
, "unread-string", 2, 0, 0, scm_unread_string
);
927 scm_unread_string (SCM str
, SCM port
)
929 SCM_ASSERT (SCM_NIMP (str
) && SCM_STRINGP (str
),
930 str
, SCM_ARG1
, s_unread_string
);
932 if (SCM_UNBNDP (port
))
935 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
),
936 port
, SCM_ARG2
, s_unread_string
);
938 scm_ungets (SCM_ROUCHARS (str
), SCM_LENGTH (str
), port
);
943 SCM_PROC (s_seek
, "seek", 3, 0, 0, scm_seek
);
945 scm_seek (SCM object
, SCM offset
, SCM whence
)
951 object
= SCM_COERCE_OUTPORT (object
);
953 off
= scm_num2long (offset
, (char *)SCM_ARG2
, s_seek
);
954 SCM_ASSERT (SCM_INUMP (whence
), whence
, SCM_ARG3
, s_seek
);
955 how
= SCM_INUM (whence
);
956 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
957 scm_out_of_range (s_seek
, whence
);
958 if (SCM_NIMP (object
) && SCM_OPPORTP (object
))
960 scm_port
*pt
= SCM_PTAB_ENTRY (object
);
961 scm_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
964 scm_misc_error (s_seek
, "port is not seekable",
965 scm_cons (object
, SCM_EOL
));
968 if (pt
->rw_active
== SCM_PORT_READ
)
969 scm_end_input (object
);
970 else if (pt
->rw_active
== SCM_PORT_WRITE
)
971 ptob
->flush (object
);
973 rv
= ptob
->seek (object
, off
, how
);
976 else /* file descriptor?. */
978 SCM_ASSERT (SCM_INUMP (object
), object
, SCM_ARG1
, s_seek
);
979 rv
= lseek (SCM_INUM (object
), off
, how
);
981 scm_syserror (s_seek
);
983 return scm_long2num (rv
);
986 SCM_PROC (s_truncate_file
, "truncate-file", 1, 1, 0, scm_truncate_file
);
989 scm_truncate_file (SCM object
, SCM length
)
994 /* object can be a port, fdes or filename. */
996 if (SCM_UNBNDP (length
))
998 /* must supply length if object is a filename. */
999 if (SCM_NIMP (object
) && SCM_ROSTRINGP (object
))
1000 scm_wrong_num_args (scm_makfrom0str (s_truncate_file
));
1002 length
= scm_seek (object
, SCM_INUM0
, SCM_MAKINUM (SEEK_CUR
));
1004 c_length
= scm_num2long (length
, (char *)SCM_ARG2
, s_truncate_file
);
1006 scm_misc_error (s_truncate_file
, "negative offset", SCM_EOL
);
1008 object
= SCM_COERCE_OUTPORT (object
);
1009 if (SCM_INUMP (object
))
1011 SCM_SYSCALL (rv
= ftruncate (SCM_INUM (object
), c_length
));
1013 else if (SCM_NIMP (object
) && SCM_OPOUTPORTP (object
))
1015 scm_port
*pt
= SCM_PTAB_ENTRY (object
);
1016 scm_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1018 if (!ptob
->truncate
)
1019 scm_misc_error (s_truncate_file
, "port is not truncatable", SCM_EOL
);
1020 if (pt
->rw_active
== SCM_PORT_READ
)
1021 scm_end_input (object
);
1022 else if (pt
->rw_active
== SCM_PORT_WRITE
)
1023 ptob
->flush (object
);
1025 ptob
->truncate (object
, c_length
);
1030 SCM_ASSERT (SCM_NIMP (object
) && SCM_ROSTRINGP (object
),
1031 object
, SCM_ARG1
, s_truncate_file
);
1032 SCM_COERCE_SUBSTR (object
);
1033 SCM_SYSCALL (rv
= truncate (SCM_ROCHARS (object
), c_length
));
1036 scm_syserror (s_truncate_file
);
1037 return SCM_UNSPECIFIED
;
1040 SCM_PROC (s_port_line
, "port-line", 1, 0, 0, scm_port_line
);
1043 scm_port_line (SCM port
)
1045 port
= SCM_COERCE_OUTPORT (port
);
1046 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1050 return SCM_MAKINUM (SCM_LINUM (port
));
1053 SCM_PROC (s_set_port_line_x
, "set-port-line!", 2, 0, 0, scm_set_port_line_x
);
1056 scm_set_port_line_x (SCM port
, SCM 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 (SCM port
)
1072 port
= SCM_COERCE_OUTPORT (port
);
1073 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1077 return SCM_MAKINUM (SCM_COL (port
));
1080 SCM_PROC (s_set_port_column_x
, "set-port-column!", 2, 0, 0, scm_set_port_column_x
);
1083 scm_set_port_column_x (SCM port
, SCM column
)
1085 port
= SCM_COERCE_OUTPORT (port
);
1086 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1089 s_set_port_column_x
);
1090 SCM_ASSERT (SCM_INUMP (column
), column
, SCM_ARG2
, s_set_port_column_x
);
1091 return SCM_PTAB_ENTRY (port
)->column_number
= SCM_INUM (column
);
1094 SCM_PROC (s_port_filename
, "port-filename", 1, 0, 0, scm_port_filename
);
1097 scm_port_filename (SCM port
)
1099 port
= SCM_COERCE_OUTPORT (port
);
1100 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1104 return SCM_PTAB_ENTRY (port
)->file_name
;
1107 SCM_PROC (s_set_port_filename_x
, "set-port-filename!", 2, 0, 0, scm_set_port_filename_x
);
1110 scm_set_port_filename_x (SCM port
, SCM filename
)
1112 port
= SCM_COERCE_OUTPORT (port
);
1113 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1116 s_set_port_filename_x
);
1117 /* We allow the user to set the filename to whatever he likes. */
1118 return SCM_PTAB_ENTRY (port
)->file_name
= filename
;
1122 extern char * ttyname();
1126 scm_print_port_mode (SCM exp
, SCM port
)
1128 scm_puts (SCM_CLOSEDP (exp
)
1130 : (SCM_RDNG
& SCM_CAR (exp
)
1131 ? (SCM_WRTNG
& SCM_CAR (exp
)
1134 : (SCM_WRTNG
& SCM_CAR (exp
)
1141 scm_port_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
1143 char *type
= SCM_PTOBNAME (SCM_PTOBNUM (exp
));
1146 scm_puts ("#<", port
);
1147 scm_print_port_mode (exp
, port
);
1148 scm_puts (type
, port
);
1149 scm_putc (' ', port
);
1150 scm_intprint (SCM_CDR (exp
), 16, port
);
1151 scm_putc ('>', port
);
1155 extern void scm_make_fptob ();
1156 extern void scm_make_stptob ();
1157 extern void scm_make_sfptob ();
1160 scm_ports_prehistory ()
1163 scm_ptobs
= (scm_ptob_descriptor
*) malloc (sizeof (scm_ptob_descriptor
));
1165 /* WARNING: These scm_newptob calls must be done in this order.
1166 * They must agree with the port declarations in tags.h.
1168 /* scm_tc16_fport = */ scm_make_fptob ();
1169 /* scm_tc16_pipe was here */ scm_make_fptob (); /* dummy. */
1170 /* scm_tc16_strport = */ scm_make_stptob ();
1171 /* scm_tc16_sfport = */ scm_make_sfptob ();
1178 long scm_tc16_void_port
= 0;
1181 flush_void_port (SCM port
)
1186 end_input_void_port (SCM port
, int offset
)
1191 write_void_port (SCM port
, void *data
, size_t size
)
1196 scm_void_port (char *mode_str
)
1202 SCM_NEWCELL (answer
);
1204 mode_bits
= scm_mode_bits (mode_str
);
1205 pt
= scm_add_to_port_table (answer
);
1206 SCM_SETPTAB_ENTRY (answer
, pt
);
1207 SCM_SETSTREAM (answer
, 0);
1208 SCM_SETCAR (answer
, scm_tc16_void_port
| mode_bits
);
1214 SCM_PROC (s_sys_make_void_port
, "%make-void-port", 1, 0, 0, scm_sys_make_void_port
);
1217 scm_sys_make_void_port (SCM mode
)
1219 SCM_ASSERT (SCM_NIMP (mode
) && SCM_ROSTRINGP (mode
), mode
,
1220 SCM_ARG1
, s_sys_make_void_port
);
1222 SCM_COERCE_SUBSTR (mode
);
1223 return scm_void_port (SCM_ROCHARS (mode
));
1227 /* Initialization. */
1232 /* lseek() symbols. */
1233 scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET
));
1234 scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR
));
1235 scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END
));
1237 scm_tc16_void_port
= scm_make_port_type ("void", 0, write_void_port
);