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

Fix bug in conversion of dotted patterns.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2006-09-19 14:31:17 -04:00
parent 086db937b8
commit a6f8fbe350
1 changed files with 15 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/mzlib/private/match/convert-pat.ss
View File

@ -23,32 +23,20 @@
(with-syntax ([new-pats (syntax-map convert-pat stx)]) (with-syntax ([new-pats (syntax-map convert-pat stx)])
#'new-pats)) #'new-pats))
(define (imp-list? x stx) (define (imp-list? stx)
(define datum (syntax-e stx))
(define (keyword? x) (define (keyword? x)
(member (syntax-object->datum x) (memq (syntax-object->datum x)
'( '(quote quasiquote ? = and or not $ set! get!)))
quote
quasiquote
?
=
and
or
not
$
set!
get!
;unquote
;unquote-splicing
)))
(let/ec out (let/ec out
(let loop ((x x)) (let loop ([x datum])
(cond ((null? x) (out #f)) (cond [(null? x) (out #f)]
((or (not (pair? x)) [(or (not (pair? x))
(and (list? x) (and (list? x)
(keyword? (car x)))) (keyword? (car x))))
(list (list
(quasisyntax/loc stx #,x))) (quasisyntax/loc stx #,x))]
(else (cons (car x) (loop (cdr x)))))))) [else (cons (car x) (loop (cdr x)))]))))
(define (convert-quasi stx) (define (convert-quasi stx)
(syntax-case stx (unquote quasiquote unquote-splicing) (syntax-case stx (unquote quasiquote unquote-splicing)
@ -133,12 +121,11 @@
[(set! id) (with-syntax ([id (cert #'id)]) [(set! id) (with-syntax ([id (cert #'id)])
(syntax/loc stx (set! id)))] (syntax/loc stx (set! id)))]
[(quote p) stx] [(quote p) stx]
;; FIXME [(car-pat . cdr-pat)
[(elems ...) (quasisyntax/loc stx (list . #,(syntax-map convert-pat stx)))] (let ([l (imp-list? stx)])
[(e elems ... . rest) (if l (quasisyntax/loc stx (list-rest #,@(map convert-pat l)))
(quasisyntax/loc stx (list-rest #,@(syntax-map convert-pat #'(e elems ...)) (quasisyntax/loc stx (list #,@(syntax-map convert-pat stx)))))]
#,(convert-pat #'rest)))] [pt
[pt
(vector? (syntax-e stx)) (vector? (syntax-e stx))
(with-syntax ([new-pats (map convert-pat (vector->list (syntax-e stx)))]) (with-syntax ([new-pats (map convert-pat (vector->list (syntax-e stx)))])
(syntax/loc stx (vector . new-pats)))] (syntax/loc stx (vector . new-pats)))]