diff --git a/collects/r6rs/private/reconstruct.ss b/collects/r6rs/private/reconstruct.ss index 95d3c9175f..81556242e4 100644 --- a/collects/r6rs/private/reconstruct.ss +++ b/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)]))) diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss index 998af489ba..ceef4e0b19 100644 --- a/collects/rnrs/base-6.ss +++ b/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))] diff --git a/collects/rnrs/syntax-case-6.ss b/collects/rnrs/syntax-case-6.ss index 03eb0af3c6..ce5f439c43 100644 --- a/collects/rnrs/syntax-case-6.ss +++ b/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)