103 lines
3.5 KiB
Racket
103 lines
3.5 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/match
|
|
syntax/parse
|
|
(for-syntax racket/base
|
|
racket/syntax
|
|
racket/list
|
|
racket/struct
|
|
syntax/parse
|
|
racket/private/sc)
|
|
;; attribute-mapping? is provided for-syntax
|
|
(only-in syntax/parse/private/residual attribute-mapping?))
|
|
|
|
(provide auto-with-syntax)
|
|
(provide auto-syntax)
|
|
(provide auto-syntax-case)
|
|
|
|
(define (leaves->datum e depth)
|
|
(if (> depth 0)
|
|
(map (λ (eᵢ) (leaves->datum eᵢ (sub1 depth))) e)
|
|
(if (syntax? e)
|
|
(syntax->datum e)
|
|
e)))
|
|
|
|
|
|
(define-syntax (to-datum stx)
|
|
(syntax-case stx ()
|
|
[(_ id)
|
|
(syntax-pattern-variable? (syntax-local-value #'id (λ () #f)))
|
|
(begin
|
|
(let* ([mapping (syntax-local-value #'id)]
|
|
[valvar (syntax-mapping-valvar mapping)]
|
|
[depth (syntax-mapping-depth mapping)])
|
|
(if (attribute-mapping? (syntax-local-value valvar (λ () #f)))
|
|
#`(leaves->datum (attribute id) #,depth)
|
|
#`(leaves->datum #,valvar #,depth))))]))
|
|
|
|
(begin-for-syntax
|
|
(define-values (struct:auto-pvar
|
|
make-auto-pvar
|
|
auto-pvar?
|
|
auto-pvar-ref
|
|
auto-pvar-set!)
|
|
(make-struct-type 'auto-pvar
|
|
(eval #'struct:syntax-mapping
|
|
(module->namespace 'racket/private/sc))
|
|
0
|
|
0
|
|
#f
|
|
null
|
|
(current-inspector)
|
|
(λ (self stx)
|
|
#`(to-datum #,stx)))))
|
|
|
|
(define-for-syntax (syntax->tree/ids e)
|
|
(cond [(identifier? e) e]
|
|
[(syntax? e) (syntax->tree/ids (syntax-e e))]
|
|
[(pair? e) (cons (syntax->tree/ids (car e))
|
|
(syntax->tree/ids (cdr e)))]
|
|
[(vector? e) (map syntax->tree/ids (vector->list e))]
|
|
[(box? e) (syntax->tree/ids (unbox e))]
|
|
[(prefab-struct-key e) (map syntax->tree/ids (struct->list e))]
|
|
[else e]))
|
|
|
|
(define-for-syntax (syntax->ids e)
|
|
(filter identifier? (flatten (syntax->tree/ids e))))
|
|
|
|
(define-syntax auto-syntax
|
|
(syntax-parser
|
|
[(_ (id ...) body ...)
|
|
#:with (pvar-id ...) (filter (λ (id)
|
|
(syntax-pattern-variable?
|
|
(syntax-local-value id (λ () #f))))
|
|
(syntax->list #'(id ...)))
|
|
(with-disappeared-uses
|
|
(let ()
|
|
(record-disappeared-uses (syntax->list #'(pvar-id ...)))
|
|
#'(let-syntax ([pvar-id
|
|
(make-set!-transformer
|
|
(let ([mapping (syntax-local-value
|
|
(quote-syntax pvar-id))])
|
|
(make-auto-pvar (syntax-mapping-depth mapping)
|
|
(syntax-mapping-valvar mapping))))]
|
|
...)
|
|
body ...)))]))
|
|
|
|
(define-syntax auto-with-syntax
|
|
(syntax-parser
|
|
[(_ ([pat e] ...) body ...)
|
|
#:with (id ...) (syntax->ids #'(pat ...))
|
|
#'(with-syntax ([pat e] ...)
|
|
(auto-syntax (id ...)
|
|
body ...))]))
|
|
|
|
|
|
(define-syntax auto-syntax-case
|
|
(syntax-parser
|
|
[(_ stx-expression literals [pat guard+body ...] ...)
|
|
#:with (id ...) (syntax->ids #'(pat ...))
|
|
#'(syntax-case stx-expression literals
|
|
[pat (auto-syntax (id ...)
|
|
guard+body ...)]
|
|
...)])) |