Skip to content

Commit 771cba4

Browse files
Copilotjackfirth
Copilot
and
jackfirth
committed
Refactor analyzers to reuse expansion table code
Move syntax-label-id-phases and binding-site-identifiers to expanded-id-table module, and create fully-expanded-syntax-id-table function. Update both identifier-usage-analyzer and variable-mutability-analyzer to use the shared code. Co-authored-by: jackfirth <[email protected]>
1 parent 0b32534 commit 771cba4

File tree

3 files changed

+123
-134
lines changed

3 files changed

+123
-134
lines changed

‎default-recommendations/analyzers/identifier-usage.rkt‎

Lines changed: 2 additions & 68 deletions
Original file line numberDiff line numberDiff line change
@@ -32,67 +32,6 @@
3232
;@----------------------------------------------------------------------------------------------------
3333

3434

35-
;; Label syntax with phase information
36-
(define (syntax-label-id-phases expanded-stx)
37-
(let loop ([expanded-stx expanded-stx] [phase 0] [skip? #false])
38-
(syntax-traverse expanded-stx
39-
#:skip-root? skip?
40-
#:literal-sets ([kernel-literals #:phase phase])
41-
42-
[:id (syntax-property this-syntax 'phase phase)]
43-
[(begin-for-syntax _ ...) (loop this-syntax (add1 phase) #true)]
44-
45-
[(define-syntaxes-id:define-syntaxes ids expr)
46-
(define new-define-syntaxes (loop (attribute define-syntaxes-id) phase #false))
47-
(define new-ids (loop (attribute ids) phase #true))
48-
(define new-expr (loop (attribute expr) (add1 phase) #false))
49-
(define new-datum (list new-define-syntaxes new-ids new-expr))
50-
(datum->syntax this-syntax new-datum this-syntax this-syntax)]
51-
52-
[((~or module module*) _ ...) (loop this-syntax 0 #true)]
53-
54-
#:parent-context-modifier (λ (stx) stx)
55-
#:parent-srcloc-modifier (λ (stx) stx)
56-
#:parent-props-modifier (λ (stx) stx))))
57-
58-
59-
;; Find all binding sites and return them as a stream of identifiers
60-
(define (binding-site-identifiers expanded-stx)
61-
(let loop ([expanded-stx expanded-stx] [phase 0])
62-
(define (recur stx)
63-
(loop stx phase))
64-
(syntax-search expanded-stx
65-
#:literal-sets ([kernel-literals #:phase phase])
66-
67-
[(id:id _ ...)
68-
#:do [(define id-phase (syntax-property (attribute id) 'phase))]
69-
#:when (not (equal? id-phase phase))
70-
(loop this-syntax id-phase)]
71-
72-
[(quote-syntax _ ...) (stream)]
73-
74-
[(define-values (id ...) body)
75-
(stream-append (attribute id) (recur (attribute body)))]
76-
77-
[(define-syntaxes (id ...) body)
78-
(stream-append (attribute id) (loop (attribute body) (add1 phase)))]
79-
80-
[((~or let-values letrec-values) ([(id ...) rhs] ...) body ...)
81-
(define inner-exprs (append (attribute rhs) (attribute body)))
82-
(define ids (append* (attribute id)))
83-
(apply stream-append ids (map recur inner-exprs))]
84-
85-
[(#%plain-lambda formals body ...)
86-
(apply stream-append
87-
(syntax-search (attribute formals) [:id])
88-
(map recur (attribute body)))]
89-
90-
[(case-lambda [formals body ...] ...)
91-
(apply stream-append
92-
(syntax-search #'(formals ...) [:id])
93-
(map recur (append* (attribute body))))])))
94-
95-
9635
;; Find all identifier usage sites (not binding sites)
9736
(define (usage-site-identifiers expanded-stx)
9837
(let loop ([expanded-stx expanded-stx] [phase 0])
@@ -156,13 +95,8 @@
15695
(define (fully-expanded-syntax-binding-table stx)
15796
(define labeled-stx (syntax-label-id-phases (syntax-label-paths stx 'expanded-path)))
15897

159-
;; Create expanded-id-table to track bound identifiers with empty usage lists
160-
(define table (make-expanded-id-table))
161-
162-
;; Initialize all bound identifiers with empty usage lists
163-
(for ([id (in-stream (binding-site-identifiers labeled-stx))])
164-
(define id-phase (syntax-property id 'phase))
165-
(expanded-id-table-set! table (expanded-identifier id id-phase) '()))
98+
;; Create expanded-id-table with all bound identifiers initialized to empty usage lists
99+
(define table (fully-expanded-syntax-id-table labeled-stx))
166100

167101
;; For each usage, find its binding within the same phase and add it to the usage list
168102
(for ([used-id (in-stream (usage-site-identifiers labeled-stx))])

‎default-recommendations/analyzers/private/expanded-id-table.rkt‎

Lines changed: 111 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -15,18 +15,23 @@
1515
[in-expanded-id-table
1616
(-> expanded-id-table? (sequence/c (entry/c expanded-identifier? any/c)))]
1717
[in-expanded-id-table-phase
18-
(-> expanded-id-table? (or/c exact-nonnegative-integer? #false) (sequence/c (entry/c expanded-identifier? any/c)))]))
18+
(-> expanded-id-table? (or/c exact-nonnegative-integer? #false) (sequence/c (entry/c expanded-identifier? any/c)))]
19+
[syntax-label-id-phases (-> syntax? syntax?)]
20+
[fully-expanded-syntax-id-table (-> syntax? expanded-id-table?)]))
1921

2022

2123
(require guard
2224
racket/contract/base
2325
racket/dict
26+
racket/list
2427
racket/match
2528
racket/sequence
2629
racket/stream
2730
rebellion/base/result
2831
rebellion/collection/entry
29-
syntax/id-table)
32+
resyntax/private/syntax-traversal
33+
syntax/id-table
34+
syntax/parse)
3035

3136

3237
(module+ test
@@ -87,6 +92,79 @@
8792
;@----------------------------------------------------------------------------------------------------
8893

8994

95+
;; Label syntax with phase information
96+
(define (syntax-label-id-phases expanded-stx)
97+
(let loop ([expanded-stx expanded-stx] [phase 0] [skip? #false])
98+
(syntax-traverse expanded-stx
99+
#:skip-root? skip?
100+
#:literal-sets ([kernel-literals #:phase phase])
101+
102+
[:id (syntax-property this-syntax 'phase phase)]
103+
[(begin-for-syntax _ ...) (loop this-syntax (add1 phase) #true)]
104+
105+
[(define-syntaxes-id:define-syntaxes ids expr)
106+
(define new-define-syntaxes (loop (attribute define-syntaxes-id) phase #false))
107+
(define new-ids (loop (attribute ids) phase #true))
108+
(define new-expr (loop (attribute expr) (add1 phase) #false))
109+
(define new-datum (list new-define-syntaxes new-ids new-expr))
110+
(datum->syntax this-syntax new-datum this-syntax this-syntax)]
111+
112+
[((~or module module*) _ ...) (loop this-syntax 0 #true)]
113+
114+
#:parent-context-modifier (λ (stx) stx)
115+
#:parent-srcloc-modifier (λ (stx) stx)
116+
#:parent-props-modifier (λ (stx) stx))))
117+
118+
119+
;; Find all binding sites and return them as a stream of identifiers
120+
(define (binding-site-identifiers expanded-stx)
121+
(let loop ([expanded-stx expanded-stx] [phase 0])
122+
(define (recur stx)
123+
(loop stx phase))
124+
(syntax-search expanded-stx
125+
#:literal-sets ([kernel-literals #:phase phase])
126+
127+
[(id:id _ ...)
128+
#:do [(define id-phase (syntax-property (attribute id) 'phase))]
129+
#:when (not (equal? id-phase phase))
130+
(loop this-syntax id-phase)]
131+
132+
[(quote-syntax _ ...) (stream)]
133+
134+
[(define-values (id ...) body)
135+
(stream-append (attribute id) (recur (attribute body)))]
136+
137+
[(define-syntaxes (id ...) body)
138+
(stream-append (attribute id) (loop (attribute body) (add1 phase)))]
139+
140+
[((~or let-values letrec-values) ([(id ...) rhs] ...) body ...)
141+
(define inner-exprs (append (attribute rhs) (attribute body)))
142+
(define ids (append* (attribute id)))
143+
(apply stream-append ids (map recur inner-exprs))]
144+
145+
[(#%plain-lambda formals body ...)
146+
(apply stream-append
147+
(syntax-search (attribute formals) [:id])
148+
(map recur (attribute body)))]
149+
150+
[(case-lambda [formals body ...] ...)
151+
(apply stream-append
152+
(syntax-search #'(formals ...) [:id])
153+
(map recur (append* (attribute body))))])))
154+
155+
156+
(define (fully-expanded-syntax-id-table stx)
157+
;; stx is expected to already have phase labels via syntax-label-id-phases
158+
(define table (make-expanded-id-table))
159+
(for ([id (in-stream (binding-site-identifiers stx))])
160+
(define id-phase (syntax-property id 'phase))
161+
(expanded-id-table-set! table (expanded-identifier id id-phase) '()))
162+
table)
163+
164+
165+
;@----------------------------------------------------------------------------------------------------
166+
167+
90168
(module+ test
91169
(test-case "expanded-id-table"
92170

@@ -118,4 +196,34 @@
118196
(expanded-id-table-set! table id2 'val2)
119197
(expanded-id-table-set! table id3 'val3)
120198
(define entries (for/list ([e (in-expanded-id-table table)]) e))
121-
(check-equal? (length entries) 3))))
199+
(check-equal? (length entries) 3)))
200+
201+
(test-case "fully-expanded-syntax-id-table"
202+
203+
(test-case "creates table with binding sites from expanded module"
204+
(define stx #'(module test racket/base (define x 1) (define y 2)))
205+
(define expanded-stx (expand stx))
206+
(define labeled-stx (syntax-label-id-phases expanded-stx))
207+
(define table (fully-expanded-syntax-id-table labeled-stx))
208+
(check-pred expanded-id-table? table)
209+
;; The table should contain bindings
210+
(define entries (for/list ([e (in-expanded-id-table table)]) e))
211+
(check > (length entries) 0))
212+
213+
(test-case "creates table with phase 0 bindings"
214+
(define stx #'(module test racket/base (define a 1)))
215+
(define expanded-stx (expand stx))
216+
(define labeled-stx (syntax-label-id-phases expanded-stx))
217+
(define table (fully-expanded-syntax-id-table labeled-stx))
218+
(define phase0-entries (for/list ([e (in-expanded-id-table-phase table 0)]) e))
219+
(check > (length phase0-entries) 0))
220+
221+
(test-case "creates table with phase 1 bindings"
222+
(define stx #'(module test racket/base
223+
(require (for-syntax racket/base))
224+
(begin-for-syntax (define a 1))))
225+
(define expanded-stx (expand stx))
226+
(define labeled-stx (syntax-label-id-phases expanded-stx))
227+
(define table (fully-expanded-syntax-id-table labeled-stx))
228+
(define phase1-entries (for/list ([e (in-expanded-id-table-phase table 1)]) e))
229+
(check > (length phase1-entries) 0))))

‎default-recommendations/analyzers/variable-mutability.rkt‎

Lines changed: 10 additions & 63 deletions
Original file line numberDiff line numberDiff line change
@@ -31,65 +31,6 @@
3131
;@----------------------------------------------------------------------------------------------------
3232

3333

34-
(define (syntax-label-id-phases expanded-stx)
35-
(let loop ([expanded-stx expanded-stx] [phase 0] [skip? #false])
36-
(syntax-traverse expanded-stx
37-
#:skip-root? skip?
38-
#:literal-sets ([kernel-literals #:phase phase])
39-
40-
[:id (syntax-property this-syntax 'phase phase)]
41-
[(begin-for-syntax _ ...) (loop this-syntax (add1 phase) #true)]
42-
43-
[(define-syntaxes-id:define-syntaxes ids expr)
44-
(define new-define-syntaxes (loop (attribute define-syntaxes-id) phase #false))
45-
(define new-ids (loop (attribute ids) phase #true))
46-
(define new-expr (loop (attribute expr) (add1 phase) #false))
47-
(define new-datum (list new-define-syntaxes new-ids new-expr))
48-
(datum->syntax this-syntax new-datum this-syntax this-syntax)]
49-
50-
[((~or module module*) _ ...) (loop this-syntax 0 #true)]
51-
52-
#:parent-context-modifier (λ (stx) stx)
53-
#:parent-srcloc-modifier (λ (stx) stx)
54-
#:parent-props-modifier (λ (stx) stx))))
55-
56-
57-
(define (binding-site-variables expanded-stx)
58-
(let loop ([expanded-stx expanded-stx] [phase 0])
59-
(define (recur stx)
60-
(loop stx phase))
61-
(syntax-search expanded-stx
62-
#:literal-sets ([kernel-literals #:phase phase])
63-
64-
[(id:id _ ...)
65-
#:do [(define id-phase (syntax-property (attribute id) 'phase))]
66-
#:when (not (equal? id-phase phase))
67-
(loop this-syntax id-phase)]
68-
69-
[(quote-syntax _ ...) (stream)]
70-
71-
[(define-values (id ...) body)
72-
(stream-append (attribute id) (recur (attribute body)))]
73-
74-
[(define-syntaxes (id ...) body)
75-
(stream-append (attribute id) (loop (attribute body) (add1 phase)))]
76-
77-
[((~or let-values letrec-values) ([(id ...) rhs] ...) body ...)
78-
(define inner-exprs (append (attribute rhs) (attribute body)))
79-
(define ids (append* (attribute id)))
80-
(apply stream-append ids (map recur inner-exprs))]
81-
82-
[(#%plain-lambda formals body ...)
83-
(apply stream-append
84-
(syntax-search (attribute formals) [:id])
85-
(map recur (attribute body)))]
86-
87-
[(case-lambda [formals body ...] ...)
88-
(apply stream-append
89-
(syntax-search #'(formals ...) [:id])
90-
(map recur (append* (attribute body))))])))
91-
92-
9334
(define (mutated-variables expanded-stx)
9435
(let loop ([expanded-stx expanded-stx] [phase 0])
9536
(syntax-search expanded-stx
@@ -105,13 +46,19 @@
10546

10647
(define (variable-mutability stx)
10748
(define labeled-stx (syntax-label-id-phases (syntax-label-paths stx 'expanded-path)))
108-
(define variable-table (make-expanded-id-table))
109-
(for ([id (in-stream (binding-site-variables labeled-stx))])
110-
(define phase (syntax-property id 'phase))
111-
(expanded-id-table-set! variable-table (expanded-identifier id phase) 'immutable))
49+
50+
;; Create table with all bound identifiers initialized to 'immutable
51+
(define variable-table (fully-expanded-syntax-id-table labeled-stx))
52+
53+
;; Initialize all entries with 'immutable
54+
(for ([entry (in-expanded-id-table variable-table)])
55+
(expanded-id-table-set! variable-table (entry-key entry) 'immutable))
56+
57+
;; Mark mutated variables as 'mutable
11258
(for ([id (in-stream (mutated-variables labeled-stx))])
11359
(define phase (syntax-property id 'phase))
11460
(expanded-id-table-set! variable-table (expanded-identifier id phase) 'mutable))
61+
11562
(transduce (in-expanded-id-table variable-table)
11663
(mapping
11764
(λ (e)

0 commit comments

Comments
 (0)