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

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

@ -88,6 +88,17 @@
(dolet a)) (dolet a))
7) 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]) (test/exn (let ([else #f])
(case 0 [else (write "oops")])) (case 0 [else (write "oops")]))