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

R6RS syntax vector repair (PR 9625)

Browse Source 
svn: r10870
This commit is contained in:
Matthew Flatt 2008-07-23 12:25:41 +00:00
parent fe84c8c6a3
commit 8e1add79c9
2 changed files with 16 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/rnrs/syntax-case-6.ss
View File

@ -240,12 +240,10 @@
(if (or a b counting?)
(cons a b)
#f))]
[#(a ...) (let ([as (map (lambda (a)
(loop a in-ellipses? #f))
(syntax->list #'(a ...)))])
(if (ormap values as)
(list->vector as)
#f))]
[#(a ...) (let ([as (loop (syntax->list #'(a ...))
in-ellipses?
#f)])
(and as (vector as)))]
[a
(identifier? #'a)
(ormap (lambda (pat-var)
@ -278,7 +276,12 @@
(mcons (unwrap (car p) (car mapping))
(unwrap (cdr p) (cdr mapping))))]
[(vector? mapping)
(list->vector (mlist->list (unwrap (vector->list (syntax-e stx)) (vector->list mapping))))]
(list->vector (let loop ([v (unwrap (vector->list (syntax-e stx))
(vector-ref mapping 0))])
(cond
[(null? v) null]
[(mpair? v) (cons (mcar v) (loop (mcdr v)))]
[(syntax? v) (syntax->list v)])))]
[(null? mapping) null]
[(box? mapping)
;; ellipses

6
collects/tests/r6rs/syntax-case.sls
View File

@ -192,6 +192,12 @@
(test (syntax-case '#(1 2 3 4) ()
[#(1 x ... 2 3 4) #'(x ...)])
'())
(test (syntax-case #'() ()
[(x ...)
(let ([v #'#(x ...)])
(list (syntax->datum v) (vector? v)))])
'(#() #t))
(test (vector? #'#(1 2 3)) #f)
(test (syntax-case #'(1) ()
[(_) (syntax->datum #'_)])
'_)