R6RS: fix problem with qausisyntax and conversion of an unwrapped syntax object as the argument expression to syntax-case

svn: r15387

collects/r6rs/private/reconstruct.ss

@@ -1,4 +1,32 @@
 #lang scheme/base
 
-(provide reconstruction-memory)
+(provide reconstruction-memory wrap)
+
 (define reconstruction-memory (make-weak-hasheq))
+
+(define (wrap r stx srcloc no-symbols?)
+  (let wrap ([r r])
+    (cond
+     [(syntax? r) r]
+     [(and (symbol? r)
+           no-symbols?)
+      (error 'macro
+             "transformer result included a raw symbol: ~e"
+             r)]
+     [(mpair? r) 
+      (let ([istx (or (hash-ref reconstruction-memory r #f)
+                      stx)])
+        (datum->syntax
+         istx
+         (cons (wrap (mcar r))
+               (wrap (mcdr r)))
+         (if (eq? istx stx)
+             srcloc
+             istx)))]
+     [(vector? r) (datum->syntax
+                   stx
+                   (list->vector
+                    (map (lambda (r) (wrap r))
+                         (vector->list r)))
+                   srcloc)]
+     [else (datum->syntax stx r srcloc)])))

collects/rnrs/base-6.ss

@@ -557,28 +557,6 @@
                   (syntax/loc stx
                     (define-syntax id (wrap-as-needed expr))))]))
 
-(define-for-syntax (wrap r stx)
-  (cond
-   [(syntax? r) r]
-   [(symbol? r) (error 'macro
-                       "transformer result included a raw symbol: ~e"
-                       r)]
-   [(mpair? r) 
-    (let ([istx (or (hash-ref reconstruction-memory r #f)
-                    stx)])
-      (datum->syntax
-       istx
-       (cons (wrap (mcar r) stx)
-             (wrap (mcdr r) stx))
-       istx))]
-   [(vector? r) (datum->syntax
-                 stx
-                 (list->vector
-                  (map (lambda (r) (wrap r stx))
-                       (vector->list r)))
-                 stx)]
-   [else (datum->syntax stx r stx)]))
-
 (define-for-syntax (wrap-as-needed v)
   (cond
    [(and (procedure? v)
@@ -587,7 +565,7 @@
      (case-lambda 
       [(stx) (if (syntax? stx)
                  (let ([r (v stx)])
-                   (wrap r stx))
+                   (wrap r stx stx #t))
                  (v stx))]
       [args (apply v args)])
      (procedure-arity v))]

collects/rnrs/syntax-case-6.ss

@@ -115,11 +115,7 @@
        [else (proc stx)]))))
 
 (define unwrapped-tag (gensym))
-
-(define (wrap expr)
-  (datum->syntax #f
-                 (convert-mpairs expr)
-                 (list unwrapped-tag #f #f #f #f)))
+(define unwrapped-srcloc (list unwrapped-tag #f #f #f #f))
 
 (define (convert-mpairs expr)
   (cond
@@ -169,7 +165,7 @@
                                          lit)))
                  lits)
        (quasisyntax/loc stx
-         (syntax-case (wrap expr) (lit ...)
+         (syntax-case (wrap expr (quote-syntax #,(datum->syntax #'expr 'ctx)) unwrapped-srcloc #f) (lit ...)
            . #,(map (lambda (clause)
                       (syntax-case clause ()
                         [(pat val)