mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-22 03:30:22 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
Conflicts:
	configure.ac
	libguile/deprecated.c
	libguile/deprecated.h
	libguile/filesys.h
	libguile/fluids.c
	libguile/fports.c
	libguile/gc.c
	libguile/guile.c
	libguile/numbers.c
	libguile/objcodes.c
	libguile/r6rs-ports.c
	libguile/smob.c
	libguile/socket.c
	libguile/threads.h
	module/language/scheme/decompile-tree-il.scm
	module/language/tree-il/peval.scm
	test-suite/tests/syncase.test
This commit is contained in:
Mark H Weaver 2013-03-28 05:09:53 -04:00
commit 26d148066f
523 changed files with 10485 additions and 3954 deletions
Download patch file Download diff file Expand all files Collapse all files

26
libguile/Makefile.am
View file

@ -93,7 +93,7 @@ guile_filter_doc_snarfage_SOURCES = c-tokenize.c
c-tokenize.$(OBJEXT): c-tokenize.c
$(AM_V_GEN) \
if [ "$(cross_compiling)" = "yes" ]; then \
$(CC_FOR_BUILD) -c -o $@ $<; \
$(CC_FOR_BUILD) -I$(top_builddir) -c -o $@ $<; \
else \
$(COMPILE) -c -o $@ $<; \
fi
@ -436,12 +436,16 @@ BUILT_SOURCES = cpp-E.c cpp-SIG.c libpath.h \
scmconfig.h \
$(DOT_I_FILES) $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
# Force the generation of `guile-procedures.texi' because the top-level
# Makefile expects it to be built.
all-local: guile-procedures.texi
EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = _scm.h \
memmove.c strerror.c \
dynl.c regex-posix.c \
posix.c net_db.c socket.c \
debug-malloc.c mkstemp.c \
win32-uname.c win32-socket.c \
win32-uname.c \
locale-categories.h
## delete guile-snarf.awk from the installation bindir, in case it's
@ -458,7 +462,7 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
elf.h \
srfi-14.i.c \
quicksort.i.c \
win32-uname.h win32-socket.h \
win32-uname.h \
private-gc.h private-options.h
# vm instructions
@ -723,25 +727,9 @@ guile.texi: $(alldotdocfiles) guile$(EXEEXT)
guile-procedures.texi: $(alldotdocfiles) guile$(EXEEXT)
$(AM_V_GEN)$(dotdoc2texi) > $@ || { rm $@; false; }
if HAVE_MAKEINFO
guile-procedures.txt: guile-procedures.texi
rm -f $@
makeinfo --force -o $@ guile-procedures.texi || test -f $@
else
guile-procedures.txt: guile-procedures.texi
cp guile-procedures.texi $@
endif
c-tokenize.c: c-tokenize.lex
flex -t $(srcdir)/c-tokenize.lex > $@ || { rm $@; false; }
schemelibdir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)
schemelib_DATA = guile-procedures.txt
## Add -MG to make the .x magic work with auto-dep code.
MKDEP = gcc -M -MG $(DEFS) $(AM_CPPFLAGS) $(CPPFLAGS) $(CFLAGS)

2
libguile/__scm.h
View file

@ -371,7 +371,7 @@
#ifdef LONG_BIT
# define SCM_LONG_BIT LONG_BIT
#else
# define SCM_LONG_BIT (SCM_CHAR_BIT * sizeof (long) / sizeof (char))
# define SCM_LONG_BIT (SCM_SIZEOF_LONG * 8)
#endif
#define SCM_I_UTYPE_MAX(type) ((type)-1)

7
libguile/bdw-gc.h
View file

@ -1,7 +1,7 @@
#ifndef SCM_BDW_GC_H
#define SCM_BDW_GC_H
/* Copyright (C) 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 2006, 2008, 2009, 2011, 2012, 2013 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 License
@ -37,6 +37,11 @@
routines. */
# define GC_NO_THREAD_REDIRECTS 1
#ifdef __MINGW32__
/* Rely on pthreads-w32. */
#define GC_WIN32_PTHREADS
#endif
#endif
#include <gc/gc.h>

3
libguile/c-tokenize.lex
View file

@ -14,7 +14,8 @@ FLOQUAL (f|F|l|L)
INTQUAL (l|L|ll|LL|lL|Ll|u|U)
%{
#include <config.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>

8
libguile/debug.c
View file

@ -202,10 +202,14 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
SCM
scm_local_eval (SCM exp, SCM env)
{
static SCM local_eval_var = SCM_BOOL_F;
static SCM local_eval_var = SCM_UNDEFINED;
static scm_i_pthread_mutex_t local_eval_var_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER;
if (scm_is_false (local_eval_var))
scm_i_scm_pthread_mutex_lock (&local_eval_var_mutex);
if (SCM_UNBNDP (local_eval_var))
local_eval_var = scm_c_public_variable ("ice-9 local-eval", "local-eval");
scm_i_pthread_mutex_unlock (&local_eval_var_mutex);
return scm_call_2 (SCM_VARIABLE_REF (local_eval_var), exp, env);
}

17
libguile/error.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2004, 2006, 2010,
* 2012 Free Software Foundation, Inc.
* 2012, 2013 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 License
@ -100,17 +100,6 @@ SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0,
}
#undef FUNC_NAME
#if defined __MINGW32__ && defined HAVE_NETWORKING
# include "win32-socket.h"
# define SCM_I_STRERROR(err) \
((err >= WSABASEERR) ? scm_i_socket_strerror (err) : strerror (err))
# define SCM_I_ERRNO() \
(errno ? errno : scm_i_socket_errno ())
#else
# define SCM_I_STRERROR(err) strerror (err)
# define SCM_I_ERRNO() errno
#endif /* __MINGW32__ */
/* strerror may not be thread safe, for instance in glibc (version 2.3.2) an
error number not among the known values results in a string like "Unknown
error 9999" formed in a static buffer, which will be overwritten by a
@ -136,7 +125,7 @@ SCM_DEFINE (scm_strerror, "strerror", 1, 0, 0,
scm_dynwind_begin (0);
scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
ret = scm_from_locale_string (SCM_I_STRERROR (scm_to_int (err)));
ret = scm_from_locale_string (strerror (scm_to_int (err)));
scm_dynwind_end ();
return ret;
@ -147,7 +136,7 @@ SCM_GLOBAL_SYMBOL (scm_system_error_key, "system-error");
void
scm_syserror (const char *subr)
{
SCM err = scm_from_int (SCM_I_ERRNO ());
SCM err = scm_from_int (errno);
/* It could be that we're getting here because the syscall was
interrupted by a signal. In that case a signal handler might have

252
libguile/filesys.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004, 2006,
* 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
* 2009, 2010, 2011, 2012, 2013 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 License
@ -45,7 +45,6 @@
#include "libguile/feature.h"
#include "libguile/fports.h"
#include "libguile/private-gc.h" /* for SCM_MAX */
#include "libguile/iselect.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/dynwind.h"
@ -81,9 +80,7 @@
#include <libc.h>
#endif
#ifdef HAVE_SYS_SELECT_H
#include <sys/select.h>
#endif
#ifdef HAVE_STRING_H
#include <string.h>
@ -101,6 +98,18 @@
#define NAMLEN(dirent) strlen ((dirent)->d_name)
#ifdef HAVE_SYS_SENDFILE_H
# include <sys/sendfile.h>
#endif
/* Glibc's `sendfile' function. */
#define sendfile_or_sendfile64 \
CHOOSE_LARGEFILE (sendfile, sendfile64)
#include <full-read.h>
#include <full-write.h>
/* Some more definitions for the native Windows port. */
#ifdef __MINGW32__
# define fsync(fd) _commit (fd)
@ -435,30 +444,17 @@ scm_stat2scm (struct stat_or_stat64 *stat_temp)
return ans;
}
#ifdef __MINGW32__
/*
* Try getting the appropiate stat buffer for a given file descriptor
* under Windows. It differentiates between file, pipe and socket
* descriptors.
*/
static int fstat_Win32 (int fdes, struct stat *buf)
static int
is_file_name_separator (SCM c)
{
int error, optlen = sizeof (int);
memset (buf, 0, sizeof (struct stat));
/* Is this a socket ? */
if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0)
{
buf->st_mode = _S_IREAD | _S_IWRITE | _S_IEXEC;
buf->st_nlink = 1;
buf->st_atime = buf->st_ctime = buf->st_mtime = time (NULL);
return 0;
}
/* Maybe a regular file or pipe ? */
return fstat (fdes, buf);
if (scm_is_eq (c, SCM_MAKE_CHAR ('/')))
return 1;
#ifdef __MINGW32__
if (scm_is_eq (c, SCM_MAKE_CHAR ('\\')))
return 1;
#endif
return 0;
}
#endif /* __MINGW32__ */
SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
(SCM object, SCM exception_on_error),
@ -532,21 +528,11 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
if (scm_is_integer (object))
{
#ifdef __MINGW32__
SCM_SYSCALL (rv = fstat_Win32 (scm_to_int (object), &stat_temp));
#else
SCM_SYSCALL (rv = fstat_or_fstat64 (scm_to_int (object), &stat_temp));
#endif
}
else if (scm_is_string (object))
{
char *file = scm_to_locale_string (object);
#ifdef __MINGW32__
char *p;
p = file + strlen (file) - 1;
while (p > file && (*p == '/' || *p == '\\'))
*p-- = '\0';
#endif
SCM_SYSCALL (rv = stat_or_stat64 (file, &stat_temp));
free (file);
}
@ -555,11 +541,7 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
object = SCM_COERCE_OUTPORT (object);
SCM_VALIDATE_OPFPORT (1, object);
fdes = SCM_FPORT_FDES (object);
#ifdef __MINGW32__
SCM_SYSCALL (rv = fstat_Win32 (fdes, &stat_temp));
#else
SCM_SYSCALL (rv = fstat_or_fstat64 (fdes, &stat_temp));
#endif
}
if (rv == -1)
@ -653,15 +635,13 @@ SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0,
#ifdef HAVE_SELECT
/* check that element is a port or file descriptor. if it's a port
and its buffer is ready for use, add it to the ports_ready list.
otherwise add its file descriptor to *set. the type of list can be
determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
SCM_ARG3 for excepts. */
static int
set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos)
set_element (fd_set *set, SCM *ports_ready, SCM element, int pos)
{
int fd;
@ -707,7 +687,7 @@ set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos)
determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
SCM_ARG3 for excepts. */
static int
fill_select_type (SELECT_TYPE *set, SCM *ports_ready, SCM list_or_vec, int pos)
fill_select_type (fd_set *set, SCM *ports_ready, SCM list_or_vec, int pos)
{
int max_fd = 0;
@ -742,7 +722,7 @@ fill_select_type (SELECT_TYPE *set, SCM *ports_ready, SCM list_or_vec, int pos)
/* if element (a file descriptor or port) appears in *set, cons it to
list. return list. */
static SCM
get_element (SELECT_TYPE *set, SCM element, SCM list)
get_element (fd_set *set, SCM element, SCM list)
{
int fd;
@ -768,7 +748,7 @@ get_element (SELECT_TYPE *set, SCM element, SCM list)
*set and appending them to ports_ready. result is converted to a
vector if list_or_vec is a vector. */
static SCM
retrieve_select_type (SELECT_TYPE *set, SCM ports_ready, SCM list_or_vec)
retrieve_select_type (fd_set *set, SCM ports_ready, SCM list_or_vec)
{
SCM answer_list = ports_ready;
@ -829,9 +809,9 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
{
struct timeval timeout;
struct timeval * time_ptr;
SELECT_TYPE read_set;
SELECT_TYPE write_set;
SELECT_TYPE except_set;
fd_set read_set;
fd_set write_set;
fd_set except_set;
int read_count;
int write_count;
int except_count;
@ -922,9 +902,9 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
}
{
int rv = scm_std_select (max_fd + 1,
&read_set, &write_set, &except_set,
time_ptr);
int rv = select (max_fd + 1,
&read_set, &write_set, &except_set,
time_ptr);
if (rv < 0)
SCM_SYSERROR;
}
@ -933,7 +913,6 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
retrieve_select_type (&except_set, SCM_EOL, excepts));
}
#undef FUNC_NAME
#endif /* HAVE_SELECT */
@ -1095,15 +1074,11 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0,
c_newfile = scm_to_locale_string (newfile);
scm_dynwind_free (c_newfile);
oldfd = open_or_open64 (c_oldfile, O_RDONLY);
oldfd = open_or_open64 (c_oldfile, O_RDONLY | O_BINARY);
if (oldfd == -1)
SCM_SYSERROR;
#ifdef __MINGW32__
SCM_SYSCALL (rv = fstat_Win32 (oldfd, &oldstat));
#else
SCM_SYSCALL (rv = fstat_or_fstat64 (oldfd, &oldstat));
#endif
if (rv == -1)
goto err_close_oldfd;
@ -1133,6 +1108,90 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0,
(SCM out, SCM in, SCM count, SCM offset),
"Send @var{count} bytes from @var{in} to @var{out}, both of which "
"are either open file ports or file descriptors. When "
"@var{offset} is omitted, start reading from @var{in}'s current "
"position; otherwise, start reading at @var{offset}.")
#define FUNC_NAME s_scm_sendfile
{
#define VALIDATE_FD_OR_PORT(cvar, svar, pos) \
if (scm_is_integer (svar)) \
cvar = scm_to_int (svar); \
else \
{ \
SCM_VALIDATE_OPFPORT (pos, svar); \
scm_flush (svar); \
cvar = SCM_FPORT_FDES (svar); \
}
size_t c_count;
scm_t_off c_offset;
ssize_t result;
int in_fd, out_fd;
VALIDATE_FD_OR_PORT (out_fd, out, 1);
VALIDATE_FD_OR_PORT (in_fd, in, 2);
c_count = scm_to_size_t (count);
c_offset = SCM_UNBNDP (offset) ? 0 : scm_to_off_t (offset);
#if defined HAVE_SYS_SENDFILE_H && defined HAVE_SENDFILE
/* The Linux-style sendfile(2), which is different from the BSD-style. */
result = sendfile_or_sendfile64 (out_fd, in_fd,
SCM_UNBNDP (offset) ? NULL : &c_offset,
c_count);
/* Quoting the Linux man page: "In Linux kernels before 2.6.33, out_fd
must refer to a socket. Since Linux 2.6.33 it can be any file."
Fall back to read(2) and write(2) when such an error occurs. */
if (result < 0 && errno != EINVAL && errno != ENOSYS)
SCM_SYSERROR;
else if (result < 0)
#endif
{
char buf[8192];
size_t result, left;
if (!SCM_UNBNDP (offset))
{
if (SCM_PORTP (in))
scm_seek (in, offset, scm_from_int (SEEK_SET));
else
{
if (lseek_or_lseek64 (in_fd, c_offset, SEEK_SET) < 0)
SCM_SYSERROR;
}
}
for (result = 0, left = c_count; result < c_count; )
{
size_t asked, obtained;
asked = SCM_MIN (sizeof buf, left);
obtained = full_read (in_fd, buf, asked);
if (obtained < asked)
SCM_SYSERROR;
left -= obtained;
obtained = full_write (out_fd, buf, asked);
if (obtained < asked)
SCM_SYSERROR;
result += obtained;
}
return scm_from_size_t (result);
}
return scm_from_ssize_t (result);
#undef VALIDATE_FD_OR_PORT
}
#undef FUNC_NAME
#endif /* HAVE_POSIX */
@ -1434,6 +1493,24 @@ SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0,
SCM scm_dot_string;
#ifdef __MINGW32__
SCM_SYMBOL (sym_file_name_convention, "windows");
#else
SCM_SYMBOL (sym_file_name_convention, "posix");
#endif
SCM_INTERNAL SCM scm_system_file_name_convention (void);
SCM_DEFINE (scm_system_file_name_convention,
"system-file-name-convention", 0, 0, 0, (void),
"Return either @code{posix} or @code{windows}, depending on\n"
"what kind of system this Guile is running on.")
#define FUNC_NAME s_scm_system_file_name_convention
{
return sym_file_name_convention;
}
#undef FUNC_NAME
SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0,
(SCM filename),
"Return the directory name component of the file name\n"
@ -1449,32 +1526,17 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0,
len = scm_i_string_length (filename);
i = len - 1;
#ifdef __MINGW32__
while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
|| scm_i_string_ref (filename, i) == '\\'))
while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
while (i >= 0 && (scm_i_string_ref (filename, i) != '/'
&& scm_i_string_ref (filename, i) != '\\'))
while (i >= 0 && !is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
|| scm_i_string_ref (filename, i) == '\\'))
while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
#else
while (i >= 0 && scm_i_string_ref (filename, i) == '/')
--i;
while (i >= 0 && scm_i_string_ref (filename, i) != '/')
--i;
while (i >= 0 && scm_i_string_ref (filename, i) == '/')
--i;
#endif /* ndef __MINGW32__ */
if (i < 0)
{
#ifdef __MINGW32__
if (len > 0 && (scm_i_string_ref (filename, 0) == '/'
|| scm_i_string_ref (filename, 0) == '\\'))
#else
if (len > 0 && scm_i_string_ref (filename, 0) == '/')
#endif /* ndef __MINGW32__ */
if (len > 0 && is_file_name_separator (scm_c_string_ref (filename, 0)))
return scm_c_substring (filename, 0, 1);
else
return scm_dot_string;
@ -1505,14 +1567,8 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
j = scm_i_string_length (suffix) - 1;
}
i = len - 1;
#ifdef __MINGW32__
while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
|| scm_i_string_ref (filename, i) == '\\'))
while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
#else
while (i >= 0 && scm_i_string_ref (filename, i) == '/')
--i;
#endif /* ndef __MINGW32__ */
end = i;
while (i >= 0 && j >= 0
&& (scm_i_string_ref (filename, i)
@ -1523,22 +1579,11 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
}
if (j == -1)
end = i;
#ifdef __MINGW32__
while (i >= 0 && (scm_i_string_ref (filename, i) != '/'
&& scm_i_string_ref (filename, i) != '\\'))
while (i >= 0 && !is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
#else
while (i >= 0 && scm_i_string_ref (filename, i) != '/')
--i;
#endif /* ndef __MINGW32__ */
if (i == end)
{
#ifdef __MINGW32__
if (len > 0 && (scm_i_string_ref (filename, 0) == '/'
|| scm_i_string_ref (filename, 0) == '\\'))
#else
if (len > 0 && scm_i_string_ref (filename, 0) == '/')
#endif /* ndef __MINGW32__ */
if (len > 0 && is_file_name_separator (scm_c_string_ref (filename, 0)))
return scm_c_substring (filename, 0, 1);
else
return scm_dot_string;
@ -1605,14 +1650,7 @@ scm_i_relativize_path (SCM path, SCM in_path)
will be delimited by single delimiters. When DIR does not
have a trailing delimiter, add one to the length to strip
off the delimiter within SCANON. */
if (
#ifdef __MINGW32__
(scm_i_string_ref (dir, len - 1) != '/'
&& scm_i_string_ref (dir, len - 1) != '\\')
#else
scm_i_string_ref (dir, len - 1) != '/'
#endif
)
if (!is_file_name_separator (scm_c_string_ref (dir, len - 1)))
len++;
if (scm_c_string_length (scanon) > len)

4
libguile/filesys.h
View file

@ -3,7 +3,8 @@
#ifndef SCM_FILESYS_H
#define SCM_FILESYS_H
/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
/* Copyright (C) 1995, 1997, 1998, 1999, 2000, 2001, 2006, 2008, 2009,
* 2010, 2011, 2013 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 License
@ -66,6 +67,7 @@ SCM_API SCM scm_copy_file (SCM oldfile, SCM newfile);
SCM_API SCM scm_dirname (SCM filename);
SCM_API SCM scm_basename (SCM filename, SCM suffix);
SCM_API SCM scm_canonicalize_path (SCM path);
SCM_API SCM scm_sendfile (SCM out, SCM in, SCM count, SCM offset);
SCM_INTERNAL SCM scm_i_relativize_path (SCM path, SCM in_path);
SCM_INTERNAL void scm_init_filesys (void);

11
libguile/fluids.c
View file

@ -1,4 +1,5 @@
/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010,
* 2011, 2012, 2013 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 License
@ -304,22 +305,24 @@ apply_thunk (void *thunk)
size_t
scm_prepare_fluids (size_t n, SCM *fluids, SCM *values)
{
size_t j = n;
size_t j;
/* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
but N will usually be small, so perhaps that's OK. */
while (j--)
for (j = n; j--;)
{
size_t i;
if (SCM_UNLIKELY (!IS_FLUID (fluids[j])))
scm_wrong_type_arg ("with-fluids", 0, fluids[j]);
for (i = 0; i < j; i++)
for (i = j; i--;)
if (scm_is_eq (fluids[i], fluids[j]))
{
values[i] = values[j]; /* later bindings win */
n--;
fluids[j] = fluids[n];
values[j] = values[n];
break;
}
}

113
libguile/foreign.c
View file

@ -770,37 +770,40 @@ SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0,
/* Pre-generate trampolines for less than 10 arguments. */
#ifdef WORDS_BIGENDIAN
#define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40
#define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
#define OBJCODE_HEADER(M) M (0), M (0), M (0), M (8), M (0), M (0), M (0), M (40)
#define META_HEADER(M) M (0), M (0), M (0), M (32), M (0), M (0), M (0), M (0)
#else
#define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
#define OBJCODE_HEADER(M) M (8), M (0), M (0), M (0), M (40), M (0), M (0), M (0)
#define META_HEADER(M) M (32), M (0), M (0), M (0), M (0), M (0), M (0), M (0)
#endif
#define CODE(nreq) \
OBJCODE_HEADER, \
/* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \
/* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function pointer */ \
/* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well) */ \
/* 7 */ scm_op_nop, \
/* 8 */ META (3, 7, nreq)
#define GEN_CODE(M, nreq) \
OBJCODE_HEADER (M), \
/* 0 */ M (scm_op_assert_nargs_ee), M (0), M (nreq), /* assert number of args */ \
/* 3 */ M (scm_op_object_ref), M (0), /* push the pair with the cif and the function pointer */ \
/* 5 */ M (scm_op_foreign_call), M (nreq), /* and call (will return value as well) */ \
/* 7 */ M (scm_op_nop), \
/* 8 */ META (M, 3, 7, nreq)
#define META(start, end, nreq) \
META_HEADER, \
/* 0 */ scm_op_make_eol, /* bindings */ \
/* 1 */ scm_op_make_eol, /* sources */ \
/* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
/* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \
/* 8 */ scm_op_list, 0, 3, /* make a list of those 3 vals */ \
/* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
/* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
/* 22 */ scm_op_object_ref, 1, /* the name from the object table */ \
/* 24 */ scm_op_cons, /* make a pair for the properties */ \
/* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
/* 28 */ scm_op_return, /* and return */ \
/* 29 */ scm_op_nop, scm_op_nop, scm_op_nop \
#define META(M, start, end, nreq) \
META_HEADER (M), \
/* 0 */ M (scm_op_make_eol), /* bindings */ \
/* 1 */ M (scm_op_make_eol), /* sources */ \
/* 2 */ M (scm_op_make_int8), M (start), M (scm_op_make_int8), M (end), /* arity: from ip N to ip N */ \
/* 6 */ M (scm_op_make_int8), M (nreq), /* the arity is N required args */ \
/* 8 */ M (scm_op_list), M (0), M (3), /* make a list of those 3 vals */ \
/* 11 */ M (scm_op_list), M (0), M (1), /* and the arities will be a list of that one list */ \
/* 14 */ M (scm_op_load_symbol), M (0), M (0), M (4), M ('n'), M ('a'), M ('M'), M ('e'), /* `name' */ \
/* 22 */ M (scm_op_object_ref), M (1), /* the name from the object table */ \
/* 24 */ M (scm_op_cons), /* make a pair for the properties */ \
/* 25 */ M (scm_op_list), M (0), M (4), /* pack bindings, sources, and arities into list */ \
/* 28 */ M (scm_op_return), /* and return */ \
/* 29 */ M (scm_op_nop), M (scm_op_nop), M (scm_op_nop) \
/* 32 */
#define M_STATIC(x) (x)
#define CODE(nreq) GEN_CODE (M_STATIC, nreq)
static const struct
{
scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
@ -814,8 +817,28 @@ static const struct
}
};
#undef CODE
static SCM
make_objcode_trampoline (unsigned int nargs)
{
const int size = sizeof (struct scm_objcode) + 8
+ sizeof (struct scm_objcode) + 32;
SCM bytecode = scm_c_make_bytevector (size);
scm_t_uint8 *bytes = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bytecode);
int i = 0;
#define M_DYNAMIC(x) (bytes[i++] = (x))
GEN_CODE (M_DYNAMIC, nargs);
#undef M_DYNAMIC
if (i != size)
scm_syserror ("make_objcode_trampoline");
return scm_bytecode_to_objcode (bytecode, SCM_UNDEFINED);
}
#undef GEN_CODE
#undef META
#undef M_STATIC
#undef CODE
#undef OBJCODE_HEADER
#undef META_HEADER
@ -878,21 +901,43 @@ static const SCM objcode_trampolines[10] = {
SCM_PACK (objcode_cells.cells+18),
};
static SCM large_objcode_trampolines = SCM_UNDEFINED;
static scm_i_pthread_mutex_t large_objcode_trampolines_mutex =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
static SCM
get_objcode_trampoline (unsigned int nargs)
{
SCM objcode;
if (nargs < 10)
objcode = objcode_trampolines[nargs];
else if (nargs < 128)
{
scm_i_scm_pthread_mutex_lock (&large_objcode_trampolines_mutex);
if (SCM_UNBNDP (large_objcode_trampolines))
large_objcode_trampolines = scm_c_make_vector (128, SCM_UNDEFINED);
objcode = scm_c_vector_ref (large_objcode_trampolines, nargs);
if (SCM_UNBNDP (objcode))
scm_c_vector_set_x (large_objcode_trampolines, nargs,
objcode = make_objcode_trampoline (nargs));
scm_i_pthread_mutex_unlock (&large_objcode_trampolines_mutex);
}
else
scm_misc_error ("make-foreign-function", "args >= 128 currently unimplemented",
SCM_EOL);
return objcode;
}
static SCM
cif_to_procedure (SCM cif, SCM func_ptr)
{
ffi_cif *c_cif;
unsigned int nargs;
SCM objcode, table, ret;
c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
nargs = c_cif->nargs;
if (nargs < 10)
objcode = objcode_trampolines[nargs];
else
scm_misc_error ("make-foreign-function", "args >= 10 currently unimplemented",
SCM_EOL);
objcode = get_objcode_trampoline (c_cif->nargs);
table = scm_c_make_vector (2, SCM_UNDEFINED);
SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr));

143
libguile/fports.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
* 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
* 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 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 License
@ -28,15 +28,6 @@
#include <stdio.h>
#include <fcntl.h>
#include "libguile/_scm.h"
#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libguile/gc.h"
#include "libguile/posix.h"
#include "libguile/dynwind.h"
#include "libguile/hashtab.h"
#include "libguile/fports.h"
#ifdef HAVE_STRING_H
#include <string.h>
@ -50,36 +41,23 @@
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
#include <sys/stat.h>
#endif
#ifdef HAVE_POLL_H
#include <poll.h>
#endif
#include <errno.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <sys/select.h>
#include <full-write.h>
#include "libguile/iselect.h"
#include "libguile/_scm.h"
#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libguile/gc.h"
#include "libguile/posix.h"
#include "libguile/dynwind.h"
#include "libguile/hashtab.h"
/* Some defines for Windows (native port, not Cygwin). */
#ifdef __MINGW32__
# include <sys/stat.h>
# include <winsock2.h>
#endif /* __MINGW32__ */
#include <full-write.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 defined HAVE_CHSIZE && ! defined HAVE_FTRUNCATE
# define ftruncate(fd, size) chsize (fd, size)
# undef HAVE_FTRUNCATE
# define HAVE_FTRUNCATE 1
#endif
#include "libguile/fports.h"
#if SIZEOF_OFF_T == SIZEOF_INT
#define OFF_T_MAX INT_MAX
@ -496,48 +474,6 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
#undef FUNC_NAME
#ifdef __MINGW32__
/*
* Try getting the appropiate file flags for a given file descriptor
* under Windows. This incorporates some fancy operations because Windows
* differentiates between file, pipe and socket descriptors.
*/
#ifndef O_ACCMODE
# define O_ACCMODE 0x0003
#endif
static int getflags (int fdes)
{
int flags = 0;
struct stat buf;
int error, optlen = sizeof (int);
/* Is this a socket ? */
if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0)
flags = O_RDWR;
/* Maybe a regular file ? */
else if (fstat (fdes, &buf) < 0)
flags = -1;
else
{
/* Or an anonymous pipe handle ? */
if (buf.st_mode & _S_IFIFO)
flags = PeekNamedPipe ((HANDLE) _get_osfhandle (fdes), NULL, 0,
NULL, NULL, NULL) ? O_RDONLY : O_WRONLY;
/* stdin ? */
else if (fdes == fileno (stdin) && isatty (fdes))
flags = O_RDONLY;
/* stdout / stderr ? */
else if ((fdes == fileno (stdout) || fdes == fileno (stderr)) &&
isatty (fdes))
flags = O_WRONLY;
else
flags = buf.st_mode;
}
return flags;
}
#endif /* __MINGW32__ */
/* Building Guile ports from a file descriptor. */
/* Build a Scheme port from an open file descriptor `fdes'.
@ -551,14 +487,10 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
{
SCM port;
scm_t_fport *fp;
int flags;
/* test that fdes is valid. */
#ifdef __MINGW32__
flags = getflags (fdes);
#else
flags = fcntl (fdes, F_GETFL, 0);
#endif
/* Test that fdes is valid. */
#ifdef F_GETFL
int flags = fcntl (fdes, F_GETFL, 0);
if (flags == -1)
SCM_SYSERROR;
flags &= O_ACCMODE;
@ -568,6 +500,13 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
{
SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
}
#else
/* If we don't have F_GETFL, as on mingw, at least we can test that
it is a valid file descriptor. */
struct stat st;
if (fstat (fdes, &st) != 0)
SCM_SYSERROR;
#endif
fp = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport),
"file port");
@ -600,52 +539,12 @@ fport_input_waiting (SCM port)
{
int fdes = SCM_FSTREAM (port)->fdes;
/* `FD_SETSIZE', which is 1024 on GNU systems, effectively limits the
highest numerical value of file descriptors that can be monitored.
Thus, use poll(2) whenever that is possible. */
#ifdef HAVE_POLL
struct pollfd pollfd = { fdes, POLLIN, 0 };
if (poll (&pollfd, 1, 0) < 0)
scm_syserror ("fport_input_waiting");
return pollfd.revents & POLLIN ? 1 : 0;
#elif defined(HAVE_SELECT)
struct timeval timeout;
SELECT_TYPE read_set;
SELECT_TYPE write_set;
SELECT_TYPE except_set;
FD_ZERO (&read_set);
FD_ZERO (&write_set);
FD_ZERO (&except_set);
FD_SET (fdes, &read_set);
timeout.tv_sec = 0;
timeout.tv_usec = 0;
if (select (SELECT_SET_SIZE,
&read_set, &write_set, &except_set, &timeout)
< 0)
scm_syserror ("fport_input_waiting");
return FD_ISSET (fdes, &read_set) ? 1 : 0;
#elif HAVE_IOCTL && defined (FIONREAD)
/* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
(for use with winsock ioctlsocket()) but not ioctl(). */
int fdes = SCM_FSTREAM (port)->fdes;
int remir;
ioctl(fdes, FIONREAD, &remir);
return remir;
#else
scm_misc_error ("fport_input_waiting",
"Not fully implemented on this platform",
SCM_EOL);
#endif
}

16
libguile/gc.c
View file

@ -1,4 +1,5 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006,
* 2008, 2009, 2010, 2011, 2012, 2013 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 License
@ -281,7 +282,13 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
GC_get_heap_usage_safe (&heap_size, &free_bytes, &unmapped_bytes,
&bytes_since_gc, &total_bytes);
#ifdef HAVE_GC_GET_GC_NO
/* This function was added in 7.2alpha2 (June 2009). */
gc_times = GC_get_gc_no ();
#else
/* This symbol is deprecated as of 7.3. */
gc_times = GC_gc_no;
#endif
answer =
scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)),
@ -582,7 +589,14 @@ scm_getenv_int (const char *var, int def)
void
scm_storage_prehistory ()
{
#ifdef HAVE_GC_SET_ALL_INTERIOR_POINTERS
/* This function was added in 7.2alpha2 (June 2009). */
GC_set_all_interior_pointers (0);
#else
/* This symbol is deprecated in 7.3. */
GC_all_interior_pointers = 0;
#endif
free_space_divisor = scm_getenv_int ("GC_FREE_SPACE_DIVISOR", 3);
minimum_free_space_divisor = free_space_divisor;
target_free_space_divisor = free_space_divisor;

8
libguile/guardians.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1998,1999,2000,2001, 2006, 2008, 2009, 2011,
* 2012 Free Software Foundation, Inc.
* 2012, 2013 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 License
@ -355,7 +355,13 @@ void
scm_init_guardians ()
{
/* We use unordered finalization `a la Java. */
#ifdef HAVE_GC_SET_JAVA_FINALIZATION
/* This function was added in 7.2alpha2 (June 2009). */
GC_set_java_finalization (1);
#else
/* This symbol is deprecated as of 7.3. */
GC_java_finalization = 1;
#endif
tc16_guardian = scm_make_smob_type ("guardian", 0);

36
libguile/guile.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1996, 1997, 2000, 2001, 2006, 2008,
* 2011 Free Software Foundation, Inc.
* 2011, 2013 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 License
@ -66,15 +66,41 @@ inner_main (void *closure SCM_UNUSED, int argc, char **argv)
#endif /* __MINGW32__ */
}
static int
get_integer_from_environment (const char *var, int def)
{
char *end = 0;
char *val = getenv (var);
long res = def;
if (!val)
return def;
res = strtol (val, &end, 10);
if (end == val)
{
fprintf (stderr, "guile: warning: invalid %s: %s\n", var, val);
return def;
}
return res;
}
static int
should_install_locale (void)
{
/* If the GUILE_INSTALL_LOCALE environment variable is unset,
or set to a nonzero value, we should install the locale via
setlocale(). */
return get_integer_from_environment ("GUILE_INSTALL_LOCALE", 1);
}
int
main (int argc, char **argv)
{
/* Install the locale right at the beginning so that string conversion
for command-line arguments, along with possible error messages, use
the right locale. See
/* If we should install a locale, do it right at the beginning so that
string conversion for command-line arguments, along with possible
error messages, use the right locale. See
<https://lists.gnu.org/archive/html/guile-devel/2011-11/msg00041.html>
for the rationale. */
if (setlocale (LC_ALL, "") == NULL)
if (should_install_locale () && setlocale (LC_ALL, "") == NULL)
fprintf (stderr, "guile: warning: failed to install locale\n");
scm_install_gmp_memory_functions = 1;

4
libguile/i18n.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 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 License
@ -685,6 +685,8 @@ SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
}
}
/* silence gcc's unused variable warning */
(void) c_base_locale;
#endif
return locale;

3
libguile/init.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
* 2004, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
* 2004, 2006, 2009, 2010, 2011, 2012, 2013 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 License
@ -75,7 +75,6 @@
#include "libguile/gettext.h"
#include "libguile/i18n.h"
#include "libguile/instructions.h"
#include "libguile/iselect.h"
#include "libguile/ioext.h"
#include "libguile/keywords.h"
#include "libguile/list.h"

36
libguile/iselect.h
View file

@ -3,7 +3,8 @@
#ifndef SCM_ISELECT_H
#define SCM_ISELECT_H
/* Copyright (C) 1997,1998,2000,2001, 2002, 2006 Free Software Foundation, Inc.
/* Copyright (C) 1997,1998,2000,2001, 2002, 2006,
* 2013 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 License
@ -29,36 +30,19 @@
#include <sys/types.h>
#if SCM_HAVE_SYS_SELECT_H
# include <sys/select.h>
#endif
#if SCM_HAVE_WINSOCK2_H
# include <winsock2.h>
#endif
#ifdef FD_SET
#define SELECT_TYPE fd_set
#define SELECT_SET_SIZE FD_SETSIZE
#else /* no FD_SET */
/* Define the macros to access a single-int bitmap of descriptors. */
#define SELECT_SET_SIZE 32
#define SELECT_TYPE int
#define FD_SET(n, p) (*(p) |= (1 << (n)))
#define FD_CLR(n, p) (*(p) &= ~(1 << (n)))
#define FD_ISSET(n, p) (*(p) & (1 << (n)))
#define FD_ZERO(p) (*(p) = 0)
#endif /* no FD_SET */
#include <sys/select.h>
SCM_API int scm_std_select (int fds,
SELECT_TYPE *rfds,
SELECT_TYPE *wfds,
SELECT_TYPE *efds,
fd_set *rfds,
fd_set *wfds,
fd_set *efds,
struct timeval *timeout);
#define SELECT_TYPE fd_set
#endif /* SCM_HAVE_SYS_SELECT_H */
#endif /* SCM_ISELECT_H */
/*

2
libguile/list.c
View file

@ -377,8 +377,6 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0,
SCM_VALIDATE_LIST (1, lst);
if (SCM_UNBNDP (new_tail))
new_tail = SCM_EOL;
else
SCM_VALIDATE_LIST (2, new_tail);
while (!SCM_NULL_OR_NIL_P (lst))
{

127
libguile/load.c
View file

@ -198,6 +198,19 @@ SCM_DEFINE (scm_sys_global_site_dir, "%global-site-dir", 0,0,0,
#undef FUNC_NAME
#endif /* SCM_GLOBAL_SITE_DIR */
#ifdef SCM_SITE_CCACHE_DIR
SCM_DEFINE (scm_sys_site_ccache_dir, "%site-ccache-dir", 0,0,0,
(),
"Return the directory where users should install compiled\n"
"@code{.go} files for use with this version of Guile.\n\n"
"E.g., may return \"/usr/lib/guile/" SCM_EFFECTIVE_VERSION "/site-ccache\".")
#define FUNC_NAME s_scm_sys_site_ccache_dir
{
return scm_from_locale_string (SCM_SITE_CCACHE_DIR);
}
#undef FUNC_NAME
#endif /* SCM_SITE_CCACHE_DIR */
/* Initializing the load path, and searching it. */
@ -447,6 +460,60 @@ scm_c_string_has_an_ext (char *str, size_t len, SCM extensions)
return 0;
}
#ifdef __MINGW32__
#define FILE_NAME_SEPARATOR_STRING "\\"
#else
#define FILE_NAME_SEPARATOR_STRING "/"
#endif
static int
is_file_name_separator (SCM c)
{
if (scm_is_eq (c, SCM_MAKE_CHAR ('/')))
return 1;
#ifdef __MINGW32__
if (scm_is_eq (c, SCM_MAKE_CHAR ('\\')))
return 1;
#endif
return 0;
}
static int
is_drive_letter (SCM c)
{
#ifdef __MINGW32__
if (SCM_CHAR (c) >= 'a' && SCM_CHAR (c) <= 'z')
return 1;
else if (SCM_CHAR (c) >= 'A' && SCM_CHAR (c) <= 'Z')
return 1;
#endif
return 0;
}
static int
is_absolute_file_name (SCM filename)
{
size_t filename_len = scm_c_string_length (filename);
if (filename_len >= 1
&& is_file_name_separator (scm_c_string_ref (filename, 0))
#ifdef __MINGW32__
/* On Windows, one initial separator indicates a drive-relative
path. Two separators indicate a Universal Naming Convention
(UNC) path. UNC paths are always absolute. */
&& filename_len >= 2
&& is_file_name_separator (scm_c_string_ref (filename, 1))
#endif
)
return 1;
if (filename_len >= 3
&& is_drive_letter (scm_c_string_ref (filename, 0))
&& scm_is_eq (scm_c_string_ref (filename, 1), SCM_MAKE_CHAR (':'))
&& is_file_name_separator (scm_c_string_ref (filename, 2)))
return 1;
return 0;
}
/* Search PATH for a directory containing a file named FILENAME.
The file must be readable, and not a directory.
If we find one, return its full pathname; otherwise, return #f.
@ -477,16 +544,7 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts,
scm_dynwind_free (filename_chars);
/* If FILENAME is absolute and is still valid, return it unchanged. */
#ifdef __MINGW32__
if (((filename_len >= 1) &&
(filename_chars[0] == '/' || filename_chars[0] == '\\')) ||
((filename_len >= 3) && filename_chars[1] == ':' &&
((filename_chars[0] >= 'a' && filename_chars[0] <= 'z') ||
(filename_chars[0] >= 'A' && filename_chars[0] <= 'Z')) &&
(filename_chars[2] == '/' || filename_chars[2] == '\\')))
#else
if (filename_len >= 1 && filename_chars[0] == '/')
#endif
if (is_absolute_file_name (filename))
{
if ((scm_is_false (require_exts) ||
scm_c_string_has_an_ext (filename_chars, filename_len,
@ -520,11 +578,7 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts,
extensions = SCM_EOL;
break;
}
#ifdef __MINGW32__
else if (*endp == '/' || *endp == '\\')
#else
else if (*endp == '/')
#endif
else if (is_file_name_separator (SCM_MAKE_CHAR (*endp)))
/* This filename has no extension, so keep the current list
of extensions. */
break;
@ -553,12 +607,9 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts,
/* Concatenate the path name and the filename. */
#ifdef __MINGW32__
if ((buf.ptr > buf.buf) && (buf.ptr[-1] != '/') && (buf.ptr[-1] != '\\'))
#else
if ((buf.ptr > buf.buf) && (buf.ptr[-1] != '/'))
#endif
stringbuf_cat (&buf, "/");
if (buf.ptr > buf.buf
&& !is_file_name_separator (SCM_MAKE_CHAR (buf.ptr[-1])))
stringbuf_cat (&buf, FILE_NAME_SEPARATOR_STRING);
stringbuf_cat (&buf, filename_chars);
sans_ext_len = buf.ptr - buf.buf;
@ -823,24 +874,36 @@ scm_try_auto_compile (SCM source)
NULL, NULL);
}
/* See also (system base compile):compiled-file-name. */
/* The auto-compilation code will residualize a .go file in the cache
dir: by default, $HOME/.cache/guile/2.0/ccache/PATH.go. This
function determines the PATH to use as a key into the compilation
cache. See also (system base compile):compiled-file-name. */
static SCM
canonical_suffix (SCM fname)
{
SCM canon;
size_t len;
/* CANON should be absolute. */
canon = scm_canonicalize_path (fname);
len = scm_c_string_length (canon);
if (len > 1 && scm_is_eq (scm_c_string_ref (canon, 0), SCM_MAKE_CHAR ('/')))
return canon;
else if (len > 2 && scm_is_eq (scm_c_string_ref (canon, 1), SCM_MAKE_CHAR (':')))
return scm_string_append (scm_list_3 (scm_from_latin1_string ("/"),
scm_c_substring (canon, 0, 1),
scm_c_substring (canon, 2, len)));
else
return canon;
#ifdef __MINGW32__
{
size_t len = scm_c_string_length (canon);
/* On Windows, an absolute file name that doesn't start with a
separator starts with a drive component. Transform the drive
component to a file name element: c:\foo -> \c\foo. */
if (len >= 2
&& is_absolute_file_name (canon)
&& !is_file_name_separator (scm_c_string_ref (canon, 0)))
return scm_string_append
(scm_list_3 (scm_from_latin1_string (FILE_NAME_SEPARATOR_STRING),
scm_c_substring (canon, 0, 1),
scm_c_substring (canon, 2, len)));
}
#endif
return canon;
}
SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,

3
libguile/load.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_LOAD_H
#define SCM_LOAD_H
/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009, 2010, 2011, 2013 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 License
@ -34,6 +34,7 @@ SCM_API SCM scm_sys_package_data_dir (void);
SCM_API SCM scm_sys_library_dir (void);
SCM_API SCM scm_sys_site_dir (void);
SCM_API SCM scm_sys_global_site_dir (void);
SCM_API SCM scm_sys_site_ccache_dir (void);
SCM_API SCM scm_search_path (SCM path, SCM filename, SCM rest);
SCM_API SCM scm_sys_search_load_path (SCM filename);
SCM_API SCM scm_primitive_load_path (SCM filename_and_exception_on_not_found);

25
libguile/memoize.c
View file

@ -284,14 +284,33 @@ memoize (SCM exp, SCM env)
memoize (REF (exp, SEQ, TAIL), env));
case SCM_EXPANDED_LAMBDA:
/* The body will be a lambda-case. */
/* The body will be a lambda-case or #f. */
{
SCM meta, docstring, proc;
SCM meta, docstring, body, proc;
meta = REF (exp, LAMBDA, META);
docstring = scm_assoc_ref (meta, scm_sym_documentation);
proc = memoize (REF (exp, LAMBDA, BODY), env);
body = REF (exp, LAMBDA, BODY);
if (scm_is_false (body))
/* Give a body to case-lambda with no clauses. */
proc = MAKMEMO_LAMBDA
(MAKMEMO_CALL
(MAKMEMO_MOD_REF (list_of_guile,
scm_from_latin1_symbol ("throw"),
SCM_BOOL_F),
5,
scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key),
MAKMEMO_QUOTE (SCM_BOOL_F),
MAKMEMO_QUOTE (scm_from_latin1_string
("Wrong number of arguments")),
MAKMEMO_QUOTE (SCM_EOL),
MAKMEMO_QUOTE (SCM_BOOL_F))),
FIXED_ARITY (0),
SCM_BOOL_F /* docstring */);
else
proc = memoize (body, env);
if (scm_is_string (docstring))
{
SCM args = SCM_MEMOIZED_ARGS (proc);

4
libguile/mkstemp.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1991, 1992, 1996, 1998, 2001, 2006 Free Software Foundation, Inc.
/* Copyright (C) 1991, 1992, 1996, 1998, 2001, 2006, 2013 Free Software Foundation, Inc.
This file is derived from mkstemps.c from the GNU Libiberty Library
which in turn is derived from the GNU C Library.
@ -112,7 +112,7 @@ mkstemp (template)
v /= 62;
XXXXXX[5] = letters[v % 62];
fd = open (template, O_RDWR|O_CREAT|O_EXCL, 0600);
fd = open (template, O_RDWR|O_CREAT|O_EXCL|O_BINARY, 0600);
if (fd >= 0)
/* The file does not exist. */
return fd;

58
libguile/net_db.c
View file

@ -1,6 +1,6 @@
/* "net_db.c" network database support
* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2006, 2009,
* 2010, 2011, 2012 Free Software Foundation, Inc.
* 2010, 2011, 2012, 2013 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 License
@ -34,6 +34,17 @@
#include <verify.h>
#include <errno.h>
#ifdef HAVE_STRING_H
#include <string.h>
#endif
#include <sys/types.h>
#include <sys/socket.h>
#include <netdb.h>
#include <netinet/in.h>
#include <arpa/inet.h>
#include "libguile/_scm.h"
#include "libguile/feature.h"
#include "libguile/strings.h"
@ -44,38 +55,15 @@
#include "libguile/net_db.h"
#include "libguile/socket.h"
#ifdef HAVE_STRING_H
#include <string.h>
#endif
#include <sys/types.h>
#if defined (HAVE_H_ERRNO)
/* Only wrap gethostbyname / gethostbyaddr if h_errno is available. */
#ifdef HAVE_WINSOCK2_H
#include <winsock2.h>
#else
#include <sys/socket.h>
#include <netdb.h>
#include <netinet/in.h>
#include <arpa/inet.h>
#endif
#ifdef __MINGW32__
#include "win32-socket.h"
#endif
#if !defined (HAVE_H_ERRNO) && !defined (__MINGW32__) && !defined (__CYGWIN__)
/* h_errno not found in netdb.h, maybe this will help. */
extern int h_errno;
#endif
#if defined HAVE_HSTRERROR && !HAVE_DECL_HSTRERROR \
&& !defined __MINGW32__ && !defined __CYGWIN__
#if defined HAVE_HSTRERROR && !HAVE_DECL_HSTRERROR
/* Some OSes, such as Tru64 5.1b, lack a declaration for hstrerror(3). */
extern const char *hstrerror (int);
#endif
SCM_SYMBOL (scm_host_not_found_key, "host-not-found");
SCM_SYMBOL (scm_try_again_key, "try-again");
SCM_SYMBOL (scm_no_recovery_key, "no-recovery");
@ -204,6 +192,8 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0,
}
#undef FUNC_NAME
#endif /* HAVE_H_ERRNO */
/* In all subsequent getMUMBLE functions, when we're called with no
arguments, we're supposed to traverse the tables entry by entry.
@ -267,7 +257,7 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0,
#undef FUNC_NAME
#endif
#if defined (HAVE_GETPROTOENT) || defined (__MINGW32__)
#if defined (HAVE_GETPROTOENT)
SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0,
(SCM protocol),
"@deffnx {Scheme Procedure} getprotobyname name\n"
@ -318,7 +308,7 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0,
#undef FUNC_NAME
#endif
#if defined (HAVE_GETSERVENT) || defined (__MINGW32__)
#if defined (HAVE_GETSERVENT)
static SCM
scm_return_entry (struct servent *entry)
{
@ -420,7 +410,7 @@ SCM_DEFINE (scm_setnet, "setnet", 0, 1, 0,
#undef FUNC_NAME
#endif
#if defined (HAVE_SETPROTOENT) && defined (HAVE_ENDPROTOENT) || defined (__MINGW32__)
#if defined (HAVE_SETPROTOENT) && defined (HAVE_ENDPROTOENT)
SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0,
(SCM stayopen),
"If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}.\n"
@ -436,7 +426,7 @@ SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0,
#undef FUNC_NAME
#endif
#if defined (HAVE_SETSERVENT) && defined (HAVE_ENDSERVENT) || defined (__MINGW32__)
#if defined (HAVE_SETSERVENT) && defined (HAVE_ENDSERVENT)
SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0,
(SCM stayopen),
"If @var{stayopen} is omitted, this is equivalent to @code{endservent}.\n"
@ -605,8 +595,10 @@ SCM_DEFINE (scm_getaddrinfo, "getaddrinfo", 1, 5, 0,
"@item EAI_SOCKTYPE\n"
"@var{hint_socktype} was not recognized.\n\n"
"@item EAI_SYSTEM\n"
"A system error occurred; the error code can be found in "
"@code{errno}.\n"
"A system error occurred. In C, the error code can be found in "
"@code{errno}; this value is not accessible from Scheme, but in\n"
"practice it provides little information about the actual error "
"cause.\n\n" /* see <http://bugs.gnu.org/13958>. */
"@end table\n"
"\n"
"Users are encouraged to read the "

1660
libguile/numbers.c
View file

File diff suppressed because it is too large Load diff

3
libguile/numbers.h
View file

@ -205,7 +205,8 @@ SCM_API SCM scm_logbit_p (SCM n1, SCM n2);
SCM_API SCM scm_lognot (SCM n);
SCM_API SCM scm_modulo_expt (SCM n, SCM k, SCM m);
SCM_API SCM scm_integer_expt (SCM z1, SCM z2);
SCM_API SCM scm_ash (SCM n, SCM cnt);
SCM_API SCM scm_ash (SCM n, SCM count);
SCM_API SCM scm_round_ash (SCM n, SCM count);
SCM_API SCM scm_bit_extract (SCM n, SCM start, SCM end);
SCM_API SCM scm_logcount (SCM n);
SCM_API SCM scm_integer_length (SCM n);

5
libguile/objcodes.c
View file

@ -1,4 +1,5 @@
/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 2001, 2009, 2010, 2011, 2012
* 2013 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 License
@ -576,7 +577,7 @@ SCM_DEFINE (scm_load_thunk_from_file, "load-thunk-from-file", 1, 0, 0,
SCM_VALIDATE_STRING (1, filename);
c_filename = scm_to_locale_string (filename);
fd = open (c_filename, O_RDONLY | O_CLOEXEC);
fd = open (c_filename, O_RDONLY | O_BINARY | O_CLOEXEC);
free (c_filename);
if (fd < 0) SCM_SYSERROR;

15
libguile/poll.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2010 Free Software Foundation, Inc.
/* Copyright (C) 2010, 2013 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 License
@ -25,6 +25,8 @@
# include <config.h>
#endif
#include <poll.h>
#include "libguile/_scm.h"
#include "libguile/bytevectors.h"
#include "libguile/numbers.h"
@ -33,11 +35,6 @@
#include "libguile/poll.h"
#ifdef HAVE_POLL_H
#include <poll.h>
#endif
/* {Poll}
@ -73,7 +70,6 @@
If timeout is given and is non-negative, the poll will return after that
number of milliseconds if no fd became active.
*/
#ifdef HAVE_POLL
static SCM
scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout)
#define FUNC_NAME "primitive-poll"
@ -174,7 +170,6 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout)
return scm_from_int (rv);
}
#undef FUNC_NAME
#endif /* HAVE_POLL */
@ -182,12 +177,8 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout)
static void
scm_init_poll (void)
{
#if HAVE_POLL
scm_c_define_gsubr ("primitive-poll", 4, 0, 0, scm_primitive_poll);
scm_c_define ("%sizeof-struct-pollfd", scm_from_size_t (sizeof (struct pollfd)));
#else
scm_misc_error ("%init-poll", "`poll' unavailable on this platform", SCM_EOL);
#endif
#ifdef POLLIN
scm_c_define ("POLLIN", scm_from_int (POLLIN));

10
libguile/ports.c
View file

@ -383,10 +383,14 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
SCM
scm_current_warning_port (void)
{
static SCM cwp_var = SCM_BOOL_F;
static SCM cwp_var = SCM_UNDEFINED;
static scm_i_pthread_mutex_t cwp_var_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER;
if (scm_is_false (cwp_var))
cwp_var = scm_c_private_lookup ("guile", "current-warning-port");
scm_i_scm_pthread_mutex_lock (&cwp_var_mutex);
if (SCM_UNBNDP (cwp_var))
cwp_var = scm_c_private_variable ("guile", "current-warning-port");
scm_i_pthread_mutex_unlock (&cwp_var_mutex);
return scm_call_0 (scm_variable_ref (cwp_var));
}

108
libguile/posix.c
View file

@ -32,23 +32,6 @@
# include <sched.h>
#endif
#include "libguile/_scm.h"
#include "libguile/dynwind.h"
#include "libguile/fports.h"
#include "libguile/scmsigs.h"
#include "libguile/feature.h"
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/srfi-14.h"
#include "libguile/vectors.h"
#include "libguile/values.h"
#include "libguile/validate.h"
#include "libguile/posix.h"
#include "libguile/gettext.h"
#include "libguile/threads.h"
#ifdef HAVE_STRING_H
#include <string.h>
#endif
@ -65,10 +48,6 @@
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#else
#ifndef ttyname
extern char *ttyname();
#endif
#endif
#ifdef LIBC_H_WITH_UNISTD_H
@ -85,15 +64,23 @@ extern char *ttyname();
#ifdef HAVE_IO_H
#include <io.h>
#endif
#ifdef HAVE_WINSOCK2_H
#include <winsock2.h>
#endif
#ifdef __MINGW32__
/* Some defines for Windows here. */
# include <process.h>
# define pipe(fd) _pipe (fd, 256, O_BINARY)
#endif /* __MINGW32__ */
#include "libguile/_scm.h"
#include "libguile/dynwind.h"
#include "libguile/fports.h"
#include "libguile/scmsigs.h"
#include "libguile/feature.h"
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/srfi-14.h"
#include "libguile/vectors.h"
#include "libguile/values.h"
#include "libguile/validate.h"
#include "libguile/posix.h"
#include "libguile/gettext.h"
#include "libguile/threads.h"
#if HAVE_SYS_WAIT_H
# include <sys/wait.h>
@ -168,6 +155,13 @@ extern char *ttyname();
int sethostname (char *name, size_t namelen);
#endif
#if defined HAVE_GETLOGIN && !HAVE_DECL_GETLOGIN
/* MinGW doesn't supply this decl; see
http://lists.gnu.org/archive/html/bug-gnulib/2013-03/msg00030.html for more
details. */
char *getlogin (void);
#endif
/* On NextStep, <utime.h> doesn't define struct utime, unless we
#define _POSIX_SOURCE before #including it. I think this is less
of a kludge than defining struct utimbuf ourselves. */
@ -1148,12 +1142,7 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
exec_argv = scm_i_allocate_string_pointers (args);
execv (exec_file,
#ifdef __MINGW32__
/* extra "const" in mingw formals, provokes warning from gcc */
(const char * const *)
#endif
exec_argv);
execv (exec_file, exec_argv);
SCM_SYSERROR;
/* not reached. */
@ -1182,12 +1171,7 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1,
exec_argv = scm_i_allocate_string_pointers (args);
execvp (exec_file,
#ifdef __MINGW32__
/* extra "const" in mingw formals, provokes warning from gcc */
(const char * const *)
#endif
exec_argv);
execvp (exec_file, exec_argv);
SCM_SYSERROR;
/* not reached. */
@ -1221,17 +1205,7 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1,
exec_argv = scm_i_allocate_string_pointers (args);
exec_env = scm_i_allocate_string_pointers (env);
execve (exec_file,
#ifdef __MINGW32__
/* extra "const" in mingw formals, provokes warning from gcc */
(const char * const *)
#endif
exec_argv,
#ifdef __MINGW32__
/* extra "const" in mingw formals, provokes warning from gcc */
(const char * const *)
#endif
exec_env);
execve (exec_file, exec_argv, exec_env);
SCM_SYSERROR;
/* not reached. */
@ -1432,12 +1406,7 @@ scm_open_process (SCM mode, SCM prog, SCM args)
close (err);
}
execvp (exec_file,
#ifdef __MINGW32__
/* extra "const" in mingw formals, provokes warning from gcc */
(const char * const *)
#endif
exec_argv);
execvp (exec_file, exec_argv);
/* The exec failed! There is nothing sensible to do. */
if (err > 0)
@ -1638,6 +1607,12 @@ SCM_DEFINE (scm_utime, "utime", 1, 5, 0,
struct utimbuf utm;
utm.actime = atim_sec;
utm.modtime = mtim_sec;
/* Silence warnings. */
(void) atim_nsec;
(void) mtim_nsec;
if (f != 0)
scm_out_of_range(FUNC_NAME, flags);
STRING_SYSCALL (pathname, c_pathname,
rv = utime (c_pathname, &utm));
@ -1922,22 +1897,6 @@ SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_CHROOT */
#ifdef __MINGW32__
/* Wrapper function to supplying `getlogin()' under Windows. */
static char * getlogin (void)
{
static char user[256];
static unsigned long len = 256;
if (!GetUserName (user, &len))
return NULL;
return user;
}
#endif /* __MINGW32__ */
#if defined (HAVE_GETLOGIN) || defined (__MINGW32__)
SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
(void),
"Return a string containing the name of the user logged in on\n"
@ -1953,7 +1912,6 @@ SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
return scm_from_locale_string (p);
}
#undef FUNC_NAME
#endif /* HAVE_GETLOGIN */
#if HAVE_GETPRIORITY
SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0,

16
libguile/r6rs-ports.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
/* Copyright (C) 2009, 2010, 2011, 2013 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 License
@ -482,7 +482,7 @@ SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0,
if ((c_read == 0) && (c_count > 0))
{
if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
if (scm_peek_byte_or_eof (port) == EOF)
result = SCM_EOF_VAL;
else
result = scm_null_bytevector;
@ -529,7 +529,7 @@ SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0,
if ((c_read == 0) && (c_count > 0))
{
if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
if (scm_peek_byte_or_eof (port) == EOF)
result = SCM_EOF_VAL;
else
result = SCM_I_MAKINUM (0);
@ -577,15 +577,17 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
}
/* We can't use `scm_c_read ()' since it blocks. */
c_chr = scm_getc_unlocked (port);
c_chr = scm_get_byte_or_eof_unlocked (port);
if (c_chr != EOF)
{
c_bv[c_total] = (char) c_chr;
c_total++;
}
}
while ((scm_is_true (scm_char_ready_p (port)))
&& (!SCM_EOF_OBJECT_P (scm_peek_char (port))));
/* XXX: We want to check for the availability of a byte, but that's
what `scm_char_ready_p' actually does. */
while (scm_is_true (scm_char_ready_p (port))
&& (scm_peek_byte_or_eof_unlocked (port) != EOF));
if (c_total == 0)
{
@ -645,7 +647,7 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
c_read = scm_c_read_unlocked (port, c_bv + c_total, c_count);
c_total += c_read, c_count -= c_read;
}
while (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
while (scm_peek_byte_or_eof (port) != EOF);
if (c_total == 0)
{

14
libguile/random.c
View file

@ -1,4 +1,5 @@
/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 2009, 2010 Free Software Foundation, Inc.
/* Copyright (C) 1999, 2000, 2001, 2003, 2005, 2006, 2009, 2010,
* 2012, 2013 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 License
* as published by the Free Software Foundation; either version 3 of
@ -17,7 +18,7 @@
/* Author: Mikael Djurfeldt <djurfeldt@nada.kth.se> */
/* Original Author: Mikael Djurfeldt <djurfeldt@nada.kth.se> */
#ifdef HAVE_CONFIG_H
# include <config.h>
@ -29,6 +30,12 @@
#include <stdio.h>
#include <math.h>
#include <string.h>
#include <sys/types.h>
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#include "libguile/smob.h"
#include "libguile/numbers.h"
#include "libguile/feature.h"
@ -665,7 +672,8 @@ random_state_of_last_resort (void)
SCM time_of_day = scm_gettimeofday ();
SCM sources = scm_list_n
(scm_from_unsigned_integer (SCM_UNPACK (time_of_day)), /* heap addr */
scm_getpid (), /* process ID */
/* Avoid scm_getpid, since it depends on HAVE_POSIX. */
scm_from_unsigned_integer (getpid ()), /* process ID */
scm_get_internal_real_time (), /* high-resolution process timer */
scm_from_unsigned_integer ((scm_t_bits) &time_of_day), /* stack addr */
scm_car (time_of_day), /* seconds since midnight 1970-01-01 UTC */

34
libguile/scmsigs.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007, 2008, 2009, 2011 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007, 2008, 2009, 2011, 2013 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 License
@ -28,17 +28,6 @@
#include <stdio.h>
#include <errno.h>
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/eval.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/threads.h"
#include "libguile/validate.h"
#include "libguile/scmsigs.h"
#ifdef HAVE_PROCESS_H
#include <process.h> /* for mingw */
#endif
@ -51,16 +40,19 @@
#include <sys/time.h>
#endif
#ifdef __MINGW32__
#include <windows.h>
#define alarm(sec) (0)
/* This weird comma expression is because Sleep is void under Windows. */
#define sleep(sec) (Sleep ((sec) * 1000), 0)
#define usleep(usec) (Sleep ((usec) / 1000), 0)
#endif
#include <full-write.h>
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/eval.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/threads.h"
#include "libguile/validate.h"
#include "libguile/scmsigs.h"
@ -526,6 +518,7 @@ SCM_DEFINE (scm_restore_signals, "restore-signals", 0, 0, 0,
}
#undef FUNC_NAME
#if defined HAVE_ALARM && HAVE_DECL_ALARM
SCM_DEFINE (scm_alarm, "alarm", 1, 0, 0,
(SCM i),
"Set a timer to raise a @code{SIGALRM} signal after the specified\n"
@ -541,6 +534,7 @@ SCM_DEFINE (scm_alarm, "alarm", 1, 0, 0,
return scm_from_uint (alarm (scm_to_uint (i)));
}
#undef FUNC_NAME
#endif /* HAVE_ALARM */
#ifdef HAVE_SETITIMER
SCM_DEFINE (scm_setitimer, "setitimer", 5, 0, 0,

49
libguile/smob.c
View file

@ -1,5 +1,6 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
* 2009, 2010, 2011, 2012, 2013 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 License
* as published by the Free Software Foundation; either version 3 of
@ -283,6 +284,10 @@ scm_make_smob (scm_t_bits tc)
/* The GC kind used for SMOB types that provide a custom mark procedure. */
static int smob_gc_kind;
/* Mark stack pointer and limit, used by `scm_gc_mark'. */
static scm_i_pthread_key_t current_mark_stack_pointer;
static scm_i_pthread_key_t current_mark_stack_limit;
/* The generic SMOB mark procedure that gets called for SMOBs allocated
with smob_gc_kind. */
@ -321,14 +326,14 @@ smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
{
SCM obj;
SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit;
scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
scm_i_pthread_setspecific (current_mark_stack_limit, mark_stack_limit);
/* Invoke the SMOB's mark procedure, which will in turn invoke
`scm_gc_mark ()', which may modify `current_mark_stack_ptr'. */
`scm_gc_mark', which may modify `current_mark_stack_pointer'. */
obj = scm_smobs[smobnum].mark (cell);
mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr;
mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
if (SCM_HEAP_OBJECT_P (obj))
/* Mark the returned object. */
@ -336,42 +341,35 @@ smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
mark_stack_ptr,
mark_stack_limit, NULL);
SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL;
SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL;
scm_i_pthread_setspecific (current_mark_stack_pointer, NULL);
scm_i_pthread_setspecific (current_mark_stack_limit, NULL);
}
return mark_stack_ptr;
}
/* Mark object O. We assume that this function is only called during the
mark phase, i.e., from within `smob_mark ()' or one of its
descendents. */
/* Mark object O. We assume that this function is only called during the mark
phase, i.e., from within `smob_mark' or one of its descendants. */
void
scm_gc_mark (SCM o)
{
#define CURRENT_MARK_PTR \
((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr))
#define CURRENT_MARK_LIMIT \
((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit))
if (SCM_HEAP_OBJECT_P (o))
{
/* At this point, the `current_mark_*' fields of the current thread
must be defined (they are set in `smob_mark ()'). */
register struct GC_ms_entry *mark_stack_ptr;
void *mark_stack_ptr, *mark_stack_limit;
if (!CURRENT_MARK_PTR)
mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
mark_stack_limit = scm_i_pthread_getspecific (current_mark_stack_limit);
if (mark_stack_ptr == NULL)
/* The function was not called from a mark procedure. */
abort ();
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
CURRENT_MARK_PTR, CURRENT_MARK_LIMIT,
mark_stack_ptr, mark_stack_limit,
NULL);
SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
}
#undef CURRENT_MARK_PTR
#undef CURRENT_MARK_LIMIT
}
@ -452,6 +450,9 @@ scm_smob_prehistory ()
{
long i;
scm_i_pthread_key_create (&current_mark_stack_pointer, NULL);
scm_i_pthread_key_create (&current_mark_stack_limit, NULL);
smob_gc_kind = GC_new_kind (GC_new_free_list (),
GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
0,

59
libguile/socket.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005,
* 2006, 2007, 2009, 2011, 2012 Free Software Foundation, Inc.
* 2006, 2007, 2009, 2011, 2012, 2013 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 License
@ -25,9 +25,28 @@
#endif
#include <errno.h>
#include <gmp.h>
#include <verify.h>
#ifdef HAVE_STDINT_H
#include <stdint.h>
#endif
#ifdef HAVE_STRING_H
#include <string.h>
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#include <sys/types.h>
#include <sys/socket.h>
#ifdef HAVE_UNIX_DOMAIN_SOCKETS
#include <sys/un.h>
#endif
#include <netinet/in.h>
#include <netdb.h>
#include <arpa/inet.h>
#include <gmp.h>
#include "libguile/_scm.h"
#include "libguile/arrays.h"
#include "libguile/feature.h"
@ -40,32 +59,11 @@
#include "libguile/validate.h"
#include "libguile/socket.h"
#ifdef __MINGW32__
#include "win32-socket.h"
#include <netdb.h>
#if SCM_ENABLE_DEPRECATED == 1
# include "libguile/deprecation.h"
#endif
#ifdef HAVE_STDINT_H
#include <stdint.h>
#endif
#ifdef HAVE_STRING_H
#include <string.h>
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#include <sys/types.h>
#ifdef HAVE_WINSOCK2_H
#include <winsock2.h>
#else
#include <sys/socket.h>
#ifdef HAVE_UNIX_DOMAIN_SOCKETS
#include <sys/un.h>
#endif
#include <netinet/in.h>
#include <netdb.h>
#include <arpa/inet.h>
#endif
#if defined (HAVE_UNIX_DOMAIN_SOCKETS) && !defined (SUN_LEN)
#define SUN_LEN(ptr) ((size_t) (((struct sockaddr_un *) 0)->sun_path) \
@ -512,6 +510,7 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
"@defvarx SO_OOBINLINE\n"
"@defvarx SO_NO_CHECK\n"
"@defvarx SO_PRIORITY\n"
"@defvarx SO_REUSEPORT\n"
"The value returned is an integer.\n"
"@end defvar\n"
"\n"
@ -610,6 +609,7 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0,
"@defvarx SO_OOBINLINE\n"
"@defvarx SO_NO_CHECK\n"
"@defvarx SO_PRIORITY\n"
"@defvarx SO_REUSEPORT\n"
"@var{value} is an integer.\n"
"@end defvar\n"
"\n"
@ -1767,6 +1767,9 @@ scm_init_socket ()
#ifdef SO_LINGER
scm_c_define ("SO_LINGER", scm_from_int (SO_LINGER));
#endif
#ifdef SO_REUSEPORT /* new in Linux 3.9 */
scm_c_define ("SO_REUSEPORT", scm_from_int (SO_REUSEPORT));
#endif
/* recv/send options. */
#ifdef MSG_DONTWAIT
@ -1782,10 +1785,6 @@ scm_init_socket ()
scm_c_define ("MSG_DONTROUTE", scm_from_int (MSG_DONTROUTE));
#endif
#ifdef __MINGW32__
scm_i_init_socket_Win32 ();
#endif
#ifdef IP_ADD_MEMBERSHIP
scm_c_define ("IP_ADD_MEMBERSHIP", scm_from_int (IP_ADD_MEMBERSHIP));
scm_c_define ("IP_DROP_MEMBERSHIP", scm_from_int (IP_DROP_MEMBERSHIP));

8
libguile/srfi-14.i.c
View file

@ -4790,7 +4790,7 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x2090, 0x209c}
,
{0x20a0, 0x20b9}
{0x20a0, 0x20ba}
,
{0x20d0, 0x20f0}
,
@ -5906,7 +5906,7 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x2090, 0x209c}
,
{0x20a0, 0x20b9}
{0x20a0, 0x20ba}
,
{0x20d0, 0x20f0}
,
@ -6897,7 +6897,7 @@ scm_t_char_range cs_symbol_ranges[] = {
,
{0x208a, 0x208c}
,
{0x20a0, 0x20b9}
{0x20a0, 0x20ba}
,
{0x2100, 0x2101}
,
@ -7728,7 +7728,7 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x2090, 0x209c}
,
{0x20a0, 0x20b9}
{0x20a0, 0x20ba}
,
{0x20d0, 0x20f0}
,

9
libguile/stime.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2011 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2011, 2013 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 License
@ -84,13 +84,6 @@
# include <sys/timeb.h>
#endif
#ifndef tzname /* For SGI. */
extern char *tzname[]; /* RS6000 and others reject char **tzname. */
#endif
#if defined (__MINGW32__)
# define tzname _tzname
#endif
#if ! HAVE_DECL_STRPTIME
extern char *strptime ();
#endif

9
libguile/strports.c
View file

@ -464,13 +464,16 @@ SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0,
"procedure returns.")
#define FUNC_NAME s_scm_eval_string_in_module
{
static SCM eval_string = SCM_BOOL_F, k_module = SCM_BOOL_F;
static SCM eval_string = SCM_UNDEFINED, k_module = SCM_UNDEFINED;
static scm_i_pthread_mutex_t init_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
if (scm_is_false (eval_string))
scm_i_scm_pthread_mutex_lock (&init_mutex);
if (SCM_UNBNDP (eval_string))
{
eval_string = scm_c_public_lookup ("ice-9 eval-string", "eval-string");
eval_string = scm_c_public_variable ("ice-9 eval-string", "eval-string");
k_module = scm_from_locale_keyword ("module");
}
scm_i_pthread_mutex_unlock (&init_mutex);
if (SCM_UNBNDP (module))
module = scm_current_module ();

10
libguile/struct.c
View file

@ -1,4 +1,5 @@
/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007,
* 2008, 2009, 2010, 2011, 2012, 2013 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 License
@ -152,8 +153,9 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
#undef FUNC_NAME
/* Check whether VTABLE instances have a simple layout (i.e., either only "pr"
or only "pw" fields) and update its flags accordingly. */
/* Check whether VTABLE instances have a simple layout (i.e., either
only "pr" or only "pw" fields and no tail array) and update its flags
accordingly. */
static void
set_vtable_layout_flags (SCM vtable)
{
@ -179,13 +181,11 @@ set_vtable_layout_flags (SCM vtable)
switch (c_layout[field + 1])
{
case 'w':
case 'W':
if (field == 0)
flags |= SCM_VTABLE_FLAG_SIMPLE_RW;
break;
case 'r':
case 'R':
flags &= ~SCM_VTABLE_FLAG_SIMPLE_RW;
break;

6
libguile/struct.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_STRUCT_H
#define SCM_STRUCT_H
/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 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 License
@ -108,8 +108,8 @@
#define SCM_VTABLE_FLAG_APPLICABLE (1L << 3) /* instances of this vtable are applicable? */
#define SCM_VTABLE_FLAG_SETTER_VTABLE (1L << 4) /* instances of this vtable are applicable-with-setter vtables? */
#define SCM_VTABLE_FLAG_SETTER (1L << 5) /* instances of this vtable are applicable-with-setters? */
#define SCM_VTABLE_FLAG_SIMPLE (1L << 6) /* instances of this vtable have only "p" fields */
#define SCM_VTABLE_FLAG_SIMPLE_RW (1L << 7) /* instances of this vtable have only "pw" fields */
#define SCM_VTABLE_FLAG_SIMPLE (1L << 6) /* instances of this vtable have only "p" fields and no tail array*/
#define SCM_VTABLE_FLAG_SIMPLE_RW (1L << 7) /* instances of this vtable have only "pw" fields and no tail array */
#define SCM_VTABLE_FLAG_RESERVED_0 (1L << 8)
#define SCM_VTABLE_FLAG_RESERVED_1 (1L << 9)
#define SCM_VTABLE_FLAG_RESERVED_2 (1L << 10)

55
libguile/texi-fragments-to-docstrings Normal file
View file

@ -0,0 +1,55 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2013 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
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;
;;; Read Texinfo fragments from stdin (docstrings of Guile's primitives
;;; in the format of `guile-procedures.texi'), and write to stdout a
;;; textual rendering thereof. The output preserves page breaks (^L)
;;; found in the input, as per the Guile Documentation Format
;;; version 2---see (ice-9 documentation).
;;;
(use-modules (texinfo)
(texinfo plain-text)
(srfi srfi-1)
(ice-9 match)
(rnrs io ports))
(define (docstring-fragments->strings str)
"Return the list resulting from the split of STR at each page
break (^L)"
(string-tokenize str (char-set-complement (char-set #\page))))
(match (command-line)
((_ texi-file)
(let* ((fragments (remove (compose string-null? string-trim-both)
(call-with-input-file texi-file
(compose docstring-fragments->strings
get-string-all))))
(stexi (map texi-fragment->stexi fragments)))
(format #t "Produced by GNU Guile ~a from `~a'.~%~%"
(version) texi-file)
(for-each (lambda (stexi)
(display #\page)
(display (stexi->plain-text stexi)))
stexi)))
((command args ...)
(format (current-error-port) "invalid arguments: ~s~%" args)
(format (current-error-port) "Usage: ~a TEXINFO-FILE~%" command)
(exit 1)))

34
libguile/threads.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
* 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
* 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@ -45,6 +45,8 @@
# include <pthread_np.h>
#endif
#include <sys/select.h>
#include <assert.h>
#include <fcntl.h>
#include <nproc.h>
@ -1057,7 +1059,10 @@ SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 1, 1, 0,
errno = err;
scm_syserror (NULL);
}
scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
while (scm_is_false (data.thread))
scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
scm_i_pthread_mutex_unlock (&data.mutex);
return data.thread;
@ -1134,7 +1139,10 @@ scm_spawn_thread (scm_t_catch_body body, void *body_data,
errno = err;
scm_syserror (NULL);
}
scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
while (scm_is_false (data.thread))
scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
scm_i_pthread_mutex_unlock (&data.mutex);
assert (SCM_I_IS_THREAD (data.thread));
@ -1867,9 +1875,9 @@ SCM_DEFINE (scm_condition_variable_p, "condition-variable?", 1, 0, 0,
struct select_args
{
int nfds;
SELECT_TYPE *read_fds;
SELECT_TYPE *write_fds;
SELECT_TYPE *except_fds;
fd_set *read_fds;
fd_set *write_fds;
fd_set *except_fds;
struct timeval *timeout;
int result;
@ -1892,11 +1900,19 @@ do_std_select (void *args)
return NULL;
}
#if !SCM_HAVE_SYS_SELECT_H
static int scm_std_select (int nfds,
fd_set *readfds,
fd_set *writefds,
fd_set *exceptfds,
struct timeval *timeout);
#endif
int
scm_std_select (int nfds,
SELECT_TYPE *readfds,
SELECT_TYPE *writefds,
SELECT_TYPE *exceptfds,
fd_set *readfds,
fd_set *writefds,
fd_set *exceptfds,
struct timeval *timeout)
{
fd_set my_readfds;

7
libguile/threads.h
View file

@ -3,7 +3,8 @@
#ifndef SCM_THREADS_H
#define SCM_THREADS_H
/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006,
* 2007, 2008, 2009, 2011, 2012, 2013 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 License
@ -71,8 +72,8 @@ typedef struct scm_i_thread {
scm_i_pthread_cond_t sleep_cond;
int sleep_fd, sleep_pipe[2];
/* Information about the Boehm-GC mark stack during the mark phase. This
is used by `scm_gc_mark ()'. */
/* XXX: These two fields used to hold information about the BDW-GC
mark stack during the mark phase. They are no longer used. */
void *current_mark_stack_ptr;
void *current_mark_stack_limit;

18
libguile/vm.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 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 License
@ -37,6 +37,8 @@
#include "programs.h"
#include "vm.h"
#include "private-gc.h" /* scm_getenv_int */
static int vm_default_engine = SCM_VM_REGULAR_ENGINE;
/* Unfortunately we can't snarf these: snarfed things are only loaded up from
@ -634,7 +636,17 @@ resolve_variable (SCM what, SCM program_module)
}
}
#define VM_MIN_STACK_SIZE (1024)
#define VM_DEFAULT_STACK_SIZE (64 * 1024)
static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE;
static void
initialize_default_stack_size (void)
{
int size = scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size);
if (size >= VM_MIN_STACK_SIZE)
vm_stack_size = size;
}
#define VM_NAME vm_regular_engine
#define FUNC_NAME "vm-regular-engine"
@ -671,7 +683,7 @@ make_vm (void)
vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
vp->stack_size = VM_DEFAULT_STACK_SIZE;
vp->stack_size= vm_stack_size;
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
vp->stack_base = (SCM *)
@ -1085,6 +1097,8 @@ scm_bootstrap_vm (void)
"scm_init_vm",
(scm_t_extension_init_func)scm_init_vm, NULL);
initialize_default_stack_size ();
sym_vm_run = scm_from_latin1_symbol ("vm-run");
sym_vm_error = scm_from_latin1_symbol ("vm-error");
sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error");

632
libguile/win32-socket.c
View file

@ -1,632 +0,0 @@
/* Copyright (C) 2001, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* 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., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include "libguile/__scm.h"
#include "libguile/modules.h"
#include "libguile/numbers.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <errno.h>
#include <limits.h>
#ifndef PATH_MAX
#define PATH_MAX 255
#endif
#include "win32-socket.h"
/* Winsock API error description structure. The error description is
necessary because there is no error list available. */
typedef struct
{
int error; /* Error code. */
char *str; /* Error description. */
int replace; /* Possible error code replacement. */
char *replace_str; /* Replacement symbol. */
char *correct_str; /* Original symbol. */
}
socket_error_t;
#define FILE_ETC_SERVICES "services"
#define ENVIRON_ETC_SERVICES "SERVICES"
#define FILE_ETC_NETWORKS "networks"
#define ENVIRON_ETC_NETWORKS "NETWORKS"
#define FILE_ETC_PROTOCOLS "protocol"
#define ENVIRON_ETC_PROTOCOLS "PROTOCOLS"
#define MAX_NAMLEN 256
#define MAX_ALIASES 4
/* Internal structure for a thread's M$-Windows servent interface. */
typedef struct
{
FILE *fd; /* Current file. */
char file[PATH_MAX]; /* File name. */
struct servent ent; /* Return value. */
char name[MAX_NAMLEN]; /* Service name. */
char proto[MAX_NAMLEN]; /* Protocol name. */
char alias[MAX_ALIASES][MAX_NAMLEN]; /* All aliases. */
char *aliases[MAX_ALIASES]; /* Alias pointers. */
int port; /* Network port. */
}
scm_i_servent_t;
static scm_i_servent_t scm_i_servent;
/* Internal structure for a thread's M$-Windows protoent interface. */
typedef struct
{
FILE *fd; /* Current file. */
char file[PATH_MAX]; /* File name. */
struct protoent ent; /* Return value. */
char name[MAX_NAMLEN]; /* Protocol name. */
char alias[MAX_ALIASES][MAX_NAMLEN]; /* All aliases. */
char *aliases[MAX_ALIASES]; /* Alias pointers. */
int proto; /* Protocol number. */
}
scm_i_protoent_t;
static scm_i_protoent_t scm_i_protoent;
/* Define replacement symbols for most of the WSA* error codes. */
#ifndef EWOULDBLOCK
# define EWOULDBLOCK WSAEWOULDBLOCK
#endif
#ifndef EINPROGRESS
# define EINPROGRESS WSAEINPROGRESS
#endif
#ifndef EALREADY
# define EALREADY WSAEALREADY
#endif
#ifndef EDESTADDRREQ
# define EDESTADDRREQ WSAEDESTADDRREQ
#endif
#ifndef EMSGSIZE
# define EMSGSIZE WSAEMSGSIZE
#endif
#ifndef EPROTOTYPE
# define EPROTOTYPE WSAEPROTOTYPE
#endif
#ifndef ENOTSOCK
# define ENOTSOCK WSAENOTSOCK
#endif
#ifndef ENOPROTOOPT
# define ENOPROTOOPT WSAENOPROTOOPT
#endif
#ifndef EPROTONOSUPPORT
# define EPROTONOSUPPORT WSAEPROTONOSUPPORT
#endif
#ifndef ESOCKTNOSUPPORT
# define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT
#endif
#ifndef EOPNOTSUPP
# define EOPNOTSUPP WSAEOPNOTSUPP
#endif
#ifndef EPFNOSUPPORT
# define EPFNOSUPPORT WSAEPFNOSUPPORT
#endif
#ifndef EAFNOSUPPORT
# define EAFNOSUPPORT WSAEAFNOSUPPORT
#endif
#ifndef EADDRINUSE
# define EADDRINUSE WSAEADDRINUSE
#endif
#ifndef EADDRNOTAVAIL
# define EADDRNOTAVAIL WSAEADDRNOTAVAIL
#endif
#ifndef ENETDOWN
# define ENETDOWN WSAENETDOWN
#endif
#ifndef ENETUNREACH
# define ENETUNREACH WSAENETUNREACH
#endif
#ifndef ENETRESET
# define ENETRESET WSAENETRESET
#endif
#ifndef ECONNABORTED
# define ECONNABORTED WSAECONNABORTED
#endif
#ifndef ECONNRESET
# define ECONNRESET WSAECONNRESET
#endif
#ifndef ENOBUFS
# define ENOBUFS WSAENOBUFS
#endif
#ifndef EISCONN
# define EISCONN WSAEISCONN
#endif
#ifndef ENOTCONN
# define ENOTCONN WSAENOTCONN
#endif
#ifndef ESHUTDOWN
# define ESHUTDOWN WSAESHUTDOWN
#endif
#ifndef ETOOMANYREFS
# define ETOOMANYREFS WSAETOOMANYREFS
#endif
#ifndef ETIMEDOUT
# define ETIMEDOUT WSAETIMEDOUT
#endif
#ifndef ECONNREFUSED
# define ECONNREFUSED WSAECONNREFUSED
#endif
#ifndef ELOOP
# define ELOOP WSAELOOP
#endif
#ifndef EHOSTDOWN
# define EHOSTDOWN WSAEHOSTDOWN
#endif
#ifndef EHOSTUNREACH
# define EHOSTUNREACH WSAEHOSTUNREACH
#endif
#ifndef EPROCLIM
# define EPROCLIM WSAEPROCLIM
#endif
#ifndef EUSERS
# define EUSERS WSAEUSERS
#endif
#ifndef EDQUOT
# define EDQUOT WSAEDQUOT
#endif
#ifndef ESTALE
# define ESTALE WSAESTALE
#endif
#ifndef EREMOTE
# define EREMOTE WSAEREMOTE
#endif
/* List of error structures. */
static socket_error_t socket_errno [] = {
/* 000 */ { 0, NULL, 0, NULL, NULL },
/* 001 */ { 0, NULL, 0, NULL, NULL },
/* 002 */ { 0, NULL, 0, NULL, NULL },
/* 003 */ { 0, NULL, 0, NULL, NULL },
/* 004 */ { WSAEINTR, "Interrupted function call", EINTR, NULL, "WSAEINTR" },
/* 005 */ { 0, NULL, 0, NULL, NULL },
/* 006 */ { 0, NULL, 0, NULL, NULL },
/* 007 */ { 0, NULL, 0, NULL, NULL },
/* 008 */ { 0, NULL, 0, NULL, NULL },
/* 009 */ { WSAEBADF, "Bad file number", EBADF, NULL, "WSAEBADF" },
/* 010 */ { 0, NULL, 0, NULL, NULL },
/* 011 */ { 0, NULL, 0, NULL, NULL },
/* 012 */ { 0, NULL, 0, NULL, NULL },
/* 013 */ { WSAEACCES, "Permission denied", EACCES, NULL, "WSAEACCES" },
/* 014 */ { WSAEFAULT, "Bad address", EFAULT, NULL, "WSAEFAULT" },
/* 015 */ { 0, NULL, 0, NULL, NULL },
/* 016 */ { 0, NULL, 0, NULL, NULL },
/* 017 */ { 0, NULL, 0, NULL, NULL },
/* 018 */ { 0, NULL, 0, NULL, NULL },
/* 019 */ { 0, NULL, 0, NULL, NULL },
/* 020 */ { 0, NULL, 0, NULL, NULL },
/* 021 */ { 0, NULL, 0, NULL, NULL },
/* 022 */ { WSAEINVAL, "Invalid argument", EINVAL, NULL, "WSAEINVAL" },
/* 023 */ { 0, NULL, 0, NULL, NULL },
/* 024 */ { WSAEMFILE, "Too many open files", EMFILE, NULL, "WSAEMFILE" },
/* 025 */ { 0, NULL, 0, NULL, NULL },
/* 026 */ { 0, NULL, 0, NULL, NULL },
/* 027 */ { 0, NULL, 0, NULL, NULL },
/* 028 */ { 0, NULL, 0, NULL, NULL },
/* 029 */ { 0, NULL, 0, NULL, NULL },
/* 030 */ { 0, NULL, 0, NULL, NULL },
/* 031 */ { 0, NULL, 0, NULL, NULL },
/* 032 */ { 0, NULL, 0, NULL, NULL },
/* 033 */ { 0, NULL, 0, NULL, NULL },
/* 034 */ { 0, NULL, 0, NULL, NULL },
/* 035 */ { WSAEWOULDBLOCK, "Resource temporarily unavailable",
EWOULDBLOCK, "EWOULDBLOCK", "WSAEWOULDBLOCK" },
/* 036 */ { WSAEINPROGRESS, "Operation now in progress",
EINPROGRESS, "EINPROGRESS", "WSAEINPROGRESS" },
/* 037 */ { WSAEALREADY, "Operation already in progress",
EALREADY, "EALREADY", "WSAEALREADY" },
/* 038 */ { WSAENOTSOCK, "Socket operation on non-socket",
ENOTSOCK, "ENOTSOCK", "WSAENOTSOCK"},
/* 039 */ { WSAEDESTADDRREQ, "Destination address required",
EDESTADDRREQ, "EDESTADDRREQ", "WSAEDESTADDRREQ" },
/* 040 */ { WSAEMSGSIZE, "Message too long",
EMSGSIZE, "EMSGSIZE", "WSAEMSGSIZE" },
/* 041 */ { WSAEPROTOTYPE, "Protocol wrong type for socket",
EPROTOTYPE, "EPROTOTYPE", "WSAEPROTOTYPE" },
/* 042 */ { WSAENOPROTOOPT, "Bad protocol option",
ENOPROTOOPT, "ENOPROTOOPT", "WSAENOPROTOOPT" },
/* 043 */ { WSAEPROTONOSUPPORT, "Protocol not supported",
EPROTONOSUPPORT, "EPROTONOSUPPORT", "WSAEPROTONOSUPPORT" },
/* 044 */ { WSAESOCKTNOSUPPORT, "Socket type not supported",
ESOCKTNOSUPPORT, "ESOCKTNOSUPPORT", "WSAESOCKTNOSUPPORT" },
/* 045 */ { WSAEOPNOTSUPP, "Operation not supported",
EOPNOTSUPP, "EOPNOTSUPP", "WSAEOPNOTSUPP" },
/* 046 */ { WSAEPFNOSUPPORT, "Protocol family not supported",
EPFNOSUPPORT, "EPFNOSUPPORT", "WSAEPFNOSUPPORT" },
/* 047 */ { WSAEAFNOSUPPORT,
"Address family not supported by protocol family",
EAFNOSUPPORT, "EAFNOSUPPORT", "WSAEAFNOSUPPORT" },
/* 048 */ { WSAEADDRINUSE, "Address already in use",
EADDRINUSE, "EADDRINUSE", "WSAEADDRINUSE" },
/* 049 */ { WSAEADDRNOTAVAIL, "Cannot assign requested address",
EADDRNOTAVAIL, "EADDRNOTAVAIL", "WSAEADDRNOTAVAIL" },
/* 050 */ { WSAENETDOWN, "Network is down",
ENETDOWN, "ENETDOWN", "WSAENETDOWN" },
/* 051 */ { WSAENETUNREACH, "Network is unreachable",
ENETUNREACH, "ENETUNREACH", "WSAENETUNREACH" },
/* 052 */ { WSAENETRESET, "Network dropped connection on reset",
ENETRESET, "ENETRESET", "WSAENETRESET" },
/* 053 */ { WSAECONNABORTED, "Software caused connection abort",
ECONNABORTED, "ECONNABORTED", "WSAECONNABORTED" },
/* 054 */ { WSAECONNRESET, "Connection reset by peer",
ECONNRESET, "ECONNRESET", "WSAECONNRESET" },
/* 055 */ { WSAENOBUFS, "No buffer space available",
ENOBUFS, "ENOBUFS", "WSAENOBUFS" },
/* 056 */ { WSAEISCONN, "Socket is already connected",
EISCONN, "EISCONN", "WSAEISCONN" },
/* 057 */ { WSAENOTCONN, "Socket is not connected",
ENOTCONN, "ENOTCONN", "WSAENOTCONN" },
/* 058 */ { WSAESHUTDOWN, "Cannot send after socket shutdown",
ESHUTDOWN, "ESHUTDOWN", "WSAESHUTDOWN" },
/* 059 */ { WSAETOOMANYREFS, "Too many references; can't splice",
ETOOMANYREFS, "ETOOMANYREFS", "WSAETOOMANYREFS" },
/* 060 */ { WSAETIMEDOUT, "Connection timed out",
ETIMEDOUT, "ETIMEDOUT", "WSAETIMEDOUT" },
/* 061 */ { WSAECONNREFUSED, "Connection refused",
ECONNREFUSED, "ECONNREFUSED", "WSAECONNREFUSED" },
/* 062 */ { WSAELOOP, "Too many levels of symbolic links",
ELOOP, "ELOOP", "WSAELOOP" },
/* 063 */ { WSAENAMETOOLONG, "File name too long",
ENAMETOOLONG, NULL, "WSAENAMETOOLONG" },
/* 064 */ { WSAEHOSTDOWN, "Host is down",
EHOSTDOWN, "EHOSTDOWN", "WSAEHOSTDOWN" },
/* 065 */ { WSAEHOSTUNREACH, "No route to host",
EHOSTUNREACH, "EHOSTUNREACH", "WSAEHOSTUNREACH" },
/* 066 */ { WSAENOTEMPTY, "Directory not empty",
ENOTEMPTY, NULL, "WSAENOTEMPTY" },
/* 067 */ { WSAEPROCLIM, "Too many processes",
EPROCLIM, "EPROCLIM", "WSAEPROCLIM" },
/* 068 */ { WSAEUSERS, "Too many users",
EUSERS, "EUSERS", "WSAEUSERS" },
/* 069 */ { WSAEDQUOT, "Disc quota exceeded",
EDQUOT, "EDQUOT", "WSAEDQUOT" },
/* 070 */ { WSAESTALE, "Stale NFS file handle",
ESTALE, "ESTALE", "WSAESTALE" },
/* 071 */ { WSAEREMOTE, "Too many levels of remote in path",
EREMOTE, "EREMOTE", "WSAEREMOTE" },
/* 072 */ { 0, NULL, 0, NULL, NULL },
/* 073 */ { 0, NULL, 0, NULL, NULL },
/* 074 */ { 0, NULL, 0, NULL, NULL },
/* 075 */ { 0, NULL, 0, NULL, NULL },
/* 076 */ { 0, NULL, 0, NULL, NULL },
/* 077 */ { 0, NULL, 0, NULL, NULL },
/* 078 */ { 0, NULL, 0, NULL, NULL },
/* 079 */ { 0, NULL, 0, NULL, NULL },
/* 080 */ { 0, NULL, 0, NULL, NULL },
/* 081 */ { 0, NULL, 0, NULL, NULL },
/* 082 */ { 0, NULL, 0, NULL, NULL },
/* 083 */ { 0, NULL, 0, NULL, NULL },
/* 084 */ { 0, NULL, 0, NULL, NULL },
/* 085 */ { 0, NULL, 0, NULL, NULL },
/* 086 */ { 0, NULL, 0, NULL, NULL },
/* 087 */ { 0, NULL, 0, NULL, NULL },
/* 088 */ { 0, NULL, 0, NULL, NULL },
/* 089 */ { 0, NULL, 0, NULL, NULL },
/* 090 */ { 0, NULL, 0, NULL, NULL },
/* 091 */ { WSASYSNOTREADY, "Network subsystem is unavailable",
0, NULL, "WSASYSNOTREADY" },
/* 092 */ { WSAVERNOTSUPPORTED, "WINSOCK.DLL version out of range",
0, NULL, "WSAVERNOTSUPPORTED" },
/* 093 */ { WSANOTINITIALISED, "Successful WSAStartup not yet performed",
0, NULL, "WSANOTINITIALISED" },
/* 094 */ { 0, NULL, 0, NULL, NULL },
/* 095 */ { 0, NULL, 0, NULL, NULL },
/* 096 */ { 0, NULL, 0, NULL, NULL },
/* 097 */ { 0, NULL, 0, NULL, NULL },
/* 098 */ { 0, NULL, 0, NULL, NULL },
/* 099 */ { 0, NULL, 0, NULL, NULL },
/* 100 */ { 0, NULL, 0, NULL, NULL },
/* 101 */ { WSAEDISCON, "Graceful shutdown in progress",
0, NULL, "WSAEDISCON" },
/* 102 */ { WSAENOMORE, "No more services",
0, NULL, "WSAENOMORE" },
/* 103 */ { WSAECANCELLED, "Service lookup cancelled",
0, NULL, "WSAECANCELLED" },
/* 104 */ { WSAEINVALIDPROCTABLE, "Invalid procedure call table",
0, NULL, "WSAEINVALIDPROCTABLE" },
/* 105 */ { WSAEINVALIDPROVIDER, "Invalid service provider",
0, NULL, "WSAEINVALIDPROVIDER" },
/* 106 */ { WSAEPROVIDERFAILEDINIT, "Service provider failure",
0, NULL, "WSAEPROVIDERFAILEDINIT" },
/* 107 */ { WSASYSCALLFAILURE, "System call failed",
0, NULL, "WSASYSCALLFAILURE" },
/* 108 */ { WSASERVICE_NOT_FOUND, "No such service",
0, NULL, "WSASERVICE_NOT_FOUND" },
/* 109 */ { WSATYPE_NOT_FOUND, "Class not found",
0, NULL, "WSATYPE_NOT_FOUND" },
/* 110 */ { WSA_E_NO_MORE, "No more services",
0, NULL, "WSA_E_NO_MORE" },
/* 111 */ { WSA_E_CANCELLED, "Service lookup cancelled",
0, NULL, "WSA_E_CANCELLED" },
/* 112 */ { WSAEREFUSED, "Database query refused",
0, NULL, "WSAEREFUSED" },
/* end */ { -1, NULL, -1, NULL, NULL }
};
/* Extended list of error structures. */
static socket_error_t socket_h_errno [] = {
/* 000 */ { 0, NULL, 0, NULL, NULL },
/* 001 */ { WSAHOST_NOT_FOUND, "Host not found",
HOST_NOT_FOUND, "HOST_NOT_FOUND", "WSAHOST_NOT_FOUND" },
/* 002 */ { WSATRY_AGAIN, "Non-authoritative host not found",
TRY_AGAIN, "TRY_AGAIN", "WSATRY_AGAIN" },
/* 003 */ { WSANO_RECOVERY, "This is a non-recoverable error",
NO_RECOVERY, "NO_RECOVERY", "WSANO_RECOVERY" },
/* 004 */ { WSANO_DATA, "Valid name, no data record of requested type",
NO_DATA, "NO_DATA", "WSANO_DATA" },
/* 005 */ { WSANO_ADDRESS, "No address, look for MX record",
NO_ADDRESS, "NO_ADDRESS", "WSANO_ADDRESS" },
/* end */ { -1, NULL, -1, NULL, NULL }
};
/* Returns the result of @code{WSAGetLastError()}. */
int
scm_i_socket_errno (void)
{
return WSAGetLastError ();
}
/* Returns a valid error message for Winsock-API error codes obtained via
@code{WSAGetLastError()} or NULL otherwise. */
char *
scm_i_socket_strerror (int error)
{
if (error >= WSABASEERR && error <= (WSABASEERR + 112))
return socket_errno[error - WSABASEERR].str;
else if (error >= (WSABASEERR + 1000) && error <= (WSABASEERR + 1005))
return socket_h_errno[error - (WSABASEERR + 1000)].str;
return NULL;
}
/* Constructs a valid filename for the given file @var{file} in the M$-Windows
directory. This is usually the default location for the network files. */
char *
scm_i_socket_filename (char *file)
{
static char dir[PATH_MAX];
int len = PATH_MAX;
len = GetWindowsDirectory (dir, len);
if (dir[len - 1] != '\\')
strcat (dir, "\\");
strcat (dir, file);
return dir;
}
/* Removes comments and white spaces at end of line and returns a pointer
to the end of the line. */
static char *
scm_i_socket_uncomment (char *line)
{
char *end;
if ((end = strchr (line, '#')) != NULL)
*end-- = '\0';
else
{
end = line + strlen (line) - 1;
while (end > line && (*end == '\r' || *end == '\n'))
*end-- = '\0';
}
while (end > line && isspace ((int) (*end)))
*end-- = '\0';
return end;
}
/* The getservent() function reads the next line from the file `/etc/services'
and returns a structure servent containing the broken out fields from the
line. The `/etc/services' file is opened if necessary. */
struct servent *
getservent (void)
{
char line[MAX_NAMLEN], *end, *p;
int done = 0, i, n, a;
struct servent *e = NULL;
/* Ensure a open file. */
if (scm_i_servent.fd == NULL || feof (scm_i_servent.fd))
{
setservent (1);
if (scm_i_servent.fd == NULL)
return NULL;
}
while (!done)
{
/* Get new line. */
if (fgets (line, MAX_NAMLEN, scm_i_servent.fd) != NULL)
{
end = scm_i_socket_uncomment (line);
/* Scan the line. */
if ((i = sscanf (line, "%s %d/%s%n",
scm_i_servent.name,
&scm_i_servent.port,
scm_i_servent.proto, &n)) != 3)
continue;
/* Scan the remaining aliases. */
p = line + n;
for (a = 0; a < MAX_ALIASES && p < end && i != -1 && n > 1;
a++, p += n)
i = sscanf (p, "%s%n", scm_i_servent.alias[a], &n);
/* Prepare the return value. */
e = &scm_i_servent.ent;
e->s_name = scm_i_servent.name;
e->s_port = htons (scm_i_servent.port);
e->s_proto = scm_i_servent.proto;
e->s_aliases = scm_i_servent.aliases;
scm_i_servent.aliases[a] = NULL;
while (a--)
scm_i_servent.aliases[a] = scm_i_servent.alias[a];
done = 1;
}
else
break;
}
return done ? e : NULL;
}
/* The setservent() function opens and rewinds the `/etc/services' file.
This file can be set from outside with an environment variable specifying
the file name. */
void
setservent (int stayopen)
{
char *file = NULL;
endservent ();
if ((file = getenv (ENVIRON_ETC_SERVICES)) != NULL)
strcpy (scm_i_servent.file, file);
else if ((file = scm_i_socket_filename (FILE_ETC_SERVICES)) != NULL)
strcpy (scm_i_servent.file, file);
scm_i_servent.fd = fopen (scm_i_servent.file, "rt");
}
/* The endservent() function closes the `/etc/services' file. */
void
endservent (void)
{
if (scm_i_servent.fd != NULL)
{
fclose (scm_i_servent.fd);
scm_i_servent.fd = NULL;
}
}
/* The getprotoent() function reads the next line from the file
`/etc/protocols' and returns a structure protoent containing the broken
out fields from the line. The `/etc/protocols' file is opened if
necessary. */
struct protoent *
getprotoent (void)
{
char line[MAX_NAMLEN], *end, *p;
int done = 0, i, n, a;
struct protoent *e = NULL;
/* Ensure a open file. */
if (scm_i_protoent.fd == NULL || feof (scm_i_protoent.fd))
{
setprotoent (1);
if (scm_i_protoent.fd == NULL)
return NULL;
}
while (!done)
{
/* Get new line. */
if (fgets (line, MAX_NAMLEN, scm_i_protoent.fd) != NULL)
{
end = scm_i_socket_uncomment (line);
/* Scan the line. */
if ((i = sscanf (line, "%s %d%n",
scm_i_protoent.name,
&scm_i_protoent.proto, &n)) != 2)
continue;
/* Scan the remaining aliases. */
p = line + n;
for (a = 0; a < MAX_ALIASES && p < end && i != -1 && n > 1;
a++, p += n)
i = sscanf (p, "%s%n", scm_i_protoent.alias[a], &n);
/* Prepare the return value. */
e = &scm_i_protoent.ent;
e->p_name = scm_i_protoent.name;
e->p_proto = scm_i_protoent.proto;
e->p_aliases = scm_i_protoent.aliases;
scm_i_protoent.aliases[a] = NULL;
while (a--)
scm_i_protoent.aliases[a] = scm_i_protoent.alias[a];
done = 1;
}
else
break;
}
return done ? e : NULL;
}
/* The setprotoent() function opens and rewinds the `/etc/protocols' file.
As in setservent() the user can modify the location of the file using
an environment variable. */
void
setprotoent (int stayopen)
{
char *file = NULL;
endprotoent ();
if ((file = getenv (ENVIRON_ETC_PROTOCOLS)) != NULL)
strcpy (scm_i_protoent.file, file);
else if ((file = scm_i_socket_filename (FILE_ETC_PROTOCOLS)) != NULL)
strcpy (scm_i_protoent.file, file);
scm_i_protoent.fd = fopen (scm_i_protoent.file, "rt");
}
/* The endprotoent() function closes `/etc/protocols'. */
void
endprotoent (void)
{
if (scm_i_protoent.fd != NULL)
{
fclose (scm_i_protoent.fd);
scm_i_protoent.fd = NULL;
}
}
/* Define both the original and replacement error symbol is possible. Thus
the user is able to check symbolic errors after unsuccessful networking
function calls. */
static void
scm_socket_symbols_Win32 (socket_error_t * e)
{
while (e->error != -1)
{
if (e->error)
{
if (e->correct_str)
scm_c_define (e->correct_str, scm_from_int (e->error));
if (e->replace && e->replace_str)
scm_c_define (e->replace_str, scm_from_int (e->replace));
}
e++;
}
}
/* Initialize Winsock API under M$-Windows. */
void
scm_i_init_socket_Win32 (void)
{
scm_socket_symbols_Win32 (socket_errno);
scm_socket_symbols_Win32 (socket_h_errno);
}

42
libguile/win32-socket.h
View file

@ -1,42 +0,0 @@
/* classes: h_files */
#ifndef SCM_WIN32_SOCKET_H
#define SCM_WIN32_SOCKET_H
/* Copyright (C) 2001, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* 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., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#include "libguile/__scm.h"
#ifdef SCM_HAVE_WINSOCK2_H
# include <winsock2.h>
#endif
int scm_i_socket_errno (void);
char * scm_i_socket_strerror (int error);
void scm_i_init_socket_Win32 (void);
char * scm_i_socket_filename (char *file);
struct servent * getservent (void);
void setservent (int stayopen);
void endservent (void);
struct protoent * getprotoent (void);
void setprotoent (int stayopen);
void endprotoent (void);
#endif /* SCM_WIN32_SOCKET_H */