added filtered-in and -out
svn: r10826
This commit is contained in:
parent
a2e03a8ad4
commit
5a7ce88ac0
71
collects/scheme/private/at-syntax.ss
Normal file
71
collects/scheme/private/at-syntax.ss
Normal file
|
@ -0,0 +1,71 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-template scheme/base))
|
||||
|
||||
(provide at-syntax)
|
||||
|
||||
;; -------------------------------------------------------------------
|
||||
;; NOTE: This library is for internal use only, it is can change
|
||||
;; and/or disappear. Do not use without protective eyewear!
|
||||
;; -------------------------------------------------------------------
|
||||
|
||||
#|
|
||||
|
||||
The `(at-syntax expr)' form is a useful syntax-time utility that can
|
||||
be used to sort of evaluate an expression at syntax time, and doing so
|
||||
in a well behaved way (eg, it respects the source for-syntax bindings,
|
||||
but it does have some issues). It can be used to implement an escape
|
||||
to the syntax level that is not restricted like `begin-for-syntax'.
|
||||
|
||||
The basic idea of the code is to plant the given expression on the
|
||||
right hand side of a `let-syntax' -- inside a `(lambda (stx) ...)' to
|
||||
make it a valid transformer, with a singe use of this macro so that we
|
||||
get it to execute with `local-expand'. The macro returns a 3d
|
||||
expression that contains the evaluated expression "somehwhere",
|
||||
depending on the expansion of `let-syntax' -- so to make it easy to
|
||||
find we plant it inside a thunk (so this works as long as `let-syntax'
|
||||
does not include 3d procedure values in its expansion). Finally, the
|
||||
constructed `let-syntax' is expanded, we search through the resulting
|
||||
syntax for the thunk, then apply it to get the desired value.
|
||||
|
||||
Here's a silly example to demonstrate:
|
||||
|
||||
> (define-syntax (compile-time-if stx)
|
||||
(syntax-case stx ()
|
||||
[(_ cond expr1 expr2)
|
||||
(if (at-syntax #'cond) #'expr1 #'expr2)]))
|
||||
> (define-for-syntax x 8)
|
||||
> (define x 100)
|
||||
> (compile-time-if (< x 10) (+ x 10) (- x 10))
|
||||
110
|
||||
|
||||
And another example, creating a macro for syntax-time expressions:
|
||||
|
||||
> (define-syntax (compile-time-value stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr) #`(quote #,(at-syntax #'expr))]))
|
||||
> (compile-time-value (* x 2))
|
||||
16
|
||||
|
||||
but the `quote' here is a hint that this can get 3d values into
|
||||
syntax, and all the problems that are involved. Also, note that it
|
||||
breaks if you try to do something like:
|
||||
|
||||
> (compile-time-value (begin (set! x 11) x))
|
||||
8
|
||||
|
||||
(and, of course, it cannot be used to define new bindings).
|
||||
|
||||
|#
|
||||
|
||||
(define (at-syntax expr)
|
||||
(let loop ([x (with-syntax ([e expr])
|
||||
(local-expand
|
||||
#'(let-syntax ([here (lambda (stx)
|
||||
(datum->syntax stx (lambda () e)))])
|
||||
here)
|
||||
'expression '()))])
|
||||
(cond [(procedure? x) (x)]
|
||||
[(pair? x) (or (loop (car x)) (loop (cdr x)))]
|
||||
[(syntax? x) (loop (syntax-e x))]
|
||||
[else #f])))
|
|
@ -1,6 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-syntax scheme/base scheme/provide-transform))
|
||||
(require (for-syntax scheme/base scheme/provide-transform scheme/list
|
||||
"private/at-syntax.ss"))
|
||||
|
||||
(provide matching-identifiers-out)
|
||||
(define-syntax matching-identifiers-out
|
||||
|
@ -13,3 +14,24 @@
|
|||
(filter (lambda (e)
|
||||
(regexp-match? rx (symbol->string (export-out-sym e))))
|
||||
(expand-export #'spec modes)))]))))
|
||||
|
||||
(provide filtered-out)
|
||||
(define-syntax filtered-out
|
||||
(make-provide-transformer
|
||||
(lambda (stx modes)
|
||||
(syntax-case stx ()
|
||||
[(_ proc spec)
|
||||
(let ([proc (at-syntax #'proc)])
|
||||
(filter-map
|
||||
(lambda (e)
|
||||
(let* ([s1 (symbol->string (export-out-sym e))]
|
||||
[s2 (proc s1)])
|
||||
(cond [(equal? s1 s2) e]
|
||||
[(string? s2) (make-export (export-local-id e)
|
||||
(string->symbol s2)
|
||||
(export-mode e)
|
||||
(export-protect? e)
|
||||
(export-orig-stx e))]
|
||||
[(not s2) #f]
|
||||
[else (error 'filtered-out "bad result: ~e" s2)])))
|
||||
(expand-export #'spec modes)))]))))
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-syntax scheme/base scheme/require-transform))
|
||||
(require (for-syntax scheme/base scheme/require-transform scheme/list
|
||||
"private/at-syntax.ss"))
|
||||
|
||||
(provide matching-identifiers-in)
|
||||
(define-syntax matching-identifiers-in
|
||||
|
@ -34,3 +35,31 @@
|
|||
(not (memq (syntax-e (import-local-id i)) subs)))
|
||||
imports)
|
||||
sources))]))))
|
||||
|
||||
(provide filtered-in)
|
||||
(define-syntax filtered-in
|
||||
(make-require-transformer
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ proc spec)
|
||||
(let ([proc (at-syntax #'proc)])
|
||||
(define-values [imports sources] (expand-import #'spec))
|
||||
(values
|
||||
(filter-map
|
||||
(lambda (i)
|
||||
(let* ([id (import-local-id i)]
|
||||
[s1 (symbol->string (syntax-e id))]
|
||||
[s2 (proc s1)])
|
||||
(cond [(equal? s1 s2) i]
|
||||
[(string? s2) (make-import (datum->syntax
|
||||
id (string->symbol s2) id)
|
||||
(import-src-sym i)
|
||||
(import-src-mod-path i)
|
||||
(import-mode i)
|
||||
(import-req-mode i)
|
||||
(import-orig-mode i)
|
||||
(import-orig-stx i))]
|
||||
[(not s2) #f]
|
||||
[else (error 'filtered-in "bad result: ~e" s2)])))
|
||||
imports)
|
||||
sources))]))))
|
||||
|
|
Loading…
Reference in New Issue
Block a user