/usr/share/racket/collects/syntax/wrap-modbeg.rkt is in racket-common 6.7-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 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)))))))))))))
|