140 lines
6.7 KiB
Scheme
140 lines
6.7 KiB
Scheme
;; A #%module-begin that wraps each module-level expression with
|
|
;; `print-value'.
|
|
|
|
(module modbeg '#%kernel
|
|
(#%require (for-syntax '#%kernel))
|
|
|
|
(#%provide module-begin)
|
|
|
|
(define-values (print-values)
|
|
(lambda vs (for-each (current-print) 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))))
|
|
|
|
(define-syntaxes (printing-module-begin)
|
|
(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 define-values-for-syntax
|
|
module
|
|
#%module-begin
|
|
#%require #%provide
|
|
#%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 define-values-for-syntax
|
|
module
|
|
#%module-begin
|
|
#%require #%provide))))
|
|
#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
|
|
e
|
|
(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)))))))))))
|