-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
\f
/* Headers. */
+#define _LARGEFILE64_SOURCE /* ask for stat64 etc */
+
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <errno.h>
#include "libguile/_scm.h"
+#include "libguile/async.h"
#include "libguile/eval.h"
#include "libguile/objects.h"
+#include "libguile/goops.h"
#include "libguile/smob.h"
#include "libguile/chars.h"
+#include "libguile/dynwind.h"
#include "libguile/keywords.h"
#include "libguile/root.h"
#include "libguile/strings.h"
-
+#include "libguile/mallocs.h"
#include "libguile/validate.h"
#include "libguile/ports.h"
+#include "libguile/vectors.h"
+#include "libguile/fluids.h"
#ifdef HAVE_STRING_H
#include <string.h>
char *tmp;
if (255 <= scm_numptob)
goto ptoberr;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs,
(1 + scm_numptob)
* sizeof (scm_t_ptob_descriptor)));
scm_numptob++;
}
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
if (!tmp)
{
ptoberr:
"@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"
+ "\n"
+ "@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.}")
+ "interactive port that has no ready characters.")
#define FUNC_NAME s_scm_char_ready_p
{
scm_t_port *pt;
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_current_input_port ();
else
SCM_VALIDATE_OPINPORT (1, port);
scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
if (ptob->input_waiting)
- return SCM_BOOL(ptob->input_waiting (port));
+ return scm_from_bool(ptob->input_waiting (port));
else
return SCM_BOOL_T;
}
#define FUNC_NAME s_scm_drain_input
{
SCM result;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ char *data;
+ scm_t_port *pt;
long count;
SCM_VALIDATE_OPINPORT (1, port);
+ pt = SCM_PTAB_ENTRY (port);
count = pt->read_end - pt->read_pos;
if (pt->read_buf == pt->putback_buf)
count += pt->saved_read_end - pt->saved_read_pos;
- result = scm_allocate_string (count);
- scm_take_from_input_buffers (port, SCM_STRING_CHARS (result), count);
-
+ result = scm_i_make_string (count, &data);
+ scm_take_from_input_buffers (port, data, count);
return result;
}
#undef FUNC_NAME
\f
/* Standard ports --- current input, output, error, and more(!). */
+static SCM cur_inport_fluid;
+static SCM cur_outport_fluid;
+static SCM cur_errport_fluid;
+static SCM cur_loadport_fluid;
+
SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
(),
"Return the current input port. This is the default port used\n"
"returns the @dfn{standard input} in Unix and C terminology.")
#define FUNC_NAME s_scm_current_input_port
{
- return scm_cur_inp;
+ return scm_fluid_ref (cur_inport_fluid);
}
#undef FUNC_NAME
"Unix and C terminology.")
#define FUNC_NAME s_scm_current_output_port
{
- return scm_cur_outp;
+ return scm_fluid_ref (cur_outport_fluid);
}
#undef FUNC_NAME
"@dfn{standard error} in Unix and C terminology).")
#define FUNC_NAME s_scm_current_error_port
{
- return scm_cur_errp;
+ return scm_fluid_ref (cur_errport_fluid);
}
#undef FUNC_NAME
"The load port is used internally by @code{primitive-load}.")
#define FUNC_NAME s_scm_current_load_port
{
- return scm_cur_loadp;
+ return scm_fluid_ref (cur_loadport_fluid);
}
#undef FUNC_NAME
"so that they use the supplied @var{port} for input or output.")
#define FUNC_NAME s_scm_set_current_input_port
{
- SCM oinp = scm_cur_inp;
+ SCM oinp = scm_fluid_ref (cur_inport_fluid);
SCM_VALIDATE_OPINPORT (1, port);
- scm_cur_inp = port;
+ scm_fluid_set_x (cur_inport_fluid, port);
return oinp;
}
#undef FUNC_NAME
"Set the current default output port to @var{port}.")
#define FUNC_NAME s_scm_set_current_output_port
{
- SCM ooutp = scm_cur_outp;
+ SCM ooutp = scm_fluid_ref (cur_outport_fluid);
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPOUTPORT (1, port);
- scm_cur_outp = port;
+ scm_fluid_set_x (cur_outport_fluid, port);
return ooutp;
}
#undef FUNC_NAME
"Set the current default error port to @var{port}.")
#define FUNC_NAME s_scm_set_current_error_port
{
- SCM oerrp = scm_cur_errp;
+ SCM oerrp = scm_fluid_ref (cur_errport_fluid);
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPOUTPORT (1, port);
- scm_cur_errp = port;
+ scm_fluid_set_x (cur_errport_fluid, port);
return oerrp;
}
#undef FUNC_NAME
+void
+scm_dynwind_current_input_port (SCM port)
+#define FUNC_NAME NULL
+{
+ SCM_VALIDATE_OPINPORT (1, port);
+ scm_dynwind_fluid (cur_inport_fluid, port);
+}
+#undef FUNC_NAME
+
+void
+scm_dynwind_current_output_port (SCM port)
+#define FUNC_NAME NULL
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ scm_dynwind_fluid (cur_outport_fluid, port);
+}
+#undef FUNC_NAME
+
+void
+scm_dynwind_current_error_port (SCM port)
+#define FUNC_NAME NULL
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ scm_dynwind_fluid (cur_errport_fluid, port);
+}
+#undef FUNC_NAME
+
+void
+scm_i_dynwind_current_load_port (SCM port)
+{
+ scm_dynwind_fluid (cur_loadport_fluid, port);
+}
+
\f
/* The port table --- an array of pointers to ports. */
long scm_i_port_table_size = 0; /* Number of ports in scm_i_port_table. */
long scm_i_port_table_room = 20; /* Size of the array. */
-SCM_GLOBAL_MUTEX (scm_i_port_table_mutex);
+scm_i_pthread_mutex_t scm_i_port_table_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/* This function is not and should not be thread safe. */
"is only included in @code{--enable-guile-debug} builds.")
#define FUNC_NAME s_scm_pt_size
{
- return SCM_MAKINUM (scm_i_port_table_size);
+ return scm_from_int (scm_i_port_table_size);
}
#undef FUNC_NAME
"@code{--enable-guile-debug} builds.")
#define FUNC_NAME s_scm_pt_member
{
- long i;
- SCM_VALIDATE_INUM_COPY (1, index, i);
- if (i < 0 || i >= scm_i_port_table_size)
+ size_t i = scm_to_size_t (index);
+ if (i >= scm_i_port_table_size)
return SCM_BOOL_F;
else
return scm_i_port_table[i]->port;
{
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port);
- return SCM_MAKINUM (scm_revealed_count (port));
+ return scm_from_int (scm_revealed_count (port));
}
#undef FUNC_NAME
{
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port);
- SCM_VALIDATE_INUM (2, rcount);
- SCM_REVEALED (port) = SCM_INUM (rcount);
+ SCM_REVEALED (port) = scm_to_int (rcount);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
* See PORT FLAGS in scm.h
*/
+static long
+scm_i_mode_bits_n (const char *modes, size_t n)
+{
+ return (SCM_OPN
+ | (memchr (modes, 'r', n) || memchr (modes, '+', n) ? SCM_RDNG : 0)
+ | ( memchr (modes, 'w', n)
+ || memchr (modes, 'a', n)
+ || memchr (modes, '+', n) ? SCM_WRTNG : 0)
+ | (memchr (modes, '0', n) ? SCM_BUF0 : 0)
+ | (memchr (modes, 'l', n) ? SCM_BUFLINE : 0));
+}
+
long
scm_mode_bits (char *modes)
{
- return (SCM_OPN
- | (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0)
- | ( strchr (modes, 'w')
- || strchr (modes, 'a')
- || strchr (modes, '+') ? SCM_WRTNG : 0)
- | (strchr (modes, '0') ? SCM_BUF0 : 0)
- | (strchr (modes, 'l') ? SCM_BUFLINE : 0));
+ return scm_i_mode_bits_n (modes, strlen (modes));
}
+long
+scm_i_mode_bits (SCM modes)
+{
+ long bits;
+
+ if (!scm_is_string (modes))
+ scm_wrong_type_arg_msg (NULL, 0, modes, "string");
+
+ bits = scm_i_mode_bits_n (scm_i_string_chars (modes),
+ scm_i_string_length (modes));
+ scm_remember_upto_here_1 (modes);
+ return bits;
+}
/* Return the mode flags from an open port.
* Some modes such as "append" are only used when opening
strcpy (modes, "w");
if (SCM_CELL_WORD_0 (port) & SCM_BUF0)
strcat (modes, "0");
- return scm_mem2string (modes, strlen (modes));
+ return scm_from_locale_string (modes);
}
#undef FUNC_NAME
rv = (scm_ptobs[i].close) (port);
else
rv = 0;
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
scm_remove_from_port_table (port);
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
SCM_CLR_PORT_OPEN_FLAG (port);
- return SCM_BOOL (rv >= 0);
+ return scm_from_bool (rv >= 0);
}
#undef FUNC_NAME
}
#undef FUNC_NAME
+void
+scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
+{
+ long i;
+ size_t n;
+ SCM ports;
+
+ /* 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 first
+ collect the ports into a vector. -mvo */
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ n = scm_i_port_table_size;
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
+ ports = scm_c_make_vector (n, SCM_BOOL_F);
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ if (n > scm_i_port_table_size)
+ n = scm_i_port_table_size;
+ for (i = 0; i < n; i++)
+ SCM_SIMPLE_VECTOR_SET (ports, i, scm_i_port_table[i]->port);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
+ for (i = 0; i < n; i++)
+ proc (data, SCM_SIMPLE_VECTOR_REF (ports, i));
+}
+
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"
"have no effect as far as @var{port-for-each} is concerned.")
#define FUNC_NAME s_scm_port_for_each
{
- long i;
- SCM ports;
-
SCM_VALIDATE_PROC (1, proc);
- /* 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_mutex_lock (&scm_i_port_table_mutex);
- scm_block_gc++;
- ports = SCM_EOL;
- for (i = 0; i < scm_i_port_table_size; i++)
- ports = scm_cons (scm_i_port_table[i]->port, ports);
- scm_block_gc--;
- scm_mutex_unlock (&scm_i_port_table_mutex);
-
- while (ports != SCM_EOL)
- {
- scm_call_1 (proc, SCM_CAR (ports));
- ports = SCM_CDR (ports);
- }
-
+ scm_c_port_for_each ((void (*)(void*,SCM))scm_call_1, proc);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+
\f
/* Utter miscellany. Gosh, we should clean this up some time. */
"@code{port?}.")
#define FUNC_NAME s_scm_input_port_p
{
- return SCM_BOOL (SCM_INPUT_PORT_P (x));
+ return scm_from_bool (SCM_INPUT_PORT_P (x));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_output_port_p
{
x = SCM_COERCE_OUTPORT (x);
- return SCM_BOOL (SCM_OUTPUT_PORT_P (x));
+ return scm_from_bool (SCM_OUTPUT_PORT_P (x));
}
#undef FUNC_NAME
"@var{x}))}.")
#define FUNC_NAME s_scm_port_p
{
- return SCM_BOOL (SCM_PORTP (x));
+ return scm_from_bool (SCM_PORTP (x));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_port_closed_p
{
SCM_VALIDATE_PORT (1, port);
- return SCM_BOOL (!SCM_OPPORTP (port));
+ return scm_from_bool (!SCM_OPPORTP (port));
}
#undef FUNC_NAME
"return @code{#f}.")
#define FUNC_NAME s_scm_eof_object_p
{
- return SCM_BOOL(SCM_EOF_OBJECT_P (x));
+ return scm_from_bool(SCM_EOF_OBJECT_P (x));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_force_output
{
if (SCM_UNBNDP (port))
- port = scm_cur_outp;
+ port = scm_current_output_port ();
else
{
port = SCM_COERCE_OUTPORT (port);
{
size_t i;
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
for (i = 0; i < scm_i_port_table_size; i++)
{
if (SCM_OPOUTPORTP (scm_i_port_table[i]->port))
scm_flush (scm_i_port_table[i]->port);
}
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
{
int c;
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_current_input_port ();
SCM_VALIDATE_OPINPORT (1, port);
c = scm_getc (port);
if (EOF == c)
switch (c)
{
+ case '\a':
+ break;
+ case '\b':
+ SCM_DECCOL (port);
+ break;
case '\n':
SCM_INCLINE (port);
break;
+ case '\r':
+ SCM_ZEROCOL (port);
+ break;
case '\t':
SCM_TABCOL (port);
break;
void
scm_putc (char c, SCM port)
{
+ SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
scm_lfwrite (&c, 1, port);
}
void
scm_puts (const char *s, SCM port)
{
+ SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
scm_lfwrite (s, strlen (s), port);
}
ptob->write (port, ptr, size);
for (; size; ptr++, size--) {
- if (*ptr == '\n') {
+ if (*ptr == '\a') {
+ }
+ else if (*ptr == '\b') {
+ SCM_DECCOL(port);
+ }
+ else if (*ptr == '\n') {
SCM_INCLINE(port);
}
+ else if (*ptr == '\r') {
+ SCM_ZEROCOL(port);
+ }
else if (*ptr == '\t') {
SCM_TABCOL(port);
}
"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"
+ "end-of-file object is returned.\n"
+ "\n"
+ "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"
"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.}")
+ "to @code{read-char} would have hung.")
#define FUNC_NAME s_scm_peek_char
{
- int c;
+ int c, column;
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_current_input_port ();
else
SCM_VALIDATE_OPINPORT (1, port);
+ column = SCM_COL(port);
c = scm_getc (port);
if (EOF == c)
return SCM_EOF_VAL;
scm_ungetc (c, port);
+ SCM_COL(port) = column;
return SCM_MAKE_CHAR (c);
}
#undef FUNC_NAME
SCM_VALIDATE_CHAR (1, cobj);
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_current_input_port ();
else
SCM_VALIDATE_OPINPORT (2, port);
{
SCM_VALIDATE_STRING (1, str);
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_current_input_port ();
else
SCM_VALIDATE_OPINPORT (2, port);
- scm_ungets (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), port);
+ scm_ungets (scm_i_string_chars (str), scm_i_string_length (str), port);
return str;
}
fd_port = SCM_COERCE_OUTPORT (fd_port);
- off = SCM_NUM2LONG (2, offset);
- SCM_VALIDATE_INUM_COPY (3, whence, how);
+ if (sizeof (off_t) == sizeof (scm_t_intmax))
+ off = scm_to_intmax (offset);
+ else
+ off = scm_to_long (offset);
+ how = scm_to_int (whence);
+
if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
SCM_OUT_OF_RANGE (3, whence);
if (SCM_OPPORTP (fd_port))
}
else /* file descriptor?. */
{
- SCM_VALIDATE_INUM (1, fd_port);
- rv = lseek (SCM_INUM (fd_port), off, how);
+ rv = lseek (scm_to_int (fd_port), off, how);
if (rv == -1)
SCM_SYSERROR;
}
- return scm_long2num (rv);
+ return scm_from_intmax (rv);
}
#undef FUNC_NAME
"@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"
+ "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;
- off_t c_length;
- /* object can be a port, fdes or filename. */
+ /* "object" can be a port, fdes or filename.
+
+ Negative "length" makes no sense, but it's left to truncate() or
+ ftruncate() to give back an error for that (normally EINVAL).
+ */
if (SCM_UNBNDP (length))
{
/* must supply length if object is a filename. */
- if (SCM_STRINGP (object))
+ if (scm_is_string (object))
SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL);
- length = scm_seek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR));
+ length = scm_seek (object, SCM_INUM0, scm_from_int (SEEK_CUR));
}
- c_length = SCM_NUM2LONG (2, length);
- if (c_length < 0)
- SCM_MISC_ERROR ("negative offset", SCM_EOL);
object = SCM_COERCE_OUTPORT (object);
- if (SCM_INUMP (object))
+ if (scm_is_integer (object))
{
- SCM_SYSCALL (rv = ftruncate (SCM_INUM (object), c_length));
+ off_t c_length = scm_to_off_t (length);
+ SCM_SYSCALL (rv = ftruncate (scm_to_int (object), c_length));
}
else if (SCM_OPOUTPORTP (object))
{
+ off_t c_length = scm_to_off_t (length);
scm_t_port *pt = SCM_PTAB_ENTRY (object);
scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object);
}
else
{
- SCM_VALIDATE_STRING (1, object);
- SCM_SYSCALL (rv = truncate (SCM_STRING_CHARS (object), c_length));
+ off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
+ char *str = scm_to_locale_string (object);
+ int eno;
+ SCM_SYSCALL (rv = truncate_or_truncate64 (str, c_length));
+ eno = errno;
+ free (str);
+ errno = eno;
}
if (rv == -1)
SCM_SYSERROR;
SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0,
(SCM port),
- "Return the current line number for @var{port}.")
+ "Return the current line number for @var{port}.\n"
+ "\n"
+ "The first line of a file is 0. But you might want to add 1\n"
+ "when printing line numbers, since starting from 1 is\n"
+ "traditional in error messages, and likely to be more natural to\n"
+ "non-programmers.")
#define FUNC_NAME s_scm_port_line
{
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port);
- return SCM_MAKINUM (SCM_LINUM (port));
+ return scm_from_int (SCM_LINUM (port));
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0,
(SCM port, SCM line),
- "Set the current line number for @var{port} to @var{line}.")
+ "Set the current line number for @var{port} to @var{line}. The\n"
+ "first line of a file is 0.")
#define FUNC_NAME s_scm_set_port_line_x
{
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port);
- SCM_VALIDATE_INUM (2, line);
- SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line);
+ SCM_PTAB_ENTRY (port)->line_number = scm_to_int (line);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0,
(SCM port),
- "@deffnx {Scheme Procedure} 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"
+ "Return the current column number of @var{port}.\n"
+ "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"
{
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port);
- return SCM_MAKINUM (SCM_COL (port));
+ return scm_from_int (SCM_COL (port));
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0,
(SCM port, SCM column),
- "@deffnx {Scheme Procedure} 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.")
+ "Set the current column of @var{port}. Before reading the first\n"
+ "character on a line the column should be 0.")
#define FUNC_NAME s_scm_set_port_column_x
{
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port);
- SCM_VALIDATE_INUM (2, column);
- SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column);
+ SCM_PTAB_ENTRY (port)->column_number = scm_to_int (column);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
}
#undef FUNC_NAME
-#ifndef ttyname
-extern char * ttyname();
-#endif
-
void
scm_print_port_mode (SCM exp, SCM port)
{
scm_print_port_mode (exp, port);
scm_puts (type, port);
scm_putc (' ', port);
- scm_intprint (SCM_CELL_WORD_1 (exp), 16, port);
+ scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
scm_putc ('>', port);
return 1;
}
{
}
-SCM
-scm_void_port (char *mode_str)
+static SCM
+scm_i_void_port (long mode_bits)
{
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
{
- int mode_bits = scm_mode_bits (mode_str);
SCM answer = scm_new_port_table_entry (scm_tc16_void_port);
scm_t_port * pt = SCM_PTAB_ENTRY(answer);
SCM_SETSTREAM (answer, 0);
SCM_SET_CELL_TYPE (answer, scm_tc16_void_port | mode_bits);
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
return answer;
}
}
+SCM
+scm_void_port (char *mode_str)
+{
+ return scm_i_void_port (scm_mode_bits (mode_str));
+}
+
SCM_DEFINE (scm_sys_make_void_port, "%make-void-port", 1, 0, 0,
(SCM mode),
"Create and return a new void port. A void port acts like\n"
"documentation for @code{open-file} in @ref{File Ports}.")
#define FUNC_NAME s_scm_sys_make_void_port
{
- SCM_VALIDATE_STRING (1, mode);
- return scm_void_port (SCM_STRING_CHARS (mode));
+ return scm_i_void_port (scm_i_mode_bits (mode));
}
#undef FUNC_NAME
scm_init_ports ()
{
/* lseek() symbols. */
- 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_c_define ("SEEK_SET", scm_from_int (SEEK_SET));
+ scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR));
+ scm_c_define ("SEEK_END", scm_from_int (SEEK_END));
scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port,
write_void_port);
+
+ cur_inport_fluid = scm_permanent_object (scm_make_fluid ());
+ cur_outport_fluid = scm_permanent_object (scm_make_fluid ());
+ cur_errport_fluid = scm_permanent_object (scm_make_fluid ());
+ cur_loadport_fluid = scm_permanent_object (scm_make_fluid ());
+
#include "libguile/ports.x"
}
HCoop / bpt / guile.git / blobdiff