/usr/share/racket/collects/syntax/kerncase.rkt is in racket-common 6.7-3.
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 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | (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 [pattern . rhs] ...)
(let ()
(define kernel-ids (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))))
(define (replace-same-free-id pat)
(cond
[(identifier? pat)
(or (for/or ([kernel-id (in-list kernel-ids)])
(and (free-identifier=? pat kernel-id)
(datum->syntax kernel-id (syntax-e kernel-id) pat pat)))
pat)]
[(pair? pat) (cons (replace-same-free-id (car pat))
(replace-same-free-id (cdr pat)))]
[(vector? pat)
(list->vector (map replace-same-free-id (vector->list pat)))]
[(box? pat)
(box (replace-same-free-id (unbox pat)))]
[(prefab-struct-key pat)
=> (lambda (key)
(apply make-prefab-struct
key
(map replace-same-free-id (cdr (struct->vector pat)))))]
[(syntax? pat)
(datum->syntax pat (replace-same-free-id (syntax-e pat)) pat pat)]
[else pat]))
(with-syntax ([(pattern ...)
(map (lambda (pat)
(replace-same-free-id pat))
(syntax->list #'(pattern ...)))])
(quasisyntax/loc
stx
(syntax-case* stxv (extras ... #,@kernel-ids)
(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)))]))
[pattern . rhs] ...))))])))
(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))
|