fb29a2498e
Add convenience lib for unstable docs.
Add char support to format-{id,symbol}
Add unstable/sequence library.
svn: r16789
71 lines
2.7 KiB
Scheme
71 lines
2.7 KiB
Scheme
#lang scheme/base
|
|
|
|
(require (for-syntax scheme/base
|
|
"patterns.ss"))
|
|
|
|
(provide define-match-expander)
|
|
|
|
(define-syntax (define-match-expander stx)
|
|
(define (lookup v alist)
|
|
(cond [(assoc v alist) => cadr]
|
|
[else #f]))
|
|
(define (parse args)
|
|
(let loop ([args args]
|
|
[alist '()])
|
|
(if (null? args)
|
|
alist
|
|
(let* ([stx-v (car args)]
|
|
[v (syntax-e stx-v)])
|
|
(cond
|
|
[(not (keyword? v))
|
|
(raise-syntax-error #f "argument must be a keyword" stx stx-v)]
|
|
[(not (memq v '(#:expression #:plt-match #:match)))
|
|
(raise-syntax-error
|
|
#f (format "keyword argument ~a is not a correct keyword" v)
|
|
stx stx-v)]
|
|
[else
|
|
(loop (cddr args) (cons (list v (cadr args)) alist))])))))
|
|
(syntax-case stx ()
|
|
[(_ id kw . rest)
|
|
(keyword? (syntax-e #'kw))
|
|
(let* ([args (syntax->list #'(kw . rest))]
|
|
[parsed-args (parse args)])
|
|
(with-syntax
|
|
([legacy-xform (lookup '#:match parsed-args)]
|
|
[match-xform (lookup '#:plt-match parsed-args)]
|
|
[macro-xform
|
|
(or (lookup '#:expression parsed-args)
|
|
#'(lambda (stx)
|
|
(raise-syntax-error
|
|
#f "this match expander must be used inside match"
|
|
stx)))])
|
|
(if (identifier? #'macro-xform)
|
|
(syntax/loc stx
|
|
(define-syntax id
|
|
(make-match-expander
|
|
match-xform
|
|
legacy-xform
|
|
(lambda (stx)
|
|
(syntax-case stx (set!)
|
|
[(nm . args) #'(macro-xform . args)]
|
|
[nm (identifier? #'nm) #'macro-xform]
|
|
[(set! . _)
|
|
(raise-syntax-error #f "match expander cannot be target of a set!" stx)]))
|
|
(syntax-local-certifier))))
|
|
(syntax/loc stx
|
|
(define-syntax id
|
|
(make-match-expander match-xform legacy-xform macro-xform
|
|
(syntax-local-certifier)))))))]
|
|
;; implement legacy syntax
|
|
[(_ id plt-match-xform match-xform std-xform)
|
|
#'(define-match-expander id #:plt-match plt-match-xform
|
|
#:match match-xform
|
|
#:expression std-xform)]
|
|
[(_ id plt-match-xform std-xform)
|
|
#'(define-match-expander id #:plt-match plt-match-xform
|
|
#:expression std-xform)]
|
|
[(_ id plt-match-xform)
|
|
#'(define-match-expander id #:plt-match plt-match-xform)]
|
|
;; error checking
|
|
[_ (raise-syntax-error #f "invalid use of define-match-expander" stx)]))
|