fix r6rs syntax-case yet again (PR 9647)
svn: r11024
This commit is contained in:
parent
95965f54cb
commit
f4df83106e
|
@ -253,6 +253,47 @@
|
||||||
pattern-vars)]
|
pattern-vars)]
|
||||||
[_ #f])))
|
[_ #f])))
|
||||||
|
|
||||||
|
(define-for-syntax (group-ellipses tmpl umap)
|
||||||
|
(define (stx-cdr s) (if (syntax? s) (cdr (syntax-e s)) (cdr s)))
|
||||||
|
(let loop ([tmpl tmpl][umap umap])
|
||||||
|
(if (not umap)
|
||||||
|
tmpl
|
||||||
|
(syntax-case tmpl ()
|
||||||
|
[(ellipses expr)
|
||||||
|
(and (identifier? #'ellipses)
|
||||||
|
(free-identifier=? #'ellipses #'(... ...)))
|
||||||
|
tmpl]
|
||||||
|
[(expr ellipses . rest)
|
||||||
|
(and (identifier? #'ellipses)
|
||||||
|
(free-identifier=? #'ellipses #'(... ...)))
|
||||||
|
(let rloop ([rest (stx-cdr (stx-cdr tmpl))]
|
||||||
|
[accum (list #'ellipses (loop #'expr
|
||||||
|
(car (unbox umap))))])
|
||||||
|
(syntax-case rest ()
|
||||||
|
[(ellipses . _)
|
||||||
|
(and (identifier? #'ellipses)
|
||||||
|
(free-identifier=? #'ellipses #'(... ...)))
|
||||||
|
;; keep going:
|
||||||
|
(rloop (stx-cdr rest) (cons #'ellipses accum))]
|
||||||
|
[_ (cons (datum->syntax #f (reverse accum))
|
||||||
|
(loop rest (cdr (unbox umap))))]))]
|
||||||
|
[(a . b) (let ([n (cons (loop #'a (car umap))
|
||||||
|
(loop (cdr (if (syntax? tmpl)
|
||||||
|
(syntax-e tmpl)
|
||||||
|
tmpl))
|
||||||
|
(cdr umap)))])
|
||||||
|
(if (syntax? tmpl)
|
||||||
|
(datum->syntax tmpl n tmpl tmpl tmpl)
|
||||||
|
n))]
|
||||||
|
[#(a ...) (datum->syntax
|
||||||
|
tmpl
|
||||||
|
(list->vector (loop (syntax->list #'(a ...))
|
||||||
|
(vector-ref umap 0)))
|
||||||
|
tmpl
|
||||||
|
tmpl
|
||||||
|
tmpl)]
|
||||||
|
[_ tmpl]))))
|
||||||
|
|
||||||
(define (unwrap stx mapping)
|
(define (unwrap stx mapping)
|
||||||
(cond
|
(cond
|
||||||
[(not mapping)
|
[(not mapping)
|
||||||
|
@ -289,32 +330,13 @@
|
||||||
;; ellipses
|
;; ellipses
|
||||||
(let* ([mapping (unbox mapping)]
|
(let* ([mapping (unbox mapping)]
|
||||||
[rest-mapping (cdr mapping)]
|
[rest-mapping (cdr mapping)]
|
||||||
[rest-size
|
[p (if (syntax? stx) (syntax-e stx) stx)]
|
||||||
;; count number of cons cells we need at the end:
|
[repeat-stx (car p)]
|
||||||
(let loop ([m rest-mapping])
|
[rest-stx (cdr p)])
|
||||||
(if (pair? m)
|
|
||||||
(add1 (loop (cdr m)))
|
|
||||||
0))]
|
|
||||||
[repeat-stx (reverse
|
|
||||||
(list-tail (let loop ([stx stx][accum null])
|
|
||||||
(let ([p (if (syntax? stx)
|
|
||||||
(syntax-e stx)
|
|
||||||
stx)])
|
|
||||||
(if (pair? p)
|
|
||||||
(loop (cdr p) (cons (car p) accum))
|
|
||||||
accum)))
|
|
||||||
rest-size))]
|
|
||||||
[rest-stx (let loop ([stx stx][size (length repeat-stx)])
|
|
||||||
(if (zero? size)
|
|
||||||
stx
|
|
||||||
(let ([p (if (syntax? stx)
|
|
||||||
(syntax-e stx)
|
|
||||||
stx)])
|
|
||||||
(loop (cdr p) (sub1 size)))))])
|
|
||||||
(let ([repeats (list->mlist
|
(let ([repeats (list->mlist
|
||||||
(map (lambda (rep)
|
(map (lambda (rep)
|
||||||
(unwrap rep (car mapping)))
|
(unwrap rep (car mapping)))
|
||||||
repeat-stx))]
|
(syntax->list repeat-stx)))]
|
||||||
[rest-mapping
|
[rest-mapping
|
||||||
;; collapse #fs to single #f:
|
;; collapse #fs to single #f:
|
||||||
(if (let loop ([rest-mapping rest-mapping])
|
(if (let loop ([rest-mapping rest-mapping])
|
||||||
|
@ -338,10 +360,19 @@
|
||||||
(define-syntax (r6rs:syntax stx)
|
(define-syntax (r6rs:syntax stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ tmpl)
|
[(_ tmpl)
|
||||||
|
(let ([umap (make-unwrap-map #'tmpl
|
||||||
|
(syntax-parameter-value #'pattern-vars))])
|
||||||
(quasisyntax/loc stx
|
(quasisyntax/loc stx
|
||||||
(unwrap #,(syntax/loc stx (syntax tmpl))
|
(unwrap (if #f
|
||||||
'#,(make-unwrap-map #'tmpl
|
;; Process tmpl first, so that syntax errors are reported
|
||||||
(syntax-parameter-value #'pattern-vars))))]
|
;; usinf the original source.
|
||||||
|
#,(syntax/loc stx (syntax tmpl))
|
||||||
|
;; Convert tmpl to group ...-created repetitions together,
|
||||||
|
;; so that `unwrap' can tell which result came from which
|
||||||
|
;; template:
|
||||||
|
#,(with-syntax ([tmpl (group-ellipses #'tmpl umap)])
|
||||||
|
(syntax/loc stx (syntax tmpl))))
|
||||||
|
'#,umap)))]
|
||||||
[(_ . rest) (syntax/loc stx (syntax . rest))]))
|
[(_ . rest) (syntax/loc stx (syntax . rest))]))
|
||||||
|
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
|
|
|
@ -287,6 +287,14 @@
|
||||||
#`(1 #`(#,(+ 3 4) #,#,(+ 1 1))))
|
#`(1 #`(#,(+ 3 4) #,#,(+ 1 1))))
|
||||||
'(1 #`(#,(+ 3 4) #,2)))
|
'(1 #`(#,(+ 3 4) #,2)))
|
||||||
|
|
||||||
|
(test (unwrap
|
||||||
|
(syntax-case #'(weird-letrec ([x 1][y 7]) x) ()
|
||||||
|
[(_ ([v e] ...) . b)
|
||||||
|
#'(let ()
|
||||||
|
(define v) ...
|
||||||
|
. b)]))
|
||||||
|
'(let () (define x) (define y) x))
|
||||||
|
|
||||||
(test/exn (syntax-violation #f "bad" 7) &syntax)
|
(test/exn (syntax-violation #f "bad" 7) &syntax)
|
||||||
(test/exn (syntax-violation 'form "bad" 7) &syntax)
|
(test/exn (syntax-violation 'form "bad" 7) &syntax)
|
||||||
(test/exn (syntax-violation #f "bad" #'7) &syntax)
|
(test/exn (syntax-violation #f "bad" #'7) &syntax)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user