Skip to content

Commit 8b3da66

Browse files
Copilotjackfirth
Copilot
and
jackfirth
authored
Refactor analyzers to reuse expansion table code (#739)
Co-authored-by: copilot-swe-agent[bot] <[email protected]> Co-authored-by: jackfirth <[email protected]>
1 parent 1147699 commit 8b3da66

File tree

3 files changed

+124
-131
lines changed

3 files changed

+124
-131
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: 116 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -15,18 +15,24 @@
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+
[binding-site-identifiers (-> syntax? stream?)]
21+
[fully-expanded-syntax-id-table (-> syntax? expanded-id-table?)]))
1922

2023

2124
(require guard
2225
racket/contract/base
2326
racket/dict
27+
racket/list
2428
racket/match
2529
racket/sequence
2630
racket/stream
2731
rebellion/base/result
2832
rebellion/collection/entry
29-
syntax/id-table)
33+
resyntax/private/syntax-traversal
34+
syntax/id-table
35+
syntax/parse)
3036

3137

3238
(module+ test
@@ -87,6 +93,83 @@
8793
;@----------------------------------------------------------------------------------------------------
8894

8995

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

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

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

Lines changed: 6 additions & 60 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,18 @@
10546

10647
(define (variable-mutability stx)
10748
(define labeled-stx (syntax-label-id-phases (syntax-label-paths stx 'expanded-path)))
49+
50+
;; Create table and initialize all bound identifiers with 'immutable
10851
(define variable-table (make-expanded-id-table))
109-
(for ([id (in-stream (binding-site-variables labeled-stx))])
52+
(for ([id (in-stream (binding-site-identifiers labeled-stx))])
11053
(define phase (syntax-property id 'phase))
11154
(expanded-id-table-set! variable-table (expanded-identifier id phase) 'immutable))
55+
56+
;; Mark mutated variables as 'mutable
11257
(for ([id (in-stream (mutated-variables labeled-stx))])
11358
(define phase (syntax-property id 'phase))
11459
(expanded-id-table-set! variable-table (expanded-identifier id phase) 'mutable))
60+
11561
(transduce (in-expanded-id-table variable-table)
11662
(mapping
11763
(λ (e)

0 commit comments

Comments
 (0)