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
118
119
120
|
(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
quote-syntax
letrec-syntaxes+values
with-continuation-mark
#%expression
#%plain-app
#%top
#%datum
#%variable-reference
#%plain-module-begin
module module* #%provide #%require #%declare))))
(provide kernel-syntax-case
kernel-syntax-case*
kernel-syntax-case/phase
kernel-syntax-case*/phase
kernel-form-identifier-list))
|
