|
|
@ -3,7 +3,6 @@
|
|
|
|
(provide define+provide+safe+match)
|
|
|
|
(provide define+provide+safe+match)
|
|
|
|
|
|
|
|
|
|
|
|
(require racket/match
|
|
|
|
(require racket/match
|
|
|
|
syntax/parse/define
|
|
|
|
|
|
|
|
(for-syntax racket/base
|
|
|
|
(for-syntax racket/base
|
|
|
|
racket/syntax
|
|
|
|
racket/syntax
|
|
|
|
syntax/parse
|
|
|
|
syntax/parse
|
|
|
@ -32,45 +31,47 @@
|
|
|
|
[(stx-pair? stx)
|
|
|
|
[(stx-pair? stx)
|
|
|
|
(datum->syntax stx (cons id (stx-cdr stx)) stx stx)])))
|
|
|
|
(datum->syntax stx (cons id (stx-cdr stx)) stx stx)])))
|
|
|
|
|
|
|
|
|
|
|
|
(define-syntax-parser define+provide+safe+match
|
|
|
|
(define-syntax define+provide+safe+match
|
|
|
|
|
|
|
|
(λ (stx)
|
|
|
|
|
|
|
|
(syntax-parse stx
|
|
|
|
|
|
|
|
|
|
|
|
[(d (head . args)
|
|
|
|
[(d (head . args)
|
|
|
|
contract:expr
|
|
|
|
contract:expr
|
|
|
|
value-body:expr ...+
|
|
|
|
value-body:expr ...+
|
|
|
|
#:match-expander match-transformer:expr)
|
|
|
|
#:match-expander match-transformer:expr)
|
|
|
|
#:with fn-expr (syntax/loc this-syntax (λ args value-body ...))
|
|
|
|
#:with fn-expr (syntax/loc stx (λ args value-body ...))
|
|
|
|
(syntax/loc this-syntax
|
|
|
|
(syntax/loc stx
|
|
|
|
(d head contract fn-expr #:match-expander match-transformer))]
|
|
|
|
(d head contract fn-expr #:match-expander match-transformer))]
|
|
|
|
|
|
|
|
|
|
|
|
[(_ name:id
|
|
|
|
[(_ name:id
|
|
|
|
contract:expr
|
|
|
|
contract:expr
|
|
|
|
value:expr
|
|
|
|
value:expr
|
|
|
|
#:match-expander match-transformer:expr)
|
|
|
|
#:match-expander match-transformer:expr)
|
|
|
|
#:with internal-name (generate-temporary #'name)
|
|
|
|
#:with internal-name (generate-temporary #'name)
|
|
|
|
#:with contract-name (generate-temporary #'name)
|
|
|
|
#:with contract-name (generate-temporary #'name)
|
|
|
|
#:with make-name-match-transformer (generate-temporary #'name)
|
|
|
|
#:with make-name-match-transformer (generate-temporary #'name)
|
|
|
|
#'(begin
|
|
|
|
#'(begin
|
|
|
|
(define internal-name (let ([name value]) name))
|
|
|
|
(define internal-name (let ([name value]) name))
|
|
|
|
|
|
|
|
|
|
|
|
(begin-for-syntax
|
|
|
|
(begin-for-syntax
|
|
|
|
(define (make-name-match-transformer name)
|
|
|
|
(define (make-name-match-transformer name)
|
|
|
|
(with-syntax ([name name]) match-transformer)))
|
|
|
|
(with-syntax ([name name]) match-transformer)))
|
|
|
|
|
|
|
|
|
|
|
|
(define-match-expander name
|
|
|
|
(define-match-expander name
|
|
|
|
(make-name-match-transformer (quote-syntax internal-name))
|
|
|
|
(make-name-match-transformer (quote-syntax internal-name))
|
|
|
|
(variable-like-transformer (quote-syntax internal-name)))
|
|
|
|
(variable-like-transformer (quote-syntax internal-name)))
|
|
|
|
|
|
|
|
|
|
|
|
(provide name)
|
|
|
|
(provide name)
|
|
|
|
|
|
|
|
|
|
|
|
(module+ safe
|
|
|
|
(module+ safe
|
|
|
|
(require racket/contract/base)
|
|
|
|
(require racket/contract/base)
|
|
|
|
|
|
|
|
|
|
|
|
(define-module-boundary-contract contract-name internal-name contract
|
|
|
|
(define-module-boundary-contract contract-name internal-name contract
|
|
|
|
#:name-for-blame name)
|
|
|
|
#:name-for-blame name)
|
|
|
|
|
|
|
|
|
|
|
|
(define-match-expander name
|
|
|
|
(define-match-expander name
|
|
|
|
(make-name-match-transformer (quote-syntax contract-name))
|
|
|
|
(make-name-match-transformer (quote-syntax contract-name))
|
|
|
|
(variable-like-transformer (quote-syntax contract-name)))
|
|
|
|
(variable-like-transformer (quote-syntax contract-name)))
|
|
|
|
|
|
|
|
|
|
|
|
(provide name)))])
|
|
|
|
(provide name)))])))
|
|
|
|
|
|
|
|
|
|
|
|