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
= 0;
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 return SCM_OUTPORTP (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
640 SCM_PROC(s_eof_object_p
, "eof-object?", 1, 0, 0, scm_eof_object_p
);
646 return SCM_EOF_OBJECT_P (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
649 SCM_PROC(s_force_output
, "force-output", 0, 1, 0, scm_force_output
);
652 scm_force_output (port
)
655 if (SCM_UNBNDP (port
))
659 port
= SCM_COERCE_OUTPORT (port
);
660 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
), port
, SCM_ARG1
,
664 return SCM_UNSPECIFIED
;
667 SCM_PROC (s_flush_all_ports
, "flush-all-ports", 0, 0, 0, scm_flush_all_ports
);
669 scm_flush_all_ports (void)
673 for (i
= 0; i
< scm_port_table_size
; i
++)
675 if (SCM_OPOUTPORTP (scm_port_table
[i
]->port
))
676 scm_flush (scm_port_table
[i
]->port
);
678 return SCM_UNSPECIFIED
;
681 SCM_PROC(s_read_char
, "read-char", 0, 1, 0, scm_read_char
);
688 if (SCM_UNBNDP (port
))
691 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
, s_read_char
);
695 return SCM_MAKICHR (c
);
698 /* this should only be called when the read buffer is empty. it
699 tries to refill the read buffer. it returns the first char from
700 the port, which is either EOF or *(pt->read_pos). */
702 scm_fill_input (SCM port
)
704 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
706 if (pt
->read_buf
== pt
->putback_buf
)
708 /* finished reading put-back chars. */
709 pt
->read_buf
= pt
->saved_read_buf
;
710 pt
->read_pos
= pt
->saved_read_pos
;
711 pt
->read_end
= pt
->saved_read_end
;
712 pt
->read_buf_size
= pt
->saved_read_buf_size
;
713 if (pt
->read_pos
< pt
->read_end
)
714 return *(pt
->read_pos
);
716 return scm_ptobs
[SCM_PTOBNUM (port
)].fill_input (port
);
724 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
726 if (pt
->rw_active
== SCM_PORT_WRITE
)
728 /* may be marginally faster than calling scm_flush. */
729 scm_ptobs
[SCM_PTOBNUM (port
)].flush (port
);
733 pt
->rw_active
= SCM_PORT_READ
;
735 if (pt
->read_pos
>= pt
->read_end
)
737 if (scm_fill_input (port
) == EOF
)
741 c
= *(pt
->read_pos
++);
764 scm_lfwrite (&c
, 1, port
);
772 scm_lfwrite (s
, strlen (s
), port
);
776 scm_lfwrite (ptr
, size
, port
)
781 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
782 scm_ptob_descriptor
*ptob
= &scm_ptobs
[SCM_PTOBNUM (port
)];
784 if (pt
->rw_active
== SCM_PORT_READ
)
785 scm_end_input (port
);
787 ptob
->write (port
, ptr
, size
);
790 pt
->rw_active
= SCM_PORT_WRITE
;
798 scm_sizet i
= SCM_PTOBNUM (port
);
799 (scm_ptobs
[i
].flush
) (port
);
807 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
809 if (pt
->read_buf
== pt
->putback_buf
)
811 offset
= pt
->read_end
- pt
->read_pos
;
812 pt
->read_buf
= pt
->saved_read_buf
;
813 pt
->read_pos
= pt
->saved_read_pos
;
814 pt
->read_end
= pt
->saved_read_end
;
815 pt
->read_buf_size
= pt
->saved_read_buf_size
;
820 scm_ptobs
[SCM_PTOBNUM (port
)].end_input (port
, offset
);
831 scm_port
*pt
= SCM_PTAB_ENTRY (port
);
833 if (pt
->read_buf
== pt
->putback_buf
)
834 /* already using the put-back buffer. */
836 /* enlarge putback_buf if necessary. */
837 if (pt
->read_end
== pt
->read_buf
+ pt
->read_buf_size
838 && pt
->read_buf
== pt
->read_pos
)
840 int new_size
= pt
->read_buf_size
* 2;
842 (unsigned char *) realloc (pt
->putback_buf
, new_size
);
845 scm_memory_error ("scm_ungetc");
846 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
= tmp
;
847 pt
->read_end
= pt
->read_buf
+ pt
->read_buf_size
;
848 pt
->read_buf_size
= pt
->putback_buf_size
= new_size
;
851 /* shift any existing bytes to buffer + 1. */
852 if (pt
->read_pos
== pt
->read_end
)
853 pt
->read_end
= pt
->read_buf
+ 1;
854 else if (pt
->read_pos
!= pt
->read_buf
+ 1)
856 int count
= pt
->read_end
- pt
->read_pos
;
858 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
859 pt
->read_end
= pt
->read_buf
+ 1 + count
;
862 pt
->read_pos
= pt
->read_buf
;
865 /* switch to the put-back buffer. */
867 if (pt
->putback_buf
== NULL
)
869 pt
->putback_buf
= (char *) malloc (pt
->putback_buf_size
);
870 if (pt
->putback_buf
== NULL
)
871 scm_memory_error ("scm_ungetc");
872 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
875 pt
->saved_read_buf
= pt
->read_buf
;
876 pt
->saved_read_pos
= pt
->read_pos
;
877 pt
->saved_read_end
= pt
->read_end
;
878 pt
->saved_read_buf_size
= pt
->read_buf_size
;
880 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
881 pt
->read_end
= pt
->read_buf
+ 1;
882 pt
->read_buf_size
= pt
->putback_buf_size
;
888 pt
->rw_active
= SCM_PORT_READ
;
892 /* What should col be in this case?
893 * We'll leave it at -1.
895 SCM_LINUM (port
) -= 1;
903 scm_ungets (s
, n
, port
)
908 /* This is simple minded and inefficient, but unreading strings is
909 * probably not a common operation, and remember that line and
910 * column numbers have to be handled...
912 * Please feel free to write an optimized version!
915 scm_ungetc (s
[n
], port
);
919 SCM_PROC(s_peek_char
, "peek-char", 0, 1, 0, scm_peek_char
);
926 if (SCM_UNBNDP (port
))
929 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
, s_peek_char
);
933 scm_ungetc (c
, port
);
934 return SCM_MAKICHR (c
);
937 SCM_PROC (s_unread_char
, "unread-char", 2, 0, 0, scm_unread_char
);
940 scm_unread_char (cobj
, port
)
946 SCM_ASSERT (SCM_ICHRP (cobj
), cobj
, SCM_ARG1
, s_unread_char
);
948 if (SCM_UNBNDP (port
))
951 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG2
, s_unread_char
);
956 scm_ungetc (c
, port
);
960 SCM_PROC (s_unread_string
, "unread-string", 2, 0, 0, scm_unread_string
);
963 scm_unread_string (str
, port
)
967 SCM_ASSERT (SCM_NIMP (str
) && SCM_STRINGP (str
),
968 str
, SCM_ARG1
, s_unread_string
);
970 if (SCM_UNBNDP (port
))
973 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
),
974 port
, SCM_ARG2
, s_unread_string
);
976 scm_ungets (SCM_ROUCHARS (str
), SCM_LENGTH (str
), port
);
981 SCM_PROC (s_lseek
, "lseek", 3, 0, 0, scm_lseek
);
983 scm_lseek (SCM object
, SCM offset
, SCM whence
)
989 object
= SCM_COERCE_OUTPORT (object
);
991 off
= scm_num2long (offset
, (char *)SCM_ARG2
, s_lseek
);
992 SCM_ASSERT (SCM_INUMP (whence
), whence
, SCM_ARG3
, s_lseek
);
993 how
= SCM_INUM (whence
);
994 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
995 scm_out_of_range (s_lseek
, whence
);
996 if (SCM_NIMP (object
) && SCM_OPPORTP (object
))
998 scm_port
*pt
= SCM_PTAB_ENTRY (object
);
999 scm_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1002 scm_misc_error (s_lseek
, "port is not seekable",
1003 scm_cons (object
, SCM_EOL
));
1006 if (pt
->rw_active
== SCM_PORT_READ
)
1007 scm_end_input (object
);
1008 else if (pt
->rw_active
== SCM_PORT_WRITE
)
1009 ptob
->flush (object
);
1011 rv
= ptob
->seek (object
, off
, how
);
1014 else /* file descriptor?. */
1016 SCM_ASSERT (SCM_INUMP (object
), object
, SCM_ARG1
, s_lseek
);
1017 rv
= lseek (SCM_INUM (object
), off
, how
);
1019 scm_syserror (s_lseek
);
1021 return scm_long2num (rv
);
1024 SCM_PROC (s_truncate_file
, "truncate-file", 1, 1, 0, scm_truncate_file
);
1027 scm_truncate_file (SCM object
, SCM length
)
1032 /* object can be a port, fdes or filename. */
1034 if (SCM_UNBNDP (length
))
1036 /* must supply length if object is a filename. */
1037 if (SCM_NIMP (object
) && SCM_ROSTRINGP (object
))
1038 scm_wrong_num_args (scm_makfrom0str (s_truncate_file
));
1040 length
= scm_lseek (object
, SCM_INUM0
, SCM_MAKINUM (SEEK_CUR
));
1042 c_length
= scm_num2long (length
, (char *)SCM_ARG2
, s_truncate_file
);
1044 scm_misc_error (s_truncate_file
, "negative offset", SCM_EOL
);
1046 object
= SCM_COERCE_OUTPORT (object
);
1047 if (SCM_INUMP (object
))
1049 SCM_SYSCALL (rv
= ftruncate (SCM_INUM (object
), c_length
));
1051 else if (SCM_NIMP (object
) && SCM_OPOUTPORTP (object
))
1053 scm_port
*pt
= SCM_PTAB_ENTRY (object
);
1054 scm_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1056 if (!ptob
->truncate
)
1057 scm_misc_error (s_truncate_file
, "port is not truncatable", SCM_EOL
);
1058 if (pt
->rw_active
== SCM_PORT_READ
)
1059 scm_end_input (object
);
1060 else if (pt
->rw_active
== SCM_PORT_WRITE
)
1061 ptob
->flush (object
);
1063 ptob
->truncate (object
, c_length
);
1068 SCM_ASSERT (SCM_NIMP (object
) && SCM_ROSTRINGP (object
),
1069 object
, SCM_ARG1
, s_truncate_file
);
1070 SCM_COERCE_SUBSTR (object
);
1071 SCM_SYSCALL (rv
= truncate (SCM_ROCHARS (object
), c_length
));
1074 scm_syserror (s_truncate_file
);
1075 return SCM_UNSPECIFIED
;
1078 SCM_PROC (s_port_line
, "port-line", 1, 0, 0, scm_port_line
);
1081 scm_port_line (port
)
1084 port
= SCM_COERCE_OUTPORT (port
);
1085 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1089 return SCM_MAKINUM (SCM_LINUM (port
));
1092 SCM_PROC (s_set_port_line_x
, "set-port-line!", 2, 0, 0, scm_set_port_line_x
);
1095 scm_set_port_line_x (port
, line
)
1099 port
= SCM_COERCE_OUTPORT (port
);
1100 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1104 SCM_ASSERT (SCM_INUMP (line
), line
, SCM_ARG2
, s_set_port_line_x
);
1105 return SCM_PTAB_ENTRY (port
)->line_number
= SCM_INUM (line
);
1108 SCM_PROC (s_port_column
, "port-column", 1, 0, 0, scm_port_column
);
1111 scm_port_column (port
)
1114 port
= SCM_COERCE_OUTPORT (port
);
1115 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1119 return SCM_MAKINUM (SCM_COL (port
));
1122 SCM_PROC (s_set_port_column_x
, "set-port-column!", 2, 0, 0, scm_set_port_column_x
);
1125 scm_set_port_column_x (port
, column
)
1129 port
= SCM_COERCE_OUTPORT (port
);
1130 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1133 s_set_port_column_x
);
1134 SCM_ASSERT (SCM_INUMP (column
), column
, SCM_ARG2
, s_set_port_column_x
);
1135 return SCM_PTAB_ENTRY (port
)->column_number
= SCM_INUM (column
);
1138 SCM_PROC (s_port_filename
, "port-filename", 1, 0, 0, scm_port_filename
);
1141 scm_port_filename (port
)
1144 port
= SCM_COERCE_OUTPORT (port
);
1145 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1149 return SCM_PTAB_ENTRY (port
)->file_name
;
1152 SCM_PROC (s_set_port_filename_x
, "set-port-filename!", 2, 0, 0, scm_set_port_filename_x
);
1155 scm_set_port_filename_x (port
, filename
)
1159 port
= SCM_COERCE_OUTPORT (port
);
1160 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1163 s_set_port_filename_x
);
1164 /* We allow the user to set the filename to whatever he likes. */
1165 return SCM_PTAB_ENTRY (port
)->file_name
= filename
;
1169 extern char * ttyname();
1173 scm_print_port_mode (SCM exp
, SCM port
)
1175 scm_puts (SCM_CLOSEDP (exp
)
1177 : (SCM_RDNG
& SCM_CAR (exp
)
1178 ? (SCM_WRTNG
& SCM_CAR (exp
)
1181 : (SCM_WRTNG
& SCM_CAR (exp
)
1188 scm_port_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
1190 char *type
= SCM_PTOBNAME (SCM_PTOBNUM (exp
));
1193 scm_puts ("#<", port
);
1194 scm_print_port_mode (exp
, port
);
1195 scm_puts (type
, port
);
1196 scm_putc (' ', port
);
1197 scm_intprint (SCM_CDR (exp
), 16, port
);
1198 scm_putc ('>', port
);
1202 extern void scm_make_fptob ();
1203 extern void scm_make_stptob ();
1204 extern void scm_make_sfptob ();
1207 scm_ports_prehistory ()
1210 scm_ptobs
= (scm_ptob_descriptor
*) malloc (sizeof (scm_ptob_descriptor
));
1212 /* WARNING: These scm_newptob calls must be done in this order.
1213 * They must agree with the port declarations in tags.h.
1215 /* scm_tc16_fport = */ scm_make_fptob ();
1216 /* scm_tc16_pipe was here */ scm_make_fptob (); /* dummy. */
1217 /* scm_tc16_strport = */ scm_make_stptob ();
1218 /* scm_tc16_sfport = */ scm_make_sfptob ();
1225 long scm_tc16_void_port
= 0;
1228 flush_void_port (SCM port
)
1233 end_input_void_port (SCM port
, int offset
)
1238 write_void_port (SCM port
, void *data
, size_t size
)
1243 scm_void_port (mode_str
)
1250 SCM_NEWCELL (answer
);
1252 mode_bits
= scm_mode_bits (mode_str
);
1253 pt
= scm_add_to_port_table (answer
);
1254 SCM_SETPTAB_ENTRY (answer
, pt
);
1255 SCM_SETSTREAM (answer
, 0);
1256 SCM_SETCAR (answer
, scm_tc16_void_port
| mode_bits
);
1262 SCM_PROC (s_sys_make_void_port
, "%make-void-port", 1, 0, 0, scm_sys_make_void_port
);
1265 scm_sys_make_void_port (mode
)
1268 SCM_ASSERT (SCM_NIMP (mode
) && SCM_ROSTRINGP (mode
), mode
,
1269 SCM_ARG1
, s_sys_make_void_port
);
1271 SCM_COERCE_SUBSTR (mode
);
1272 return scm_void_port (SCM_ROCHARS (mode
));
1276 /* Initialization. */
1281 /* lseek() symbols. */
1282 scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET
));
1283 scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR
));
1284 scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END
));
1286 scm_tc16_void_port
= scm_make_port_type ("void", 0, write_void_port
);