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
;
387 scm_port_table
[scm_port_table_size
] = entry
;
388 scm_port_table_size
++;
393 /* Remove a port from the table and destroy it. */
396 scm_remove_from_port_table (SCM port
)
398 scm_port
*p
= SCM_PTAB_ENTRY (port
);
401 if (i
>= scm_port_table_size
)
402 scm_wta (port
, "Port not in table", "scm_remove_from_port_table");
404 free (p
->putback_buf
);
406 /* Since we have just freed slot i we can shrink the table by moving
407 the last entry to that slot... */
408 if (i
< scm_port_table_size
- 1)
410 scm_port_table
[i
] = scm_port_table
[scm_port_table_size
- 1];
411 scm_port_table
[i
]->entry
= i
;
413 SCM_SETPTAB_ENTRY (port
, 0);
414 scm_port_table_size
--;
418 /* Undocumented functions for debugging. */
419 /* Return the number of ports in the table. */
421 SCM_PROC(s_pt_size
, "pt-size", 0, 0, 0, scm_pt_size
);
425 return SCM_MAKINUM (scm_port_table_size
);
428 /* Return the ith member of the port table. */
429 SCM_PROC(s_pt_member
, "pt-member", 1, 0, 0, scm_pt_member
);
431 scm_pt_member (SCM member
)
434 SCM_ASSERT (SCM_INUMP (member
), member
, SCM_ARG1
, s_pt_member
);
435 i
= SCM_INUM (member
);
436 if (i
< 0 || i
>= scm_port_table_size
)
439 return scm_port_table
[i
]->port
;
445 /* Revealed counts --- an oddity inherited from SCSH. */
447 /* Find a port in the table and return its revealed count.
448 Also used by the garbage collector.
452 scm_revealed_count (SCM port
)
454 return SCM_REVEALED(port
);
459 /* Return the revealed count for a port. */
461 SCM_PROC(s_port_revealed
, "port-revealed", 1, 0, 0, scm_port_revealed
);
464 scm_port_revealed (SCM port
)
466 port
= SCM_COERCE_OUTPORT (port
);
467 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
), port
, SCM_ARG1
, s_port_revealed
);
468 return SCM_MAKINUM (scm_revealed_count (port
));
471 /* Set the revealed count for a port. */
472 SCM_PROC(s_set_port_revealed_x
, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x
);
475 scm_set_port_revealed_x (SCM port
, SCM rcount
)
477 port
= SCM_COERCE_OUTPORT (port
);
478 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
),
479 port
, SCM_ARG1
, s_set_port_revealed_x
);
480 SCM_ASSERT (SCM_INUMP (rcount
), rcount
, SCM_ARG2
, s_set_port_revealed_x
);
481 SCM_REVEALED (port
) = SCM_INUM (rcount
);
482 return SCM_UNSPECIFIED
;
487 /* Retrieving a port's mode. */
489 /* Return the flags that characterize a port based on the mode
490 * string used to open a file for that port.
492 * See PORT FLAGS in scm.h
496 scm_mode_bits (char *modes
)
499 | (strchr (modes
, 'r') || strchr (modes
, '+') ? SCM_RDNG
: 0)
500 | ( strchr (modes
, 'w')
501 || strchr (modes
, 'a')
502 || strchr (modes
, '+') ? SCM_WRTNG
: 0)
503 | (strchr (modes
, '0') ? SCM_BUF0
: 0)
504 | (strchr (modes
, 'l') ? SCM_BUFLINE
: 0));
508 /* Return the mode flags from an open port.
509 * Some modes such as "append" are only used when opening
510 * a file and are not returned here. */
512 SCM_PROC(s_port_mode
, "port-mode", 1, 0, 0, scm_port_mode
);
515 scm_port_mode (SCM port
)
520 port
= SCM_COERCE_OUTPORT (port
);
521 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPPORTP (port
), port
, SCM_ARG1
, s_port_mode
);
522 if (SCM_CAR (port
) & SCM_RDNG
) {
523 if (SCM_CAR (port
) & SCM_WRTNG
)
524 strcpy (modes
, "r+");
528 else if (SCM_CAR (port
) & SCM_WRTNG
)
530 if (SCM_CAR (port
) & SCM_BUF0
)
532 return scm_makfromstr (modes
, strlen (modes
), 0);
540 * Call the close operation on a port object.
541 * see also scm_close.
543 SCM_PROC(s_close_port
, "close-port", 1, 0, 0, scm_close_port
);
546 scm_close_port (SCM port
)
551 port
= SCM_COERCE_OUTPORT (port
);
553 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
), port
, SCM_ARG1
,
555 if (SCM_CLOSEDP (port
))
557 i
= SCM_PTOBNUM (port
);
558 if (scm_ptobs
[i
].close
)
559 rv
= (scm_ptobs
[i
].close
) (port
);
562 scm_remove_from_port_table (port
);
563 SCM_SETAND_CAR (port
, ~SCM_OPN
);
564 return (rv
< 0) ? SCM_BOOL_F
: SCM_BOOL_T
;
567 SCM_PROC(s_close_all_ports_except
, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except
);
570 scm_close_all_ports_except (SCM ports
)
573 SCM_ASSERT (SCM_NIMP (ports
) && SCM_CONSP (ports
), ports
, SCM_ARG1
, s_close_all_ports_except
);
574 while (i
< scm_port_table_size
)
576 SCM thisport
= scm_port_table
[i
]->port
;
578 SCM ports_ptr
= ports
;
580 while (SCM_NNULLP (ports_ptr
))
582 SCM port
= SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr
));
584 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPPORTP (port
), port
, SCM_ARG1
, s_close_all_ports_except
);
585 if (port
== thisport
)
587 ports_ptr
= SCM_CDR (ports_ptr
);
592 /* i is not to be incremented here. */
593 scm_close_port (thisport
);
595 return SCM_UNSPECIFIED
;
600 /* Utter miscellany. Gosh, we should clean this up some time. */
602 SCM_PROC(s_input_port_p
, "input-port?", 1, 0, 0, scm_input_port_p
);
605 scm_input_port_p (SCM x
)
609 return SCM_INPORTP (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
612 SCM_PROC(s_output_port_p
, "output-port?", 1, 0, 0, scm_output_port_p
);
615 scm_output_port_p (SCM x
)
619 if (SCM_PORT_WITH_PS_P (x
))
620 x
= SCM_PORT_WITH_PS_PORT (x
);
621 return SCM_OUTPORTP (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
625 SCM_PROC(s_eof_object_p
, "eof-object?", 1, 0, 0, scm_eof_object_p
);
628 scm_eof_object_p (SCM x
)
630 return SCM_EOF_OBJECT_P (x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
633 SCM_PROC(s_force_output
, "force-output", 0, 1, 0, scm_force_output
);
636 scm_force_output (SCM port
)
638 if (SCM_UNBNDP (port
))
642 port
= SCM_COERCE_OUTPORT (port
);
643 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPOUTPORTP (port
), port
, SCM_ARG1
,
647 return SCM_UNSPECIFIED
;
650 SCM_PROC (s_flush_all_ports
, "flush-all-ports", 0, 0, 0, scm_flush_all_ports
);
652 scm_flush_all_ports ()
656 for (i
= 0; i
< scm_port_table_size
; i
++)
658 if (SCM_OPOUTPORTP (scm_port_table
[i
]->port
))
659 scm_flush (scm_port_table
[i
]->port
);
661 return SCM_UNSPECIFIED
;
664 SCM_PROC(s_read_char
, "read-char", 0, 1, 0, scm_read_char
);
667 scm_read_char (SCM port
)
670 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
);