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
;
829 memmove (pt
->read_buf
+ 1, pt
->read_pos
, count
);
832 bcopy (pt
->read_pos
, pt
->read_buf
+ 1, count
);
834 #error Need memmove. Please send a bug report to bug-guile@gnu.org.
837 pt
->read_end
= pt
->read_buf
+ 1 + count
;
840 pt
->read_pos
= pt
->read_buf
;
843 /* switch to the put-back buffer. */
845 if (pt
->putback_buf
== NULL
)
847 pt
->putback_buf
= (char *) malloc (SCM_INITIAL_PUTBACK_BUF_SIZE
);
848 if (pt
->putback_buf
== NULL
)
849 scm_memory_error ("scm_ungetc");
850 pt
->putback_buf_size
= SCM_INITIAL_PUTBACK_BUF_SIZE
;
853 pt
->saved_read_buf
= pt
->read_buf
;
854 pt
->saved_read_pos
= pt
->read_pos
;
855 pt
->saved_read_end
= pt
->read_end
;
856 pt
->saved_read_buf_size
= pt
->read_buf_size
;
858 pt
->read_pos
= pt
->read_buf
= pt
->putback_buf
;
859 pt
->read_end
= pt
->read_buf
+ 1;
860 pt
->read_buf_size
= pt
->putback_buf_size
;
866 pt
->rw_active
= SCM_PORT_READ
;
870 /* What should col be in this case?
871 * We'll leave it at -1.
873 SCM_LINUM (port
) -= 1;
881 scm_ungets (char *s
, int n
, SCM port
)
883 /* This is simple minded and inefficient, but unreading strings is
884 * probably not a common operation, and remember that line and
885 * column numbers have to be handled...
887 * Please feel free to write an optimized version!
890 scm_ungetc (s
[n
], port
);
894 SCM_PROC(s_peek_char
, "peek-char", 0, 1, 0, scm_peek_char
);
897 scm_peek_char (SCM port
)
900 if (SCM_UNBNDP (port
))
903 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG1
, s_peek_char
);
907 scm_ungetc (c
, port
);
908 return SCM_MAKICHR (c
);
911 SCM_PROC (s_unread_char
, "unread-char", 2, 0, 0, scm_unread_char
);
914 scm_unread_char (SCM cobj
, SCM port
)
918 SCM_ASSERT (SCM_ICHRP (cobj
), cobj
, SCM_ARG1
, s_unread_char
);
920 if (SCM_UNBNDP (port
))
923 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
), port
, SCM_ARG2
, s_unread_char
);
928 scm_ungetc (c
, port
);
932 SCM_PROC (s_unread_string
, "unread-string", 2, 0, 0, scm_unread_string
);
935 scm_unread_string (SCM str
, SCM port
)
937 SCM_ASSERT (SCM_NIMP (str
) && SCM_STRINGP (str
),
938 str
, SCM_ARG1
, s_unread_string
);
940 if (SCM_UNBNDP (port
))
943 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
),
944 port
, SCM_ARG2
, s_unread_string
);
946 scm_ungets (SCM_ROUCHARS (str
), SCM_LENGTH (str
), port
);
951 SCM_PROC (s_seek
, "seek", 3, 0, 0, scm_seek
);
953 scm_seek (SCM object
, SCM offset
, SCM whence
)
959 object
= SCM_COERCE_OUTPORT (object
);
961 off
= scm_num2long (offset
, (char *)SCM_ARG2
, s_seek
);
962 SCM_ASSERT (SCM_INUMP (whence
), whence
, SCM_ARG3
, s_seek
);
963 how
= SCM_INUM (whence
);
964 if (how
!= SEEK_SET
&& how
!= SEEK_CUR
&& how
!= SEEK_END
)
965 scm_out_of_range (s_seek
, whence
);
966 if (SCM_NIMP (object
) && SCM_OPPORTP (object
))
968 scm_port
*pt
= SCM_PTAB_ENTRY (object
);
969 scm_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
972 scm_misc_error (s_seek
, "port is not seekable",
973 scm_cons (object
, SCM_EOL
));
976 if (pt
->rw_active
== SCM_PORT_READ
)
977 scm_end_input (object
);
978 else if (pt
->rw_active
== SCM_PORT_WRITE
)
979 ptob
->flush (object
);
981 rv
= ptob
->seek (object
, off
, how
);
984 else /* file descriptor?. */
986 SCM_ASSERT (SCM_INUMP (object
), object
, SCM_ARG1
, s_seek
);
987 rv
= lseek (SCM_INUM (object
), off
, how
);
989 scm_syserror (s_seek
);
991 return scm_long2num (rv
);
994 SCM_PROC (s_truncate_file
, "truncate-file", 1, 1, 0, scm_truncate_file
);
997 scm_truncate_file (SCM object
, SCM length
)
1002 /* object can be a port, fdes or filename. */
1004 if (SCM_UNBNDP (length
))
1006 /* must supply length if object is a filename. */
1007 if (SCM_NIMP (object
) && SCM_ROSTRINGP (object
))
1008 scm_wrong_num_args (scm_makfrom0str (s_truncate_file
));
1010 length
= scm_seek (object
, SCM_INUM0
, SCM_MAKINUM (SEEK_CUR
));
1012 c_length
= scm_num2long (length
, (char *)SCM_ARG2
, s_truncate_file
);
1014 scm_misc_error (s_truncate_file
, "negative offset", SCM_EOL
);
1016 object
= SCM_COERCE_OUTPORT (object
);
1017 if (SCM_INUMP (object
))
1019 SCM_SYSCALL (rv
= ftruncate (SCM_INUM (object
), c_length
));
1021 else if (SCM_NIMP (object
) && SCM_OPOUTPORTP (object
))
1023 scm_port
*pt
= SCM_PTAB_ENTRY (object
);
1024 scm_ptob_descriptor
*ptob
= scm_ptobs
+ SCM_PTOBNUM (object
);
1026 if (!ptob
->truncate
)
1027 scm_misc_error (s_truncate_file
, "port is not truncatable", SCM_EOL
);
1028 if (pt
->rw_active
== SCM_PORT_READ
)
1029 scm_end_input (object
);
1030 else if (pt
->rw_active
== SCM_PORT_WRITE
)
1031 ptob
->flush (object
);
1033 ptob
->truncate (object
, c_length
);
1038 SCM_ASSERT (SCM_NIMP (object
) && SCM_ROSTRINGP (object
),
1039 object
, SCM_ARG1
, s_truncate_file
);
1040 SCM_COERCE_SUBSTR (object
);
1041 SCM_SYSCALL (rv
= truncate (SCM_ROCHARS (object
), c_length
));
1044 scm_syserror (s_truncate_file
);
1045 return SCM_UNSPECIFIED
;
1048 SCM_PROC (s_port_line
, "port-line", 1, 0, 0, scm_port_line
);
1051 scm_port_line (SCM port
)
1053 port
= SCM_COERCE_OUTPORT (port
);
1054 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1058 return SCM_MAKINUM (SCM_LINUM (port
));
1061 SCM_PROC (s_set_port_line_x
, "set-port-line!", 2, 0, 0, scm_set_port_line_x
);
1064 scm_set_port_line_x (SCM port
, SCM line
)
1066 port
= SCM_COERCE_OUTPORT (port
);
1067 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1071 SCM_ASSERT (SCM_INUMP (line
), line
, SCM_ARG2
, s_set_port_line_x
);
1072 return SCM_PTAB_ENTRY (port
)->line_number
= SCM_INUM (line
);
1075 SCM_PROC (s_port_column
, "port-column", 1, 0, 0, scm_port_column
);
1078 scm_port_column (SCM port
)
1080 port
= SCM_COERCE_OUTPORT (port
);
1081 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1085 return SCM_MAKINUM (SCM_COL (port
));
1088 SCM_PROC (s_set_port_column_x
, "set-port-column!", 2, 0, 0, scm_set_port_column_x
);
1091 scm_set_port_column_x (SCM port
, SCM column
)
1093 port
= SCM_COERCE_OUTPORT (port
);
1094 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1097 s_set_port_column_x
);
1098 SCM_ASSERT (SCM_INUMP (column
), column
, SCM_ARG2
, s_set_port_column_x
);
1099 return SCM_PTAB_ENTRY (port
)->column_number
= SCM_INUM (column
);
1102 SCM_PROC (s_port_filename
, "port-filename", 1, 0, 0, scm_port_filename
);
1105 scm_port_filename (SCM port
)
1107 port
= SCM_COERCE_OUTPORT (port
);
1108 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1112 return SCM_PTAB_ENTRY (port
)->file_name
;
1115 SCM_PROC (s_set_port_filename_x
, "set-port-filename!", 2, 0, 0, scm_set_port_filename_x
);
1118 scm_set_port_filename_x (SCM port
, SCM filename
)
1120 port
= SCM_COERCE_OUTPORT (port
);
1121 SCM_ASSERT (SCM_NIMP (port
) && SCM_PORTP (port
) && SCM_OPENP (port
),
1124 s_set_port_filename_x
);
1125 /* We allow the user to set the filename to whatever he likes. */
1126 return SCM_PTAB_ENTRY (port
)->file_name
= filename
;
1130 extern char * ttyname();
1134 scm_print_port_mode (SCM exp
, SCM port
)
1136 scm_puts (SCM_CLOSEDP (exp
)
1138 : (SCM_RDNG
& SCM_CAR (exp
)
1139 ? (SCM_WRTNG
& SCM_CAR (exp
)
1142 : (SCM_WRTNG
& SCM_CAR (exp
)
1149 scm_port_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
1151 char *type
= SCM_PTOBNAME (SCM_PTOBNUM (exp
));
1154 scm_puts ("#<", port
);
1155 scm_print_port_mode (exp
, port
);
1156 scm_puts (type
, port
);
1157 scm_putc (' ', port
);
1158 scm_intprint (SCM_CDR (exp
), 16, port
);
1159 scm_putc ('>', port
);
1163 extern void scm_make_fptob ();
1164 extern void scm_make_stptob ();
1165 extern void scm_make_sfptob ();
1168 scm_ports_prehistory ()
1171 scm_ptobs
= (scm_ptob_descriptor
*) malloc (sizeof (scm_ptob_descriptor
));
1173 /* WARNING: These scm_newptob calls must be done in this order.
1174 * They must agree with the port declarations in tags.h.
1176 /* scm_tc16_fport = */ scm_make_fptob ();
1177 /* scm_tc16_pipe was here */ scm_make_fptob (); /* dummy. */
1178 /* scm_tc16_strport = */ scm_make_stptob ();
1179 /* scm_tc16_sfport = */ scm_make_sfptob ();
1186 long scm_tc16_void_port
= 0;
1189 flush_void_port (SCM port
)
1194 end_input_void_port (SCM port
, int offset
)
1199 write_void_port (SCM port
, void *data
, size_t size
)
1204 scm_void_port (char *mode_str
)
1210 SCM_NEWCELL (answer
);
1212 mode_bits
= scm_mode_bits (mode_str
);
1213 pt
= scm_add_to_port_table (answer
);
1214 SCM_SETPTAB_ENTRY (answer
, pt
);
1215 SCM_SETSTREAM (answer
, 0);
1216 SCM_SETCAR (answer
, scm_tc16_void_port
| mode_bits
);
1222 SCM_PROC (s_sys_make_void_port
, "%make-void-port", 1, 0, 0, scm_sys_make_void_port
);
1225 scm_sys_make_void_port (SCM mode
)
1227 SCM_ASSERT (SCM_NIMP (mode
) && SCM_ROSTRINGP (mode
), mode
,
1228 SCM_ARG1
, s_sys_make_void_port
);
1230 SCM_COERCE_SUBSTR (mode
);
1231 return scm_void_port (SCM_ROCHARS (mode
));
1235 /* Initialization. */
1240 /* lseek() symbols. */
1241 scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET
));
1242 scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR
));
1243 scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END
));
1245 scm_tc16_void_port
= scm_make_port_type ("void", 0, write_void_port
);