-/* 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, 2007 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 <stdio.h>
#include <errno.h>
+#include <fcntl.h> /* for chsize on mingw */
+
+#include <assert.h>
#include "libguile/_scm.h"
+#include "libguile/async.h"
#include "libguile/eval.h"
+#include "libguile/fports.h" /* direct access for seek and truncate */
#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>
#endif
-#ifdef HAVE_MALLOC_H
-#include <malloc.h>
-#endif
-
#ifdef HAVE_IO_H
#include <io.h>
#endif
#include <sys/ioctl.h>
#endif
-#ifdef __MINGW32__
-#include <fcntl.h>
+/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
+ already, but have this code here in case that wasn't so in past versions,
+ or perhaps to help other minimal DOS environments.
+
+ gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
+ might be possibilities if we've got other systems without ftruncate. */
+
+#if HAVE_CHSIZE && ! HAVE_FTRUNCATE
#define ftruncate(fd, size) chsize (fd, size)
+#undef HAVE_FTRUNCATE
+#define HAVE_FTRUNCATE 1
#endif
\f
char *tmp;
if (255 <= scm_numptob)
goto ptoberr;
- SCM_DEFER_INTS;
- SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs,
- (1 + scm_numptob)
- * sizeof (scm_t_ptob_descriptor)));
+ SCM_CRITICAL_SECTION_START;
+ tmp = (char *) scm_gc_realloc ((char *) scm_ptobs,
+ scm_numptob * sizeof (scm_t_ptob_descriptor),
+ (1 + scm_numptob)
+ * sizeof (scm_t_ptob_descriptor),
+ "port-type");
if (tmp)
{
scm_ptobs = (scm_t_ptob_descriptor *) tmp;
scm_numptob++;
}
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
if (!tmp)
{
ptoberr:
}
void
-scm_set_port_mark (long tc, SCM (*mark) (SCM))
+scm_set_port_mark (scm_t_bits tc, SCM (*mark) (SCM))
{
scm_ptobs[SCM_TC2PTOBNUM (tc)].mark = mark;
}
void
-scm_set_port_free (long tc, size_t (*free) (SCM))
+scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM))
{
scm_ptobs[SCM_TC2PTOBNUM (tc)].free = free;
}
void
-scm_set_port_print (long tc, int (*print) (SCM exp, SCM port,
+scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port,
scm_print_state *pstate))
{
scm_ptobs[SCM_TC2PTOBNUM (tc)].print = print;
}
void
-scm_set_port_equalp (long tc, SCM (*equalp) (SCM, SCM))
+scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
{
scm_ptobs[SCM_TC2PTOBNUM (tc)].equalp = equalp;
}
void
-scm_set_port_flush (long tc, void (*flush) (SCM port))
+scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port))
{
scm_ptobs[SCM_TC2PTOBNUM (tc)].flush = flush;
}
void
-scm_set_port_end_input (long tc, void (*end_input) (SCM port, int offset))
+scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int offset))
{
scm_ptobs[SCM_TC2PTOBNUM (tc)].end_input = end_input;
}
void
-scm_set_port_close (long tc, int (*close) (SCM))
+scm_set_port_close (scm_t_bits tc, int (*close) (SCM))
{
scm_ptobs[SCM_TC2PTOBNUM (tc)].close = close;
}
void
-scm_set_port_seek (long tc, off_t (*seek) (SCM port,
+scm_set_port_seek (scm_t_bits tc, off_t (*seek) (SCM port,
off_t OFFSET,
int WHENCE))
{
}
void
-scm_set_port_truncate (long tc, void (*truncate) (SCM port, off_t length))
+scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, off_t length))
{
scm_ptobs[SCM_TC2PTOBNUM (tc)].truncate = truncate;
}
void
-scm_set_port_input_waiting (long tc, int (*input_waiting) (SCM))
+scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM))
{
scm_ptobs[SCM_TC2PTOBNUM (tc)].input_waiting = input_waiting;
}
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. */
-scm_t_port **scm_i_port_table;
+scm_t_port **scm_i_port_table = NULL;
-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. */
+long scm_i_port_table_size = 0; /* Number of ports in SCM_I_PORT_TABLE. */
+long scm_i_port_table_room = 20; /* Actual 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. */
+\f
+/* Port finalization. */
+
+
+static void finalize_port (GC_PTR, GC_PTR);
+
+/* Register a finalizer for PORT, if needed by its port type. */
+static SCM_C_INLINE_KEYWORD void
+register_finalizer_for_port (SCM port)
+{
+ long port_type;
+
+ port_type = SCM_TC2PTOBNUM (SCM_CELL_TYPE (port));
+ if (scm_ptobs[port_type].free)
+ {
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalization_data;
+
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (port), finalize_port, 0,
+ &prev_finalizer,
+ &prev_finalization_data);
+ }
+}
+
+/* Finalize the object (a port) pointed to by PTR. */
+static void
+finalize_port (GC_PTR ptr, GC_PTR data)
+{
+ long port_type;
+ SCM port = PTR2SCM (ptr);
+
+ if (!SCM_PORTP (port))
+ abort ();
+
+ if (SCM_OPENP (port))
+ {
+ if (SCM_REVEALED (port) > 0)
+ /* Keep "revealed" ports alive and re-register a finalizer. */
+ register_finalizer_for_port (port);
+ else
+ {
+ port_type = SCM_TC2PTOBNUM (SCM_CELL_TYPE (port));
+ if (port_type >= scm_numptob)
+ abort ();
+
+ if (scm_ptobs[port_type].free)
+ /* Yes, I really do mean `.free' rather than `.close'. `.close'
+ is for explicit `close-port' by user. */
+ scm_ptobs[port_type].free (port);
+
+ SCM_SETSTREAM (port, 0);
+ SCM_CLR_PORT_OPEN_FLAG (port);
+ scm_remove_from_port_table (port);
+
+ scm_gc_ports_collected++;
+ }
+ }
+}
+
+
+\f
+
+/* This function is not and should not be thread safe. */
SCM
scm_new_port_table_entry (scm_t_bits tag)
#define FUNC_NAME "scm_new_port_table_entry"
{
/* initial malloc is in gc.c. this doesn't use scm_gc_malloc etc.,
since it can never be freed during gc. */
- void *newt = scm_realloc ((char *) scm_i_port_table,
- (size_t) (sizeof (scm_t_port *)
- * scm_i_port_table_room * 2));
+ /* XXX (Ludo): Why not do it actually? */
+ size_t new_size = scm_i_port_table_room * 2;
+ /* XXX (Ludo): Can we use `GC_REALLOC' with
+ `GC_MALLOC_ATOMIC'-allocated data? */
+ void *newt = scm_gc_realloc ((char *) scm_i_port_table,
+ scm_i_port_table_room * sizeof (scm_t_port *),
+ new_size * sizeof (scm_t_port *),
+ "port-table");
scm_i_port_table = (scm_t_port **) newt;
- scm_i_port_table_room *= 2;
+ scm_i_port_table_room = new_size;
}
entry->entry = scm_i_port_table_size;
entry->port = z;
SCM_SET_CELL_TYPE(z, tag);
SCM_SETPTAB_ENTRY(z, entry);
-
+
+ /* For each new port, register a finalizer so that it port type's free
+ function can be invoked eventually. */
+ register_finalizer_for_port (z);
+
return z;
}
#undef FUNC_NAME
"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
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_remember_upto_here_1 (ports);
}
SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0,
"@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);
}
pt->rw_active = SCM_PORT_WRITE;
}
-void
+void
scm_flush (SCM port)
{
long i = SCM_PTOBNUM (port);
+ assert ((i >= 0) && (i < scm_i_port_table_size));
(scm_ptobs[i].flush) (port);
}
{
size_t new_size = pt->read_buf_size * 2;
unsigned char *tmp = (unsigned char *)
+ /* XXX: Can we use `GC_REALLOC' with `GC_MALLOC_ATOMIC'-allocated
+ data? (Ludo) */
scm_gc_realloc (pt->putback_buf, pt->read_buf_size, new_size,
"putback buffer");
if (pt->putback_buf == NULL)
{
pt->putback_buf
- = (unsigned char *) scm_gc_malloc (SCM_INITIAL_PUTBACK_BUF_SIZE,
- "putback buffer");
+ = (unsigned char *) scm_gc_malloc_pointerless
+ (SCM_INITIAL_PUTBACK_BUF_SIZE, "putback buffer");
pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE;
}
{
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;
}
"@end lisp")
#define FUNC_NAME s_scm_seek
{
- off_t off;
- off_t rv;
int how;
fd_port = SCM_COERCE_OUTPORT (fd_port);
- off = SCM_NUM2LONG (2, offset);
- SCM_VALIDATE_INUM_COPY (3, whence, how);
+ 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))
+
+ if (SCM_OPFPORTP (fd_port))
+ {
+ /* go direct to fport code to allow 64-bit offsets */
+ return scm_i_fport_seek (fd_port, offset, how);
+ }
+ else if (SCM_OPPORTP (fd_port))
{
scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port);
+ off_t off = scm_to_off_t (offset);
+ off_t rv;
if (!ptob->seek)
SCM_MISC_ERROR ("port is not seekable",
scm_cons (fd_port, SCM_EOL));
else
rv = ptob->seek (fd_port, off, how);
+ return scm_from_off_t (rv);
}
else /* file descriptor?. */
{
- SCM_VALIDATE_INUM (1, fd_port);
- rv = lseek (SCM_INUM (fd_port), off, how);
+ off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
+ off_t_or_off64_t rv;
+ rv = lseek_or_lseek64 (scm_to_int (fd_port), off, how);
if (rv == -1)
SCM_SYSERROR;
+ return scm_from_off_t_or_off64_t (rv);
}
- return scm_long2num (rv);
}
#undef FUNC_NAME
-#ifdef __MINGW32__
-/* Define this function since it is not supported under Windows. */
-static int truncate (char *file, int length)
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+
+/* Mingw has ftruncate(), perhaps implemented above using chsize, but
+ doesn't have the filename version truncate(), hence this code. */
+#if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
+static int
+truncate (const char *file, off_t length)
{
- int ret = -1, fdes;
- if ((fdes = open (file, O_BINARY | O_WRONLY)) != -1)
+ int ret, fdes;
+
+ fdes = open (file, O_BINARY | O_WRONLY);
+ if (fdes == -1)
+ return -1;
+
+ ret = ftruncate (fdes, length);
+ if (ret == -1)
{
- ret = chsize (fdes, length);
+ int save_errno = errno;
close (fdes);
+ errno = save_errno;
+ return -1;
}
- return ret;
+
+ return close (fdes);
}
-#endif /* __MINGW32__ */
+#endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
(SCM object, SCM length),
- "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.")
+ "Truncate @var{file} to @var{length} bytes. @var{file} can be a\n"
+ "filename string, a port object, or an integer file descriptor.\n"
+ "The return value is unspecified.\n"
+ "\n"
+ "For a port or file descriptor @var{length} can be omitted, in\n"
+ "which case the file is truncated at the current position (per\n"
+ "@code{ftell} above).\n"
+ "\n"
+ "On most systems a file can be extended by giving a length\n"
+ "greater than the current size, but this is not mandatory in the\n"
+ "POSIX standard.")
#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_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
+ SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object),
+ c_length));
+ }
+ else if (SCM_OPOUTFPORTP (object))
+ {
+ /* go direct to fport code to allow 64-bit offsets */
+ rv = scm_i_fport_truncate (object, 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_long (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_long (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_ports_prehistory ()
{
scm_numptob = 0;
- scm_ptobs = (scm_t_ptob_descriptor *) scm_malloc (sizeof (scm_t_ptob_descriptor));
+ scm_ptobs = NULL;
+
+ /* In order for the ports to be collectable, the port table must not be
+ scanned by the GC. */
+ scm_i_port_table =
+ scm_gc_malloc_pointerless (scm_i_port_table_room
+ * sizeof (scm_t_port *),
+ "port-table");
}
\f
{
}
-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