mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 20:30:28 +02:00
Code Activity

* ioext.c (scm_do_read_line): Rewritten to use memchr to find the

Browse source 
newline.  A bit faster, and definitely hairier.
	(scm_read_line): Count newlines here instead.
	* strings.c (scm_take_str): New function.
	(scm_take0str): Reimplement in terms of scm_take_str.  * strings.h
	(scm_take_str): New declaration.  * ioext.c (scm_read_line): Use
	scm_take_str, to avoid copying the string.
	Add some simple-minded support for line buffered ports.
	* ports.h (SCM_BUFLINE): New flag for ports.
	* init.c (scm_init_standard_ports): Request line-buffering on
	the standard output port.
*	* ports.c (scm_mode_bits): Recognize 'l' as a request for line
	buffering.
	(scm_putc, scm_puts, scm_lfwrite): If the port is line-buffered,
	and there's a newline to be written, flush the port.
	* ports.c: (scm_lseek): clear buffers even if just reading current
	position.
	* fports.c (local_fclose): call local_fflush unconditionally.
	(various): don't use the scm_must... memory procs.
	* ports.h (scm_port): make read_pos a pointer to const.
	strports.c: take care of rw_active and rw_randow.
	fports.c: scm_fport_drain_input: removed.  do it all in ports.c.
	strports.c (scm_mkstrport): check that pos is reasonable.
	ioext.c (scm_ftell, scm_fseek): use lseek.
	(SCM_CLEAR_BUFFERS): macro deleted.
	ioext.c (redirect_port: use ptob fflush, read_flush.
	ports.h (scm_ptobfuns): add ftruncate.
	ports.c (scm_newptob): set ftruncate.
	adjust ptob tables.
*	ports.c (scm_ftruncate): new procedure.
	fports.c (local_ftrunate), strports.c (str_ftruncate): new procs.
	strports.c (st_seek, st_grow_port): new procs.
	fports.h (scm_port): change size types from int to off_t.
	ports.c (scm_init_ports): initialise the seek symbols here
	instead of in ioext.c.
	strports.c (scm_call_with_output_string): start with an empty
	string, so seek and ftruncate can be used.
	* ports.h (scm_ptobfuns): add a read_flush procedure which is the
	equivalent to fflush for the read buffer.
	* ports.c (scm_newptob): set read_flush.
	ports.c (void_port_ptob): set read_flush.
	fports.c (local_read_flush): new proc.  add to ptob.
	strport.c (st_read_flush): likewise.
	vport.c (sf_read_flush): likewise.
	fports.h (struct scm_fport): remove random member.  there's nothing
	left but fdes.  leaving it as a struct to allow for future changes.
	fports.c: replace usage of scm_fport::random with scm_port::rw_random.
	ports.c: (scm_putc, scm_puts, scm_lfwrite): call the read_flush
	ptob proc if the read buffer is filled.
	* ports.h (scm_port): add a rw_random member and replace
	reading and writing members with rw_active member.
	SCM_PORT_READ/SCM_PORT_WRITE: new values.
	* ports.h (struct scm_port_table): add writing and reading members
	to replace write_needs_seek: it isn't good enough for non-fports.
	ports.c, ioext.c, fports.c: corresponding changes.
	(struct scm_port_table): give it a typedef and rename to scm_port.
	ports.c, fports.c, strports.c, vports.c, ioext.c, ports.h:
	corresponding changes.
	* ports.c (scm_newptob): bugfix: set seek member.
*	* (scm_lseek): new procedure, using code from ioext.c:scm_fseek
	and generalised to all port types.
	* scmsigs.c (scm_init_scmsigs): set the SA_RESTART flag for all
	signals (it was only being done for handlers installed from Scheme).
	Otherwise (for example) SIGSTOP followed by SIGCONT on an interpreter
	waiting for input caused an EINTR error from read.
	* ports.h (struct scm_port_table): make all the char members
	unsigned, so they convert to int without becoming negative if large.
	* fports.c (scm_fdes_wait_for_input): forgot to check compilation
	with threads enabled.  rename this procedure to
	fport_wait_for_input and take a port instead of a fdes.
	use scm_fport_input_waiting_p instead of scm_fdes_waiting_p.
	* readline.c (scm_readline): Applied a patch from Greg Harvey to
	get readline support working again: use fdopen to get FILE objects.
	* gc.c (scm_init_storage): install an atexit proc to flush the
	ports.
	(cleanup): the new proc.  it sets a global variable which can be
	checked by the ptob flush procs to avoid trying to throw
	exceptions during exit.  not very pleasant but it seems more reliable.
	* fports.c (local_fflush): check terminating variable and if set
	don't throw exception.
	* CHECKME: that the atexit proc is installed if unexec used.
	* throw.c (scm_handle_by_message): don't flush all ports here.
	it still causes bus errors.
	* fports.h (SCM_FPORT_CLEAR_BUFFERS): rename to SCM_CLEAR_BUFFERS
	and move to ioext.c.
	* fports.c (scm_fdes_waiting_p): merged into fport_input_waiting_p.
	* ports.c (scm_char_ready_p): check the port buffer and call the
	ptob entry if needed.
	* ports.h (scm_ptobfuns): input_waiting_p added.  change all the
	ptob initialisers.  use it in char-ready
	* ioext.c (scm_do_read_line): moved from ports.c.  make it static.
	* vports.c (sfflush): modified to write a char (since softports
	currently use shortbuf.)
	* fports.c (scm_standard_stream_to_port): moved to init.c and
	made static.
	* init.c (scm_init_standard_ports): make stdout and stderr
	unbuffered if connected to a terminal.  with stdio they
	were line-buffered by default.
	* ports.h (scm_ptobfuns): change fflush return to void.
	change flush proc definitions.
	* strports.c (scm_call_with_output_string): get size from
	buffer instead of port stream.
	(scm_strprint_obj): likewise.
	(st_flush): new proc.
	* ports.h (struct scm_port_table): added write_end member,
	as an optimisation.  set it where write_buf_size is set.
	* ports.h (struct scm_port_table): change stream from void *
	back to SCM.  SCM presumably must be large enough to hold a
	pointer (and probably vice versa but who knows.)
	(SCM_SSTREAM): deleted.  change users back to SCM_STREAM.
	(scm_puts): rewritten
	* fports.c (local_ffwrite, local_fputs): removed.
	* strports.c (stputc, stputs, stwrite): dyked out (FIXME)
	* vports.c (sfputc, sfputs, sfwrite) likewise.
	* ports.c (write_void_port, puts_void_port): removed.
	(putc_void_port, getc_void_port, fgets_void_port): likewise.
	* ports.c (scm_lfwrite): rewritten using fport.c version.
	* fports.c (local_fputc): deleted.
	* ports.c (scm_add_to_port_table): initialise write_needs_seek.
	* ports.h (scm_ptobfuns): add seek function pointer.
	* fports.c: set it to local_seek, new procedure.
	* fports.h (SCM_MAYBE_DRAIN_INPUT): moved to ports.c.
	use ptob for seek. take ptob instead of fport arg.
	* ports.h (struct scm_port_table): new member write_needs_seek,
	replaces reading member in fport struct.
	* vports.c (sfgetc): store the getted char into the buffer.
	rename to sf_fill_buffer and install it for fill-buffer in ptob.
	the Scheme interface is still a	procedure that gets a char.
	(scm_make_soft_port): set up the port buffer (shortbuf).
	* fports.c (local_fgetc, local_fgets): deleted.
	* strports.c (stgetc): likewise.
	* ports.c: scm_generic_fgets: likewise.
	* ports.h (scm_ptobfuns): add fill_buffer.
	* ports.c (scm_newptob): assign it.
	* strports.c (scm_mkstrport): set up the buffer.
	put just the string into the stream, not cons (pos stream).
	(stfill_buffer): new proc.
	* ports.h: fport buffer moved into port table: to be
	used for all port types.
	* throw.c (scm_handle_by_message): flush ports at exit.
	* socket.c (scm_sock_fd_to_port): use scm_fdes_to_port.
	(scm_getsockopt, scm_setsockopt, scm_shutdown, scm_connect,
	scm_bind, scm_listen, scm_accept, scm_getsockname,
	scm_getpeername, scm_recv, scm_send, scm_recvfrom,
	scm_sendto,
	use SCM_FPORT_FDES.  use SCM_OPFPORTP not SCM_FPORTP.
	* posix.c (scm_getgroups): use SCM_ALLOW/DEFER_INTS.
	(scm_ttyname): use SCM_FPORT_FDES.
	(scm_tcgetpgrp, scm_tcsetpgrp): likewise.
	* ioext.c (scm_isatty_p): use SCM_FPORT_FDES.
	(scm_fdes_to_ports): modified.
	(scm_fdopen): use scm_fdes_to_port.
	* ports.c (scm_init_ports): don't try to flush ports using
	atexit().  it's too late, errors will cause SEGV.
	* fports.c (scm_fport_buffer_add): new procedure.
	* fports.h (SCM_FDES_RANDOM_P): new macro.  use it in
	scm_fdes_to_port and scm_redirect_port.
	* ioext.c (scm_redirect_port): use setvbuf to set buffers in the
	new port.  reset fp->random.
	* fports.c (scm_fdes_to_port), ports.c (scm_void_port),
	filesys.c (scm_opendir):
	restore defer interrupts while the port is constructed.
*	(scm_setvbuf): if mode is _IOFBF and size is not supplied,
	derive buffer size from fdes or use a default.
	(scm_fdes_to_port): use setvbuf instead of creating the buffers
	directly.
	vports.c (various places): use SCM_SSTREAM.
	strports.c: likewise.
	* gdbint.c: likewise.
	* ports.h (SCM_SSTREAM): new macro.
	* fports.c (scm_input_waiting_p): use scm_return_first, since port
	may be removed from the stack by the tail call to scm_fdes_waiting_p.
	* fports.h (SCM_CLEAR_BUFFERS): new macro.
	* ports.c (scm_force_output): call scm_fflush.
	* print.c (scm_newline): don't check errno for EPIPE (it wouldn't
*	reach this point.)  don't flush port (if scm_cur_outp).
	* fports.h (SCM_FPORT_FDES): new macro.
	* vports.c (sfflush): don't need to set errno.
	* ports.c: install scm_flush_all_ports to be run on exit.
	ports.c fports.c ioext.c posix.c socket.c net_db.c filesys.c:
	removed all uses of SCM_DEFER/ALLOW ints for now.  they were mainly
	just protecting errno.  some may need to be put back.
	* scmsigs.c (take_signal): save and restore errno while this
	proc runs.
	*fports.c (print_pipe_port, local_pclose, scm_pipob): deleted.
*	open-pipe, close-pipe are emulated in (ice-9 popen)
	ports.c (scm_ports_prehistory): don't init scm_pipob.
	ports.h (scm_tc16_pipe): deleted.
	posix.c (scm_open_pipe, scm_close_pipe): deleted.
	* ioext.c (scm_primitive_move_to_fdes): use fport.
	* fport.c (scm_fport_fill_buffer): flush write buffer if needed.
	change arg type from scm_fport to SCM port.
	fport.h (SCM_SETFDES): removed.
	(SCM_MAYBE_DRAIN_INPUT): new macro.
	* ioext.c (scm_dup_to_fdes): use SCM_FSTREAM.
	(scm_ftell): always use lseek and account for the buffer.
	(scm_fileno): use fport buffer.
	(scm_fseek): clear fport buffers.  always use lseek.
	* posix.c (scm_pipe): use fport buffer.
	* unif.c: include fports.h instead of genio.h.
	* fports.c (scm_fdes_wait_for_input, scm_fport_fill_buffer): new
	procedures.
	(local_fgetc): use them.
	(local_ffwrite): use buffer.
	(local_fgets): use buffer.
	(scm_setbuf0): deleted.
	(scm_setvbuf): set the buffer.
	(scm_setfileno): deleted.
	(scm_evict_ports): set fdes directly.
*	(scm_freopen): deleted.  doesn't seem useful in Guile.
	(scm_stdio_to_port): deleted.
	fports.h (struct scm_fport): add shortbuf member to avoid separate
	code for unbuffered ports.
	(SCM_FPORTP, SCM_OPFPORTP, SCM_OPINFPORTP, SCM_OPOUTFPORTP): moved
	from ports.h.
	* genio.c, genio.h: move contents into ports.c, ports.h.  The
	division wasn't useful.
	* fports.c, fports.h (scm_fport_drain_input): new procedure.
	* ports.c (scm_drain_input): call scm_fport_drain_input.
	* scm_fdes_waiting_p: new procedure.
	* fports.c (scm_fdes_to_port): allocate read and/or write buffers.
	(scm_input_waiting_p): check the buffer.
	(local_fgetc, local_fflush, local_fputc): likewise.
	* fports.h (scm_fport): read/write_buf,_pos,_buf_end,,_buf_size:
	new members.
	* init.c (scm_init_standard_ports): pass fdes instead of FILE *.
*	* ports.c (scm_drain_input): new procedure.
	ports.h: prototype.
	* fports.c (FPORT_READ_SAFE, FPORT_WRITE_SAFE, FPORT_ALL_OKAY,
	pre_read, pre_write): removed.
	(local_fputc, local_fputs, local_ffwrite): use write, not stdio.
	(scm_standard_stream_to_port): change first arg from FILE * to
	int fdes.
	(local_fflush): flush fdes, not FILE *.
	* fports.h (SCM_NOFTELL): removed.
	* genio.c, ports.c: don't include filesys.h.
	* genio.c (scm_getc): don't use scm_internal_select if FPORT.
	do it in fports.c:local_fgetc.
	* genio.c: don't use SCM_SYSCALL when calling ptob procedures.
	do it where it's needed in the port smobs.
	* filesys.c (scm_input_waiting_p): moved to fports.c, stdio
	  buffer support removed.  take SCM arg, not FILE *.
	* filesys.h: prototype moved too.
	* fports.c (scm_fdes_to_port): new procedure.
	(local_fgetc): use read not fgetc.
	(local_fclose): use close, not fclose.
	(local_fgets): use read, not fgets
	* fports.h: prototype for scm_fdes_to_port.
	* fports.h (scm_fport): new struct.
	* fports.c (scm_open_file): use open, not fopen.
	#include fcntl.h
	* ports.h (struct scm_port_table): change stream from SCM to void *.
	* ports.c (scm_add_to_port_table): check for memory allocation error.
	(scm_prinport): remove MSDOS hair.
	(scm_void_port): set stream to 0 instead of SCM_BOOL_F.
	(scm_close_port): don't throw errors: do it in fports.c.
This commit is contained in:
Jim Blandy 1999-06-09 12:19:58 +00:00
parent 1c3abaea89
commit ee149d0368
19 changed files with 759 additions and 1146 deletions
Download patch file Download diff file Expand all files Collapse all files

61
libguile/genio.h
View file

@ -1,61 +0,0 @@
/* classes: h_files */
#ifndef GENIOH
#define GENIOH
/* Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* The exception is that, if you link the GUILE library with other files
* to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the GUILE library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the
* Free Software Foundation under the name GUILE. If you copy
* code from other Free Software Foundation releases into a copy of
* GUILE, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
#include "libguile/__scm.h"
extern void scm_putc SCM_P ((int c, SCM port));
extern void scm_puts SCM_P ((char *str_data, SCM port));
extern void scm_lfwrite SCM_P ((char *ptr, scm_sizet size, SCM port));
extern void scm_fflush SCM_P ((SCM port));
extern int scm_getc SCM_P ((SCM port));
extern void scm_ungetc SCM_P ((int c, SCM port));
extern void scm_ungets SCM_P ((char *s, int n, SCM port));
/* FIXME: this is a terrible name. */
extern char *scm_do_read_line SCM_P ((SCM port, int *len));
#endif /* GENIOH */

29
libguile/init.c
View file

@ -252,7 +252,19 @@ check_config ()
/* initializing standard and current I/O ports */
/* Create standard ports from stdio stdin, stdout, and stderr. */
/* Like scm_fdes_to_port, except that:
- NAME is a standard C string, not a Guile string
- we set the revealed count for FILE's file descriptor to 1, so
that fdes won't be closed when the port object is GC'd. */
static SCM
scm_standard_stream_to_port (int fdes, char *mode, char *name)
{
SCM port = scm_fdes_to_port (fdes, mode, scm_makfrom0str (name));
scm_set_port_revealed_x (port, SCM_MAKINUM (1));
return port;
}
/* Create standard ports from stdin, stdout, and stderr. */
static void
scm_init_standard_ports ()
{
@ -269,12 +281,19 @@ scm_init_standard_ports ()
and scsh, read stdin unbuffered. Applications that can tolerate
buffered input on stdin can reset \ex{(current-input-port)} to
block buffering for higher performance. */
/* stdout and stderr are also now unbuffered if connected to
a terminal, since line buffered output is no longer available. */
scm_def_inp
= scm_standard_stream_to_port (stdin,
(isatty (fileno (stdin)) ? "r0" : "r"),
= scm_standard_stream_to_port (0,
isatty (0) ? "r0" : "r",
"standard input");
scm_def_outp = scm_standard_stream_to_port (stdout, "w", "standard output");
scm_def_errp = scm_standard_stream_to_port (stderr, "w", "standard error");
scm_def_outp = scm_standard_stream_to_port (1,
isatty (1) ? "wl" : "w",
"standard output");
scm_def_errp = scm_standard_stream_to_port (2,
isatty (2) ? "w0" : "w",
"standard error");
scm_cur_inp = scm_def_inp;
scm_cur_outp = scm_def_outp;

317
libguile/ioext.c
View file

@ -43,7 +43,7 @@
#include <stdio.h>
#include "_scm.h"
#include "genio.h"
#include "ports.h"
#include "read.h"
#include "fports.h"
#include "unif.h"
@ -51,6 +51,8 @@
#include "ioext.h"
#include <fcntl.h>
#ifdef HAVE_STRING_H
#include <string.h>
#endif
@ -138,8 +140,144 @@ scm_read_delimited_x (delims, buf, gobble, port, start, end)
return scm_cons (SCM_BOOL_F, scm_long2num (j - cstart));
}
static unsigned char *
scm_do_read_line (SCM port, int *len_p)
{
struct scm_port_table *pt = SCM_PTAB_ENTRY (port);
unsigned char *end;
/* I thought reading lines was simple. Mercy me. */
/* If there are any pushed-back characters, read the line character
by character. */
if (SCM_CRDYP (port))
{
int buf_size = 60;
/* Invariant: buf always has buf_size + 1 characters allocated;
the `+ 1' is for the final '\0'. */
unsigned char *buf = malloc (buf_size + 1);
int buf_len = 0;
int c;
while ((c = scm_getc (port)) != EOF)
{
if (buf_len >= buf_size)
{
buf = realloc (buf, buf_size * 2 + 1);
buf_size *= 2;
}
buf[buf_len++] = c;
if (c == '\n')
break;
}
/* Since SCM_CRDYP returned true, we ought to have gotten at
least one character. */
if (buf_len == 0)
abort ();
buf[buf_len] = '\0';
*len_p = buf_len;
return buf;
}
/* The common case: no unread characters, and the buffer contains
a complete line. This needs to be fast. */
if ((end = memchr (pt->read_pos, '\n', (pt->read_end - pt->read_pos)))
!= 0)
{
int buf_len = (end + 1) - pt->read_pos;
/* Allocate a buffer of the perfect size. */
unsigned char *buf = malloc (buf_len + 1);
memcpy (buf, pt->read_pos, buf_len);
pt->read_pos += buf_len;
buf[buf_len] = '\0';
*len_p = buf_len;
return buf;
}
/* There are no unread characters, and the buffer contains no newlines. */
{
/* When live, len is always the number of characters in the
current buffer that are part of the current line. */
int len = (pt->read_end - pt->read_pos);
int buf_size = (len < 50) ? 60 : len * 2;
/* Invariant: buf always has buf_size + 1 characters allocated;
the `+ 1' is for the final '\0'. */
unsigned char *buf = malloc (buf_size + 1);
int buf_len = 0;
int c;
for (;;)
{
if (buf_len + len > buf_size)
{
int new_size = (buf_len + len) * 2;
buf = realloc (buf, new_size + 1);
buf_size = new_size;
}
/* Copy what we've got out of the port, into our buffer. */
memcpy (buf + buf_len, pt->read_pos, len);
buf_len += len;
pt->read_pos += len;
/* If we had seen a newline, we're done now. */
if (end)
break;
/* Get more characters. I think having fill_buffer return a
character is not terribly graceful... */
c = (scm_ptobs[SCM_PTOBNUM (port)].fill_buffer) (port);
if (c == EOF)
{
/* If we're missing a final newline in the file, return
what we did get, sans newline. */
if (buf_len > 0)
break;
free (buf);
return 0;
}
/* ... because it makes us duplicate code here... */
if (buf_len + 1 > buf_size)
{
int new_size = buf_size * 2;
buf = realloc (buf, new_size + 1);
buf_size = new_size;
}
/* ... and this is really a duplication of the memcpy and
memchr calls, on a single-byte buffer. */
buf[buf_len++] = c;
if (c == '\n')
break;
/* Search the buffer for newlines. */
if ((end = memchr (pt->read_pos, '\n',
(len = (pt->read_end - pt->read_pos))))
!= 0)
len = (end - pt->read_pos) + 1;
}
/* I wonder how expensive this realloc is. */
buf = realloc (buf, buf_len + 1);
buf[buf_len] = '\0';
*len_p = buf_len;
return buf;
}
}
/*
* %read-line uses a port's fgets method for fast line i/o. It
* %read-line
* truncates any terminating newline from its input, and returns
* a cons of the string read and its terminating character. Doing
* so makes it easy to implement the hairy `read-line' options
@ -173,15 +311,16 @@ scm_read_line (port)
if (s[slen-1] == '\n')
{
term = SCM_MAKICHR ('\n');
line = scm_makfromstr (s, slen-1, 0);
s[slen-1] = '\0';
line = scm_take_str (s, slen-1);
SCM_INCLINE (port);
}
else
{
/* Fix: we should check for eof on the port before assuming this. */
term = SCM_EOF_VAL;
line = scm_makfromstr (s, slen, 0);
line = scm_take_str (s, slen);
}
free (s);
}
return scm_cons (line, term);
@ -204,29 +343,57 @@ SCM
scm_ftell (object)
SCM object;
{
long pos;
object = SCM_COERCE_OUTPORT (object);
SCM_DEFER_INTS;
if (SCM_NIMP (object) && SCM_OPFPORTP (object))
if (SCM_INUMP (object))
{
SCM_SYSCALL (pos = ftell ((FILE *)SCM_STREAM (object)));
if (pos > 0 && SCM_CRDYP (object))
pos -= SCM_N_READY_CHARS (object);
int fdes = SCM_INUM (object);
fpos_t pos;
pos = lseek (fdes, 0, SEEK_CUR);
if (pos == -1)
scm_syserror (s_ftell);
return scm_long2num (pos);
}
else
{
SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_ftell);
SCM_SYSCALL (pos = lseek (SCM_INUM (object), 0, SEEK_CUR));
struct scm_fport *fp;
struct scm_port_table *pt;
int fdes;
fpos_t pos;
object = SCM_COERCE_OUTPORT (object);
SCM_ASSERT (SCM_NIMP (object) && SCM_OPFPORTP (object),
object, SCM_ARG1, s_ftell);
fp = SCM_FSTREAM (object);
pt = SCM_PTAB_ENTRY (object);
fdes = fp->fdes;
pos = lseek (fdes, 0, SEEK_CUR);
if (pos == -1)
scm_syserror (s_ftell);
/* the seek will only have succeeded if fdes is random access,
in which case only one buffer can be filled. */
if (pt->write_pos > pt->write_buf)
{
pos += pt->write_pos - pt->write_buf;
}
else
{
pos -= pt->read_end - pt->read_pos;
if (SCM_CRDYP (object))
pos -= SCM_N_READY_CHARS (object);
}
return scm_long2num (pos);
}
if (pos < 0)
scm_syserror (s_ftell);
SCM_ALLOW_INTS;
return scm_long2num (pos);
}
/* clear the three buffers in a port. */
#define SCM_CLEAR_BUFFERS(port, pt)\
{\
if (pt->write_pos > pt->write_buf)\
scm_fflush (port);\
pt->read_pos = pt->read_end = pt->read_buf;\
pt->write_needs_seek = 0;\
SCM_CLRDY (port);\
}
SCM_PROC (s_fseek, "fseek", 3, 0, 0, scm_fseek);
@ -243,20 +410,28 @@ scm_fseek (object, offset, whence)
loff = scm_num2long (offset, (char *)SCM_ARG2, s_fseek);
SCM_ASSERT (SCM_INUMP (whence), whence, SCM_ARG3, s_fseek);
SCM_DEFER_INTS;
if (SCM_NIMP (object) && SCM_OPFPORTP (object))
{
SCM_CLRDY (object); /* Clear ungetted char */
rv = fseek ((FILE *)SCM_STREAM (object), loff, SCM_INUM (whence));
struct scm_fport *fp = SCM_FSTREAM (object);
struct scm_port_table *pt = SCM_PTAB_ENTRY (object);
/* clear the three buffers. the write buffer should be flushed
before changing the position. */
if (fp->random)
{
SCM_CLEAR_BUFFERS (object, pt);
} /* if not random, lseek will fail. */
rv = lseek (fp->fdes, loff, SCM_INUM (whence));
if (rv == -1)
scm_syserror (s_fseek);
}
else
{
SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_fseek);
rv = lseek (SCM_INUM (object), loff, SCM_INUM (whence));
if (rv == -1)
scm_syserror (s_fseek);
}
if (rv < 0)
scm_syserror (s_fseek);
SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
@ -268,23 +443,31 @@ scm_redirect_port (old, new)
SCM new;
{
int ans, oldfd, newfd;
struct scm_fport *fp;
old = SCM_COERCE_OUTPORT (old);
new = SCM_COERCE_OUTPORT (new);
SCM_DEFER_INTS;
SCM_ASSERT (SCM_NIMP (old) && SCM_OPPORTP (old), old, SCM_ARG1, s_redirect_port);
SCM_ASSERT (SCM_NIMP (new) && SCM_OPPORTP (new), new, SCM_ARG2, s_redirect_port);
oldfd = fileno ((FILE *)SCM_STREAM (old));
if (oldfd == -1)
scm_syserror (s_redirect_port);
newfd = fileno ((FILE *)SCM_STREAM (new));
if (newfd == -1)
scm_syserror (s_redirect_port);
SCM_SYSCALL (ans = dup2 (oldfd, newfd));
if (ans == -1)
scm_syserror (s_redirect_port);
SCM_ALLOW_INTS;
SCM_ASSERT (SCM_NIMP (old) && SCM_OPFPORTP (old), old, SCM_ARG1, s_redirect_port);
SCM_ASSERT (SCM_NIMP (new) && SCM_OPFPORTP (new), new, SCM_ARG2, s_redirect_port);
oldfd = SCM_FPORT_FDES (old);
fp = SCM_FSTREAM (new);
newfd = fp->fdes;
if (oldfd != newfd)
{
struct scm_port_table *pt = SCM_PTAB_ENTRY (new);
/* must flush to old fdes. don't clear all buffers here
in case dup2 fails. */
if (pt->write_pos > pt->write_buf)
scm_fflush (new);
ans = dup2 (oldfd, newfd);
if (ans == -1)
scm_syserror (s_redirect_port);
fp->random = SCM_FDES_RANDOM_P (fp->fdes);
/* continue using existing buffers, even if inappropriate. */
SCM_CLEAR_BUFFERS (new, pt);
}
return SCM_UNSPECIFIED;
}
@ -296,21 +479,18 @@ scm_dup_to_fdes (SCM fd_or_port, SCM fd)
fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
SCM_DEFER_INTS;
if (SCM_INUMP (fd_or_port))
oldfd = SCM_INUM (fd_or_port);
else
{
SCM_ASSERT (SCM_NIMP (fd_or_port) && SCM_OPPORTP (fd_or_port),
SCM_ASSERT (SCM_NIMP (fd_or_port) && SCM_OPFPORTP (fd_or_port),
fd_or_port, SCM_ARG1, s_dup_to_fdes);
oldfd = fileno ((FILE *)SCM_STREAM (fd_or_port));
if (oldfd == -1)
scm_syserror (s_dup_to_fdes);
oldfd = SCM_FPORT_FDES (fd_or_port);
}
if (SCM_UNBNDP (fd))
{
SCM_SYSCALL (newfd = dup (oldfd));
newfd = dup (oldfd);
if (newfd == -1)
scm_syserror (s_dup_to_fdes);
fd = SCM_MAKINUM (newfd);
@ -322,12 +502,11 @@ scm_dup_to_fdes (SCM fd_or_port, SCM fd)
if (oldfd != newfd)
{
scm_evict_ports (newfd); /* see scsh manual. */
SCM_SYSCALL (rv = dup2 (oldfd, newfd));
rv = dup2 (oldfd, newfd);
if (rv == -1)
scm_syserror (s_dup_to_fdes);
}
}
SCM_ALLOW_INTS;
return fd;
}
@ -337,15 +516,10 @@ SCM
scm_fileno (port)
SCM port;
{
int fd;
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_fileno);
fd = fileno ((FILE *)SCM_STREAM (port));
if (fd == -1)
scm_syserror (s_fileno);
return SCM_MAKINUM (fd);
SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1,
s_fileno);
return SCM_MAKINUM (SCM_FPORT_FDES (port));
}
SCM_PROC (s_isatty, "isatty?", 1, 0, 0, scm_isatty_p);
@ -360,10 +534,8 @@ scm_isatty_p (port)
if (!(SCM_NIMP (port) && SCM_OPFPORTP (port)))
return SCM_BOOL_F;
rv = fileno ((FILE *)SCM_STREAM (port));
if (rv == -1)
scm_syserror (s_isatty);
rv = isatty (rv);
rv = isatty (SCM_FPORT_FDES (port));
return rv ? SCM_BOOL_T : SCM_BOOL_F;
}
@ -376,19 +548,13 @@ scm_fdopen (fdes, modes)
SCM fdes;
SCM modes;
{
FILE *f;
SCM port;
SCM_ASSERT (SCM_INUMP (fdes), fdes, SCM_ARG1, s_fdopen);
SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2,
s_fdopen);
SCM_COERCE_SUBSTR (modes);
SCM_DEFER_INTS;
f = fdopen (SCM_INUM (fdes), SCM_ROCHARS (modes));
if (f == NULL)
scm_syserror (s_fdopen);
port = scm_stdio_to_port (f, SCM_ROCHARS (modes), SCM_BOOL_F);
SCM_ALLOW_INTS;
port = scm_fdes_to_port (SCM_INUM (fdes), SCM_ROCHARS (modes), SCM_BOOL_F);
return port;
}
@ -406,7 +572,7 @@ scm_primitive_move_to_fdes (port, fd)
SCM port;
SCM fd;
{
FILE *stream;
struct scm_fport *stream;
int old_fd;
int new_fd;
int rv;
@ -415,22 +581,19 @@ scm_primitive_move_to_fdes (port, fd)
SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_primitive_move_to_fdes);
SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_primitive_move_to_fdes);
SCM_DEFER_INTS;
stream = (FILE *)SCM_STREAM (port);
old_fd = fileno (stream);
stream = SCM_FSTREAM (port);
old_fd = stream->fdes;
new_fd = SCM_INUM (fd);
if (old_fd == new_fd)
{
SCM_ALLOW_INTS;
return SCM_BOOL_F;
}
scm_evict_ports (new_fd);
rv = dup2 (old_fd, new_fd);
if (rv == -1)
scm_syserror (s_primitive_move_to_fdes);
scm_setfileno (stream, new_fd);
stream->fdes = new_fd;
SCM_SYSCALL (close (old_fd));
SCM_ALLOW_INTS;
return SCM_BOOL_T;
}
@ -448,14 +611,12 @@ scm_fdes_to_ports (fd)
SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG1, s_fdes_to_ports);
int_fd = SCM_INUM (fd);
SCM_DEFER_INTS;
for (i = 0; i < scm_port_table_size; i++)
{
if (SCM_FPORTP (scm_port_table[i]->port)
&& fileno ((FILE *)SCM_STREAM (scm_port_table[i]->port)) == int_fd)
if (SCM_OPFPORTP (scm_port_table[i]->port)
&& ((struct scm_fport *) scm_port_table[i]->stream)->fdes == int_fd)
result = scm_cons (scm_port_table[i]->port, result);
}
SCM_ALLOW_INTS;
return result;
}

23
libguile/net_db.c
View file

@ -102,10 +102,8 @@ scm_inet_ntoa (inetid)
char *s;
SCM answer;
addr.s_addr = htonl (scm_num2ulong (inetid, (char *) SCM_ARG1, s_inet_ntoa));
SCM_DEFER_INTS;
s = inet_ntoa (addr);
answer = scm_makfromstr (s, strlen (s), 0);
SCM_ALLOW_INTS;
return answer;
}
@ -174,7 +172,6 @@ scm_gethost (name)
int i = 0;
if (SCM_UNBNDP (name))
{
SCM_DEFER_INTS;
#ifdef HAVE_GETHOSTENT
entry = gethostent ();
#else
@ -188,23 +185,19 @@ scm_gethost (name)
afterwards doesn't cut it, because, on Linux, it seems to
try to contact some other server (YP?) and fails, which
is a benign failure. */
SCM_ALLOW_INTS;
return SCM_BOOL_F;
}
}
else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
{
SCM_COERCE_SUBSTR (name);
SCM_DEFER_INTS;
entry = gethostbyname (SCM_ROCHARS (name));
}
else
{
inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_gethost));
SCM_DEFER_INTS;
entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
}
SCM_ALLOW_INTS;
if (!entry)
{
char *errmsg;
@ -264,12 +257,10 @@ scm_getnet (name)
ve = SCM_VELTS (ans);
if (SCM_UNBNDP (name))
{
SCM_DEFER_INTS;
errno = 0;
entry = getnetent ();
if (! entry)
{
SCM_ALLOW_INTS;
if (errno)
scm_syserror (s_getnet);
else
@ -279,17 +270,14 @@ scm_getnet (name)
else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
{
SCM_COERCE_SUBSTR (name);
SCM_DEFER_INTS;
entry = getnetbyname (SCM_ROCHARS (name));
}
else
{
unsigned long netnum;
netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_getnet);
SCM_DEFER_INTS;
entry = getnetbyaddr (netnum, AF_INET);
}
SCM_ALLOW_INTS;
if (!entry)
scm_syserror_msg (s_getnet, "no such network %s",
scm_listify (name, SCM_UNDEFINED), errno);
@ -316,12 +304,10 @@ scm_getproto (name)
ve = SCM_VELTS (ans);
if (SCM_UNBNDP (name))
{
SCM_DEFER_INTS;
errno = 0;
entry = getprotoent ();
if (! entry)
{
SCM_ALLOW_INTS;
if (errno)
scm_syserror (s_getproto);
else
@ -331,17 +317,14 @@ scm_getproto (name)
else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
{
SCM_COERCE_SUBSTR (name);
SCM_DEFER_INTS;
entry = getprotobyname (SCM_ROCHARS (name));
}
else
{
unsigned long protonum;
protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_getproto);
SCM_DEFER_INTS;
entry = getprotobynumber (protonum);
}
SCM_ALLOW_INTS;
if (!entry)
scm_syserror_msg (s_getproto, "no such protocol %s",
scm_listify (name, SCM_UNDEFINED), errno);
@ -367,7 +350,6 @@ scm_return_entry (entry)
ve[1] = scm_makfromstrs (-1, entry->s_aliases);
ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L);
ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0);
SCM_ALLOW_INTS;
return ans;
}
@ -382,10 +364,8 @@ scm_getserv (name, proto)
struct servent *entry;
if (SCM_UNBNDP (name))
{
SCM_DEFER_INTS;
errno = 0;
entry = getservent ();
SCM_ALLOW_INTS;
if (!entry)
{
if (errno)
@ -400,19 +380,16 @@ scm_getserv (name, proto)
if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
{
SCM_COERCE_SUBSTR (name);
SCM_DEFER_INTS;
entry = getservbyname (SCM_ROCHARS (name), SCM_ROCHARS (proto));
}
else
{
SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_getserv);
SCM_DEFER_INTS;
entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (proto));
}
if (!entry)
scm_syserror_msg (s_getserv, "no such service %s",
scm_listify (name, SCM_UNDEFINED), errno);
SCM_ALLOW_INTS;
return scm_return_entry (entry);
}
#endif

451
libguile/ports.c
View file

@ -46,7 +46,6 @@
#include "genio.h"
#include "chars.h"
#include "filesys.h"
#include "fports.h"
#include "strports.h"
#include "vports.h"
@ -78,7 +77,7 @@
scm_ptobfuns *scm_ptobs;
int scm_numptob;
/* GC marker for a port with stream of SCM type. */
SCM
scm_markstream (ptr)
SCM ptr;
@ -92,7 +91,6 @@ scm_markstream (ptr)
}
long
scm_newptob (ptob)
scm_ptobfuns *ptob;
@ -100,8 +98,7 @@ scm_newptob (ptob)
char *tmp;
if (255 <= scm_numptob)
goto ptoberr;
SCM_DEFER_INTS;
SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) * sizeof (scm_ptobfuns)));
tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) * sizeof (scm_ptobfuns));
if (tmp)
{
scm_ptobs = (scm_ptobfuns *) tmp;
@ -109,16 +106,12 @@ scm_newptob (ptob)
scm_ptobs[scm_numptob].free = ptob->free;
scm_ptobs[scm_numptob].print = ptob->print;
scm_ptobs[scm_numptob].equalp = ptob->equalp;
scm_ptobs[scm_numptob].fputc = ptob->fputc;
scm_ptobs[scm_numptob].fputs = ptob->fputs;
scm_ptobs[scm_numptob].fwrite = ptob->fwrite;
scm_ptobs[scm_numptob].fflush = ptob->fflush;
scm_ptobs[scm_numptob].fgetc = ptob->fgetc;
scm_ptobs[scm_numptob].fgets = ptob->fgets;
scm_ptobs[scm_numptob].fclose = ptob->fclose;
scm_ptobs[scm_numptob].fill_buffer = ptob->fill_buffer;
scm_ptobs[scm_numptob].input_waiting_p = ptob->input_waiting_p;
scm_numptob++;
}
SCM_ALLOW_INTS;
if (!tmp)
ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob), (char *) SCM_NALLOC, "newptob");
return scm_tc7_port + (scm_numptob - 1) * 256;
@ -138,13 +131,61 @@ scm_char_ready_p (port)
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1,
s_char_ready_p);
if (SCM_CRDYP (port) || !SCM_FPORTP (port))
if (SCM_CRDYP (port))
return SCM_BOOL_T;
return (scm_input_waiting_p ((FILE *) SCM_STREAM (port), s_char_ready_p)
? SCM_BOOL_T
: SCM_BOOL_F);
else
{
struct scm_port_table *pt = SCM_PTAB_ENTRY (port);
if (pt->read_pos < pt->read_end)
return SCM_BOOL_T;
else
{
scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
if (ptob->input_waiting_p)
return ((ptob->input_waiting_p) (port)) ? SCM_BOOL_T : SCM_BOOL_F;
else
return SCM_BOOL_T;
}
}
}
/* Clear a port's read buffer, returning the contents. */
SCM_PROC (s_drain_input, "drain-input", 1, 0, 0, scm_drain_input);
SCM
scm_drain_input (SCM port)
{
char *fp_buf = NULL;
int fp_count = 0;
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1,
s_drain_input);
if (SCM_FPORTP (port))
{
fp_buf = scm_fport_drain_input (port, &fp_count);
}
{
int p_count = (SCM_CRDYP (port)) ? SCM_N_READY_CHARS (port) : 0;
SCM result = scm_makstr (p_count + fp_count, 0);
char *dst = SCM_CHARS (result);
char *p_buf = SCM_PTAB_ENTRY (port)->cp;
while (p_count > 0)
{
*dst++ = *p_buf--;
p_count--;
}
while (fp_count > 0)
{
*dst++ = *fp_buf++;
fp_count--;
}
SCM_CLRDY (port);
return result;
}
}
/* Standard ports --- current input, output, error, and more(!). */
@ -224,13 +265,12 @@ scm_set_current_error_port (port)
/* The port table --- a table of all the open ports. */
/* Array of open ports, required for reliable MOVE->FDES etc. */
struct scm_port_table **scm_port_table;
int scm_port_table_size = 0; /* Number of ports in scm_port_table. */
int scm_port_table_room = 20; /* Size of the array. */
/* Add a port to the table. Call with SCM_DEFER_INTS active. */
/* Add a port to the table. */
struct scm_port_table *
scm_add_to_port_table (port)
@ -238,11 +278,14 @@ scm_add_to_port_table (port)
{
if (scm_port_table_size == scm_port_table_room)
{
scm_port_table = ((struct scm_port_table **)
realloc ((char *) scm_port_table,
(scm_sizet) (sizeof (struct scm_port_table *)
* scm_port_table_room * 2)));
/* !!! error checking */
void *newt = realloc ((char *) scm_port_table,
(scm_sizet) (sizeof (struct scm_port_table *)
* scm_port_table_room * 2));
if (newt == NULL)
{
scm_memory_error ("scm_add_to_port_table");
}
scm_port_table = (struct scm_port_table **) newt;
scm_port_table_room *= 2;
}
scm_port_table[scm_port_table_size] = ((struct scm_port_table *)
@ -259,10 +302,11 @@ scm_add_to_port_table (port)
= scm_port_table[scm_port_table_size]->cbuf;
scm_port_table[scm_port_table_size]->cbufend
= &scm_port_table[scm_port_table_size]->cbuf[SCM_INITIAL_CBUF_SIZE];
scm_port_table[scm_port_table_size]->write_needs_seek = 0;
return scm_port_table[scm_port_table_size++];
}
/* Remove a port from the table. Call with SCM_DEFER_INTS active. */
/* Remove a port from the table. */
void
scm_remove_from_port_table (port)
@ -371,9 +415,7 @@ scm_set_port_revealed_x (port, rcount)
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_set_port_revealed_x);
SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x);
SCM_DEFER_INTS;
SCM_REVEALED (port) = SCM_INUM (rcount);
SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
@ -396,7 +438,8 @@ scm_mode_bits (modes)
| ( strchr (modes, 'w')
|| strchr (modes, 'a')
|| strchr (modes, '+') ? SCM_WRTNG : 0)
| (strchr (modes, '0') ? SCM_BUF0 : 0));
| (strchr (modes, '0') ? SCM_BUF0 : 0)
| (strchr (modes, 'l') ? SCM_BUFLINE : 0));
}
@ -452,19 +495,12 @@ scm_close_port (port)
if (SCM_CLOSEDP (port))
return SCM_BOOL_F;
i = SCM_PTOBNUM (port);
SCM_DEFER_INTS;
if (scm_ptobs[i].fclose)
{
SCM_SYSCALL (rv = (scm_ptobs[i].fclose) (port));
/* ports with a closed file descriptor can be reclosed without error. */
if (rv < 0 && errno != EBADF)
scm_syserror (s_close_port);
}
rv = (scm_ptobs[i].fclose) (port);
else
rv = 0;
scm_remove_from_port_table (port);
SCM_SETAND_CAR (port, ~SCM_OPN);
SCM_ALLOW_INTS;
return (rv < 0) ? SCM_BOOL_F : SCM_BOOL_T;
}
@ -476,7 +512,6 @@ scm_close_all_ports_except (ports)
{
int i = 0;
SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except);
SCM_DEFER_INTS;
while (i < scm_port_table_size)
{
SCM thisport = scm_port_table[i]->port;
@ -498,7 +533,6 @@ scm_close_all_ports_except (ports)
/* i is not to be incremented here. */
scm_close_port (thisport);
}
SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
@ -552,11 +586,8 @@ scm_force_output (port)
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1,
s_force_output);
}
{
scm_sizet i = SCM_PTOBNUM (port);
SCM_SYSCALL ((scm_ptobs[i].fflush) (port));
return SCM_UNSPECIFIED;
}
scm_fflush (port);
return SCM_UNSPECIFIED;
}
SCM_PROC (s_flush_all_ports, "flush-all-ports", 0, 0, 0, scm_flush_all_ports);
@ -567,12 +598,8 @@ scm_flush_all_ports (void)
for (i = 0; i < scm_port_table_size; i++)
{
SCM port = scm_port_table[i]->port;
if (SCM_OPOUTPORTP (port))
{
scm_sizet ptob = SCM_PTOBNUM (port);
(scm_ptobs[ptob].fflush) (port);
}
if (SCM_OPOUTPORTP (scm_port_table[i]->port))
scm_fflush (scm_port_table[i]->port);
}
return SCM_UNSPECIFIED;
}
@ -594,6 +621,191 @@ scm_read_char (port)
return SCM_MAKICHR (c);
}
int
scm_getc (port)
SCM port;
{
int c;
if (SCM_CRDYP (port))
{
c = SCM_CGETUN (port);
SCM_TRY_CLRDY (port); /* Clear ungetted char */
}
else
{
struct scm_port_table *pt = SCM_PTAB_ENTRY (port);
if (pt->read_pos < pt->read_end)
{
c = *(pt->read_pos++);
}
else
{
scm_sizet i = SCM_PTOBNUM (port);
c = (scm_ptobs [i].fill_buffer) (port);
}
}
if (c == '\n')
{
SCM_INCLINE (port);
}
else if (c == '\t')
{
SCM_TABCOL (port);
}
else
{
SCM_INCCOL (port);
}
return c;
}
/* a macro used whenever writing to a port. in the case of fports,
if fdes is random access and the last access was a
read, then clear the read and put-back buffers and adjust the file position
to account for unread chars. */
#define SCM_MAYBE_DRAIN_INPUT(port, pt, ptob)\
{\
if (pt->write_needs_seek)\
{\
int offset = pt->read_end - pt->read_pos;\
if (SCM_CRDYP (port))\
{\
offset += SCM_N_READY_CHARS (port);\
SCM_CLRDY (port);\
}\
if (offset > 0)\
{\
pt->read_pos = pt->read_end;\
/* will throw error if unread-char used at beginning of file\
then attempting to write. seems correct. */\
if ((ptob->seek) (port, -offset, SEEK_CUR) == -1)\
scm_syserror ("scm_maybe_drain_input");\
}\
pt->write_needs_seek = 0;\
}\
}
void
scm_putc (c, port)
int c;
SCM port;
{
struct scm_port_table *pt = SCM_PTAB_ENTRY (port);
scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
SCM_MAYBE_DRAIN_INPUT (port, pt, ptob)
*(pt->write_pos++) = (char) c;
if (pt->write_pos == pt->write_end
|| (c == '\n'
&& (SCM_CAR (port) & SCM_BUFLINE)))
{
(ptob->fflush) (port);
}
}
void
scm_puts (s, port)
char *s;
SCM port;
{
struct scm_port_table *pt = SCM_PTAB_ENTRY (port);
scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
SCM_MAYBE_DRAIN_INPUT (port, pt, ptob);
while (*s != 0)
{
*pt->write_pos++ = *s++;
if (pt->write_pos == pt->write_end)
(ptob->fflush) (port);
}
/* If the port is line-buffered, flush it. */
if ((SCM_CAR (port) & SCM_BUFLINE)
&& memchr (pt->write_buf, '\n', pt->write_pos - pt->write_buf))
(ptob->fflush) (port);
}
void
scm_lfwrite (ptr, size, port)
char *ptr;
scm_sizet size;
SCM port;
{
struct scm_port_table *pt = SCM_PTAB_ENTRY (port);
scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
SCM_MAYBE_DRAIN_INPUT (port, pt, ptob);
while (size > 0)
{
int space = pt->write_end - pt->write_pos;
int write_len = (size > space) ? space : size;
strncpy (pt->write_pos, ptr, write_len);
pt->write_pos += write_len;
size -= write_len;
ptr += write_len;
if (write_len == space)
(ptob->fflush) (port);
}
/* If the port is line-buffered, flush it. */
if ((SCM_CAR (port) & SCM_BUFLINE)
&& memchr (pt->write_buf, '\n', pt->write_pos - pt->write_buf))
(ptob->fflush) (port);
}
void
scm_fflush (port)
SCM port;
{
scm_sizet i = SCM_PTOBNUM (port);
(scm_ptobs[i].fflush) (port);
}
void
scm_ungetc (c, port)
int c;
SCM port;
{
SCM_CUNGET (c, port);
if (c == '\n')
{
/* What should col be in this case?
* We'll leave it at -1.
*/
SCM_LINUM (port) -= 1;
}
else
SCM_COL(port) -= 1;
}
void
scm_ungets (s, n, port)
char *s;
int n;
SCM port;
{
/* This is simple minded and inefficient, but unreading strings is
* probably not a common operation, and remember that line and
* column numbers have to be handled...
*
* Please feel free to write an optimized version!
*/
while (n--)
scm_ungetc (s[n], port);
}
SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char);
@ -613,70 +825,6 @@ scm_peek_char (port)
return SCM_MAKICHR (c);
}
/*
* A generic fgets method. We supply this method so that ports which
* can't use fgets(3) (like string ports or soft ports) can still use
* line-based i/o. The generic method calls the port's own fgetc method
* for input. It should be possible to write a more efficient
* method for any given port representation -- this is supplied just
* to ensure that you don't have to.
*/
char * scm_generic_fgets SCM_P ((SCM port, int *len));
char *
scm_generic_fgets (port, len)
SCM port;
int *len;
{
scm_sizet p = SCM_PTOBNUM (port);
char *buf;
int limit = 80; /* current size of buffer */
int c;
/* FIXME: It would be nice to be able to check for EOF before anything. */
*len = 0;
buf = (char *) malloc (limit * sizeof(char));
/* If a char has been pushed onto the port with scm_ungetc,
read that first. */
while (SCM_CRDYP (port))
{
buf[*len] = SCM_CGETUN (port);
SCM_TRY_CLRDY (port);
if (buf[(*len)++] == '\n' || *len == limit - 1)
{
buf[*len] = '\0';
return buf;
}
}
while (1) {
if (*len >= limit-1)
{
buf = (char *) realloc (buf, sizeof(char) * limit * 2);
limit *= 2;
}
c = (scm_ptobs[p].fgetc) (port);
if (c != EOF)
buf[(*len)++] = c;
if (c == EOF || c == '\n')
{
if (*len)
{
buf[*len] = '\0';
return buf;
}
free (buf);
return NULL;
}
}
}
SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char);
SCM
@ -834,23 +982,19 @@ scm_prinport (exp, port, type)
}
scm_puts (type, port);
scm_putc (' ', port);
#ifndef MSDOS
#ifndef __EMX__
#ifndef _DCC
#ifndef AMIGA
#ifndef THINK_C
if (SCM_OPENP (exp) && scm_tc16_fport == SCM_TYP16 (exp) && isatty (fileno ((FILE *)SCM_STREAM (exp))))
scm_puts (ttyname (fileno ((FILE *)SCM_STREAM (exp))), port);
else
#endif
#endif
#endif
#endif
#endif
if (SCM_OPFPORTP (exp))
scm_intprint ((long) fileno ((FILE *)SCM_STREAM (exp)), 10, port);
{
int fdes = (SCM_FSTREAM (exp))->fdes;
if (isatty (fdes))
scm_puts (ttyname (fdes), port);
else
scm_intprint (fdes, 10, port);
}
else
scm_intprint (SCM_CDR (exp), 16, port);
{
scm_intprint (SCM_CDR (exp), 16, port);
}
scm_putc ('>', port);
}
@ -865,12 +1009,13 @@ scm_ports_prehistory ()
* They must agree with the port declarations in tags.h.
*/
/* scm_tc16_fport = */ scm_newptob (&scm_fptob);
/* scm_tc16_pipe = */ scm_newptob (&scm_pipob);
/* scm_tc16_pipe was here */ scm_newptob (&scm_fptob); /* dummy. */
/* scm_tc16_strport = */ scm_newptob (&scm_stptob);
/* scm_tc16_sfport = */ scm_newptob (&scm_sfptob);
}
/* Void ports. */
int scm_tc16_void_port = 0;
@ -882,44 +1027,9 @@ print_void_port (SCM exp, SCM port, scm_print_state *pstate)
return 1;
}
static int
putc_void_port (int c, SCM port)
{
return 0; /* vestigial return value */
}
static int
puts_void_port (char *s, SCM port)
{
return 0; /* vestigial return value */
}
static scm_sizet
write_void_port (char *ptr, scm_sizet size, scm_sizet nitems, SCM port)
{
int len;
len = size * nitems;
return len;
}
static int
static void
flush_void_port (SCM port)
{
return 0;
}
static int
getc_void_port (SCM port)
{
return EOF;
}
static char *
fgets_void_port (SCM port, int *len)
{
return NULL;
}
static int
@ -943,13 +1053,11 @@ static struct scm_ptobfuns void_port_ptob =
noop0,
print_void_port,
0, /* equal? */
putc_void_port,
puts_void_port,
write_void_port,
flush_void_port,
getc_void_port,
fgets_void_port,
close_void_port,
0,
0,
0,
};
SCM
@ -964,9 +1072,9 @@ scm_void_port (mode_str)
SCM_DEFER_INTS;
mode_bits = scm_mode_bits (mode_str);
pt = scm_add_to_port_table (answer);
SCM_SETCAR (answer, scm_tc16_void_port | mode_bits);
SCM_SETPTAB_ENTRY (answer, pt);
SCM_SETSTREAM (answer, SCM_BOOL_F);
SCM_SETSTREAM (answer, 0);
SCM_SETCAR (answer, scm_tc16_void_port | mode_bits);
SCM_ALLOW_INTS;
return answer;
}
@ -985,8 +1093,6 @@ scm_sys_make_void_port (mode)
return scm_void_port (SCM_ROCHARS (mode));
}
/* Initialization. */
@ -996,4 +1102,3 @@ scm_init_ports ()
scm_tc16_void_port = scm_newptob (&void_port_ptob);
#include "ports.x"
}

76
libguile/ports.h
View file

@ -53,23 +53,53 @@
#define SCM_INITIAL_CBUF_SIZE 4
struct scm_port_table
struct scm_port_table
{
SCM port; /* Open port. */
SCM port; /* Link back to the port object. */
int entry; /* Index in port table. */
int revealed; /* 0 not revealed, > 1 revealed.
* Revealed ports do not get GC'd.
*/
/* ptob specific data. may be SCM data or cast to a pointer to C data. */
SCM stream;
SCM file_name; /* debugging support. */
int line_number; /* debugging support. */
int column_number; /* debugging support. */
char *cp; /* where to put and get unget chars */
char *cbufend; /* points after this struct */
char cbuf[SCM_INITIAL_CBUF_SIZE]; /* must be last: may grow */
/* port buffers. the buffer(s) are set up for all ports.
in the case of string ports, the buffer is the string itself.
in the case of unbuffered file ports, the buffer is a
single char: shortbuf. */
/* this buffer is filled from read_buf to read_end using the ptob
buffer_fill. then input requests are taken from read_pos until
it reaches read_end. */
unsigned char *read_buf; /* buffer start. */
unsigned char *read_pos; /* the next unread char. */
unsigned char *read_end; /* pointer to last buffered char + 1. */
int read_buf_size; /* size of the buffer. */
/* write requests are saved into this buffer at write_pos until it
reaches write_buf + write_buf_size, then the ptob flush is
called. */
unsigned char *write_buf; /* buffer start. */
unsigned char *write_pos; /* pointer to last buffered char + 1. */
unsigned char *write_end; /* pointer to end of buffer + 1. */
int write_buf_size; /* size of the buffer. */
unsigned char shortbuf; /* buffer for "unbuffered" streams. */
int write_needs_seek; /* whether port position needs to be adjusted
before writing to it. */
/* a completely separate buffer which is only used for un-read chars
and strings. */
unsigned char *cp; /* where to put and get unget chars */
unsigned char *cbufend; /* points after this struct */
unsigned char cbuf[SCM_INITIAL_CBUF_SIZE]; /* must be last: may grow */
};
extern struct scm_port_table **scm_port_table;
@ -88,9 +118,9 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */
#define SCM_OPN (1L<<16) /* Is the port open? */
#define SCM_RDNG (2L<<16) /* Is it a readable port? */
#define SCM_WRTNG (4L<<16) /* Is it writable? */
#define SCM_BUF0 (8L<<16)
#define SCM_NOFTELL (16L<<16) /* Does ftell work on this? Yuck! */
#define SCM_CRDY (32L<<16) /* Should char-ready? return #t? */
#define SCM_BUF0 (8L<<16) /* Is it unbuffered? */
#define SCM_CRDY (32L<<16) /* Are there pushed back characters? */
#define SCM_BUFLINE (64L<<16) /* Is it line-buffered? */
/* A mask used to clear the char-ready port flag. */
#define SCM_CUC (~SCM_CRDY)
@ -99,11 +129,6 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */
#define SCM_OPPORTP(x) (((0x7f | SCM_OPN) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN))
#define SCM_OPINPORTP(x) (((0x7f | SCM_OPN | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG))
#define SCM_OPOUTPORTP(x) (((0x7f | SCM_OPN | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG))
#define SCM_FPORTP(x) (SCM_TYP16S(x)==scm_tc7_port)
#define SCM_OPFPORTP(x) (((0xfeff | SCM_OPN) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN))
#define SCM_OPINFPORTP(x) (((0xfeff | SCM_OPN | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG))
#define SCM_OPOUTFPORTP(x) (((0xfeff | SCM_OPN | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG))
#define SCM_INPORTP(x) (((0x7f | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_RDNG))
#define SCM_OUTPORTP(x) (((0x7f | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_WRTNG))
#define SCM_OPENP(x) (SCM_OPN & SCM_CAR(x))
@ -111,7 +136,7 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */
#define SCM_PTAB_ENTRY(x) ((struct scm_port_table *)SCM_CDR(x))
#define SCM_SETPTAB_ENTRY(x,ent) SCM_SETCDR ((x), (SCM)(ent))
#define SCM_STREAM(x) SCM_PTAB_ENTRY(x)->stream
#define SCM_SETSTREAM(x,s) (SCM_PTAB_ENTRY(x)->stream = s)
#define SCM_SETSTREAM(x,s) (SCM_PTAB_ENTRY(x)->stream = (SCM) s)
#define SCM_FILENAME(x) SCM_PTAB_ENTRY(x)->file_name
#define SCM_LINUM(x) SCM_PTAB_ENTRY(x)->line_number
#define SCM_COL(x) SCM_PTAB_ENTRY(x)->column_number
@ -168,16 +193,11 @@ typedef struct scm_ptobfuns
int (*free) (SCM);
int (*print) (SCM exp, SCM port, scm_print_state *pstate);
SCM (*equalp) (SCM, SCM);
int (*fputc) (int, SCM port);
int (*fputs) (char *, SCM port);
scm_sizet (*fwrite) SCM_P ((char *ptr,
scm_sizet size,
scm_sizet nitems,
SCM port));
int (*fflush) (SCM port);
int (*fgetc) (SCM port);
char * (*fgets) (SCM port, int *len);
void (*fflush) (SCM port);
int (*fclose) (SCM port);
int (*fill_buffer) (SCM port);
off_t (*seek) (SCM port, off_t OFFSET, int WHENCE);
int (*input_waiting_p) (SCM port);
} scm_ptobfuns;
#define SCM_PTOBNUM(x) (0x0ff & (SCM_CAR(x)>>8))
@ -193,6 +213,7 @@ extern int scm_port_table_room;
extern SCM scm_markstream SCM_P ((SCM ptr));
extern long scm_newptob SCM_P ((scm_ptobfuns *ptob));
extern SCM scm_char_ready_p SCM_P ((SCM port));
extern SCM scm_drain_input (SCM port);
extern SCM scm_current_input_port SCM_P ((void));
extern SCM scm_current_output_port SCM_P ((void));
extern SCM scm_current_error_port SCM_P ((void));
@ -218,6 +239,13 @@ extern SCM scm_eof_object_p SCM_P ((SCM x));
extern SCM scm_force_output SCM_P ((SCM port));
extern SCM scm_flush_all_ports SCM_P ((void));
extern SCM scm_read_char SCM_P ((SCM port));
extern void scm_putc SCM_P ((int c, SCM port));
extern void scm_puts SCM_P ((char *str_data, SCM port));
extern void scm_lfwrite SCM_P ((char *ptr, scm_sizet size, SCM port));
extern void scm_fflush SCM_P ((SCM port));
extern int scm_getc SCM_P ((SCM port));
extern void scm_ungetc SCM_P ((int c, SCM port));
extern void scm_ungets SCM_P ((char *s, int n, SCM port));
extern SCM scm_peek_char SCM_P ((SCM port));
extern SCM scm_unread_char SCM_P ((SCM cobj, SCM port));
extern SCM scm_unread_string SCM_P ((SCM str, SCM port));

114
libguile/posix.c
View file

@ -167,34 +167,14 @@ SCM
scm_pipe ()
{
int fd[2], rv;
FILE *f_rd, *f_wt;
SCM p_rd, p_wt;
rv = pipe (fd);
if (rv)
scm_syserror (s_pipe);
f_rd = fdopen (fd[0], "r");
if (!f_rd)
{
SCM_SYSCALL (close (fd[0]));
SCM_SYSCALL (close (fd[1]));
scm_syserror (s_pipe);
}
f_wt = fdopen (fd[1], "w");
if (!f_wt)
{
int en;
en = errno;
fclose (f_rd);
SCM_SYSCALL (close (fd[1]));
errno = en;
scm_syserror (s_pipe);
}
p_rd = scm_stdio_to_port (f_rd, "r", sym_read_pipe);
p_wt = scm_stdio_to_port (f_wt, "w", sym_write_pipe);
SCM_ALLOW_INTS;
p_rd = scm_fdes_to_port (fd[0], "r", sym_read_pipe);
p_wt = scm_fdes_to_port (fd[1], "w", sym_write_pipe);
return scm_cons (p_rd, p_wt);
}
@ -220,15 +200,17 @@ scm_getgroups()
val = getgroups(ngroups, groups);
if (val < 0)
{
int en = errno;
scm_must_free((char *)groups);
errno = en;
scm_syserror (s_getgroups);
}
SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */
SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string);
SCM_ALLOW_INTS;
ans = scm_make_vector (SCM_MAKINUM(ngroups), SCM_UNDEFINED);
while (--ngroups >= 0) SCM_VELTS(ans)[ngroups] = SCM_MAKINUM(groups[ngroups]);
SCM_SETCHARS(grps, groups); /* to make sure grps stays around. */
SCM_ALLOW_INTS;
return ans;
}
}
@ -249,17 +231,14 @@ scm_getpwuid (user)
ve = SCM_VELTS (result);
if (SCM_UNBNDP (user) || SCM_FALSEP (user))
{
SCM_DEFER_INTS;
SCM_SYSCALL (entry = getpwent ());
if (! entry)
{
SCM_ALLOW_INTS;
return SCM_BOOL_F;
}
}
else if (SCM_INUMP (user))
{
SCM_DEFER_INTS;
entry = getpwuid (SCM_INUM (user));
}
else
@ -267,7 +246,6 @@ scm_getpwuid (user)
SCM_ASSERT (SCM_NIMP (user) && SCM_ROSTRINGP (user), user, SCM_ARG1, s_getpwuid);
if (SCM_SUBSTRP (user))
user = scm_makfromstr (SCM_ROCHARS (user), SCM_ROLENGTH (user), 0);
SCM_DEFER_INTS;
entry = getpwnam (SCM_ROCHARS (user));
}
if (!entry)
@ -286,7 +264,6 @@ scm_getpwuid (user)
ve[6] = scm_makfrom0str ("");
else
ve[6] = scm_makfrom0str (entry->pw_shell);
SCM_ALLOW_INTS;
return result;
}
@ -320,13 +297,11 @@ scm_getgrgid (name)
SCM *ve;
result = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED);
ve = SCM_VELTS (result);
SCM_DEFER_INTS;
if (SCM_UNBNDP (name) || (name == SCM_BOOL_F))
{
SCM_SYSCALL (entry = getgrent ());
if (! entry)
{
SCM_ALLOW_INTS;
return SCM_BOOL_F;
}
}
@ -346,7 +321,6 @@ scm_getgrgid (name)
ve[1] = scm_makfrom0str (entry->gr_passwd);
ve[2] = scm_ulong2num ((unsigned long) entry->gr_gid);
ve[3] = scm_makfromstrs (-1, entry->gr_mem);
SCM_ALLOW_INTS;
return result;
}
@ -644,9 +618,7 @@ scm_ttyname (port)
SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_ttyname);
if (scm_tc16_fport != SCM_TYP16 (port))
return SCM_BOOL_F;
fd = fileno ((FILE *)SCM_STREAM (port));
if (fd == -1)
scm_syserror (s_ttyname);
fd = SCM_FPORT_FDES (port);
SCM_SYSCALL (ans = ttyname (fd));
if (!ans)
scm_syserror (s_ttyname);
@ -683,8 +655,8 @@ scm_tcgetpgrp (port)
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcgetpgrp);
fd = fileno ((FILE *)SCM_STREAM (port));
if (fd == -1 || (pgid = tcgetpgrp (fd)) == -1)
fd = SCM_FPORT_FDES (port);
if ((pgid = tcgetpgrp (fd)) == -1)
scm_syserror (s_tcgetpgrp);
return SCM_MAKINUM (pgid);
#else
@ -706,8 +678,8 @@ scm_tcsetpgrp (port, pgid)
SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcsetpgrp);
SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_tcsetpgrp);
fd = fileno ((FILE *)SCM_STREAM (port));
if (fd == -1 || tcsetpgrp (fd, SCM_INUM (pgid)) == -1)
fd = SCM_FPORT_FDES (port);
if (tcsetpgrp (fd, SCM_INUM (pgid)) == -1)
scm_syserror (s_tcsetpgrp);
return SCM_UNSPECIFIED;
#else
@ -729,7 +701,6 @@ scm_convert_exec_args (SCM args, int pos, const char *subr)
SCM_ASSERT (SCM_NULLP (args)
|| (SCM_NIMP (args) && SCM_CONSP (args)),
args, pos, subr);
SCM_DEFER_INTS;
num_args = scm_ilength (args);
execargv = (char **)
scm_must_malloc ((num_args + 1) * sizeof (char *), subr);
@ -748,7 +719,6 @@ scm_convert_exec_args (SCM args, int pos, const char *subr)
execargv[i] = dst;
}
execargv[i] = 0;
SCM_ALLOW_INTS;
return execargv;
}
@ -793,7 +763,6 @@ environ_list_to_c (SCM envlist, int arg, const char *proc)
char **result;
int i = 0;
SCM_REDEFER_INTS;
SCM_ASSERT (SCM_NULLP (envlist)
|| (SCM_NIMP (envlist) && SCM_CONSP (envlist)),
envlist, arg, proc);
@ -820,7 +789,6 @@ environ_list_to_c (SCM envlist, int arg, const char *proc)
i++;
}
result[i] = 0;
SCM_REALLOW_INTS;
return result;
}
@ -867,7 +835,6 @@ scm_uname ()
struct utsname buf;
SCM ans = scm_make_vector (SCM_MAKINUM(5), SCM_UNSPECIFIED);
SCM *ve = SCM_VELTS (ans);
SCM_DEFER_INTS;
if (uname (&buf) < 0)
scm_syserror (s_uname);
ve[0] = scm_makfrom0str (buf.sysname);
@ -879,7 +846,6 @@ scm_uname ()
a linux special?
ve[5] = scm_makfrom0str (buf.domainname);
*/
SCM_ALLOW_INTS;
return ans;
#else
scm_sysmissing (s_uname);
@ -900,7 +866,6 @@ scm_environ (env)
{
char **new_environ;
SCM_DEFER_INTS;
new_environ = environ_list_to_c (env, SCM_ARG1, s_environ);
/* Free the old environment, except when called for the first
* time.
@ -917,7 +882,6 @@ scm_environ (env)
first = 0;
}
environ = new_environ;
SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
}
@ -934,60 +898,6 @@ SCM scm_tmpnam()
}
#endif
SCM_PROC (s_open_pipe, "open-pipe", 2, 0, 0, scm_open_pipe);
SCM
scm_open_pipe (pipestr, modes)
SCM pipestr;
SCM modes;
{
FILE *f;
register SCM z;
struct scm_port_table * pt;
SCM_ASSERT (SCM_NIMP (pipestr) && SCM_ROSTRINGP (pipestr), pipestr,
SCM_ARG1, s_open_pipe);
if (SCM_SUBSTRP (pipestr))
pipestr = scm_makfromstr (SCM_ROCHARS (pipestr),
SCM_ROLENGTH (pipestr), 0);
SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2,
s_open_pipe);
if (SCM_SUBSTRP (modes))
modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
SCM_NEWCELL (z);
SCM_DEFER_INTS;
SCM_SYSCALL (f = popen (SCM_ROCHARS (pipestr), SCM_ROCHARS (modes)));
if (!f)
scm_syserror (s_open_pipe);
pt = scm_add_to_port_table (z);
SCM_SETPTAB_ENTRY (z, pt);
SCM_SETCAR (z, scm_tc16_pipe | SCM_OPN
| (strchr (SCM_ROCHARS (modes), 'r') ? SCM_RDNG : SCM_WRTNG));
SCM_SETSTREAM (z, (SCM)f);
SCM_ALLOW_INTS;
return z;
}
SCM_PROC (s_close_pipe, "close-pipe", 1, 0, 0, scm_close_pipe);
SCM
scm_close_pipe (port)
SCM port;
{
int rv;
SCM_ASSERT (SCM_NIMP (port) && SCM_TYP16(port) == scm_tc16_pipe
&& SCM_OPENP (port), port, SCM_ARG1, s_close_pipe);
SCM_DEFER_INTS;
rv = pclose ((FILE *) SCM_STREAM (port));
scm_remove_from_port_table (port);
SCM_SETAND_CAR (port, ~SCM_OPN);
if (rv == -1)
scm_syserror (s_close_pipe);
SCM_ALLOW_INTS;
return SCM_MAKINUM (rv);
}
SCM_PROC (s_utime, "utime", 1, 2, 0, scm_utime);
SCM
@ -1140,12 +1050,10 @@ scm_mknod(path, type, perms, dev)
else
scm_out_of_range (s_mknod, type);
SCM_DEFER_INTS;
SCM_SYSCALL (val = mknod(SCM_ROCHARS(path), ctype | SCM_INUM (perms),
SCM_INUM (dev)));
if (val != 0)
scm_syserror (s_mknod);
SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
#else
scm_sysmissing (s_mknod);

9
libguile/print.c
View file

@ -961,15 +961,6 @@ scm_newline (port)
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG1, s_newline);
scm_putc ('\n', SCM_COERCE_OUTPORT (port));
#ifdef HAVE_PIPE
# ifdef EPIPE
if (EPIPE == errno)
scm_close_port (port);
else
# endif
#endif
if (port == scm_cur_outp)
scm_fflush (port);
return SCM_UNSPECIFIED;
}

478
libguile/readline.c
View file

@ -1,478 +0,0 @@
/* readline.c --- line editing support for Guile */
/* Copyright (C) 1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* The exception is that, if you link the GUILE library with other files
* to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the GUILE library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the
* Free Software Foundation under the name GUILE. If you copy
* code from other Free Software Foundation releases into a copy of
* GUILE, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*/
#include "_scm.h"
#if defined (HAVE_RL_GETC_FUNCTION)
#include <libguile.h>
#include <readline.h>
#include <gh.h>
#include <readline/readline.h>
#include <readline/history.h>
#include <sys/time.h>
#include "iselect.h"
scm_option scm_readline_opts[] = {
{ SCM_OPTION_BOOLEAN, "history-file", 1,
"Use history file." },
{ SCM_OPTION_INTEGER, "history-length", 200,
"History length." },
{ SCM_OPTION_INTEGER, "bounce-parens", 500,
"Time (ms) to show matching opening parenthesis (0 = off)."}
};
extern void stifle_history (int max);
SCM_PROC (s_readline_options, "readline-options-interface", 0, 1, 0, scm_readline_options);
SCM
scm_readline_options (setting)
SCM setting;
{
SCM ans = scm_options (setting,
scm_readline_opts,
SCM_N_READLINE_OPTIONS,
s_readline_options);
stifle_history (SCM_HISTORY_LENGTH);
return ans;
}
#ifndef HAVE_STRDUP
static char *
strdup (char *s)
{
int len = strlen (s);
char *new = malloc (len + 1);
strcpy (new, s);
return new;
}
#endif /* HAVE_STRDUP */
#ifndef HAVE_RL_CLEANUP_AFTER_SIGNAL
/* These are readline functions added in release 2.3. They will work
* together with readline-2.1 and 2.2. (The readline interface is
* disabled for earlier releases.)
* They are declared static; if we want to use them elsewhere, then
* we need external declarations for them, but at the moment, I don't
* think anything else in Guile ought to use these.
*/
extern void _rl_clean_up_for_exit ();
extern void _rl_kill_kbd_macro ();
extern int _rl_init_argument ();
static void
rl_cleanup_after_signal ()
{
#ifdef HAVE_RL_CLEAR_SIGNALS
_rl_clean_up_for_exit ();
#endif
(*rl_deprep_term_function) ();
#ifdef HAVE_RL_CLEAR_SIGNALS
rl_clear_signals ();
#endif
rl_pending_input = 0;
}
static void
rl_free_line_state ()
{
register HIST_ENTRY *entry;
free_undo_list ();
entry = current_history ();
if (entry)
entry->data = (char *)NULL;
_rl_kill_kbd_macro ();
rl_clear_message ();
_rl_init_argument ();
}
#endif /* !HAVE_RL_CLEANUP_AFTER_SIGNAL */
static int promptp;
static SCM input_port;
static SCM before_read;
static int
current_input_getc (FILE *in)
{
SCM ans;
if (promptp && SCM_NIMP (before_read))
{
scm_apply (before_read, SCM_EOL, SCM_EOL);
promptp = 0;
}
ans = scm_getc (input_port);
return ans;
}
static void
redisplay ()
{
rl_redisplay ();
/* promptp = 1; */
}
SCM_PROC (s_readline, "readline", 0, 4, 0, scm_readline);
static int in_readline = 0;
#ifdef USE_THREADS
static scm_mutex_t reentry_barrier_mutex;
#endif
static void
reentry_barrier ()
{
int reentryp = 0;
#ifdef USE_THREADS
/* We should rather use scm_mutex_try_lock when it becomes available */
scm_mutex_lock (&reentry_barrier_mutex);
#endif
if (in_readline)
reentryp = 1;
else
++in_readline;
#ifdef USE_THREADS
scm_mutex_unlock (&reentry_barrier_mutex);
#endif
if (reentryp)
scm_misc_error (s_readline, "readline is not reentrant", SCM_EOL);
}
static SCM
handle_error (void *data, SCM tag, SCM args)
{
rl_free_line_state ();
rl_cleanup_after_signal ();
--in_readline;
scm_handle_by_throw (data, tag, args);
return SCM_UNSPECIFIED; /* never reached */
}
static SCM
internal_readline (SCM text)
{
SCM ret;
char *s;
char *prompt = SCM_UNBNDP (text) ? "" : SCM_CHARS (text);
promptp = 1;
s = readline (prompt);
if (s)
ret = scm_makfrom0str (s);
else
ret = SCM_EOF_VAL;
free (s);
return ret;
}
SCM
scm_readline (SCM text, SCM inp, SCM outp, SCM read_hook)
{
SCM ans;
reentry_barrier ();
before_read = SCM_BOOL_F;
if (!SCM_UNBNDP (text))
{
if (!(SCM_NIMP (text) && SCM_STRINGP (text)))
{
--in_readline;
scm_wrong_type_arg (s_readline, SCM_ARG1, text);
}
SCM_COERCE_SUBSTR (text);
}
if (SCM_UNBNDP (inp))
inp = scm_cur_inp;
if (SCM_UNBNDP (outp))
outp = scm_cur_outp;
if (!(SCM_UNBNDP (read_hook) || SCM_FALSEP (read_hook)))
{
if (!(SCM_NFALSEP (scm_thunk_p (read_hook))))
{
--in_readline;
scm_wrong_type_arg (s_readline, SCM_ARG4, read_hook);
}
before_read = read_hook;
}
if (!(SCM_NIMP (inp) && SCM_OPINFPORTP (inp)))
{
--in_readline;
scm_misc_error (s_readline,
"Input port is not open or not a file port",
SCM_EOL);
}
if (!(SCM_NIMP (outp) && SCM_OPOUTFPORTP (outp)))
{
--in_readline;
scm_misc_error (s_readline,
"Output port is not open or not a file port",
SCM_EOL);
}
input_port = inp;
rl_instream = (FILE *) SCM_STREAM (inp);
rl_outstream = (FILE *) SCM_STREAM (outp);
ans = scm_internal_catch (SCM_BOOL_T,
(scm_catch_body_t) internal_readline,
(void *) text,
handle_error, 0);
--in_readline;
return ans;
}
SCM_PROC (s_add_history, "add-history", 1, 0, 0, scm_add_history);
SCM
scm_add_history (SCM text)
{
char* s;
SCM_ASSERT ((SCM_NIMP(text) && SCM_STRINGP(text)), text, SCM_ARG1,
s_add_history);
SCM_COERCE_SUBSTR (text);
s = SCM_CHARS (text);
add_history (strdup (s));
return SCM_UNSPECIFIED;
}
SCM_PROC (s_read_history, "read-history", 1, 0, 0, scm_read_history);
SCM
scm_read_history (SCM file)
{
SCM_ASSERT (SCM_NIMP (file) && SCM_STRINGP (file),
file, SCM_ARG1, s_read_history);
return read_history (SCM_ROCHARS (file)) ? SCM_BOOL_F : SCM_BOOL_T;
}
SCM_PROC (s_write_history, "write-history", 1, 0, 0, scm_write_history);
SCM
scm_write_history (SCM file)
{
SCM_ASSERT (SCM_NIMP (file) && SCM_STRINGP (file),
file, SCM_ARG1, s_write_history);
return write_history (SCM_ROCHARS (file)) ? SCM_BOOL_F : SCM_BOOL_T;
}
SCM_PROC (s_filename_completion_function, "filename-completion-function", 2, 0, 0, scm_filename_completion_function);
SCM
scm_filename_completion_function (SCM text, SCM continuep)
{
char *s;
SCM ans;
SCM_ASSERT (SCM_NIMP (text) && SCM_STRINGP (text),
text,
SCM_ARG1,
s_filename_completion_function);
SCM_COERCE_SUBSTR (text);
s = filename_completion_function (SCM_CHARS (text), SCM_NFALSEP (continuep));
ans = scm_makfrom0str (s);
free (s);
return ans;
}
/*
* The following has been modified from code contributed by
* Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>
*/
SCM scm_readline_completion_function_var;
static char *
completion_function (char *text, int continuep)
{
SCM compfunc = SCM_CDR (scm_readline_completion_function_var);
SCM res;
if (SCM_FALSEP (compfunc))
return NULL; /* #f => completion disabled */
else
{
SCM t = scm_makfrom0str (text);
SCM c = continuep ? SCM_BOOL_T : SCM_BOOL_F;
res = scm_apply (compfunc, SCM_LIST2 (t, c), SCM_EOL);
if (SCM_FALSEP (res))
return NULL;
if (!(SCM_NIMP (res) && SCM_STRINGP (res)))
scm_misc_error (s_readline,
"Completion function returned bogus value: %S",
SCM_LIST1 (res));
SCM_COERCE_SUBSTR (res);
return strdup (SCM_CHARS (res));
}
}
/*Bouncing parenthesis (reimplemented by GH, 11/23/98, since readline is strict gpl)*/
static void match_paren(int x, int k);
static int find_matching_paren(int k);
static void init_bouncing_parens();
static void
init_bouncing_parens()
{
if(strncmp(rl_get_keymap_name(rl_get_keymap()), "vi", 2)) {
rl_bind_key(')', match_paren);
rl_bind_key(']', match_paren);
rl_bind_key('}', match_paren);
}
}
static int
find_matching_paren(int k)
{
register int i;
register char c = 0;
int end_parens_found = 0;
/* Choose the corresponding opening bracket. */
if (k == ')') c = '(';
else if (k == ']') c = '[';
else if (k == '}') c = '{';
for (i=rl_point-2; i>=0; i--)
{
/* Is the current character part of a character literal? */
if (i - 2 >= 0
&& rl_line_buffer[i - 1] == '\\'
&& rl_line_buffer[i - 2] == '#')
;
else if (rl_line_buffer[i] == k)
end_parens_found++;
else if (rl_line_buffer[i] == '"')
{
/* Skip over a string literal. */
for (i--; i >= 0; i--)
if (rl_line_buffer[i] == '"'
&& ! (i - 1 >= 0
&& rl_line_buffer[i - 1] == '\\'))
break;
}
else if (rl_line_buffer[i] == c)
{
if (end_parens_found==0) return i;
else --end_parens_found;
}
}
return -1;
}
static void
match_paren(int x, int k)
{
int tmp;
fd_set readset;
struct timeval timeout;
rl_insert(x, k);
if (!SCM_READLINE_BOUNCE_PARENS)
return;
/* Did we just insert a quoted paren? If so, then don't bounce. */
if (rl_point - 1 >= 1
&& rl_line_buffer[rl_point - 2] == '\\')
return;
tmp = 1000 * SCM_READLINE_BOUNCE_PARENS;
timeout.tv_sec = tmp / 1000000;
timeout.tv_usec = tmp % 1000000;
FD_ZERO(&readset);
FD_SET(fileno(rl_instream), &readset);
if(rl_point > 1) {
tmp = rl_point;
rl_point = find_matching_paren(k);
if(rl_point > -1) {
rl_redisplay();
scm_internal_select(1, &readset, NULL, NULL, &timeout);
}
rl_point = tmp;
}
}
void
scm_init_readline ()
{
#include "readline.x"
scm_readline_completion_function_var
= scm_sysintern ("*readline-completion-function*", SCM_BOOL_F);
rl_getc_function = current_input_getc;
rl_redisplay_function = redisplay;
rl_completion_entry_function = (Function*) completion_function;
rl_basic_word_break_characters = "\t\n\"'`;()";
#ifdef USE_THREADS
scm_mutex_init (&reentry_barrier_mutex);
#endif
scm_init_opts (scm_readline_options,
scm_readline_opts,
SCM_N_READLINE_OPTIONS);
init_bouncing_parens();
scm_add_feature ("readline");
}
#endif

2
libguile/scmsigs.c
View file

@ -113,6 +113,7 @@ static SIGRETTYPE (*orig_handlers)(int)[NSIG];
static SIGRETTYPE
take_signal (int signum)
{
int saved_errno = errno;
SCM ignored;
if (!scm_ints_disabled)
{
@ -141,6 +142,7 @@ take_signal (int signum)
}
#endif
scm_system_async_mark (signal_async);
errno = saved_errno;
}
static SCM

1
libguile/simpos.c
View file

@ -105,6 +105,7 @@ scm_getenv(nam)
return (val) ? scm_makfromstr(val, (scm_sizet)strlen(val), 0) : SCM_BOOL_F;
}
/* simple exit, without unwinding the scheme stack or flushing ports. */
SCM_PROC (s_primitive_exit, "primitive-exit", 0, 1, 0, scm_primitive_exit);
SCM
scm_primitive_exit (SCM status)

78
libguile/socket.c
View file

@ -75,18 +75,10 @@ scm_sock_fd_to_port (fd, proc)
const char *proc;
{
SCM result;
FILE *f;
if (fd == -1)
scm_syserror (proc);
f = fdopen (fd, "r+");
if (!f)
{
SCM_SYSCALL (close (fd));
scm_syserror (proc);
}
result = scm_stdio_to_port (f, "r+0", sym_socket);
scm_setbuf0 (result);
result = scm_fdes_to_port (fd, "r+0", sym_socket);
return result;
}
@ -104,11 +96,8 @@ scm_socket (family, style, proto)
SCM_ASSERT (SCM_INUMP (family), family, SCM_ARG1, s_socket);
SCM_ASSERT (SCM_INUMP (style), style, SCM_ARG2, s_socket);
SCM_ASSERT (SCM_INUMP (proto), proto, SCM_ARG3, s_socket);
SCM_DEFER_INTS;
fd = socket (SCM_INUM (family), SCM_INUM (style), SCM_INUM (proto));
result = scm_sock_fd_to_port (fd, s_socket);
SCM_SETOR_CAR (result, SCM_NOFTELL);
SCM_ALLOW_INTS;
return result;
}
@ -134,13 +123,11 @@ scm_socketpair (family, style, proto)
fam = SCM_INUM (family);
SCM_DEFER_INTS;
if (socketpair (fam, SCM_INUM (style), SCM_INUM (proto), fd) == -1)
scm_syserror (s_socketpair);
a = scm_sock_fd_to_port (fd[0], s_socketpair);
b = scm_sock_fd_to_port (fd[1], s_socketpair);
SCM_ALLOW_INTS;
return scm_cons (a, b);
}
#endif
@ -170,12 +157,12 @@ scm_getsockopt (sock, level, optname)
#endif
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1,
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1,
s_getsockopt);
SCM_ASSERT (SCM_INUMP (level), level, SCM_ARG2, s_getsockopt);
SCM_ASSERT (SCM_INUMP (optname), optname, SCM_ARG3, s_getsockopt);
fd = fileno ((FILE *)SCM_STREAM (sock));
fd = SCM_FPORT_FDES (sock);
ilevel = SCM_INUM (level);
ioptname = SCM_INUM (optname);
if (getsockopt (fd, ilevel, ioptname, (void *) optval, &optlen) == -1)
@ -230,11 +217,11 @@ scm_setsockopt (sock, level, optname, value)
#endif
int ilevel, ioptname;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1,
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1,
s_setsockopt);
SCM_ASSERT (SCM_INUMP (level), level, SCM_ARG2, s_setsockopt);
SCM_ASSERT (SCM_INUMP (optname), optname, SCM_ARG3, s_setsockopt);
fd = fileno ((FILE *)SCM_STREAM (sock));
fd = SCM_FPORT_FDES (sock);
ilevel = SCM_INUM (level);
ioptname = SCM_INUM (optname);
if (0);
@ -300,11 +287,11 @@ scm_shutdown (sock, how)
{
int fd;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1,
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1,
s_shutdown);
SCM_ASSERT (SCM_INUMP (how) && 0 <= SCM_INUM (how) && 2 >= SCM_INUM (how),
how, SCM_ARG2, s_shutdown);
fd = fileno ((FILE *)SCM_STREAM (sock));
fd = SCM_FPORT_FDES (sock);
if (shutdown (fd, SCM_INUM (how)) == -1)
scm_syserror (s_shutdown);
return SCM_UNSPECIFIED;
@ -386,15 +373,13 @@ scm_connect (sock, fam, address, args)
scm_sizet size;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_connect);
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_connect);
SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG2, s_connect);
fd = fileno ((FILE *)SCM_STREAM (sock));
SCM_DEFER_INTS;
fd = SCM_FPORT_FDES (sock);
soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, s_connect, &size);
if (connect (fd, soka, size) == -1)
scm_syserror (s_connect);
scm_must_free ((char *) soka);
SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
@ -413,10 +398,10 @@ scm_bind (sock, fam, address, args)
int fd;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_bind);
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_bind);
SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG2, s_bind);
soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, s_bind, &size);
fd = fileno ((FILE *)SCM_STREAM (sock));
fd = SCM_FPORT_FDES (sock);
rv = bind (fd, soka, size);
if (rv == -1)
scm_syserror (s_bind);
@ -433,9 +418,9 @@ scm_listen (sock, backlog)
{
int fd;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_listen);
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_listen);
SCM_ASSERT (SCM_INUMP (backlog), backlog, SCM_ARG2, s_listen);
fd = fileno ((FILE *)SCM_STREAM (sock));
fd = SCM_FPORT_FDES (sock);
if (listen (fd, SCM_INUM (backlog)) == -1)
scm_syserror (s_listen);
return SCM_UNSPECIFIED;
@ -515,9 +500,8 @@ scm_accept (sock)
int tmp_size;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_accept);
fd = fileno ((FILE *)SCM_STREAM (sock));
SCM_DEFER_INTS;
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_accept);
fd = SCM_FPORT_FDES (sock);
tmp_size = scm_addr_buffer_size;
newfd = accept (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size);
newsock = scm_sock_fd_to_port (newfd, s_accept);
@ -526,7 +510,6 @@ scm_accept (sock)
else
address = SCM_BOOL_F;
SCM_ALLOW_INTS;
return scm_cons (newsock, address);
}
@ -540,9 +523,8 @@ scm_getsockname (sock)
int fd;
SCM result;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_getsockname);
fd = fileno ((FILE *)SCM_STREAM (sock));
SCM_DEFER_INTS;
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_getsockname);
fd = SCM_FPORT_FDES (sock);
tmp_size = scm_addr_buffer_size;
if (getsockname (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1)
scm_syserror (s_getsockname);
@ -550,7 +532,6 @@ scm_getsockname (sock)
result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getsockname);
else
result = SCM_BOOL_F;
SCM_ALLOW_INTS;
return result;
}
@ -565,8 +546,7 @@ scm_getpeername (sock)
SCM result;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_getpeername);
fd = fileno ((FILE *)SCM_STREAM (sock));
SCM_DEFER_INTS;
fd = SCM_FPORT_FDES (sock);
tmp_size = scm_addr_buffer_size;
if (getpeername (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1)
scm_syserror (s_getpeername);
@ -574,7 +554,6 @@ scm_getpeername (sock)
result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getpeername);
else
result = SCM_BOOL_F;
SCM_ALLOW_INTS;
return result;
}
@ -590,10 +569,10 @@ scm_recv (sock, buf, flags)
int fd;
int flg;
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_recv);
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_recv);
SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recv);
fd = fileno ((FILE *)SCM_STREAM (sock));
fd = SCM_FPORT_FDES (sock);
if (SCM_UNBNDP (flags))
flg = 0;
else
@ -619,10 +598,10 @@ scm_send (sock, message, flags)
int flg;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_send);
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_send);
SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message, SCM_ARG2, s_send);
fd = fileno ((FILE *)SCM_STREAM (sock));
fd = SCM_FPORT_FDES (sock);
if (SCM_UNBNDP (flags))
flg = 0;
else
@ -652,7 +631,7 @@ scm_recvfrom (sock, buf, flags, start, end)
int tmp_size;
SCM address;
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1,
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1,
s_recvfrom);
SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recvfrom);
cend = SCM_LENGTH (buf);
@ -684,7 +663,7 @@ scm_recvfrom (sock, buf, flags, start, end)
}
}
fd = fileno ((FILE *)SCM_STREAM (sock));
fd = SCM_FPORT_FDES (sock);
tmp_size = scm_addr_buffer_size;
SCM_SYSCALL (rv = recvfrom (fd, SCM_CHARS (buf) + offset,
@ -716,14 +695,14 @@ scm_sendto (sock, message, fam, address, args_and_flags)
int flg;
struct sockaddr *soka;
scm_sizet size;
int save_err;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_sendto);
SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message,
SCM_ARG2, s_sendto);
SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG3, s_sendto);
fd = fileno ((FILE *)SCM_STREAM (sock));
SCM_DEFER_INTS;
fd = SCM_FPORT_FDES (sock);
soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args_and_flags, 4,
s_sendto, &size);
if (SCM_NULLP (args_and_flags))
@ -736,10 +715,11 @@ scm_sendto (sock, message, fam, address, args_and_flags)
}
SCM_SYSCALL (rv = sendto (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message),
flg, soka, size));
save_err = errno;
scm_must_free ((char *) soka);
errno = save_err;
if (rv == -1)
scm_syserror (s_sendto);
scm_must_free ((char *) soka);
SCM_ALLOW_INTS;
return SCM_MAKINUM (rv);
}

22
libguile/strings.c
View file

@ -173,20 +173,34 @@ scm_makfromstrs (argc, argv)
}
/* This function must only be applied to memory obtained via malloc,
since the GC is going to apply `free' to it when the string is
dropped.
Also, s[len] must be `\0', since we promise that strings are
null-terminated. Perhaps we could handle non-null-terminated
strings by claiming they're shared substrings of a string we just
made up. */
SCM
scm_take0str (it)
char * it;
scm_take_str (char *s, int len)
{
SCM answer;
SCM_NEWCELL (answer);
SCM_DEFER_INTS;
SCM_SETLENGTH (answer, strlen (it), scm_tc7_string);
SCM_SETCHARS (answer, it);
SCM_SETLENGTH (answer, len, scm_tc7_string);
scm_done_malloc (len + 1);
SCM_SETCHARS (answer, s);
SCM_ALLOW_INTS;
return answer;
}
/* `s' must be a malloc'd string. See scm_take_str. */
SCM
scm_take0str (char *s)
{
return scm_take_str (s, strlen (s));
}
SCM
scm_makfromstr (src, len, slots)

3
libguile/strings.h
View file

@ -67,7 +67,8 @@ extern SCM scm_read_only_string_p SCM_P ((SCM x));
extern SCM scm_string SCM_P ((SCM chrs));
extern SCM scm_makstr SCM_P ((long len, int slots));
extern SCM scm_makfromstrs SCM_P ((int argc, char **argv));
extern SCM scm_take0str SCM_P ((char * it));
extern SCM scm_take_str SCM_P ((char *s, int len));
extern SCM scm_take0str SCM_P ((char *s));
extern SCM scm_makfromstr SCM_P ((const char *src, scm_sizet len, int slots));
extern SCM scm_makfrom0str SCM_P ((const char *src));
extern SCM scm_makfrom0str_opt SCM_P ((const char *src));

127
libguile/strports.c
View file

@ -66,65 +66,46 @@ prinstpt (SCM exp, SCM port, scm_print_state *pstate)
return !0;
}
static int
stputc (int c, SCM port)
static int
stfill_buffer (SCM port)
{
SCM p = SCM_STREAM (port);
scm_sizet ind = SCM_INUM (SCM_CAR (p));
SCM_DEFER_INTS;
if (ind >= SCM_LENGTH (SCM_CDR (p)))
scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + (ind >> 1)));
SCM_ALLOW_INTS;
SCM_CHARS (SCM_CDR (p))[ind] = c;
SCM_SETCAR (p, SCM_MAKINUM (ind + 1));
return c;
}
SCM str = SCM_STREAM (port);
struct scm_port_table *pt = SCM_PTAB_ENTRY (port);
pt->read_buf = SCM_ROCHARS (str);
pt->read_buf_size = SCM_ROLENGTH (str);
pt->read_end = pt->read_buf + pt->read_buf_size;
static scm_sizet
stwrite (char *str,
scm_sizet siz,
scm_sizet num,
SCM port)
{
SCM p = SCM_STREAM (port);
scm_sizet ind = SCM_INUM (SCM_CAR (p));
scm_sizet len = siz * num;
char *dst;
SCM_DEFER_INTS;
if (ind + len >= SCM_LENGTH (SCM_CDR (p)))
scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + len + ((ind + len) >> 1)));
SCM_ALLOW_INTS;
dst = &(SCM_CHARS (SCM_CDR (p))[ind]);
while (len--)
dst[len] = str[len];
SCM_SETCAR (p, SCM_MAKINUM (ind + siz * num));
return num;
}
static int
stputs (char *s, SCM port)
{
stwrite (s, 1, strlen (s), port);
return 0;
}
static int
stgetc (SCM port)
{
SCM p = SCM_STREAM (port);
scm_sizet ind = SCM_INUM (SCM_CAR (p));
if (ind >= SCM_ROLENGTH (SCM_CDR (p)))
if (pt->read_pos >= pt->read_end)
return EOF;
SCM_SETCAR (p, SCM_MAKINUM (ind + 1));
return SCM_ROUCHARS (SCM_CDR (p))[ind];
else
return scm_return_first (*(pt->read_pos++), port);
}
/* not a conventional "flush": it extends the string for more data. */
static void
st_flush (SCM port)
{
struct scm_port_table *pt = SCM_PTAB_ENTRY (port);
if (pt->write_pos == pt->write_end)
{
pt->write_buf_size += pt->write_buf_size >> 1;
scm_vector_set_length_x (pt->stream,
SCM_MAKINUM (pt->write_buf_size));
/* reset buffer in case reallocation moved the string. */
{
int read = pt->read_pos - pt->read_buf;
int written = pt->write_pos - pt->write_buf;
pt->read_buf = pt->write_buf = SCM_CHARS (pt->stream);
pt->read_pos = pt->read_buf + read;
pt->write_pos = pt->write_buf + written;
pt->write_end = pt->write_buf + pt->write_buf_size;
pt->read_end = pt->read_buf + pt->read_buf_size;
}
}
}
SCM
scm_mkstrport (pos, str, modes, caller)
@ -139,13 +120,21 @@ scm_mkstrport (pos, str, modes, caller)
SCM_ASSERT(SCM_INUMP(pos) && SCM_INUM(pos) >= 0, pos, SCM_ARG1, caller);
SCM_ASSERT(SCM_NIMP(str) && SCM_ROSTRINGP(str), str, SCM_ARG1, caller);
stream = scm_cons(pos, str);
stream = str;
SCM_NEWCELL (z);
SCM_DEFER_INTS;
pt = scm_add_to_port_table (z);
SCM_SETCAR (z, scm_tc16_strport | modes);
SCM_SETPTAB_ENTRY (z, pt);
SCM_SETSTREAM (z, stream);
pt->write_buf = pt->read_buf = SCM_ROCHARS (str);
pt->write_pos = pt->read_pos = pt->read_buf + SCM_INUM (pos);
pt->read_buf_size = SCM_ROLENGTH (str);
pt->read_end = pt->read_buf + pt->read_buf_size;
/* after the last (normally NUL) character is written to,
the port will be "flushed". */
pt->write_buf_size = pt->read_buf_size + 1;
pt->write_end = pt->write_buf + pt->write_buf_size;
SCM_ALLOW_INTS;
return z;
}
@ -163,11 +152,11 @@ scm_call_with_output_string (proc)
scm_apply (proc, p, scm_listofnull);
{
SCM answer;
SCM_DEFER_INTS;
answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (p))),
SCM_INUM (SCM_CAR (SCM_STREAM (p))),
struct scm_port_table *pt = SCM_PTAB_ENTRY (p);
answer = scm_makfromstr (SCM_CHARS (SCM_STREAM (p)),
pt->write_pos - pt->write_buf,
0);
SCM_ALLOW_INTS;
return answer;
}
}
@ -189,12 +178,12 @@ scm_strprint_obj (obj)
port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "scm_strprint_obj");
scm_prin1 (obj, port, 1);
{
struct scm_port_table *pt = SCM_PTAB_ENTRY (obj);
SCM answer;
SCM_DEFER_INTS;
answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (port))),
SCM_INUM (SCM_CAR (SCM_STREAM (port))),
answer = scm_makfromstr (SCM_CHARS (SCM_STREAM (port)),
pt->write_pos - pt->write_buf,
0);
SCM_ALLOW_INTS;
return answer;
}
}
@ -285,13 +274,11 @@ scm_ptobfuns scm_stptob =
noop0,
prinstpt,
0,
stputc,
stputs,
stwrite,
noop0,
stgetc,
scm_generic_fgets,
0
st_flush,
0,
stfill_buffer,
0,
0,
};

8
libguile/tags.h
View file

@ -364,17 +364,13 @@ typedef long SCM;
#define scm_tc7_lsubr 119
/* There are 256 port subtypes. Here are the first four.
/* There are 256 port subtypes. Here are the first few.
* These must agree with the init function in ports.c
*/
#define scm_tc7_port 125
/* fports and pipes form an intended TYP16S equivelancy
* group (similar to a tc7 "couple".
*/
#define scm_tc16_fport (scm_tc7_port + 0*256L)
#define scm_tc16_pipe (scm_tc7_port + 1*256L)
/* scm_tc16_pipe was here. */
#define scm_tc16_strport (scm_tc7_port + 2*256L)
#define scm_tc16_sfport (scm_tc7_port + 3*256L)

8
libguile/throw.c
View file

@ -527,10 +527,14 @@ scm_handle_by_message (handler_data, tag, args)
SCM args;
{
if (SCM_NFALSEP (scm_eq_p (tag, SCM_CAR (scm_intern0 ("quit")))))
exit (scm_exit_status (args));
{
exit (scm_exit_status (args));
}
handler_message (handler_data, tag, args);
/* try to flush the error message first before the rest of the
ports: if any throw error, it currently causes a bus
exception. */
exit (2);
}

2
libguile/unif.c
View file

@ -44,7 +44,7 @@
#include "_scm.h"
#include "chars.h"
#include "eval.h"
#include "genio.h"
#include "fports.h"
#include "smob.h"
#include "strop.h"
#include "feature.h"

96
libguile/vports.c
View file

@ -72,71 +72,47 @@ prinsfpt (exp, port, pstate)
return !0;
}
/* sfputc sfwrite sfputs sfclose
* are called within a SCM_SYSCALL.
*
* So we need to set errno to 0 before returning. sfflush
* may be called within a SCM_SYSCALL. So we need to set errno to 0
* before returning.
*/
static int
sfputc (int c, SCM port)
{
SCM p = SCM_STREAM (port);
scm_apply (SCM_VELTS (p)[0], SCM_MAKICHR (c), scm_listofnull);
errno = 0;
return c;
}
static scm_sizet
sfwrite (char *str, scm_sizet siz, scm_sizet num, SCM port)
{
SCM p = SCM_STREAM (port);
SCM sstr;
sstr = scm_makfromstr (str, siz * num, 0);
scm_apply (SCM_VELTS (p)[1], sstr, scm_listofnull);
errno = 0;
return num;
}
static int
sfputs (char *s, SCM port)
{
sfwrite (s, 1, strlen (s), port);
return 0;
}
static int
/* called with a single char at most. */
static void
sfflush (SCM port)
{
SCM stream = SCM_STREAM (port);
struct scm_port_table *pt = SCM_PTAB_ENTRY (port);
SCM stream = pt->stream;
SCM f = SCM_VELTS (stream)[2];
if (SCM_BOOL_F == f)
return 0;
f = scm_apply (f, SCM_EOL, SCM_EOL);
errno = 0;
return SCM_BOOL_F == f ? EOF : 0;
if (pt->write_pos > pt->write_buf)
{
/* write the char. */
scm_apply (SCM_VELTS (stream)[0], SCM_MAKICHR (*pt->write_buf),
scm_listofnull);
pt->write_pos = pt->write_buf;
/* flush the output. */
{
SCM f = SCM_VELTS (stream)[2];
if (f != SCM_BOOL_F)
scm_apply (f, SCM_EOL, SCM_EOL);
}
}
}
/* string output proc (element 1) is no longer called. */
/* calling the flush proc (element 2) is in case old code needs it,
but perhaps softports could the use port buffer in the same way as
fports. */
/* returns a single character. */
static int
sfgetc (SCM port)
sf_fill_buffer (SCM port)
{
SCM p = SCM_STREAM (port);
SCM ans;
ans = scm_apply (SCM_VELTS (p)[3], SCM_EOL, SCM_EOL);
errno = 0;
ans = scm_apply (SCM_VELTS (p)[3], SCM_EOL, SCM_EOL); /* get char. */
if (SCM_FALSEP (ans) || SCM_EOF_OBJECT_P (ans))
return EOF;
SCM_ASSERT (SCM_ICHRP (ans), ans, SCM_ARG1, "getc");
SCM_ASSERT (SCM_ICHRP (ans), ans, SCM_ARG1, "sf_fill_buffer");
return SCM_ICHR (ans);
}
@ -173,6 +149,10 @@ scm_make_soft_port (pv, modes)
SCM_SETCAR (z, scm_tc16_sfport | scm_mode_bits (SCM_ROCHARS (modes)));
SCM_SETPTAB_ENTRY (z, pt);
SCM_SETSTREAM (z, pv);
pt->read_buf = pt->read_pos = pt->read_end = &pt->shortbuf;
pt->write_buf = pt->write_pos = &pt->shortbuf;
pt->read_buf_size = pt->write_buf_size = 1;
pt->write_end = pt->write_buf + pt->write_buf_size;
SCM_ALLOW_INTS;
return z;
}
@ -191,13 +171,11 @@ scm_ptobfuns scm_sfptob =
noop0,
prinsfpt,
0,
sfputc,
sfputs,
sfwrite,
sfflush,
sfgetc,
scm_generic_fgets,
sfclose
sfclose,
sf_fill_buffer,
0,
0,
};