suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/parse: fixed error-reporting bugs, added error-reporting tests

Browse Source 
svn: r15853
This commit is contained in:
Ryan Culpepper 2009-09-01 19:16:33 +00:00
parent 0a4bfe6d3c
commit 2acdfd6eb5
2 changed files with 207 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/syntax/private/stxparse/rep.ss
View File

@ -208,24 +208,23 @@
;; parse-variant : stx boolean DeclEnv -> RHS ;; parse-variant : stx boolean DeclEnv -> RHS
(define (parse-variant stx splicing? decls0) (define (parse-variant stx splicing? decls0)
(parameterize ((current-syntax-context stx)) (syntax-case stx (pattern)
(syntax-case stx (pattern) [(pattern p . rest)
[(pattern p . rest) (let-values ([(rest decls defs clauses)
(let-values ([(rest decls defs clauses) (parse-pattern-directives #'rest
(parse-pattern-directives #'rest #:allow-declare? #t
#:allow-declare? #t #:decls decls0)])
#:decls decls0)]) (unless (stx-null? rest)
(unless (stx-null? rest) (wrong-syntax (if (pair? rest) (car rest) rest)
(wrong-syntax (if (pair? rest) (car rest) rest) "unexpected terms after pattern directives"))
"unexpected terms after pattern directives")) (let* ([pattern
(let* ([pattern (parse-whole-pattern #'p decls splicing?)]
(parse-whole-pattern #'p decls splicing?)] [attrs
[attrs (append-iattrs
(append-iattrs (cons (pattern-attrs pattern)
(cons (pattern-attrs pattern) (side-clauses-attrss clauses)))]
(side-clauses-attrss clauses)))] [sattrs (iattrs->sattrs attrs)])
[sattrs (iattrs->sattrs attrs)]) (make variant stx sattrs pattern clauses defs)))]))
(make variant stx sattrs pattern clauses defs)))])))
(define (side-clauses-attrss clauses) (define (side-clauses-attrss clauses)
(for/list ([c clauses] (for/list ([c clauses]
@ -246,7 +245,7 @@
(define excess-domain (declenv-domain-difference decls pvars)) (define excess-domain (declenv-domain-difference decls pvars))
(when (pair? excess-domain) (when (pair? excess-domain)
(wrong-syntax #f "declared pattern variables do not appear in pattern" (wrong-syntax #f "declared pattern variables do not appear in pattern"
#:extras excess-domain)) #:extra excess-domain))
pattern)) pattern))
;; ---- ;; ----
@ -493,6 +492,8 @@
(begin (begin
(unless (stx-list? head) (unless (stx-list? head)
(wrong-syntax head "expected sequence of patterns")) (wrong-syntax head "expected sequence of patterns"))
(unless (stx-pair? (stx-cdr head))
(wrong-syntax head "expected at least one pattern"))
(for/list ([sub (cdr (stx->list head))]) (for/list ([sub (cdr (stx->list head))])
(parse-ellipsis-head-pattern sub decls)))] (parse-ellipsis-head-pattern sub decls)))]
[_ [_
@ -618,11 +619,11 @@
(unless (exact-nonnegative-integer? minN) (unless (exact-nonnegative-integer? minN)
(wrong-syntax #'min (wrong-syntax #'min
"expected exact nonnegative integer")) "expected exact nonnegative integer"))
(unless (or (exact-nonnegative-integer? maxN) (= +inf.0 maxN)) (unless (or (exact-nonnegative-integer? maxN) (equal? maxN +inf.0))
(wrong-syntax #'max (wrong-syntax #'max
"expected exact nonnegative integer or +inf.0")) "expected exact nonnegative integer or +inf.0"))
(when (> minN maxN) (when (> minN maxN)
(wrong-syntax stx "minumum larger than maximum repetition constraint")) (wrong-syntax stx "minimum larger than maximum repetition constraint"))
(let ([chunks (parse-keyword-options #'options (let ([chunks (parse-keyword-options #'options
(list (list '#:too-few check-expression) (list (list '#:too-few check-expression)
(list '#:too-many check-expression) (list '#:too-many check-expression)

190
collects/tests/stxclass/more-tests.ss
View File

@ -11,6 +11,14 @@
#`(error '#,(exn-message e)))]) #`(error '#,(exn-message e)))])
(local-expand #'expr 'expression null))])) (local-expand #'expr 'expression null))]))
(define-syntax-rule (tcerr name expr erx ...)
(test-case name
(check-exn (lambda (exn)
(define msg (exn-message exn))
(check regexp-match? erx msg) ...
#t)
(lambda () (convert-syntax-error expr)))))
;; Test #:auto-nested-attributes ;; Test #:auto-nested-attributes
(define-syntax-class two (define-syntax-class two
@ -40,13 +48,185 @@
#:declare x (static number? "identifier bound to number") #:declare x (static number? "identifier bound to number")
#`(quote #,(attribute x.value))])) #`(quote #,(attribute x.value))]))
(test-case "static: right error" (tcerr "static: right error"
(check-exn (lambda (exn) (m twelve)
(regexp-match? #rx"identifier bound to number" #rx"identifier bound to number")
(exn-message exn)))
(lambda () (convert-syntax-error (m twelve)))))
(test-case "static: works" (test-case "static: works"
(check-equal? (convert-syntax-error (m zero)) (check-equal? (convert-syntax-error (m zero))
0)) 0))
;; Error message tests
(tcerr "define-conventions non id"
(let () (define-conventions "foo") 0)
#rx"^define-conventions: "
#rx"expected identifier")
(tcerr "define-literal-set non id"
(let () (define-literal-set "foo" (+ -)) 0)
#rx"^define-literal-set: "
#rx"expected identifier")
(tcerr "parse-rhs: no variants"
(let () (define-syntax-class x) 0)
#rx"^define-syntax-class: "
#rx"expected at least one variant")
(tcerr "parse-rhs (splicing): no variants"
(let () (define-splicing-syntax-class x) 0)
#rx"^define-splicing-syntax-class: "
#rx"expected at least one variant")
(tcerr "parse-rhs: incompatible attrs flags"
(let ()
(define-syntax-class foo
#:attributes (x)
#:auto-nested-attributes
(pattern x))
0)
#rx"^define-syntax-class: "
#rx"not allowed after")
(tcerr "parse-variants: not a variant"
(let () (define-syntax-class x y) 0)
#rx"^define-syntax-class: "
#rx"expected syntax-class variant")
(tcerr "check-literals-bound: unbound literal"
(let () (define-syntax-class x #:literals (foo) (pattern (foo))) 0)
#rx"^define-syntax-class: "
#rx"unbound identifier not allowed as literal")
(tcerr "append-lits+litsets: duplicate"
(let ()
(define-literal-set lits1 (+))
(define-syntax-class x
#:literals (+)
#:literal-sets (lits1)
(pattern foo))
0)
#rx"^define-syntax-class: "
#rx"duplicate literal declaration")
(tcerr "parse-variant: too much"
(let ()
(define-syntax-class x
(pattern y z)))
#rx"^define-syntax-class: "
#rx"unexpected terms")
(tcerr "parse-whole-pattern: declared not used"
(syntax-parse #'1
[x
#:declare y nat
'ok])
#rx"^syntax-parse: "
#rx"do not appear in pattern")
(tcerr "parse-single-pattern: reserved"
(syntax-parse #'1
[~and 'ok])
#rx"^syntax-parse: "
#rx"not allowed here")
(tcerr "parse-pat:id: splicing not allowed"
(let ()
(define-splicing-syntax-class foo (pattern (~seq a b c)))
(syntax-parse #'1
[x:foo 'ok]))
#rx"^syntax-parse: "
#rx"splicing syntax class not allowed here")
(tcerr "parse-cdr-patterns: not list"
(syntax-parse #'1
[(~and x . y) 'ok])
#rx"^syntax-parse: "
#rx"expected sequence of patterns")
(tcerr "parse-cdr-patterns: empty"
(syntax-parse #'1
[(~and) 'ok])
#rx"^syntax-parse: "
#rx"expected at least one pattern")
(tcerr "parse-some-pattern: no heads"
(syntax-parse #'1
[(~and (~seq 1 2)) 'ok])
#rx"^syntax-parse: "
#rx"head pattern not allowed here")
(tcerr "parse-pat:dots: or, not list"
(syntax-parser
[((~or . x) ...) 'ok])
#rx"^syntax-parser: "
#rx"expected sequence of patterns")
(tcerr "parse-pat:dots: or, empty"
(syntax-parser
[((~or) ...) 'ok])
#rx"^syntax-parser: "
#rx"expected at least one pattern")
(tcerr "parse-pat:fail: missing message"
(syntax-parser
[(~fail) 'ok])
#rx"^syntax-parser: "
#rx"missing message expression")
(tcerr "parse-pat:fail: bad"
(syntax-parser
[(~fail . x) 'ok])
#rx"^syntax-parser: "
#rx"bad fail pattern")
(tcerr "check-list-pattern"
(syntax-parser
[((~seq x . y)) 'ok])
#rx"^syntax-parser: "
#rx"expected proper list pattern")
(tcerr "parse-ehpat/bounds: min"
(syntax-parser
[((~bounds x 1.0 9) ...) 'ok])
#rx"^syntax-parser: "
#rx"expected exact nonnegative integer")
(tcerr "parse-ehpat/bounds: max"
(syntax-parser
[((~bounds x 1 "foo") ...) 'ok])
#rx"^syntax-parser: "
#rx"expected exact nonnegative integer")
(tcerr "parse-ehpat/bounds: min>max"
(syntax-parser
[((~bounds x 3 2) ...) 'ok])
#rx"^syntax-parser: "
#rx"minimum larger than maximum")
(tcerr "parse-pattern-sides: bad declare"
(syntax-parser
[x #:fail-unless #t #f #:declare x nat 'ok])
#rx"^syntax-parser: "
#rx"#:declare can only follow")
(tcerr "grab-decls: bad sc"
(syntax-parser
[x #:declare x 5 'ok])
#rx"^syntax-parser: "
#rx"expected syntax class")
;; checker procedures... bleh
(tcerr "check-attr-arity-list"
(let () (define-syntax-class x #:attributes x (pattern x)) 'ok)
#rx"^define-syntax-class: "
#rx"expected list of attribute declarations")
(tcerr "check-attr-arity"
(let () (define-syntax-class x #:attributes ("foo" 0) (pattern x)) 'ok)
#rx"^define-syntax-class: "
#rx"expected attribute name")
;; two more