X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/b42170a484f0f77bbfa481f37accde19d0a27654..e9b8556ec92039396e740620238d56a3748f2a99:/libguile/ports.c diff --git a/libguile/ports.c b/libguile/ports.c index 70fdcc0f2..fc716bebf 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1,4 +1,4 @@ -/* 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, 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 @@ -12,23 +12,31 @@ * * 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 */ /* Headers. */ +#define _LARGEFILE64_SOURCE /* ask for stat64 etc */ + #if HAVE_CONFIG_H # include #endif #include #include +#include /* for chsize on mingw */ + +#include #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" @@ -39,15 +47,13 @@ #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 #endif -#ifdef HAVE_MALLOC_H -#include -#endif - #ifdef HAVE_IO_H #include #endif @@ -60,9 +66,17 @@ #include #endif -#ifdef __MINGW32__ -#include +/* 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 @@ -119,10 +133,12 @@ scm_make_port_type (char *name, 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; @@ -146,7 +162,7 @@ scm_make_port_type (char *name, scm_numptob++; } - SCM_ALLOW_INTS; + SCM_CRITICAL_SECTION_END; if (!tmp) { ptoberr: @@ -159,50 +175,50 @@ scm_make_port_type (char *name, } 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)) { @@ -210,13 +226,13 @@ scm_set_port_seek (long tc, off_t (*seek) (SCM port, } 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; } @@ -244,7 +260,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, scm_t_port *pt; if (SCM_UNBNDP (port)) - port = scm_cur_inp; + port = scm_current_input_port (); else SCM_VALIDATE_OPINPORT (1, port); @@ -262,7 +278,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, 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; } @@ -319,6 +335,7 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, #define FUNC_NAME s_scm_drain_input { SCM result; + char *data; scm_t_port *pt; long count; @@ -329,9 +346,8 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, 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 @@ -339,6 +355,11 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, /* 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" @@ -346,7 +367,7 @@ SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0, "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 @@ -358,7 +379,7 @@ SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0, "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 @@ -368,7 +389,7 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0, "@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 @@ -378,7 +399,7 @@ SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0, "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 @@ -391,9 +412,9 @@ SCM_DEFINE (scm_set_current_input_port, "set-current-input-port", 1, 0, 0, "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 @@ -404,10 +425,10 @@ SCM_DEFINE (scm_set_current_output_port, "set-current-output-port", 1, 0, 0, "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 @@ -418,81 +439,123 @@ SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0, "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_with_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_on_rewind_with_scm (swap_port, scm_data, SCM_F_WIND_EXPLICITLY); - scm_on_unwind_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_with_current_input_port (SCM port) +scm_dynwind_current_output_port (SCM port) +#define FUNC_NAME NULL { - scm_with_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_with_current_output_port (SCM port) +scm_dynwind_current_error_port (SCM port) +#define FUNC_NAME NULL { - scm_with_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_with_current_error_port (SCM port) +scm_i_dynwind_current_load_port (SCM port) { - scm_with_current_foo_port (port, - scm_current_error_port, - scm_set_current_error_port); + scm_dynwind_fluid (cur_loadport_fluid, port); } /* 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. */ + +/* 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++; + } + } +} + + + + + +/* 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" @@ -508,11 +571,16 @@ scm_new_port_table_entry (scm_t_bits tag) { /* 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; @@ -526,7 +594,11 @@ scm_new_port_table_entry (scm_t_bits tag) 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 @@ -585,7 +657,7 @@ SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0, "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 @@ -596,9 +668,8 @@ SCM_DEFINE (scm_pt_member, "pt-member", 1, 0, 0, "@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; @@ -639,7 +710,7 @@ SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0, { 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 @@ -652,8 +723,7 @@ SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, { 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 @@ -668,18 +738,37 @@ SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, * 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 @@ -708,7 +797,7 @@ SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0, 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 @@ -743,11 +832,11 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, 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 @@ -786,26 +875,31 @@ 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 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, @@ -836,7 +930,7 @@ SCM_DEFINE (scm_input_port_p, "input-port?", 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 @@ -848,7 +942,7 @@ SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0, #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 @@ -859,7 +953,7 @@ SCM_DEFINE (scm_port_p, "port?", 1, 0, 0, "@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 @@ -870,7 +964,7 @@ SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0, #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 @@ -880,7 +974,7 @@ SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0, "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 @@ -895,7 +989,7 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 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); @@ -914,13 +1008,13 @@ SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0, { 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 @@ -934,7 +1028,7 @@ SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0, { 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) @@ -987,9 +1081,17 @@ scm_getc (SCM port) 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; @@ -1004,12 +1106,14 @@ scm_getc (SCM port) 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); } @@ -1030,9 +1134,17 @@ scm_lfwrite (const char *ptr, size_t size, SCM 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); } @@ -1121,10 +1233,11 @@ scm_c_write (SCM port, const void *ptr, size_t size) 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); } @@ -1166,6 +1279,8 @@ scm_ungetc (int c, SCM 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"); @@ -1193,8 +1308,8 @@ scm_ungetc (int c, SCM port) 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; } @@ -1260,7 +1375,7 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0, { 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); @@ -1285,7 +1400,7 @@ SCM_DEFINE (scm_unread_char, "unread-char", 1, 1, 0, SCM_VALIDATE_CHAR (1, cobj); if (SCM_UNBNDP (port)) - port = scm_cur_inp; + port = scm_current_input_port (); else SCM_VALIDATE_OPINPORT (2, port); @@ -1306,11 +1421,11 @@ SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0, { 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; } @@ -1343,85 +1458,120 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, "@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)) + { + 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)) { - SCM_SYSCALL (rv = ftruncate (SCM_INUM (object), c_length)); + /* 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); @@ -1437,8 +1587,13 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, } 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; @@ -1448,33 +1603,37 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, 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" @@ -1485,21 +1644,19 @@ SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0, { 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 @@ -1533,10 +1690,6 @@ SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0, } #undef FUNC_NAME -#ifndef ttyname -extern char * ttyname(); -#endif - void scm_print_port_mode (SCM exp, SCM port) { @@ -1562,7 +1715,7 @@ scm_port_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) 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; } @@ -1571,7 +1724,14 @@ void 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"); } @@ -1592,12 +1752,11 @@ write_void_port (SCM port SCM_UNUSED, { } -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); @@ -1605,11 +1764,17 @@ scm_void_port (char *mode_str) 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" @@ -1618,8 +1783,7 @@ SCM_DEFINE (scm_sys_make_void_port, "%make-void-port", 1, 0, 0, "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 @@ -1630,12 +1794,18 @@ void 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" }