syntax-case-as-syntax-parse.rkt (2064B)
1 #lang racket/base 2 (provide ~syntax-case ~syntax-case-stat) 3 (require stxparse-info/parse 4 (for-syntax racket/base)) 5 (define-for-syntax (~syntax-case-impl not-stat? stx) 6 (with-syntax ([(_ stx1) stx]) 7 (define (id=? a b) (and (identifier? a) 8 (free-identifier=? a b))) 9 (define (ds e [ctx #'stx1]) 10 (datum->syntax ctx e ctx ctx)) 11 (define (ds2 sym [locprop #'stx1]) 12 (datum->syntax #'here sym locprop locprop)) 13 (define (sc e) 14 (datum->syntax #'here `{~syntax-case ,e} e e)) 15 (define (process-sequence stx2) 16 (syntax-case stx2 () 17 [(pat ooo . rest) 18 (and (id=? #'ooo (quote-syntax ...)) not-stat?) 19 `(,{sc #'pat} ,#'ooo . ,(process-sequence #'rest))] 20 [(pat . rest) 21 `(,{sc #'pat} . ,(process-sequence #'rest))] 22 [() 23 stx2])) 24 (syntax-case #'stx1 () 25 [underscore (id=? #'underscore #'_) 26 #'underscore] 27 [id (identifier? #'id) 28 (ds `{,{ds2 '~var #'id} ,#'id})] 29 [(ooo stat) (and (id=? #'ooo (quote-syntax ...)) not-stat?) 30 {ds 31 `(,{ds2 '~syntax-case-stat #'ooo} 32 ,#'stat)}] 33 [(pat ooo . rest) (and (id=? #'ooo (quote-syntax ...)) not-stat?) 34 (ds `(,{sc #'pat} ,#'ooo . ,{sc #'rest}))] 35 [(pat . rest) (ds `(,{sc #'pat} . ,{sc #'rest}))] 36 [() #'stx1] 37 [#(pat ...) 38 (ds (vector->immutable-vector 39 (list->vector 40 (process-sequence #'(pat ...)))))] 41 [#&pat 42 (ds (box-immutable (sc #'pat)))] 43 [p 44 (prefab-struct-key (syntax-e #'p)) 45 (ds (make-prefab-struct 46 (prefab-struct-key (syntax-e #'p)) 47 (process-sequence 48 (cdr (vector->list (struct->vector (syntax-e #'p)))))))] 49 [other 50 (ds `{,(ds2 '~datum #'other) ,#'other})]))) 51 52 (define-syntax ~syntax-case 53 (pattern-expander (λ (stx) (~syntax-case-impl #t stx)))) 54 (define-syntax ~syntax-case-stat 55 (pattern-expander (λ (stx) (~syntax-case-impl #f stx))))