mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

syntax-case: fix error reporting for misplaced ellipses.

Browse source 
Reported by taylanbayirli@gmail.com (Taylan Ulrich B.).

* module/ice-9/psyntax.scm (cvt*): Use 'syntax-case' to destructure
  the pattern tail, instead of 'pair?', 'car', and 'cdr'.
  (gen-clause): When checking for errors, check for misplaced ellipsis
  before duplicate pattern variables, to improve the error message in
  case of multiple misplaced ellipses.

* module/ice-9/psyntax-pp.scm: Regenerate.

* test-suite/tests/syntax.test: Add tests.
This commit is contained in:
Mark H Weaver 2013-12-13 12:53:24 -05:00
parent d8c476b68d
commit aa8630efb3
3 changed files with 80 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

25
module/ice-9/psyntax-pp.scm
View file

@ -2072,14 +2072,17 @@
(lambda (pattern keys) (lambda (pattern keys)
(letrec* (letrec*
((cvt* (lambda (p* n ids) ((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 (v-reverse
(lambda (x) (lambda (x)
(let loop ((r '()) (x x)) (let loop ((r '()) (x x))
@ -2162,10 +2165,10 @@
(call-with-values (call-with-values
(lambda () (convert-pattern pat keys)) (lambda () (convert-pattern pat keys))
(lambda (p pvars) (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)) (syntax-violation 'syntax-case "misplaced ellipsis" pat))
((not (distinct-bound-ids? (map car pvars)))
(syntax-violation 'syntax-case "duplicate pattern variable" pat))
(else (else
(let ((y (gen-var 'tmp))) (let ((y (gen-var 'tmp)))
(build-application (build-application

17
module/ice-9/psyntax.scm
View file

@ -2341,15 +2341,16 @@
(lambda (pattern keys) (lambda (pattern keys)
(define cvt* (define cvt*
(lambda (p* n ids) (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) (lambda (y ids)
(call-with-values (call-with-values
(lambda () (cvt (car p*) n ids)) (lambda () (cvt #'x n ids))
(lambda (x ids) (lambda (x ids)
(values (cons x y) ids)))))))) (values (cons x y) ids))))))
(_ (cvt p* n ids)))))
(define (v-reverse x) (define (v-reverse x)
(let loop ((r '()) (x x)) (let loop ((r '()) (x x))
@ -2429,10 +2430,10 @@
(lambda () (convert-pattern pat keys)) (lambda () (convert-pattern pat keys))
(lambda (p pvars) (lambda (p pvars)
(cond (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)) ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
(syntax-violation 'syntax-case "misplaced ellipsis" pat)) (syntax-violation 'syntax-case "misplaced ellipsis" pat))
((not (distinct-bound-ids? (map car pvars)))
(syntax-violation 'syntax-case "duplicate pattern variable" pat))
(else (else
(let ((y (gen-var 'tmp))) (let ((y (gen-var 'tmp)))
;; fat finger binding and references to temp variable y ;; fat finger binding and references to temp variable y

57
test-suite/tests/syntax.test
View file

@ -1171,3 +1171,60 @@
(unreachable)))))) (unreachable))))))
(r 'outer)) (r 'outer))
#t))) #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: