Merge branch 'stable-2.0'

Conflicts:
	module/system/vm/traps.scm
	test-suite/tests/peval.test

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

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

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;

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"
+	    "Return @code{#t} if @var{x} is an integer number,\n"
-	    "else.")
+	    "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,
@@ -9623,6 +9636,12 @@ scm_is_integer (SCM val)
   return scm_is_true (scm_integer_p (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)
 {

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,

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

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

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

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, 
+          for (i = 0; i < len; i++)
-                              scm_i_string_ref (s, cstart + 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);

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,18 +199,43 @@ 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
+    GUILE_EFFECTIVE_VERSION=$_guile_effective_version
-  elif test "$GUILE_EFFECTIVE_VERSION" != "$_guile_prog_version"; then
+  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_prog_version])
+    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)
 

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

module/ice-9/psyntax-pp.scm

@@ -2106,14 +2106,17 @@
          (lambda (pattern keys)
            (letrec*
              ((cvt* (lambda (p* n ids)
-                      (if (not (pair? p*))
+                      (let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any))))
-                        (cvt p* n ids)
+                        (if tmp
-                        (call-with-values
+                          (apply (lambda (x y)
-                          (lambda () (cvt* (cdr p*) n ids))
+                                   (call-with-values
-                          (lambda (y ids)
+                                     (lambda () (cvt* y n ids))
-                            (call-with-values
+                                     (lambda (y ids)
-                              (lambda () (cvt (car p*) n ids))
+                                       (call-with-values
-                              (lambda (x ids) (values (cons x y) ids))))))))
+                                         (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)))
+               (cond ((not (and-map (lambda (x) (not (ellipsis? (car x)))) 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)))
                         (build-call

module/ice-9/psyntax.scm

@@ -2441,15 +2441,16 @@
                        (lambda (pattern keys)
                          (define cvt*
                            (lambda (p* n ids)
-                             (if (not (pair? p*)) 
+                             (syntax-case p* ()
-                                 (cvt p* n ids)
+                               ((x . y)
-                                 (call-with-values
+                                (call-with-values
-                                     (lambda () (cvt* (cdr p*) n ids))
+                                     (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

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)
+               (if (var-set? (operand-var op))
-                            (visit-operand op counter 'value 10 10)
+                   (values #f #f)
-                            (operand-source op))))
+                   (let ((y (or (operand-residual-value op)
-                 (cond
+                                (visit-operand op counter 'value 10 10)
-                  ((and (lexical-ref? y)
+                                (operand-source op))))
-                        (= (lexical-refcount (lexical-ref-gensym x)) 1))
+                     (cond
-                   ;; X is a simple alias for Y.  Recurse, regardless of
+                      ((and (lexical-ref? y)
-                   ;; the number of aliases we were expecting.
+                            (= (lexical-refcount (lexical-ref-gensym x)) 1))
-                   (find-definition y n-aliases))
+                       ;; X is a simple alias for Y.  Recurse, regardless of
-                  ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
+                       ;; the number of aliases we were expecting.
-                   ;; We found a definition that is aliased the right
+                       (find-definition y n-aliases))
-                   ;; number of times.  We still recurse in case it is a
+                      ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
-                   ;; lexical.
+                       ;; We found a definition that is aliased the right
-                   (values (find-definition y 1)
+                       ;; number of times.  We still recurse in case it is a
-                           op))
+                       ;; lexical.
-                  (else
+                       (values (find-definition y 1)
-                   ;; We can't account for our aliases.
+                               op))
-                   (values #f #f))))))
+                      (else
+                       ;; We can't account for our aliases.
+                       (values #f #f)))))))
          (else
           ;; A formal parameter.  Can't say anything about that.
           (values #f #f))))

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?
+  (let ((proc (if (struct? proc)
-      (if (program? proc)
+                  (procedure proc)
-          (let ((start (program-code proc))
+                  proc)))
-                (end (program-last-ip proc)))
+    (if match-code?
-            (lambda (frame)
+        (if (program? proc)
-              (let ((ip (frame-instruction-pointer frame)))
+            (let ((start (program-code proc))
-                (and (<= start ip) (< ip end)))))
+                  (end (program-last-ip proc)))
-          (lambda (frame) #f))
+              (lambda (frame)
-      (lambda (frame)
+                (let ((ip (frame-instruction-pointer frame)))
-        (eq? (frame-procedure frame) proc))))
+                  (and (<= start ip) (< ip end)))))
+            (lambda (frame) #f))
+        (lambda (frame)
+          (eq? (frame-procedure frame) proc)))))
 
 ;; A basic trap, fires when a procedure is called.
 ;;

test-suite/tests/numbers.test

@@ -1807,6 +1807,34 @@
   (pass-if (not (integer? (lambda () #t))))
   (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?
 ;;;

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

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"
 

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: