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

fix problems with template expansion when a pattern variable is used at different depths under a common ellipsis

Browse Source 
svn: r12327
This commit is contained in:
Matthew Flatt 2008-11-06 16:21:50 +00:00
parent 7872b59070
commit fadf10cf10
1 changed files with 46 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
collects/scheme/private/sc.ss
View File

@ -36,16 +36,19 @@
[else (loop (add1 p) (cdr l))]))) [else (loop (add1 p) (cdr l))])))
;; Like stx-memq-pos, but goes into nestings to ;; Like stx-memq-pos, but goes into nestings to
;; find identifiers. ;; find identifiers at the same nesting.
(-define (stx-memq*-pos ssym l) (-define (stx-memq*-pos ssym l)
(let loop ([p 0][l l]) (let loop ([p 0][l l])
(cond (cond
[(null? l) #f] [(null? l) #f]
[(bound-identifier=? ssym [(let loop ([i (car l)][ssym ssym])
(let loop ([i (car l)]) (if (syntax? i)
(if (syntax? i) (if (syntax? ssym)
i (bound-identifier=? i ssym)
(loop (car i))))) #f)
(if (pair? ssym)
(loop (car i) (car ssym))
#f)))
p] p]
[else (loop (add1 p) (cdr l))]))) [else (loop (add1 p) (cdr l))])))
@ -534,19 +537,19 @@
(ellipsis-sub-env nesting proto-r top local-top)) (ellipsis-sub-env nesting proto-r top local-top))
nestings))] nestings))]
[proto-rr-deep (and proto-r [proto-rr-deep (and proto-r
;; the ones that we had to unwrap:
(let loop ([l proto-rr+deep?s]) (let loop ([l proto-rr+deep?s])
(cond (cond
[(null? l) null] [(null? l) null]
[(cdar l) (loop (cdr l))] [(cdar l) (loop (cdr l))]
[else (cons (caar l) (loop (cdr l)))])))] [else (cons (caar l) (loop (cdr l)))])))]
[proto-rr-shallow (and proto-r [proto-rr-shallow (and proto-r
;; the ones that we leave alone for these ellipses:
(let loop ([l proto-rr+deep?s]) (let loop ([l proto-rr+deep?s])
(cond (cond
[(null? l) null] [(null? l) null]
[(cdar l) (cons (caar l) (loop (cdr l)))] [(cdar l) (cons (caar l) (loop (cdr l)))]
[else (loop (cdr l))])))] [else (loop (cdr l))])))]
[flat-nestings-deep (and proto-r (extract-vars proto-rr-deep))]
[flat-nestings-shallow (and proto-r (extract-vars proto-rr-shallow))]
[__ (unless (null? proto-rr-shallow) [__ (unless (null? proto-rr-shallow)
(when (null? proto-rr-deep) (when (null? proto-rr-deep)
(apply (apply
@ -562,19 +565,24 @@
`(lambda (r) `(lambda (r)
,(let ([pre (let ([deeps ,(let ([pre (let ([deeps
(let ([valses (let ([valses
;; Generate one binding per nested use. This will duplicate
;; bindings if a pattern variable is used multiple times; that's
;; good if the uses are in different nesting levels (which could be
;; ok if there are extra ellipses around them), but it might also
;; create redundant entries.
(map (lambda (var) (map (lambda (var)
(apply-list-ref 'r (stx-memq*-pos var proto-r) use-tail-pos)) (apply-list-ref 'r (stx-memq*-pos (list var) proto-r) use-tail-pos))
flat-nestings-deep)]) proto-rr-deep)])
(cond (cond
[(and (= 1 (length valses)) [(and (= 1 (length valses))
(= 0 el-count) (= 0 el-count)
(null? flat-nestings-shallow) (null? proto-rr-shallow)
(equal? ehead '(lambda (r) (car r)))) (equal? ehead '(lambda (r) (car r))))
;; Common case: one item in list, no map needed: ;; Common case: one item in list, no map needed:
(car valses)] (car valses)]
[(and (= 2 (length valses)) [(and (= 2 (length valses))
(= 0 el-count) (= 0 el-count)
(null? flat-nestings-shallow) (null? proto-rr-shallow)
(equal? ehead '(lambda (r) (list (car r) (cadr r))))) (equal? ehead '(lambda (r) (list (car r) (cadr r)))))
;; Another common case: a maintained pair ;; Another common case: a maintained pair
`(map `(map
@ -590,17 +598,17 @@
(wrap (wrap
`(map `(map
(lambda vals (,ehead (lambda vals (,ehead
,(if (null? flat-nestings-shallow) ,(if (null? proto-rr-shallow)
'vals 'vals
'(append shallows vals)))) '(append shallows vals))))
,@valses) ,@valses)
el-count))]))]) el-count))]))])
(if (null? flat-nestings-shallow) (if (null? proto-rr-shallow)
deeps deeps
`(let ([shallows `(let ([shallows
(list ,@(map (lambda (var) (list ,@(map (lambda (var)
(apply-list-ref 'r (stx-memq*-pos var proto-r) use-tail-pos)) (apply-list-ref 'r (stx-memq*-pos var proto-r) use-tail-pos))
flat-nestings-shallow))]) proto-rr-shallow))])
,deeps)))] ,deeps)))]
[post (apply-to-r rest)]) [post (apply-to-r rest)])
(if (eq? post 'null) (if (eq? post 'null)
@ -896,27 +904,29 @@
;; found, and signaling an error otherwise. If the prototype ;; found, and signaling an error otherwise. If the prototype
;; entry should be unwrapped by one, it is, and the resulting ;; entry should be unwrapped by one, it is, and the resulting
;; prototype is paired with #f. Otherwise, the prototype is left ;; prototype is paired with #f. Otherwise, the prototype is left
;; alone and paired with #t. ;; alone and paired with #t. There may be multiple matches; in that
;; case, prefer unwrapping to not unwrapping (because the other one
;; must be for a different sub-template nuder a shared ellipsis).
(-define ellipsis-sub-env (-define ellipsis-sub-env
(lambda (nesting proto-r src detail-src) (lambda (nesting proto-r src detail-src)
(let ([v (ormap (lambda (proto) (let ([vs (map (lambda (proto)
(let ([start (if (pair? proto) (let ([start (if (pair? proto)
(car proto) (car proto)
proto)]) proto)])
(let loop ([c start] [n nesting] [unwrap? (pair? proto)]) (let loop ([c start] [n nesting] [unwrap? (pair? proto)])
(cond (cond
[(and (pair? c) (pair? n)) [(and (pair? c) (pair? n))
(loop (car c) (car n) #t)] (loop (car c) (car n) #t)]
[(pair? n) [(pair? n)
(loop c (car n) #f)] (loop c (car n) #f)]
[(and (syntax? c) (syntax? n)) [(and (syntax? c) (syntax? n))
(if (bound-identifier=? c n) (if (bound-identifier=? c n)
(cons (if unwrap? start proto) (cons (if unwrap? start proto)
(not unwrap?)) (not unwrap?))
#f)] #f)]
[else #f])))) [else #f]))))
proto-r)]) proto-r)])
(unless v (unless (ormap values vs)
(apply (apply
raise-syntax-error raise-syntax-error
'syntax 'syntax
@ -927,7 +937,8 @@
(if (syntax? n) (if (syntax? n)
n n
(loop (car n))))))) (loop (car n)))))))
v))) (or (ormap (lambda (v) (and v (not (cdr v)) v)) vs)
(ormap values vs)))))
(-define (extract-vars proto-r) (-define (extract-vars proto-r)
(map (lambda (i) (map (lambda (i)