-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004 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/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:
scm_t_port *pt;
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_current_input_port ();
else
SCM_VALIDATE_OPINPORT (1, port);
#define FUNC_NAME s_scm_drain_input
{
SCM result;
+ char *data;
scm_t_port *pt;
long count;
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
-typedef struct {
- SCM value;
- SCM (*getter) (void);
- SCM (*setter) (SCM);
-} swap_data;
-
-static void
-swap_port (SCM scm_data)
+void
+scm_dynwind_current_input_port (SCM port)
+#define FUNC_NAME NULL
{
- swap_data *d = (swap_data *)SCM_MALLOCDATA (scm_data);
- SCM t;
-
- t = d->getter ();
- d->setter (d->value);
- d->value = t;
-}
-
-static void
-scm_frame_current_foo_port (SCM port,
- SCM (*getter) (void), SCM (*setter) (SCM))
-{
- SCM scm_data = scm_malloc_obj (sizeof (swap_data));
- swap_data *data = (swap_data *)SCM_MALLOCDATA (scm_data);
- data->value = port;
- data->getter = getter;
- data->setter = setter;
-
- scm_frame_rewind_handler_with_scm (swap_port, scm_data,
- SCM_F_WIND_EXPLICITLY);
- scm_frame_unwind_handler_with_scm (swap_port, scm_data,
- SCM_F_WIND_EXPLICITLY);
+ SCM_VALIDATE_OPINPORT (1, port);
+ scm_dynwind_fluid (cur_inport_fluid, port);
}
+#undef FUNC_NAME
void
-scm_frame_current_input_port (SCM port)
+scm_dynwind_current_output_port (SCM port)
+#define FUNC_NAME NULL
{
- scm_frame_current_foo_port (port,
- scm_current_input_port,
- scm_set_current_input_port);
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ scm_dynwind_fluid (cur_outport_fluid, port);
}
+#undef FUNC_NAME
void
-scm_frame_current_output_port (SCM port)
+scm_dynwind_current_error_port (SCM port)
+#define FUNC_NAME NULL
{
- scm_frame_current_foo_port (port,
- scm_current_output_port,
- scm_set_current_output_port);
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ scm_dynwind_fluid (cur_errport_fluid, port);
}
+#undef FUNC_NAME
void
-scm_frame_current_error_port (SCM port)
+scm_i_dynwind_current_load_port (SCM port)
{
- scm_frame_current_foo_port (port,
- scm_current_error_port,
- scm_set_current_error_port);
+ scm_dynwind_fluid (cur_loadport_fluid, port);
}
\f
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_from_bool (rv >= 0);
}
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 build a
- list in advance while blocking the GC. -mvo */
+ can change arbitrarily (from a GC, for example). So we first
+ collect the ports into a vector. -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);
+ 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);
- while (ports != SCM_EOL)
- {
- proc (data, SCM_CAR (ports));
- ports = SCM_CDR (ports);
- }
+ 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,
#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);
}
{
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);
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;
{
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
{
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
{
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
{
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