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

improve ellipsis-related error messages

Browse Source 
closes PR 14435
This commit is contained in:
Robby Findler 2014-04-12 08:04:42 -05:00
parent f5928dda7d
commit adac0b9138
1 changed files with 32 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
pkgs/redex-pkgs/redex-lib/redex/private/term.rkt
View File

@ -122,11 +122,11 @@
(make-free-identifier-mapping)) (make-free-identifier-mapping))
(define (rewrite stx) (define (rewrite stx)
(let-values ([(rewritten _) (rewrite/max-depth stx 0)]) (let-values ([(rewritten _) (rewrite/max-depth stx 0 #f)])
rewritten)) rewritten))
(define (rewrite-application fn args depth) (define (rewrite-application fn args depth)
(let-values ([(rewritten max-depth) (rewrite/max-depth args depth)]) (let-values ([(rewritten max-depth) (rewrite/max-depth args depth #t)])
(let ([result-id (car (generate-temporaries '(f-results)))]) (let ([result-id (car (generate-temporaries '(f-results)))])
(with-syntax ([fn fn]) (with-syntax ([fn fn])
(let loop ([func (if (judgment-form-id? #'fn) (let loop ([func (if (judgment-form-id? #'fn)
@ -149,7 +149,7 @@
(syntax (res (... ...))) (syntax (res (... ...)))
(sub1 args-depth))))))))) (sub1 args-depth)))))))))
(define (rewrite/max-depth stx depth) (define (rewrite/max-depth stx depth ellipsis-allowed?)
(syntax-case stx (unquote unquote-splicing in-hole hole) (syntax-case stx (unquote unquote-splicing in-hole hole)
[(metafunc-name arg ...) [(metafunc-name arg ...)
(and (identifier? (syntax metafunc-name)) (and (identifier? (syntax metafunc-name))
@ -193,7 +193,7 @@
(define prefix-sym (if m (define prefix-sym (if m
(string->symbol (list-ref m 1)) (string->symbol (list-ref m 1))
raw-sym)) raw-sym))
(check-id (syntax->datum (term-id-id id)) stx) (check-id (syntax->datum (term-id-id id)) stx ellipsis-allowed?)
(define new-id (define new-id
(build-disappeared-use (current-id-stx-table) (build-disappeared-use (current-id-stx-table)
@ -208,7 +208,7 @@
(defined-term-value (syntax-local-value #'x)) (defined-term-value (syntax-local-value #'x))
'disappeared-use 'disappeared-use
(syntax-local-introduce #'x))]) (syntax-local-introduce #'x))])
(check-id (syntax->datum #'x) stx) (check-id (syntax->datum #'x) stx ellipsis-allowed?)
(with-syntax ([v #`(begin (with-syntax ([v #`(begin
#,(defined-check ref "term" #:external #'x) #,(defined-check ref "term" #:external #'x)
#,ref)]) #,ref)])
@ -228,7 +228,7 @@
[hole (values (syntax (undatum the-hole)) 0)] [hole (values (syntax (undatum the-hole)) 0)]
[x [x
(and (identifier? (syntax x)) (and (identifier? (syntax x))
(check-id (syntax->datum #'x) stx)) (check-id (syntax->datum #'x) stx ellipsis-allowed?))
(values stx 0)] (values stx 0)]
[() (values stx 0)] [() (values stx 0)]
[(x ... . y) [(x ... . y)
@ -236,7 +236,7 @@
(let-values ([(x-rewrite max-depth) (let-values ([(x-rewrite max-depth)
(let i-loop ([xs (syntax->list (syntax (x ...)))]) (let i-loop ([xs (syntax->list (syntax (x ...)))])
(cond (cond
[(null? xs) (rewrite/max-depth #'y depth)] [(null? xs) (rewrite/max-depth #'y depth #t)]
[else [else
(let ([new-depth (if (and (not (null? (cdr xs))) (let ([new-depth (if (and (not (null? (cdr xs)))
(identifier? (cadr xs)) (identifier? (cadr xs))
@ -245,7 +245,7 @@
(+ depth 1) (+ depth 1)
depth)]) depth)])
(let-values ([(fst fst-max-depth) (let-values ([(fst fst-max-depth)
(rewrite/max-depth (car xs) new-depth)] (rewrite/max-depth (car xs) new-depth #t)]
[(rst rst-max-depth) [(rst rst-max-depth)
(i-loop (cdr xs))]) (i-loop (cdr xs))])
(values (cons fst rst) (values (cons fst rst)
@ -254,15 +254,30 @@
[_ (values stx 0)])) [_ (values stx 0)]))
(define (check-id id stx) (define (check-id id stx ellipsis-allowed?)
(when lang-nts (define m (regexp-match #rx"^([^_]*)_" (symbol->string id)))
(define m (regexp-match #rx"^([^_]*)_" (symbol->string id))) (cond
(when m [m
(unless (memq (string->symbol (list-ref m 1)) (append pattern-symbols lang-nts)) (define before-underscore (string->symbol (list-ref m 1)))
(raise-syntax-error 'term (when (equal? before-underscore '...)
"before underscore must be either a non-terminal or a built-in pattern" (raise-syntax-error
arg-stx stx))))) 'term
"ellipsis cannot have an underscore"
arg-stx stx))
(when lang-nts
(unless (memq before-underscore (append pattern-symbols lang-nts))
(raise-syntax-error
'term
"before underscore must be either a non-terminal or a built-in pattern"
arg-stx stx)))]
[else
(unless ellipsis-allowed?
(when (equal? id '...)
(raise-syntax-error
'term
"misplaced ellipsis"
arg-stx stx)))]))
(values (values
(with-syntax ([rewritten (rewrite arg-stx)]) (with-syntax ([rewritten (rewrite arg-stx)])
(with-syntax ([(outer-bs ...) (reverse outer-bindings)]) (with-syntax ([(outer-bs ...) (reverse outer-bindings)])