[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-562-g1df515a
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-562-g1df515a |
|
Date: |
Thu, 09 Jan 2014 07:55:54 +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=1df515a077f26d59510e48fad3d45a33d2c90e0f
The branch, master has been updated
via 1df515a077f26d59510e48fad3d45a33d2c90e0f (commit)
via 306cc01d3981feaa11aa0d866ff1d99128f0ace3 (commit)
via 793e8a9317d24298c82389bdf86b8ca17b4ee2f0 (commit)
via 900a897cd31df98df06b84a478b77a7438739b54 (commit)
via f659df44954a7f182361395396c5e0340b08c7dd (commit)
via 4101d14f2e8857cb50489a1027d853a1aa565239 (commit)
via 6146984cc5f5788836eca55c52bac66cb96ddc73 (commit)
via a662686a25df19970e15f3b642ab08db5128489b (commit)
via b6203a189ba9e3bc8d72529528ab75b62a2c46e1 (commit)
via 265e7bd92a3d8720ca94d64443878d309250ecba (commit)
via 70511cc4037c9129cf501d87c79d19f062d56357 (commit)
via ecf0498df562c1e5cf5b6d585fd9e8a9fe6cebe4 (commit)
via 0b83be7eb64eb11479d2bec867d428afb46b5f58 (commit)
via 70c74b847680d3b239e591afa2e99c51a712980c (commit)
via 032a16fced2128626e13e6964ea39f1c8fe44091 (commit)
via aa8630efb37e71db56430d2090b0aaabbbaf2df3 (commit)
via d8c476b68d2c8c1aee3cefd5226f091ce34c7c2a (commit)
from 61989c705359c50c61d7f52392f244d386218298 (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 1df515a077f26d59510e48fad3d45a33d2c90e0f
Merge: 61989c7 306cc01
Author: Mark H Weaver <address@hidden>
Date: Thu Jan 9 01:32:32 2014 -0500
Merge branch 'stable-2.0'
Conflicts:
module/system/vm/traps.scm
test-suite/tests/peval.test
-----------------------------------------------------------------------
Summary of changes:
THANKS | 2 +
doc/ref/api-data.texi | 27 +++++++++++++++--
libguile/load.c | 15 +++------
libguile/numbers.c | 23 +++++++++++++-
libguile/numbers.h | 2 +
libguile/private-options.h | 2 +-
libguile/read.c | 3 ++
libguile/socket.c | 2 +-
libguile/srfi-13.c | 13 ++++++--
meta/guile.m4 | 45 ++++++++++++++++++++++++-----
module/ice-9/boot-9.scm | 3 ++
module/ice-9/psyntax-pp.scm | 25 +++++++++-------
module/ice-9/psyntax.scm | 17 ++++++-----
module/language/tree-il/peval.scm | 38 +++++++++++++-----------
module/system/vm/traps.scm | 23 ++++++++------
test-suite/tests/numbers.test | 28 ++++++++++++++++++
test-suite/tests/peval.test | 16 ++++++++++-
test-suite/tests/srfi-13.test | 15 ++++++++--
test-suite/tests/syntax.test | 57 +++++++++++++++++++++++++++++++++++++
19 files changed, 276 insertions(+), 80 deletions(-)
diff --git a/THANKS b/THANKS
index 63f8feb..90a4357 100644
--- a/THANKS
+++ b/THANKS
@@ -2,6 +2,7 @@ Contributors since the last release:
Greg Benison
Tristan Colgate-McFarlane
+ Aleix Conchillo Flaqué
Ludovic Courtès
Jason Earl
Brian Gough
@@ -167,6 +168,7 @@ For fixes or providing information which led to a fix:
Rainer Tammer
Samuel Thibault
Richard Todd
+ Tom Tromey
Issac Trotts
Greg Troxel
Aaron M. Ucko
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 7603180..59d7db0 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -1,7 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
address@hidden 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
address@hidden 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software
Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Simple Data Types
@@ -318,7 +318,8 @@ Scheme integers can be exact and inexact. For example, a
number
written as @code{3.0} with an explicit decimal-point is inexact, but
it is also an integer. The functions @code{integer?} and
@code{scm_is_integer} report true for such a number, but the functions
address@hidden and @code{scm_is_unsigned_integer} only
address@hidden, @code{scm_is_exact_integer},
address@hidden, and @code{scm_is_unsigned_integer} only
allow exact integers and thus report false. Likewise, the conversion
functions like @code{scm_to_signed_integer} only accept exact
integers.
@@ -333,7 +334,7 @@ will become exact fractions.)
@deffn {Scheme Procedure} integer? x
@deffnx {C Function} scm_integer_p (x)
Return @code{#t} if @var{x} is an exact or inexact integer number, else
address@hidden
+return @code{#f}.
@lisp
(integer? 487)
@@ -346,7 +347,7 @@ Return @code{#t} if @var{x} is an exact or inexact integer
number, else
@result{} #f
(integer? +inf.0)
address@hidden #t
address@hidden #f
@end lisp
@end deffn
@@ -354,6 +355,24 @@ Return @code{#t} if @var{x} is an exact or inexact integer
number, else
This is equivalent to @code{scm_is_true (scm_integer_p (x))}.
@end deftypefn
address@hidden {Scheme Procedure} exact-integer? x
address@hidden {C Function} scm_exact_integer_p (x)
+Return @code{#t} if @var{x} is an exact integer number, else
+return @code{#f}.
+
address@hidden
+(exact-integer? 37)
address@hidden #t
+
+(exact-integer? 3.0)
address@hidden #f
address@hidden lisp
address@hidden deffn
+
address@hidden {C Function} int scm_is_exact_integer (SCM x)
+This is equivalent to @code{scm_is_true (scm_exact_integer_p (x))}.
address@hidden deftypefn
+
@defvr {C Type} scm_t_int8
@defvrx {C Type} scm_t_uint8
@defvrx {C Type} scm_t_int16
diff --git a/libguile/load.c b/libguile/load.c
index 16e3fb2..5019201 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -88,7 +88,6 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
{
SCM hook = *scm_loc_load_hook;
SCM ret = SCM_UNSPECIFIED;
- char *encoding;
SCM_VALIDATE_STRING (1, filename);
if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook)))
@@ -101,18 +100,14 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
{
SCM port;
- port = scm_open_file (filename, scm_from_locale_string ("r"));
+ port = scm_open_file_with_encoding (filename,
+ scm_from_latin1_string ("r"),
+ SCM_BOOL_T, /* guess_encoding */
+ scm_from_latin1_string ("UTF-8"));
+
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
scm_i_dynwind_current_load_port (port);
- encoding = scm_i_scan_for_encoding (port);
- if (encoding)
- scm_i_set_port_encoding_x (port, encoding);
- else
- /* The file has no encoding declared. We'll presume UTF-8, like
- compile-file does. */
- scm_i_set_port_encoding_x (port, "UTF-8");
-
while (1)
{
SCM reader, form;
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 2ed98d3..f4e8b27 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -6519,8 +6519,8 @@ SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0,
SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
(SCM x),
- "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
- "else.")
+ "Return @code{#t} if @var{x} is an integer number,\n"
+ "else return @code{#f}.")
#define FUNC_NAME s_scm_integer_p
{
if (SCM_I_INUMP (x) || SCM_BIGP (x))
@@ -6535,6 +6535,19 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_exact_integer_p, "exact-integer?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an exact integer number,\n"
+ "else return @code{#f}.")
+#define FUNC_NAME s_scm_exact_integer_p
+{
+ if (SCM_I_INUMP (x) || SCM_BIGP (x))
+ return SCM_BOOL_T;
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
SCM scm_i_num_eq_p (SCM, SCM, SCM);
SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1,
@@ -9624,6 +9637,12 @@ scm_is_integer (SCM val)
}
int
+scm_is_exact_integer (SCM val)
+{
+ return scm_is_true (scm_exact_integer_p (val));
+}
+
+int
scm_is_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max)
{
if (SCM_I_INUMP (val))
diff --git a/libguile/numbers.h b/libguile/numbers.h
index 5cdfbac..6e382ea 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -242,6 +242,7 @@ SCM_API SCM scm_complex_p (SCM x);
SCM_API SCM scm_real_p (SCM x);
SCM_API SCM scm_rational_p (SCM z);
SCM_API SCM scm_integer_p (SCM x);
+SCM_API SCM scm_exact_integer_p (SCM x);
SCM_API SCM scm_inexact_p (SCM x);
SCM_API int scm_is_inexact (SCM x);
SCM_API SCM scm_num_eq_p (SCM x, SCM y);
@@ -330,6 +331,7 @@ SCM_INTERNAL void scm_i_print_complex (double real, double
imag, SCM port);
/* conversion functions for integers */
SCM_API int scm_is_integer (SCM val);
+SCM_API int scm_is_exact_integer (SCM val);
SCM_API int scm_is_signed_integer (SCM val,
scm_t_intmax min, scm_t_intmax max);
SCM_API int scm_is_unsigned_integer (SCM val,
diff --git a/libguile/private-options.h b/libguile/private-options.h
index ed0f314..4f580a6 100644
--- a/libguile/private-options.h
+++ b/libguile/private-options.h
@@ -69,6 +69,6 @@ SCM_INTERNAL scm_t_option scm_read_opts[];
#define SCM_HUNGRY_EOL_ESCAPES_P scm_read_opts[6].val
#define SCM_CURLY_INFIX_P scm_read_opts[7].val
-#define SCM_N_READ_OPTIONS 7
+#define SCM_N_READ_OPTIONS 8
#endif /* PRIVATE_OPTIONS */
diff --git a/libguile/read.c b/libguile/read.c
index 382a1d3..61addf3 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -1116,6 +1116,9 @@ read_decimal_integer (SCM port, int c, ssize_t *resp)
while ('0' <= c && c <= '9')
{
+ if (((SSIZE_MAX - (c-'0')) / 10) <= res)
+ scm_i_input_error ("read_decimal_integer", port,
+ "number too large", SCM_EOL);
res = 10*res + c-'0';
got_it = 1;
c = scm_getc_unlocked (port);
diff --git a/libguile/socket.c b/libguile/socket.c
index 34bc21a..8c1326a 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -1331,7 +1331,7 @@ SCM_DEFINE (scm_accept, "accept", 1, 0, 0,
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (sock);
- newfd = accept (fd, (struct sockaddr *) &addr, &addr_size);
+ SCM_SYSCALL (newfd = accept (fd, (struct sockaddr *) &addr, &addr_size));
if (newfd == -1)
SCM_SYSERROR;
newsock = SCM_SOCK_FD_TO_PORT (newfd);
diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c
index 4e5d572..5c30dfe 100644
--- a/libguile/srfi-13.c
+++ b/libguile/srfi-13.c
@@ -546,10 +546,17 @@ SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0,
SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart);
target = scm_i_string_start_writing (target);
- for (i = 0; i < cend - cstart; i++)
+ if (ctstart < cstart)
{
- scm_i_string_set_x (target, ctstart + i,
- scm_i_string_ref (s, cstart + i));
+ for (i = 0; i < len; i++)
+ scm_i_string_set_x (target, ctstart + i,
+ scm_i_string_ref (s, cstart + i));
+ }
+ else
+ {
+ for (i = len; i--;)
+ scm_i_string_set_x (target, ctstart + i,
+ scm_i_string_ref (s, cstart + i));
}
scm_i_string_stop_writing ();
scm_remember_upto_here_1 (target);
diff --git a/meta/guile.m4 b/meta/guile.m4
index a3e1ef1..29eccec 100644
--- a/meta/guile.m4
+++ b/meta/guile.m4
@@ -1,17 +1,17 @@
## Autoconf macros for working with Guile.
##
-## Copyright (C) 1998,2001, 2006, 2010, 2012 Free Software Foundation, Inc.
+## Copyright (C) 1998,2001, 2006, 2010, 2012, 2013 Free Software Foundation,
Inc.
##
## This library is free software; you can redistribute it and/or
## modify it under the terms of the GNU Lesser General Public License
## as published by the Free Software Foundation; either version 3 of
## the License, or (at your option) any later version.
-##
+##
## This library is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
## Lesser General Public License for more details.
-##
+##
## You should have received a copy of the GNU Lesser General Public
## License along with this library; if not, write to the Free Software
## Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
@@ -177,12 +177,16 @@ AC_DEFUN([GUILE_SITE_DIR],
# GUILE_PROGS -- set paths to Guile interpreter, config and tool programs
#
-# Usage: GUILE_PROGS
+# Usage: GUILE_PROGS([VERSION])
#
# This macro looks for programs @code{guile} and @code{guild}, setting
# variables @var{GUILE} and @var{GUILD} to their paths, respectively.
# If @code{guile} is not found, signal an error.
#
+# By default, this macro will search for the latest stable version of
+# Guile (e.g. 2.0). x.y or x.y.z versions can be specified. If an older
+# version is found, the macro will signal an error.
+#
# The effective version of the found @code{guile} is set to
# @var{GUILE_EFFECTIVE_VERSION}. This macro ensures that the effective
# version is compatible with the result of a previous invocation of
@@ -195,17 +199,42 @@ AC_DEFUN([GUILE_SITE_DIR],
#
AC_DEFUN([GUILE_PROGS],
[AC_PATH_PROG(GUILE,guile)
+ _guile_required_version="m4_default([$1], [2.0])"
if test "$GUILE" = "" ; then
AC_MSG_ERROR([guile required but not found])
fi
AC_SUBST(GUILE)
- _guile_prog_version=`$GUILE -c "(display (effective-version))"`
+ _guile_effective_version=`$GUILE -c "(display (effective-version))"`
if test -z "$GUILE_EFFECTIVE_VERSION"; then
- GUILE_EFFECTIVE_VERSION=$_guile_prog_version
- elif test "$GUILE_EFFECTIVE_VERSION" != "$_guile_prog_version"; then
- AC_MSG_ERROR([found development files for Guile $GUILE_EFFECTIVE_VERSION,
but $GUILE has effective version $_guile_prog_version])
+ GUILE_EFFECTIVE_VERSION=$_guile_effective_version
+ elif test "$GUILE_EFFECTIVE_VERSION" != "$_guile_effective_version"; then
+ AC_MSG_ERROR([found development files for Guile $GUILE_EFFECTIVE_VERSION,
but $GUILE has effective version $_guile_effective_version])
+ fi
+
+ _guile_major_version=`$GUILE -c "(display (major-version))"`
+ _guile_minor_version=`$GUILE -c "(display (minor-version))"`
+ _guile_micro_version=`$GUILE -c "(display (micro-version))"`
+
_guile_prog_version="$_guile_major_version.$_guile_minor_version.$_guile_micro_version"
+
+ AC_MSG_CHECKING([for Guile version >= $_guile_required_version])
+ _major_version=`echo $_guile_required_version | cut -d . -f 1`
+ _minor_version=`echo $_guile_required_version | cut -d . -f 2`
+ _micro_version=`echo $_guile_required_version | cut -d . -f 3`
+ if test "$_guile_major_version" -ge "$_major_version"; then
+ if test "$_guile_minor_version" -ge "$_minor_version"; then
+ if test -n "$_micro_version"; then
+ if test "$_guile_micro_version" -lt "$_micro_version"; then
+ AC_MSG_ERROR([Guile $_guile_required_version required, but
$_guile_prog_version found])
+ fi
+ fi
+ else
+ AC_MSG_ERROR([Guile $_guile_required_version required, but
$_guile_prog_version found])
+ fi
+ else
+ AC_MSG_ERROR([Guile $_guile_required_version required, but
$_guile_prog_version found])
fi
+ AC_MSG_RESULT([$_guile_prog_version])
AC_PATH_PROG(GUILD,guild)
AC_SUBST(GUILD)
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 83e5480..3748c13 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3295,6 +3295,9 @@ module '(ice-9 q) '(make-q q-length))}."
;;; {Autoloading modules}
;;;
+;;; XXX FIXME autoloads-in-progress and autoloads-done
+;;; are not handled in a thread-safe way.
+
(define autoloads-in-progress '())
;; This function is called from scm_load_scheme_module in
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index eeffecf..0684890 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -2106,14 +2106,17 @@
(lambda (pattern keys)
(letrec*
((cvt* (lambda (p* n ids)
- (if (not (pair? p*))
- (cvt p* n ids)
- (call-with-values
- (lambda () (cvt* (cdr p*) n ids))
- (lambda (y ids)
- (call-with-values
- (lambda () (cvt (car p*) n ids))
- (lambda (x ids) (values (cons x y) ids))))))))
+ (let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any))))
+ (if tmp
+ (apply (lambda (x y)
+ (call-with-values
+ (lambda () (cvt* y n ids))
+ (lambda (y ids)
+ (call-with-values
+ (lambda () (cvt x n ids))
+ (lambda (x ids) (values (cons x y)
ids))))))
+ tmp)
+ (cvt p* n ids)))))
(v-reverse
(lambda (x)
(let loop ((r '()) (x x))
@@ -2196,10 +2199,10 @@
(call-with-values
(lambda () (convert-pattern pat keys))
(lambda (p pvars)
- (cond ((not (distinct-bound-ids? (map car pvars)))
- (syntax-violation 'syntax-case "duplicate pattern
variable" pat))
- ((not (and-map (lambda (x) (not (ellipsis? (car x))))
pvars))
+ (cond ((not (and-map (lambda (x) (not (ellipsis? (car x))))
pvars))
(syntax-violation 'syntax-case "misplaced ellipsis" pat))
+ ((not (distinct-bound-ids? (map car pvars)))
+ (syntax-violation 'syntax-case "duplicate pattern
variable" pat))
(else
(let ((y (gen-var 'tmp)))
(build-call
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 5368785..cfcea4b 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2441,15 +2441,16 @@
(lambda (pattern keys)
(define cvt*
(lambda (p* n ids)
- (if (not (pair? p*))
- (cvt p* n ids)
- (call-with-values
- (lambda () (cvt* (cdr p*) n ids))
+ (syntax-case p* ()
+ ((x . y)
+ (call-with-values
+ (lambda () (cvt* #'y n ids))
(lambda (y ids)
(call-with-values
- (lambda () (cvt (car p*) n ids))
+ (lambda () (cvt #'x n ids))
(lambda (x ids)
- (values (cons x y) ids))))))))
+ (values (cons x y) ids))))))
+ (_ (cvt p* n ids)))))
(define (v-reverse x)
(let loop ((r '()) (x x))
@@ -2530,10 +2531,10 @@
(lambda () (convert-pattern pat keys))
(lambda (p pvars)
(cond
- ((not (distinct-bound-ids? (map car pvars)))
- (syntax-violation 'syntax-case "duplicate
pattern variable" pat))
((not (and-map (lambda (x) (not (ellipsis? (car
x)))) pvars))
(syntax-violation 'syntax-case "misplaced
ellipsis" pat))
+ ((not (distinct-bound-ids? (map car pvars)))
+ (syntax-violation 'syntax-case "duplicate
pattern variable" pat))
(else
(let ((y (gen-var 'tmp)))
;; fat finger binding and references to temp
variable y
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 8859dd4..8a60d7b 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -731,24 +731,26 @@ top-level bindings from ENV and return the resulting
expression."
(cond
((lookup (lexical-ref-gensym x))
=> (lambda (op)
- (let ((y (or (operand-residual-value op)
- (visit-operand op counter 'value 10 10)
- (operand-source op))))
- (cond
- ((and (lexical-ref? y)
- (= (lexical-refcount (lexical-ref-gensym x)) 1))
- ;; X is a simple alias for Y. Recurse, regardless of
- ;; the number of aliases we were expecting.
- (find-definition y n-aliases))
- ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
- ;; We found a definition that is aliased the right
- ;; number of times. We still recurse in case it is a
- ;; lexical.
- (values (find-definition y 1)
- op))
- (else
- ;; We can't account for our aliases.
- (values #f #f))))))
+ (if (var-set? (operand-var op))
+ (values #f #f)
+ (let ((y (or (operand-residual-value op)
+ (visit-operand op counter 'value 10 10)
+ (operand-source op))))
+ (cond
+ ((and (lexical-ref? y)
+ (= (lexical-refcount (lexical-ref-gensym x)) 1))
+ ;; X is a simple alias for Y. Recurse, regardless of
+ ;; the number of aliases we were expecting.
+ (find-definition y n-aliases))
+ ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
+ ;; We found a definition that is aliased the right
+ ;; number of times. We still recurse in case it is a
+ ;; lexical.
+ (values (find-definition y 1)
+ op))
+ (else
+ ;; We can't account for our aliases.
+ (values #f #f)))))))
(else
;; A formal parameter. Can't say anything about that.
(values #f #f))))
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index aa13b6a..114647e 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -113,16 +113,19 @@
(and pdi (program-debug-info-size pdi))))
(define (frame-matcher proc match-code?)
- (if match-code?
- (if (program? proc)
- (let ((start (program-code proc))
- (end (program-last-ip proc)))
- (lambda (frame)
- (let ((ip (frame-instruction-pointer frame)))
- (and (<= start ip) (< ip end)))))
- (lambda (frame) #f))
- (lambda (frame)
- (eq? (frame-procedure frame) proc))))
+ (let ((proc (if (struct? proc)
+ (procedure proc)
+ proc)))
+ (if match-code?
+ (if (program? proc)
+ (let ((start (program-code proc))
+ (end (program-last-ip proc)))
+ (lambda (frame)
+ (let ((ip (frame-instruction-pointer frame)))
+ (and (<= start ip) (< ip end)))))
+ (lambda (frame) #f))
+ (lambda (frame)
+ (eq? (frame-procedure frame) proc)))))
;; A basic trap, fires when a procedure is called.
;;
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 16f06bf..e91bc52 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -1808,6 +1808,34 @@
(pass-if (not (integer? (current-input-port)))))
;;;
+;;; integer?
+;;;
+
+(with-test-prefix "exact-integer?"
+ (pass-if (documented? exact-integer?))
+ (pass-if (exact-integer? 0))
+ (pass-if (exact-integer? 7))
+ (pass-if (exact-integer? -7))
+ (pass-if (exact-integer? (+ 1 fixnum-max)))
+ (pass-if (exact-integer? (- 1 fixnum-min)))
+ (pass-if (and (= 1.0 (round 1.0))
+ (not (exact-integer? 1.0))))
+ (pass-if (not (exact-integer? 1.3)))
+ (pass-if (not (exact-integer? +inf.0)))
+ (pass-if (not (exact-integer? -inf.0)))
+ (pass-if (not (exact-integer? +nan.0)))
+ (pass-if (not (exact-integer? +inf.0-inf.0i)))
+ (pass-if (not (exact-integer? +nan.0+nan.0i)))
+ (pass-if (not (exact-integer? 3+4i)))
+ (pass-if (not (exact-integer? #\a)))
+ (pass-if (not (exact-integer? "a")))
+ (pass-if (not (exact-integer? (make-vector 0))))
+ (pass-if (not (exact-integer? (cons 1 2))))
+ (pass-if (not (exact-integer? #t)))
+ (pass-if (not (exact-integer? (lambda () #t))))
+ (pass-if (not (exact-integer? (current-input-port)))))
+
+;;;
;;; inexact?
;;;
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index cb17652..4d8a280 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1286,4 +1286,18 @@
(list a b))
(bar 1))
1)
- (primcall list (const 1) (const 2))))
+ (primcall list (const 1) (const 2)))
+
+ (pass-if-peval
+ ;; Should not inline tail list to apply if it is mutable.
+ ;; <http://debbugs.gnu.org/15533>
+ (let ((l '()))
+ (if (pair? arg)
+ (set! l arg))
+ (apply f l))
+ (let (l) (_) ((const ()))
+ (seq
+ (if (primcall pair? (toplevel arg))
+ (set! (lexical l _) (toplevel arg))
+ (void))
+ (primcall apply (toplevel f) (lexical l _))))))
diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test
index de6df8e..a1bae7b 100644
--- a/test-suite/tests/srfi-13.test
+++ b/test-suite/tests/srfi-13.test
@@ -555,8 +555,7 @@
(string=? "o-bar" (string-copy "\u0100\u0101o-bar" 2)))
(pass-if "start and end index"
- (string=? "o-ba" (string-copy "foo-bar" 2 6)))
-)
+ (string=? "o-ba" (string-copy "foo-bar" 2 6))))
(with-test-prefix "substring/shared"
@@ -578,7 +577,17 @@
(let* ((s "hello")
(t (string-copy "world, oh yeah!")))
(string-copy! t 1 s 1 3)
- t))))
+ t)))
+
+ (pass-if-equal "overlapping src and dest, moving right"
+ "aabce"
+ (let ((str (string-copy "abcde")))
+ (string-copy! str 1 str 0 3) str))
+
+ (pass-if-equal "overlapping src and dest, moving left"
+ "bcdde"
+ (let ((str (string-copy "abcde")))
+ (string-copy! str 0 str 1 4) str)))
(with-test-prefix "string-take"
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index e55cba1..8b8c9d9 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -1237,3 +1237,60 @@
(unreachable))))))
(r 'outer))
#t)))
+
+(with-test-prefix "syntax-case"
+
+ (pass-if-syntax-error "duplicate pattern variable"
+ '(syntax-case . "duplicate pattern variable")
+ (eval '(lambda (e)
+ (syntax-case e ()
+ ((a b c d e d f) #f)))
+ (interaction-environment)))
+
+ (with-test-prefix "misplaced ellipses"
+
+ (pass-if-syntax-error "bare ellipsis"
+ '(syntax-case . "misplaced ellipsis")
+ (eval '(lambda (e)
+ (syntax-case e ()
+ (... #f)))
+ (interaction-environment)))
+
+ (pass-if-syntax-error "ellipsis singleton"
+ '(syntax-case . "misplaced ellipsis")
+ (eval '(lambda (e)
+ (syntax-case e ()
+ ((...) #f)))
+ (interaction-environment)))
+
+ (pass-if-syntax-error "ellipsis in car"
+ '(syntax-case . "misplaced ellipsis")
+ (eval '(lambda (e)
+ (syntax-case e ()
+ ((... . _) #f)))
+ (interaction-environment)))
+
+ (pass-if-syntax-error "ellipsis in cdr"
+ '(syntax-case . "misplaced ellipsis")
+ (eval '(lambda (e)
+ (syntax-case e ()
+ ((_ . ...) #f)))
+ (interaction-environment)))
+
+ (pass-if-syntax-error "two ellipses in the same list"
+ '(syntax-case . "misplaced ellipsis")
+ (eval '(lambda (e)
+ (syntax-case e ()
+ ((x ... y ...) #f)))
+ (interaction-environment)))
+
+ (pass-if-syntax-error "three ellipses in the same list"
+ '(syntax-case . "misplaced ellipsis")
+ (eval '(lambda (e)
+ (syntax-case e ()
+ ((x ... y ... z ...) #f)))
+ (interaction-environment)))))
+
+;;; Local Variables:
+;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1)
+;;; End:
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-562-g1df515a,
Mark H Weaver <=