stxloc.rkt (2961B)
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 (relocate loc stx) 39 (if (or (syntax-source loc) 40 (syntax-position loc)) 41 (datum->syntax stx 42 (syntax-e stx) 43 loc 44 stx) 45 stx)) 46 47 ;; Like syntax, but also takes a syntax object 48 ;; that supplies a source location for the 49 ;; resulting syntax object. 50 (-define-syntax syntax/loc 51 (lambda (stx) 52 (syntax-case** #f #t stx () free-identifier=? #f 53 [(_ loc pattern) 54 (if (if (symbol? (syntax-e #'pattern)) 55 (syntax-pattern-variable? (syntax-local-value #'pattern (lambda () #f))) 56 #f) 57 (syntax (syntax pattern)) 58 (syntax (relocate loc (syntax pattern))))]))) 59 60 (-define-syntax quote-syntax/prune 61 (lambda (stx) 62 (syntax-case** #f #t stx () free-identifier=? #f 63 [(_ id) 64 (if (symbol? (syntax-e #'id)) 65 (datum->syntax #'here 66 (list (quote-syntax quote-syntax) 67 (identifier-prune-lexical-context (syntax id) 68 (list 69 (syntax-e (syntax id)) 70 '#%top))) 71 stx 72 #f 73 stx) 74 (raise-syntax-error 75 #f 76 "expected an identifier" 77 stx 78 #'id))]))) 79 80 (#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case datum-case ... _))