suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Actually, just have the descender return the #%module-begin expression,

Browse Source 
if it finds one, and otherwise do the wrapping appropriately.

svn: r17154
This commit is contained in:
Stevie Strickland 2009-12-01 21:58:58 +00:00
parent a24dd4affb
commit 4c61aabea0
1 changed files with 21 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/syntax/module-reader.ss
View File

@ -12,17 +12,25 @@
;; Takes either a syntax object representing a list of expressions ;; Takes either a syntax object representing a list of expressions
;; or a list of s-expressions, and checks to see if it's a single ;; or a list of s-expressions, and checks to see if it's a single
;; expression that begins with the literal #%module-begin. ;; expression that begins with the literal #%module-begin. If so,
(define (contains-#%module-begin exps) ;; it just returns that expression, else it wraps with #%module-begin.
(let ([exps (if (syntax? exps) (syntax->list exps) exps)]) (define (wrap-#%module-begin exps stx?)
(and exps (define wrapped-exps
(pair? exps) (let ([wrapped `(#%module-begin . ,exps)])
(null? (cdr exps)) (if stx?
(let ([exp (car exps)]) (datum->syntax #f wrapped)
(let ([lst (if (syntax? exp) (syntax->list exp) exp)]) wrapped)))
(and lst (let ([exps (if stx? (syntax->list exps) exps)])
(let ([head (if (syntax? (car lst)) (syntax-e (car lst)) (car lst))]) (cond
(eq? '#%module-begin head)))))))) [(null? exps) wrapped-exps]
[(not (null? (cdr exps))) wrapped-exps]
[else (let ([exp (if stx? (syntax-e (car exps)) (car exps))])
(cond
[(not (pair? exp)) wrapped-exps]
[(eq? '#%module-begin
(if stx? (syntax-e (car exp)) (car exp)))
(car exp)]
[else wrapped-exps]))])))
(define-syntax (provide-module-reader stx) (define-syntax (provide-module-reader stx)
(define (err str [sub #f]) (define (err str [sub #f])
@ -188,13 +196,8 @@
;; or wrapper1 functions, we need to avoid double-wrapping. Having to ;; or wrapper1 functions, we need to avoid double-wrapping. Having to
;; do this for #lang readers should be considered deprecated, and ;; do this for #lang readers should be considered deprecated, and
;; hopefully one day we'll move to just doing it unilaterally. ;; hopefully one day we'll move to just doing it unilaterally.
[wrapped-body (if (contains-#%module-begin body) [wrapped-body (wrap-#%module-begin body stx?)]
body [r `(,(tag-src 'module) ,(tag-src name) ,lang ,wrapped-body)])
(let ([wrapped `(#%module-begin . ,body)])
(if stx?
(list (datum->syntax #f wrapped all-loc))
(list wrapped))))]
[r `(,(tag-src 'module) ,(tag-src name) ,lang . ,wrapped-body)])
(if stx? (datum->syntax #f r all-loc) r))) (if stx? (datum->syntax #f r all-loc) r)))
(define (wrap lang port read modpath src line col pos) (define (wrap lang port read modpath src line col pos)