Wrote a preexpander for a simplified variant of syntax-case.
This commit is contained in:
parent
abe7438d7d
commit
984f861a85
17
and.rkt
Normal file
17
and.rkt
Normal file
|
@ -0,0 +1,17 @@
|
||||||
|
#lang racket
|
||||||
|
|
||||||
|
(provide preexpanded-and)
|
||||||
|
|
||||||
|
(require syntax/parse
|
||||||
|
(for-template racket/base))
|
||||||
|
|
||||||
|
(define (preexpanded-and stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(clause)
|
||||||
|
#'clause]
|
||||||
|
[(#t . rest)
|
||||||
|
(preexpanded-and #`rest)]
|
||||||
|
[(clause . rest)
|
||||||
|
#`(if clause
|
||||||
|
#,(preexpanded-and #`rest)
|
||||||
|
#f)]))
|
65
syntax-case.rkt
Normal file
65
syntax-case.rkt
Normal file
|
@ -0,0 +1,65 @@
|
||||||
|
#lang racket
|
||||||
|
|
||||||
|
(provide preexpanded-syntax-case/no-bind)
|
||||||
|
|
||||||
|
(require (for-syntax preexpanded/and
|
||||||
|
racket/pretty
|
||||||
|
syntax/stx
|
||||||
|
syntax/parse
|
||||||
|
syntax/parse/experimental/template)
|
||||||
|
syntax/stx)
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
(define-syntax-class (pat part)
|
||||||
|
#:attributes (test)
|
||||||
|
(pattern (~literal _)
|
||||||
|
#:with test #'#t)
|
||||||
|
(pattern ()
|
||||||
|
#:with test #`(null? #,part))
|
||||||
|
(pattern ((~literal ~literal) identifier:id)
|
||||||
|
#:when (syntax-pattern-variable?
|
||||||
|
(syntax-local-value #'identifier
|
||||||
|
(λ _ #f)))
|
||||||
|
#:with test #`(free-identifier=? #,part (quote-syntax identifier)))
|
||||||
|
(pattern ((~literal ~literal) identifier:id)
|
||||||
|
#:with test #`(free-identifier=? #,part (quote-syntax identifier)))
|
||||||
|
(pattern ((~literal ~datum) identifier:id)
|
||||||
|
#:with test #`(eq? (syntax-e #,part) 'identifier))
|
||||||
|
(pattern k:keyword
|
||||||
|
#:with test #`(eq? (syntax-e #,part) 'k))
|
||||||
|
(pattern ((~var sub (pat #'car-part)) . (~var rest (pat #'cdr-part)))
|
||||||
|
;; TODO: optimize the #t case.
|
||||||
|
#:with test (preexpanded-and
|
||||||
|
#`((stx-pair? #,part)
|
||||||
|
(let-values ([(car-part) (stx-car #,part)]
|
||||||
|
[(cdr-part) (stx-cdr #,part)])
|
||||||
|
#,(preexpanded-and
|
||||||
|
#'(sub.test rest.test))))))))
|
||||||
|
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
(define-splicing-syntax-class (clause-maybe-dotted whole)
|
||||||
|
(pattern (~seq [(~var pat (pat whole)) body]
|
||||||
|
(~optional (~seq (patvar ...)
|
||||||
|
(~and ddd (~literal ...)))))
|
||||||
|
#:with test #'pat.test
|
||||||
|
;#:with (patvar ...) #`#,(attribute pat.patvar)
|
||||||
|
#:with expanded
|
||||||
|
(if (attribute ddd)
|
||||||
|
#'(map (lambda (patvar ...)
|
||||||
|
(with-syntax ([patvar patvar] ...)
|
||||||
|
#'[test body]))
|
||||||
|
(syntax->list #'(patvar (... ...)))
|
||||||
|
...)
|
||||||
|
#'(list #'[test body])))))
|
||||||
|
|
||||||
|
(define-syntax (preexpanded-syntax-case/no-bind stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ name stx2 (~var clause (clause-maybe-dotted #'whole)) ...)
|
||||||
|
((λ (x)
|
||||||
|
;(pretty-write (syntax->datum x))
|
||||||
|
x)
|
||||||
|
#'#`(let-values ([(whole) stx2])
|
||||||
|
(cond #,@clause.expanded
|
||||||
|
...
|
||||||
|
[else (raise-syntax-error 'name "Invalid syntax" whole)])))]))
|
30
test/test-syntax-case.rkt
Normal file
30
test/test-syntax-case.rkt
Normal file
|
@ -0,0 +1,30 @@
|
||||||
|
#lang racket
|
||||||
|
|
||||||
|
(require (for-syntax preexpanded/syntax-case))
|
||||||
|
|
||||||
|
(define-syntax (define-a*-b stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ name [foo val] ...)
|
||||||
|
#`(define-syntax (name stx2)
|
||||||
|
#,(preexpanded-syntax-case/no-bind define-a*-b stx2
|
||||||
|
[(_ #:a (~literal foo)) #'val]
|
||||||
|
(foo val)
|
||||||
|
...
|
||||||
|
[(_ #:b) #'2]))]))
|
||||||
|
|
||||||
|
(define-a*-b myab [a 10] [b 20] [c 30])
|
||||||
|
(myab #:a a)
|
||||||
|
(myab #:a b)
|
||||||
|
(myab #:a c)
|
||||||
|
;(myab #:a d) ;; Invalid syntax, as expected
|
||||||
|
;(myab #:a) ;; Invalid syntax, as expected
|
||||||
|
;(myab #:a a e) ;; Invalid syntax, as expected
|
||||||
|
(myab #:b)
|
||||||
|
|
||||||
|
#;(preexpanded-syntax-case/no-bind mymacro #'(mymacro #:a +)
|
||||||
|
[(_ #:a (~literal +)) 1]
|
||||||
|
[(_ #:b) 2])
|
||||||
|
|
||||||
|
#;(preexpanded-syntax-case/no-bind mymacro #'(mymacro #:b foo)
|
||||||
|
[(_ #:a (~literal +)) 1]
|
||||||
|
[(_ #:b (~datum foo)) 2])
|
Loading…
Reference in New Issue
Block a user