/usr/share/racket/collects/syntax/kerncase.rkt is in racket-common 6.1-4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | (module kerncase racket/base
(require (for-syntax racket/base)
(for-template racket/base))
(define-syntax kernel-syntax-case-internal
(lambda (stx)
(syntax-case stx ()
[(_ stxv phase rel? (extras ...) kernel-context clause ...)
(quasisyntax/loc
stx
(syntax-case* stxv (extras ...
#,@(map
syntax-local-introduce
(syntax-e
(quote-syntax
(quote
quote-syntax #%top
#%plain-lambda case-lambda
let-values letrec-values letrec-syntaxes+values
begin begin0 set!
with-continuation-mark
if #%plain-app #%expression
define-values define-syntaxes begin-for-syntax
module module*
#%plain-module-begin
#%require #%provide #%declare
#%variable-reference)))))
(let ([p phase])
(cond
[(and #,(syntax-e #'rel?) (= p 0))
free-identifier=?]
[(and #,(syntax-e #'rel?) (= p 1))
free-transformer-identifier=?]
[else (lambda (a b)
(free-identifier=? a b p '#,(syntax-local-phase-level)))]))
clause ...))])))
(define-syntax kernel-syntax-case
(lambda (stx)
(syntax-case stx ()
[(_ stxv trans? clause ...)
(quasisyntax/loc stx
(kernel-syntax-case-internal stxv (if trans? 1 0) #t () #,stx clause ...))])))
(define-syntax kernel-syntax-case*
(lambda (stx)
(syntax-case stx ()
[(_ stxv trans? (extras ...) clause ...)
(quasisyntax/loc stx
(kernel-syntax-case-internal stxv (if trans? 1 0) #t (extras ...) #,stx clause ...))])))
(define-syntax kernel-syntax-case/phase
(lambda (stx)
(syntax-case stx ()
[(_ stxv phase clause ...)
(quasisyntax/loc stx
(kernel-syntax-case-internal stxv phase #f () #,stx clause ...))])))
(define-syntax kernel-syntax-case*/phase
(lambda (stx)
(syntax-case stx ()
[(_ stxv phase (extras ...) clause ...)
(quasisyntax/loc stx
(kernel-syntax-case-internal stxv phase #f (extras ...) #,stx clause ...))])))
(define (kernel-form-identifier-list)
(syntax-e (quote-syntax
(begin
begin0
define-values
define-syntaxes
begin-for-syntax
set!
let-values
letrec-values
#%plain-lambda
case-lambda
if
quote
letrec-syntaxes+values
with-continuation-mark
#%expression
#%plain-app
#%top
#%datum
#%variable-reference
module module* #%provide #%require #%declare))))
(provide kernel-syntax-case
kernel-syntax-case*
kernel-syntax-case/phase
kernel-syntax-case*/phase
kernel-form-identifier-list))
|