mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-24 12:20:20 +02:00
Merge commit '29776e85da' into boehm-demers-weiser-gc
Conflicts: libguile/gc-card.c libguile/gc.c libguile/gc.h libguile/ports.c
This commit is contained in:
Ludovic Courtès
commit
6774820f1e
45 changed files with 2244 additions and 798 deletions
|
|
@ -1,3 +1,120 @@
|
|||
2007-10-02 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
* threads.c (on_thread_exit): Don't call `scm_leave_guile ()'
|
||||
since we're already in non-guile mode. Reported by Greg Toxel
|
||||
for NetBSD.
|
||||
|
||||
2007-10-01 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
* ports.c (flush_output_port): Expect directly a port instead of
|
||||
a pair. Fixes a bug in the new port table (2007-08-26).
|
||||
|
||||
2007-09-11 Kevin Ryde <user42@zip.com.au>
|
||||
|
||||
* posix.c (scm_putenv): Confine the putenv("NAME=") bit to mingw, use
|
||||
putenv("NAME") as the fallback everywhere else. In particular this is
|
||||
needed for solaris 9. Reported by Frank Storbeck.
|
||||
|
||||
2007-09-03 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
* read.c (flush_ws): Handle SCSH block comments.
|
||||
|
||||
2007-09-03 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
Fix alignment issues which showed up at least on SPARC.
|
||||
|
||||
* socket.c (scm_t_max_sockaddr, scm_t_getsockopt_result): New.
|
||||
(scm_inet_pton): Change DST to `scm_t_uint32' for correct
|
||||
alignment.
|
||||
(scm_getsockopt): Change OPTVAL to `scm_t_getsockopt_result' for
|
||||
correct alignment.
|
||||
(_scm_from_sockaddr): Change ADDRESS to `scm_t_max_sockaddr *'.
|
||||
(scm_from_sockaddr): Cast ADDRESS to `scm_t_max_sockaddr *'.
|
||||
(MAX_SIZE_UN, MAX_SIZE_IN6): Removed.
|
||||
(scm_accept, scm_getsockname, scm_getpeername, scm_recvfrom):
|
||||
Use `scm_t_max_sockaddr' instead of "char max_addr[MAX_ADDR_SIZE]".
|
||||
|
||||
2007-09-03 Kevin Ryde <user42@zip.com.au>
|
||||
|
||||
* numbers.c (scm_log): Test HAVE_CLOG as well as HAVE_COMPLEX_DOUBLE
|
||||
before using clog(). It's possible for gcc to provide the "complex
|
||||
double" type, but for the system not to have the complex funcs.
|
||||
(scm_exp): Ditto HAVE_CEXP for cexp().
|
||||
(clog, cexp, carg): Remove fallback definitions. These only
|
||||
duplicated the code within scm_log and scm_exp, and the latter have to
|
||||
exist for the case when there's no "complex double". So better just
|
||||
fix up the conditionals selecting between the complex funcs and plain
|
||||
doubles than worry about fallbacks.
|
||||
|
||||
2007-09-02 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
* socket.c (scm_make_socket_address): Free C_ADDRESS after use.
|
||||
This fixes a memory leak.
|
||||
|
||||
2007-08-26 Han-Wen Nienhuys <hanwen@lilypond.org>
|
||||
|
||||
* fports.c gc-card.c gc.c gc.h ioext.c ports.c ports.h weaks.h
|
||||
gc.c: replace port table with weak hash table. This simplifies
|
||||
memory management, and fixes freed cells appearing in
|
||||
port-for-each output.
|
||||
|
||||
* init.c (cleanup_for_exit): abort cleanup if init_mutex is still
|
||||
held.
|
||||
|
||||
2007-08-23 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
* read.c (scm_read_quote): Record position and copy source
|
||||
expression when asked to. Reported by Kevin.
|
||||
|
||||
* stime.c: Define `_REENTRANT' only if not already defined.
|
||||
|
||||
2007-08-21 Kevin Ryde <user42@zip.com.au>
|
||||
|
||||
* gc-card.c (scm_i_card_statistics): Record scm_tc7_number types as
|
||||
tc16 values so big, real, complex and fraction can be distinguished.
|
||||
|
||||
(scm_i_tag_name): Return "number" for scm_tc7_number, not NULL. NULL
|
||||
was making numbers come out as "type 23" in gc-live-object-stats.
|
||||
Fix tests of the tc16 number types, they were checked under
|
||||
scm_tc7_number, but the values went down the tag>=255 smob case.
|
||||
Put smob case under scm_tc7_smob instead of using tag>=255, per
|
||||
recommendation in comments with scm_tc7_smob to use symbolic values.
|
||||
Use SCM_TC2SMOBNUM to extract scm_smobs index, instead of explicit
|
||||
code. Lose some unnecessary "break" statements.
|
||||
|
||||
(scm_i_card_statistics): Use scm_hashq_create_handle_x and modify the
|
||||
element returned, rather than two lookups scm_hashq_ref and
|
||||
scm_hashq_set_x.
|
||||
|
||||
2007-08-17 Kevin Ryde <user42@zip.com.au>
|
||||
|
||||
* stime.c: Add #define _REENTRANT, to get gmtime_r() prototype on
|
||||
solaris 2.6. Reported by anirkko.
|
||||
|
||||
2007-07-29 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
* Makefile.am (INCLUDES): Added Gnulib includes.
|
||||
(gnulib_library): New.
|
||||
(libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LIBADD): Added
|
||||
`$(gnulib_library)'.
|
||||
(libguile_la_LIBADD): Likewise.
|
||||
|
||||
* posix.c: Don't define `_GNU_SOURCE' since `gl_EARLY' arranges
|
||||
to define it when available.
|
||||
* srfi-14.c: Likewise.
|
||||
* i18n.c: Likewise. Include Gnulib's <alloca.h>
|
||||
* eval.c: Include Gnulib's <alloca.h>.
|
||||
* filesys.c: Likewise.
|
||||
* read.c: Don't include <strings.h> and don't provide an
|
||||
`strncasecmp ()' replacement; use Gnulib's <string.h> and
|
||||
`strncasecmp ()' instead.
|
||||
|
||||
2007-07-25 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
* eval.c (macroexp): When `scm_ilength (res) <= 0', return
|
||||
immediately. This used to produce a circular memoized
|
||||
expression, e.g., for `(set (quote x) #t)'.
|
||||
|
||||
2007-07-22 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
Overhauled the reader, making it faster.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
## Process this file with Automake to create Makefile.in
|
||||
##
|
||||
## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
|
||||
## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
|
||||
##
|
||||
## This file is part of GUILE.
|
||||
##
|
||||
|
|
@ -25,8 +25,12 @@ AUTOMAKE_OPTIONS = gnu
|
|||
DEFS = @DEFS@
|
||||
## Check for headers in $(srcdir)/.., so that #include
|
||||
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
|
||||
## building.
|
||||
INCLUDES = -I.. -I$(top_srcdir)
|
||||
## building. Also look for Gnulib headers in `lib'.
|
||||
INCLUDES = -I.. -I$(top_srcdir) \
|
||||
-I$(top_srcdir)/lib -I$(top_builddir)/lib
|
||||
|
||||
## The Gnulib Libtool archive.
|
||||
gnulib_library = $(top_builddir)/lib/libgnu.la
|
||||
|
||||
ETAGS_ARGS = --regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_LONG\).*\"\([^\"]\)*\"/\3/' \
|
||||
--regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/'
|
||||
|
|
@ -114,7 +118,7 @@ libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c
|
|||
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \
|
||||
$(libguile_la_CFLAGS)
|
||||
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LIBADD = \
|
||||
libguile.la
|
||||
libguile.la $(gnulib_library)
|
||||
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \
|
||||
-module -L$(builddir) -lguile \
|
||||
-version-info @LIBGUILE_I18N_INTERFACE@
|
||||
|
|
@ -186,7 +190,7 @@ noinst_HEADERS = convert.i.c \
|
|||
private-gc.h private-options.h
|
||||
|
||||
libguile_la_DEPENDENCIES = @LIBLOBJS@
|
||||
libguile_la_LIBADD = @LIBLOBJS@
|
||||
libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library)
|
||||
libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined
|
||||
|
||||
# These are headers visible as <guile/mumble.h>
|
||||
|
|
|
|||
|
|
@ -27,25 +27,9 @@
|
|||
# include <config.h>
|
||||
#endif
|
||||
|
||||
#include "libguile/__scm.h"
|
||||
#include <alloca.h>
|
||||
|
||||
/* This blob per the Autoconf manual (under "Particular Functions"). */
|
||||
#if HAVE_ALLOCA_H
|
||||
# include <alloca.h>
|
||||
#elif defined __GNUC__
|
||||
# define alloca __builtin_alloca
|
||||
#elif defined _AIX
|
||||
# define alloca __alloca
|
||||
#elif defined _MSC_VER
|
||||
# include <malloc.h>
|
||||
# define alloca _alloca
|
||||
#else
|
||||
# include <stddef.h>
|
||||
# ifdef __cplusplus
|
||||
extern "C"
|
||||
# endif
|
||||
void *alloca (size_t);
|
||||
#endif
|
||||
#include "libguile/__scm.h"
|
||||
|
||||
#include <assert.h>
|
||||
#include "libguile/_scm.h"
|
||||
|
|
@ -874,26 +858,29 @@ macroexp (SCM x, SCM env)
|
|||
|
||||
SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
|
||||
res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
|
||||
|
||||
|
||||
if (scm_ilength (res) <= 0)
|
||||
res = scm_list_2 (SCM_IM_BEGIN, res);
|
||||
/* Result of expansion is not a list. */
|
||||
return (scm_list_2 (SCM_IM_BEGIN, res));
|
||||
else
|
||||
{
|
||||
/* njrev: Several queries here: (1) I don't see how it can be
|
||||
correct that the SCM_SETCAR 2 lines below this comment needs
|
||||
protection, but the SCM_SETCAR 6 lines above does not, so
|
||||
something here is probably wrong. (2) macroexp() is now only
|
||||
used in one place - scm_m_generalized_set_x - whereas all other
|
||||
macro expansion happens through expand_user_macros. Therefore
|
||||
(2.1) perhaps macroexp() could be eliminated completely now?
|
||||
(2.2) Does expand_user_macros need any critical section
|
||||
protection? */
|
||||
|
||||
/* njrev: Several queries here: (1) I don't see how it can be
|
||||
correct that the SCM_SETCAR 2 lines below this comment needs
|
||||
protection, but the SCM_SETCAR 6 lines above does not, so
|
||||
something here is probably wrong. (2) macroexp() is now only
|
||||
used in one place - scm_m_generalized_set_x - whereas all other
|
||||
macro expansion happens through expand_user_macros. Therefore
|
||||
(2.1) perhaps macroexp() could be eliminated completely now?
|
||||
(2.2) Does expand_user_macros need any critical section
|
||||
protection? */
|
||||
SCM_CRITICAL_SECTION_START;
|
||||
SCM_SETCAR (x, SCM_CAR (res));
|
||||
SCM_SETCDR (x, SCM_CDR (res));
|
||||
SCM_CRITICAL_SECTION_END;
|
||||
|
||||
SCM_CRITICAL_SECTION_START;
|
||||
SCM_SETCAR (x, SCM_CAR (res));
|
||||
SCM_SETCDR (x, SCM_CDR (res));
|
||||
SCM_CRITICAL_SECTION_END;
|
||||
|
||||
goto macro_tail;
|
||||
goto macro_tail;
|
||||
}
|
||||
}
|
||||
|
||||
/* Start of the memoizers for the standard R5RS builtin macros. */
|
||||
|
|
|
|||
|
|
@ -29,23 +29,7 @@
|
|||
# include <config.h>
|
||||
#endif
|
||||
|
||||
/* This blob per the Autoconf manual (under "Particular Functions"). */
|
||||
#if HAVE_ALLOCA_H
|
||||
# include <alloca.h>
|
||||
#elif defined __GNUC__
|
||||
# define alloca __builtin_alloca
|
||||
#elif defined _AIX
|
||||
# define alloca __alloca
|
||||
#elif defined _MSC_VER
|
||||
# include <malloc.h>
|
||||
# define alloca _alloca
|
||||
#else
|
||||
# include <stddef.h>
|
||||
# ifdef __cplusplus
|
||||
extern "C"
|
||||
# endif
|
||||
void *alloca (size_t);
|
||||
#endif
|
||||
#include <alloca.h>
|
||||
|
||||
#include <stdio.h>
|
||||
#include <errno.h>
|
||||
|
|
|
|||
|
|
@ -31,6 +31,7 @@
|
|||
#include "libguile/gc.h"
|
||||
#include "libguile/posix.h"
|
||||
#include "libguile/dynwind.h"
|
||||
#include "libguile/hashtab.h"
|
||||
|
||||
#include "libguile/fports.h"
|
||||
|
||||
|
|
@ -220,32 +221,35 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
|
|||
/* Move ports with the specified file descriptor to new descriptors,
|
||||
* resetting the revealed count to 0.
|
||||
*/
|
||||
static SCM
|
||||
scm_i_evict_port (SCM handle, void *closure)
|
||||
{
|
||||
int fd = * (int*) closure;
|
||||
SCM port = SCM_CAR (handle);
|
||||
|
||||
if (SCM_FPORTP (port))
|
||||
{
|
||||
scm_t_fport *fp = SCM_FSTREAM (port);
|
||||
|
||||
if (fp->fdes == fd)
|
||||
{
|
||||
fp->fdes = dup (fd);
|
||||
if (fp->fdes == -1)
|
||||
scm_syserror ("scm_evict_ports");
|
||||
scm_set_port_revealed_x (port, scm_from_int (0));
|
||||
}
|
||||
}
|
||||
|
||||
return handle;
|
||||
}
|
||||
|
||||
void
|
||||
scm_evict_ports (int fd)
|
||||
{
|
||||
long i;
|
||||
|
||||
scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
|
||||
|
||||
for (i = 0; i < scm_i_port_table_size; i++)
|
||||
{
|
||||
SCM port = scm_i_port_table[i]->port;
|
||||
|
||||
if (SCM_FPORTP (port))
|
||||
{
|
||||
scm_t_fport *fp = SCM_FSTREAM (port);
|
||||
|
||||
if (fp->fdes == fd)
|
||||
{
|
||||
fp->fdes = dup (fd);
|
||||
if (fp->fdes == -1)
|
||||
scm_syserror ("scm_evict_ports");
|
||||
scm_set_port_revealed_x (port, scm_from_int (0));
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
scm_internal_hash_for_each_handle (&scm_i_evict_port,
|
||||
(void*) &fd,
|
||||
scm_i_port_weak_hash);
|
||||
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -15,28 +15,11 @@
|
|||
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
*/
|
||||
|
||||
#define _GNU_SOURCE /* Ask for glibc's `newlocale' API */
|
||||
|
||||
#if HAVE_CONFIG_H
|
||||
# include <config.h>
|
||||
#endif
|
||||
|
||||
#if HAVE_ALLOCA_H
|
||||
# include <alloca.h>
|
||||
#elif defined __GNUC__
|
||||
# define alloca __builtin_alloca
|
||||
#elif defined _AIX
|
||||
# define alloca __alloca
|
||||
#elif defined _MSC_VER
|
||||
# include <malloc.h>
|
||||
# define alloca _alloca
|
||||
#else
|
||||
# include <stddef.h>
|
||||
# ifdef __cplusplus
|
||||
extern "C"
|
||||
# endif
|
||||
void *alloca (size_t);
|
||||
#endif
|
||||
#include <alloca.h>
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/feature.h"
|
||||
|
|
|
|||
|
|
@ -395,6 +395,14 @@ really_cleanup_for_exit (void *unused)
|
|||
static void
|
||||
cleanup_for_exit ()
|
||||
{
|
||||
if (scm_i_pthread_mutex_trylock (&scm_i_init_mutex) == 0)
|
||||
scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
|
||||
else
|
||||
{
|
||||
fprintf (stderr, "Cannot exit gracefully when init is in progress; aborting.\n");
|
||||
abort ();
|
||||
}
|
||||
|
||||
/* This function might be called in non-guile mode, so we need to
|
||||
enter it temporarily.
|
||||
*/
|
||||
|
|
@ -474,6 +482,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
|
|||
scm_init_backtrace (); /* Requires fluids */
|
||||
scm_init_fports ();
|
||||
scm_init_strports ();
|
||||
scm_init_ports ();
|
||||
scm_init_gdbint (); /* Requires strports */
|
||||
scm_init_hash ();
|
||||
scm_init_hashtab ();
|
||||
|
|
@ -492,7 +501,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
|
|||
scm_init_numbers ();
|
||||
scm_init_options ();
|
||||
scm_init_pairs ();
|
||||
scm_init_ports ();
|
||||
#ifdef HAVE_POSIX
|
||||
scm_init_filesys ();
|
||||
scm_init_posix ();
|
||||
|
|
|
|||
|
|
@ -26,13 +26,14 @@
|
|||
#include <errno.h>
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/ioext.h"
|
||||
#include "libguile/fports.h"
|
||||
#include "libguile/dynwind.h"
|
||||
#include "libguile/feature.h"
|
||||
#include "libguile/fports.h"
|
||||
#include "libguile/hashtab.h"
|
||||
#include "libguile/ioext.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/validate.h"
|
||||
#include "libguile/dynwind.h"
|
||||
|
||||
#include <fcntl.h>
|
||||
|
||||
|
|
@ -266,6 +267,19 @@ SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
static SCM
|
||||
get_matching_port (void *closure, SCM port, SCM val, SCM result)
|
||||
{
|
||||
int fd = * (int *) closure;
|
||||
scm_t_port *entry = SCM_PTAB_ENTRY (port);
|
||||
|
||||
if (SCM_OPFPORTP (port)
|
||||
&& ((scm_t_fport *) entry->stream)->fdes == fd)
|
||||
result = scm_cons (port, result);
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/* Return a list of ports using a given file descriptor. */
|
||||
SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
|
||||
(SCM fd),
|
||||
|
|
@ -275,18 +289,12 @@ SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
|
|||
#define FUNC_NAME s_scm_fdes_to_ports
|
||||
{
|
||||
SCM result = SCM_EOL;
|
||||
int int_fd;
|
||||
long i;
|
||||
|
||||
int_fd = scm_to_int (fd);
|
||||
int int_fd = scm_to_int (fd);
|
||||
|
||||
scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
|
||||
for (i = 0; i < scm_i_port_table_size; i++)
|
||||
{
|
||||
if (SCM_OPFPORTP (scm_i_port_table[i]->port)
|
||||
&& ((scm_t_fport *) scm_i_port_table[i]->stream)->fdes == int_fd)
|
||||
result = scm_cons (scm_i_port_table[i]->port, result);
|
||||
}
|
||||
result = scm_internal_hash_fold (get_matching_port,
|
||||
(void*) &int_fd, result,
|
||||
scm_i_port_weak_hash);
|
||||
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
|
||||
return result;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007 Free Software Foundation, Inc.
|
||||
*
|
||||
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
|
||||
* and Bellcore. See scm_divide.
|
||||
|
|
@ -5998,35 +5998,6 @@ scm_is_number (SCM z)
|
|||
return scm_is_true (scm_number_p (z));
|
||||
}
|
||||
|
||||
#ifdef HAVE_COMPLEX_DOUBLE
|
||||
#ifndef HAVE_CLOG
|
||||
complex double clog (complex double z);
|
||||
complex double
|
||||
clog (complex double z)
|
||||
{
|
||||
return log(cabs(z))+I*carg(z);
|
||||
}
|
||||
#endif
|
||||
|
||||
#ifndef HAVE_CEXP
|
||||
complex double cexp (complex double z);
|
||||
complex double
|
||||
cexp (complex double z)
|
||||
{
|
||||
return exp (cabs (z)) * cos(carg (z) + I*sin(carg (z)));
|
||||
}
|
||||
#endif
|
||||
|
||||
#ifndef HAVE_CARG
|
||||
double carg (complex double z);
|
||||
double
|
||||
carg (complex double z)
|
||||
{
|
||||
return atan2 (cimag(z), creal(z));
|
||||
}
|
||||
#endif
|
||||
#endif /* HAVE_COMPLEX_DOUBLE */
|
||||
|
||||
|
||||
/* In the following functions we dispatch to the real-arg funcs like log()
|
||||
when we know the arg is real, instead of just handing everything to
|
||||
|
|
@ -6041,7 +6012,7 @@ SCM_DEFINE (scm_log, "log", 1, 0, 0,
|
|||
{
|
||||
if (SCM_COMPLEXP (z))
|
||||
{
|
||||
#if HAVE_COMPLEX_DOUBLE
|
||||
#if HAVE_COMPLEX_DOUBLE && HAVE_CLOG
|
||||
return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z)));
|
||||
#else
|
||||
double re = SCM_COMPLEX_REAL (z);
|
||||
|
|
@ -6107,7 +6078,7 @@ SCM_DEFINE (scm_exp, "exp", 1, 0, 0,
|
|||
{
|
||||
if (SCM_COMPLEXP (z))
|
||||
{
|
||||
#if HAVE_COMPLEX_DOUBLE
|
||||
#if HAVE_COMPLEX_DOUBLE && HAVE_CEXP
|
||||
return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z)));
|
||||
#else
|
||||
return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)),
|
||||
|
|
|
|||
136
libguile/ports.c
136
libguile/ports.c
|
|
@ -42,12 +42,14 @@
|
|||
#include "libguile/dynwind.h"
|
||||
|
||||
#include "libguile/keywords.h"
|
||||
#include "libguile/hashtab.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/weaks.h"
|
||||
#include "libguile/fluids.h"
|
||||
|
||||
#ifdef HAVE_STRING_H
|
||||
|
|
@ -84,7 +86,7 @@
|
|||
|
||||
|
||||
/* scm_ptobs scm_numptob
|
||||
* implement a dynamicly resized array of ptob records.
|
||||
* implement a dynamically resized array of ptob records.
|
||||
* Indexes into this table are used when generating type
|
||||
* tags for smobjects (if you know a tag you can get an index and conversely).
|
||||
*/
|
||||
|
|
@ -485,10 +487,11 @@ scm_i_dynwind_current_load_port (SCM port)
|
|||
|
||||
/* The port table --- an array of pointers to ports. */
|
||||
|
||||
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; /* Actual size of the array. */
|
||||
/*
|
||||
We need a global registry of ports to flush them all at exit, and to
|
||||
get all the ports matching a file descriptor.
|
||||
*/
|
||||
SCM scm_i_port_weak_hash;
|
||||
|
||||
scm_i_pthread_mutex_t scm_i_port_table_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
|
||||
|
||||
|
|
@ -567,33 +570,15 @@ scm_new_port_table_entry (scm_t_bits tag)
|
|||
|
||||
SCM z = scm_cons (SCM_EOL, SCM_EOL);
|
||||
scm_t_port *entry = (scm_t_port *) scm_gc_calloc (sizeof (scm_t_port), "port");
|
||||
if (scm_i_port_table_size == scm_i_port_table_room)
|
||||
{
|
||||
/* initial malloc is in gc.c. this doesn't use scm_gc_malloc etc.,
|
||||
since it can never be freed during gc. */
|
||||
/* 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 = new_size;
|
||||
}
|
||||
|
||||
entry->entry = scm_i_port_table_size;
|
||||
|
||||
entry->file_name = SCM_BOOL_F;
|
||||
entry->rw_active = SCM_PORT_NEITHER;
|
||||
|
||||
scm_i_port_table[scm_i_port_table_size] = entry;
|
||||
scm_i_port_table_size++;
|
||||
|
||||
entry->port = z;
|
||||
SCM_SET_CELL_TYPE(z, tag);
|
||||
SCM_SETPTAB_ENTRY(z, entry);
|
||||
|
||||
SCM_SET_CELL_TYPE (z, tag);
|
||||
SCM_SETPTAB_ENTRY (z, entry);
|
||||
|
||||
scm_hashq_set_x (scm_i_port_weak_hash, z, SCM_BOOL_F);
|
||||
|
||||
/* For each new port, register a finalizer so that it port type's free
|
||||
function can be invoked eventually. */
|
||||
|
|
@ -611,8 +596,8 @@ scm_add_to_port_table (SCM port)
|
|||
scm_t_port * pt = SCM_PTAB_ENTRY(z);
|
||||
|
||||
pt->port = port;
|
||||
SCM_SETCAR(z, SCM_EOL);
|
||||
SCM_SETCDR(z, SCM_EOL);
|
||||
SCM_SETCAR (z, SCM_EOL);
|
||||
SCM_SETCDR (z, SCM_EOL);
|
||||
SCM_SETPTAB_ENTRY (port, pt);
|
||||
return pt;
|
||||
}
|
||||
|
|
@ -622,57 +607,30 @@ scm_add_to_port_table (SCM port)
|
|||
/* Remove a port from the table and destroy it. */
|
||||
|
||||
/* This function is not and should not be thread safe. */
|
||||
|
||||
void
|
||||
scm_remove_from_port_table (SCM port)
|
||||
#define FUNC_NAME "scm_remove_from_port_table"
|
||||
scm_i_remove_port (SCM port)
|
||||
#define FUNC_NAME "scm_remove_port"
|
||||
{
|
||||
scm_t_port *p = SCM_PTAB_ENTRY (port);
|
||||
long i = p->entry;
|
||||
|
||||
if (i >= scm_i_port_table_size)
|
||||
SCM_MISC_ERROR ("Port not in table: ~S", scm_list_1 (port));
|
||||
if (p->putback_buf)
|
||||
scm_gc_free (p->putback_buf, p->putback_buf_size, "putback buffer");
|
||||
scm_gc_free (p, sizeof (scm_t_port), "port");
|
||||
/* Since we have just freed slot i we can shrink the table by moving
|
||||
the last entry to that slot... */
|
||||
if (i < scm_i_port_table_size - 1)
|
||||
{
|
||||
scm_i_port_table[i] = scm_i_port_table[scm_i_port_table_size - 1];
|
||||
scm_i_port_table[i]->entry = i;
|
||||
}
|
||||
|
||||
SCM_SETPTAB_ENTRY (port, 0);
|
||||
scm_i_port_table_size--;
|
||||
scm_hashq_remove_x (scm_i_port_weak_hash, port);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
#ifdef GUILE_DEBUG
|
||||
/* Functions for debugging. */
|
||||
|
||||
#ifdef GUILE_DEBUG
|
||||
SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0,
|
||||
(),
|
||||
"Return the number of ports in the port table. @code{pt-size}\n"
|
||||
"is only included in @code{--enable-guile-debug} builds.")
|
||||
#define FUNC_NAME s_scm_pt_size
|
||||
{
|
||||
return scm_from_int (scm_i_port_table_size);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_pt_member, "pt-member", 1, 0, 0,
|
||||
(SCM index),
|
||||
"Return the port at @var{index} in the port table.\n"
|
||||
"@code{pt-member} is only included in\n"
|
||||
"@code{--enable-guile-debug} builds.")
|
||||
#define FUNC_NAME s_scm_pt_member
|
||||
{
|
||||
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;
|
||||
return scm_from_int (SCM_HASHTABLE_N_ITEMS (scm_i_port_weak_hash));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
#endif
|
||||
|
|
@ -833,7 +791,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
|
|||
else
|
||||
rv = 0;
|
||||
scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
|
||||
scm_remove_from_port_table (port);
|
||||
scm_i_remove_port (port);
|
||||
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
|
||||
SCM_CLR_PORT_OPEN_FLAG (port);
|
||||
return scm_from_bool (rv >= 0);
|
||||
|
|
@ -871,10 +829,20 @@ SCM_DEFINE (scm_close_output_port, "close-output-port", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
static SCM
|
||||
scm_i_collect_keys_in_vector (void *closure, SCM key, SCM value, SCM result)
|
||||
{
|
||||
int *i = (int*) closure;
|
||||
scm_c_vector_set_x (result, *i, key);
|
||||
(*i)++;
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
void
|
||||
scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
|
||||
{
|
||||
long i;
|
||||
int i = 0;
|
||||
size_t n;
|
||||
SCM ports;
|
||||
|
||||
|
|
@ -884,20 +852,20 @@ scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
|
|||
collect the ports into a vector. -mvo */
|
||||
|
||||
scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
|
||||
n = scm_i_port_table_size;
|
||||
n = SCM_HASHTABLE_N_ITEMS (scm_i_port_weak_hash);
|
||||
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_lock (&scm_i_port_table_mutex);
|
||||
ports = scm_internal_hash_fold (scm_i_collect_keys_in_vector, &i,
|
||||
ports, scm_i_port_weak_hash);
|
||||
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
|
||||
|
||||
for (i = 0; i < n; i++)
|
||||
proc (data, SCM_SIMPLE_VECTOR_REF (ports, i));
|
||||
for (i = 0; i < n; i++) {
|
||||
SCM p = SCM_SIMPLE_VECTOR_REF (ports, i);
|
||||
if (SCM_PORTP (p))
|
||||
proc (data, p);
|
||||
}
|
||||
|
||||
scm_remember_upto_here_1 (ports);
|
||||
}
|
||||
|
|
@ -1000,21 +968,21 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
static void
|
||||
flush_output_port (void *closure, SCM port)
|
||||
{
|
||||
if (SCM_OPOUTPORTP (port))
|
||||
scm_flush (port);
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
|
||||
(),
|
||||
"Equivalent to calling @code{force-output} on\n"
|
||||
"all open output ports. The return value is unspecified.")
|
||||
#define FUNC_NAME s_scm_flush_all_ports
|
||||
{
|
||||
size_t i;
|
||||
|
||||
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_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
|
||||
scm_c_port_for_each (&flush_output_port, NULL);
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
|
@ -1806,6 +1774,8 @@ scm_init_ports ()
|
|||
cur_errport_fluid = scm_permanent_object (scm_make_fluid ());
|
||||
cur_loadport_fluid = scm_permanent_object (scm_make_fluid ());
|
||||
|
||||
scm_i_port_weak_hash = scm_permanent_object (scm_make_weak_key_hash_table (SCM_I_MAKINUM(31)));
|
||||
|
||||
#include "libguile/ports.x"
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -47,7 +47,6 @@ typedef enum scm_t_port_rw_active {
|
|||
typedef struct
|
||||
{
|
||||
SCM port; /* Link back to the port object. */
|
||||
long entry; /* Index in port table. */
|
||||
int revealed; /* 0 not revealed, > 1 revealed.
|
||||
* Revealed ports do not get GC'd.
|
||||
*/
|
||||
|
|
@ -109,9 +108,10 @@ typedef struct
|
|||
size_t putback_buf_size; /* allocated size of putback_buf. */
|
||||
} scm_t_port;
|
||||
|
||||
SCM_API scm_t_port **scm_i_port_table;
|
||||
SCM_API long scm_i_port_table_size; /* Number of ports in scm_i_port_table. */
|
||||
|
||||
SCM_API scm_i_pthread_mutex_t scm_i_port_table_mutex;
|
||||
SCM_API SCM scm_i_port_weak_hash;
|
||||
|
||||
|
||||
#define SCM_READ_BUFFER_EMPTY_P(c_port) (c_port->read_pos >= c_port->read_end)
|
||||
|
||||
|
|
@ -241,7 +241,7 @@ SCM_API void scm_dynwind_current_input_port (SCM port);
|
|||
SCM_API void scm_dynwind_current_output_port (SCM port);
|
||||
SCM_API void scm_dynwind_current_error_port (SCM port);
|
||||
SCM_API SCM scm_new_port_table_entry (scm_t_bits tag);
|
||||
SCM_API void scm_remove_from_port_table (SCM port);
|
||||
SCM_API void scm_i_remove_port (SCM port);
|
||||
SCM_API void scm_grow_port_cbuf (SCM port, size_t requested);
|
||||
SCM_API SCM scm_pt_size (void);
|
||||
SCM_API SCM scm_pt_member (SCM member);
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 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
|
||||
|
|
@ -21,9 +21,6 @@
|
|||
# include <config.h>
|
||||
#endif
|
||||
|
||||
/* Make GNU/Linux libc declare everything it has. */
|
||||
#define _GNU_SOURCE
|
||||
|
||||
#include <stdio.h>
|
||||
#include <errno.h>
|
||||
|
||||
|
|
@ -1343,16 +1340,39 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
|
|||
|
||||
if (strchr (c_str, '=') == NULL)
|
||||
{
|
||||
#ifdef HAVE_UNSETENV
|
||||
/* No '=' in argument means we should remove the variable from
|
||||
the environment. Not all putenvs understand this (for instance
|
||||
FreeBSD 4.8 doesn't). To be safe, we do it explicitely using
|
||||
unsetenv. */
|
||||
/* We want no "=" in the argument to mean remove the variable from the
|
||||
environment, but not all putenv()s understand this, for example
|
||||
FreeBSD 4.8 doesn't. Getting it happening everywhere is a bit
|
||||
painful. What unsetenv() exists, we use that, of course.
|
||||
|
||||
Traditionally putenv("NAME") removes a variable, for example that's
|
||||
what we have to do on Solaris 9 (it doesn't have an unsetenv).
|
||||
|
||||
But on DOS and on that DOS overlay manager thing called W-whatever,
|
||||
putenv("NAME=") must be used (it too doesn't have an unsetenv).
|
||||
|
||||
Supposedly on AIX a putenv("NAME") could cause a segfault, but also
|
||||
supposedly AIX 5.3 and up has unsetenv() available so should be ok
|
||||
with the latter there.
|
||||
|
||||
For the moment we hard code the DOS putenv("NAME=") style under
|
||||
__MINGW32__ and do the traditional everywhere else. Such
|
||||
system-name tests are bad, of course. It'd be possible to use a
|
||||
configure test when doing a a native build. For example GNU R has
|
||||
such a test (see R_PUTENV_AS_UNSETENV in
|
||||
https://svn.r-project.org/R/trunk/m4/R.m4). But when cross
|
||||
compiling there'd want to be a guess, one probably based on the
|
||||
system name (ie. mingw or not), thus landing back in basically the
|
||||
present hard-coded situation. Another possibility for a cross
|
||||
build would be to try "NAME" then "NAME=" at runtime, if that's not
|
||||
too much like overkill. */
|
||||
|
||||
#if HAVE_UNSETENV
|
||||
/* when unsetenv() exists then we use it */
|
||||
unsetenv (c_str);
|
||||
free (c_str);
|
||||
#else
|
||||
/* On e.g. Win32 hosts putenv() called with 'name=' removes the
|
||||
environment variable 'name'. */
|
||||
#elif defined (__MINGW32__)
|
||||
/* otherwise putenv("NAME=") on DOS */
|
||||
int e;
|
||||
size_t len = strlen (c_str);
|
||||
char *ptr = scm_malloc (len + 2);
|
||||
|
|
@ -1362,7 +1382,12 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
|
|||
e = errno; free (ptr); free (c_str); errno = e;
|
||||
if (rv < 0)
|
||||
SCM_SYSERROR;
|
||||
#endif /* !HAVE_UNSETENV */
|
||||
#else
|
||||
/* otherwise traditional putenv("NAME") */
|
||||
rv = putenv (c_str);
|
||||
if (rv < 0)
|
||||
SCM_SYSERROR;
|
||||
#endif
|
||||
}
|
||||
else
|
||||
{
|
||||
|
|
|
|||
|
|
@ -26,9 +26,6 @@
|
|||
#include <stdio.h>
|
||||
#include <ctype.h>
|
||||
#include <string.h>
|
||||
#ifdef HAVE_STRINGS_H
|
||||
# include <strings.h>
|
||||
#endif
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/chars.h"
|
||||
|
|
@ -182,29 +179,8 @@ static SCM *scm_read_hash_procedures;
|
|||
(((_chr) <= UCHAR_MAX) ? tolower (_chr) : (_chr))
|
||||
|
||||
|
||||
#ifndef HAVE_STRNCASECMP
|
||||
/* XXX: Use Gnulib's `strncasecmp ()'. */
|
||||
|
||||
static int
|
||||
strncasecmp (const char *s1, const char *s2, size_t len2)
|
||||
{
|
||||
while (*s1 && *s2 && len2 > 0)
|
||||
{
|
||||
int c1 = *s1, c2 = *s2;
|
||||
|
||||
if (CHAR_DOWNCASE (c1) != CHAR_DOWNCASE (c2))
|
||||
return 0;
|
||||
else
|
||||
{
|
||||
++s1;
|
||||
++s2;
|
||||
--len2;
|
||||
}
|
||||
}
|
||||
return !(*s1 || *s2 || len2 > 0);
|
||||
}
|
||||
#endif
|
||||
|
||||
/* Read an SCSH block comment. */
|
||||
static inline SCM scm_read_scsh_block_comment (int chr, SCM port);
|
||||
|
||||
/* Helper function similar to `scm_read_token ()'. Read from PORT until a
|
||||
whitespace is read. Return zero if the whole token could fit in BUF,
|
||||
|
|
@ -272,6 +248,21 @@ flush_ws (SCM port, const char *eoferr)
|
|||
}
|
||||
break;
|
||||
|
||||
case '#':
|
||||
switch (c = scm_getc (port))
|
||||
{
|
||||
case EOF:
|
||||
eoferr = "read_sharp";
|
||||
goto goteof;
|
||||
case '!':
|
||||
scm_read_scsh_block_comment (c, port);
|
||||
break;
|
||||
default:
|
||||
scm_ungetc (c, port);
|
||||
return '#';
|
||||
}
|
||||
break;
|
||||
|
||||
case SCM_LINE_INCREMENTORS:
|
||||
case SCM_SINGLE_SPACES:
|
||||
case '\t':
|
||||
|
|
@ -637,6 +628,8 @@ static SCM
|
|||
scm_read_quote (int chr, SCM port)
|
||||
{
|
||||
SCM p;
|
||||
long line = SCM_LINUM (port);
|
||||
int column = SCM_COL (port) - 1;
|
||||
|
||||
switch (chr)
|
||||
{
|
||||
|
|
@ -670,6 +663,17 @@ scm_read_quote (int chr, SCM port)
|
|||
}
|
||||
|
||||
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
|
||||
if (SCM_RECORD_POSITIONS_P)
|
||||
scm_whash_insert (scm_source_whash, p,
|
||||
scm_make_srcprops (line, column,
|
||||
SCM_FILENAME (port),
|
||||
SCM_COPY_SOURCE_P
|
||||
? (scm_cons2 (SCM_CAR (p),
|
||||
SCM_CAR (SCM_CDR (p)),
|
||||
SCM_EOL))
|
||||
: SCM_UNDEFINED,
|
||||
SCM_EOL));
|
||||
|
||||
|
||||
return p;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -67,6 +67,26 @@
|
|||
+ strlen ((ptr)->sun_path))
|
||||
#endif
|
||||
|
||||
/* The largest possible socket address. Wrapping it in a union guarantees
|
||||
that the compiler will make it suitably aligned. */
|
||||
typedef union
|
||||
{
|
||||
struct sockaddr sockaddr;
|
||||
struct sockaddr_in sockaddr_in;
|
||||
|
||||
#ifdef HAVE_UNIX_DOMAIN_SOCKETS
|
||||
struct sockaddr_un sockaddr_un;
|
||||
#endif
|
||||
#ifdef HAVE_IPV6
|
||||
struct sockaddr_in6 sockaddr_in6;
|
||||
#endif
|
||||
} scm_t_max_sockaddr;
|
||||
|
||||
|
||||
/* Maximum size of a socket address. */
|
||||
#define MAX_ADDR_SIZE (sizeof (scm_t_max_sockaddr))
|
||||
|
||||
|
||||
|
||||
|
||||
SCM_DEFINE (scm_htons, "htons", 1, 0, 0,
|
||||
|
|
@ -344,7 +364,7 @@ SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0,
|
|||
{
|
||||
int af;
|
||||
char *src;
|
||||
char dst[16];
|
||||
scm_t_uint32 dst[4];
|
||||
int rv, eno;
|
||||
|
||||
af = scm_to_int (family);
|
||||
|
|
@ -359,7 +379,7 @@ SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0,
|
|||
else if (rv == 0)
|
||||
SCM_MISC_ERROR ("Bad address", SCM_EOL);
|
||||
if (af == AF_INET)
|
||||
return scm_from_ulong (ntohl (*(scm_t_uint32 *) dst));
|
||||
return scm_from_ulong (ntohl (*dst));
|
||||
else
|
||||
return scm_from_ipv6 ((scm_t_uint8 *) dst);
|
||||
}
|
||||
|
|
@ -468,6 +488,17 @@ SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0,
|
|||
#undef FUNC_NAME
|
||||
#endif
|
||||
|
||||
/* Possible results for `getsockopt ()'. Wrapping it into a union guarantees
|
||||
suitable alignment. */
|
||||
typedef union
|
||||
{
|
||||
#ifdef HAVE_STRUCT_LINGER
|
||||
struct linger linger;
|
||||
#endif
|
||||
size_t size;
|
||||
int integer;
|
||||
} scm_t_getsockopt_result;
|
||||
|
||||
SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
|
||||
(SCM sock, SCM level, SCM optname),
|
||||
"Return an option value from socket port @var{sock}.\n"
|
||||
|
|
@ -518,13 +549,8 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
|
|||
{
|
||||
int fd;
|
||||
/* size of optval is the largest supported option. */
|
||||
#ifdef HAVE_STRUCT_LINGER
|
||||
char optval[sizeof (struct linger)];
|
||||
socklen_t optlen = sizeof (struct linger);
|
||||
#else
|
||||
char optval[sizeof (size_t)];
|
||||
socklen_t optlen = sizeof (size_t);
|
||||
#endif
|
||||
scm_t_getsockopt_result optval;
|
||||
socklen_t optlen = sizeof (optval);
|
||||
int ilevel;
|
||||
int ioptname;
|
||||
|
||||
|
|
@ -534,7 +560,7 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
|
|||
ioptname = scm_to_int (optname);
|
||||
|
||||
fd = SCM_FPORT_FDES (sock);
|
||||
if (getsockopt (fd, ilevel, ioptname, (void *) optval, &optlen) == -1)
|
||||
if (getsockopt (fd, ilevel, ioptname, (void *) &optval, &optlen) == -1)
|
||||
SCM_SYSERROR;
|
||||
|
||||
if (ilevel == SOL_SOCKET)
|
||||
|
|
@ -543,12 +569,12 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
|
|||
if (ioptname == SO_LINGER)
|
||||
{
|
||||
#ifdef HAVE_STRUCT_LINGER
|
||||
struct linger *ling = (struct linger *) optval;
|
||||
struct linger *ling = (struct linger *) &optval;
|
||||
|
||||
return scm_cons (scm_from_long (ling->l_onoff),
|
||||
scm_from_long (ling->l_linger));
|
||||
#else
|
||||
return scm_cons (scm_from_long (*(int *) optval),
|
||||
return scm_cons (scm_from_long (*(int *) &optval),
|
||||
scm_from_int (0));
|
||||
#endif
|
||||
}
|
||||
|
|
@ -563,10 +589,10 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
|
|||
#endif
|
||||
)
|
||||
{
|
||||
return scm_from_size_t (*(size_t *) optval);
|
||||
return scm_from_size_t (*(size_t *) &optval);
|
||||
}
|
||||
}
|
||||
return scm_from_int (*(int *) optval);
|
||||
return scm_from_int (*(int *) &optval);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -1011,12 +1037,11 @@ SCM_DEFINE (scm_listen, "listen", 2, 0, 0,
|
|||
|
||||
/* Put the components of a sockaddr into a new SCM vector. */
|
||||
static SCM_C_INLINE_KEYWORD SCM
|
||||
_scm_from_sockaddr (const struct sockaddr *address, unsigned addr_size,
|
||||
const char *proc)
|
||||
_scm_from_sockaddr (const scm_t_max_sockaddr *address, unsigned addr_size,
|
||||
const char *proc)
|
||||
{
|
||||
short int fam = address->sa_family;
|
||||
SCM result =SCM_EOL;
|
||||
|
||||
SCM result = SCM_EOL;
|
||||
short int fam = ((struct sockaddr *) address)->sa_family;
|
||||
|
||||
switch (fam)
|
||||
{
|
||||
|
|
@ -1083,7 +1108,8 @@ _scm_from_sockaddr (const struct sockaddr *address, unsigned addr_size,
|
|||
SCM
|
||||
scm_from_sockaddr (const struct sockaddr *address, unsigned addr_size)
|
||||
{
|
||||
return (_scm_from_sockaddr (address, addr_size, "scm_from_sockaddr"));
|
||||
return (_scm_from_sockaddr ((scm_t_max_sockaddr *) address,
|
||||
addr_size, "scm_from_sockaddr"));
|
||||
}
|
||||
|
||||
/* Convert ADDRESS, an address object returned by either
|
||||
|
|
@ -1262,38 +1288,23 @@ SCM_DEFINE (scm_make_socket_address, "make-socket-address", 2, 0, 1,
|
|||
"@code{connect} for details).")
|
||||
#define FUNC_NAME s_scm_make_socket_address
|
||||
{
|
||||
SCM result = SCM_BOOL_F;
|
||||
struct sockaddr *c_address;
|
||||
size_t c_address_size;
|
||||
|
||||
c_address = scm_c_make_socket_address (family, address, args,
|
||||
&c_address_size);
|
||||
if (!c_address)
|
||||
return SCM_BOOL_F;
|
||||
if (c_address != NULL)
|
||||
{
|
||||
result = scm_from_sockaddr (c_address, c_address_size);
|
||||
free (c_address);
|
||||
}
|
||||
|
||||
return (scm_from_sockaddr (c_address, c_address_size));
|
||||
return result;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
/* calculate the size of a buffer large enough to hold any supported
|
||||
sockaddr type. if the buffer isn't large enough, certain system
|
||||
calls will return a truncated address. */
|
||||
|
||||
#if defined (HAVE_UNIX_DOMAIN_SOCKETS)
|
||||
#define MAX_SIZE_UN sizeof (struct sockaddr_un)
|
||||
#else
|
||||
#define MAX_SIZE_UN 0
|
||||
#endif
|
||||
|
||||
#if defined (HAVE_IPV6)
|
||||
#define MAX_SIZE_IN6 sizeof (struct sockaddr_in6)
|
||||
#else
|
||||
#define MAX_SIZE_IN6 0
|
||||
#endif
|
||||
|
||||
#define MAX_ADDR_SIZE max (max (sizeof (struct sockaddr_in), MAX_SIZE_IN6),\
|
||||
MAX_SIZE_UN)
|
||||
|
||||
SCM_DEFINE (scm_accept, "accept", 1, 0, 0,
|
||||
(SCM sock),
|
||||
"Accept a connection on a bound, listening socket.\n"
|
||||
|
|
@ -1315,17 +1326,18 @@ SCM_DEFINE (scm_accept, "accept", 1, 0, 0,
|
|||
SCM address;
|
||||
SCM newsock;
|
||||
socklen_t addr_size = MAX_ADDR_SIZE;
|
||||
char max_addr[MAX_ADDR_SIZE];
|
||||
struct sockaddr *addr = (struct sockaddr *) max_addr;
|
||||
scm_t_max_sockaddr addr;
|
||||
|
||||
sock = SCM_COERCE_OUTPORT (sock);
|
||||
SCM_VALIDATE_OPFPORT (1, sock);
|
||||
fd = SCM_FPORT_FDES (sock);
|
||||
newfd = accept (fd, addr, &addr_size);
|
||||
newfd = accept (fd, (struct sockaddr *) &addr, &addr_size);
|
||||
if (newfd == -1)
|
||||
SCM_SYSERROR;
|
||||
newsock = SCM_SOCK_FD_TO_PORT (newfd);
|
||||
address = _scm_from_sockaddr (addr, addr_size, FUNC_NAME);
|
||||
address = _scm_from_sockaddr (&addr, addr_size,
|
||||
FUNC_NAME);
|
||||
|
||||
return scm_cons (newsock, address);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
|
@ -1339,15 +1351,15 @@ SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0,
|
|||
{
|
||||
int fd;
|
||||
socklen_t addr_size = MAX_ADDR_SIZE;
|
||||
char max_addr[MAX_ADDR_SIZE];
|
||||
struct sockaddr *addr = (struct sockaddr *) max_addr;
|
||||
scm_t_max_sockaddr addr;
|
||||
|
||||
sock = SCM_COERCE_OUTPORT (sock);
|
||||
SCM_VALIDATE_OPFPORT (1, sock);
|
||||
fd = SCM_FPORT_FDES (sock);
|
||||
if (getsockname (fd, addr, &addr_size) == -1)
|
||||
if (getsockname (fd, (struct sockaddr *) &addr, &addr_size) == -1)
|
||||
SCM_SYSERROR;
|
||||
return _scm_from_sockaddr (addr, addr_size, FUNC_NAME);
|
||||
|
||||
return _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -1361,15 +1373,15 @@ SCM_DEFINE (scm_getpeername, "getpeername", 1, 0, 0,
|
|||
{
|
||||
int fd;
|
||||
socklen_t addr_size = MAX_ADDR_SIZE;
|
||||
char max_addr[MAX_ADDR_SIZE];
|
||||
struct sockaddr *addr = (struct sockaddr *) max_addr;
|
||||
scm_t_max_sockaddr addr;
|
||||
|
||||
sock = SCM_COERCE_OUTPORT (sock);
|
||||
SCM_VALIDATE_OPFPORT (1, sock);
|
||||
fd = SCM_FPORT_FDES (sock);
|
||||
if (getpeername (fd, addr, &addr_size) == -1)
|
||||
if (getpeername (fd, (struct sockaddr *) &addr, &addr_size) == -1)
|
||||
SCM_SYSERROR;
|
||||
return _scm_from_sockaddr (addr, addr_size, FUNC_NAME);
|
||||
|
||||
return _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -1505,8 +1517,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0,
|
|||
size_t cend;
|
||||
SCM address;
|
||||
socklen_t addr_size = MAX_ADDR_SIZE;
|
||||
char max_addr[MAX_ADDR_SIZE];
|
||||
struct sockaddr *addr = (struct sockaddr *) max_addr;
|
||||
scm_t_max_sockaddr addr;
|
||||
|
||||
SCM_VALIDATE_OPFPORT (1, sock);
|
||||
fd = SCM_FPORT_FDES (sock);
|
||||
|
|
@ -1523,20 +1534,21 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0,
|
|||
/* recvfrom will not necessarily return an address. usually nothing
|
||||
is returned for stream sockets. */
|
||||
buf = scm_i_string_writable_chars (str);
|
||||
addr->sa_family = AF_UNSPEC;
|
||||
((struct sockaddr *) &addr)->sa_family = AF_UNSPEC;
|
||||
SCM_SYSCALL (rv = recvfrom (fd, buf + offset,
|
||||
cend - offset, flg,
|
||||
addr, &addr_size));
|
||||
(struct sockaddr *) &addr, &addr_size));
|
||||
scm_i_string_stop_writing ();
|
||||
|
||||
if (rv == -1)
|
||||
SCM_SYSERROR;
|
||||
if (addr->sa_family != AF_UNSPEC)
|
||||
address = _scm_from_sockaddr (addr, addr_size, FUNC_NAME);
|
||||
if (((struct sockaddr *) &addr)->sa_family != AF_UNSPEC)
|
||||
address = _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
|
||||
else
|
||||
address = SCM_BOOL_F;
|
||||
|
||||
scm_remember_upto_here_1 (str);
|
||||
|
||||
return scm_cons (scm_from_int (rv), address);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
/* srfi-14.c --- SRFI-14 procedures for Guile
|
||||
*
|
||||
* Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc.
|
||||
* Copyright (C) 2001, 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
|
||||
|
|
@ -22,8 +22,6 @@
|
|||
#endif
|
||||
|
||||
|
||||
#define _GNU_SOURCE /* Ask for `isblank ()'. */
|
||||
|
||||
#include <string.h>
|
||||
#include <ctype.h>
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 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
|
||||
|
|
@ -32,6 +32,9 @@
|
|||
hard coding __hpux. */
|
||||
|
||||
#define _GNU_SOURCE /* ask glibc for everything, in particular strptime */
|
||||
#ifndef _REENTRANT
|
||||
# define _REENTRANT /* ask solaris for gmtime_r prototype */
|
||||
#endif
|
||||
#ifdef __hpux
|
||||
#define _POSIX_C_SOURCE 199506L /* for gmtime_r prototype */
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -487,20 +487,18 @@ do_thread_exit (void *v)
|
|||
static void
|
||||
on_thread_exit (void *v)
|
||||
{
|
||||
/* This handler is executed in non-guile mode. */
|
||||
scm_i_thread *t = (scm_i_thread *)v, **tp;
|
||||
|
||||
scm_i_pthread_setspecific (scm_i_thread_key, v);
|
||||
|
||||
/* Unblocking the joining threads needs to happen in guile mode
|
||||
since the queue is a SCM data structure.
|
||||
*/
|
||||
since the queue is a SCM data structure. */
|
||||
scm_with_guile (do_thread_exit, v);
|
||||
|
||||
/* Removing ourself from the list of all threads needs to happen in
|
||||
non-guile mode since all SCM values on our stack become
|
||||
unprotected once we are no longer in the list.
|
||||
*/
|
||||
scm_leave_guile ();
|
||||
unprotected once we are no longer in the list. */
|
||||
scm_i_pthread_mutex_lock (&thread_admin_mutex);
|
||||
for (tp = &all_threads; *tp; tp = &(*tp)->next_thread)
|
||||
if (*tp == t)
|
||||
|
|
|
|||
|
|
@ -99,6 +99,7 @@ SCM_API void scm_i_mark_weak_vector (SCM w);
|
|||
SCM_API int scm_i_mark_weak_vectors_non_weaks (void);
|
||||
SCM_API void scm_i_remove_weaks_from_weak_vectors (void);
|
||||
|
||||
|
||||
#endif /* SCM_WEAKS_H */
|
||||
|
||||
/*
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue