From 788adace201cd420c8f59797ca57deffa9f6a12c Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 15 Mar 2008 21:57:58 +0000
Subject: [PATCH] fix r6rs let[rec]-syntax for expression positions

svn: r8982
---
 collects/rnrs/base-6.ss            | 64 +++++++++++++++++-------------
 collects/tests/r6rs/syntax-case.ss | 11 +++++
 2 files changed, 47 insertions(+), 28 deletions(-)

diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss
index e202adf7f2..f73a2a9800 100644
--- a/collects/rnrs/base-6.ss
+++ b/collects/rnrs/base-6.ss
@@ -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))
diff --git a/collects/tests/r6rs/syntax-case.ss b/collects/tests/r6rs/syntax-case.ss
index 64bb4442c6..c38d21dfad 100644
--- a/collects/tests/r6rs/syntax-case.ss
+++ b/collects/tests/r6rs/syntax-case.ss
@@ -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")]))