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

improve ellipsis-count checking wrapper

Browse Source 
For a template expression that involevs ellipses, a wrapper is added
to catch failures an report as an "incompatible ellipsis match count"
error. The wrapper was only added when there are multiple pattern
variables with ellipses, but it turns out that it's possible to fail
with incompatible counts using a single pattern variable.

Besides handlign that case, the revised check avoids an unnecessary
wrapper in cases where multiple pattern variables have ellipses but
they are used independently in a template.

Closes #1511
This commit is contained in:
Matthew Flatt 2016-11-21 08:55:50 -07:00
parent cf2030b0b1
commit 02b0a30988
2 changed files with 80 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
pkgs/racket-test-core/tests/racket/macro.rktl
View File

@ -1697,6 +1697,15 @@
(ax))])
(test 'two values also-x)))
;; ----------------------------------------
;; Check that ellipsis-counts errors are reported when a single
;; pattern variable is used at different depths
(err/rt-test (syntax->datum
(with-syntax ([((b ...) ...) #'((1 2) (3) ())])
#'([(b (b ...)) ...] ...)))
(lambda (exn) (regexp-match? #rx"incompatible ellipsis" (exn-message exn))))
;; ----------------------------------------
(report-errs)

80
racket/collects/racket/private/sc.rkt
View File

@ -762,7 +762,7 @@
dest))])
`(datum->syntax/shape (quote-syntax ,small-dest)
,build))))])
(if (multiple-ellipsis-vars? proto-r)
(if (multiple-ellipsis-vars? p proto-r)
`(catch-ellipsis-error
(lambda () ,main)
(quote ,p)
@ -1067,18 +1067,76 @@
(loop (cdr nestings)))
(loop (cdr nestings))))))
(-define (multiple-ellipsis-vars? proto-r)
(let loop ([proto-r proto-r])
;; Determines whether any ellipsis has multiple pattern
;; variables so that a run-time check on the pattern-variable
;; matching length will be needed
(-define (multiple-ellipsis-vars? p proto-r)
(let loop ([p p])
(cond
[(null? proto-r) #f]
[(pair? (car proto-r))
(let loop ([proto-r (cdr proto-r)])
[(ellipsis? p)
(or (eq? 'multi (multiple-pattern-vars (stx-car p) proto-r))
(loop (stx-cdr (stx-cdr p))))]
[(stx-pair? p)
(let ([hd (stx-car p)])
(if (and (identifier? hd)
(...? hd))
#f
(or (loop hd)
(loop (stx-cdr p)))))]
[(stx-vector? p #f)
(loop (vector->list (syntax-e p)))]
[(stx-box? p)
(loop (unbox (syntax-e p)))]
[(and (syntax? p)
(prefab-struct-key (syntax-e p)))
(loop (cdr (vector->list (struct->vector (syntax-e p)))))]
[else #f])))
;; Determines whether a given expression, which is under ellipses,
;; has multiple pattern variables or the same variable at different
;; depths; returns 'multi if so, some other internal accumulator otherwise
(-define (multiple-pattern-vars p proto-r)
(let loop ([p p] [use-ellipsis? #t] [depth 0] [found #f])
(cond
[(null? proto-r) #f]
[(pair? (car proto-r))
#t]
[else (loop (cdr proto-r))]))]
[else (loop (cdr proto-r))])))
[(identifier? p)
(if (ormap (lambda (l)
(and
(pair? l) ;; only need to track repeats
(let loop ([l l])
(cond
[(syntax? l)
(bound-identifier=? l p)]
[else (loop (car l))]))))
proto-r)
(cond
[(not found) (cons p depth)]
[(and (bound-identifier=? p (car found))
(= depth (cdr found)))
found]
[else 'multi])
found)]
[(and use-ellipsis? (ellipsis? p))
(let ([new-found (loop (stx-car p) #t (add1 depth) found)])
(if (eq? new-found 'multi)
new-found
(loop (stx-cdr (stx-cdr p)) #t depth new-found)))]
[(stx-pair? p)
(let ([hd (stx-car p)])
(if (and (identifier? hd)
(...? hd))
(loop (stx-cdr p) #f depth found)
(let ([new-found (loop (stx-car p) #t depth found)])
(if (eq? new-found 'multi)
new-found
(loop (stx-cdr p) #t depth new-found)))))]
[(stx-vector? p #f)
(loop (vector->list (syntax-e p)) use-ellipsis? depth found)]
[(stx-box? p)
(loop (unbox (syntax-e p)) use-ellipsis? depth found)]
[(and (syntax? p)
(prefab-struct-key (syntax-e p)))
(loop (cdr (vector->list (struct->vector (syntax-e p)))) use-ellipsis? depth found)]
[else #f])))
(-define (no-ellipses? stx)
(cond