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

fix r6rs let[rec]-syntax for expression positions

Browse Source 
svn: r8982
This commit is contained in:
Matthew Flatt 2008-03-15 21:57:58 +00:00
parent 7f3c8510de
commit 788adace20
2 changed files with 47 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
collects/rnrs/base-6.ss
View File

@ -478,34 +478,42 @@
(define-for-syntax (do-let-syntax stx rec?)
(syntax-case stx ()
[(_ ([id expr] ...) body ...)
(let ([sli (if (list? (syntax-local-context))
syntax-local-introduce
values)])
(let ([ids (map sli (syntax->list #'(id ...)))]
[def-ctx (syntax-local-make-definition-context)]
[ctx (list (gensym 'intdef))])
(syntax-local-bind-syntaxes ids #f def-ctx)
(let* ([add-context
(lambda (expr)
(let ([q (local-expand #`(quote #,expr)
ctx
(list #'quote)
def-ctx)])
(syntax-case q ()
[(_ expr) #'expr])))])
(with-syntax ([(id ...)
(map sli (map add-context ids))]
[(expr ...)
(let ([exprs (syntax->list #'(expr ...))])
(if rec?
(map add-context exprs)
exprs))]
[(body ...)
(map add-context (syntax->list #'(body ...)))])
#'(begin
(define-syntax id (wrap-as-needed expr))
...
body ...)))))]))
(if (eq? 'expression (syntax-local-context))
(with-syntax ([let-stx (if rec?
#'letrec-syntax
#'let-syntax)])
(syntax/loc stx
(let-stx ([id (wrap-as-needed expr)] ...)
(#%expression body)
...)))
(let ([sli (if (list? (syntax-local-context))
syntax-local-introduce
values)])
(let ([ids (map sli (syntax->list #'(id ...)))]
[def-ctx (syntax-local-make-definition-context)]
[ctx (list (gensym 'intdef))])
(syntax-local-bind-syntaxes ids #f def-ctx)
(let* ([add-context
(lambda (expr)
(let ([q (local-expand #`(quote #,expr)
ctx
(list #'quote)
def-ctx)])
(syntax-case q ()
[(_ expr) #'expr])))])
(with-syntax ([(id ...)
(map sli (map add-context ids))]
[(expr ...)
(let ([exprs (syntax->list #'(expr ...))])
(if rec?
(map add-context exprs)
exprs))]
[(body ...)
(map add-context (syntax->list #'(body ...)))])
#'(begin
(define-syntax id (wrap-as-needed expr))
...
body ...))))))]))
(define-syntax (r6rs:let-syntax stx)
(do-let-syntax stx #f))

11
collects/tests/r6rs/syntax-case.ss
View File

@ -88,6 +88,17 @@
(dolet a))
7)
;; check that it's ok as an expression:
(test 6
(let-syntax ([foo
(syntax-rules ()
[(_)
(let-syntax ([bar
(syntax-rules ()
[(_) 5])])
(bar))])])
(+ 1 (foo))))
#;
(test/exn (let ([else #f])
(case 0 [else (write "oops")]))