diff --git a/THANKS b/THANKS index d34b951e2..4038d5eeb 100644 --- a/THANKS +++ b/THANKS @@ -167,6 +167,7 @@ For fixes or providing information which led to a fix: Cesar Strauss Klaus Stehle Rainer Tammer + Frank Terbeck Samuel Thibault Richard Todd Sree Harsha Totakura @@ -182,6 +183,7 @@ For fixes or providing information which led to a fix: Aaron VanDevender Sjoerd Van Leent Andreas Vögele + Chris Vine Michael Talbot-Wilson Michael Tuexen Xin Wang diff --git a/autogen.sh b/autogen.sh index 5187cd4aa..af1ade60d 100755 --- a/autogen.sh +++ b/autogen.sh @@ -15,11 +15,7 @@ autoconf --version echo "" automake --version echo "" -if test "`uname -s`" = Darwin; then - glibtool --version -else - libtool --version -fi +libtoolize --version echo "" ${M4:-m4} --version echo "" diff --git a/benchmark-suite/benchmarks/ports.bm b/benchmark-suite/benchmarks/ports.bm index 0b1d7f5f3..417725531 100644 --- a/benchmark-suite/benchmarks/ports.bm +++ b/benchmark-suite/benchmarks/ports.bm @@ -1,6 +1,6 @@ ;;; ports.bm --- Port I/O. -*- mode: scheme; coding: utf-8; -*- ;;; -;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;;; Copyright (C) 2010-2014 Free Software Foundation, Inc. ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public License @@ -87,4 +87,9 @@ (let ((str (string-concatenate (make-list 1000 "one line\n")))) (benchmark "read-line" 1000 (let ((port (open-input-string str))) - (sequence (read-line port) 1000))))) + (sequence (read-line port) 1000)))) + + (let ((str (large-string "Hello, world.\n"))) + (benchmark "read-string" 200 + (let ((port (open-input-string str))) + (read-string port))))) diff --git a/configure.ac b/configure.ac index 55bfafcec..152460132 100644 --- a/configure.ac +++ b/configure.ac @@ -692,10 +692,9 @@ AC_TYPE_GETGROUPS AC_TYPE_SIGNAL AC_TYPE_MODE_T -# On mingw -lm is empty, so this test is unnecessary, but it's -# harmless so we don't hard-code to suppress it. -# -AC_CHECK_LIB(m, cos) +dnl Check whether we need -lm. +LT_LIB_M +LIBS="$LIBS $LIBM" AC_CHECK_FUNCS(gethostbyname) if test $ac_cv_func_gethostbyname = no; then @@ -770,9 +769,6 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \ strcoll strcoll_l newlocale utimensat sched_getaffinity \ sched_setaffinity sendfile]) -AM_CONDITIONAL([BUILD_ICE_9_POPEN], - [test "x$enable_posix" = "xyes" && test "x$ac_cv_func_fork" = "xyes"]) - # Reasons for testing: # netdb.h - not in mingw # sys/param.h - not in mingw @@ -1351,8 +1347,11 @@ case "$with_threads" in # pthread_attr_get_np - "np" meaning "non portable" says it # all; specific to FreeBSD # pthread_sigmask - not available on mingw + # pthread_cancel - not available on Android (Bionic libc) # - AC_CHECK_FUNCS(pthread_attr_getstack pthread_getattr_np pthread_get_stackaddr_np pthread_attr_get_np pthread_sigmask) + AC_CHECK_FUNCS([pthread_attr_getstack pthread_getattr_np \ + pthread_get_stackaddr_np pthread_attr_get_np pthread_sigmask \ + pthread_cancel]) # On past versions of Solaris, believe 8 through 10 at least, you # had to write "pthread_once_t foo = { PTHREAD_ONCE_INIT };". diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index a23cf1ae4..296f1da5a 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -215,8 +215,9 @@ convention is used when indenting code in Emacs' Scheme mode. In addition to the standard line comments defined by R5RS, Guile has another comment type for multiline comments, called @dfn{block comments}. This type of comment begins with the character sequence -@code{#!} and ends with the characters @code{!#}, which must appear on a -line of their own. These comments are compatible with the block +@code{#!} and ends with the characters @code{!#}. + +These comments are compatible with the block comments in the Scheme Shell @file{scsh} (@pxref{The Scheme shell (scsh)}). The characters @code{#!} were chosen because they are the magic characters used in shell scripts for indicating that the name of diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi index 286a37d7e..e9d7aecf3 100644 --- a/doc/ref/api-modules.texi +++ b/doc/ref/api-modules.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2008, 2009, 2010, 2011, 2012, 2013 +@c Copyright (C) 1996, 1997, 2000-2004, 2007-2014 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -126,6 +126,16 @@ them to suit the current module's needs. For example: #:renamer (symbol-prefix-proc 'unixy:))) @end lisp +@noindent +or more simply: + +@cindex prefix +@lisp +(use-modules ((ice-9 popen) + #:select ((open-pipe . pipe-open) close-pipe) + #:prefix unixy:)) +@end lisp + Here, the interface specification is more complex than before, and the result is that a custom interface with only two bindings is created and subsequently accessed by the current module. The mapping of old to new @@ -184,21 +194,24 @@ whose public interface is found and used. @cindex binding renamer @lisp - (MODULE-NAME [#:select SELECTION] [#:renamer RENAMER]) + (MODULE-NAME [#:select SELECTION] + [#:prefix PREFIX] + [#:renamer RENAMER]) @end lisp in which case a custom interface is newly created and used. @var{module-name} is a list of symbols, as above; @var{selection} is a -list of selection-specs; and @var{renamer} is a procedure that takes a -symbol and returns its new name. A selection-spec is either a symbol or -a pair of symbols @code{(ORIG . SEEN)}, where @var{orig} is the name in -the used module and @var{seen} is the name in the using module. Note -that @var{seen} is also passed through @var{renamer}. +list of selection-specs; @var{prefix} is a symbol that is prepended to +imported names; and @var{renamer} is a procedure that takes a symbol and +returns its new name. A selection-spec is either a symbol or a pair of +symbols @code{(ORIG . SEEN)}, where @var{orig} is the name in the used +module and @var{seen} is the name in the using module. Note that +@var{seen} is also modified by @var{prefix} and @var{renamer}. -The @code{#:select} and @code{#:renamer} clauses are optional. If both are -omitted, the returned interface has no bindings. If the @code{#:select} -clause is omitted, @var{renamer} operates on the used module's public -interface. +The @code{#:select}, @code{#:prefix}, and @code{#:renamer} clauses are +optional. If all are omitted, the returned interface has no bindings. +If the @code{#:select} clause is omitted, @var{prefix} and @var{renamer} +operate on the used module's public interface. In addition to the above, @var{spec} can also include a @code{#:version} clause, of the form: @@ -584,8 +597,8 @@ expression: @lisp (library (mylib (1 2)) - (import (otherlib (3))) - (export mybinding)) + (export mybinding) + (import (otherlib (3)))) @end lisp is equivalent to the module definition: diff --git a/doc/ref/api-utility.texi b/doc/ref/api-utility.texi index ffdf27687..e2b60e2f9 100644 --- a/doc/ref/api-utility.texi +++ b/doc/ref/api-utility.texi @@ -222,7 +222,7 @@ setting of @var{obj}'s @var{property}. A single object property created by @code{make-object-property} can associate distinct property values with all Scheme values that are -distinguishable by @code{eq?} (including, for example, integers). +distinguishable by @code{eq?} (ruling out numeric values). Internally, object properties are implemented using a weak key hash table. This means that, as long as a Scheme value with property values diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 570102c27..9182bd8db 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1793,13 +1793,19 @@ Example: (system* "echo" "foo" "bar") Terminate the current process with proper unwinding of the Scheme stack. The exit status zero if @var{status} is not supplied. If @var{status} is supplied, and it is an integer, that integer is used as the exit -status. If @var{status} is @code{#t} or @code{#f}, the exit status is 0 -or 1, respectively. +status. If @var{status} is @code{#t} or @code{#f}, the exit status is +@var{EXIT_SUCCESS} or @var{EXIT_FAILURE}, respectively. The procedure @code{exit} is an alias of @code{quit}. They have the same functionality. @end deffn +@defvr {Scheme Variable} EXIT_SUCCESS +@defvrx {Scheme Variable} EXIT_FAILURE +These constants represent the standard exit codes for success (zero) or +failure (one.) +@end defvr + @deffn {Scheme Procedure} primitive-exit [status] @deffnx {Scheme Procedure} primitive-_exit [status] @deffnx {C Function} scm_primitive_exit (status) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 882b7d371..4ebf76d69 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, -@c 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014 +@c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node SRFI Support @@ -4517,11 +4517,11 @@ Create and return a vector whose elements are @var{x} @enddots{}. @end deffn @deffn {Scheme Procedure} vector-unfold f length initial-seed @dots{} -The fundamental vector constructor. Create a vector whose length is -@var{length} and iterates across each index k from 0 up to -@var{length} - 1, applying @var{f} at each iteration to the current index -and current seeds, in that order, to receive n + 1 values: first, the -element to put in the kth slot of the new vector and n new seeds for +The fundamental vector constructor. Create a vector whose length +is @var{length} and iterates across each index k from 0 up to +@var{length} - 1, applying @var{f} at each iteration to the current +index and current seeds, in that order, to receive n + 1 values: the +element to put in the kth slot of the new vector, and n new seeds for the next iteration. It is an error for the number of seeds to vary between iterations. diff --git a/doc/ref/texinfo.texi b/doc/ref/texinfo.texi index ec0686388..5006fd427 100644 --- a/doc/ref/texinfo.texi +++ b/doc/ref/texinfo.texi @@ -287,7 +287,7 @@ as an argument, and the returned value is sent to the output string via @samp{display}. If @var{replace} is anything else, it is sent through the output string via @samp{display}. -Note that te replacement for the matched characters does not need to be +Note that the replacement for the matched characters does not need to be a single character. That is what differentiates this function from @samp{string-map}, and what makes it useful for applications such as converting @samp{#\&} to @samp{"&"} in web page text. Some other diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm index 02e68af0f..df2edaf77 100644 --- a/guile-readline/ice-9/readline.scm +++ b/guile-readline/ice-9/readline.scm @@ -119,7 +119,8 @@ (define-once the-readline-port #f) (define-once history-variable "GUILE_HISTORY") -(define-once history-file (string-append (getenv "HOME") "/.guile_history")) +(define-once history-file + (string-append (or (getenv "HOME") ".") "/.guile_history")) (define-public readline-port (let ((do (lambda (r/w) diff --git a/libguile/async.h b/libguile/async.h index e6fe5237c..00b791449 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -3,7 +3,8 @@ #ifndef SCM_ASYNC_H #define SCM_ASYNC_H -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008, 2009, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2008, 2009, 2011 + * 2014 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 @@ -44,10 +45,10 @@ SCM_API SCM scm_run_asyncs (SCM list_of_a); SCM_API SCM scm_noop (SCM args); SCM_API SCM scm_call_with_blocked_asyncs (SCM proc); SCM_API SCM scm_call_with_unblocked_asyncs (SCM proc); -void *scm_c_call_with_blocked_asyncs (void *(*p) (void *d), void *d); -void *scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d); -void scm_dynwind_block_asyncs (void); -void scm_dynwind_unblock_asyncs (void); +SCM_API void *scm_c_call_with_blocked_asyncs (void *(*p) (void *d), void *d); +SCM_API void *scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d); +SCM_API void scm_dynwind_block_asyncs (void); +SCM_API void scm_dynwind_unblock_asyncs (void); /* Critical sections */ diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index c7908d75c..dda912ff0 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 2009-2014 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 @@ -332,10 +332,16 @@ scm_c_shrink_bytevector (SCM bv, size_t c_new_len) SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len); if (SCM_BYTEVECTOR_CONTIGUOUS_P (bv)) - new_bv = PTR2SCM (scm_gc_realloc (SCM2PTR (bv), - c_len + SCM_BYTEVECTOR_HEADER_BYTES, - c_new_len + SCM_BYTEVECTOR_HEADER_BYTES, - SCM_GC_BYTEVECTOR)); + { + signed char *c_bv; + + c_bv = scm_gc_realloc (SCM2PTR (bv), + c_len + SCM_BYTEVECTOR_HEADER_BYTES, + c_new_len + SCM_BYTEVECTOR_HEADER_BYTES, + SCM_GC_BYTEVECTOR); + new_bv = PTR2SCM (c_bv); + SCM_BYTEVECTOR_SET_CONTENTS (new_bv, c_bv + SCM_BYTEVECTOR_HEADER_BYTES); + } else { signed char *c_bv; diff --git a/libguile/debug.c b/libguile/debug.c index f9bcc33db..878777d56 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -27,6 +27,11 @@ #include #endif +#ifdef __MINGW32__ +# define WIN32_LEAN_AND_MEAN +# include +#endif + #include "libguile/_scm.h" #include "libguile/async.h" #include "libguile/eval.h" @@ -180,7 +185,7 @@ scm_local_eval (SCM exp, SCM env) static void init_stack_limit (void) { -#ifdef HAVE_GETRLIMIT +#if defined HAVE_GETRLIMIT struct rlimit lim; if (getrlimit (RLIMIT_STACK, &lim) == 0) { @@ -194,6 +199,16 @@ init_stack_limit (void) SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits); } errno = 0; +#elif defined __MINGW32__ + MEMORY_BASIC_INFORMATION m; + uintptr_t bytes; + + if (VirtualQuery ((LPCVOID) &m, &m, sizeof m)) + { + bytes = (DWORD_PTR) m.BaseAddress + m.RegionSize + - (DWORD_PTR) m.AllocationBase; + SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits); + } #endif } diff --git a/libguile/filesys.c b/libguile/filesys.c index a2280a51a..204d74eed 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -50,6 +50,7 @@ #include "libguile/validate.h" #include "libguile/filesys.h" +#include "libguile/load.h" /* for scm_i_mirror_backslashes */ #ifdef HAVE_IO_H @@ -1238,6 +1239,9 @@ SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0, errno = save_errno; SCM_SYSERROR; } + /* On Windows, convert backslashes in current directory to forward + slashes. */ + scm_i_mirror_backslashes (wd); result = scm_from_locale_stringn (wd, strlen (wd)); free (wd); return result; diff --git a/libguile/foreign.c b/libguile/foreign.c index 5ee225da4..0cab6b8b0 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2010, 2011, 2012, 2013 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 diff --git a/libguile/fports.c b/libguile/fports.c index e4038def6..cbd3a618f 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -155,7 +155,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, int cmode; long csize; size_t ndrained; - char *drained; + char *drained = NULL; scm_t_port *pt; scm_t_ptob_descriptor *ptob; diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 650ea668b..329241da2 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1995-2001, 2006, 2008-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 diff --git a/libguile/i18n.c b/libguile/i18n.c index 0f607f331..c6b9b845e 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 2006-2014 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 @@ -1465,6 +1465,14 @@ SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact", Note: We don't use Gnulib's `nl_langinfo' module because it's currently not as complete as the compatibility hacks in `i18n.scm'. */ +static char * +copy_string_or_null (const char *s) +{ + if (s == NULL) + return NULL; + else + return strdup (s); +} SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, (SCM item, SCM locale), @@ -1496,8 +1504,8 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, if (c_locale != NULL) { #ifdef USE_GNU_LOCALE_API - c_result = nl_langinfo_l (c_item, c_locale); - codeset = nl_langinfo_l (CODESET, c_locale); + c_result = copy_string_or_null (nl_langinfo_l (c_item, c_locale)); + codeset = copy_string_or_null (nl_langinfo_l (CODESET, c_locale)); #else /* !USE_GNU_LOCALE_API */ /* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale mutex is already taken. */ @@ -1521,8 +1529,8 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, scm_locale_error (FUNC_NAME, lsec_err); else { - c_result = nl_langinfo (c_item); - codeset = nl_langinfo (CODESET); + c_result = copy_string_or_null (nl_langinfo (c_item)); + codeset = copy_string_or_null (nl_langinfo (CODESET)); restore_locale_settings (&lsec_prev_locale); free_locale_settings (&lsec_prev_locale); @@ -1531,13 +1539,10 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, } else { - c_result = nl_langinfo (c_item); - codeset = nl_langinfo (CODESET); + c_result = copy_string_or_null (nl_langinfo (c_item)); + codeset = copy_string_or_null (nl_langinfo (CODESET)); } - if (c_result != NULL) - c_result = strdup (c_result); - unlock_locale_mutex (); if (c_result == NULL) @@ -1580,9 +1585,13 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, } #endif -#if (defined FRAC_DIGITS) && (defined INT_FRAC_DIGITS) +#if defined FRAC_DIGITS || defined INT_FRAC_DIGITS +#ifdef FRAC_DIGITS case FRAC_DIGITS: +#endif +#ifdef INT_FRAC_DIGITS case INT_FRAC_DIGITS: +#endif /* This is to be interpreted as a single integer. */ if (*c_result == CHAR_MAX) /* Unspecified. */ @@ -1594,12 +1603,18 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, break; #endif -#if (defined P_CS_PRECEDES) && (defined INT_N_CS_PRECEDES) +#if defined P_CS_PRECEDES || defined N_CS_PRECEDES || \ + defined INT_P_CS_PRECEDES || defined INT_N_CS_PRECEDES || \ + defined P_SEP_BY_SPACE || defined N_SEP_BY_SPACE +#ifdef P_CS_PRECEDES case P_CS_PRECEDES: case N_CS_PRECEDES: +#endif +#ifdef INT_N_CS_PRECEDES case INT_P_CS_PRECEDES: case INT_N_CS_PRECEDES: -#if (defined P_SEP_BY_SPACE) && (defined N_SEP_BY_SPACE) +#endif +#ifdef P_SEP_BY_SPACE case P_SEP_BY_SPACE: case N_SEP_BY_SPACE: #endif @@ -1610,11 +1625,16 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, break; #endif -#if (defined P_SIGN_POSN) && (defined INT_N_SIGN_POSN) +#if defined P_SIGN_POSN || defined N_SIGN_POSN || \ + defined INT_P_SIGN_POSN || defined INT_N_SIGN_POSN +#ifdef P_SIGN_POSN case P_SIGN_POSN: case N_SIGN_POSN: +#endif +#ifdef INT_P_SIGN_POSN case INT_P_SIGN_POSN: case INT_N_SIGN_POSN: +#endif /* See `(libc) Sign of Money Amount' for the interpretation of the return value here. */ switch (*c_result) @@ -1654,6 +1674,9 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, } } + if (codeset != NULL) + free (codeset); + return result; } #undef FUNC_NAME diff --git a/libguile/init.c b/libguile/init.c index 50ea1966f..d2928bd60 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -310,6 +310,9 @@ scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure) void *res; struct main_func_closure c; + /* On Windows, convert backslashes in argv[0] to forward + slashes. */ + scm_i_mirror_backslashes (argv[0]); c.main_func = main_func; c.closure = closure; c.argc = argc; diff --git a/libguile/list.c b/libguile/list.c index 41cc937f7..27ac22f2b 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -1,5 +1,5 @@ -/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008,2009,2010,2011 - * Free Software Foundation, Inc. +/* Copyright (C) 1995-1997, 2000, 2001, 2003, 2004, 2008-2011, + * 2014 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 @@ -179,24 +179,25 @@ SCM_DEFINE (scm_list_p, "list?", 1, 0, 0, long" lists (i.e. lists with cycles in their cdrs), and returns -1 if it does find one. */ long -scm_ilength(SCM sx) +scm_ilength (SCM sx) { long i = 0; SCM tortoise = sx; SCM hare = sx; - do { - if (SCM_NULL_OR_NIL_P(hare)) return i; - if (!scm_is_pair (hare)) return -1; - hare = SCM_CDR(hare); - i++; - if (SCM_NULL_OR_NIL_P(hare)) return i; - if (!scm_is_pair (hare)) return -1; - hare = SCM_CDR(hare); - i++; - /* For every two steps the hare takes, the tortoise takes one. */ - tortoise = SCM_CDR(tortoise); - } + do + { + if (!scm_is_pair (hare)) + return SCM_NULL_OR_NIL_P (hare) ? i : -1; + hare = SCM_CDR (hare); + i++; + if (!scm_is_pair (hare)) + return SCM_NULL_OR_NIL_P (hare) ? i : -1; + hare = SCM_CDR (hare); + i++; + /* For every two steps the hare takes, the tortoise takes one. */ + tortoise = SCM_CDR (tortoise); + } while (!scm_is_eq (hare, tortoise)); /* If the tortoise ever catches the hare, then the list must contain diff --git a/libguile/load.c b/libguile/load.c index d24b4ae02..a68d96d7d 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -276,6 +276,41 @@ SCM_DEFINE (scm_parse_path_with_ellipsis, "parse-path-with-ellipsis", 2, 0, 0, } #undef FUNC_NAME +/* On Posix hosts, just return PATH unaltered. On Windows, + destructively replace all backslashes in PATH with Unix-style + forward slashes, so that Scheme code always gets d:/foo/bar style + file names. This avoids multiple subtle problems with comparing + file names as strings, and with redirections in /bin/sh command + lines. + + Note that, if PATH is result of a call to 'getenv', this + destructively modifies the environment variables, so both + scm_getenv and subprocesses will afterwards see the values with + forward slashes. That is OK as long as applied to Guile-specific + environment variables, since having scm_getenv return the same + value as used by the callers of this function is good for + consistency and file-name comparison. Avoid using this function on + values returned by 'getenv' for general-purpose environment + variables; instead, make a copy of the value and work on that. */ +SCM_INTERNAL char * +scm_i_mirror_backslashes (char *path) +{ +#ifdef __MINGW32__ + if (path) + { + char *p = path; + + while (*p) + { + if (*p == '\\') + *p = '/'; + p++; + } + } +#endif + + return path; +} /* Initialize the global variable %load-path, given the value of the SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the @@ -288,7 +323,7 @@ scm_init_load_path () SCM cpath = SCM_EOL; #ifdef SCM_LIBRARY_DIR - env = getenv ("GUILE_SYSTEM_PATH"); + env = scm_i_mirror_backslashes (getenv ("GUILE_SYSTEM_PATH")); if (env && strcmp (env, "") == 0) /* special-case interpret system-path=="" as meaning no system path instead of '("") */ @@ -301,7 +336,7 @@ scm_init_load_path () scm_from_locale_string (SCM_GLOBAL_SITE_DIR), scm_from_locale_string (SCM_PKGDATA_DIR)); - env = getenv ("GUILE_SYSTEM_COMPILED_PATH"); + env = scm_i_mirror_backslashes (getenv ("GUILE_SYSTEM_COMPILED_PATH")); if (env && strcmp (env, "") == 0) /* like above */ ; @@ -344,14 +379,17 @@ scm_init_load_path () cachedir[0] = 0; if (cachedir[0]) - *scm_loc_compile_fallback_path = scm_from_locale_string (cachedir); + { + scm_i_mirror_backslashes (cachedir); + *scm_loc_compile_fallback_path = scm_from_locale_string (cachedir); + } } - env = getenv ("GUILE_LOAD_PATH"); + env = scm_i_mirror_backslashes (getenv ("GUILE_LOAD_PATH")); if (env) path = scm_parse_path_with_ellipsis (scm_from_locale_string (env), path); - env = getenv ("GUILE_LOAD_COMPILED_PATH"); + env = scm_i_mirror_backslashes (getenv ("GUILE_LOAD_COMPILED_PATH")); if (env) cpath = scm_parse_path_with_ellipsis (scm_from_locale_string (env), cpath); @@ -451,11 +489,10 @@ scm_c_string_has_an_ext (char *str, size_t len, SCM extensions) return 0; } -#ifdef __MINGW32__ -#define FILE_NAME_SEPARATOR_STRING "\\" -#else +/* Defined as "/" for Unix and Windows alike, so that file names + constructed by the functions in this module wind up with Unix-style + forward slashes as directory separators. */ #define FILE_NAME_SEPARATOR_STRING "/" -#endif static int is_file_name_separator (SCM c) @@ -619,7 +656,8 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, if (stat (buf.buf, stat_buf) == 0 && ! (stat_buf->st_mode & S_IFDIR)) { - result = scm_from_locale_string (buf.buf); + result = + scm_from_locale_string (scm_i_mirror_backslashes (buf.buf)); goto end; } } @@ -876,7 +914,7 @@ canonical_suffix (SCM fname) /* CANON should be absolute. */ canon = scm_canonicalize_path (fname); - + #ifdef __MINGW32__ { size_t len = scm_c_string_length (canon); diff --git a/libguile/load.h b/libguile/load.h index ab75ea3b3..986948d3f 100644 --- a/libguile/load.h +++ b/libguile/load.h @@ -44,6 +44,7 @@ SCM_INTERNAL void scm_init_load_path (void); SCM_INTERNAL void scm_init_load (void); SCM_INTERNAL void scm_init_load_should_auto_compile (void); SCM_INTERNAL void scm_init_eval_in_scheme (void); +SCM_INTERNAL char *scm_i_mirror_backslashes (char *path); #endif /* SCM_LOAD_H */ diff --git a/libguile/locale-categories.h b/libguile/locale-categories.h index 26b030dc5..fb5ac1081 100644 --- a/libguile/locale-categories.h +++ b/libguile/locale-categories.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 2006, 2008, 2014 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 @@ -23,8 +23,10 @@ SCM_DEFINE_LOCALE_CATEGORY (COLLATE) SCM_DEFINE_LOCALE_CATEGORY (CTYPE) -#ifdef LC_MESSAGES -/* MinGW doesn't have `LC_MESSAGES'. */ +#if defined(LC_MESSAGES) && !(defined(LC_MAX) && LC_MESSAGES > LC_MAX) +/* MinGW doesn't have `LC_MESSAGES'. libintl.h might define + `LC_MESSAGES' for MinGW to an arbitrary large value which we cannot + use in a call to `setlocale'. */ SCM_DEFINE_LOCALE_CATEGORY (MESSAGES) #endif diff --git a/libguile/posix.c b/libguile/posix.c index ae0f7c3c3..494df1e0c 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1346,23 +1346,21 @@ scm_open_process (SCM mode, SCM prog, SCM args) SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F; /* There is no sense in catching errors on close(). */ - if (reading) + if (reading) { close (c2p[1]); - read_port = scm_fdes_to_port (c2p[0], "r", sym_read_pipe); - scm_setvbuf (read_port, scm_from_int (_IONBF), SCM_UNDEFINED); + read_port = scm_fdes_to_port (c2p[0], "r0", sym_read_pipe); } if (writing) { close (p2c[0]); - write_port = scm_fdes_to_port (p2c[1], "w", sym_write_pipe); - scm_setvbuf (write_port, scm_from_int (_IONBF), SCM_UNDEFINED); + write_port = scm_fdes_to_port (p2c[1], "w0", sym_write_pipe); } - + return scm_values (scm_list_3 (read_port, write_port, scm_from_int (pid))); } - + /* The child. */ if (reading) close (c2p[0]); @@ -1982,9 +1980,9 @@ cpu_set_to_bitvector (const cpu_set_t *cs) SCM bv; size_t cpu; - bv = scm_c_make_bitvector (sizeof (*cs), SCM_BOOL_F); + bv = scm_c_make_bitvector (CPU_SETSIZE, SCM_BOOL_F); - for (cpu = 0; cpu < sizeof (*cs); cpu++) + for (cpu = 0; cpu < CPU_SETSIZE; cpu++) { if (CPU_ISSET (cpu, cs)) /* XXX: This is inefficient but avoids code duplication. */ @@ -2250,6 +2248,12 @@ void scm_init_posix () { scm_add_feature ("posix"); +#ifdef EXIT_SUCCESS + scm_c_define ("EXIT_SUCCESS", scm_from_int (EXIT_SUCCESS)); +#endif +#ifdef EXIT_FAILURE + scm_c_define ("EXIT_FAILURE", scm_from_int (EXIT_FAILURE)); +#endif #ifdef HAVE_GETEUID scm_add_feature ("EIDs"); #endif diff --git a/libguile/simpos.c b/libguile/simpos.c index a657a8f09..70058285a 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -45,6 +45,10 @@ # include #endif +#ifdef __MINGW32__ +# include /* for spawnvp and friends */ +#endif + #include "posix.h" @@ -86,8 +90,6 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, #ifdef HAVE_SYSTEM -#ifdef HAVE_WAITPID - SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, (SCM args), @@ -115,11 +117,18 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, if (scm_is_pair (args)) { SCM oldint; - SCM oldquit; SCM sig_ign; SCM sigint; + /* SIGQUIT is undefined on MS-Windows. */ +#ifdef SIGQUIT + SCM oldquit; SCM sigquit; +#endif +#ifdef HAVE_FORK int pid; +#else + int status; +#endif char **execargv; /* allocate before fork */ @@ -128,10 +137,13 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, /* make sure the child can't kill us (as per normal system call) */ sig_ign = scm_from_ulong ((unsigned long) SIG_IGN); sigint = scm_from_int (SIGINT); - sigquit = scm_from_int (SIGQUIT); oldint = scm_sigaction (sigint, sig_ign, SCM_UNDEFINED); +#ifdef SIGQUIT + sigquit = scm_from_int (SIGQUIT); oldquit = scm_sigaction (sigquit, sig_ign, SCM_UNDEFINED); - +#endif + +#ifdef HAVE_FORK pid = fork (); if (pid == 0) { @@ -164,12 +176,20 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, return scm_from_int (status); } +#else /* !HAVE_FORK */ + status = spawnvp (P_WAIT, execargv[0], (const char * const *)execargv); + scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint)); +#ifdef SIGQUIT + scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit)); +#endif + + return scm_from_int (status); +#endif /* !HAVE_FORK */ } else SCM_WRONG_TYPE_ARG (1, args); } #undef FUNC_NAME -#endif /* HAVE_WAITPID */ #endif /* HAVE_SYSTEM */ diff --git a/libguile/smob.h b/libguile/smob.h index 37ea64247..0e59f89d0 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -147,14 +147,14 @@ scm_new_double_smob (scm_t_bits tc, scm_t_bits data1, #define SCM_SET_SMOB_OBJECT_1(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 1, (obj))) #define SCM_SET_SMOB_OBJECT_2(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 2, (obj))) #define SCM_SET_SMOB_OBJECT_3(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 3, (obj))) -#define SCM_SMOB_OBJECT_0_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 0))) -#define SCM_SMOB_OBJECT_1_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 1))) -#define SCM_SMOB_OBJECT_2_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 2))) -#define SCM_SMOB_OBJECT_3_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 3))) +#define SCM_SMOB_OBJECT_0_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 0)) +#define SCM_SMOB_OBJECT_1_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 1)) +#define SCM_SMOB_OBJECT_2_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 2)) +#define SCM_SMOB_OBJECT_3_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 3)) #define SCM_SMOB_OBJECT(x) (SCM_SMOB_OBJECT_1 (x)) #define SCM_SET_SMOB_OBJECT(x,obj) (SCM_SET_SMOB_OBJECT_1 ((x), (obj))) -#define SCM_SMOB_OBJECT_LOC(x) (SCM_SMOB_OBJECT_1_LOC (x))) +#define SCM_SMOB_OBJECT_LOC(x) (SCM_SMOB_OBJECT_1_LOC (x)) #define SCM_SMOB_APPLY_0(x) (scm_call_0 (x)) diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index aaa3efe6c..353a746f5 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -1,7 +1,7 @@ /* srfi-1.c --- SRFI-1 procedures for Guile * - * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006, - * 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. + * Copyright (C) 1995-1997, 2000-2003, 2005, 2006, 2008-2011, 2013 + * 2014 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 @@ -614,8 +614,40 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0, "circular.") #define FUNC_NAME s_scm_srfi1_length_plus { - long len = scm_ilength (lst); - return (len >= 0 ? SCM_I_MAKINUM (len) : SCM_BOOL_F); + size_t i = 0; + SCM tortoise = lst; + SCM hare = lst; + + do + { + if (!scm_is_pair (hare)) + { + if (SCM_NULL_OR_NIL_P (hare)) + return scm_from_size_t (i); + else + scm_wrong_type_arg_msg (FUNC_NAME, 1, lst, + "proper or circular list"); + } + hare = SCM_CDR (hare); + i++; + if (!scm_is_pair (hare)) + { + if (SCM_NULL_OR_NIL_P (hare)) + return scm_from_size_t (i); + else + scm_wrong_type_arg_msg (FUNC_NAME, 1, lst, + "proper or circular list"); + } + hare = SCM_CDR (hare); + i++; + /* For every two steps the hare takes, the tortoise takes one. */ + tortoise = SCM_CDR (tortoise); + } + while (!scm_is_eq (hare, tortoise)); + + /* If the tortoise ever catches the hare, then the list must contain + a cycle. */ + return SCM_BOOL_F; } #undef FUNC_NAME diff --git a/libguile/threads.c b/libguile/threads.c index bcf1e0d63..3dc0f40c3 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1036,6 +1036,11 @@ SCM_DEFINE (scm_yield, "yield", 0, 0, 0, } #undef FUNC_NAME +/* Some systems, notably Android, lack 'pthread_cancel'. Don't provide + 'cancel-thread' on these systems. */ + +#if !SCM_USE_PTHREAD_THREADS || defined HAVE_PTHREAD_CANCEL + SCM_DEFINE (scm_cancel_thread, "cancel-thread", 1, 0, 0, (SCM thread), "Asynchronously force the target @var{thread} to terminate. @var{thread} " @@ -1061,6 +1066,8 @@ SCM_DEFINE (scm_cancel_thread, "cancel-thread", 1, 0, 0, } #undef FUNC_NAME +#endif + SCM_DEFINE (scm_set_thread_cleanup_x, "set-thread-cleanup!", 2, 0, 0, (SCM thread, SCM proc), "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. " diff --git a/module/Makefile.am b/module/Makefile.am index 8de297245..7b3a4a8b9 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -198,7 +198,9 @@ SCRIPTS_SOURCES = \ scripts/summarize-guile-TODO.scm \ scripts/api-diff.scm \ scripts/read-rfc822.scm \ - scripts/snarf-guile-m4-docs.scm + scripts/snarf-guile-m4-docs.scm \ + scripts/autofrisk.scm \ + scripts/scan-api.scm SYSTEM_BASE_SOURCES = \ system/base/pmatch.scm \ @@ -248,6 +250,7 @@ ICE_9_SOURCES = \ ice-9/peg.scm \ ice-9/poe.scm \ ice-9/poll.scm \ + ice-9/popen.scm \ ice-9/posix.scm \ ice-9/q.scm \ ice-9/rdelim.scm \ @@ -280,18 +283,6 @@ ICE_9_SOURCES = \ ice-9/local-eval.scm \ ice-9/unicode.scm -if BUILD_ICE_9_POPEN - -# This functionality is missing on systems without `fork'---i.e., Windows. -ICE_9_SOURCES += ice-9/popen.scm - -# These modules rely on (ice-9 popen). -SCRIPTS_SOURCES += \ - scripts/autofrisk.scm \ - scripts/scan-api.scm - -endif BUILD_ICE_9_POPEN - srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm SRFI_SOURCES = \ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 7f38c4b19..a5b3422bc 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1,8 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- -;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, -;;;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 -;;;; Free Software Foundation, Inc. +;;;; Copyright (C) 1995-2014 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 @@ -430,13 +428,15 @@ file with the given name already exists, the effect is unspecified." (syntax-rules () ((_) #t) ((_ x) x) - ((_ x y ...) (if x (and y ...) #f)))) + ;; Avoid ellipsis, which would lead to quadratic expansion time. + ((_ x . y) (if x (and . y) #f)))) (define-syntax or (syntax-rules () ((_) #f) ((_ x) x) - ((_ x y ...) (let ((t x)) (if t t (or y ...)))))) + ;; Avoid ellipsis, which would lead to quadratic expansion time. + ((_ x . y) (let ((t x)) (if t t (or . y)))))) (include-from-path "ice-9/quasisyntax") @@ -1891,7 +1891,7 @@ written into the port is returned." (or (char=? c #\/) (char=? c #\\))) - (define file-name-separator-string "\\") + (define file-name-separator-string "/") (define (absolute-file-name? file-name) (define (file-name-separator-at-index? idx) @@ -1982,7 +1982,7 @@ written into the port is returned." (define-syntax-rule (add-to-load-path elt) "Add ELT to Guile's load path, at compile-time and at run-time." (eval-when (expand load eval) - (set! %load-path (cons elt %load-path)))) + (set! %load-path (cons elt (delete elt %load-path))))) (define %load-verbosely #f) (define (assert-load-verbosity v) (set! %load-verbosely v)) diff --git a/module/ice-9/curried-definitions.scm b/module/ice-9/curried-definitions.scm index fa369906c..7545338e3 100644 --- a/module/ice-9/curried-definitions.scm +++ b/module/ice-9/curried-definitions.scm @@ -17,7 +17,8 @@ (define-module (ice-9 curried-definitions) #:replace ((cdefine . define) (cdefine* . define*) - define-public)) + define-public + define*-public)) (define-syntax cdefine (syntax-rules () @@ -44,3 +45,13 @@ (begin (define name val) (export name))))) + +(define-syntax define*-public + (syntax-rules () + ((_ (head . rest) body body* ...) + (define*-public head + (lambda* rest body body* ...))) + ((_ name val) + (begin + (define* name val) + (export name))))) diff --git a/module/ice-9/rdelim.scm b/module/ice-9/rdelim.scm index 32908cc4a..a406f4e55 100644 --- a/module/ice-9/rdelim.scm +++ b/module/ice-9/rdelim.scm @@ -1,7 +1,8 @@ ;;; installed-scm-file -;;;; Copyright (C) 1997, 1999, 2000, 2001, 2006, 2010, 2013 Free Software Foundation, Inc. -;;;; +;;;; Copyright (C) 1997, 1999, 2000, 2001, 2006, 2010, 2013, +;;;; 2014 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 @@ -148,26 +149,29 @@ left in the port." (lp (1+ n))))) (- n start)))) -(define* (read-string #:optional (port (current-input-port)) (count #f)) - "Read all of the characters out of PORT and return them as a string. +(define* read-string + (case-lambda* + "Read all of the characters out of PORT and return them as a string. If the COUNT argument is present, treat it as a limit to the number of characters to read. By default, there is no limit." - (check-arg (or (not count) (index? count)) "bad count" count) - (let loop ((substrings '()) - (total-chars 0) - (buf-size 100)) ; doubled each time through. - (let* ((buf (make-string (if count - (min buf-size (- count total-chars)) - buf-size))) - (nchars (read-string! buf port)) - (new-total (+ total-chars nchars))) - (cond - ((= nchars buf-size) - ;; buffer filled. - (loop (cons buf substrings) new-total (* buf-size 2))) - (else - (string-concatenate-reverse - (cons (substring buf 0 nchars) substrings))))))) + ((#:optional (port (current-input-port))) + ;; Fast path. + ;; This creates more garbage than using 'string-set!' as in + ;; 'read-string!', but currently that is faster nonetheless. + (let loop ((chars '())) + (let ((char (read-char port))) + (if (eof-object? char) + (list->string (reverse! chars)) + (loop (cons char chars)))))) + ((port count) + ;; Slower path. + (let loop ((chars '()) + (total 0)) + (let ((char (read-char port))) + (if (or (eof-object? char) (>= total count)) + (list->string (reverse chars)) + (loop (cons char chars) (+ 1 total)))))))) + ;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string ;;; from PORT. The return value depends on the value of HANDLE-DELIM, diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 0ce7344e7..1c0612764 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -1,6 +1,6 @@ ;;; TREE-IL -> GLIL compiler -;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2008-2014 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 @@ -1222,6 +1222,16 @@ given `tree-il' element." conditions end-group (+ 1 min-count) (+ 1 max-count))) + ((#\p #\P) (let* ((colon? (memq #\: params)) + (min-count (if colon? + (max 1 min-count) + (+ 1 min-count)))) + (loop (cdr chars) 'literal '() + conditions end-group + min-count + (if colon? + (max max-count min-count) + (+ 1 max-count))))) ((#\[) (loop chars 'literal '() '() (let ((selector (previous-number params)) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index f70d3b154..3daa2ecc7 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1,6 +1,6 @@ ;;; Tree-IL partial evaluator -;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2011-2014 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 @@ -1405,18 +1405,31 @@ top-level bindings from ENV and return the resulting expression." gensyms (append req-vals opt-vals rest-vals) body) - ;; The required argument values are in the scope - ;; of the optional argument initializers. + ;; The default initializers of optional arguments + ;; may refer to earlier arguments, so in the general + ;; case we must expand into a series of nested let + ;; expressions. + ;; + ;; In the generated code, the outermost let + ;; expression will bind all required arguments, as + ;; well as the empty rest argument, if any. Each + ;; optional argument will be bound within an inner + ;; let. (make-let src (append req rest) (append (list-head gensyms nreq) (last-pair gensyms)) (append req-vals rest-vals) - (make-let src - opt - (list-head (drop gensyms nreq) nopt) - opt-vals - body))))) + (fold-right (lambda (var gensym val body) + (make-let src + (list var) + (list gensym) + (list val) + body)) + body + opt + (list-head (drop gensyms nreq) nopt) + opt-vals))))) (cond ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt)))) diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index ab2c456d4..5b644c3d4 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -1,6 +1,6 @@ ;;; Compile --- Command-line Guile Scheme compiler -*- coding: iso-8859-1 -*- -;; Copyright 2005,2008,2009,2010,2011,2013 Free Software Foundation, Inc. +;; Copyright 2005, 2008-2011, 2013, 2014 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -176,6 +176,14 @@ Report bugs to <~A>.~%" (fail "`-o' option can only be specified " "when compiling a single file")) + ;; Install a SIGINT handler. As a side effect, this gives unwind + ;; handlers an opportunity to run upon SIGINT; this includes that of + ;; 'call-with-output-file/atomic', called by 'compile-file', which + ;; removes the temporary output file. + (sigaction SIGINT + (lambda args + (fail "interrupted by the user"))) + (for-each (lambda (file) (format #t "wrote `~A'\n" (with-fluids ((*current-warning-prefix* "")) diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm index 88a3f3fec..153b0cbcd 100644 --- a/module/srfi/srfi-43.scm +++ b/module/srfi/srfi-43.scm @@ -104,10 +104,10 @@ The fundamental vector constructor. Create a vector whose length is LENGTH and iterates across each index k from 0 up to LENGTH - 1, -applying F at each iteration to the current index and current seeds, -in that order, to receive n + 1 values: first, the element to put in -the kth slot of the new vector and n new seeds for the next iteration. -It is an error for the number of seeds to vary between iterations." +applying F at each iteration to the current index and current seeds, in +that order, to receive n + 1 values: the element to put in the kth slot +of the new vector, and n new seeds for the next iteration. It is an +error for the number of seeds to vary between iterations." ((f len) (assert-procedure f 'vector-unfold) (assert-nonneg-exact-integer len 'vector-unfold) @@ -154,10 +154,10 @@ It is an error for the number of seeds to vary between iterations." The fundamental vector constructor. Create a vector whose length is LENGTH and iterates across each index k from LENGTH - 1 down to 0, -applying F at each iteration to the current index and current seeds, -in that order, to receive n + 1 values: first, the element to put in -the kth slot of the new vector and n new seeds for the next iteration. -It is an error for the number of seeds to vary between iterations." +applying F at each iteration to the current index and current seeds, in +that order, to receive n + 1 values: the element to put in the kth slot +of the new vector, and n new seeds for the next iteration. It is an +error for the number of seeds to vary between iterations." ((f len) (assert-procedure f 'vector-unfold-right) (assert-nonneg-exact-integer len 'vector-unfold-right) @@ -304,7 +304,7 @@ from the subsequent locations in VEC ..." Append each vector in LIST-OF-VECTORS. Equivalent to: (apply vector-append LIST-OF-VECTORS)" - (assert-vectors vs 'vector-append) + (assert-vectors vs 'vector-concatenate) (%vector-concatenate vs)) (define (vector-empty? vec) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index ce5ff33d6..e5456749b 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -1,6 +1,6 @@ ;;; Compilation targets -;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012, 2013, 2014 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 @@ -70,6 +70,14 @@ (endianness big)) ((string-match "^arm.*el" cpu) (endianness little)) + ((string-match "^arm.*eb" cpu) + (endianness big)) + ((string-prefix? "arm" cpu) ;ARMs are LE by default + (endianness little)) + ((string-match "^aarch64.*be" cpu) + (endianness big)) + ((string=? "aarch64" cpu) + (endianness little)) (else (error "unknown CPU endianness" cpu))))) @@ -93,7 +101,7 @@ ((string-match "^x86_64-.*-gnux32" triplet) 4) ; x32 ((string-match "64$" cpu) 8) - ((string-match "64[lbe][lbe]$" cpu) 8) + ((string-match "64_?[lbe][lbe]$" cpu) 8) ((member cpu '("sparc" "powerpc" "mips" "mipsel")) 4) ((string-match "^arm.*" cpu) 4) (else (error "unknown CPU word size" cpu))))) diff --git a/module/web/client.scm b/module/web/client.scm index 3f6c45bfe..070b0c3d1 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -1,6 +1,6 @@ ;;; Web client -;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012, 2013, 2014 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 @@ -92,8 +92,6 @@ ;; Buffer input and output on this port. (setvbuf s _IOFBF) - ;; Enlarge the receive buffer. - (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024)) ;; If we're using a proxy, make a note of that. (when http-proxy (set-http-proxy-port?! s #t)) s) diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index ce5f36959..5138b1549 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -93,6 +93,9 @@ check_SCRIPTS += test-language TESTS += test-language EXTRA_DIST += test-language.el test-language.js +check_SCRIPTS += test-guild-compile +TESTS += test-guild-compile + # test-num2integral test_num2integral_SOURCES = test-num2integral.c test_num2integral_CFLAGS = ${test_cflags} @@ -190,7 +193,8 @@ TESTS += test-scm-c-read # test-scm-take-locale-symbol test_scm_take_locale_symbol_SOURCES = test-scm-take-locale-symbol.c test_scm_take_locale_symbol_CFLAGS = ${test_cflags} -test_scm_take_locale_symbol_LDADD = $(LIBGUILE_LDADD) +test_scm_take_locale_symbol_LDADD = \ + $(LIBGUILE_LDADD) $(top_builddir)/lib/libgnu.la check_PROGRAMS += test-scm-take-locale-symbol TESTS += test-scm-take-locale-symbol diff --git a/test-suite/standalone/test-guild-compile b/test-suite/standalone/test-guild-compile new file mode 100755 index 000000000..525ecc6e0 --- /dev/null +++ b/test-suite/standalone/test-guild-compile @@ -0,0 +1,42 @@ +#!/bin/sh +# +# This -*- sh -*- script tests whether 'guild compile' leaves traces +# behind it upon SIGINT. + +source="t-guild-compile-$$" +target="$source.go" + +trap 'rm -f "$source" "$target"' EXIT + +cat > "$source"<&2 + rm "$target"* + kill "$pid" + exit 1 + fi +done + +if test -f "$target" +then + echo "error: '$target' produced" >&2 + exit 1 +fi diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm index 9ecaf897d..749e8cc3a 100644 --- a/test-suite/test-suite/lib.scm +++ b/test-suite/test-suite/lib.scm @@ -63,6 +63,9 @@ ;; Using a given locale with-locale with-locale* with-latin1-locale with-latin1-locale* + ;; The bit bucket. + %null-device + ;; Reporting results in various ways. register-reporter unregister-reporter reporter-registered? make-count-reporter print-counts @@ -562,6 +565,17 @@ ((_ body ...) (with-latin1-locale* (lambda () body ...))))) +(define %null-device + ;; On Windows (MinGW), /dev/null does not exist and we must instead + ;; use NUL. Note that file system procedures automatically translate + ;; /dev/null, so this variable is only useful for shell snippets. + + ;; Test for Windowsness by checking whether the current directory name + ;; starts with a drive letter. + (if (string-match "^[a-zA-Z]:[/\\]" (getcwd)) + "NUL" + "/dev/null")) + ;;;; REPORTERS ;;;; diff --git a/test-suite/tests/c-api.test b/test-suite/tests/c-api.test index 9a2108e69..5ce033f8d 100644 --- a/test-suite/tests/c-api.test +++ b/test-suite/tests/c-api.test @@ -1,7 +1,7 @@ ;;;; c-api.test --- complementary test suite for the c-api -*- scheme -*- ;;;; MDJ 990915 ;;;; -;;;; Copyright (C) 1999, 2006, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2006, 2012, 2014 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -22,7 +22,8 @@ (define srcdir (cdr (assq 'srcdir %guile-build-info))) (define (egrep string filename) - (zero? (system (string-append "egrep '" string "' " filename " >/dev/null")))) + (zero? (system (string-append "egrep '" string "' " filename + " >" %null-device)))) (define (seek-offset-test dirname) (let ((dir (opendir dirname))) diff --git a/test-suite/tests/coding.test b/test-suite/tests/coding.test index b57ef7da7..5f643f871 100644 --- a/test-suite/tests/coding.test +++ b/test-suite/tests/coding.test @@ -20,7 +20,10 @@ #:use-module (test-suite lib)) (define (with-temp-file proc) - (let* ((name (string-copy "/tmp/coding-test.XXXXXX")) + (let* ((tmpdir (or (getenv "TMPDIR") + (getenv "TEMP") + "/tmp")) + (name (string-append tmpdir "/coding-test.XXXXXX")) (port (mkstemp! name))) (let ((res (with-throw-handler #t diff --git a/test-suite/tests/cross-compilation.test b/test-suite/tests/cross-compilation.test index 5438c2092..175e6402b 100644 --- a/test-suite/tests/cross-compilation.test +++ b/test-suite/tests/cross-compilation.test @@ -1,6 +1,6 @@ ;;;; Cross compilation -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2010-2014 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 @@ -79,6 +79,14 @@ (endianness little) 8) (test-target "x86_64-unknown-linux-gnux32" ; x32 ABI (Debian tuplet) (endianness little) 4) + (test-target "arm-unknown-linux-androideabi" + (endianness little) 4) + (test-target "armeb-unknown-linux-gnu" + (endianness big) 4) + (test-target "aarch64-linux-gnu" + (endianness little) 8) + (test-target "aarch64_be-linux-gnu" + (endianness big) 8) (pass-if-exception "unknown target" exception:miscellaneous-error (with-target "fcpu-unknown-gnu1.0" diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index b980cdcdb..c63e3ac5b 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -1,7 +1,7 @@ ;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*- ;;;; ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012, -;;;; 2013 Free Software Foundation, Inc. +;;;; 2013, 2014 Free Software Foundation, Inc. ;;;; Ludovic Courtès ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -38,18 +38,18 @@ (not (not (make-locale LC_ALL "C")))) (pass-if "make-locale (2 args, list)" - (not (not (make-locale (list LC_COLLATE LC_MESSAGES) "C")))) + (not (not (make-locale (list LC_COLLATE LC_NUMERIC) "C")))) (pass-if "make-locale (3 args)" (not (not (make-locale (list LC_COLLATE) "C" - (make-locale (list LC_MESSAGES) "C"))))) + (make-locale (list LC_NUMERIC) "C"))))) (pass-if-exception "make-locale with unknown locale" exception:locale-error (make-locale LC_ALL "does-not-exist")) (pass-if "locale?" (and (locale? (make-locale (list LC_ALL) "C")) - (locale? (make-locale (list LC_MESSAGES LC_NUMERIC) "C" + (locale? (make-locale (list LC_TIME LC_NUMERIC) "C" (make-locale (list LC_CTYPE) "C"))))) (pass-if "%global-locale" @@ -81,20 +81,36 @@ (make-locale (list LC_COLLATE) "C"))))) +(define mingw? + (string-contains %host-type "-mingw32")) + (define %french-locale-name - "fr_FR.ISO-8859-1") + (if mingw? + "fra_FRA.850" + "fr_FR.ISO-8859-1")) + +;; What we really want for the following locales is that they be Unicode +;; capable, not necessarily UTF-8, which Windows does not provide. (define %french-utf8-locale-name - "fr_FR.UTF-8") + (if mingw? + "fra_FRA.1252" + "fr_FR.UTF-8")) (define %turkish-utf8-locale-name - "tr_TR.UTF-8") + (if mingw? + "tur_TRK.1254" + "tr_TR.UTF-8")) (define %german-utf8-locale-name - "de_DE.UTF-8") + (if mingw? + "deu_DEU.1252" + "de_DE.UTF-8")) (define %greek-utf8-locale-name - "el_GR.UTF-8") + (if mingw? + "grc_ELL.1253" + "el_GR.UTF-8")) (define %american-english-locale-name "en_US") @@ -148,13 +164,14 @@ (under-locale-or-unresolved %french-utf8-locale thunk)) (define (under-turkish-utf8-locale-or-unresolved thunk) - ;; FreeBSD 8.2 and 9.1, Solaris 2.10, and Darwin 8.11.0 have a broken - ;; tr_TR locale where `i' is mapped to uppercase `I' instead of `İ', - ;; so disable tests on that platform. + ;; FreeBSD 8.2 and 9.1, Solaris 2.10, Darwin 8.11.0, and MinGW have + ;; a broken tr_TR locale where `i' is mapped to uppercase `I' + ;; instead of `İ', so disable tests on that platform. (if (or (string-contains %host-type "freebsd8") (string-contains %host-type "freebsd9") (string-contains %host-type "solaris2.10") - (string-contains %host-type "darwin8")) + (string-contains %host-type "darwin8") + (string-contains %host-type "mingw32")) (throw 'unresolved) (under-locale-or-unresolved %turkish-utf8-locale thunk))) @@ -192,7 +209,7 @@ ;; strings. (dynamic-wind (lambda () - (setlocale LC_ALL "fr_FR.UTF-8")) + (setlocale LC_ALL %french-utf8-locale-name)) (lambda () (string-locale-ci=? "œuf" "ŒUF")) (lambda () diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test index fb540610a..5e08ac9c9 100644 --- a/test-suite/tests/modules.test +++ b/test-suite/tests/modules.test @@ -1,6 +1,6 @@ ;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*- -;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2006, 2007, 2009-2011, 2014 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 @@ -18,8 +18,7 @@ (define-module (test-suite test-modules) #:use-module (srfi srfi-1) - #:use-module ((ice-9 streams) ;; for test purposes - #:renamer (symbol-prefix-proc 's:)) + #:use-module ((ice-9 streams) #:prefix s:) ; for test purposes #:use-module (test-suite lib)) diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index 2c1c609b8..7cc5a31ab 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -1,7 +1,7 @@ ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; Andy Wingo --- May 2009 ;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2014 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 @@ -409,6 +409,90 @@ '(2 3)) (const 7)) + (pass-if-peval + ;; Higher order with optional argument (default uses earlier argument). + ;; + ((lambda* (f x #:optional (y (+ 3 (car x)))) + (+ y (f (* (car x) (cadr x))))) + (lambda (x) + (+ x 1)) + '(2 3)) + (const 12)) + + (pass-if-peval + ;; Higher order with optional arguments + ;; (default uses earlier optional argument). + ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))) + (+ y z (f (* (car x) (cadr x))))) + (lambda (x) + (+ x 1)) + '(2 3)) + (const 20)) + + (pass-if-peval + ;; Higher order with optional arguments (one caller-supplied value, + ;; one default that uses earlier optional argument). + ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))) + (+ y z (f (* (car x) (cadr x))))) + (lambda (x) + (+ x 1)) + '(2 3) + -3) + (const 4)) + + (pass-if-peval + ;; Higher order with optional arguments (caller-supplied values). + ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))) + (+ y z (f (* (car x) (cadr x))))) + (lambda (x) + (+ x 1)) + '(2 3) + -3 + 17) + (const 21)) + + (pass-if-peval + ;; Higher order with optional and rest arguments (one + ;; caller-supplied value, one default that uses earlier optional + ;; argument). + ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)) + #:rest r) + (list r (+ y z (f (* (car x) (cadr x)))))) + (lambda (x) + (+ x 1)) + '(2 3) + -3) + (primcall list (const ()) (const 4))) + + (pass-if-peval + ;; Higher order with optional and rest arguments + ;; (caller-supplied values for optionals). + ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)) + #:rest r) + (list r (+ y z (f (* (car x) (cadr x)))))) + (lambda (x) + (+ x 1)) + '(2 3) + -3 + 17) + (primcall list (const ()) (const 21))) + + (pass-if-peval + ;; Higher order with optional and rest arguments + ;; (caller-supplied values for optionals and rest). + ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)) + #:rest r) + (list r (+ y z (f (* (car x) (cadr x)))))) + (lambda (x) + (+ x 1)) + '(2 3) + -3 + 17 + 8 + 3) + (let (r) (_) ((primcall list (const 8) (const 3))) + (primcall list (lexical r _) (const 21)))) + (pass-if-peval ;; Higher order with optional argument (caller-supplied value). ((lambda* (f x #:optional (y 0)) diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test index 2818be01b..2c0877484 100644 --- a/test-suite/tests/popen.test +++ b/test-suite/tests/popen.test @@ -1,6 +1,6 @@ ;;;; popen.test --- exercise ice-9/popen.scm -*- scheme -*- ;;;; -;;;; Copyright 2003, 2006, 2010, 2011, 2013 Free Software Foundation, Inc. +;;;; Copyright 2003, 2006, 2010, 2011, 2013, 2014 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 @@ -36,8 +36,7 @@ restore-signals)) (define-syntax-rule (if-supported body ...) - (if (provided? 'fork) - (begin body ...))) + (begin body ...)) (if-supported (use-modules (ice-9 popen)) @@ -109,7 +108,9 @@ (with-input-from-port (car p2c) (lambda () (open-input-pipe - "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; read REPLY"))))))) + (format #f "exec 1>~a; echo closed 1>&2; \ +exec 2>~a; read REPLY" + %null-device %null-device)))))))) (close-port (cdr c2p)) ;; write side (let ((result (eof-object? (read-char port)))) (display "hello!\n" (cdr p2c)) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index fb3299b59..30c2c3a6b 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -53,12 +53,12 @@ (let loop ((chars '())) (let ((char (read-char port))) (if (eof-object? char) - (list->string (reverse! chars)) - (loop (cons char chars)))))) + (list->string (reverse! chars)) + (loop (cons char chars)))))) (define (read-file filename) (let* ((port (open-input-file filename)) - (string (read-all port))) + (string (read-all port))) (close-port port) string)) @@ -95,7 +95,7 @@ ;;; Write out an s-expression, and read it back. (let ((string '("From fairest creatures we desire increase," - "That thereby beauty's rose might never die,")) + "That thereby beauty's rose might never die,")) (filename (test-file))) (let ((port (open-output-file filename))) (write string port) @@ -103,10 +103,10 @@ (let ((port (open-input-file filename))) (let ((in-string (read port))) (pass-if "file: write and read back list of strings" - (equal? string in-string))) + (equal? string in-string))) (close-port port)) (delete-file filename)) - + ;;; Write out a string, and read it back a character at a time. (let ((string "This is a test string\nwith no newline at the end") (filename (test-file))) @@ -115,7 +115,7 @@ (close-port port)) (let ((in-string (read-file filename))) (pass-if "file: write and read back characters" - (equal? string in-string))) + (equal? string in-string))) (delete-file filename)) ;;; Buffered input/output port with seeking. @@ -124,17 +124,17 @@ (display "J'Accuse" port) (seek port -1 SEEK_CUR) (pass-if "file: r/w 1" - (char=? (read-char port) #\e)) + (char=? (read-char port) #\e)) (pass-if "file: r/w 2" - (eof-object? (read-char port))) + (eof-object? (read-char port))) (seek port -1 SEEK_CUR) (write-char #\x port) (seek port 7 SEEK_SET) (pass-if "file: r/w 3" - (char=? (read-char port) #\x)) + (char=? (read-char port) #\x)) (seek port -2 SEEK_END) (pass-if "file: r/w 4" - (char=? (read-char port) #\s)) + (char=? (read-char port) #\s)) (close-port port) (delete-file filename)) @@ -144,17 +144,17 @@ (display "J'Accuse" port) (seek port -1 SEEK_CUR) (pass-if "file: ub r/w 1" - (char=? (read-char port) #\e)) + (char=? (read-char port) #\e)) (pass-if "file: ub r/w 2" - (eof-object? (read-char port))) + (eof-object? (read-char port))) (seek port -1 SEEK_CUR) (write-char #\x port) (seek port 7 SEEK_SET) (pass-if "file: ub r/w 3" - (char=? (read-char port) #\x)) + (char=? (read-char port) #\x)) (seek port -2 SEEK_END) (pass-if "file: ub r/w 4" - (char=? (read-char port) #\s)) + (char=? (read-char port) #\s)) (close-port port) (delete-file filename)) @@ -163,24 +163,24 @@ (port (open-output-file filename))) (display "J'Accuse" port) (pass-if "file: out tell" - (= (seek port 0 SEEK_CUR) 8)) + (= (seek port 0 SEEK_CUR) 8)) (seek port -1 SEEK_CUR) (write-char #\x port) (close-port port) (let ((iport (open-input-file filename))) (pass-if "file: in tell 0" - (= (seek iport 0 SEEK_CUR) 0)) + (= (seek iport 0 SEEK_CUR) 0)) (read-char iport) (pass-if "file: in tell 1" - (= (seek iport 0 SEEK_CUR) 1)) + (= (seek iport 0 SEEK_CUR) 1)) (unread-char #\z iport) (pass-if "file: in tell 0 after unread" - (= (seek iport 0 SEEK_CUR) 0)) + (= (seek iport 0 SEEK_CUR) 0)) (pass-if "file: unread char still there" - (char=? (read-char iport) #\z)) + (char=? (read-char iport) #\z)) (seek iport 7 SEEK_SET) (pass-if "file: in last char" - (char=? (read-char iport) #\x)) + (char=? (read-char iport) #\x)) (close-port iport)) (delete-file filename)) @@ -188,20 +188,20 @@ (let* ((filename (test-file)) (port (open-output-file filename))) (display (string #\nul (integer->char 255) (integer->char 128) - #\nul) port) + #\nul) port) (close-port port) (let* ((port (open-input-file filename)) - (line (read-line port))) + (line (read-line port))) (pass-if "file: read back NUL 1" - (char=? (string-ref line 0) #\nul)) + (char=? (string-ref line 0) #\nul)) (pass-if "file: read back 255" - (char=? (string-ref line 1) (integer->char 255))) + (char=? (string-ref line 1) (integer->char 255))) (pass-if "file: read back 128" - (char=? (string-ref line 2) (integer->char 128))) + (char=? (string-ref line 2) (integer->char 128))) (pass-if "file: read back NUL 2" - (char=? (string-ref line 3) #\nul)) + (char=? (string-ref line 3) #\nul)) (pass-if "file: EOF" - (eof-object? (read-char port))) + (eof-object? (read-char port))) (close-port port)) (delete-file filename)) @@ -211,11 +211,11 @@ (test-string "one line more or less")) (write-line test-string port) (let* ((in-port (open-input-file filename)) - (line (read-line in-port))) + (line (read-line in-port))) (close-port in-port) (close-port port) (pass-if "file: line buffering" - (string=? line test-string))) + (string=? line test-string))) (delete-file filename)) ;;; read-line should use the port encoding (not the locale encoding). @@ -573,19 +573,19 @@ ;;; ungetting characters and strings. (with-input-from-string "walk on the moon\nmoon" - (lambda () - (read-char) - (unread-char #\a (current-input-port)) - (pass-if "unread-char" - (char=? (read-char) #\a)) - (read-line) - (let ((replacenoid "chicken enchilada")) - (unread-char #\newline (current-input-port)) - (unread-string replacenoid (current-input-port)) - (pass-if "unread-string" - (string=? (read-line) replacenoid))) - (pass-if "unread residue" - (string=? (read-line) "moon")))) + (lambda () + (read-char) + (unread-char #\a (current-input-port)) + (pass-if "unread-char" + (char=? (read-char) #\a)) + (read-line) + (let ((replacenoid "chicken enchilada")) + (unread-char #\newline (current-input-port)) + (unread-string replacenoid (current-input-port)) + (pass-if "unread-string" + (string=? (read-line) replacenoid))) + (pass-if "unread residue" + (string=? (read-line) "moon")))) ;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on ;;; the reading end. try to read a byte: should get EAGAIN or @@ -594,13 +594,13 @@ (r (car p))) (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK)) (pass-if "non-blocking-I/O" - (catch 'system-error - (lambda () (read-char r) #f) - (lambda (key . args) - (and (eq? key 'system-error) - (let ((errno (car (list-ref args 3)))) - (or (= errno EAGAIN) - (= errno EWOULDBLOCK)))))))) + (catch 'system-error + (lambda () (read-char r) #f) + (lambda (key . args) + (and (eq? key 'system-error) + (let ((errno (car (list-ref args 3)))) + (or (= errno EAGAIN) + (= errno EWOULDBLOCK)))))))) ;;;; Pipe (popen) ports. @@ -610,7 +610,7 @@ (in-string (read-all pipe))) (close-pipe pipe) (pass-if "pipe: read" - (equal? in-string "Howdy there, partner!\n"))) + (equal? in-string "Howdy there, partner!\n"))) ;;; Run a command, send some output to it, and see if it worked. (let* ((filename (test-file)) @@ -620,9 +620,33 @@ (close-pipe pipe) (let ((in-string (read-file filename))) (pass-if "pipe: write" - (equal? in-string "Mommy, why does everybody have a bomb?\n"))) + (equal? in-string "Mommy, why does everybody have a bomb?\n"))) (delete-file filename)) +(pass-if-equal "pipe, fdopen, and _IOLBF" + "foo\nbar\n" + (let ((in+out (pipe)) + (pid (primitive-fork))) + (if (zero? pid) + (dynamic-wind + (const #t) + (lambda () + (close-port (car in+out)) + (let ((port (cdr in+out))) + (setvbuf port _IOLBF ) + ;; Strings containing '\n' or should be flushed; others + ;; should be kept in PORT's buffer. + (display "foo\n" port) + (display "bar\n" port) + (display "this will be kept in PORT's buffer" port))) + (lambda () + (primitive-_exit 0))) + (begin + (close-port (cdr in+out)) + (let ((str (read-all (car in+out)))) + (waitpid pid) + str))))) + ;;;; Void ports. These are so trivial we don't test them. @@ -633,70 +657,70 @@ ;; Write text to a string port. (let* ((string "Howdy there, partner!") - (in-string (call-with-output-string - (lambda (port) - (display string port) - (newline port))))) + (in-string (call-with-output-string + (lambda (port) + (display string port) + (newline port))))) (pass-if "display text" - (equal? in-string (string-append string "\n")))) - + (equal? in-string (string-append string "\n")))) + ;; Write an s-expression to a string port. (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926)) - (in-sexpr - (call-with-input-string (call-with-output-string - (lambda (port) - (write sexpr port))) - read))) + (in-sexpr + (call-with-input-string (call-with-output-string + (lambda (port) + (write sexpr port))) + read))) (pass-if "write/read sexpr" - (equal? in-sexpr sexpr))) + (equal? in-sexpr sexpr))) ;; seeking and unreading from an input string. (let ((text "that text didn't look random to me")) (call-with-input-string text - (lambda (p) - (pass-if "input tell 0" - (= (seek p 0 SEEK_CUR) 0)) - (read-char p) - (pass-if "input tell 1" - (= (seek p 0 SEEK_CUR) 1)) - (unread-char #\x p) - (pass-if "input tell back to 0" - (= (seek p 0 SEEK_CUR) 0)) - (pass-if "input ungetted char" - (char=? (read-char p) #\x)) - (seek p 0 SEEK_END) - (pass-if "input seek to end" - (= (seek p 0 SEEK_CUR) - (string-length text))) - (unread-char #\x p) - (pass-if "input seek to beginning" - (= (seek p 0 SEEK_SET) 0)) - (pass-if "input reread first char" - (char=? (read-char p) - (string-ref text 0)))))) + (lambda (p) + (pass-if "input tell 0" + (= (seek p 0 SEEK_CUR) 0)) + (read-char p) + (pass-if "input tell 1" + (= (seek p 0 SEEK_CUR) 1)) + (unread-char #\x p) + (pass-if "input tell back to 0" + (= (seek p 0 SEEK_CUR) 0)) + (pass-if "input ungetted char" + (char=? (read-char p) #\x)) + (seek p 0 SEEK_END) + (pass-if "input seek to end" + (= (seek p 0 SEEK_CUR) + (string-length text))) + (unread-char #\x p) + (pass-if "input seek to beginning" + (= (seek p 0 SEEK_SET) 0)) + (pass-if "input reread first char" + (char=? (read-char p) + (string-ref text 0)))))) ;; seeking an output string. (let* ((text (string-copy "123456789")) - (len (string-length text)) - (result (call-with-output-string - (lambda (p) - (pass-if "output tell 0" - (= (seek p 0 SEEK_CUR) 0)) - (display text p) - (pass-if "output tell end" - (= (seek p 0 SEEK_CUR) len)) - (pass-if "output seek to beginning" - (= (seek p 0 SEEK_SET) 0)) - (write-char #\a p) - (seek p -1 SEEK_END) - (pass-if "output seek to last char" - (= (seek p 0 SEEK_CUR) - (- len 1))) - (write-char #\b p))))) + (len (string-length text)) + (result (call-with-output-string + (lambda (p) + (pass-if "output tell 0" + (= (seek p 0 SEEK_CUR) 0)) + (display text p) + (pass-if "output tell end" + (= (seek p 0 SEEK_CUR) len)) + (pass-if "output seek to beginning" + (= (seek p 0 SEEK_SET) 0)) + (write-char #\a p) + (seek p -1 SEEK_END) + (pass-if "output seek to last char" + (= (seek p 0 SEEK_CUR) + (- len 1))) + (write-char #\b p))))) (string-set! text 0 #\a) (string-set! text (- len 1) #\b) (pass-if "output check" - (string=? text result))) + (string=? text result))) (pass-if "%default-port-encoding is ignored" (let ((str "ĉu bone?")) @@ -936,17 +960,17 @@ ;; Return a list of input ports that all return the same text. ;; We map tests over this list. (define (input-port-list text) - + ;; Create a text file some of the ports will use. (let ((out-port (open-output-file port-loop-temp))) (display text out-port) (close-port out-port)) (list (open-input-file port-loop-temp) - (open-input-pipe (string-append "cat " port-loop-temp)) - (call-with-input-string text (lambda (x) x)) - ;; We don't test soft ports at the moment. - )) + (open-input-pipe (string-append "cat " port-loop-temp)) + (call-with-input-string text (lambda (x) x)) + ;; We don't test soft ports at the moment. + )) (define port-list-names '("file" "pipe" "string")) @@ -954,55 +978,55 @@ (define (test-line-counter text second-line final-column) (with-test-prefix "line counter" (let ((ports (input-port-list text))) - (for-each - (lambda (port port-name) - (with-test-prefix port-name - (pass-if "at beginning of input" - (= (port-line port) 0)) - (pass-if "read first character" - (eqv? (read-char port) #\x)) - (pass-if "after reading one character" - (= (port-line port) 0)) - (pass-if "read first newline" - (eqv? (read-char port) #\newline)) - (pass-if "after reading first newline char" - (= (port-line port) 1)) - (pass-if "second line read correctly" - (equal? (read-line port) second-line)) - (pass-if "read-line increments line number" - (= (port-line port) 2)) - (pass-if "read-line returns EOF" - (let loop ((i 0)) - (cond - ((eof-object? (read-line port)) #t) - ((> i 20) #f) - (else (loop (+ i 1)))))) - (pass-if "line count is 5 at EOF" - (= (port-line port) 5)) - (pass-if "column is correct at EOF" - (= (port-column port) final-column)))) - ports port-list-names) - (for-each close-port ports) - (delete-file port-loop-temp)))) + (for-each + (lambda (port port-name) + (with-test-prefix port-name + (pass-if "at beginning of input" + (= (port-line port) 0)) + (pass-if "read first character" + (eqv? (read-char port) #\x)) + (pass-if "after reading one character" + (= (port-line port) 0)) + (pass-if "read first newline" + (eqv? (read-char port) #\newline)) + (pass-if "after reading first newline char" + (= (port-line port) 1)) + (pass-if "second line read correctly" + (equal? (read-line port) second-line)) + (pass-if "read-line increments line number" + (= (port-line port) 2)) + (pass-if "read-line returns EOF" + (let loop ((i 0)) + (cond + ((eof-object? (read-line port)) #t) + ((> i 20) #f) + (else (loop (+ i 1)))))) + (pass-if "line count is 5 at EOF" + (= (port-line port) 5)) + (pass-if "column is correct at EOF" + (= (port-column port) final-column)))) + ports port-list-names) + (for-each close-port ports) + (delete-file port-loop-temp)))) (with-test-prefix "newline" (test-line-counter (string-append "x\n" - "He who receives an idea from me, receives instruction\n" - "himself without lessening mine; as he who lights his\n" - "taper at mine, receives light without darkening me.\n" - " --- Thomas Jefferson\n") + "He who receives an idea from me, receives instruction\n" + "himself without lessening mine; as he who lights his\n" + "taper at mine, receives light without darkening me.\n" + " --- Thomas Jefferson\n") "He who receives an idea from me, receives instruction" 0)) (with-test-prefix "no newline" (test-line-counter (string-append "x\n" - "He who receives an idea from me, receives instruction\n" - "himself without lessening mine; as he who lights his\n" - "taper at mine, receives light without darkening me.\n" - " --- Thomas Jefferson\n" - "no newline here") + "He who receives an idea from me, receives instruction\n" + "himself without lessening mine; as he who lights his\n" + "taper at mine, receives light without darkening me.\n" + " --- Thomas Jefferson\n" + "no newline here") "He who receives an idea from me, receives instruction" 15))) @@ -1012,28 +1036,28 @@ (with-test-prefix "port-line and port-column for output ports" (let ((port (open-output-string))) (pass-if "at beginning of input" - (and (= (port-line port) 0) - (= (port-column port) 0))) + (and (= (port-line port) 0) + (= (port-column port) 0))) (write-char #\x port) (pass-if "after writing one character" - (and (= (port-line port) 0) - (= (port-column port) 1))) + (and (= (port-line port) 0) + (= (port-column port) 1))) (write-char #\newline port) (pass-if "after writing first newline char" - (and (= (port-line port) 1) - (= (port-column port) 0))) + (and (= (port-line port) 1) + (= (port-column port) 0))) (display text port) (pass-if "line count is 5 at end" - (= (port-line port) 5)) + (= (port-line port) 5)) (pass-if "column is correct at end" - (= (port-column port) final-column))))) + (= (port-column port) final-column))))) (test-output-line-counter (string-append "He who receives an idea from me, receives instruction\n" - "himself without lessening mine; as he who lights his\n" - "taper at mine, receives light without darkening me.\n" - " --- Thomas Jefferson\n" - "no newline here") + "himself without lessening mine; as he who lights his\n" + "taper at mine, receives light without darkening me.\n" + " --- Thomas Jefferson\n" + "no newline here") 15) (with-test-prefix "port-column" @@ -1042,115 +1066,115 @@ (pass-if "x" (let ((port (open-output-string))) - (display "x" port) - (= 1 (port-column port)))) + (display "x" port) + (= 1 (port-column port)))) (pass-if "\\a" (let ((port (open-output-string))) - (display "\a" port) - (= 0 (port-column port)))) + (display "\a" port) + (= 0 (port-column port)))) (pass-if "x\\a" (let ((port (open-output-string))) - (display "x\a" port) - (= 1 (port-column port)))) + (display "x\a" port) + (= 1 (port-column port)))) (pass-if "\\x08 backspace" (let ((port (open-output-string))) - (display "\x08" port) - (= 0 (port-column port)))) + (display "\x08" port) + (= 0 (port-column port)))) (pass-if "x\\x08 backspace" (let ((port (open-output-string))) - (display "x\x08" port) - (= 0 (port-column port)))) + (display "x\x08" port) + (= 0 (port-column port)))) (pass-if "\\n" (let ((port (open-output-string))) - (display "\n" port) - (= 0 (port-column port)))) + (display "\n" port) + (= 0 (port-column port)))) (pass-if "x\\n" (let ((port (open-output-string))) - (display "x\n" port) - (= 0 (port-column port)))) + (display "x\n" port) + (= 0 (port-column port)))) (pass-if "\\r" (let ((port (open-output-string))) - (display "\r" port) - (= 0 (port-column port)))) + (display "\r" port) + (= 0 (port-column port)))) (pass-if "x\\r" (let ((port (open-output-string))) - (display "x\r" port) - (= 0 (port-column port)))) + (display "x\r" port) + (= 0 (port-column port)))) (pass-if "\\t" (let ((port (open-output-string))) - (display "\t" port) - (= 8 (port-column port)))) + (display "\t" port) + (= 8 (port-column port)))) (pass-if "x\\t" (let ((port (open-output-string))) - (display "x\t" port) - (= 8 (port-column port))))) + (display "x\t" port) + (= 8 (port-column port))))) (with-test-prefix "input" (pass-if "x" (let ((port (open-input-string "x"))) - (while (not (eof-object? (read-char port)))) - (= 1 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 1 (port-column port)))) (pass-if "\\a" (let ((port (open-input-string "\a"))) - (while (not (eof-object? (read-char port)))) - (= 0 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 0 (port-column port)))) (pass-if "x\\a" (let ((port (open-input-string "x\a"))) - (while (not (eof-object? (read-char port)))) - (= 1 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 1 (port-column port)))) (pass-if "\\x08 backspace" (let ((port (open-input-string "\x08"))) - (while (not (eof-object? (read-char port)))) - (= 0 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 0 (port-column port)))) (pass-if "x\\x08 backspace" (let ((port (open-input-string "x\x08"))) - (while (not (eof-object? (read-char port)))) - (= 0 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 0 (port-column port)))) (pass-if "\\n" (let ((port (open-input-string "\n"))) - (while (not (eof-object? (read-char port)))) - (= 0 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 0 (port-column port)))) (pass-if "x\\n" (let ((port (open-input-string "x\n"))) - (while (not (eof-object? (read-char port)))) - (= 0 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 0 (port-column port)))) (pass-if "\\r" (let ((port (open-input-string "\r"))) - (while (not (eof-object? (read-char port)))) - (= 0 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 0 (port-column port)))) (pass-if "x\\r" (let ((port (open-input-string "x\r"))) - (while (not (eof-object? (read-char port)))) - (= 0 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 0 (port-column port)))) (pass-if "\\t" (let ((port (open-input-string "\t"))) - (while (not (eof-object? (read-char port)))) - (= 8 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 8 (port-column port)))) (pass-if "x\\t" (let ((port (open-input-string "x\t"))) - (while (not (eof-object? (read-char port)))) - (= 8 (port-column port)))))) + (while (not (eof-object? (read-char port)))) + (= 8 (port-column port)))))) (with-test-prefix "port-line" @@ -1159,7 +1183,7 @@ ;; systems (pass-if "set most-positive-fixnum/2" (let ((n (quotient most-positive-fixnum 2)) - (port (open-output-string))) + (port (open-output-string))) (set-port-line! port n) (eqv? n (port-line port))))) @@ -1205,7 +1229,7 @@ (gc) ;; but they're still in the port table, so this sees them (port-for-each (lambda (port) - (set! lst (cons port lst)))) + (set! lst (cons port lst)))) ;; this forces completion of the sweeping (gc) (gc) (gc) ;; and (if the bug is present) the cells accumulated in LST are now @@ -1215,9 +1239,10 @@ (with-test-prefix "fdes->port" (pass-if "fdes->ports finds port" - (let ((port (open-file (test-file) "w"))) - - (not (not (memq port (fdes->ports (port->fdes port)))))))) + (let* ((port (open-file (test-file) "w")) + (res (not (not (memq port (fdes->ports (port->fdes port))))))) + (close-port port) + res))) ;;; ;;; seek @@ -1229,30 +1254,36 @@ (pass-if "SEEK_CUR" (call-with-output-file (test-file) - (lambda (port) - (display "abcde" port))) + (lambda (port) + (display "abcde" port))) (let ((port (open-file (test-file) "r"))) - (read-char port) - (seek port 2 SEEK_CUR) - (eqv? #\d (read-char port)))) + (read-char port) + (seek port 2 SEEK_CUR) + (let ((res (eqv? #\d (read-char port)))) + (close-port port) + res))) (pass-if "SEEK_SET" (call-with-output-file (test-file) - (lambda (port) - (display "abcde" port))) + (lambda (port) + (display "abcde" port))) (let ((port (open-file (test-file) "r"))) - (read-char port) - (seek port 3 SEEK_SET) - (eqv? #\d (read-char port)))) + (read-char port) + (seek port 3 SEEK_SET) + (let ((res (eqv? #\d (read-char port)))) + (close-port port) + res))) (pass-if "SEEK_END" (call-with-output-file (test-file) - (lambda (port) - (display "abcde" port))) + (lambda (port) + (display "abcde" port))) (let ((port (open-file (test-file) "r"))) - (read-char port) - (seek port -2 SEEK_END) - (eqv? #\d (read-char port)))))) + (read-char port) + (seek port -2 SEEK_END) + (let ((res (eqv? #\d (read-char port)))) + (close-port port) + res))))) ;;; ;;; truncate-file @@ -1270,61 +1301,63 @@ (pass-if-exception "flonum length" exception:wrong-type-arg (call-with-output-file (test-file) - (lambda (port) - (display "hello" port))) + (lambda (port) + (display "hello" port))) (truncate-file (test-file) 1.0)) (pass-if "shorten" (call-with-output-file (test-file) - (lambda (port) - (display "hello" port))) + (lambda (port) + (display "hello" port))) (truncate-file (test-file) 1) (eqv? 1 (stat:size (stat (test-file))))) (pass-if-exception "shorten to current pos" exception:miscellaneous-error (call-with-output-file (test-file) - (lambda (port) - (display "hello" port))) + (lambda (port) + (display "hello" port))) (truncate-file (test-file)))) (with-test-prefix "file descriptor" (pass-if "shorten" (call-with-output-file (test-file) - (lambda (port) - (display "hello" port))) + (lambda (port) + (display "hello" port))) (let ((fd (open-fdes (test-file) O_RDWR))) - (truncate-file fd 1) - (close-fdes fd)) + (truncate-file fd 1) + (close-fdes fd)) (eqv? 1 (stat:size (stat (test-file))))) (pass-if "shorten to current pos" (call-with-output-file (test-file) - (lambda (port) - (display "hello" port))) + (lambda (port) + (display "hello" port))) (let ((fd (open-fdes (test-file) O_RDWR))) - (seek fd 1 SEEK_SET) - (truncate-file fd) - (close-fdes fd)) + (seek fd 1 SEEK_SET) + (truncate-file fd) + (close-fdes fd)) (eqv? 1 (stat:size (stat (test-file)))))) (with-test-prefix "file port" (pass-if "shorten" (call-with-output-file (test-file) - (lambda (port) - (display "hello" port))) + (lambda (port) + (display "hello" port))) (let ((port (open-file (test-file) "r+"))) - (truncate-file port 1)) + (truncate-file port 1) + (close-port port)) (eqv? 1 (stat:size (stat (test-file))))) (pass-if "shorten to current pos" (call-with-output-file (test-file) - (lambda (port) - (display "hello" port))) + (lambda (port) + (display "hello" port))) (let ((port (open-file (test-file) "r+"))) - (read-char port) - (truncate-file port)) + (read-char port) + (truncate-file port) + (close-port port)) (eqv? 1 (stat:size (stat (test-file))))))) @@ -1332,17 +1365,17 @@ (with-test-prefix "read-delimited!" (let ((c (make-string 20 #\!))) - (call-with-input-string + (call-with-input-string "defdef\nghighi\n" (lambda (port) - + (read-delimited! "\n" c port 'concat) (pass-if "read-delimited! reads a first line" - (string=? c "defdef\n!!!!!!!!!!!!!")) + (string=? c "defdef\n!!!!!!!!!!!!!")) (read-delimited! "\n" c port 'concat 3) (pass-if "read-delimited! reads a first line" - (string=? c "defghighi\n!!!!!!!!!!")))))) + (string=? c "defghighi\n!!!!!!!!!!")))))) ;;;; char-ready? @@ -1351,7 +1384,7 @@ "howdy" (lambda (port) (pass-if "char-ready? returns true on string port" - (char-ready? port)))) + (char-ready? port)))) ;;; This segfaults on some versions of Guile. We really should run ;;; the tests in a subprocess... @@ -1363,7 +1396,7 @@ port (lambda () (pass-if "char-ready? returns true on string port as default port" - (char-ready?)))))) + (char-ready?)))))) ;;;; pending-eof behavior @@ -1454,15 +1487,15 @@ (with-test-prefix "closing current-input-port" (for-each (lambda (procedure name) - (with-input-from-port - (call-with-input-string "foo" (lambda (p) p)) - (lambda () - (close-port (current-input-port)) - (pass-if-exception name - exception:wrong-type-arg - (procedure))))) - (list read read-char read-line) - '("read" "read-char" "read-line"))) + (with-input-from-port + (call-with-input-string "foo" (lambda (p) p)) + (lambda () + (close-port (current-input-port)) + (pass-if-exception name + exception:wrong-type-arg + (procedure))))) + (list read read-char read-line) + '("read" "read-char" "read-line"))) @@ -1824,6 +1857,17 @@ (with-fluids ((%file-port-name-canonicalization 'absolute)) (port-filename (open-input-file (%search-load-path "ice-9/q.scm")))))) +(with-test-prefix "file name separators" + + (pass-if "no backslash separators in Windows file names" + ;; In Guile 2.0.11 and earlier, %load-path on Windows could + ;; include file names with backslashes, and `getcwd' on Windows + ;; would always return a directory name with backslashes. + (or (not (file-name-separator? #\\)) + (with-load-path (cons (getcwd) %load-path) + (not (string-index (%search-load-path (basename (test-file))) + #\\)))))) + (delete-file (test-file)) ;;; Local Variables: diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test index 00e9c682e..9a0e489b4 100644 --- a/test-suite/tests/posix.test +++ b/test-suite/tests/posix.test @@ -70,9 +70,10 @@ (pass-if "filename string modified" (let* ((template "T-XXXXXX") - (str (string-copy template)) - (port (mkstemp! str)) - (result (not (string=? str template)))) + (str (string-copy template)) + (port (mkstemp! str)) + (result (not (string=? str template)))) + (close-port port) (delete-file str) result))) diff --git a/test-suite/tests/r6rs-files.test b/test-suite/tests/r6rs-files.test index df5dd22e2..9b31a8296 100644 --- a/test-suite/tests/r6rs-files.test +++ b/test-suite/tests/r6rs-files.test @@ -24,7 +24,9 @@ (with-test-prefix "delete-file" (pass-if "delete-file deletes file" - (let ((filename (port-filename (mkstemp! "T-XXXXXX")))) + (let* ((port (mkstemp! "T-XXXXXX")) + (filename (port-filename port))) + (close-port port) (delete-file filename) (not (file-exists? filename)))) @@ -32,9 +34,9 @@ (let ((success #f)) (call/cc (lambda (continuation) - (with-exception-handler - (lambda (condition) - (set! success (i/o-filename-error? condition)) - (continuation)) - (lambda () (delete-file ""))))) + (with-exception-handler + (lambda (condition) + (set! success (i/o-filename-error? condition)) + (continuation)) + (lambda () (delete-file ""))))) success))) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index b0ffa765f..17acdc44c 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -137,6 +137,26 @@ (close-port port) (get-bytevector-n port 3))) + (let ((expected (make-bytevector 20 (char->integer #\a)))) + (pass-if-equal "http://bugs.gnu.org/17466" + ;; is about a memory corruption + ;; whereas bytevector shrunk in 'get-bytevector-n' would keep + ;; referring to the previous (larger) bytevector. + expected + (let loop ((count 50)) + (if (zero? count) + expected + (let ((bv (call-with-input-string "aaaaaaaaaaaaaaaaaaaa" + (lambda (port) + (get-bytevector-n port 4096))))) + ;; Cause the 4 KiB bytevector initially created by + ;; 'get-bytevector-n' to be reclaimed. + (make-bytevector 4096) + + (if (equal? bv expected) + (loop (- count 1)) + bv)))))) + (pass-if "get-bytevector-n! [short]" (let* ((port (open-input-string "GNU Guile")) (bv (make-bytevector 4)) diff --git a/test-suite/tests/rdelim.test b/test-suite/tests/rdelim.test index 437a0ee40..617e65167 100644 --- a/test-suite/tests/rdelim.test +++ b/test-suite/tests/rdelim.test @@ -1,7 +1,7 @@ ;;;; rdelim.test --- Delimited I/O. -*- mode: scheme; coding: utf-8; -*- ;;;; Ludovic Courtès ;;;; -;;;; Copyright (C) 2011, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2011, 2013, 2014 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 @@ -207,7 +207,13 @@ (let* ((s (string-concatenate (make-list 20 "hello, world!"))) (p (open-input-string s))) (and (string=? (read-string p) s) - (string=? (read-string p) ""))))) + (string=? (read-string p) "")))) + + (pass-if-equal "longer than 100 chars, with limit" + "hello, world!" + (let* ((s (string-concatenate (make-list 20 "hello, world!"))) + (p (open-input-string s))) + (read-string p 13)))) (with-test-prefix "read-string!" diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index d40f8e1c2..bce0e86da 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -1,6 +1,6 @@ ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*- ;;;; -;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright 2003-2006, 2008-2011, 2014 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 @@ -1329,6 +1329,10 @@ (length+)) (pass-if-exception "too many args" exception:wrong-num-args (length+ 123 456)) + (pass-if-exception "not a pair" exception:wrong-type-arg + (length+ 'x)) + (pass-if-exception "improper list" exception:wrong-type-arg + (length+ '(x y . z))) (pass-if (= 0 (length+ '()))) (pass-if (= 1 (length+ '(x)))) (pass-if (= 2 (length+ '(x y)))) diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index 817812051..3b7a3e440 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -1,6 +1,7 @@ ;;;; threads.test --- Tests for Guile threading. -*- scheme -*- ;;;; -;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013, +;;;; 2014 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 @@ -36,6 +37,11 @@ (equal? '(a b c) '(a b c)) a)) +(define (require-cancel-thread) + ;; Skip the test when 'cancel-thread' is unavailable. + (unless (defined? 'cancel-thread) + (throw 'unresolved))) + (if (provided? 'threads) (begin @@ -277,6 +283,7 @@ (with-test-prefix "join-thread" (pass-if "timed joining fails if timeout exceeded" + (require-cancel-thread) (let* ((m (make-mutex)) (c (make-condition-variable)) (t (begin-thread (begin (lock-mutex m) @@ -286,6 +293,7 @@ (not r))) (pass-if "join-thread returns timeoutval on timeout" + (require-cancel-thread) (let* ((m (make-mutex)) (c (make-condition-variable)) (t (begin-thread (begin (lock-mutex m) @@ -335,6 +343,7 @@ (with-test-prefix "cancel-thread" (pass-if "cancel succeeds" + (require-cancel-thread) (let ((m (make-mutex))) (lock-mutex m) (let ((t (begin-thread (begin (lock-mutex m) 'foo)))) @@ -343,6 +352,7 @@ #t))) (pass-if "handler result passed to join" + (require-cancel-thread) (let ((m (make-mutex))) (lock-mutex m) (let ((t (begin-thread (lock-mutex m)))) @@ -351,6 +361,7 @@ (eq? (join-thread t) 'foo)))) (pass-if "can cancel self" + (require-cancel-thread) (let ((m (make-mutex))) (lock-mutex m) (let ((t (begin-thread (begin diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 0f6d9451b..d52a642aa 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -1,8 +1,7 @@ ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; Andy Wingo --- May 2009 ;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, -;;;; 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2014 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 @@ -1132,6 +1131,50 @@ (number? (string-contains (car w) "expected 3, got 2"))))) + (pass-if "~p" + (null? (call-with-warnings + (lambda () + (compile '(((@ (ice-9 format) format) #f "thing~p" 2)) + #:opts %opts-w-format + #:to 'cps))))) + + (pass-if "~p, too few arguments" + (let ((w (call-with-warnings + (lambda () + (compile '((@ (ice-9 format) format) #f "~p") + #:opts %opts-w-format + #:to 'cps))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 1, got 0"))))) + + (pass-if "~:p" + (null? (call-with-warnings + (lambda () + (compile '(((@ (ice-9 format) format) #f "~d thing~:p" 2)) + #:opts %opts-w-format + #:to 'cps))))) + + (pass-if "~:@p, too many arguments" + (let ((w (call-with-warnings + (lambda () + (compile '((@ (ice-9 format) format) #f "~d pupp~:@p" 5 5) + #:opts %opts-w-format + #:to 'cps))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 1, got 2"))))) + + (pass-if "~:@p, too few arguments" + (let ((w (call-with-warnings + (lambda () + (compile '((@ (ice-9 format) format) #f "pupp~:@p") + #:opts %opts-w-format + #:to 'cps))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 1, got 0"))))) + (pass-if "~?" (null? (call-with-warnings (lambda () @@ -1202,8 +1245,7 @@ (let ((w (call-with-warnings (lambda () (let ((in (open-input-string - "(use-modules ((ice-9 format) - #:renamer (symbol-prefix-proc 'i9-))) + "(use-modules ((ice-9 format) #:prefix i9-)) (i9-format #t \"yo! ~A\" 1 2)"))) (read-and-compile in #:opts %opts-w-format