syntax-case.rkt (2606B)
1 #lang racket 2 3 (provide preexpanded-syntax-case/no-bind) 4 5 (require (for-syntax preexpanded/and 6 racket/pretty 7 syntax/stx 8 syntax/parse 9 syntax/parse/experimental/template) 10 syntax/stx) 11 12 (begin-for-syntax 13 (define-syntax-class (pat part) 14 #:attributes (test) 15 (pattern (~literal _) 16 #:with test #'#t) 17 (pattern () 18 #:with test #`(null? #,part)) 19 (pattern ((~literal ~literal) identifier:id) 20 #:when (syntax-pattern-variable? 21 (syntax-local-value #'identifier 22 (λ _ #f))) 23 #:with test #`(free-identifier=? #,part (quote-syntax identifier))) 24 (pattern ((~literal ~literal) identifier:id) 25 #:with test #`(free-identifier=? #,part (quote-syntax identifier))) 26 (pattern ((~literal ~datum) identifier:id) 27 #:with test #`(eq? (syntax-e #,part) 'identifier)) 28 (pattern k:keyword 29 #:with test #`(eq? (syntax-e #,part) 'k)) 30 (pattern ((~var sub (pat #'car-part)) . (~var rest (pat #'cdr-part))) 31 ;; TODO: optimize the #t case. 32 #:with test (preexpanded-and 33 #`((stx-pair? #,part) 34 (let-values ([(car-part) (stx-car #,part)] 35 [(cdr-part) (stx-cdr #,part)]) 36 #,(preexpanded-and 37 #'(sub.test rest.test)))))))) 38 39 40 (begin-for-syntax 41 (define-splicing-syntax-class (clause-maybe-dotted whole) 42 (pattern (~seq [(~var pat (pat whole)) body] 43 (~optional (~seq (patvar ...) 44 (~and ddd (~literal ...))))) 45 #:with test #'pat.test 46 ;#:with (patvar ...) #`#,(attribute pat.patvar) 47 #:with expanded 48 (if (attribute ddd) 49 #'(map (lambda (patvar ...) 50 (with-syntax ([patvar patvar] ...) 51 #'[test body])) 52 (syntax->list #'(patvar (... ...))) 53 ...) 54 #'(list #'[test body]))))) 55 56 (define-syntax (preexpanded-syntax-case/no-bind stx) 57 (syntax-parse stx 58 [(_ name stx2 (~var clause (clause-maybe-dotted #'whole)) ...) 59 ((λ (x) 60 ;(pretty-write (syntax->datum x)) 61 x) 62 #'#`(let-values ([(whole) stx2]) 63 (cond #,@clause.expanded 64 ... 65 [else (raise-syntax-error 'name "Invalid syntax" whole)])))]))