mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Merge branch 'stable-2.0'

Browse source 
Conflicts:
	benchmark-suite/benchmarks/ports.bm
	libguile/async.h
	libguile/bytevectors.c
	libguile/foreign.c
	libguile/gsubr.c
	libguile/srfi-1.c
	libguile/vm-engine.h
	libguile/vm-i-scheme.c
	module/Makefile.am
	module/language/tree-il/analyze.scm
	module/language/tree-il/peval.scm
	module/scripts/compile.scm
	module/scripts/disassemble.scm
	test-suite/tests/asm-to-bytecode.test
	test-suite/tests/peval.test
	test-suite/tests/rdelim.test
This commit is contained in:
Mark H Weaver 2014-09-30 03:50:47 -04:00
commit 856d318a9f
57 changed files with 1018 additions and 491 deletions
Download patch file Download diff file Expand all files Collapse all files

2
THANKS
View file

@ -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

6
autogen.sh
View file

@ -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 ""

9
benchmark-suite/benchmarks/ports.bm
View file

@ -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)))))

15
configure.ac
View file

@ -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 };".

5
doc/ref/api-evaluation.texi
View file

@ -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

39
doc/ref/api-modules.texi
View file

@ -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:

2
doc/ref/api-utility.texi
View file

@ -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

10
doc/ref/posix.texi
View file

@ -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)

14
doc/ref/srfi-modules.texi
View file

@ -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.

2
doc/ref/texinfo.texi
View file

@ -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

3
guile-readline/ice-9/readline.scm
View file

@ -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)

11
libguile/async.h
View file

@ -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 */

16
libguile/bytevectors.c
View file

@ -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;

17
libguile/debug.c
View file

@ -27,6 +27,11 @@
#include <sys/resource.h>
#endif
#ifdef __MINGW32__
# define WIN32_LEAN_AND_MEAN
# include <windows.h>
#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
}

4
libguile/filesys.c
View file

@ -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;

2
libguile/foreign.c
View file

@ -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

2
libguile/fports.c
View file

@ -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;

3
libguile/gsubr.c
View file

@ -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

51
libguile/i18n.c
View file

@ -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

3
libguile/init.c
View file

@ -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;

31
libguile/list.c
View file

@ -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

60
libguile/load.c
View file

@ -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);

1
libguile/load.h
View file

@ -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 */

8
libguile/locale-categories.h
View file

@ -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

22
libguile/posix.c
View file

@ -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

32
libguile/simpos.c
View file

@ -45,6 +45,10 @@
# include <sys/wait.h>
#endif
#ifdef __MINGW32__
# include <process.h> /* 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 */

10
libguile/smob.h
View file

@ -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))

40
libguile/srfi-1.c
View file

@ -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

7
libguile/threads.c
View file

@ -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}. "

17
module/Makefile.am
View file

@ -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 = \

14
module/ice-9/boot-9.scm
View file

@ -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))

13
module/ice-9/curried-definitions.scm
View file

@ -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)))))

44
module/ice-9/rdelim.scm
View file

@ -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,

12
module/language/tree-il/analyze.scm
View file

@ -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))

29
module/language/tree-il/peval.scm
View file

@ -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))))

10
module/scripts/compile.scm
View file

@ -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* ""))

18
module/srfi/srfi-43.scm
View file

@ -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)

12
module/system/base/target.scm
View file

@ -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)))))

4
module/web/client.scm
View file

@ -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)

6
test-suite/standalone/Makefile.am
View file

@ -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

42
test-suite/standalone/test-guild-compile Executable file
View file

@ -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"<<EOF
(eval-when (expand load eval)
(sleep 100))
(define chbouib 42)
EOF
guild compile -o "$target" "$source" &
pid="$!"
# Send SIGINT.
sleep 2 && kill -INT "$pid"
# Wait for 'guild compile' to terminate.
sleep 2
# Check whether there are any leftovers.
for file in "$target"*
do
if test "$file" != "${target}*"
then
echo "error: 'guild compile' failed to remove '$file'" >&2
rm "$target"*
kill "$pid"
exit 1
fi
done
if test -f "$target"
then
echo "error: '$target' produced" >&2
exit 1
fi

14
test-suite/test-suite/lib.scm
View file

@ -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
;;;;

5
test-suite/tests/c-api.test
View file

@ -1,7 +1,7 @@
;;;; c-api.test --- complementary test suite for the c-api -*- scheme -*-
;;;; MDJ 990915 <djurfeldt@nada.kth.se>
;;;;
;;;; 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)))

5
test-suite/tests/coding.test
View file

@ -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

10
test-suite/tests/cross-compilation.test
View file

@ -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"

45
test-suite/tests/i18n.test
View file

@ -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 ()

5
test-suite/tests/modules.test
View file

@ -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))

86
test-suite/tests/peval.test
View file

@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- 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).
;; <http://bugs.gnu.org/17634>
((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))

9
test-suite/tests/popen.test
View file

@ -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))

562
test-suite/tests/ports.test
View file

@ -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:

7
test-suite/tests/posix.test
View file

@ -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)))

14
test-suite/tests/r6rs-files.test
View file

@ -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)))

20
test-suite/tests/r6rs-ports.test
View file

@ -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"
;; <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))

10
test-suite/tests/rdelim.test
View file

@ -1,7 +1,7 @@
;;;; rdelim.test --- Delimited I/O. -*- mode: scheme; coding: utf-8; -*-
;;;; Ludovic Courtès <ludo@gnu.org>
;;;;
;;;; 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!"

6
test-suite/tests/srfi-1.test
View file

@ -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))))

13
test-suite/tests/threads.test
View file

@ -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

50
test-suite/tests/tree-il.test
View file

@ -1,8 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- 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