Subject: bug#13509: wrong "definition in expression context" in R6RS mode

From: Mark H Weaver <[email-masked]>
Date: Wed, 23 Jan 2013 18:48:46 -0500

Marco Maggi <[email-masked]> writes:
>     #!r6rs
>     (import (rnrs))
>     (define (alpha)
>       (define-syntax define-special
>         (syntax-rules ()
>           ((_ ?who ?val)
>            (define ?who ?val))))
>       (define-special beta #t)
>       #f)
>     (alpha)
>
> should succeed, but instead it fails with:
[...]
>     /home/marco/var/tmp/proof.sps:12:2: definition in expression context, where definitions are not allowed, in form (define beta #t)

I've attached two patches for stable-2.0.  The second patch fixes this
bug.  The first patch is for an unrelated bug that I discovered during
my investigation.

Reviews solicited, otherwise I'll commit these in a week or so.

     Mark

>From 2b8587d090d13f044f3cc4d221e832a655dcc1cd Mon Sep 17 00:00:00 2001
From: Mark H Weaver <[email-masked]>
Date: Wed, 23 Jan 2013 17:27:50 -0500
Subject: [PATCH 1/2] Fix source annotation bug in psyntax 'expand-body'.

* module/ice-9/psyntax.scm (expand-body): Apply source-annotation to an
  expression, not to the expression's compile-time environment.

* module/ice-9/psyntax-pp.scm: Regenerate.
---
 module/ice-9/psyntax-pp.scm |    2 +-
 module/ice-9/psyntax.scm    |    2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 5dfa8c0..139c02b 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -976,7 +976,7 @@
              (let ((e (cdar body)) (er (caar body)))
                (call-with-values
                  (lambda ()
-                   (syntax-type e er '(()) (source-annotation er) ribcage mod #f))
+                   (syntax-type e er '(()) (source-annotation e) ribcage mod #f))
                  (lambda (type value form e w s mod)
                    (let ((key type))
                      (cond ((memv key '(define-form))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index d41a0eb..4abd3c9 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1457,7 +1457,7 @@
                 (syntax-violation #f "no expressions in body" outer-form)
                 (let ((e (cdar body)) (er (caar body)))
                   (call-with-values
-                      (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f))
+                      (lambda () (syntax-type e er empty-wrap (source-annotation e) ribcage mod #f))
                     (lambda (type value form e w s mod)
                       (case type
                         ((define-form)
-- 
1.7.10.4

>From 20e2db39b23dfd27c92cfbdd831e91eb3e2880a5 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <[email-masked]>
Date: Wed, 23 Jan 2013 17:49:38 -0500
Subject: [PATCH 2/2] Do not defer expansion of internal define-syntax forms.

* module/ice-9/psyntax.scm (expand-body): As required by R6RS, expand
  the right-hand-sides of internal 'define-syntax' forms and add their
  transformers to the compile-time environment immediately, so that the
  newly-defined keywords may be used in definition context within the
  same lexical contour.  Fixes #13509.
---
 module/ice-9/psyntax-pp.scm |   29 ++++++++++-------------------
 module/ice-9/psyntax.scm    |   36 +++++++++++++++---------------------
 2 files changed, 25 insertions(+), 40 deletions(-)

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 139c02b..a0d338c 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -991,15 +991,17 @@
                                        (cons (cons er (wrap e w mod)) vals)
                                        (cons (cons 'lexical var) bindings)))))
                            ((memv key '(define-syntax-form define-syntax-parameter-form))
-                            (let ((id (wrap value w mod)) (label (gen-label)))
+                            (let ((id (wrap value w mod))
+                                  (label (gen-label))
+                                  (trans-r (macros-only-env er)))
                               (extend-ribcage! ribcage id label)
-                              (parse (cdr body)
-                                     (cons id ids)
-                                     (cons label labels)
-                                     var-ids
-                                     vars
-                                     vals
-                                     (cons (cons 'macro (cons er (wrap e w mod))) bindings))))
+                              (set-cdr!
+                                r
+                                (extend-env
+                                  (list label)
+                                  (list (cons 'macro (eval-local-transformer (expand e trans-r w mod) mod)))
+                                  (cdr r)))
+                              (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
                            ((memv key '(begin-form))
                             (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
                               (if tmp
@@ -1049,17 +1051,6 @@
                                 #f
                                 "invalid or duplicate identifier in definition"
                                 outer-form))
-                            (let loop ((bs bindings) (er-cache #f) (r-cache #f))
-                              (if (not (null? bs))
-                                (let ((b (car bs)))
-                                  (if (eq? (car b) 'macro)
-                                    (let* ((er (cadr b))
-                                           (r-cache (if (eq? er er-cache) r-cache (macros-only-env er))))
-                                      (set-cdr!
-                                        b
-                                        (eval-local-transformer (expand (cddr b) r-cache '(()) mod) mod))
-                                      (loop (cdr bs) er r-cache))
-                                    (loop (cdr bs) er-cache r-cache)))))
                             (set-cdr! r (extend-env labels bindings (cdr r)))
                             (build-letrec
                               #f
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 4abd3c9..980db80 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1470,13 +1470,22 @@
                                     (cons var vars) (cons (cons er (wrap e w mod)) vals)
                                     (cons (make-binding 'lexical var) bindings)))))
                         ((define-syntax-form define-syntax-parameter-form)
-                         (let ((id (wrap value w mod)) (label (gen-label)))
+                         (let ((id (wrap value w mod))
+                               (label (gen-label))
+                               (trans-r (macros-only-env er)))
                            (extend-ribcage! ribcage id label)
-                           (parse (cdr body)
-                                  (cons id ids) (cons label labels)
-                                  var-ids vars vals
-                                  (cons (make-binding 'macro (cons er (wrap e w mod)))
-                                        bindings))))
+                           ;; As required by R6RS, expand the right-hand-sides of internal
+                           ;; syntax definition forms and add their transformers to the
+                           ;; compile-time environment immediately, so that the newly-defined
+                           ;; keywords may be used in definition context within the same
+                           ;; lexical contour.
+                           (set-cdr! r (extend-env (list label)
+                                                   (list (make-binding 'macro
+                                                                       (eval-local-transformer
+                                                                        (expand e trans-r w mod)
+                                                                        mod)))
+                                                   (cdr r)))
+                           (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
                         ((begin-form)
                          (syntax-case e ()
                            ((_ e1 ...)
@@ -1507,21 +1516,6 @@
                                    (syntax-violation
                                     #f "invalid or duplicate identifier in definition"
                                     outer-form))
-                               (let loop ((bs bindings) (er-cache #f) (r-cache #f))
-                                 (if (not (null? bs))
-                                     (let* ((b (car bs)))
-                                       (if (eq? (car b) 'macro)
-                                           (let* ((er (cadr b))
-                                                  (r-cache
-                                                   (if (eq? er er-cache)
-                                                       r-cache
-                                                       (macros-only-env er))))
-                                             (set-cdr! b
-                                                       (eval-local-transformer
-                                                        (expand (cddr b) r-cache empty-wrap mod)
-                                                        mod))
-                                             (loop (cdr bs) er r-cache))
-                                           (loop (cdr bs) er-cache r-cache)))))
                                (set-cdr! r (extend-env labels bindings (cdr r)))
                                (build-letrec no-source #t
                                              (reverse (map syntax->datum var-ids))
-- 
1.7.10.4