[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-11-282-g3
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-11-282-g358663c |
|
Date: |
Fri, 27 Aug 2010 17:06:57 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=358663caf54994e2b7d0c2eb1dd8ce8794116971
The branch, master has been updated
via 358663caf54994e2b7d0c2eb1dd8ce8794116971 (commit)
via d3cc00f65d8d792024ffcd5f63ab1512f21ee25d (commit)
via b86d23093284512a6a3c1780e9e5547c9ab34c25 (commit)
via d7418e60a5b427a9d733929cf6ff468402dada1d (commit)
via ea975f72cf4c041cf0b0ca3be3955f70868d8380 (commit)
via 93003b16b03a3aac486994f01140c0ebc6fe1b66 (commit)
from 172988eeb4445ca5408be55a9888f7c2d59a316b (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 358663caf54994e2b7d0c2eb1dd8ce8794116971
Author: Ludovic Courtès <address@hidden>
Date: Fri Aug 27 18:58:13 2010 +0200
Document (ice-9 match).
* doc/ref/Makefile.am (guile_TEXINFOS): Add `match.texi'.
* doc/ref/guile.texi (Guile Modules): Include `match.texi'.
* doc/ref/match.texi: New file.
* doc/ref/sxml-match.texi (sxml-match): Add xref to `match.texi'.
* module/ice-9/match.scm: Note lack of support for `(pat => exp)'.
commit d3cc00f65d8d792024ffcd5f63ab1512f21ee25d
Author: Ludovic Courtès <address@hidden>
Date: Fri Aug 27 15:44:55 2010 +0200
SRFI-1: Choose better benchmark names.
* benchmark-suite/benchmarks/srfi-1.bm ("fold"): Rename sub-tests to
"big" and "small".
commit b86d23093284512a6a3c1780e9e5547c9ab34c25
Author: Ludovic Courtès <address@hidden>
Date: Fri Aug 27 15:43:30 2010 +0200
SRFI-1: Rewrite `break' and `break!' in Scheme.
This partially reverts commit 6e9f3c2676c0101590d4229653e9c628cb293064
(Tue May 3 2005).
* module/srfi/srfi-1.scm (break, break!): New procedures.
* srfi/srfi-1.c (scm_srfi1_break, scm_srfi1_break_x): Rewrite as
proxies to the corresponding Scheme procedures.
* test-suite/standalone/test-srfi-1.c (failure): New function.
(tests): Add `scm_srfi1_break' test. Use `failure'.
commit d7418e60a5b427a9d733929cf6ff468402dada1d
Author: Ludovic Courtès <address@hidden>
Date: Fri Aug 27 12:51:47 2010 +0200
SRFI-1: Rewrite `fifth', `sixth', etc. in Scheme.
This partially reverts commit 03731332d5dc8d650b947f5126427402c2b1d8bb
(Tue May 3 2005).
* module/srfi/srfi-1.scm (fifth, sixth, seventh, eighth, ninth, tenth):
New procedures.
* srfi/srfi-1.c (scm_srfi1_fifth, scm_srfi1_sixth, scm_srfi1_seventh,
scm_srfi1_eighth, scm_srfi1_ninth, scm_srfi1_tenth): Rewrite as
proxies to the corresponding Scheme procedure.
* test-suite/tests/srfi-1.test ("eighth")["() -1"]: Change exception
type to `exception:wrong-type-arg'.
("fifth")["() -1"]: Likewise.
("ninth")["() -1"]: Likewise.
("seventh")["() -1"]: Likewise.
("sixth")["() -1"]: Likewise.
("tenth")["() -1"]: Likewise.
commit ea975f72cf4c041cf0b0ca3be3955f70868d8380
Author: Ludovic Courtès <address@hidden>
Date: Fri Aug 27 12:36:23 2010 +0200
Remove unneeded #:use-module.
* module/system/vm/frame.scm: Remove use of (srfi srfi-1).
commit 93003b16b03a3aac486994f01140c0ebc6fe1b66
Author: Ludovic Courtès <address@hidden>
Date: Fri Aug 20 21:08:49 2010 +0200
Assorted `syntax-check' fixes.
* doc/ref/Makefile.am ($(snarf_doc).am): Untabify.
* libguile/eval.c: Remove unnecessary <assert.h> inclusion.
* .x-sc_m4_quote_check: Update.
* libguile/error.c (scm_error_scm): Use `EXIT_FAILURE' instead of 1.
* libguile/init.c (fixconfig, scm_boot_guile): Likewise.
* libguile/null-threads.h (scm_i_pthread_exit): Likewise.
* libguile/script.c (scm_compile_shell_switches): Likewise.
* test-suite/standalone/test-conversion.c: Likewise.
* test-suite/standalone/test-list.c: Likewise.
* test-suite/standalone/test-unwind.c: Likewise.
* libguile/async.c: Remove unnecessary inclusion of <signal.h>.
* NEWS: "filesystem" -> "file system".
* doc/ref/r6rs.texi: Ditto.
* cfg.mk (local-checks-to-skip): New variable.
* .x-sc_m4_quote_check, .x-sc_obsolete_symbols, .x-sc_program_name,
.x-sc_prohibit_atoi_atof, .x-sc_prohibit_magic_number_exit: New
files.
* .gitignore: Update.
-----------------------------------------------------------------------
Summary of changes:
.gitignore | 1 +
.x-sc_m4_quote_check | 3 +-
.x-sc_obsolete_symbols | 4 +
.x-sc_program_name | 5 +
.x-sc_prohibit_atoi_atof | 2 +
.x-sc_prohibit_magic_number_exit | 4 +
NEWS | 4 +-
benchmark-suite/benchmarks/srfi-1.bm | 4 +-
cfg.mk | 8 ++
doc/ref/Makefile.am | 7 +-
doc/ref/guile.texi | 4 +-
doc/ref/match.texi | 159 +++++++++++++++++++++++++++++++
doc/ref/r6rs.texi | 2 +-
doc/ref/sxml-match.texi | 4 +-
libguile/async.c | 1 -
libguile/error.c | 5 +-
libguile/eval.c | 1 -
libguile/init.c | 9 +-
libguile/null-threads.h | 7 +-
libguile/script.c | 5 +-
module/ice-9/match.scm | 3 +-
module/srfi/srfi-1.scm | 30 ++++++
module/system/vm/frame.scm | 1 -
srfi/srfi-1.c | 133 ++++++-------------------
test-suite/standalone/test-conversion.c | 73 +++++++-------
test-suite/standalone/test-list.c | 7 +-
test-suite/standalone/test-srfi-1.c | 32 ++++++-
test-suite/standalone/test-unwind.c | 16 ++--
test-suite/tests/srfi-1.test | 12 +-
29 files changed, 362 insertions(+), 184 deletions(-)
create mode 100644 .x-sc_obsolete_symbols
create mode 100644 .x-sc_program_name
create mode 100644 .x-sc_prohibit_atoi_atof
create mode 100644 .x-sc_prohibit_magic_number_exit
create mode 100644 doc/ref/match.texi
diff --git a/.gitignore b/.gitignore
index e3ccf28..df46a80 100644
--- a/.gitignore
+++ b/.gitignore
@@ -136,3 +136,4 @@ INSTALL
/lib/unistr.h
/lib/unitypes.h
/lib/c++defs.h
+/.sc-start-*
diff --git a/.x-sc_m4_quote_check b/.x-sc_m4_quote_check
index 6b09fcb..b730975 100644
--- a/.x-sc_m4_quote_check
+++ b/.x-sc_m4_quote_check
@@ -1 +1,2 @@
-m4/version-etc.m4
+m4/absolute-header.m4
+m4/*
diff --git a/.x-sc_obsolete_symbols b/.x-sc_obsolete_symbols
new file mode 100644
index 0000000..5b1140c
--- /dev/null
+++ b/.x-sc_obsolete_symbols
@@ -0,0 +1,4 @@
+doc/*
+lib/flock.c
+libguile/filesys.c
+libguile/ChangeLog-2008
diff --git a/.x-sc_program_name b/.x-sc_program_name
new file mode 100644
index 0000000..1f5046e
--- /dev/null
+++ b/.x-sc_program_name
@@ -0,0 +1,5 @@
+test-suite/*
+examples/*
+doc/example-smob/*
+libguile/gen-scmconfig.c
+*
diff --git a/.x-sc_prohibit_atoi_atof b/.x-sc_prohibit_atoi_atof
new file mode 100644
index 0000000..bf0f25f
--- /dev/null
+++ b/.x-sc_prohibit_atoi_atof
@@ -0,0 +1,2 @@
+lib/*
+libguile/win32-socket.c
diff --git a/.x-sc_prohibit_magic_number_exit b/.x-sc_prohibit_magic_number_exit
new file mode 100644
index 0000000..adcd138
--- /dev/null
+++ b/.x-sc_prohibit_magic_number_exit
@@ -0,0 +1,4 @@
+configure.ac
+NEWS
+doc/ref/api-init.texi
+libguile/ChangeLog*
diff --git a/NEWS b/NEWS
index 24dac97..55c5186 100644
--- a/NEWS
+++ b/NEWS
@@ -154,11 +154,11 @@ on chance.
** Remove encoding of versions into the file system
It used to be that, when loading a module, if the user specified a
-version, Guile would grovel about in the filesystem to find the
+version, Guile would grovel about in the file system to find the
module. This process was slow and not robust. This support has been
removed: modules are once more always loaded via `primitive-load-path'.
-Module versions in the filesystem may be added again in the future, in
+Module versions in the file system may be added again in the future, in
an extensible way. Contact address@hidden with patches.
** Alex Shinn's pattern matcher for (ice-9 match).
diff --git a/benchmark-suite/benchmarks/srfi-1.bm
b/benchmark-suite/benchmarks/srfi-1.bm
index 2888934..e07d3b9 100644
--- a/benchmark-suite/benchmarks/srfi-1.bm
+++ b/benchmark-suite/benchmarks/srfi-1.bm
@@ -31,8 +31,8 @@
(with-benchmark-prefix "fold"
- (benchmark "fold" 30
+ (benchmark "big" 30
(fold (lambda (x y) y) #f %big-list))
- (benchmark "fold" 2000000
+ (benchmark "small" 2000000
(fold (lambda (x y) y) #f %small-list)))
diff --git a/cfg.mk b/cfg.mk
index b63cf78..5161cc4 100644
--- a/cfg.mk
+++ b/cfg.mk
@@ -1,3 +1,11 @@
old_NEWS_hash = d41d8cd98f00b204e9800998ecf8427e
git-version-gen-tag-sed-script := \
's/^release_\([0-9]\+\)-\([0-9]\+\)-\([0-9]\+\)/v\1.\2\.\3/g'
+
+local-checks-to-skip := \
+ sc_makefile_at_at_check \
+ sc_prohibit_HAVE_MBRTOWC \
+ sc_prohibit_empty_lines_at_EOF \
+ sc_prohibit_have_config_h \
+ sc_prohibit_safe_read_without_use \
+ sc_prohibit_stat_st_blocks
diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am
index beeba0f..72ef8a1 100644
--- a/doc/ref/Makefile.am
+++ b/doc/ref/Makefile.am
@@ -70,6 +70,7 @@ guile_TEXINFOS = preface.texi \
repl-modules.texi \
srfi-modules.texi \
r6rs.texi \
+ match.texi \
misc-modules.texi \
api-compound.texi \
autoconf.texi \
@@ -146,9 +147,9 @@ $(snarf_doc).am: $(snarf_doc).scm
(format #t \"# Automatically generated, do not edit.~%\")
\
(format #t \"$$variable = \")
\
(for-each (lambda (m)
\
- (format #t \"$$""(top_srcdir)/module/~a.scm \"
\
- (string-join (map symbol->string m) \"/\")))
\
- (map car *modules*))" > "address@hidden"
+ (format #t \"$$""(top_srcdir)/module/~a.scm \"
\
+ (string-join (map symbol->string m) \"/\")))
\
+ (map car *modules*))" > "address@hidden"
mv "address@hidden" "$@"
# The following line leads to the definition of $(standard_library_scm_files).
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index 18069ae..1f57343 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -301,7 +301,7 @@ available through both Scheme and C interfaces.
* Binding Constructs:: Definitions and variable bindings.
* Control Mechanisms:: Controlling the flow of program execution.
* Input and Output:: Ports, reading and writing.
-* LALR(1) Parsing:: Generating LALR(1) parsers.
+* LALR(1) Parsing:: Generating LALR(1) parsers.
* Read/Load/Eval/Compile:: Reading and evaluating Scheme code.
* Memory Management:: Memory management and garbage collection.
* Modules:: Designing reusable code libraries.
@@ -350,6 +350,7 @@ available through both Scheme and C interfaces.
* getopt-long:: Command line handling.
* SRFI Support:: Support for various SRFIs.
* R6RS Support:: Modules defined by the R6RS.
+* Pattern Matching:: Generic pattern matching constructs.
* Readline Support:: Module for using the readline library.
* Pretty Printing:: Nicely formatting Scheme objects for output.
* Formatted Output:: The @code{format} procedure.
@@ -368,6 +369,7 @@ available through both Scheme and C interfaces.
@include mod-getopt-long.texi
@include srfi-modules.texi
@include r6rs.texi
address@hidden match.texi
@include repl-modules.texi
@include misc-modules.texi
@include expect.texi
diff --git a/doc/ref/match.texi b/doc/ref/match.texi
new file mode 100644
index 0000000..66bb0bf
--- /dev/null
+++ b/doc/ref/match.texi
@@ -0,0 +1,159 @@
address@hidden -*-texinfo-*-
address@hidden This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2010 Free Software Foundation, Inc.
address@hidden See the file guile.texi for copying conditions.
address@hidden
+
address@hidden The pattern syntax is taken from the documentation available in
address@hidden Andrew K. Wright's implementation of `match.scm', which is in the
address@hidden public domain. See Guile before commit
address@hidden d967913f05301a35573c5d3f7217d0994bbb1016 (Thu Jun 17 2010) or
address@hidden <http://www.cs.indiana.edu/scheme-repository/code.match.html>.
+
address@hidden FIXME: This section is a bit rough on the edges. The
introduction
address@hidden could be improved, e.g., by adding examples.
+
address@hidden Pattern Matching
address@hidden Pattern Matching
+
address@hidden pattern matching
address@hidden (ice-9 match)
+
+The @code{(ice-9 match)} module provides a @dfn{pattern matcher},
+written by Alex Shinn, and compatible with Andrew K. Wright's pattern
+matcher found in many Scheme implementations.
+
address@hidden pattern variable
+A pattern matcher can match an object against several patterns and
+extract the elements that make it up. Patterns can represent any Scheme
+object: lists, strings, symbols, etc. They can optionally contain
address@hidden variables}. When a matching pattern is found, an
+expression associated with the pattern is evaluated, optionally with all
+pattern variables bound to the corresponding elements of the object:
+
address@hidden
+(let ((l '(hello (world))))
+ (match l ;; <- the input object
+ (('hello (who)) ;; <- the pattern
+ who))) ;; <- the expression evaluated upon matching
address@hidden world
address@hidden example
+
+In this example, list @var{l} matches the pattern @code{('hello (who))},
+because it is a two-element list whose first element is the symbol
address@hidden and whose second element is a one-element list. Here
address@hidden is a pattern variable. @code{match}, the pattern matcher,
+locally binds @var{who} to the value contained in this one-element list,
+i.e., the symbol @code{world}.
+
+The same object can be matched against a simpler pattern:
+
address@hidden
+(let ((l '(hello (world))))
+ (match l
+ ((x y)
+ (values x y))))
address@hidden hello
address@hidden (world)
address@hidden example
+
+Here pattern @code{(x y)} matches any two-element list, regardless of
+the types of these elements. Pattern variables @var{x} and @var{y} are
+bound to, respectively, the first and second element of @var{l}.
+
+
+The pattern matcher is defined as follows:
+
address@hidden {Scheme Syntax} match exp clause ...
+Match object @var{exp} against the patterns in the given @var{clause}s,
+in the order in which they appear. Return the value produced by the
+first matching clause. If no @var{clause} matches, throw an exception
+with key @code{match-error}.
+
+Each @var{clause} has the form @code{(pattern body)}. Each
address@hidden must follow the syntax described below. Each @var{body}
+is an arbitrary Scheme expression, possibly referring to pattern
+variables of @var{pattern}.
address@hidden deffn
+
address@hidden FIXME: Document other forms:
address@hidden
address@hidden exp ::= ...
address@hidden | (match exp clause ...)
address@hidden | (match-lambda clause ...)
address@hidden | (match-lambda* clause ...)
address@hidden | (match-let ((pat exp) ...) body)
address@hidden | (match-let* ((pat exp) ...) body)
address@hidden | (match-letrec ((pat exp) ...) body)
address@hidden | (match-define pat exp)
address@hidden
address@hidden clause ::= (pat body) | (pat => exp)
+
+The syntax and interpretation of patterns is as follows:
+
address@hidden
+ patterns: matches:
+
+pat ::= identifier anything, and binds identifier
+ | _ anything
+ | () the empty list
+ | #t #t
+ | #f #f
+ | string a string
+ | number a number
+ | character a character
+ | 'sexp an s-expression
+ | 'symbol a symbol (special case of s-expr)
+ | (pat_1 ... pat_n) list of n elements
+ | (pat_1 ... pat_n . pat_{n+1}) list of n or more
+ | (pat_1 ... pat_n pat_n+1 ooo) list of n or more, each element
+ of remainder must match pat_n+1
+ | #(pat_1 ... pat_n) vector of n elements
+ | #(pat_1 ... pat_n pat_n+1 ooo) vector of n or more, each element
+ of remainder must match pat_n+1
+ | #&pat box
+ | ($ struct-name pat_1 ... pat_n) a structure
+ | (= field pat) a field of a structure
+ | (and pat_1 ... pat_n) if all of pat_1 thru pat_n match
+ | (or pat_1 ... pat_n) if any of pat_1 thru pat_n match
+ | (not pat_1 ... pat_n) if all pat_1 thru pat_n don't match
+ | (? predicate pat_1 ... pat_n) if predicate true and all of
+ pat_1 thru pat_n match
+ | (set! identifier) anything, and binds setter
+ | (get! identifier) anything, and binds getter
+ | `qp a quasi-pattern
+
+ooo ::= ... zero or more
+ | ___ zero or more
+ | ..k k or more
+ | __k k or more
+
+ quasi-patterns: matches:
+
+qp ::= () the empty list
+ | #t #t
+ | #f #f
+ | string a string
+ | number a number
+ | character a character
+ | identifier a symbol
+ | (qp_1 ... qp_n) list of n elements
+ | (qp_1 ... qp_n . qp_{n+1}) list of n or more
+ | (qp_1 ... qp_n qp_n+1 ooo) list of n or more, each element
+ of remainder must match qp_n+1
+ | #(qp_1 ... qp_n) vector of n elements
+ | #(qp_1 ... qp_n qp_n+1 ooo) vector of n or more, each element
+ of remainder must match qp_n+1
+ | #&qp box
+ | ,pat a pattern
+ | ,@pat a pattern
address@hidden verbatim
+
+The names @code{quote}, @code{quasiquote}, @code{unquote},
address@hidden, @code{?}, @code{_}, @code{$}, @code{and},
address@hidden, @code{not}, @code{set!}, @code{get!}, @code{...}, and
address@hidden cannot be used as pattern variables.
+
+
+Guile also comes with a pattern matcher specifically tailored to SXML
+trees, @xref{sxml-match}.
diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi
index 4bdec27..5fee65f 100644
--- a/doc/ref/r6rs.texi
+++ b/doc/ref/r6rs.texi
@@ -1442,7 +1442,7 @@ library. @xref{Writing}, for documentation.
The @code{(rnrs files (6))} library provides the @code{file-exists?} and
@code{delete-file} procedures, which test for the existence of a file
-and allow the deletion of files from the filesystem, respectively.
+and allow the deletion of files from the file system, respectively.
These procedures are identical to the ones provided by Guile's core
library. @xref{File System}, for documentation.
diff --git a/doc/ref/sxml-match.texi b/doc/ref/sxml-match.texi
index 828c838..f92331b 100644
--- a/doc/ref/sxml-match.texi
+++ b/doc/ref/sxml-match.texi
@@ -38,8 +38,8 @@ illustration, transforming a music album catalog language
into HTML.
Three macros are provided: @code{sxml-match}, @code{sxml-match-let}, and
@code{sxml-match-let*}.
-Compared to a standard s-expression pattern matcher, @code{sxml-match} provides
-the following benefits:
+Compared to a standard s-expression pattern matcher (@pxref{Pattern
+Matching}), @code{sxml-match} provides the following benefits:
@itemize
@item
diff --git a/libguile/async.c b/libguile/async.c
index e448dc1..1412448 100644
--- a/libguile/async.c
+++ b/libguile/async.c
@@ -24,7 +24,6 @@
#define SCM_BUILDING_DEPRECATED_CODE
-#include <signal.h>
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/throw.h"
diff --git a/libguile/error.c b/libguile/error.c
index a582c86..4b6bab8 100644
--- a/libguile/error.c
+++ b/libguile/error.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2006 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2006, 2010 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,6 +23,7 @@
# include <config.h>
#endif
+#include <stdlib.h>
#include <stdio.h>
#include <errno.h>
@@ -94,7 +95,7 @@ SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0,
/* No return, but just in case: */
fprintf (stderr, "Guile scm_ithrow returned!\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
#undef FUNC_NAME
diff --git a/libguile/eval.c b/libguile/eval.c
index 752ba2c..f0a4ea5 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -24,7 +24,6 @@
#endif
#include <alloca.h>
-#include <assert.h>
#include "libguile/__scm.h"
diff --git a/libguile/init.c b/libguile/init.c
index b511aae..6e4ee0e 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -25,6 +25,7 @@
# include <config.h>
#endif
+#include <stdlib.h>
#include <stdio.h>
#include <sys/stat.h>
#include <fcntl.h>
@@ -160,7 +161,7 @@ fixconfig (char *s1, char *s2, int s)
fputs ("\nin ", stderr);
fputs (s ? "setjump" : "scmfig", stderr);
fputs (".h and recompile scm\n", stderr);
- exit (1);
+ exit (EXIT_FAILURE);
}
@@ -326,8 +327,8 @@ static void *invoke_main_func(void *body_data);
Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV. MAIN_FUNC
should do all the work of the program (initializing other packages,
reading user input, etc.) before returning. When MAIN_FUNC
- returns, call exit (0); this function never returns. If you want
- some other exit value, MAIN_FUNC may call exit itself.
+ returns, call exit (EXIT_FAILURE); this function never returns.
+ If you want some other exit value, MAIN_FUNC may call exit itself.
scm_boot_guile arranges for program-arguments to return the strings
given by ARGC and ARGV. If MAIN_FUNC modifies ARGC/ARGV, should
@@ -368,7 +369,7 @@ scm_boot_guile (int argc, char ** argv, void (*main_func)
(), void *closure)
if (res == NULL)
exit (EXIT_FAILURE);
else
- exit (0);
+ exit (EXIT_SUCCESS);
}
static void *
diff --git a/libguile/null-threads.h b/libguile/null-threads.h
index ec83ab7..116b845 100644
--- a/libguile/null-threads.h
+++ b/libguile/null-threads.h
@@ -3,7 +3,7 @@
#ifndef SCM_NULL_THREADS_H
#define SCM_NULL_THREADS_H
-/* Copyright (C) 2005, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 2005, 2006, 2010 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
@@ -33,15 +33,16 @@
goal.
*/
+#include <stdlib.h>
#include <errno.h>
-/* Threads
+/* Threads
*/
#define scm_i_pthread_t int
#define scm_i_pthread_self() 0
#define scm_i_pthread_create(t,a,f,d) (*(t)=0, (void)(f), ENOSYS)
#define scm_i_pthread_detach(t) do { } while (0)
-#define scm_i_pthread_exit(v) exit(0)
+#define scm_i_pthread_exit(v) exit (EXIT_SUCCESS)
#define scm_i_pthread_cancel(t) 0
#define scm_i_pthread_cleanup_push(t,v) 0
#define scm_i_pthread_cleanup_pop(e) 0
diff --git a/libguile/script.c b/libguile/script.c
index 3ea425c..03d5de1 100644
--- a/libguile/script.c
+++ b/libguile/script.c
@@ -22,6 +22,7 @@
# include <config.h>
#endif
+#include <stdlib.h>
#include <stdio.h>
#include <errno.h>
#include <ctype.h>
@@ -643,7 +644,7 @@ scm_compile_shell_switches (int argc, char **argv)
|| ! strcmp (argv[i], "--help"))
{
scm_shell_usage (0, 0);
- exit (0);
+ exit (EXIT_SUCCESS);
}
else if (! strcmp (argv[i], "-v")
@@ -653,7 +654,7 @@ scm_compile_shell_switches (int argc, char **argv)
version_etc (stdout, scm_usage_name, PACKAGE_NAME, PACKAGE_VERSION,
/* XXX: Use gettext for the string below. */
"the Guile developers", NULL);
- exit (0);
+ exit (EXIT_SUCCESS);
}
else
diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm
index cbb2525..7cedff0 100644
--- a/module/ice-9/match.scm
+++ b/module/ice-9/match.scm
@@ -30,7 +30,8 @@
;; Compared to Andrew K. Wright's `match', this one lacks `match-define',
;; `match:error-control', `match:set-error-control', `match:error',
-;; `match:set-error', and all structure-related procedures.
+;; `match:set-error', and all structure-related procedures. Also,
+;; `match' doesn't support clauses of the form `(pat => exp)'.
;; Unmodified public domain code by Alex Shinn retrieved from
;; <http://synthcode.com/scheme/match.scm>.
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 27aa39e..8527293 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -336,6 +336,12 @@ end-of-list checking in contexts where dotted lists are
allowed."
(define second cadr)
(define third caddr)
(define fourth cadddr)
+(define (fifth x) (car (cddddr x)))
+(define (sixth x) (cadr (cddddr x)))
+(define (seventh x) (caddr (cddddr x)))
+(define (eighth x) (cadddr (cddddr x)))
+(define (ninth x) (car (cddddr (cddddr x))))
+(define (tenth x) (cadr (cddddr (cddddr x))))
(define (car+cdr x)
"Return two values, the `car' and the `cdr' of PAIR."
@@ -466,6 +472,30 @@ that result. See the manual for details."
;;; Searching
+(define (break pred clist)
+ "Return two values, the longest initial prefix of LST whose elements
+all fail the predicate PRED, and the remainder of LST."
+ (let lp ((clist clist) (rl '()))
+ (if (or (null? clist)
+ (pred (car clist)))
+ (values (reverse! rl) clist)
+ (lp (cdr clist) (cons (car clist) rl)))))
+
+(define (break! pred list)
+ "Linear-update variant of `break'."
+ (let loop ((l list)
+ (prev #f))
+ (cond ((null? l)
+ (values list '()))
+ ((pred (car l))
+ (if (pair? prev)
+ (begin
+ (set-cdr! prev '())
+ (values list l))
+ (values '() list)))
+ (else
+ (loop (cdr l) l)))))
+
(define (any pred ls . lists)
(if (null? lists)
(any1 pred ls)
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index ff002b2..c94b802 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -23,7 +23,6 @@
#:use-module (system vm program)
#:use-module (system vm instruction)
#:use-module (system vm objcode)
- #:use-module ((srfi srfi-1) #:select (fold))
#:export (frame-bindings
frame-lookup-binding
frame-binding-ref frame-binding-set!
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index 44db0e3..02c580d 100644
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -207,72 +207,19 @@ SCM_DEFINE (scm_srfi1_append_reverse_x,
"append-reverse!", 2, 0, 0,
}
#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_break, "break", 2, 0, 0,
- (SCM pred, SCM lst),
- "Return two values, the longest initial prefix of @var{lst}\n"
- "whose elements all fail the predicate @var{pred}, and the\n"
- "remainder of @var{lst}.\n"
- "\n"
- "Note that the name @code{break} conflicts with the @code{break}\n"
- "binding established by @code{while}. Applications wanting to\n"
- "use @code{break} from within a @code{while} loop will need to\n"
- "make a new define under a different name.")
-#define FUNC_NAME s_scm_srfi1_break
+SCM
+scm_srfi1_break (SCM pred, SCM lst)
{
- SCM ret, *p;
-
- SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
-
- ret = SCM_EOL;
- p = &ret;
- for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
- {
- SCM elem = SCM_CAR (lst);
- if (scm_is_true (scm_call_1 (pred, elem)))
- goto done;
-
- /* want this elem, tack it onto the end of ret */
- *p = scm_cons (elem, SCM_EOL);
- p = SCM_CDRLOC (*p);
- }
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
-
- done:
- return scm_values (scm_list_2 (ret, lst));
+ CACHE_VAR (break_proc, "break");
+ return scm_call_2 (break_proc, pred, lst);
}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_break_x, "break!", 2, 0, 0,
- (SCM pred, SCM lst),
- "Return two values, the longest initial prefix of @var{lst}\n"
- "whose elements all fail the predicate @var{pred}, and the\n"
- "remainder of @var{lst}. @var{lst} may be modified to form the\n"
- "return.")
-#define FUNC_NAME s_scm_srfi1_break_x
+SCM
+scm_srfi1_break_x (SCM pred, SCM lst)
{
- SCM upto, *p;
-
- SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
-
- p = &lst;
- for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
- {
- if (scm_is_true (scm_call_1 (pred, SCM_CAR (upto))))
- goto done;
-
- /* want this element */
- p = SCM_CDRLOC (upto);
- }
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto), lst, SCM_ARG2, FUNC_NAME, "list");
-
- done:
- *p = SCM_EOL;
- return scm_values (scm_list_2 (lst, upto));
+ CACHE_VAR (break_x, "break!");
+ return scm_call_2 (break_x, pred, lst);
}
-#undef FUNC_NAME
-
SCM
scm_srfi1_car_plus_cdr (SCM pair)
@@ -783,24 +730,19 @@ SCM_DEFINE (scm_srfi1_drop_while, "drop-while", 2, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_srfi1_eighth, "eighth", 1, 0, 0,
- (SCM lst),
- "Return the eighth element of @var{lst}.")
-#define FUNC_NAME s_scm_srfi1_eighth
+SCM
+scm_srfi1_eighth (SCM lst)
{
- return scm_list_ref (lst, SCM_I_MAKINUM (7));
+ CACHE_VAR (eighth, "eighth");
+ return scm_call_1 (eighth, lst);
}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_fifth, "fifth", 1, 0, 0,
- (SCM lst),
- "Return the fifth element of @var{lst}.")
-#define FUNC_NAME s_scm_srfi1_fifth
+SCM
+scm_srfi1_fifth (SCM lst)
{
- return scm_list_ref (lst, SCM_I_MAKINUM (4));
+ CACHE_VAR (fifth, "fifth");
+ return scm_call_1 (fifth, lst);
}
-#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_filter_map, "filter-map", 2, 0, 1,
@@ -1398,14 +1340,12 @@ SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_srfi1_ninth, "ninth", 1, 0, 0,
- (SCM lst),
- "Return the ninth element of @var{lst}.")
-#define FUNC_NAME s_scm_srfi1_ninth
+SCM
+scm_srfi1_ninth (SCM lst)
{
- return scm_list_ref (lst, scm_from_int (8));
+ CACHE_VAR (ninth, "ninth");
+ return scm_call_1 (ninth, lst);
}
-#undef FUNC_NAME
SCM
scm_srfi1_not_pair_p (SCM obj)
@@ -1696,24 +1636,19 @@ SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_srfi1_seventh, "seventh", 1, 0, 0,
- (SCM lst),
- "Return the seventh element of @var{lst}.")
-#define FUNC_NAME s_scm_srfi1_seventh
+SCM
+scm_srfi1_seventh (SCM lst)
{
- return scm_list_ref (lst, scm_from_int (6));
+ CACHE_VAR (seventh, "seventh");
+ return scm_call_1 (seventh, lst);
}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_sixth, "sixth", 1, 0, 0,
- (SCM lst),
- "Return the sixth element of @var{lst}.")
-#define FUNC_NAME s_scm_srfi1_sixth
+SCM
+scm_srfi1_sixth (SCM lst)
{
- return scm_list_ref (lst, scm_from_int (5));
+ CACHE_VAR (sixth, "sixth");
+ return scm_call_1 (sixth, lst);
}
-#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_span, "span", 2, 0, 0,
@@ -1931,16 +1866,12 @@ SCM_DEFINE (scm_srfi1_take_while_x, "take-while!", 2,
0, 0,
}
#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_tenth, "tenth", 1, 0, 0,
- (SCM lst),
- "Return the tenth element of @var{lst}.")
-#define FUNC_NAME s_scm_srfi1_tenth
+SCM
+scm_srfi1_tenth (SCM lst)
{
- return scm_list_ref (lst, scm_from_int (9));
+ CACHE_VAR (tenth, "tenth");
+ return scm_call_1 (tenth, lst);
}
-#undef FUNC_NAME
-
SCM
scm_srfi1_xcons (SCM d, SCM a)
diff --git a/test-suite/standalone/test-conversion.c
b/test-suite/standalone/test-conversion.c
index 4480125..124ae9d 100644
--- a/test-suite/standalone/test-conversion.c
+++ b/test-suite/standalone/test-conversion.c
@@ -22,6 +22,7 @@
#include <libguile.h>
+#include <stdlib.h>
#include <stdio.h>
#include <string.h>
@@ -50,7 +51,7 @@ test_1 (const char *str, scm_t_intmax min, scm_t_intmax max,
fprintf (stderr, "fail: scm_is_signed_integer (%s, "
"%" PRIiMAX ", %" PRIiMAX ") == %d\n",
str, min, max, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
@@ -136,7 +137,7 @@ test_2 (const char *str, scm_t_uintmax min, scm_t_uintmax
max,
fprintf (stderr, "fail: scm_is_unsigned_integer (%s, "
"%" PRIuMAX ", %" PRIuMAX ") == %d\n",
str, min, max, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
@@ -257,7 +258,7 @@ test_3 (const char *str, scm_t_intmax min, scm_t_intmax max,
"fail: scm_to_signed_int (%s, "
"%" PRIiMAX ", %" PRIiMAX ") -> out of range\n",
str, min, max);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else if (type_error)
@@ -270,7 +271,7 @@ test_3 (const char *str, scm_t_intmax min, scm_t_intmax max,
"fail: scm_to_signed_int (%s, "
"%" PRIiMAX", %" PRIiMAX ") -> wrong type\n",
str, min, max);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else
@@ -284,7 +285,7 @@ test_3 (const char *str, scm_t_intmax min, scm_t_intmax max,
"fail: scm_to_signed_int (%s, "
"%" PRIiMAX ", %" PRIiMAX ") = %" PRIiMAX "\n",
str, min, max, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
}
@@ -392,7 +393,7 @@ test_4 (const char *str, scm_t_uintmax min, scm_t_uintmax
max,
"fail: scm_to_unsigned_int (%s, "
"%" PRIuMAX ", %" PRIuMAX ") -> out of range\n",
str, min, max);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else if (type_error)
@@ -405,7 +406,7 @@ test_4 (const char *str, scm_t_uintmax min, scm_t_uintmax
max,
"fail: scm_to_unsigned_int (%s, "
"%" PRIuMAX ", %" PRIuMAX ") -> wrong type\n",
str, min, max);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else
@@ -419,7 +420,7 @@ test_4 (const char *str, scm_t_uintmax min, scm_t_uintmax
max,
"fail: scm_to_unsigned_int (%s, "
"%" PRIuMAX ", %" PRIuMAX ") == %" PRIuMAX "\n",
str, min, max, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
}
@@ -475,7 +476,7 @@ test_5 (scm_t_intmax val, const char *result)
{
fprintf (stderr, "fail: scm_from_signed_integer (%" PRIiMAX ") == %s\n",
val, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
@@ -508,7 +509,7 @@ test_6 (scm_t_uintmax val, const char *result)
fprintf (stderr, "fail: scm_from_unsigned_integer (%"
PRIuMAX ") == %s\n",
val, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
@@ -536,7 +537,7 @@ test_7s (SCM n, scm_t_intmax c_n, const char *result, const
char *func)
if (scm_is_false (scm_equal_p (n, r)))
{
fprintf (stderr, "fail: %s (%" PRIiMAX ") == %s\n", func, c_n, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
@@ -550,7 +551,7 @@ test_7u (SCM n, scm_t_uintmax c_n, const char *result,
const char *func)
if (scm_is_false (scm_equal_p (n, r)))
{
fprintf (stderr, "fail: %s (%" PRIuMAX ") == %s\n", func, c_n, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
@@ -586,7 +587,7 @@ test_8s (const char *str, scm_t_intmax (*func) (SCM), const
char *func_name,
{
fprintf (stderr,
"fail: %s (%s) -> out of range\n", func_name, str);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else if (type_error)
@@ -597,7 +598,7 @@ test_8s (const char *str, scm_t_intmax (*func) (SCM), const
char *func_name,
{
fprintf (stderr,
"fail: %s (%s) -> wrong type\n", func_name, str);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else
@@ -609,7 +610,7 @@ test_8s (const char *str, scm_t_intmax (*func) (SCM), const
char *func_name,
{
fprintf (stderr,
"fail: %s (%s) = %" PRIiMAX "\n", func_name, str, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
}
@@ -644,7 +645,7 @@ test_8u (const char *str, scm_t_uintmax (*func) (SCM),
const char *func_name,
{
fprintf (stderr,
"fail: %s (%s) -> out of range\n", func_name, str);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else if (type_error)
@@ -655,7 +656,7 @@ test_8u (const char *str, scm_t_uintmax (*func) (SCM),
const char *func_name,
{
fprintf (stderr,
"fail: %s (%s) -> wrong type\n", func_name, str);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else
@@ -667,7 +668,7 @@ test_8u (const char *str, scm_t_uintmax (*func) (SCM),
const char *func_name,
{
fprintf (stderr,
"fail: %s (%s) = %" PRIiMAX "\n", func_name, str, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
}
@@ -808,7 +809,7 @@ test_9 (double val, const char *result)
if (scm_is_false (scm_eqv_p (res, scm_from_double (val))))
{
fprintf (stderr, "fail: scm_from_double (%g) == %s\n", val, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
@@ -895,7 +896,7 @@ test_10 (const char *val, double result, int type_error)
{
fprintf (stderr,
"fail: scm_double (%s) -> wrong type\n", val);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else
@@ -907,7 +908,7 @@ test_10 (const char *val, double result, int type_error)
{
fprintf (stderr,
"fail: scm_to_double (%s) = %g\n", val, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
}
@@ -952,7 +953,7 @@ test_11 (const char *str, const char *result, int
misc_error, int type_error)
{
fprintf (stderr,
"fail: scm_to_locale_string (%s) -> misc error\n", str);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else if (type_error)
@@ -963,7 +964,7 @@ test_11 (const char *str, const char *result, int
misc_error, int type_error)
{
fprintf (stderr,
"fail: scm_to_locale_string (%s) -> wrong type\n", str);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else
@@ -975,7 +976,7 @@ test_11 (const char *str, const char *result, int
misc_error, int type_error)
{
fprintf (stderr,
"fail: scm_to_locale_string (%s) = %s\n", str, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
@@ -994,7 +995,7 @@ test_locale_strings ()
if (!scm_is_string (scm_c_eval_string ("\"foo\"")))
{
fprintf (stderr, "fail: scm_is_string (\"foo\") = true\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
str = scm_from_locale_string (lstr);
@@ -1002,14 +1003,14 @@ test_locale_strings ()
if (!scm_is_string (str))
{
fprintf (stderr, "fail: scm_is_string (str) = true\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
lstr2 = scm_to_locale_string (str);
if (strcmp (lstr, lstr2))
{
fprintf (stderr, "fail: lstr = lstr2\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
free (lstr2);
@@ -1018,17 +1019,17 @@ test_locale_strings ()
if (len != strlen (lstr))
{
fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = strlen(lstr)\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
if (buf[15] != 'x')
{
fprintf (stderr, "fail: scm_to_locale_stringbuf (...) no overrun\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
if (strncmp (lstr, buf, 15))
{
fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = lstr\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
str2 = scm_from_locale_stringn (lstr, 10);
@@ -1036,14 +1037,14 @@ test_locale_strings ()
if (!scm_is_string (str2))
{
fprintf (stderr, "fail: scm_is_string (str2) = true\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
lstr2 = scm_to_locale_string (str2);
if (strncmp (lstr, lstr2, 10))
{
fprintf (stderr, "fail: lstr = lstr2\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
free (lstr2);
@@ -1052,24 +1053,24 @@ test_locale_strings ()
if (len != 10)
{
fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = 10\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
if (buf[10] != 'x')
{
fprintf (stderr, "fail: scm_to_locale_stringbuf (...) no overrun\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
if (strncmp (lstr, buf, 10))
{
fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = lstr\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
lstr2 = scm_to_locale_stringn (str2, &len);
if (len != 10)
{
fprintf (stderr, "fail: scm_to_locale_stringn, len = 10\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
test_11 ("#f", NULL, 0, 1);
diff --git a/test-suite/standalone/test-list.c
b/test-suite/standalone/test-list.c
index b298a4e..2efaf5c 100644
--- a/test-suite/standalone/test-list.c
+++ b/test-suite/standalone/test-list.c
@@ -1,6 +1,6 @@
/* test-list.c - exercise libguile/list.c functions */
-/* Copyright (C) 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2008, 2009, 2010 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
@@ -24,6 +24,7 @@
#include <libguile.h>
+#include <stdlib.h>
#include <stdio.h>
#include <string.h>
@@ -36,7 +37,7 @@ test_scm_list (void)
if (! scm_is_eq (SCM_EOL, scm_list (SCM_EOL)))
{
fprintf (stderr, "fail: scm_list SCM_EOL\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
}
@@ -45,7 +46,7 @@ test_scm_list (void)
if (! scm_is_true (scm_equal_p (lst, scm_list (lst))))
{
fprintf (stderr, "fail: scm_list '(1 2)\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
}
}
diff --git a/test-suite/standalone/test-srfi-1.c
b/test-suite/standalone/test-srfi-1.c
index 215008d..995c20e 100644
--- a/test-suite/standalone/test-srfi-1.c
+++ b/test-suite/standalone/test-srfi-1.c
@@ -27,10 +27,18 @@
#include <stdlib.h>
+static void
+failure (const char *proc, SCM result)
+{
+ scm_simple_format (scm_current_error_port (),
+ scm_from_locale_string ("`~S' failed: ~S~%"),
+ scm_list_2 (scm_from_locale_symbol (proc), result));
+}
+
static void *
tests (void *data)
{
- SCM times, lst, result;
+ SCM times, negative_p, lst, result;
scm_init_srfi_1 ();
@@ -41,9 +49,27 @@ tests (void *data)
result = scm_srfi1_fold (times, scm_from_int (1), lst, scm_list_1 (lst));
if (scm_to_int (result) == 36)
- * (int *) data = EXIT_SUCCESS;
+ {
+ negative_p = SCM_VARIABLE_REF (scm_c_lookup ("negative?"));
+ result = scm_srfi1_break (negative_p,
+ scm_list_3 (scm_from_int (1),
+ scm_from_int (2),
+ scm_from_int (-1)));
+
+ if (SCM_VALUESP (result))
+ /* There's no API to access the values, so assume this is OK. */
+ * (int *) data = EXIT_SUCCESS;
+ else
+ {
+ failure ("break", result);
+ * (int *) data = EXIT_FAILURE;
+ }
+ }
else
- * (int *) data = EXIT_FAILURE;
+ {
+ failure ("fold", result);
+ * (int *) data = EXIT_FAILURE;
+ }
return data;
}
diff --git a/test-suite/standalone/test-unwind.c
b/test-suite/standalone/test-unwind.c
index 2d6894d..cf56a96 100644
--- a/test-suite/standalone/test-unwind.c
+++ b/test-suite/standalone/test-unwind.c
@@ -129,7 +129,7 @@ check_flag1 (const char *tag, void (*func)(void), int val)
if (flag1 != val)
{
printf ("%s failed\n", tag);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
@@ -170,7 +170,7 @@ check_cont (int rewindable)
if (rewindable)
return;
printf ("continuation not blocked\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
else
{
@@ -178,7 +178,7 @@ check_cont (int rewindable)
if (!rewindable)
return;
printf ("continuation didn't work\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
}
@@ -211,7 +211,7 @@ check_ports ()
/* Sanity check: Make sure that `filename' is actually writeable.
We used to use mktemp(3), but that is now considered a security risk. */
if (0 > mkstemp (filename))
- exit (1);
+ exit (EXIT_FAILURE);
scm_dynwind_begin (0);
{
@@ -239,7 +239,7 @@ check_ports ()
if (scm_is_false (scm_equal_p (res, scm_version ())))
{
printf ("ports didn't work\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
}
scm_dynwind_end ();
@@ -262,13 +262,13 @@ check_fluid ()
if (!scm_is_eq (x, scm_from_int (13)))
{
printf ("setting fluid didn't work\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
if (!scm_is_eq (scm_fluid_ref (f), scm_from_int (12)))
{
printf ("resetting fluid didn't work\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
}
@@ -287,7 +287,7 @@ inner_main (void *data, int argc, char **argv)
check_fluid ();
- exit (0);
+ exit (EXIT_SUCCESS);
}
int
diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index 909f58c..ca34e8f 100644
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -964,7 +964,7 @@
;;
(with-test-prefix "eighth"
- (pass-if-exception "() -1" exception:out-of-range
+ (pass-if-exception "() -1" exception:wrong-type-arg
(eighth '(a b c d e f g)))
(pass-if (eq? 'h (eighth '(a b c d e f g h))))
(pass-if (eq? 'h (eighth '(a b c d e f g h i)))))
@@ -974,7 +974,7 @@
;;
(with-test-prefix "fifth"
- (pass-if-exception "() -1" exception:out-of-range
+ (pass-if-exception "() -1" exception:wrong-type-arg
(fifth '(a b c d)))
(pass-if (eq? 'e (fifth '(a b c d e))))
(pass-if (eq? 'e (fifth '(a b c d e f)))))
@@ -1900,7 +1900,7 @@
;;
(with-test-prefix "ninth"
- (pass-if-exception "() -1" exception:out-of-range
+ (pass-if-exception "() -1" exception:wrong-type-arg
(ninth '(a b c d e f g h)))
(pass-if (eq? 'i (ninth '(a b c d e f g h i))))
(pass-if (eq? 'i (ninth '(a b c d e f g h i j)))))
@@ -2283,7 +2283,7 @@
;;
(with-test-prefix "seventh"
- (pass-if-exception "() -1" exception:out-of-range
+ (pass-if-exception "() -1" exception:wrong-type-arg
(seventh '(a b c d e f)))
(pass-if (eq? 'g (seventh '(a b c d e f g))))
(pass-if (eq? 'g (seventh '(a b c d e f g h)))))
@@ -2293,7 +2293,7 @@
;;
(with-test-prefix "sixth"
- (pass-if-exception "() -1" exception:out-of-range
+ (pass-if-exception "() -1" exception:wrong-type-arg
(sixth '(a b c d e)))
(pass-if (eq? 'f (sixth '(a b c d e f))))
(pass-if (eq? 'f (sixth '(a b c d e f g)))))
@@ -2578,7 +2578,7 @@
;;
(with-test-prefix "tenth"
- (pass-if-exception "() -1" exception:out-of-range
+ (pass-if-exception "() -1" exception:wrong-type-arg
(tenth '(a b c d e f g h i)))
(pass-if (eq? 'j (tenth '(a b c d e f g h i j))))
(pass-if (eq? 'j (tenth '(a b c d e f g h i j k)))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-11-282-g358663c,
Ludovic Courtès <=