diff options
Diffstat (limited to 'libguile')
45 files changed, 1782 insertions, 1905 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am index d42c650ae..6f914e060 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -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) diff --git a/libguile/__scm.h b/libguile/__scm.h index b42b82397..0a749bec5 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -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) diff --git a/libguile/bdw-gc.h b/libguile/bdw-gc.h index 2e1fce27b..7aa757fed 100644 --- a/libguile/bdw-gc.h +++ b/libguile/bdw-gc.h @@ -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> diff --git a/libguile/c-tokenize.lex b/libguile/c-tokenize.lex index dc7225778..856224e46 100644 --- a/libguile/c-tokenize.lex +++ b/libguile/c-tokenize.lex @@ -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> diff --git a/libguile/debug.c b/libguile/debug.c index 87513bf48..b01864fb8 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -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); } diff --git a/libguile/error.c b/libguile/error.c index 790ed0571..0df4c737e 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -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 diff --git a/libguile/filesys.c b/libguile/filesys.c index 3d5b1fb3e..09a0de0e9 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -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) == '\\')) - --i; - while (i >= 0 && (scm_i_string_ref (filename, i) != '/' - && scm_i_string_ref (filename, i) != '\\')) - --i; - while (i >= 0 && (scm_i_string_ref (filename, i) == '/' - || scm_i_string_ref (filename, i) == '\\')) - --i; -#else - while (i >= 0 && 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) != '/') + while (i >= 0 && !is_file_name_separator (scm_c_string_ref (filename, i))) --i; - while (i >= 0 && scm_i_string_ref (filename, i) == '/') + while (i >= 0 && is_file_name_separator (scm_c_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) != '\\')) - --i; -#else - while (i >= 0 && scm_i_string_ref (filename, i) != '/') + while (i >= 0 && !is_file_name_separator (scm_c_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) diff --git a/libguile/filesys.h b/libguile/filesys.h index c420992bd..fc66e40b2 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -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); diff --git a/libguile/fluids.c b/libguile/fluids.c index 8e36acde6..146854b96 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -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; } } diff --git a/libguile/foreign.c b/libguile/foreign.c index c81c5f407..4f5aa58e1 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -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 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 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(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 -cif_to_procedure (SCM cif, SCM func_ptr) +get_objcode_trampoline (unsigned int nargs) { - ffi_cif *c_cif; - unsigned int nargs; - SCM objcode, table, ret; - - c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif); - nargs = c_cif->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 >= 10 currently unimplemented", + 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; + SCM objcode, table, ret; + + c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif); + 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)); diff --git a/libguile/fports.c b/libguile/fports.c index 94ce434d1..067c3e2b5 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -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" - -/* 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. */ +#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" -#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 } diff --git a/libguile/gc.c b/libguile/gc.c index d580a65a0..581bbc527 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -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; diff --git a/libguile/guardians.c b/libguile/guardians.c index 8a0d2961c..49d7cbab4 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -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); diff --git a/libguile/guile.c b/libguile/guile.c index 133afc43e..03b603eb2 100644 --- a/libguile/guile.c +++ b/libguile/guile.c @@ -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; diff --git a/libguile/i18n.c b/libguile/i18n.c index 817c66198..dc6d07d12 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -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; diff --git a/libguile/init.c b/libguile/init.c index 684f6eb02..fb952f2d1 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -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" diff --git a/libguile/iselect.h b/libguile/iselect.h index 760d959d8..1c7b12db0 100644 --- a/libguile/iselect.h +++ b/libguile/iselect.h @@ -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,35 +30,18 @@ #include <sys/types.h> #if SCM_HAVE_SYS_SELECT_H -# include <sys/select.h> -#endif -#if SCM_HAVE_WINSOCK2_H -# include <winsock2.h> -#endif +#include <sys/select.h> -#ifdef FD_SET +SCM_API int scm_std_select (int fds, + fd_set *rfds, + fd_set *wfds, + fd_set *efds, + struct timeval *timeout); #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 */ - -SCM_API int scm_std_select (int fds, - SELECT_TYPE *rfds, - SELECT_TYPE *wfds, - SELECT_TYPE *efds, - struct timeval *timeout); +#endif /* SCM_HAVE_SYS_SELECT_H */ #endif /* SCM_ISELECT_H */ diff --git a/libguile/list.c b/libguile/list.c index 627640334..1f44ad032 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -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)) { diff --git a/libguile/load.c b/libguile/load.c index 081c364e6..ebf79a9eb 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -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, diff --git a/libguile/load.h b/libguile/load.h index 698bbaf6c..ab75ea3b3 100644 --- a/libguile/load.h +++ b/libguile/load.h @@ -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); diff --git a/libguile/memoize.c b/libguile/memoize.c index 7431d3c0e..f20241c20 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -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); diff --git a/libguile/mkstemp.c b/libguile/mkstemp.c index 6a573c695..a7eaf105b 100644 --- a/libguile/mkstemp.c +++ b/libguile/mkstemp.c @@ -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; diff --git a/libguile/net_db.c b/libguile/net_db.c index 4d63aabcc..d7a12c50f 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -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,48 +34,36 @@ #include <verify.h> #include <errno.h> -#include "libguile/_scm.h" -#include "libguile/feature.h" -#include "libguile/strings.h" -#include "libguile/vectors.h" -#include "libguile/dynwind.h" - -#include "libguile/validate.h" -#include "libguile/net_db.h" -#include "libguile/socket.h" - #ifdef HAVE_STRING_H #include <string.h> #endif #include <sys/types.h> -#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 +#include "libguile/_scm.h" +#include "libguile/feature.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" +#include "libguile/dynwind.h" -#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 +#include "libguile/validate.h" +#include "libguile/net_db.h" +#include "libguile/socket.h" + + +#if defined (HAVE_H_ERRNO) +/* Only wrap gethostbyname / gethostbyaddr if h_errno is available. */ -#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 " diff --git a/libguile/numbers.c b/libguile/numbers.c index 01f8e05ac..29d266984 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -81,6 +81,9 @@ #define M_PI 3.14159265358979323846 #endif +/* FIXME: We assume that FLT_RADIX is 2 */ +verify (FLT_RADIX == 2); + typedef scm_t_signed_bits scm_t_inum; #define scm_from_inum(x) (scm_from_signed_integer (x)) @@ -327,81 +330,52 @@ scm_i_dbl2num (double u) return scm_i_dbl2big (u); } -/* scm_i_big2dbl() rounds to the closest representable double, in accordance - with R5RS exact->inexact. - - The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits - (ie. truncate towards zero), then adjust to get the closest double by - examining the next lower bit and adding 1 (to the absolute value) if - necessary. - - Bignums exactly half way between representable doubles are rounded to the - next higher absolute value (ie. away from zero). This seems like an - adequate interpretation of R5RS "numerically closest", and it's easier - and faster than a full "nearest-even" style. - - The bit test must be done on the absolute value of the mpz_t, which means - we need to use mpz_getlimbn. mpz_tstbit is not right, it treats - negatives as twos complement. +static SCM round_right_shift_exact_integer (SCM n, long count); - In GMP before 4.2, mpz_get_d rounding was unspecified. It ended up - following the hardware rounding mode, but applied to the absolute - value of the mpz_t operand. This is not what we want so we put the - high DBL_MANT_DIG bits into a temporary. Starting with GMP 4.2 - (released in March 2006) mpz_get_d now always truncates towards zero. +/* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the + bignum b into a normalized significand and exponent such that + b = significand * 2^exponent and 1/2 <= abs(significand) < 1. + The return value is the significand rounded to the closest + representable double, and the exponent is placed into *expon_p. + If b is zero, then the returned exponent and significand are both + zero. */ - ENHANCE-ME: The temporary init+clear to force the rounding in GMP - before 4.2 is a slowdown. It'd be faster to pick out the relevant - high bits with mpz_getlimbn. */ - -double -scm_i_big2dbl (SCM b) +static double +scm_i_big2dbl_2exp (SCM b, long *expon_p) { - double result; - size_t bits; - - bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2); - -#if 1 - { - /* For GMP earlier than 4.2, force truncation towards zero */ - - /* FIXME: DBL_MANT_DIG is the number of base-`FLT_RADIX' digits, - _not_ the number of bits, so this code will break badly on a - system with non-binary doubles. */ - - mpz_t tmp; - if (bits > DBL_MANT_DIG) - { - size_t shift = bits - DBL_MANT_DIG; - mpz_init2 (tmp, DBL_MANT_DIG); - mpz_tdiv_q_2exp (tmp, SCM_I_BIG_MPZ (b), shift); - result = ldexp (mpz_get_d (tmp), shift); - mpz_clear (tmp); - } - else - { - result = mpz_get_d (SCM_I_BIG_MPZ (b)); - } - } -#else - /* GMP 4.2 or later */ - result = mpz_get_d (SCM_I_BIG_MPZ (b)); -#endif + size_t bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2); + size_t shift = 0; if (bits > DBL_MANT_DIG) { - unsigned long pos = bits - DBL_MANT_DIG - 1; - /* test bit number "pos" in absolute value */ - if (mpz_getlimbn (SCM_I_BIG_MPZ (b), pos / GMP_NUMB_BITS) - & ((mp_limb_t) 1 << (pos % GMP_NUMB_BITS))) + shift = bits - DBL_MANT_DIG; + b = round_right_shift_exact_integer (b, shift); + if (SCM_I_INUMP (b)) { - result += ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b)), pos + 1); + int expon; + double signif = frexp (SCM_I_INUM (b), &expon); + *expon_p = expon + shift; + return signif; } } - scm_remember_upto_here_1 (b); - return result; + { + long expon; + double signif = mpz_get_d_2exp (&expon, SCM_I_BIG_MPZ (b)); + scm_remember_upto_here_1 (b); + *expon_p = expon + shift; + return signif; + } +} + +/* scm_i_big2dbl() rounds to the closest representable double, + in accordance with R5RS exact->inexact. */ +double +scm_i_big2dbl (SCM b) +{ + long expon; + double signif = scm_i_big2dbl_2exp (b, &expon); + return ldexp (signif, expon); } SCM @@ -436,107 +410,212 @@ scm_i_mpz2num (mpz_t b) } } -/* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */ -static SCM scm_divide2real (SCM x, SCM y); - +/* Make the ratio NUMERATOR/DENOMINATOR, where: + 1. NUMERATOR and DENOMINATOR are exact integers + 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */ static SCM -scm_i_make_ratio (SCM numerator, SCM denominator) -#define FUNC_NAME "make-ratio" +scm_i_make_ratio_already_reduced (SCM numerator, SCM denominator) { - /* First make sure the arguments are proper. - */ - if (SCM_I_INUMP (denominator)) + /* Flip signs so that the denominator is positive. */ + if (scm_is_false (scm_positive_p (denominator))) { - if (scm_is_eq (denominator, SCM_INUM0)) + if (SCM_UNLIKELY (scm_is_eq (denominator, SCM_INUM0))) scm_num_overflow ("make-ratio"); - if (scm_is_eq (denominator, SCM_INUM1)) - return numerator; - } - else - { - if (!(SCM_BIGP(denominator))) - SCM_WRONG_TYPE_ARG (2, denominator); + else + { + numerator = scm_difference (numerator, SCM_UNDEFINED); + denominator = scm_difference (denominator, SCM_UNDEFINED); + } } - if (!SCM_I_INUMP (numerator) && !SCM_BIGP (numerator)) - SCM_WRONG_TYPE_ARG (1, numerator); - /* Then flip signs so that the denominator is positive. - */ - if (scm_is_true (scm_negative_p (denominator))) - { - numerator = scm_difference (numerator, SCM_UNDEFINED); - denominator = scm_difference (denominator, SCM_UNDEFINED); - } + /* Check for the integer case */ + if (scm_is_eq (denominator, SCM_INUM1)) + return numerator; - /* Now consider for each of the four fixnum/bignum combinations - whether the rational number is really an integer. - */ - if (SCM_I_INUMP (numerator)) + return scm_double_cell (scm_tc16_fraction, + SCM_UNPACK (numerator), + SCM_UNPACK (denominator), 0); +} + +static SCM scm_exact_integer_quotient (SCM x, SCM y); + +/* Make the ratio NUMERATOR/DENOMINATOR */ +static SCM +scm_i_make_ratio (SCM numerator, SCM denominator) +#define FUNC_NAME "make-ratio" +{ + /* Make sure the arguments are proper */ + if (!SCM_LIKELY (SCM_I_INUMP (numerator) || SCM_BIGP (numerator))) + SCM_WRONG_TYPE_ARG (1, numerator); + else if (!SCM_LIKELY (SCM_I_INUMP (denominator) || SCM_BIGP (denominator))) + SCM_WRONG_TYPE_ARG (2, denominator); + else { - scm_t_inum x = SCM_I_INUM (numerator); - if (scm_is_eq (numerator, SCM_INUM0)) - return SCM_INUM0; - if (SCM_I_INUMP (denominator)) + SCM the_gcd = scm_gcd (numerator, denominator); + if (!(scm_is_eq (the_gcd, SCM_INUM1))) { - scm_t_inum y; - y = SCM_I_INUM (denominator); - if (x == y) - return SCM_INUM1; - if ((x % y) == 0) - return SCM_I_MAKINUM (x / y); + /* Reduce to lowest terms */ + numerator = scm_exact_integer_quotient (numerator, the_gcd); + denominator = scm_exact_integer_quotient (denominator, the_gcd); } - else - { - /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative - of that value for the denominator, as a bignum. Apart from - that case, abs(bignum) > abs(inum) so inum/bignum is not an - integer. */ - if (x == SCM_MOST_NEGATIVE_FIXNUM - && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator), - - SCM_MOST_NEGATIVE_FIXNUM) == 0) - return SCM_I_MAKINUM(-1); - } + return scm_i_make_ratio_already_reduced (numerator, denominator); } - else if (SCM_BIGP (numerator)) +} +#undef FUNC_NAME + +static mpz_t scm_i_divide2double_lo2b; + +/* Return the double that is closest to the exact rational N/D, with + ties rounded toward even mantissas. N and D must be exact + integers. */ +static double +scm_i_divide2double (SCM n, SCM d) +{ + int neg; + mpz_t nn, dd, lo, hi, x; + ssize_t e; + + if (SCM_LIKELY (SCM_I_INUMP (d))) { - if (SCM_I_INUMP (denominator)) - { - scm_t_inum yy = SCM_I_INUM (denominator); - if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), yy)) - return scm_divide (numerator, denominator); - } - else - { - if (scm_is_eq (numerator, denominator)) - return SCM_INUM1; - if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator), - SCM_I_BIG_MPZ (denominator))) - return scm_divide(numerator, denominator); - } + if (SCM_LIKELY (SCM_I_INUMP (n) + && (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG + || (SCM_I_INUM (n) < (1L << DBL_MANT_DIG) + && SCM_I_INUM (d) < (1L << DBL_MANT_DIG))))) + /* If both N and D can be losslessly converted to doubles, then + we can rely on IEEE floating point to do proper rounding much + faster than we can. */ + return ((double) SCM_I_INUM (n)) / ((double) SCM_I_INUM (d)); + + if (SCM_UNLIKELY (scm_is_eq (d, SCM_INUM0))) + { + if (scm_is_true (scm_positive_p (n))) + return 1.0 / 0.0; + else if (scm_is_true (scm_negative_p (n))) + return -1.0 / 0.0; + else + return 0.0 / 0.0; + } + + mpz_init_set_si (dd, SCM_I_INUM (d)); } + else + mpz_init_set (dd, SCM_I_BIG_MPZ (d)); - /* No, it's a proper fraction. - */ + if (SCM_I_INUMP (n)) + mpz_init_set_si (nn, SCM_I_INUM (n)); + else + mpz_init_set (nn, SCM_I_BIG_MPZ (n)); + + neg = (mpz_sgn (nn) < 0) ^ (mpz_sgn (dd) < 0); + mpz_abs (nn, nn); + mpz_abs (dd, dd); + + /* Now we need to find the value of e such that: + + For e <= 0: + b^{p-1} - 1/2b <= b^-e n / d < b^p - 1/2 [1A] + (2 b^p - 1) <= 2 b b^-e n / d < (2 b^p - 1) b [2A] + (2 b^p - 1) d <= 2 b b^-e n < (2 b^p - 1) d b [3A] + + For e >= 0: + b^{p-1} - 1/2b <= n / b^e d < b^p - 1/2 [1B] + (2 b^p - 1) <= 2 b n / b^e d < (2 b^p - 1) b [2B] + (2 b^p - 1) d b^e <= 2 b n < (2 b^p - 1) d b b^e [3B] + + where: p = DBL_MANT_DIG + b = FLT_RADIX (here assumed to be 2) + + After rounding, the mantissa must be an integer between b^{p-1} and + (b^p - 1), except for subnormal numbers. In the inequations [1A] + and [1B], the middle expression represents the mantissa *before* + rounding, and therefore is bounded by the range of values that will + round to a floating-point number with the exponent e. The upper + bound is (b^p - 1 + 1/2) = (b^p - 1/2), and is exclusive because + ties will round up to the next power of b. The lower bound is + (b^{p-1} - 1/2b), and is inclusive because ties will round toward + this power of b. Here we subtract 1/2b instead of 1/2 because it + is in the range of the next smaller exponent, where the + representable numbers are closer together by a factor of b. + + Inequations [2A] and [2B] are derived from [1A] and [1B] by + multiplying by 2b, and in [3A] and [3B] we multiply by the + denominator of the middle value to obtain integer expressions. + + In the code below, we refer to the three expressions in [3A] or + [3B] as lo, x, and hi. If the number is normalizable, we will + achieve the goal: lo <= x < hi */ + + /* Make an initial guess for e */ + e = mpz_sizeinbase (nn, 2) - mpz_sizeinbase (dd, 2) - (DBL_MANT_DIG-1); + if (e < DBL_MIN_EXP - DBL_MANT_DIG) + e = DBL_MIN_EXP - DBL_MANT_DIG; + + /* Compute the initial values of lo, x, and hi + based on the initial guess of e */ + mpz_inits (lo, hi, x, NULL); + mpz_mul_2exp (x, nn, 2 + ((e < 0) ? -e : 0)); + mpz_mul (lo, dd, scm_i_divide2double_lo2b); + if (e > 0) + mpz_mul_2exp (lo, lo, e); + mpz_mul_2exp (hi, lo, 1); + + /* Adjust e as needed to satisfy the inequality lo <= x < hi, + (but without making e less then the minimum exponent) */ + while (mpz_cmp (x, lo) < 0 && e > DBL_MIN_EXP - DBL_MANT_DIG) + { + mpz_mul_2exp (x, x, 1); + e--; + } + while (mpz_cmp (x, hi) >= 0) + { + /* If we ever used lo's value again, + we would need to double lo here. */ + mpz_mul_2exp (hi, hi, 1); + e++; + } + + /* Now compute the rounded mantissa: + n / b^e d (if e >= 0) + n b^-e / d (if e <= 0) */ { - SCM divisor = scm_gcd (numerator, denominator); - if (!(scm_is_eq (divisor, SCM_INUM1))) - { - numerator = scm_divide (numerator, divisor); - denominator = scm_divide (denominator, divisor); - } - - return scm_double_cell (scm_tc16_fraction, - SCM_UNPACK (numerator), - SCM_UNPACK (denominator), 0); + int cmp; + double result; + + if (e < 0) + mpz_mul_2exp (nn, nn, -e); + else + mpz_mul_2exp (dd, dd, e); + + /* mpz does not directly support rounded right + shifts, so we have to do it the hard way. + For efficiency, we reuse lo and hi. + hi == quotient, lo == remainder */ + mpz_fdiv_qr (hi, lo, nn, dd); + + /* The fractional part of the unrounded mantissa would be + remainder/dividend, i.e. lo/dd. So we have a tie if + lo/dd = 1/2. Multiplying both sides by 2*dd yields the + integer expression 2*lo = dd. Here we do that comparison + to decide whether to round up or down. */ + mpz_mul_2exp (lo, lo, 1); + cmp = mpz_cmp (lo, dd); + if (cmp > 0 || (cmp == 0 && mpz_odd_p (hi))) + mpz_add_ui (hi, hi, 1); + + result = ldexp (mpz_get_d (hi), e); + if (neg) + result = -result; + + mpz_clears (nn, dd, lo, hi, x, NULL); + return result; } } -#undef FUNC_NAME double scm_i_fraction2double (SCM z) { - return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z), - SCM_FRACTION_DENOMINATOR (z))); + return scm_i_divide2double (SCM_FRACTION_NUMERATOR (z), + SCM_FRACTION_DENOMINATOR (z)); } static int @@ -820,8 +899,9 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0, { if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x)))) return x; - return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED), - SCM_FRACTION_DENOMINATOR (x)); + return scm_i_make_ratio_already_reduced + (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED), + SCM_FRACTION_DENOMINATOR (x)); } else return scm_wta_dispatch_1 (g_scm_abs, x, 1, s_scm_abs); @@ -889,6 +969,84 @@ SCM_PRIMITIVE_GENERIC (scm_modulo, "modulo", 2, 0, 0, } #undef FUNC_NAME +/* Return the exact integer q such that n = q*d, for exact integers n + and d, where d is known in advance to divide n evenly (with zero + remainder). For large integers, this can be computed more + efficiently than when the remainder is unknown. */ +static SCM +scm_exact_integer_quotient (SCM n, SCM d) +#define FUNC_NAME "exact-integer-quotient" +{ + if (SCM_LIKELY (SCM_I_INUMP (n))) + { + scm_t_inum nn = SCM_I_INUM (n); + if (SCM_LIKELY (SCM_I_INUMP (d))) + { + scm_t_inum dd = SCM_I_INUM (d); + if (SCM_UNLIKELY (dd == 0)) + scm_num_overflow ("exact-integer-quotient"); + else + { + scm_t_inum qq = nn / dd; + if (SCM_LIKELY (SCM_FIXABLE (qq))) + return SCM_I_MAKINUM (qq); + else + return scm_i_inum2big (qq); + } + } + else if (SCM_LIKELY (SCM_BIGP (d))) + { + /* n is an inum and d is a bignum. Given that d is known to + divide n evenly, there are only two possibilities: n is 0, + or else n is fixnum-min and d is abs(fixnum-min). */ + if (nn == 0) + return SCM_INUM0; + else + return SCM_I_MAKINUM (-1); + } + else + SCM_WRONG_TYPE_ARG (2, d); + } + else if (SCM_LIKELY (SCM_BIGP (n))) + { + if (SCM_LIKELY (SCM_I_INUMP (d))) + { + scm_t_inum dd = SCM_I_INUM (d); + if (SCM_UNLIKELY (dd == 0)) + scm_num_overflow ("exact-integer-quotient"); + else if (SCM_UNLIKELY (dd == 1)) + return n; + else + { + SCM q = scm_i_mkbig (); + if (dd > 0) + mpz_divexact_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), dd); + else + { + mpz_divexact_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), -dd); + mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q)); + } + scm_remember_upto_here_1 (n); + return scm_i_normbig (q); + } + } + else if (SCM_LIKELY (SCM_BIGP (d))) + { + SCM q = scm_i_mkbig (); + mpz_divexact (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (n), + SCM_I_BIG_MPZ (d)); + scm_remember_upto_here_2 (n, d); + return scm_i_normbig (q); + } + else + SCM_WRONG_TYPE_ARG (2, d); + } + else + SCM_WRONG_TYPE_ARG (1, n); +} +#undef FUNC_NAME + /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for two-valued functions. It is called from primitive generics that take two arguments and return two values, when the core procedure is @@ -3888,52 +4046,58 @@ SCM_PRIMITIVE_GENERIC (scm_i_gcd, "gcd", 0, 2, 1, SCM scm_gcd (SCM x, SCM y) { - if (SCM_UNBNDP (y)) + if (SCM_UNLIKELY (SCM_UNBNDP (y))) return SCM_UNBNDP (x) ? SCM_INUM0 : scm_abs (x); - if (SCM_I_INUMP (x)) + if (SCM_LIKELY (SCM_I_INUMP (x))) { - if (SCM_I_INUMP (y)) + if (SCM_LIKELY (SCM_I_INUMP (y))) { scm_t_inum xx = SCM_I_INUM (x); scm_t_inum yy = SCM_I_INUM (y); scm_t_inum u = xx < 0 ? -xx : xx; scm_t_inum v = yy < 0 ? -yy : yy; scm_t_inum result; - if (xx == 0) + if (SCM_UNLIKELY (xx == 0)) result = v; - else if (yy == 0) + else if (SCM_UNLIKELY (yy == 0)) result = u; else { - scm_t_inum k = 1; - scm_t_inum t; + int k = 0; /* Determine a common factor 2^k */ - while (!(1 & (u | v))) + while (((u | v) & 1) == 0) { - k <<= 1; + k++; u >>= 1; v >>= 1; } /* Now, any factor 2^n can be eliminated */ - if (u & 1) - t = -v; + if ((u & 1) == 0) + while ((u & 1) == 0) + u >>= 1; else + while ((v & 1) == 0) + v >>= 1; + /* Both u and v are now odd. Subtract the smaller one + from the larger one to produce an even number, remove + more factors of two, and repeat. */ + while (u != v) { - t = u; - b3: - t = SCM_SRS (t, 1); + if (u > v) + { + u -= v; + while ((u & 1) == 0) + u >>= 1; + } + else + { + v -= u; + while ((v & 1) == 0) + v >>= 1; + } } - if (!(1 & t)) - goto b3; - if (t > 0) - u = t; - else - v = -t; - t = u - v; - if (t != 0) - goto b3; - result = u * k; + result = u << k; } return (SCM_POSFIXABLE (result) ? SCM_I_MAKINUM (result) @@ -4666,6 +4830,26 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, else /* return NaN for (0 ^ k) for negative k per R6RS */ return scm_nan (); } + else if (SCM_FRACTIONP (n)) + { + /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid + needless reduction of intermediate products to lowest terms. + If a and b have no common factors, then a^k and b^k have no + common factors. Use 'scm_i_make_ratio_already_reduced' to + construct the final result, so that no gcd computations are + needed to exponentiate a fraction. */ + if (scm_is_true (scm_positive_p (k))) + return scm_i_make_ratio_already_reduced + (scm_integer_expt (SCM_FRACTION_NUMERATOR (n), k), + scm_integer_expt (SCM_FRACTION_DENOMINATOR (n), k)); + else + { + k = scm_difference (k, SCM_UNDEFINED); + return scm_i_make_ratio_already_reduced + (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n), k), + scm_integer_expt (SCM_FRACTION_NUMERATOR (n), k)); + } + } if (SCM_I_INUMP (k)) i2 = SCM_I_INUM (k); @@ -4723,19 +4907,119 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, } #undef FUNC_NAME +/* Efficiently compute (N * 2^COUNT), + where N is an exact integer, and COUNT > 0. */ +static SCM +left_shift_exact_integer (SCM n, long count) +{ + if (SCM_I_INUMP (n)) + { + scm_t_inum nn = SCM_I_INUM (n); + + /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will always + overflow a non-zero fixnum. For smaller shifts we check the + bits going into positions above SCM_I_FIXNUM_BIT-1. If they're + all 0s for nn>=0, or all 1s for nn<0 then there's no overflow. + Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)". */ + + if (nn == 0) + return n; + else if (count < SCM_I_FIXNUM_BIT-1 && + ((scm_t_bits) (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - count)) + 1) + <= 1)) + return SCM_I_MAKINUM (nn << count); + else + { + SCM result = scm_i_inum2big (nn); + mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), + count); + return result; + } + } + else if (SCM_BIGP (n)) + { + SCM result = scm_i_mkbig (); + mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), count); + scm_remember_upto_here_1 (n); + return result; + } + else + scm_syserror ("left_shift_exact_integer"); +} + +/* Efficiently compute floor (N / 2^COUNT), + where N is an exact integer and COUNT > 0. */ +static SCM +floor_right_shift_exact_integer (SCM n, long count) +{ + if (SCM_I_INUMP (n)) + { + scm_t_inum nn = SCM_I_INUM (n); + + if (count >= SCM_I_FIXNUM_BIT) + return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM (-1)); + else + return SCM_I_MAKINUM (SCM_SRS (nn, count)); + } + else if (SCM_BIGP (n)) + { + SCM result = scm_i_mkbig (); + mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), + count); + scm_remember_upto_here_1 (n); + return scm_i_normbig (result); + } + else + scm_syserror ("floor_right_shift_exact_integer"); +} + +/* Efficiently compute round (N / 2^COUNT), + where N is an exact integer and COUNT > 0. */ +static SCM +round_right_shift_exact_integer (SCM n, long count) +{ + if (SCM_I_INUMP (n)) + { + if (count >= SCM_I_FIXNUM_BIT) + return SCM_INUM0; + else + { + scm_t_inum nn = SCM_I_INUM (n); + scm_t_inum qq = SCM_SRS (nn, count); + + if (0 == (nn & (1L << (count-1)))) + return SCM_I_MAKINUM (qq); /* round down */ + else if (nn & ((1L << (count-1)) - 1)) + return SCM_I_MAKINUM (qq + 1); /* round up */ + else + return SCM_I_MAKINUM ((~1L) & (qq + 1)); /* round to even */ + } + } + else if (SCM_BIGP (n)) + { + SCM q = scm_i_mkbig (); + + mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), count); + if (mpz_tstbit (SCM_I_BIG_MPZ (n), count-1) + && (mpz_odd_p (SCM_I_BIG_MPZ (q)) + || (mpz_scan1 (SCM_I_BIG_MPZ (n), 0) < count-1))) + mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1); + scm_remember_upto_here_1 (n); + return scm_i_normbig (q); + } + else + scm_syserror ("round_right_shift_exact_integer"); +} + SCM_DEFINE (scm_ash, "ash", 2, 0, 0, - (SCM n, SCM cnt), - "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n" - "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n" + (SCM n, SCM count), + "Return @math{floor(@var{n} * 2^@var{count})}.\n" + "@var{n} and @var{count} must be exact integers.\n" "\n" - "This is effectively a multiplication by 2^@var{cnt}, and when\n" - "@var{cnt} is negative it's a division, rounded towards negative\n" - "infinity. (Note that this is not the same rounding as\n" - "@code{quotient} does.)\n" - "\n" - "With @var{n} viewed as an infinite precision twos complement,\n" - "@code{ash} means a left shift introducing zero bits, or a right\n" - "shift dropping bits.\n" + "With @var{n} viewed as an infinite-precision twos-complement\n" + "integer, @code{ash} means a left shift introducing zero bits\n" + "when @var{count} is positive, or a right shift dropping bits\n" + "when @var{count} is negative. This is an ``arithmetic'' shift.\n" "\n" "@lisp\n" "(number->string (ash #b1 3) 2) @result{} \"1000\"\n" @@ -4746,79 +5030,57 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_ash { - long bits_to_shift; - bits_to_shift = scm_to_long (cnt); - - if (SCM_I_INUMP (n)) + if (SCM_I_INUMP (n) || SCM_BIGP (n)) { - scm_t_inum nn = SCM_I_INUM (n); + long bits_to_shift = scm_to_long (count); if (bits_to_shift > 0) - { - /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always - overflow a non-zero fixnum. For smaller shifts we check the - bits going into positions above SCM_I_FIXNUM_BIT-1. If they're - all 0s for nn>=0, or all 1s for nn<0 then there's no overflow. - Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - - bits_to_shift)". */ - - if (nn == 0) - return n; - - if (bits_to_shift < SCM_I_FIXNUM_BIT-1 - && ((scm_t_bits) - (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1) - <= 1)) - { - return SCM_I_MAKINUM (nn << bits_to_shift); - } - else - { - SCM result = scm_i_inum2big (nn); - mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), - bits_to_shift); - return result; - } - } + return left_shift_exact_integer (n, bits_to_shift); + else if (SCM_LIKELY (bits_to_shift < 0)) + return floor_right_shift_exact_integer (n, -bits_to_shift); else - { - bits_to_shift = -bits_to_shift; - if (bits_to_shift >= SCM_LONG_BIT) - return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM(-1)); - else - return SCM_I_MAKINUM (SCM_SRS (nn, bits_to_shift)); - } - + return n; } - else if (SCM_BIGP (n)) - { - SCM result; + else + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); +} +#undef FUNC_NAME - if (bits_to_shift == 0) - return n; +SCM_DEFINE (scm_round_ash, "round-ash", 2, 0, 0, + (SCM n, SCM count), + "Return @math{round(@var{n} * 2^@var{count})}.\n" + "@var{n} and @var{count} must be exact integers.\n" + "\n" + "With @var{n} viewed as an infinite-precision twos-complement\n" + "integer, @code{round-ash} means a left shift introducing zero\n" + "bits when @var{count} is positive, or a right shift rounding\n" + "to the nearest integer (with ties going to the nearest even\n" + "integer) when @var{count} is negative. This is a rounded\n" + "``arithmetic'' shift.\n" + "\n" + "@lisp\n" + "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n" + "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n" + "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n" + "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n" + "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n" + "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n" + "@end lisp") +#define FUNC_NAME s_scm_round_ash +{ + if (SCM_I_INUMP (n) || SCM_BIGP (n)) + { + long bits_to_shift = scm_to_long (count); - result = scm_i_mkbig (); - if (bits_to_shift >= 0) - { - mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), - bits_to_shift); - return result; - } + if (bits_to_shift > 0) + return left_shift_exact_integer (n, bits_to_shift); + else if (SCM_LIKELY (bits_to_shift < 0)) + return round_right_shift_exact_integer (n, -bits_to_shift); else - { - /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so - we have to allocate a bignum even if the result is going to be a - fixnum. */ - mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), - -bits_to_shift); - return scm_i_normbig (result); - } - + return n; } else - { - SCM_WRONG_TYPE_ARG (SCM_ARG1, n); - } + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); } #undef FUNC_NAME @@ -4998,220 +5260,230 @@ SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0, #undef FUNC_NAME /*** NUMBERS -> STRINGS ***/ -#define SCM_MAX_DBL_PREC 60 #define SCM_MAX_DBL_RADIX 36 -/* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */ -static int scm_dblprec[SCM_MAX_DBL_RADIX - 1]; -static double fx_per_radix[SCM_MAX_DBL_RADIX - 1][SCM_MAX_DBL_PREC]; - -static -void init_dblprec(int *prec, int radix) { - /* determine floating point precision by adding successively - smaller increments to 1.0 until it is considered == 1.0 */ - double f = ((double)1.0)/radix; - double fsum = 1.0 + f; - - *prec = 0; - while (fsum != 1.0) - { - if (++(*prec) > SCM_MAX_DBL_PREC) - fsum = 1.0; - else - { - f /= radix; - fsum = f + 1.0; - } - } - (*prec) -= 1; -} - -static -void init_fx_radix(double *fx_list, int radix) -{ - /* initialize a per-radix list of tolerances. When added - to a number < 1.0, we can determine if we should raund - up and quit converting a number to a string. */ - int i; - fx_list[0] = 0.0; - fx_list[1] = 0.5; - for( i = 2 ; i < SCM_MAX_DBL_PREC; ++i ) - fx_list[i] = (fx_list[i-1] / radix); -} - /* use this array as a way to generate a single digit */ static const char number_chars[] = "0123456789abcdefghijklmnopqrstuvwxyz"; +static mpz_t dbl_minimum_normal_mantissa; + static size_t -idbl2str (double f, char *a, int radix) +idbl2str (double dbl, char *a, int radix) { - int efmt, dpt, d, i, wp; - double *fx; -#ifdef DBL_MIN_10_EXP - double f_cpy; - int exp_cpy; -#endif /* DBL_MIN_10_EXP */ - size_t ch = 0; - int exp = 0; - - if(radix < 2 || - radix > SCM_MAX_DBL_RADIX) - { - /* revert to existing behavior */ - radix = 10; - } + int ch = 0; - wp = scm_dblprec[radix-2]; - fx = fx_per_radix[radix-2]; + if (radix < 2 || radix > SCM_MAX_DBL_RADIX) + /* revert to existing behavior */ + radix = 10; - if (f == 0.0) + if (isinf (dbl)) { -#ifdef HAVE_COPYSIGN - double sgn = copysign (1.0, f); - - if (sgn < 0.0) - a[ch++] = '-'; -#endif - goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */ + strcpy (a, (dbl > 0.0) ? "+inf.0" : "-inf.0"); + return 6; } - - if (isinf (f)) + else if (dbl > 0.0) + ; + else if (dbl < 0.0) { - if (f < 0) - strcpy (a, "-inf.0"); - else - strcpy (a, "+inf.0"); - return ch+6; + dbl = -dbl; + a[ch++] = '-'; } - else if (isnan (f)) + else if (dbl == 0.0) { - strcpy (a, "+nan.0"); - return ch+6; + if (!double_is_non_negative_zero (dbl)) + a[ch++] = '-'; + strcpy (a + ch, "0.0"); + return ch + 3; } - - if (f < 0.0) + else if (isnan (dbl)) { - f = -f; - a[ch++] = '-'; + strcpy (a, "+nan.0"); + return 6; } -#ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from - make-uniform-vector, from causing infinite loops. */ - /* just do the checking...if it passes, we do the conversion for our - radix again below */ - f_cpy = f; - exp_cpy = exp; + /* Algorithm taken from "Printing Floating-Point Numbers Quickly and + Accurately" by Robert G. Burger and R. Kent Dybvig */ + { + int e, k; + mpz_t f, r, s, mplus, mminus, hi, digit; + int f_is_even, f_is_odd; + int expon; + int show_exp = 0; + + mpz_inits (f, r, s, mplus, mminus, hi, digit, NULL); + mpz_set_d (f, ldexp (frexp (dbl, &e), DBL_MANT_DIG)); + if (e < DBL_MIN_EXP) + { + mpz_tdiv_q_2exp (f, f, DBL_MIN_EXP - e); + e = DBL_MIN_EXP; + } + e -= DBL_MANT_DIG; - while (f_cpy < 1.0) - { - f_cpy *= 10.0; - if (exp_cpy-- < DBL_MIN_10_EXP) - { - a[ch++] = '#'; - a[ch++] = '.'; - a[ch++] = '#'; - return ch; - } - } - while (f_cpy > 10.0) - { - f_cpy *= 0.10; - if (exp_cpy++ > DBL_MAX_10_EXP) - { - a[ch++] = '#'; - a[ch++] = '.'; - a[ch++] = '#'; - return ch; - } - } -#endif + f_is_even = !mpz_odd_p (f); + f_is_odd = !f_is_even; - while (f < 1.0) - { - f *= radix; - exp--; - } - while (f > radix) - { - f /= radix; - exp++; - } + /* Initialize r, s, mplus, and mminus according + to Table 1 from the paper. */ + if (e < 0) + { + mpz_set_ui (mminus, 1); + if (mpz_cmp (f, dbl_minimum_normal_mantissa) != 0 + || e == DBL_MIN_EXP - DBL_MANT_DIG) + { + mpz_set_ui (mplus, 1); + mpz_mul_2exp (r, f, 1); + mpz_mul_2exp (s, mminus, 1 - e); + } + else + { + mpz_set_ui (mplus, 2); + mpz_mul_2exp (r, f, 2); + mpz_mul_2exp (s, mminus, 2 - e); + } + } + else + { + mpz_set_ui (mminus, 1); + mpz_mul_2exp (mminus, mminus, e); + if (mpz_cmp (f, dbl_minimum_normal_mantissa) != 0) + { + mpz_set (mplus, mminus); + mpz_mul_2exp (r, f, 1 + e); + mpz_set_ui (s, 2); + } + else + { + mpz_mul_2exp (mplus, mminus, 1); + mpz_mul_2exp (r, f, 2 + e); + mpz_set_ui (s, 4); + } + } - if (f + fx[wp] >= radix) + /* Find the smallest k such that: + (r + mplus) / s < radix^k (if f is even) + (r + mplus) / s <= radix^k (if f is odd) */ { - f = 1.0; - exp++; - } - zero: - efmt = (exp < -3) || (exp > wp + 2); - if (!efmt) - { - if (exp < 0) - { - a[ch++] = '0'; - a[ch++] = '.'; - dpt = exp; - while (++dpt) - a[ch++] = '0'; - } - else - dpt = exp + 1; + /* IMPROVE-ME: Make an initial guess to speed this up */ + mpz_add (hi, r, mplus); + k = 0; + while (mpz_cmp (hi, s) >= f_is_odd) + { + mpz_mul_ui (s, s, radix); + k++; + } + if (k == 0) + { + mpz_mul_ui (hi, hi, radix); + while (mpz_cmp (hi, s) < f_is_odd) + { + mpz_mul_ui (r, r, radix); + mpz_mul_ui (mplus, mplus, radix); + mpz_mul_ui (mminus, mminus, radix); + mpz_mul_ui (hi, hi, radix); + k--; + } + } } - else - dpt = 1; - do - { - d = f; - f -= d; - a[ch++] = number_chars[d]; - if (f < fx[wp]) - break; - if (f + fx[wp] >= 1.0) - { - a[ch - 1] = number_chars[d+1]; - break; - } - f *= radix; - if (!(--dpt)) - a[ch++] = '.'; - } - while (wp--); + expon = k - 1; + if (k <= 0) + { + if (k <= -3) + { + /* Use scientific notation */ + show_exp = 1; + k = 1; + } + else + { + int i; - if (dpt > 0) - { - if ((dpt > 4) && (exp > 6)) - { - d = (a[0] == '-' ? 2 : 1); - for (i = ch++; i > d; i--) - a[i] = a[i - 1]; - a[d] = '.'; - efmt = 1; - } - else - { - while (--dpt) - a[ch++] = '0'; - a[ch++] = '.'; - } - } - if (a[ch - 1] == '.') - a[ch++] = '0'; /* trailing zero */ - if (efmt && exp) - { - a[ch++] = 'e'; - if (exp < 0) - { - exp = -exp; - a[ch++] = '-'; - } - for (i = radix; i <= exp; i *= radix); - for (i /= radix; i; i /= radix) - { - a[ch++] = number_chars[exp / i]; - exp %= i; - } - } + /* Print leading zeroes */ + a[ch++] = '0'; + a[ch++] = '.'; + for (i = 0; i > k; i--) + a[ch++] = '0'; + } + } + + for (;;) + { + int end_1_p, end_2_p; + int d; + + mpz_mul_ui (mplus, mplus, radix); + mpz_mul_ui (mminus, mminus, radix); + mpz_mul_ui (r, r, radix); + mpz_fdiv_qr (digit, r, r, s); + d = mpz_get_ui (digit); + + mpz_add (hi, r, mplus); + end_1_p = (mpz_cmp (r, mminus) < f_is_even); + end_2_p = (mpz_cmp (s, hi) < f_is_even); + if (end_1_p || end_2_p) + { + mpz_mul_2exp (r, r, 1); + if (!end_2_p) + ; + else if (!end_1_p) + d++; + else if (mpz_cmp (r, s) >= !(d & 1)) + d++; + a[ch++] = number_chars[d]; + if (--k == 0) + a[ch++] = '.'; + break; + } + else + { + a[ch++] = number_chars[d]; + if (--k == 0) + a[ch++] = '.'; + } + } + + if (k > 0) + { + if (expon >= 7 && k >= 4 && expon >= k) + { + /* Here we would have to print more than three zeroes + followed by a decimal point and another zero. It + makes more sense to use scientific notation. */ + + /* Adjust k to what it would have been if we had chosen + scientific notation from the beginning. */ + k -= expon; + + /* k will now be <= 0, with magnitude equal to the number of + digits that we printed which should now be put after the + decimal point. */ + + /* Insert a decimal point */ + memmove (a + ch + k + 1, a + ch + k, -k); + a[ch + k] = '.'; + ch++; + + show_exp = 1; + } + else + { + for (; k > 0; k--) + a[ch++] = '0'; + a[ch++] = '.'; + } + } + + if (k == 0) + a[ch++] = '0'; + + if (show_exp) + { + a[ch++] = 'e'; + ch += scm_iint2str (expon, radix, a + ch); + } + + mpz_clears (f, r, s, mplus, mminus, hi, digit, NULL); + } return ch; } @@ -5695,7 +5967,7 @@ mem2decimal_from_point (SCM result, SCM mem, break; } - if (exponent > SCM_MAXEXP) + if (exponent > ((sign == 1) ? SCM_MAXEXP : SCM_MAXEXP + DBL_DIG + 1)) { size_t exp_len = idx - start; SCM exp_string = scm_i_substring_copy (mem, start, start + exp_len); @@ -5731,7 +6003,8 @@ mem2decimal_from_point (SCM result, SCM mem, static SCM mem2ureal (SCM mem, unsigned int *p_idx, - unsigned int radix, enum t_exactness forced_x) + unsigned int radix, enum t_exactness forced_x, + int allow_inf_or_nan) { unsigned int idx = *p_idx; SCM result; @@ -5744,30 +6017,53 @@ mem2ureal (SCM mem, unsigned int *p_idx, if (idx == len) return SCM_BOOL_F; - if (idx+5 <= len && !scm_i_string_strcmp (mem, idx, "inf.0")) - { - *p_idx = idx+5; - return scm_inf (); - } - - if (idx+4 < len && !scm_i_string_strcmp (mem, idx, "nan.")) - { - /* Cobble up the fractional part. We might want to set the - NaN's mantissa from it. */ - idx += 4; - if (!scm_is_eq (mem2uinteger (mem, &idx, 10, &implicit_x), SCM_INUM0)) - { + if (allow_inf_or_nan && forced_x != EXACT && idx+5 <= len) + switch (scm_i_string_ref (mem, idx)) + { + case 'i': case 'I': + switch (scm_i_string_ref (mem, idx + 1)) + { + case 'n': case 'N': + switch (scm_i_string_ref (mem, idx + 2)) + { + case 'f': case 'F': + if (scm_i_string_ref (mem, idx + 3) == '.' + && scm_i_string_ref (mem, idx + 4) == '0') + { + *p_idx = idx+5; + return scm_inf (); + } + } + } + case 'n': case 'N': + switch (scm_i_string_ref (mem, idx + 1)) + { + case 'a': case 'A': + switch (scm_i_string_ref (mem, idx + 2)) + { + case 'n': case 'N': + if (scm_i_string_ref (mem, idx + 3) == '.') + { + /* Cobble up the fractional part. We might want to + set the NaN's mantissa from it. */ + idx += 4; + if (!scm_is_eq (mem2uinteger (mem, &idx, 10, &implicit_x), + SCM_INUM0)) + { #if SCM_ENABLE_DEPRECATED == 1 - scm_c_issue_deprecation_warning - ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'."); + scm_c_issue_deprecation_warning + ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'."); #else - return SCM_BOOL_F; + return SCM_BOOL_F; #endif - } + } - *p_idx = idx; - return scm_nan (); - } + *p_idx = idx; + return scm_nan (); + } + } + } + } if (scm_i_string_ref (mem, idx) == '.') { @@ -5800,7 +6096,7 @@ mem2ureal (SCM mem, unsigned int *p_idx, return SCM_BOOL_F; divisor = mem2uinteger (mem, &idx, radix, &implicit_x); - if (scm_is_false (divisor)) + if (scm_is_false (divisor) || scm_is_eq (divisor, SCM_INUM0)) return SCM_BOOL_F; /* both are int/big here, I assume */ @@ -5876,7 +6172,7 @@ mem2complex (SCM mem, unsigned int idx, if (idx == len) return SCM_BOOL_F; - ureal = mem2ureal (mem, &idx, radix, forced_x); + ureal = mem2ureal (mem, &idx, radix, forced_x, sign != 0); if (scm_is_false (ureal)) { /* input must be either +i or -i */ @@ -5945,9 +6241,9 @@ mem2complex (SCM mem, unsigned int idx, sign = -1; } else - sign = 1; + sign = 0; - angle = mem2ureal (mem, &idx, radix, forced_x); + angle = mem2ureal (mem, &idx, radix, forced_x, sign != 0); if (scm_is_false (angle)) return SCM_BOOL_F; if (idx != len) @@ -5969,7 +6265,7 @@ mem2complex (SCM mem, unsigned int idx, else { int sign = (c == '+') ? 1 : -1; - SCM imag = mem2ureal (mem, &idx, radix, forced_x); + SCM imag = mem2ureal (mem, &idx, radix, forced_x, sign != 0); if (scm_is_false (imag)) imag = SCM_I_MAKINUM (sign); @@ -7323,8 +7619,9 @@ scm_difference (SCM x, SCM y) return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x), -SCM_COMPLEX_IMAG (x)); else if (SCM_FRACTIONP (x)) - return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED), - SCM_FRACTION_DENOMINATOR (x)); + return scm_i_make_ratio_already_reduced + (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED), + SCM_FRACTION_DENOMINATOR (x)); else return scm_wta_dispatch_1 (g_difference, x, SCM_ARG1, s_difference); } @@ -7850,8 +8147,8 @@ SCM_PRIMITIVE_GENERIC (scm_i_divide, "/", 0, 2, 1, #define s_divide s_scm_i_divide #define g_divide g_scm_i_divide -static SCM -do_divide (SCM x, SCM y, int inexact) +SCM +scm_divide (SCM x, SCM y) #define FUNC_NAME s_divide { double a; @@ -7870,18 +8167,10 @@ do_divide (SCM x, SCM y, int inexact) scm_num_overflow (s_divide); #endif else - { - if (inexact) - return scm_from_double (1.0 / (double) xx); - else return scm_i_make_ratio (SCM_INUM1, x); - } + return scm_i_make_ratio_already_reduced (SCM_INUM1, x); } else if (SCM_BIGP (x)) - { - if (inexact) - return scm_from_double (1.0 / scm_i_big2dbl (x)); - else return scm_i_make_ratio (SCM_INUM1, x); - } + return scm_i_make_ratio_already_reduced (SCM_INUM1, x); else if (SCM_REALP (x)) { double xx = SCM_REAL_VALUE (x); @@ -7910,8 +8199,8 @@ do_divide (SCM x, SCM y, int inexact) } } else if (SCM_FRACTIONP (x)) - return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x), - SCM_FRACTION_NUMERATOR (x)); + return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x), + SCM_FRACTION_NUMERATOR (x)); else return scm_wta_dispatch_1 (g_divide, x, SCM_ARG1, s_divide); } @@ -7931,11 +8220,7 @@ do_divide (SCM x, SCM y, int inexact) #endif } else if (xx % yy != 0) - { - if (inexact) - return scm_from_double ((double) xx / (double) yy); - else return scm_i_make_ratio (x, y); - } + return scm_i_make_ratio (x, y); else { scm_t_inum z = xx / yy; @@ -7946,11 +8231,7 @@ do_divide (SCM x, SCM y, int inexact) } } else if (SCM_BIGP (y)) - { - if (inexact) - return scm_from_double ((double) xx / scm_i_big2dbl (y)); - else return scm_i_make_ratio (x, y); - } + return scm_i_make_ratio (x, y); else if (SCM_REALP (y)) { double yy = SCM_REAL_VALUE (y); @@ -7959,6 +8240,9 @@ do_divide (SCM x, SCM y, int inexact) scm_num_overflow (s_divide); else #endif + /* FIXME: Precision may be lost here due to: + (1) The cast from 'scm_t_inum' to 'double' + (2) Double rounding */ return scm_from_double ((double) xx / yy); } else if (SCM_COMPLEXP (y)) @@ -7985,7 +8269,7 @@ do_divide (SCM x, SCM y, int inexact) else if (SCM_FRACTIONP (y)) /* a / b/c = ac / b */ return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)), - SCM_FRACTION_NUMERATOR (y)); + SCM_FRACTION_NUMERATOR (y)); else return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide); } @@ -8029,43 +8313,24 @@ do_divide (SCM x, SCM y, int inexact) return scm_i_normbig (result); } else - { - if (inexact) - return scm_from_double (scm_i_big2dbl (x) / (double) yy); - else return scm_i_make_ratio (x, y); - } + return scm_i_make_ratio (x, y); } } else if (SCM_BIGP (y)) { - /* big_x / big_y */ - if (inexact) - { - /* It's easily possible for the ratio x/y to fit a double - but one or both x and y be too big to fit a double, - hence the use of mpq_get_d rather than converting and - dividing. */ - mpq_t q; - *mpq_numref(q) = *SCM_I_BIG_MPZ (x); - *mpq_denref(q) = *SCM_I_BIG_MPZ (y); - return scm_from_double (mpq_get_d (q)); - } - else - { - int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x), - SCM_I_BIG_MPZ (y)); - if (divisible_p) - { - SCM result = scm_i_mkbig (); - mpz_divexact (SCM_I_BIG_MPZ (result), - SCM_I_BIG_MPZ (x), - SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - return scm_i_normbig (result); - } - else - return scm_i_make_ratio (x, y); - } + int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + if (divisible_p) + { + SCM result = scm_i_mkbig (); + mpz_divexact (SCM_I_BIG_MPZ (result), + SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return scm_i_normbig (result); + } + else + return scm_i_make_ratio (x, y); } else if (SCM_REALP (y)) { @@ -8075,6 +8340,8 @@ do_divide (SCM x, SCM y, int inexact) scm_num_overflow (s_divide); else #endif + /* FIXME: Precision may be lost here due to: + (1) scm_i_big2dbl (2) Double rounding */ return scm_from_double (scm_i_big2dbl (x) / yy); } else if (SCM_COMPLEXP (y)) @@ -8084,7 +8351,7 @@ do_divide (SCM x, SCM y, int inexact) } else if (SCM_FRACTIONP (y)) return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)), - SCM_FRACTION_NUMERATOR (y)); + SCM_FRACTION_NUMERATOR (y)); else return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide); } @@ -8099,10 +8366,16 @@ do_divide (SCM x, SCM y, int inexact) scm_num_overflow (s_divide); else #endif + /* FIXME: Precision may be lost here due to: + (1) The cast from 'scm_t_inum' to 'double' + (2) Double rounding */ return scm_from_double (rx / (double) yy); } else if (SCM_BIGP (y)) { + /* FIXME: Precision may be lost here due to: + (1) The conversion from bignum to double + (2) Double rounding */ double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); scm_remember_upto_here_1 (y); return scm_from_double (rx / dby); @@ -8140,12 +8413,18 @@ do_divide (SCM x, SCM y, int inexact) else #endif { + /* FIXME: Precision may be lost here due to: + (1) The conversion from 'scm_t_inum' to double + (2) Double rounding */ double d = yy; return scm_c_make_rectangular (rx / d, ix / d); } } else if (SCM_BIGP (y)) { + /* FIXME: Precision may be lost here due to: + (1) The conversion from bignum to double + (2) Double rounding */ double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); scm_remember_upto_here_1 (y); return scm_c_make_rectangular (rx / dby, ix / dby); @@ -8179,6 +8458,9 @@ do_divide (SCM x, SCM y, int inexact) } else if (SCM_FRACTIONP (y)) { + /* FIXME: Precision may be lost here due to: + (1) The conversion from fraction to double + (2) Double rounding */ double yy = scm_i_fraction2double (y); return scm_c_make_rectangular (rx / yy, ix / yy); } @@ -8196,12 +8478,12 @@ do_divide (SCM x, SCM y, int inexact) else #endif return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x), - scm_product (SCM_FRACTION_DENOMINATOR (x), y)); + scm_product (SCM_FRACTION_DENOMINATOR (x), y)); } else if (SCM_BIGP (y)) { return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x), - scm_product (SCM_FRACTION_DENOMINATOR (x), y)); + scm_product (SCM_FRACTION_DENOMINATOR (x), y)); } else if (SCM_REALP (y)) { @@ -8211,33 +8493,28 @@ do_divide (SCM x, SCM y, int inexact) scm_num_overflow (s_divide); else #endif + /* FIXME: Precision may be lost here due to: + (1) The conversion from fraction to double + (2) Double rounding */ return scm_from_double (scm_i_fraction2double (x) / yy); } else if (SCM_COMPLEXP (y)) { + /* FIXME: Precision may be lost here due to: + (1) The conversion from fraction to double + (2) Double rounding */ a = scm_i_fraction2double (x); goto complex_div; } else if (SCM_FRACTIONP (y)) return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)), - scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))); + scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))); else return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide); } else return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARG1, s_divide); } - -SCM -scm_divide (SCM x, SCM y) -{ - return do_divide (x, y, 0); -} - -static SCM scm_divide2real (SCM x, SCM y) -{ - return do_divide (x, y, 1); -} #undef FUNC_NAME @@ -8875,8 +9152,9 @@ SCM_PRIMITIVE_GENERIC (scm_magnitude, "magnitude", 1, 0, 0, { if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z)))) return z; - return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED), - SCM_FRACTION_DENOMINATOR (z)); + return scm_i_make_ratio_already_reduced + (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED), + SCM_FRACTION_DENOMINATOR (z)); } else return scm_wta_dispatch_1 (g_scm_magnitude, z, SCM_ARG1, @@ -8973,21 +9251,35 @@ SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, if (!SCM_LIKELY (DOUBLE_IS_FINITE (val))) SCM_OUT_OF_RANGE (1, z); + else if (val == 0.0) + return SCM_INUM0; else { - mpq_t frac; - SCM q; - - mpq_init (frac); - mpq_set_d (frac, val); - q = scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac)), - scm_i_mpz2num (mpq_denref (frac))); + int expon; + SCM numerator; - /* When scm_i_make_ratio throws, we leak the memory allocated - for frac... - */ - mpq_clear (frac); - return q; + numerator = scm_i_dbl2big (ldexp (frexp (val, &expon), + DBL_MANT_DIG)); + expon -= DBL_MANT_DIG; + if (expon < 0) + { + int shift = mpz_scan1 (SCM_I_BIG_MPZ (numerator), 0); + + if (shift > -expon) + shift = -expon; + mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator), + SCM_I_BIG_MPZ (numerator), + shift); + expon += shift; + } + numerator = scm_i_normbig (numerator); + if (expon < 0) + return scm_i_make_ratio_already_reduced + (numerator, left_shift_exact_integer (SCM_INUM1, -expon)); + else if (expon > 0) + return left_shift_exact_integer (numerator, expon); + else + return numerator; } } } @@ -9423,26 +9715,20 @@ log_of_shifted_double (double x, long shift) return scm_c_make_rectangular (ans, M_PI); } -/* Returns log(n), for exact integer n of integer-length size */ -static SCM -log_of_exact_integer_with_size (SCM n, long size) -{ - long shift = size - 2 * scm_dblprec[0]; - - if (shift > 0) - return log_of_shifted_double - (scm_to_double (scm_ash (n, scm_from_long(-shift))), - shift); - else - return log_of_shifted_double (scm_to_double (n), 0); -} - /* Returns log(n), for exact integer n */ static SCM log_of_exact_integer (SCM n) { - return log_of_exact_integer_with_size - (n, scm_to_long (scm_integer_length (n))); + if (SCM_I_INUMP (n)) + return log_of_shifted_double (SCM_I_INUM (n), 0); + else if (SCM_BIGP (n)) + { + long expon; + double signif = scm_i_big2dbl_2exp (n, &expon); + return log_of_shifted_double (signif, expon); + } + else + scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1, n); } /* Returns log(n/d), for exact non-zero integers n and d */ @@ -9453,16 +9739,15 @@ log_of_fraction (SCM n, SCM d) long d_size = scm_to_long (scm_integer_length (d)); if (abs (n_size - d_size) > 1) - return (scm_difference (log_of_exact_integer_with_size (n, n_size), - log_of_exact_integer_with_size (d, d_size))); + return (scm_difference (log_of_exact_integer (n), + log_of_exact_integer (d))); else if (scm_is_false (scm_negative_p (n))) return scm_from_double - (log1p (scm_to_double (scm_divide2real (scm_difference (n, d), d)))); + (log1p (scm_i_divide2double (scm_difference (n, d), d))); else return scm_c_make_rectangular - (log1p (scm_to_double (scm_divide2real - (scm_difference (scm_abs (n), d), - d))), + (log1p (scm_i_divide2double (scm_difference (scm_abs (n), d), + d)), M_PI); } @@ -9610,25 +9895,17 @@ scm_exact_integer_sqrt (SCM k, SCM *sp, SCM *rp) { if (SCM_LIKELY (SCM_I_INUMP (k))) { - scm_t_inum kk = SCM_I_INUM (k); - scm_t_inum uu = kk; - scm_t_inum ss; + mpz_t kk, ss, rr; - if (SCM_LIKELY (kk > 0)) - { - do - { - ss = uu; - uu = (ss + kk/ss) / 2; - } while (uu < ss); - *sp = SCM_I_MAKINUM (ss); - *rp = SCM_I_MAKINUM (kk - ss*ss); - } - else if (SCM_LIKELY (kk == 0)) - *sp = *rp = SCM_INUM0; - else + if (SCM_I_INUM (k) < 0) scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k, "exact non-negative integer"); + mpz_init_set_ui (kk, SCM_I_INUM (k)); + mpz_inits (ss, rr, NULL); + mpz_sqrtrem (ss, rr, kk); + *sp = SCM_I_MAKINUM (mpz_get_ui (ss)); + *rp = SCM_I_MAKINUM (mpz_get_ui (rr)); + mpz_clears (kk, ss, rr, NULL); } else if (SCM_LIKELY (SCM_BIGP (k))) { @@ -9649,6 +9926,56 @@ scm_exact_integer_sqrt (SCM k, SCM *sp, SCM *rp) "exact non-negative integer"); } +/* Return true iff K is a perfect square. + K must be an exact integer. */ +static int +exact_integer_is_perfect_square (SCM k) +{ + int result; + + if (SCM_LIKELY (SCM_I_INUMP (k))) + { + mpz_t kk; + + mpz_init_set_si (kk, SCM_I_INUM (k)); + result = mpz_perfect_square_p (kk); + mpz_clear (kk); + } + else + { + result = mpz_perfect_square_p (SCM_I_BIG_MPZ (k)); + scm_remember_upto_here_1 (k); + } + return result; +} + +/* Return the floor of the square root of K. + K must be an exact integer. */ +static SCM +exact_integer_floor_square_root (SCM k) +{ + if (SCM_LIKELY (SCM_I_INUMP (k))) + { + mpz_t kk; + scm_t_inum ss; + + mpz_init_set_ui (kk, SCM_I_INUM (k)); + mpz_sqrt (kk, kk); + ss = mpz_get_ui (kk); + mpz_clear (kk); + return SCM_I_MAKINUM (ss); + } + else + { + SCM s; + + s = scm_i_mkbig (); + mpz_sqrt (SCM_I_BIG_MPZ (s), SCM_I_BIG_MPZ (k)); + scm_remember_upto_here_1 (k); + return scm_i_normbig (s); + } +} + SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0, (SCM z), @@ -9679,11 +10006,111 @@ SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0, } else if (SCM_NUMBERP (z)) { - double xx = scm_to_double (z); - if (xx < 0) - return scm_c_make_rectangular (0.0, sqrt (-xx)); - else - return scm_from_double (sqrt (xx)); + if (SCM_I_INUMP (z)) + { + scm_t_inum x = SCM_I_INUM (z); + + if (SCM_LIKELY (x >= 0)) + { + if (SCM_LIKELY (SCM_I_FIXNUM_BIT < DBL_MANT_DIG + || x < (1L << (DBL_MANT_DIG - 1)))) + { + double root = sqrt (x); + + /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an + integer, then the result is exact. */ + if (root == floor (root)) + return SCM_I_MAKINUM ((scm_t_inum) root); + else + return scm_from_double (root); + } + else + { + mpz_t xx; + scm_t_inum root; + + mpz_init_set_ui (xx, x); + if (mpz_perfect_square_p (xx)) + { + mpz_sqrt (xx, xx); + root = mpz_get_ui (xx); + mpz_clear (xx); + return SCM_I_MAKINUM (root); + } + else + mpz_clear (xx); + } + } + } + else if (SCM_BIGP (z)) + { + if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z))) + { + SCM root = scm_i_mkbig (); + + mpz_sqrt (SCM_I_BIG_MPZ (root), SCM_I_BIG_MPZ (z)); + scm_remember_upto_here_1 (z); + return scm_i_normbig (root); + } + else + { + long expon; + double signif = scm_i_big2dbl_2exp (z, &expon); + + if (expon & 1) + { + signif *= 2; + expon--; + } + if (signif < 0) + return scm_c_make_rectangular + (0.0, ldexp (sqrt (-signif), expon / 2)); + else + return scm_from_double (ldexp (sqrt (signif), expon / 2)); + } + } + else if (SCM_FRACTIONP (z)) + { + SCM n = SCM_FRACTION_NUMERATOR (z); + SCM d = SCM_FRACTION_DENOMINATOR (z); + + if (exact_integer_is_perfect_square (n) + && exact_integer_is_perfect_square (d)) + return scm_i_make_ratio_already_reduced + (exact_integer_floor_square_root (n), + exact_integer_floor_square_root (d)); + else + { + double xx = scm_i_divide2double (n, d); + double abs_xx = fabs (xx); + long shift = 0; + + if (SCM_UNLIKELY (abs_xx > DBL_MAX || abs_xx < DBL_MIN)) + { + shift = (scm_to_long (scm_integer_length (n)) + - scm_to_long (scm_integer_length (d))) / 2; + if (shift > 0) + d = left_shift_exact_integer (d, 2 * shift); + else + n = left_shift_exact_integer (n, -2 * shift); + xx = scm_i_divide2double (n, d); + } + + if (xx < 0) + return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx), shift)); + else + return scm_from_double (ldexp (sqrt (xx), shift)); + } + } + + /* Fallback method, when the cases above do not apply. */ + { + double xx = scm_to_double (z); + if (xx < 0) + return scm_c_make_rectangular (0.0, sqrt (-xx)); + else + return scm_from_double (sqrt (xx)); + } } else return scm_wta_dispatch_1 (g_scm_sqrt, z, 1, s_scm_sqrt); @@ -9695,8 +10122,6 @@ SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0, void scm_init_numbers () { - int i; - if (scm_install_gmp_memory_functions) mp_set_memory_functions (custom_gmp_malloc, custom_gmp_realloc, @@ -9718,18 +10143,25 @@ scm_init_numbers () flo0 = scm_from_double (0.0); flo_log10e = scm_from_double (M_LOG10E); - /* determine floating point precision */ - for (i=2; i <= SCM_MAX_DBL_RADIX; ++i) - { - init_dblprec(&scm_dblprec[i-2],i); - init_fx_radix(fx_per_radix[i-2],i); - } -#ifdef DBL_DIG - /* hard code precision for base 10 if the preprocessor tells us to... */ - scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG; -#endif - exactly_one_half = scm_divide (SCM_INUM1, SCM_I_MAKINUM (2)); + + { + /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */ + mpz_init_set_ui (scm_i_divide2double_lo2b, 1); + mpz_mul_2exp (scm_i_divide2double_lo2b, + scm_i_divide2double_lo2b, + DBL_MANT_DIG + 1); /* 2 b^p */ + mpz_sub_ui (scm_i_divide2double_lo2b, scm_i_divide2double_lo2b, 1); + } + + { + /* Set dbl_minimum_normal_mantissa to b^{p-1} */ + mpz_init_set_ui (dbl_minimum_normal_mantissa, 1); + mpz_mul_2exp (dbl_minimum_normal_mantissa, + dbl_minimum_normal_mantissa, + DBL_MANT_DIG - 1); + } + #include "libguile/numbers.x" } diff --git a/libguile/numbers.h b/libguile/numbers.h index 3c43ae421..01eb2cfcd 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -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); diff --git a/libguile/objcodes.c b/libguile/objcodes.c index c2932334b..3f51c70e0 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -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; diff --git a/libguile/poll.c b/libguile/poll.c index 1bb75727b..9ea846b6d 100644 --- a/libguile/poll.c +++ b/libguile/poll.c @@ -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" @@ -34,11 +36,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)); diff --git a/libguile/ports.c b/libguile/ports.c index 0aacacc06..31d338efe 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -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; - - if (scm_is_false (cwp_var)) - cwp_var = scm_c_private_lookup ("guile", "current-warning-port"); + static SCM cwp_var = SCM_UNDEFINED; + static scm_i_pthread_mutex_t cwp_var_mutex + = SCM_I_PTHREAD_MUTEX_INITIALIZER; + + 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)); } diff --git a/libguile/posix.c b/libguile/posix.c index 383ab76fd..a6bf90070 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -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, diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 60ba38caa..07845c317 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -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) { diff --git a/libguile/random.c b/libguile/random.c index 2db19f729..c0b04bc05 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -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 */ diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 86fce0fe7..497da2f2e 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -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, diff --git a/libguile/smob.c b/libguile/smob.c index c2347f3be..857773c18 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -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 (¤t_mark_stack_pointer, NULL); + scm_i_pthread_key_create (¤t_mark_stack_limit, NULL); + smob_gc_kind = GC_new_kind (GC_new_free_list (), GC_MAKE_PROC (GC_new_proc (smob_mark), 0), 0, diff --git a/libguile/socket.c b/libguile/socket.c index 232041479..7e735f43c 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -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,26 +25,8 @@ #endif #include <errno.h> -#include <gmp.h> #include <verify.h> -#include "libguile/_scm.h" -#include "libguile/arrays.h" -#include "libguile/feature.h" -#include "libguile/fports.h" -#include "libguile/strings.h" -#include "libguile/vectors.h" -#include "libguile/dynwind.h" -#include "libguile/srfi-13.h" - -#include "libguile/validate.h" -#include "libguile/socket.h" - -#ifdef __MINGW32__ -#include "win32-socket.h" -#include <netdb.h> -#endif - #ifdef HAVE_STDINT_H #include <stdint.h> #endif @@ -55,9 +37,6 @@ #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> @@ -65,8 +44,27 @@ #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" +#include "libguile/fports.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" +#include "libguile/dynwind.h" +#include "libguile/srfi-13.h" + +#include "libguile/validate.h" +#include "libguile/socket.h" + +#if SCM_ENABLE_DEPRECATED == 1 +# include "libguile/deprecation.h" #endif + + #if defined (HAVE_UNIX_DOMAIN_SOCKETS) && !defined (SUN_LEN) #define SUN_LEN(ptr) ((size_t) (((struct sockaddr_un *) 0)->sun_path) \ + strlen ((ptr)->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)); diff --git a/libguile/srfi-14.i.c b/libguile/srfi-14.i.c index f59a8071c..42a1c2cf2 100644 --- a/libguile/srfi-14.i.c +++ b/libguile/srfi-14.i.c @@ -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} , diff --git a/libguile/stime.c b/libguile/stime.c index 7fdbba9a7..90de697e5 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -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 diff --git a/libguile/strports.c b/libguile/strports.c index 425b08929..40f656e4b 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -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 (); diff --git a/libguile/struct.c b/libguile/struct.c index db79e7974..c7f410b63 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -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; diff --git a/libguile/struct.h b/libguile/struct.h index 97b6768ad..0aecfb979 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -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) diff --git a/libguile/texi-fragments-to-docstrings b/libguile/texi-fragments-to-docstrings new file mode 100644 index 000000000..b72390b89 --- /dev/null +++ b/libguile/texi-fragments-to-docstrings @@ -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))) diff --git a/libguile/threads.c b/libguile/threads.c index 61fc43e7f..ef771dcae 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -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; diff --git a/libguile/threads.h b/libguile/threads.h index 3030f6fdc..147e36dd8 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -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; diff --git a/libguile/vm.c b/libguile/vm.c index c26447028..ccc182afe 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -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"); diff --git a/libguile/win32-socket.c b/libguile/win32-socket.c deleted file mode 100644 index 825b4c499..000000000 --- a/libguile/win32-socket.c +++ /dev/null @@ -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); -} diff --git a/libguile/win32-socket.h b/libguile/win32-socket.h deleted file mode 100644 index 4ab9b942a..000000000 --- a/libguile/win32-socket.h +++ /dev/null @@ -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 */ |