-/* Copyright (C) 1995,1996,1997,1998,1999 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 "_scm.h"
-#include "objects.h"
-#include "smob.h"
-#include "chars.h"
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/objects.h"
+#include "libguile/smob.h"
+#include "libguile/chars.h"
-#include "keywords.h"
+#include "libguile/keywords.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
-#include "validate.h"
-#include "ports.h"
+#include "libguile/validate.h"
+#include "libguile/ports.h"
#ifdef HAVE_STRING_H
#include <string.h>
scm_markstream (SCM ptr)
{
int openp;
- openp = SCM_UNPACK_CAR (ptr) & SCM_OPN;
+ openp = SCM_CELL_WORD_0 (ptr) & SCM_OPN;
if (openp)
- return SCM_STREAM (ptr);
+ return SCM_PACK (SCM_STREAM (ptr));
else
return SCM_BOOL_F;
}
{
}
-long
+scm_bits_t
scm_make_port_type (char *name,
int (*fill_input) (SCM port),
void (*write) (SCM port, const void *data, size_t size))
}
SCM_ALLOW_INTS;
if (!tmp)
- ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob),
- (char *) SCM_NALLOC, "scm_make_port_type");
+ {
+ ptoberr:
+ scm_memory_error ("scm_make_port_type");
+ }
/* Make a class object if Goops is present */
if (scm_port_class)
scm_make_port_classes (scm_numptob - 1, SCM_PTOBNAME (scm_numptob - 1));
}
#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_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 returns 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_VALIDATE_OPINPORT (1,port);
count += pt->saved_read_end - pt->saved_read_pos;
result = scm_makstr (count, 0);
- dst = SCM_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++);
- }
+ 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;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPPORT (1,port);
- if (SCM_UNPACK_CAR (port) & SCM_RDNG) {
- if (SCM_UNPACK_CAR (port) & SCM_WRTNG)
+ if (SCM_CELL_WORD_0 (port) & SCM_RDNG) {
+ if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
strcpy (modes, "r+");
else
strcpy (modes, "r");
}
- else if (SCM_UNPACK_CAR (port) & SCM_WRTNG)
+ else if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
strcpy (modes, "w");
- if (SCM_UNPACK_CAR (port) & SCM_BUF0)
+ if (SCM_CELL_WORD_0 (port) & SCM_BUF0)
strcat (modes, "0");
return scm_makfromstr (modes, strlen (modes), 0);
}
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_PORT (1,port);
+ SCM_VALIDATE_PORT (1, port);
if (SCM_CLOSEDP (port))
return SCM_BOOL_F;
i = SCM_PTOBNUM (port);
rv = 0;
scm_remove_from_port_table (port);
SCM_SETAND_CAR (port, ~SCM_OPN);
- return SCM_NEGATE_BOOL(rv < 0);
+ return SCM_NEGATE_BOOL (rv < 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_close_input_port, "close-input-port", 1, 0, 0,
+ (SCM port),
+ "Close the specified input port object. The routine has no effect if\n"
+ "the file has already been closed. An exception may be raised if an\n"
+ "error occurs. The value returned is unspecified.\n\n"
+ "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
+ "which can close file descriptors.")
+#define FUNC_NAME s_scm_close_input_port
+{
+ SCM_VALIDATE_INPUT_PORT (1, port);
+ scm_close_port (port);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_close_output_port, "close-output-port", 1, 0, 0,
+ (SCM port),
+ "Close the specified output port object. The routine has no effect if\n"
+ "the file has already been closed. An exception may be raised if an\n"
+ "error occurs. The value returned is unspecified.\n\n"
+ "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
+ "which can close file descriptors.")
+#define FUNC_NAME s_scm_close_output_port
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OUTPUT_PORT (1, port);
+ scm_close_port (port);
+ return SCM_UNSPECIFIED;
+}
+#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
+{
+ int 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_port_table_size; i++)
+ ports = scm_cons (scm_port_table[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"
- "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.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;
- SCM_VALIDATE_CONS (1,ports);
+ SCM_VALIDATE_REST_ARGUMENT (ports);
while (i < scm_port_table_size)
{
SCM thisport = scm_port_table[i]->port;
SCM port = SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr));
if (i == 0)
SCM_VALIDATE_OPPORT (SCM_ARG1,port);
- if (port == thisport)
+ if (SCM_EQ_P (port, thisport))
found = 1;
ports_ptr = SCM_CDR (ports_ptr);
}
}
#undef FUNC_NAME
+#endif
\f
/* Utter miscellany. Gosh, we should clean this up some time. */
{
if (SCM_IMP (x))
return SCM_BOOL_F;
- return SCM_BOOL(SCM_INPORTP (x));
+ return SCM_BOOL(SCM_INPUT_PORT_P (x));
}
#undef FUNC_NAME
return SCM_BOOL_F;
if (SCM_PORT_WITH_PS_P (x))
x = SCM_PORT_WITH_PS_PORT (x);
- return SCM_BOOL(SCM_OUTPORTP (x));
+ return SCM_BOOL(SCM_OUTPUT_PORT_P (x));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_port_p, "port?", 1, 0, 0,
+ (SCM x),
+ "Returns a boolean indicating whether @var{x} is a port.\n"
+ "Equivalent to @code{(or (input-port? X) (output-port? X))}.")
+#define FUNC_NAME s_scm_port_p
+{
+ return SCM_BOOL (SCM_PORTP (x));
}
#undef FUNC_NAME
scm_lfwrite (s, strlen (s), port);
}
+/* scm_lfwrite
+ *
+ * Currently, this function has an identical implementation to
+ * scm_c_write. We could have turned it into a macro expanding into a
+ * call to scm_c_write. However, the implementation is small and
+ * might differ in the future.
+ */
+
void
scm_lfwrite (const char *ptr, scm_sizet size, SCM port)
{
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! */
+
+scm_sizet
+scm_c_read (SCM port, void *buffer, scm_sizet size)
+{
+ scm_port *pt = SCM_PTAB_ENTRY (port);
+ scm_sizet 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 += 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, scm_sizet size)
+{
+ scm_port *pt = SCM_PTAB_ENTRY (port);
+ scm_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)
{
if (pt->putback_buf == NULL)
{
- pt->putback_buf = (char *) malloc (SCM_INITIAL_PUTBACK_BUF_SIZE);
+ pt->putback_buf
+ = (unsigned char *) malloc (SCM_INITIAL_PUTBACK_BUF_SIZE);
if (pt->putback_buf == NULL)
scm_memory_error ("scm_ungetc");
pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE;
}
#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_ROUCHARS (str), SCM_LENGTH (str), port);
+ scm_ungets (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), port);
return str;
}
object = SCM_COERCE_OUTPORT (object);
- 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_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
{
- 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_set_port_column_x, "set-port-column!", 2, 0, 0,
(SCM port, SCM column),
- "@deffnx primitive set-port-column! [input-port] column\n"
- "Set the current column or line number of @var{input-port}, using the\n"
+ "@deffnx primitive set-port-line! port line\n"
+ "Set the current column or line number of @var{port}, using the\n"
"current input port if none is specified.")
#define FUNC_NAME s_scm_set_port_column_x
{
SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0,
(SCM port),
"Return the filename associated with @var{port}. This function returns\n"
- "the strings \"standard input\", \"standard output\" and \"standard error\""
+ "the strings \"standard input\", \"standard output\" and \"standard error\"\n"
"when called on the current input, output and error ports respectively.")
#define FUNC_NAME s_scm_port_filename
{
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
{
scm_puts (SCM_CLOSEDP (exp)
? "closed: "
- : (SCM_RDNG & SCM_UNPACK_CAR (exp)
- ? (SCM_WRTNG & SCM_UNPACK_CAR (exp)
+ : (SCM_RDNG & SCM_CELL_WORD_0 (exp)
+ ? (SCM_WRTNG & SCM_CELL_WORD_0 (exp)
? "input-output: "
: "input: ")
- : (SCM_WRTNG & SCM_UNPACK_CAR (exp)
+ : (SCM_WRTNG & SCM_CELL_WORD_0 (exp)
? "output: "
: "bogus: ")),
port);
scm_print_port_mode (exp, port);
scm_puts (type, port);
scm_putc (' ', port);
- scm_intprint ((int) SCM_CDR (exp), 16, port);
+ scm_intprint (SCM_CELL_WORD_1 (exp), 16, port);
scm_putc ('>', port);
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 ();
}
\f
/* Void ports. */
-long scm_tc16_void_port = 0;
+scm_bits_t scm_tc16_void_port = 0;
static int fill_input_void_port (SCM port)
{
scm_port_non_buffer (pt);
SCM_SETPTAB_ENTRY (answer, pt);
SCM_SETSTREAM (answer, 0);
- SCM_SETCAR (answer, scm_tc16_void_port | mode_bits);
+ SCM_SET_CELL_TYPE (answer, scm_tc16_void_port | mode_bits);
SCM_ALLOW_INTS;
return answer;
}
"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_tc16_void_port = scm_make_port_type ("void", fill_input_void_port,
write_void_port);
-#include "ports.x"
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/ports.x"
+#endif
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff