stxloc.rkt (2302B)
1 2 ;;---------------------------------------------------------------------- 3 ;; syntax/loc 4 5 (module stxloc '#%kernel 6 (#%require racket/private/qq-and-or "stxcase.rkt" racket/private/define-et-al 7 (for-syntax '#%kernel "stxcase.rkt" racket/private/sc)) 8 9 (begin-for-syntax 10 (define-values (transform-to-syntax-case**) 11 (lambda (stx sc arg-is-stx? expr kws lit-comp s-exp? clauses) 12 ((λ (ans) (datum->syntax #'here ans stx)) 13 (list* 'syntax-case** sc arg-is-stx? expr kws lit-comp s-exp? 14 clauses))))) 15 16 ;; Like regular syntax-case, but with free-identifier=? replacement 17 (-define-syntax syntax-case* 18 (lambda (stx) 19 (syntax-case** #f #t stx () free-identifier=? #f 20 [(sc stxe kl id=? . clause) 21 (transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'id=? #f #'clause)]))) 22 23 ;; Regular syntax-case 24 (-define-syntax syntax-case 25 (lambda (stx) 26 (syntax-case** #f #t stx () free-identifier=? #f 27 [(sc stxe kl . clause) 28 (transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'free-identifier=? #f 29 #'clause)]))) 30 31 ;; Like `syntax-case, but on plain datums 32 (-define-syntax datum-case 33 (lambda (stx) 34 (syntax-case** #f #t stx () free-identifier=? #f 35 [(sc stxe kl . clause) 36 (transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'eq? #t #'clause)]))) 37 38 (-define-syntax quote-syntax/prune 39 (lambda (stx) 40 (syntax-case** #f #t stx () free-identifier=? #f 41 [(_ id) 42 (if (symbol? (syntax-e #'id)) 43 (datum->syntax #'here 44 (list (quote-syntax quote-syntax) 45 (identifier-prune-lexical-context (syntax id) 46 (list 47 (syntax-e (syntax id)) 48 '#%top))) 49 stx 50 #f 51 stx) 52 (raise-syntax-error 53 #f 54 "expected an identifier" 55 stx 56 #'id))]))) 57 58 (#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case datum-case 59 ... _ ~? ~@))