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

A little simpler and a little more robust (eg, using source location for

Browse Source 
the wrapped body, and accepting any syntax/sexpr combination).

svn: r17197
This commit is contained in:
Eli Barzilay 2009-12-05 05:53:15 +00:00
parent af998f0d56
commit 6ab2e7edad
1 changed files with 22 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -142,27 +142,28 @@
(construct-reader #''lang (syntax->list #'(body ...)))]
[(_ body ...) (construct-reader #f (syntax->list #'(body ...)))]))
;; Since there are users that wrap with `#%module-begin' in their reader
;; or wrapper1 functions, we need to avoid double-wrapping. Having to do
;; this for #lang readers should be considered deprecated, and hopefully
;; one day we'll move to just doing it unilaterally (making this code throw
;; an error in that case before that's done).
;; This function takes "body" as a sequence of expressions (can be syntaxes
;; and/or sexprs) and returns a new body as a *single* expression that is
;; wrapped in a `#%module-begin' -- using the input if it was a single
;; pre-wrapped expression.
(define (wrap-module-begin body)
(let ([exprs (if (syntax? body) (syntax->list body) body)])
(if (and (pair? exprs) (null? (cdr exprs))
(let* ([x (car exprs)]
[x (if (syntax? x) (syntax-e x) x)]
[x (and (pair? x) (car x))]
[x (if (syntax? x) (syntax-e x) x)])
(eq? x '#%module-begin)))
(car exprs)
(cons '#%module-begin body))))
(define (wrap-internal lang port read whole? wrapper stx?
modpath src line col pos)
;; 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
;; expression that begins with the literal #%module-begin. If so,
;; it just returns that expression, else it wraps with #%module-begin.
(define (wrap-#%module-begin exps stx?)
(define wrapped-exps
(let ([wrapped `(#%module-begin . ,exps)])
(if stx? (datum->syntax #f wrapped) wrapped)))
(let ([exps (if stx? (syntax->list exps) exps)])
(cond
[(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 exps)]
[else wrapped-exps]))])))
(let* ([lang (if stx? (datum->syntax #f lang modpath modpath) lang)]
[body (lambda ()
(if whole?
@ -175,12 +176,10 @@
[body (cond [(not wrapper) (body)]
[(ar? wrapper 2) (wrapper body stx?)]
[else (wrapper body)])]
[body (wrap-module-begin body)]
[all-loc (vector src line col pos
(let-values ([(l c p) (port-next-location port)])
(and p (- p pos))))]
[body (if (and stx? (not (syntax? body)))
(datum->syntax #f body all-loc)
body)]
[p-name (object-name port)]
[name (if (path? p-name)
(let-values ([(base name dir?) (split-path p-name)])
@ -195,13 +194,7 @@
(add1 pos))
pos)))
v))]
;; Since there are users that wrap with #%module-begin in their
;; reader or wrapper1 functions, we need to avoid double-wrapping.
;; Having to do this for #lang readers should be considered
;; deprecated, and hopefully one day we'll move to just doing it
;; unilaterally.
[wrapped-body (wrap-#%module-begin body stx?)]
[r `(,(tag-src 'module) ,(tag-src name) ,lang ,wrapped-body)])
[r `(,(tag-src 'module) ,(tag-src name) ,lang ,body)])
(if stx? (datum->syntax #f r all-loc) r)))
(define (wrap lang port read modpath src line col pos)