diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 7b801ad24..f5f764b0f 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -2072,14 +2072,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)) @@ -2162,10 +2165,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-application diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 5f1bd8ae4..fa009d2d5 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -2341,15 +2341,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)) @@ -2429,10 +2430,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/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index cdaee716b..6fac0ba34 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -1171,3 +1171,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: