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

add syntax/wrap-modbeg

Browse Source
This commit is contained in:
Matthew Flatt 2014-01-13 18:08:35 -07:00
parent 780d6ae566
commit bfda0665de
4 changed files with 187 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
pkgs/racket-pkgs/racket-doc/syntax/scribblings/module-helpers.scrbl
View File

@ -8,3 +8,4 @@
@include-section["modresolve.scrbl"]
@include-section["modcollapse.scrbl"]
@include-section["moddep.scrbl"]
@include-section["wrap-modbeg.scrbl"]

28
pkgs/racket-pkgs/racket-doc/syntax/scribblings/wrap-modbeg.scrbl Normal file
View File

@ -0,0 +1,28 @@
#lang scribble/doc
@(require "common.rkt" (for-label syntax/wrap-modbeg))
@title[#:tag "wrap-modbeg"]{Wrapping Module-Body Expressions}
@defmodule[syntax/wrap-modbeg]
@history[#:added "6.0.0.1"]
@defproc[(make-wrapping-module-begin [wrap-form syntax?]
[module-begin-form syntax? #'#%plain-module-begin])
(syntax? . -> . syntax?)]{
Provided @racket[for-syntax].
Constructs a function that is suitable for use as a
@racket[#%module-begin] replacement, particularly to replace the
facet of @racket[#%module-begin] that wraps each top-level
expression to print the expression's result(s).
The function takes a syntax object and returns a syntax object using
@racket[module-begin-form]. Assuming that @racket[module-begin-form]
resembles @racket[#%plain-module-begin], each top-level expression
@racket[_expr] will be wrapped as @racket[(wrap-form _expr)], while
top-level declarations (such as @racket[define-values] and
@racket[require] forms) are left as-is. Expressions are detected after
macro expansion and @racket[begin] splicing, and expansion is
interleaved with declaration processing as usual.}

140
racket/collects/racket/private/modbeg.rkt
View File

@ -2,7 +2,8 @@
;; `print-value'.
(module modbeg '#%kernel
(#%require (for-syntax '#%kernel))
(#%require syntax/wrap-modbeg
(for-syntax '#%kernel))
(#%provide module-begin)
@ -12,130 +13,17 @@
(apply values vs)))
(define-syntaxes (module-begin)
(lambda (stx)
(if (eq? 'module-begin (syntax-local-context))
(void)
(raise-syntax-error
#f
"allowed only around a module body"
stx))
(if (symbol? (syntax-e stx))
(raise-syntax-error
#f
"bad syntax"
stx)
(void))
(let-values ([(l) (syntax->list stx)])
(if l
(void)
(raise-syntax-error
#f
"bad syntax (illegal use of `.')"
stx))
(datum->syntax
stx
(cons (quote-syntax #%module-begin)
(map (lambda (e)
(list (quote-syntax printing-module-begin)
e))
(cdr l)))
stx
stx))))
(make-wrapping-module-begin (quote-syntax print-result)))
(define-syntaxes (printing-module-begin)
(define-syntaxes (print-result)
(lambda (stx)
(let-values ([(r) (cdr (syntax-e stx))])
(let-values ([(r) (if (syntax? r)
(syntax-e r)
r)])
(if (null? r)
(quote-syntax (void))
(let-values ([(e) (local-expand (car r)
'module
(syntax->list
(quote-syntax
(quote
quote-syntax #%top
lambda case-lambda
let-values letrec-values
begin begin0 set!
with-continuation-mark
if #%app #%expression
define-values define-syntaxes begin-for-syntax
module module*
#%module-begin
#%require #%provide #%declare
#%variable-reference))))])
;; `begin' is special...
(if (let-values ([(p) (syntax-e e)])
(if (pair? p)
(if (symbol? (syntax-e (car p)))
(if (free-identifier=? (car p) (quote-syntax begin))
(syntax->list e)
#f)
#f)
#f))
;; splice `begin'
(let-values ([(l) (syntax->list e)])
(datum->syntax
stx
(cons (car l)
(append
(map (lambda (elem)
(list
(quote-syntax printing-module-begin)
(syntax-track-origin elem e (car l))))
(cdr l))
(cdr r)))
stx))
;; no need to splice
(let-values ([(wrap?)
(let-values ([(e) (syntax-e e)])
(if (pair? e)
(let-values ([(a) (car e)])
(if (symbol? (syntax-e a))
(if (ormap (lambda (i)
(free-identifier=? i a))
(syntax->list
(quote-syntax
(define-values define-syntaxes begin-for-syntax
module module*
#%module-begin
#%require #%provide #%declare))))
#f
;; Also check for calls to `void':
(if (free-identifier=? a (quote-syntax #%app))
(let-values ([(e) (cdr e)])
(let-values ([(e) (if (syntax? e)
(syntax-e e)
e)])
(if (pair? e)
(if (symbol? (syntax-e (car e)))
(if (free-identifier=? (car e) (quote-syntax void))
#f
#t)
#t)
#t)))
#t))
#t))
#t))])
(let-values ([(e) (if wrap?
(datum->syntax
(quote-syntax here)
(list (quote-syntax #%app)
(quote-syntax call-with-values)
(list (quote-syntax lambda)
'()
e)
(quote-syntax print-values))
e)
e)])
(datum->syntax
stx
(if (null? (cdr r))
(list (quote-syntax begin) e)
(list (quote-syntax begin)
e
(cons (quote-syntax printing-module-begin)
(cdr r))))
stx)))))))))))
(let-values ([(e) (cadr (syntax->list stx))])
(datum->syntax
(quote-syntax here)
(list (quote-syntax #%app)
(quote-syntax call-with-values)
(list (quote-syntax lambda)
'()
e)
(quote-syntax print-values))
e)))))

144
racket/collects/syntax/wrap-modbeg.rkt Normal file
View File

@ -0,0 +1,144 @@
;; A #%module-begin that wraps each module-level expression with
;; given form:
(module modbeg '#%kernel
(#%require (for-syntax '#%kernel))
(#%provide (for-syntax make-wrapping-module-begin))
(begin-for-syntax
(define-values (make-wrapping-module-begin)
(case-lambda
[(wrapper) (make-wrapping-module-begin wrapper (quote-syntax #%module-begin))]
[(wrapper module-begin)
(lambda (stx)
(if (eq? 'module-begin (syntax-local-context))
(void)
(raise-syntax-error
#f
"allowed only around a module body"
stx))
(if (symbol? (syntax-e stx))
(raise-syntax-error
#f
"bad syntax"
stx)
(void))
(let-values ([(l) (syntax->list stx)])
(if l
(void)
(raise-syntax-error
#f
"bad syntax (illegal use of `.')"
stx))
(datum->syntax
stx
(cons module-begin
(map (lambda (e)
(list (quote-syntax do-wrapping-module-begin)
wrapper
e))
(cdr l)))
stx
stx)))])))
(define-syntaxes (do-wrapping-module-begin)
(lambda (stx)
(let-values ([(r) (cdr (syntax-e stx))])
(let-values ([(r) (if (syntax? r)
(syntax-e r)
r)])
(let-values ([(wrapper) (car r)]
[(r) (cdr r)])
(let-values ([(r) (if (syntax? r)
(syntax-e r)
r)])
(if (null? r)
(quote-syntax (void))
(let-values ([(e) (local-expand (car r)
'module
(syntax->list
(quote-syntax
(quote
quote-syntax #%top
lambda case-lambda
let-values letrec-values
begin begin0 set!
with-continuation-mark
if #%app #%expression
define-values define-syntaxes begin-for-syntax
module module*
#%module-begin
#%require #%provide #%declare
#%variable-reference))))])
;; `begin' is special...
(if (let-values ([(p) (syntax-e e)])
(if (pair? p)
(if (symbol? (syntax-e (car p)))
(if (free-identifier=? (car p) (quote-syntax begin))
(syntax->list e)
#f)
#f)
#f))
;; splice `begin'
(let-values ([(l) (syntax->list e)])
(datum->syntax
stx
(cons (car l)
(append
(map (lambda (elem)
(list
(quote-syntax do-wrapping-module-begin)
wrapper
(syntax-track-origin elem e (car l))))
(cdr l))
(cdr r)))
stx))
;; no need to splice
(let-values ([(wrap?)
(let-values ([(e) (syntax-e e)])
(if (pair? e)
(let-values ([(a) (car e)])
(if (symbol? (syntax-e a))
(if (ormap (lambda (i)
(free-identifier=? i a))
(syntax->list
(quote-syntax
(define-values define-syntaxes begin-for-syntax
module module*
#%module-begin
#%require #%provide #%declare))))
#f
;; Also check for calls to `void':
(if (free-identifier=? a (quote-syntax #%app))
(let-values ([(e) (cdr e)])
(let-values ([(e) (if (syntax? e)
(syntax-e e)
e)])
(if (pair? e)
(if (symbol? (syntax-e (car e)))
(if (free-identifier=? (car e) (quote-syntax void))
#f
#t)
#t)
#t)))
#t))
#t))
#t))])
(let-values ([(e) (if wrap?
(datum->syntax
(quote-syntax here)
(list wrapper
e)
e)
e)])
(datum->syntax
stx
(if (null? (cdr r))
(list (quote-syntax begin) e)
(list (quote-syntax begin)
e
(list* (quote-syntax do-wrapping-module-begin)
wrapper
(cdr r))))
stx)))))))))))))