b7127dc9c7
Does not yet work: - some errors about car of () - some match-expander certification errors svn: r9049
61 lines
2.7 KiB
Scheme
61 lines
2.7 KiB
Scheme
#lang scheme/base
|
|
|
|
(require (for-syntax scheme/base)
|
|
(for-syntax "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 #'macro-xform]))
|
|
(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)]
|
|
)) |