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, @@ -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) { 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,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 - 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 @@ -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? ;;; 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. + ;; + (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: