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

another with-syntax/quasisyntax fix for non-syntax inputs

Browse Source 
svn: r15420
This commit is contained in:
Matthew Flatt 2009-07-09 15:59:10 +00:00
parent 5adb4eb004
commit f9aeba626c
1 changed files with 7 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -165,7 +165,7 @@
lit))) lit)))
lits) lits)
(quasisyntax/loc stx (quasisyntax/loc stx
(syntax-case (wrap expr (quote-syntax #,(datum->syntax #'expr 'ctx)) unwrapped-srcloc #f) (lit ...) (syntax-case (add-wrap expr) (lit ...)
. #,(map (lambda (clause) . #,(map (lambda (clause)
(syntax-case clause () (syntax-case clause ()
[(pat val) [(pat val)
@ -180,6 +180,11 @@
(syntax->list #'(clause ...))))))] (syntax->list #'(clause ...))))))]
[(_ . rest) (syntax/loc stx (syntax-case . rest))])) [(_ . rest) (syntax/loc stx (syntax-case . rest))]))
(define-syntax (add-wrap stx)
(syntax-case stx ()
[(_ expr)
#`(wrap expr (quote-syntax #,(datum->syntax #'expr 'ctx)) unwrapped-srcloc #f)]))
;; ---------------------------------------- ;; ----------------------------------------
(define (unwrap-reconstructed data stx datum) (define (unwrap-reconstructed data stx datum)
@ -238,7 +243,7 @@
(define-syntax r6rs:with-syntax (define-syntax r6rs:with-syntax
(syntax-rules () (syntax-rules ()
[(_ [(p e0) ...] e1 e2 ...) [(_ [(p e0) ...] e1 e2 ...)
(r6rs:syntax-case (mlist e0 ...) () (r6rs:syntax-case (mlist (add-wrap e0) ...) ()
[(p ...) (let () e1 e2 ...)])])) [(p ...) (let () e1 e2 ...)])]))
(define-syntax (r6rs:quasisyntax stx) (define-syntax (r6rs:quasisyntax stx)