summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2014-01-09 01:32:32 -0500
committerMark H Weaver <mhw@netris.org>2014-01-09 02:52:34 -0500
commit1df515a077f26d59510e48fad3d45a33d2c90e0f (patch)
tree05991bb4b3d527390d036fbb17617d6905097bda
parent61989c705359c50c61d7f52392f244d386218298 (diff)
parent306cc01d3981feaa11aa0d866ff1d99128f0ace3 (diff)
downloadguile-1df515a077f26d59510e48fad3d45a33d2c90e0f.tar.gz
Merge branch 'stable-2.0'
Conflicts: module/system/vm/traps.scm test-suite/tests/peval.test
-rw-r--r--THANKS2
-rw-r--r--doc/ref/api-data.texi27
-rw-r--r--libguile/load.c15
-rw-r--r--libguile/numbers.c23
-rw-r--r--libguile/numbers.h2
-rw-r--r--libguile/private-options.h2
-rw-r--r--libguile/read.c3
-rw-r--r--libguile/socket.c2
-rw-r--r--libguile/srfi-13.c13
-rw-r--r--meta/guile.m445
-rw-r--r--module/ice-9/boot-9.scm3
-rw-r--r--module/ice-9/psyntax-pp.scm25
-rw-r--r--module/ice-9/psyntax.scm17
-rw-r--r--module/language/tree-il/peval.scm38
-rw-r--r--module/system/vm/traps.scm23
-rw-r--r--test-suite/tests/numbers.test28
-rw-r--r--test-suite/tests/peval.test16
-rw-r--r--test-suite/tests/srfi-13.test15
-rw-r--r--test-suite/tests/syntax.test57
19 files changed, 276 insertions, 80 deletions
diff --git a/THANKS b/THANKS
index 63f8feb42..90a4357d1 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 760318028..59d7db075 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,
-@c 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+@c 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
-@code{scm_is_signed_integer} and @code{scm_is_unsigned_integer} only
+@code{exact-integer?}, @code{scm_is_exact_integer},
+@code{scm_is_signed_integer}, 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
-@code{#f}.
+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)
-@result{} #t
+@result{} #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
+@deffn {Scheme Procedure} exact-integer? x
+@deffnx {C Function} scm_exact_integer_p (x)
+Return @code{#t} if @var{x} is an exact integer number, else
+return @code{#f}.
+
+@lisp
+(exact-integer? 37)
+@result{} #t
+
+(exact-integer? 3.0)
+@result{} #f
+@end lisp
+@end deffn
+
+@deftypefn {C Function} int scm_is_exact_integer (SCM x)
+This is equivalent to @code{scm_is_true (scm_exact_integer_p (x))}.
+@end 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 16e3fb2a6..5019201dc 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 2ed98d3f6..f4e8b2710 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 5cdfbacea..6e382ea35 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 ed0f314e5..4f580a640 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 382a1d379..61addf3a5 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 34bc21a73..8c1326a54 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 4e5d5725f..5c30dfe20 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 a3e1ef1de..29eccec03 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 83e5480d2..3748c1336 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 eeffecf38..0684890ed 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 5368785c2..cfcea4b26 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 8859dd4ad..8a60d7bd8 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 aa13b6ab8..114647e9e 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 16f06bf83..e91bc5240 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 cb17652cf..4d8a28050 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 de6df8e52..a1bae7b9f 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 e55cba11e..8b8c9d954 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: