163 lines
5.0 KiB
Racket
163 lines
5.0 KiB
Racket
#lang racket/base
|
|
|
|
(require
|
|
(for-syntax
|
|
racket/base
|
|
racket/list
|
|
racket/match
|
|
racket/block
|
|
syntax/parse
|
|
syntax/kerncase
|
|
racket/syntax
|
|
unstable/syntax
|
|
(for-syntax ;; phase 2!
|
|
racket/base)))
|
|
|
|
(provide
|
|
|
|
in-phase1 in-phase1/pass2
|
|
|
|
at-end
|
|
|
|
define-syntax-block
|
|
|
|
declare-names
|
|
define-renamings
|
|
define-single-definition
|
|
define-with-parameter
|
|
|
|
define-if-unbound
|
|
define-values-if-unbound
|
|
define-syntax-if-unbound
|
|
define-syntaxes-if-unbound)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Macro Definitions
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-syntax define-syntax-block
|
|
(block
|
|
|
|
(define-syntax-class declaration
|
|
#:attributes [internal external]
|
|
(pattern external:id
|
|
#:attr internal
|
|
(format-id #'external #:source #'external
|
|
"~a/proc" #'external))
|
|
(pattern [external:id internal:id]))
|
|
|
|
(syntax-parser
|
|
[(_ (decl:declaration ...) body:expr ...)
|
|
#:fail-when (check-duplicate-identifier
|
|
(syntax-list decl.external ...))
|
|
"duplicate defined name"
|
|
#'(define-syntaxes [decl.external ...]
|
|
;; Easier way to ensure the internal names are bound than
|
|
;; local-expand: bind them to an error macro and force the
|
|
;; user to shadow them.
|
|
(let-syntax
|
|
([decl.internal
|
|
(make-set!-transformer
|
|
(lambda (stx)
|
|
(raise-syntax-error #f
|
|
"transformer must be defined within define-syntax-block"
|
|
stx)))]
|
|
...)
|
|
(block
|
|
body ...
|
|
(values decl.internal ...))))])))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Definition Generalization
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-syntax-rule (define-single-definition define-one define-many)
|
|
(define-syntax define-one
|
|
(syntax-rules []
|
|
[(_ (head . args) . body) (define-one head (lambda args . body))]
|
|
[(_ name expr) (define-many [name] expr)])))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Potentially Redundant Bindings
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-syntax (define-many-if-unbound stx)
|
|
(syntax-case stx []
|
|
[(_ def [name ...] expr)
|
|
(let* ([ids (syntax->list #'(name ...))])
|
|
(for ([bad (in-list ids)] #:when (not (identifier? bad)))
|
|
(wrong-syntax bad "expected an identifier"))
|
|
(let*-values ([(bound unbound) (partition identifier-binding ids)])
|
|
(cond
|
|
[(null? bound) (syntax/loc stx (def [name ...] expr))]
|
|
[(null? unbound) (syntax/loc stx (def [] (values)))]
|
|
[else (wrong-syntax
|
|
stx
|
|
"conflicting definitions for ~s; none for ~s"
|
|
(map syntax-e bound)
|
|
(map syntax-e unbound))])))]))
|
|
|
|
(define-syntax-rule (define-values-if-unbound [name ...] expr)
|
|
(define-many-if-unbound define-values [name ...] expr))
|
|
|
|
(define-single-definition define-if-unbound define-values-if-unbound)
|
|
|
|
(define-syntax-rule (define-syntaxes-if-unbound [name ...] expr)
|
|
(define-many-if-unbound define-syntaxes [name ...] expr))
|
|
|
|
(define-single-definition define-syntax-if-unbound define-syntaxes-if-unbound)
|
|
|
|
(define-syntax (at-end stx)
|
|
(syntax-case stx ()
|
|
[(_ e ...)
|
|
(match (syntax-local-context)
|
|
['module
|
|
(begin
|
|
(syntax-local-lift-module-end-declaration
|
|
(syntax/loc stx (begin e ...)))
|
|
(syntax/loc stx (begin)))]
|
|
[ctx (wrong-syntax stx
|
|
"can only be used in module context; got: ~s"
|
|
ctx)])]))
|
|
|
|
(define-syntax-rule (define-with-parameter name parameter)
|
|
(define-syntax-rule (name value body (... ...))
|
|
(parameterize ([parameter value]) body (... ...))))
|
|
|
|
(define-syntax (declare-names stx)
|
|
(match (syntax-local-context)
|
|
['top-level
|
|
(syntax-case stx []
|
|
[(_ name ...) (syntax/loc stx (define-syntaxes [name ...] (values)))])]
|
|
[_ (syntax/loc stx (begin))]))
|
|
|
|
(define-syntax-rule (define-renamings [new old] ...)
|
|
(define-syntaxes [new ...] (values (make-rename-transformer #'old) ...)))
|
|
|
|
(define-syntax (in-phase1 stx)
|
|
(syntax-case stx []
|
|
[(_ e)
|
|
(match (syntax-local-context)
|
|
['expression (syntax/loc stx (let-syntax ([dummy e]) (void)))]
|
|
[(or 'module 'top-level (? pair?))
|
|
(syntax/loc stx
|
|
(begin
|
|
(define-syntax (macro stx*) (begin e (syntax/loc stx* (begin))))
|
|
(macro)))]
|
|
['module-begin (wrong-syntax stx "cannot be used as module body")])]))
|
|
|
|
(define-syntax (in-phase1/pass2 stx)
|
|
(syntax-case stx []
|
|
[(_ e)
|
|
(match (syntax-local-context)
|
|
[(? pair?)
|
|
(syntax/loc stx (define-values [] (begin (in-phase1 e) (values))))]
|
|
[(or 'expression 'top-level 'module 'module-begin)
|
|
(syntax/loc stx (#%expression (in-phase1 e)))])]))
|