-/* Copyright (C) 1995,1996,1997,1998,1999, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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
/* Headers. */
#include <stdio.h>
+#include <errno.h>
+
#include "libguile/_scm.h"
+#include "libguile/eval.h"
#include "libguile/objects.h"
#include "libguile/smob.h"
#include "libguile/chars.h"
* Indexes into this table are used when generating type
* tags for smobjects (if you know a tag you can get an index and conversely).
*/
-scm_ptob_descriptor *scm_ptobs;
-int scm_numptob;
+scm_t_ptob_descriptor *scm_ptobs;
+long scm_numptob;
/* GC marker for a port with stream of SCM type. */
SCM
*/
static void
-flush_port_default (SCM port)
+flush_port_default (SCM port SCM_UNUSED)
{
}
static void
-end_input_default (SCM port, int offset)
+end_input_default (SCM port SCM_UNUSED, int offset SCM_UNUSED)
{
}
-long
+scm_t_bits
scm_make_port_type (char *name,
int (*fill_input) (SCM port),
void (*write) (SCM port, const void *data, size_t size))
SCM_DEFER_INTS;
SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs,
(1 + scm_numptob)
- * sizeof (scm_ptob_descriptor)));
+ * sizeof (scm_t_ptob_descriptor)));
if (tmp)
{
- scm_ptobs = (scm_ptob_descriptor *) tmp;
+ scm_ptobs = (scm_t_ptob_descriptor *) tmp;
scm_ptobs[scm_numptob].name = name;
scm_ptobs[scm_numptob].mark = 0;
}
void
-scm_set_port_free (long tc, scm_sizet (*free) (SCM))
+scm_set_port_free (long tc, size_t (*free) (SCM))
{
scm_ptobs[SCM_TC2PTOBNUM (tc)].free = free;
}
\f
SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0,
- (SCM port),
- "Returns @code{#t} if a character is ready on input @var{port} and\n"
- "returns @code{#f} otherwise. If @code{char-ready?} returns @code{#t}\n"
- "then the next @code{read-char} operation on @var{port} is\n"
- "guaranteed not to hang. If @var{port} is a file port at end of\n"
- "file then @code{char-ready?} returns @code{#t}.\n"
- "@footnote{@code{char-ready?} exists to make it possible for a\n"
- "program to accept characters from interactive ports without getting\n"
- "stuck waiting for input. Any input editors associated with such ports\n"
- "must make sure that characters whose existence has been asserted by\n"
- "@code{char-ready?} cannot be rubbed out. If @code{char-ready?} were to\n"
- "return @code{#f} at end of file, a port at end of file would be\n"
- "indistinguishable from an interactive port that has no ready\n"
- "characters.}")
+ (SCM port),
+ "Return @code{#t} if a character is ready on input @var{port}\n"
+ "and return @code{#f} otherwise. If @code{char-ready?} returns\n"
+ "@code{#t} then the next @code{read-char} operation on\n"
+ "@var{port} is guaranteed not to hang. If @var{port} is a file\n"
+ "port at end of file then @code{char-ready?} returns @code{#t}.\n"
+ "@footnote{@code{char-ready?} exists to make it possible for a\n"
+ "program to accept characters from interactive ports without\n"
+ "getting stuck waiting for input. Any input editors associated\n"
+ "with such ports must make sure that characters whose existence\n"
+ "has been asserted by @code{char-ready?} cannot be rubbed out.\n"
+ "If @code{char-ready?} were to return @code{#f} at end of file,\n"
+ "a port at end of file would be indistinguishable from an\n"
+ "interactive port that has no ready characters.}")
#define FUNC_NAME s_scm_char_ready_p
{
- scm_port *pt;
+ scm_t_port *pt;
if (SCM_UNBNDP (port))
port = scm_cur_inp;
return SCM_BOOL_T;
else
{
- scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
+ scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
if (ptob->input_waiting)
return SCM_BOOL(ptob->input_waiting (port));
}
#undef FUNC_NAME
+/* move up to read_len chars from port's putback and/or read buffers
+ into memory starting at dest. returns the number of chars moved. */
+size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ size_t chars_read = 0;
+ size_t from_buf = min (pt->read_end - pt->read_pos, read_len);
+
+ if (from_buf > 0)
+ {
+ memcpy (dest, pt->read_pos, from_buf);
+ pt->read_pos += from_buf;
+ chars_read += from_buf;
+ read_len -= from_buf;
+ dest += from_buf;
+ }
+
+ /* if putback was active, try the real input buffer too. */
+ if (pt->read_buf == pt->putback_buf)
+ {
+ from_buf = min (pt->saved_read_end - pt->saved_read_pos, read_len);
+ if (from_buf > 0)
+ {
+ memcpy (dest, pt->saved_read_pos, from_buf);
+ pt->saved_read_pos += from_buf;
+ chars_read += from_buf;
+ }
+ }
+ return chars_read;
+}
+
/* Clear a port's read buffers, returning the contents. */
SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
(SCM port),
- "Drains @var{PORT}'s read buffers (including any pushed-back characters)\n"
- "and returns the contents as a single string.")
+ "Drain @var{port}'s read buffers (including any pushed-back\n"
+ "characters) and return the content as a single string.")
#define FUNC_NAME s_scm_drain_input
{
SCM result;
- scm_port *pt = SCM_PTAB_ENTRY (port);
- int count;
- char *dst;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ long count;
SCM_VALIDATE_OPINPORT (1,port);
if (pt->read_buf == pt->putback_buf)
count += pt->saved_read_end - pt->saved_read_pos;
- result = scm_makstr (count, 0);
- dst = SCM_STRING_CHARS (result);
-
- while (pt->read_pos < pt->read_end)
- *dst++ = *(pt->read_pos++);
-
- if (pt->read_buf == pt->putback_buf)
- {
- while (pt->saved_read_pos < pt->saved_read_end)
- *dst++ = *(pt->saved_read_pos++);
- }
+ result = scm_allocate_string (count);
+ scm_take_from_input_buffers (port, SCM_STRING_CHARS (result), count);
return result;
}
/* Standard ports --- current input, output, error, and more(!). */
SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
- (),
- "Returns the current input port. This is the default port used by many\n"
- "input procedures. Initially, @code{current-input-port} returns the\n"
- "value of @code{???}.")
+ (),
+ "Return the current input port. This is the default port used\n"
+ "by many input procedures. Initially, @code{current-input-port}\n"
+ "returns the @dfn{standard input} in Unix and C terminology.")
#define FUNC_NAME s_scm_current_input_port
{
return scm_cur_inp;
#undef FUNC_NAME
SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0,
- (),
- "Returns the current output port. This is the default port used by many\n"
- "output procedures. Initially, @code{current-output-port} returns the\n"
- "value of @code{???}.")
+ (),
+ "Return the current output port. This is the default port used\n"
+ "by many output procedures. Initially, \n"
+ "@code{current-output-port} returns the @dfn{standard output} in\n"
+ "Unix and C terminology.")
#define FUNC_NAME s_scm_current_output_port
{
return scm_cur_outp;
#undef FUNC_NAME
SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
- (),
+ (),
"Return the current-load-port.\n"
- "The load port is used internally by `primitive-load'.")
+ "The load port is used internally by @code{primitive-load}.")
#define FUNC_NAME s_scm_current_load_port
{
return scm_cur_loadp;
SCM_DEFINE (scm_set_current_output_port, "set-current-output-port", 1, 0, 0,
- (SCM port),
- "Set the current default output port to PORT.")
+ (SCM port),
+ "Set the current default output port to @var{port}.")
#define FUNC_NAME s_scm_set_current_output_port
{
SCM ooutp = scm_cur_outp;
SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0,
- (SCM port),
- "Set the current default error port to PORT.")
+ (SCM port),
+ "Set the current default error port to @var{port}.")
#define FUNC_NAME s_scm_set_current_error_port
{
SCM oerrp = scm_cur_errp;
\f
/* The port table --- an array of pointers to ports. */
-scm_port **scm_port_table;
+scm_t_port **scm_t_portable;
-int scm_port_table_size = 0; /* Number of ports in scm_port_table. */
-int scm_port_table_room = 20; /* Size of the array. */
+long scm_t_portable_size = 0; /* Number of ports in scm_t_portable. */
+long scm_t_portable_room = 20; /* Size of the array. */
/* Add a port to the table. */
-scm_port *
+scm_t_port *
scm_add_to_port_table (SCM port)
+#define FUNC_NAME "scm_add_to_port_table"
{
- scm_port *entry;
+ scm_t_port *entry;
- if (scm_port_table_size == scm_port_table_room)
+ if (scm_t_portable_size == scm_t_portable_room)
{
- void *newt = realloc ((char *) scm_port_table,
- (scm_sizet) (sizeof (scm_port *)
- * scm_port_table_room * 2));
+ /* initial malloc is in gc.c. this doesn't use scm_must_malloc etc.,
+ since it can never be freed during gc. */
+ void *newt = realloc ((char *) scm_t_portable,
+ (size_t) (sizeof (scm_t_port *)
+ * scm_t_portable_room * 2));
if (newt == NULL)
scm_memory_error ("scm_add_to_port_table");
- scm_port_table = (scm_port **) newt;
- scm_port_table_room *= 2;
+ scm_t_portable = (scm_t_port **) newt;
+ scm_t_portable_room *= 2;
}
- entry = (scm_port *) malloc (sizeof (scm_port));
- if (entry == NULL)
- scm_memory_error ("scm_add_to_port_table");
+ entry = (scm_t_port *) scm_must_malloc (sizeof (scm_t_port), FUNC_NAME);
entry->port = port;
- entry->entry = scm_port_table_size;
+ entry->entry = scm_t_portable_size;
entry->revealed = 0;
entry->stream = 0;
entry->file_name = SCM_BOOL_F;
entry->rw_active = SCM_PORT_NEITHER;
entry->rw_random = 0;
- scm_port_table[scm_port_table_size] = entry;
- scm_port_table_size++;
+ scm_t_portable[scm_t_portable_size] = entry;
+ scm_t_portable_size++;
return entry;
}
+#undef FUNC_NAME
/* Remove a port from the table and destroy it. */
void
scm_remove_from_port_table (SCM port)
+#define FUNC_NAME "scm_remove_from_port_table"
{
- scm_port *p = SCM_PTAB_ENTRY (port);
- int i = p->entry;
+ scm_t_port *p = SCM_PTAB_ENTRY (port);
+ long i = p->entry;
- if (i >= scm_port_table_size)
- scm_wta (port, "Port not in table", "scm_remove_from_port_table");
+ if (i >= scm_t_portable_size)
+ SCM_MISC_ERROR ("Port not in table: ~S", SCM_LIST1 (port));
if (p->putback_buf)
- free (p->putback_buf);
- free (p);
+ scm_must_free (p->putback_buf);
+ scm_must_free (p);
/* Since we have just freed slot i we can shrink the table by moving
the last entry to that slot... */
- if (i < scm_port_table_size - 1)
+ if (i < scm_t_portable_size - 1)
{
- scm_port_table[i] = scm_port_table[scm_port_table_size - 1];
- scm_port_table[i]->entry = i;
+ scm_t_portable[i] = scm_t_portable[scm_t_portable_size - 1];
+ scm_t_portable[i]->entry = i;
}
SCM_SETPTAB_ENTRY (port, 0);
- scm_port_table_size--;
+ scm_t_portable_size--;
}
+#undef FUNC_NAME
+
#ifdef GUILE_DEBUG
/* Functions for debugging. */
SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0,
(),
- "Returns the number of ports in the port table.\n"
- "`pt-size' is only included in GUILE_DEBUG builds.")
+ "Return the number of ports in the port table. @code{pt-size}\n"
+ "is only included in @code{--enable-guile-debug} builds.")
#define FUNC_NAME s_scm_pt_size
{
- return SCM_MAKINUM (scm_port_table_size);
+ return SCM_MAKINUM (scm_t_portable_size);
}
#undef FUNC_NAME
SCM_DEFINE (scm_pt_member, "pt-member", 1, 0, 0,
(SCM index),
- "Returns the port at INDEX in the port table.\n"
- "`pt-member' is only included in GUILE_DEBUG builds.")
+ "Return the port at @var{index} in the port table.\n"
+ "@code{pt-member} is only included in\n"
+ "@code{--enable-guile-debug} builds.")
#define FUNC_NAME s_scm_pt_member
{
- int i;
+ long i;
SCM_VALIDATE_INUM_COPY (1,index,i);
- if (i < 0 || i >= scm_port_table_size)
+ if (i < 0 || i >= scm_t_portable_size)
return SCM_BOOL_F;
else
- return scm_port_table[i]->port;
+ return scm_t_portable[i]->port;
}
#undef FUNC_NAME
#endif
void
-scm_port_non_buffer (scm_port *pt)
+scm_port_non_buffer (scm_t_port *pt)
{
pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
pt->write_buf = pt->write_pos = &pt->shortbuf;
SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
(SCM port),
- "Returns the revealed count for @var{port}.")
+ "Return the revealed count for @var{port}.")
#define FUNC_NAME s_scm_port_revealed
{
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_PORT (1,port);
+ SCM_VALIDATE_OPENPORT (1,port);
return SCM_MAKINUM (scm_revealed_count (port));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_set_port_revealed_x
{
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_PORT (1,port);
+ SCM_VALIDATE_OPENPORT (1,port);
SCM_VALIDATE_INUM (2,rcount);
SCM_REVEALED (port) = SCM_INUM (rcount);
return SCM_UNSPECIFIED;
SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0,
(SCM port),
- "Returns the port modes associated with the open port @var{port}. These\n"
- "will not necessarily be identical to the modes used when the port was\n"
- "opened, since modes such as \"append\" which are used only during\n"
- "port creation are not retained.")
+ "Return the port modes associated with the open port @var{port}.\n"
+ "These will not necessarily be identical to the modes used when\n"
+ "the port was opened, since modes such as \"append\" which are\n"
+ "used only during port creation are not retained.")
#define FUNC_NAME s_scm_port_mode
{
- char modes[3];
+ char modes[4];
modes[0] = '\0';
port = SCM_COERCE_OUTPORT (port);
strcpy (modes, "w");
if (SCM_CELL_WORD_0 (port) & SCM_BUF0)
strcat (modes, "0");
- return scm_makfromstr (modes, strlen (modes), 0);
+ return scm_mem2string (modes, strlen (modes));
}
#undef FUNC_NAME
*/
SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
(SCM port),
- "Close the specified port object. Returns @code{#t} if it successfully\n"
- "closes a port or @code{#f} if it was already\n"
- "closed. An exception may be raised if an error occurs, for example\n"
- "when flushing buffered output.\n"
- "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
- "which can close file descriptors.")
+ "Close the specified port object. Return @code{#t} if it\n"
+ "successfully closes a port or @code{#f} if it was already\n"
+ "closed. An exception may be raised if an error occurs, for\n"
+ "example when flushing buffered output. See also @ref{Ports and\n"
+ "File Descriptors, close}, for a procedure which can close file\n"
+ "descriptors.")
#define FUNC_NAME s_scm_close_port
{
- scm_sizet i;
+ size_t i;
int rv;
port = SCM_COERCE_OUTPORT (port);
else
rv = 0;
scm_remove_from_port_table (port);
- SCM_SETAND_CAR (port, ~SCM_OPN);
- return SCM_NEGATE_BOOL (rv < 0);
+ SCM_CLR_PORT_OPEN_FLAG (port);
+ return SCM_BOOL (rv >= 0);
}
#undef FUNC_NAME
}
#undef FUNC_NAME
+SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0,
+ (SCM proc),
+ "Apply @var{proc} to each port in the Guile port table\n"
+ "in turn. The return value is unspecified. More specifically,\n"
+ "@var{proc} is applied exactly once to every port that exists\n"
+ "in the system at the time @var{port-for-each} is invoked.\n"
+ "Changes to the port table while @var{port-for-each} is running\n"
+ "have no effect as far as @var{port-for-each} is concerned.\n")
+#define FUNC_NAME s_scm_port_for_each
+{
+ long i;
+ SCM ports;
+
+ SCM_VALIDATE_PROC (1, proc);
+
+ /* when pre-emptive multithreading is supported, access to the port
+ table will need to be controlled by a mutex. */
+
+ /* Even without pre-emptive multithreading, running arbitrary code
+ while scanning the port table is unsafe because the port table
+ can change arbitrarily (from a GC, for example). So we build a
+ list in advance while blocking the GC. -mvo */
+
+ SCM_DEFER_INTS;
+ scm_block_gc++;
+ ports = SCM_EOL;
+ for (i = 0; i < scm_t_portable_size; i++)
+ ports = scm_cons (scm_t_portable[i]->port, ports);
+ scm_block_gc--;
+ SCM_ALLOW_INTS;
+
+ while (ports != SCM_EOL)
+ {
+ scm_apply (proc, scm_cons (SCM_CAR (ports), SCM_EOL), SCM_EOL);
+ ports = SCM_CDR (ports);
+ }
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#if (SCM_DEBUG_DEPRECATED == 0)
+
SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1,
(SCM ports),
- "Close all open file ports used by the interpreter\n"
+ "[DEPRECATED] Close all open file ports used by the interpreter\n"
"except for those supplied as arguments. This procedure\n"
- "is intended to be used before an exec call to close file descriptors\n"
- "which are not needed in the new process.")
+ "was intended to be used before an exec call to close file descriptors\n"
+ "which are not needed in the new process. However it has the\n"
+ "undesirable side-effect of flushing buffes, so it's deprecated.\n"
+ "Use port-for-each instead.")
#define FUNC_NAME s_scm_close_all_ports_except
{
- int i = 0;
+ long i = 0;
SCM_VALIDATE_REST_ARGUMENT (ports);
- while (i < scm_port_table_size)
+ while (i < scm_t_portable_size)
{
- SCM thisport = scm_port_table[i]->port;
+ SCM thisport = scm_t_portable[i]->port;
int found = 0;
SCM ports_ptr = ports;
- while (SCM_NNULLP (ports_ptr))
+ while (!SCM_NULLP (ports_ptr))
{
SCM port = SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr));
if (i == 0)
}
#undef FUNC_NAME
+#endif
\f
/* Utter miscellany. Gosh, we should clean this up some time. */
SCM_DEFINE (scm_input_port_p, "input-port?", 1, 0, 0,
(SCM x),
- "Returns @code{#t} if @var{x} is an input port, otherwise returns\n"
- "@code{#f}. Any object satisfying this predicate also satisfies\n"
- "@code{port?}.")
+ "Return @code{#t} if @var{x} is an input port, otherwise return\n"
+ "@code{#f}. Any object satisfying this predicate also satisfies\n"
+ "@code{port?}.")
#define FUNC_NAME s_scm_input_port_p
{
- if (SCM_IMP (x))
- return SCM_BOOL_F;
- return SCM_BOOL(SCM_INPUT_PORT_P (x));
+ return SCM_BOOL (SCM_INPUT_PORT_P (x));
}
#undef FUNC_NAME
SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0,
(SCM x),
- "Returns @code{#t} if @var{x} is an output port, otherwise returns\n"
- "@code{#f}. Any object satisfying this predicate also satisfies\n"
- "@code{port?}.")
+ "Return @code{#t} if @var{x} is an output port, otherwise return\n"
+ "@code{#f}. Any object satisfying this predicate also satisfies\n"
+ "@code{port?}.")
#define FUNC_NAME s_scm_output_port_p
{
- if (SCM_IMP (x))
- return SCM_BOOL_F;
- if (SCM_PORT_WITH_PS_P (x))
- x = SCM_PORT_WITH_PS_PORT (x);
- return SCM_BOOL(SCM_OUTPUT_PORT_P (x));
+ SCM_COERCE_OUTPORT (x);
+ return SCM_BOOL (SCM_OUTPUT_PORT_P (x));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_port_p, "port?", 1, 0, 0,
+ (SCM x),
+ "Return a boolean indicating whether @var{x} is a port.\n"
+ "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
+ "@var{x}))}.")
+#define FUNC_NAME s_scm_port_p
+{
+ return SCM_BOOL (SCM_PORTP (x));
}
#undef FUNC_NAME
SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0,
(SCM port),
- "Returns @code{#t} if @var{port} is closed or @code{#f} if it is open.")
+ "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
+ "open.")
#define FUNC_NAME s_scm_port_closed_p
{
SCM_VALIDATE_PORT (1,port);
- return SCM_NEGATE_BOOL(SCM_OPPORTP (port));
+ return SCM_BOOL (!SCM_OPPORTP (port));
}
#undef FUNC_NAME
SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0,
(SCM x),
- "Returns @code{#t} if @var{x} is an end-of-file object; otherwise\n"
- "returns @code{#f}.")
+ "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
+ "return @code{#f}.")
#define FUNC_NAME s_scm_eof_object_p
{
return SCM_BOOL(SCM_EOF_OBJECT_P (x));
"all open output ports. The return value is unspecified.")
#define FUNC_NAME s_scm_flush_all_ports
{
- int i;
+ size_t i;
- for (i = 0; i < scm_port_table_size; i++)
+ for (i = 0; i < scm_t_portable_size; i++)
{
- if (SCM_OPOUTPORTP (scm_port_table[i]->port))
- scm_flush (scm_port_table[i]->port);
+ if (SCM_OPOUTPORTP (scm_t_portable[i]->port))
+ scm_flush (scm_t_portable[i]->port);
}
return SCM_UNSPECIFIED;
}
SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0,
(SCM port),
- "Returns the next character available from @var{port}, updating\n"
- "@var{port} to point to the following character. If no more\n"
- "characters are available, an end-of-file object is returned.")
+ "Return the next character available from @var{port}, updating\n"
+ "@var{port} to point to the following character. If no more\n"
+ "characters are available, the end-of-file object is returned.")
#define FUNC_NAME s_scm_read_char
{
int c;
int
scm_fill_input (SCM port)
{
- scm_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
if (pt->read_buf == pt->putback_buf)
{
scm_getc (SCM port)
{
int c;
- scm_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
if (pt->rw_active == SCM_PORT_WRITE)
{
scm_lfwrite (s, strlen (s), port);
}
+/* scm_lfwrite
+ *
+ * This function differs from scm_c_write; it updates port line and
+ * column. */
+
void
-scm_lfwrite (const char *ptr, scm_sizet size, SCM port)
+scm_lfwrite (const char *ptr, size_t size, SCM port)
{
- scm_port *pt = SCM_PTAB_ENTRY (port);
- scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
if (pt->rw_active == SCM_PORT_READ)
scm_end_input (port);
ptob->write (port, ptr, size);
+ for (; size; ptr++, size--) {
+ if (*ptr == '\n') {
+ SCM_INCLINE(port);
+ }
+ else if (*ptr == '\t') {
+ SCM_TABCOL(port);
+ }
+ else {
+ SCM_INCCOL(port);
+ }
+ }
+
if (pt->rw_random)
pt->rw_active = SCM_PORT_WRITE;
}
+/* scm_c_read
+ *
+ * Used by an application to read arbitrary number of bytes from an
+ * SCM port. Same semantics as libc read, except that scm_c_read only
+ * returns less than SIZE bytes if at end-of-file.
+ *
+ * Warning: Doesn't update port line and column counts! */
+
+size_t
+scm_c_read (SCM port, void *buffer, size_t size)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ size_t n_read = 0, n_available;
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ scm_ptobs[SCM_PTOBNUM (port)].flush (port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ if (SCM_READ_BUFFER_EMPTY_P (pt))
+ {
+ if (scm_fill_input (port) == EOF)
+ return 0;
+ }
+
+ n_available = pt->read_end - pt->read_pos;
+
+ while (n_available < size)
+ {
+ memcpy (buffer, pt->read_pos, n_available);
+ buffer = (char *) buffer + n_available;
+ pt->read_pos += n_available;
+ n_read += n_available;
+
+ if (SCM_READ_BUFFER_EMPTY_P (pt))
+ {
+ if (scm_fill_input (port) == EOF)
+ return n_read;
+ }
+
+ size -= n_available;
+ n_available = pt->read_end - pt->read_pos;
+ }
+
+ memcpy (buffer, pt->read_pos, size);
+ pt->read_pos += size;
+
+ return n_read + size;
+}
+
+/* scm_c_write
+ *
+ * Used by an application to write arbitrary number of bytes to an SCM
+ * port. Similar semantics as libc write. However, unlike libc
+ * write, scm_c_write writes the requested number of bytes and has no
+ * return value.
+ *
+ * Warning: Doesn't update port line and column counts!
+ */
+
+void
+scm_c_write (SCM port, const void *ptr, size_t size)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
+
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input (port);
+
+ ptob->write (port, ptr, size);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
+}
void
scm_flush (SCM port)
{
- scm_sizet i = SCM_PTOBNUM (port);
+ long i = SCM_PTOBNUM (port);
(scm_ptobs[i].flush) (port);
}
void
scm_end_input (SCM port)
{
- int offset;
- scm_port *pt = SCM_PTAB_ENTRY (port);
+ long offset;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
if (pt->read_buf == pt->putback_buf)
{
void
scm_ungetc (int c, SCM port)
+#define FUNC_NAME "scm_ungetc"
{
- scm_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
if (pt->read_buf == pt->putback_buf)
/* already using the put-back buffer. */
if (pt->read_end == pt->read_buf + pt->read_buf_size
&& pt->read_buf == pt->read_pos)
{
- int new_size = pt->read_buf_size * 2;
- unsigned char *tmp =
- (unsigned char *) realloc (pt->putback_buf, new_size);
+ size_t new_size = pt->read_buf_size * 2;
+ unsigned char *tmp = (unsigned char *)
+ scm_must_realloc (pt->putback_buf, pt->read_buf_size, new_size,
+ FUNC_NAME);
- if (tmp == NULL)
- scm_memory_error ("scm_ungetc");
pt->read_pos = pt->read_buf = pt->putback_buf = tmp;
pt->read_end = pt->read_buf + pt->read_buf_size;
pt->read_buf_size = pt->putback_buf_size = new_size;
if (pt->putback_buf == NULL)
{
pt->putback_buf
- = (unsigned char *) malloc (SCM_INITIAL_PUTBACK_BUF_SIZE);
- if (pt->putback_buf == NULL)
- scm_memory_error ("scm_ungetc");
+ = (unsigned char *) scm_must_malloc (SCM_INITIAL_PUTBACK_BUF_SIZE,
+ FUNC_NAME);
pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE;
}
else
SCM_COL(port) -= 1;
}
+#undef FUNC_NAME
void
SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
(SCM port),
- "Returns the next character available from @var{port},\n"
- "@emph{without} updating @var{port} to point to the following\n"
- "character. If no more characters are available, an end-of-file object\n"
- "is returned.@footnote{The value returned by a call to @code{peek-char}\n"
- "is the same as the value that would have been returned by a call to\n"
- "@code{read-char} on the same port. The only difference is that the very\n"
- "next call to @code{read-char} or @code{peek-char} on that\n"
- "@var{port} will return the value returned by the preceding call to\n"
- "@code{peek-char}. In particular, a call to @code{peek-char} on an\n"
- "interactive port will hang waiting for input whenever a call to\n"
- "@code{read-char} would have hung.}")
+ "Return the next character available from @var{port},\n"
+ "@emph{without} updating @var{port} to point to the following\n"
+ "character. If no more characters are available, the\n"
+ "end-of-file object is returned.@footnote{The value returned by\n"
+ "a call to @code{peek-char} is the same as the value that would\n"
+ "have been returned by a call to @code{read-char} on the same\n"
+ "port. The only difference is that the very next call to\n"
+ "@code{read-char} or @code{peek-char} on that @var{port} will\n"
+ "return the value returned by the preceding call to\n"
+ "@code{peek-char}. In particular, a call to @code{peek-char} on\n"
+ "an interactive port will hang waiting for input whenever a call\n"
+ "to @code{read-char} would have hung.}")
#define FUNC_NAME s_scm_peek_char
{
int c;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_unread_char, "unread-char", 2, 0, 0,
+SCM_DEFINE (scm_unread_char, "unread-char", 1, 1, 0,
(SCM cobj, SCM port),
"Place @var{char} in @var{port} so that it will be read by the\n"
"next read operation. If called multiple times, the unread characters\n"
else
SCM_VALIDATE_OPINPORT (2,port);
- scm_ungets (SCM_ROCHARS (str), SCM_LENGTH (str), port);
+ scm_ungets (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), port);
return str;
}
#undef FUNC_NAME
SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
- (SCM object, SCM offset, SCM whence),
- "Sets the current position of @var{fd/port} to the integer @var{offset},\n"
- "which is interpreted according to the value of @var{whence}.\n\n"
- "One of the following variables should be supplied\n"
- "for @var{whence}:\n"
+ (SCM fd_port, SCM offset, SCM whence),
+ "Sets the current position of @var{fd/port} to the integer\n"
+ "@var{offset}, which is interpreted according to the value of\n"
+ "@var{whence}.\n"
+ "\n"
+ "One of the following variables should be supplied for\n"
+ "@var{whence}:\n"
"@defvar SEEK_SET\n"
"Seek from the beginning of the file.\n"
"@end defvar\n"
"@end defvar\n"
"@defvar SEEK_END\n"
"Seek from the end of the file.\n"
- "@end defvar\n\n"
- "If @var{fd/port} is a file descriptor, the underlying system call is\n"
- "@code{lseek}. @var{port} may be a string port.\n\n"
- "The value returned is the new position in the file. This means that\n"
- "the current position of a port can be obtained using:\n"
- "@smalllisp\n"
+ "@end defvar\n"
+ "If @var{fd/port} is a file descriptor, the underlying system\n"
+ "call is @code{lseek}. @var{port} may be a string port.\n"
+ "\n"
+ "The value returned is the new position in the file. This means\n"
+ "that the current position of a port can be obtained using:\n"
+ "@lisp\n"
"(seek port 0 SEEK_CUR)\n"
- "@end smalllisp")
+ "@end lisp")
#define FUNC_NAME s_scm_seek
{
off_t off;
off_t rv;
int how;
- object = SCM_COERCE_OUTPORT (object);
+ fd_port = SCM_COERCE_OUTPORT (fd_port);
- off = SCM_NUM2LONG (2,offset);
- SCM_VALIDATE_INUM_COPY (3,whence,how);
+ off = SCM_NUM2LONG (2, offset);
+ SCM_VALIDATE_INUM_COPY (3, whence, how);
if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
SCM_OUT_OF_RANGE (3, whence);
- if (SCM_OPPORTP (object))
+ if (SCM_OPPORTP (fd_port))
{
- scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object);
+ scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port);
if (!ptob->seek)
SCM_MISC_ERROR ("port is not seekable",
- scm_cons (object, SCM_EOL));
+ scm_cons (fd_port, SCM_EOL));
else
- rv = ptob->seek (object, off, how);
+ rv = ptob->seek (fd_port, off, how);
}
else /* file descriptor?. */
{
- SCM_VALIDATE_INUM (1,object);
- rv = lseek (SCM_INUM (object), off, how);
+ SCM_VALIDATE_INUM (1,fd_port);
+ rv = lseek (SCM_INUM (fd_port), off, how);
if (rv == -1)
SCM_SYSERROR;
}
SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
(SCM object, SCM length),
- "Truncates the object referred to by @var{obj} to at most @var{size} bytes.\n"
- "@var{obj} can be a string containing a file name or an integer file\n"
- "descriptor or a port. @var{size} may be omitted if @var{obj} is not\n"
- "a file name, in which case the truncation occurs at the current port.\n"
- "position.\n\n"
- "The return value is unspecified.")
+ "Truncates the object referred to by @var{object} to at most\n"
+ "@var{length} bytes. @var{object} can be a string containing a\n"
+ "file name or an integer file descriptor or a port.\n"
+ "@var{length} may be omitted if @var{object} is not a file name,\n"
+ "in which case the truncation occurs at the current port.\n"
+ "position. The return value is unspecified.")
#define FUNC_NAME s_scm_truncate_file
{
int rv;
if (SCM_UNBNDP (length))
{
/* must supply length if object is a filename. */
- if (SCM_ROSTRINGP (object))
+ if (SCM_STRINGP (object))
SCM_MISC_ERROR("must supply length if OBJECT is a filename",SCM_EOL);
length = scm_seek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR));
}
else if (SCM_OPOUTPORTP (object))
{
- scm_port *pt = SCM_PTAB_ENTRY (object);
- scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object);
+ scm_t_port *pt = SCM_PTAB_ENTRY (object);
+ scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object);
if (!ptob->truncate)
SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
}
else
{
- SCM_VALIDATE_ROSTRING (1,object);
- SCM_COERCE_SUBSTR (object);
- SCM_SYSCALL (rv = truncate (SCM_ROCHARS (object), c_length));
+ SCM_VALIDATE_STRING (1, object);
+ SCM_STRING_COERCE_0TERMINATION_X (object);
+ SCM_SYSCALL (rv = truncate (SCM_STRING_CHARS (object), c_length));
}
if (rv == -1)
SCM_SYSERROR;
SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0,
(SCM port),
- "Return the current line number for PORT.")
+ "Return the current line number for @var{port}.")
#define FUNC_NAME s_scm_port_line
{
port = SCM_COERCE_OUTPORT (port);
SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0,
(SCM port, SCM line),
- "Set the current line number for PORT to LINE.")
+ "Set the current line number for @var{port} to @var{line}.")
#define FUNC_NAME s_scm_set_port_line_x
{
port = SCM_COERCE_OUTPORT (port);
SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0,
(SCM port),
- "@deffnx primitive port-line [input-port]\n"
- "Return the current column number or line number of @var{input-port},\n"
+ "@deffnx primitive port-line port\n"
+ "Return the current column number or line number of @var{port},\n"
"using the current input port if none is specified. If the number is\n"
"unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
"- i.e. the first character of the first line is line 0, column 0.\n"
"(However, when you display a file position, for example in an error\n"
- "message, we recommand you add 1 to get 1-origin integers. This is\n"
+ "message, we recommend you add 1 to get 1-origin integers. This is\n"
"because lines and column numbers traditionally start with 1, and that is\n"
"what non-programmers will find most natural.)")
#define FUNC_NAME s_scm_port_column
{
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1,port);
- return SCM_PTAB_ENTRY (port)->file_name;
+ return SCM_FILENAME (port);
}
#undef FUNC_NAME
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1,port);
/* We allow the user to set the filename to whatever he likes. */
- return SCM_PTAB_ENTRY (port)->file_name = filename;
+ SCM_SET_FILENAME (port, filename);
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
}
int
-scm_port_print (SCM exp, SCM port, scm_print_state *pstate)
+scm_port_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
char *type = SCM_PTOBNAME (SCM_PTOBNUM (exp));
if (!type)
return 1;
}
-extern void scm_make_fptob ();
-extern void scm_make_stptob ();
-extern void scm_make_sfptob ();
-
void
scm_ports_prehistory ()
{
scm_numptob = 0;
- scm_ptobs = (scm_ptob_descriptor *) malloc (sizeof (scm_ptob_descriptor));
-
- /* WARNING: These scm_newptob calls must be done in this order.
- * They must agree with the port declarations in tags.h.
- */
- /* scm_tc16_fport = */ scm_make_fptob ();
- /* scm_tc16_pipe was here */ scm_make_fptob (); /* dummy. */
- /* scm_tc16_strport = */ scm_make_stptob ();
- /* scm_tc16_sfport = */ scm_make_sfptob ();
+ scm_ptobs = (scm_t_ptob_descriptor *) malloc (sizeof (scm_t_ptob_descriptor));
}
\f
/* Void ports. */
-long scm_tc16_void_port = 0;
+scm_t_bits scm_tc16_void_port = 0;
-static int fill_input_void_port (SCM port)
+static int fill_input_void_port (SCM port SCM_UNUSED)
{
return EOF;
}
static void
-write_void_port (SCM port, const void *data, size_t size)
+write_void_port (SCM port SCM_UNUSED,
+ const void *data SCM_UNUSED,
+ size_t size SCM_UNUSED)
{
}
{
int mode_bits;
SCM answer;
- scm_port * pt;
+ scm_t_port * pt;
SCM_NEWCELL (answer);
SCM_DEFER_INTS;
"documentation for @code{open-file} in @ref{File Ports}.")
#define FUNC_NAME s_scm_sys_make_void_port
{
- SCM_VALIDATE_ROSTRING (1,mode);
- SCM_COERCE_SUBSTR (mode);
- return scm_void_port (SCM_ROCHARS (mode));
+ SCM_VALIDATE_STRING (1, mode);
+ SCM_STRING_COERCE_0TERMINATION_X (mode);
+ return scm_void_port (SCM_STRING_CHARS (mode));
}
#undef FUNC_NAME
scm_init_ports ()
{
/* lseek() symbols. */
- scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET));
- scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR));
- scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END));
+ scm_c_define ("SEEK_SET", SCM_MAKINUM (SEEK_SET));
+ scm_c_define ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR));
+ scm_c_define ("SEEK_END", SCM_MAKINUM (SEEK_END));
scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port,
write_void_port);
+#ifndef SCM_MAGIC_SNARFER
#include "libguile/ports.x"
+#endif
}
/*
HCoop / bpt / guile.git / blobdiff