]>
Commit | Line | Data |
---|---|---|
76f9c7f4 BD |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S I N F O . U T I L S -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
9 | -- Copyright (C) 2020-2021, Free Software Foundation, Inc. -- | |
10 | -- -- | |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- | |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
17 | -- for more details. You should have received a copy of the GNU General -- | |
18 | -- Public License distributed with GNAT; see file COPYING3. If not, go to -- | |
19 | -- http://www.gnu.org/licenses for a complete copy of the license. -- | |
20 | -- -- | |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- | |
23 | -- -- | |
24 | ------------------------------------------------------------------------------ | |
25 | ||
3f561db7 | 26 | with Atree; use Atree; |
1e4b06a8 BD |
27 | with Debug; use Debug; |
28 | with Output; use Output; | |
76f9c7f4 | 29 | with Seinfo; |
1e4b06a8 | 30 | with Sinput; use Sinput; |
76f9c7f4 BD |
31 | |
32 | package body Sinfo.Utils is | |
33 | ||
1e4b06a8 BD |
34 | --------------- |
35 | -- Debugging -- | |
36 | --------------- | |
37 | ||
38 | -- Suppose you find that node 12345 is messed up. You might want to find | |
39 | -- the code that created that node. There are two ways to do this: | |
40 | ||
41 | -- One way is to set a conditional breakpoint on New_Node_Debugging_Output | |
42 | -- (nickname "nnd"): | |
43 | -- break nnd if n = 12345 | |
44 | -- and run gnat1 again from the beginning. | |
45 | ||
46 | -- The other way is to set a breakpoint near the beginning (e.g. on | |
47 | -- gnat1drv), and run. Then set Watch_Node (nickname "ww") to 12345 in gdb: | |
48 | -- ww := 12345 | |
49 | -- and set a breakpoint on New_Node_Breakpoint (nickname "nn"). Continue. | |
50 | ||
51 | -- Either way, gnat1 will stop when node 12345 is created, or certain other | |
52 | -- interesting operations are performed, such as Rewrite. To see exactly | |
53 | -- which operations, search for "pragma Debug" below. | |
54 | ||
55 | -- The second method is much faster if the amount of Ada code being | |
56 | -- compiled is large. | |
57 | ||
99e30ba8 | 58 | ww : Node_Id'Base := Node_Low_Bound - 1; |
1e4b06a8 BD |
59 | pragma Export (Ada, ww); |
60 | Watch_Node : Node_Id'Base renames ww; | |
61 | -- Node to "watch"; that is, whenever a node is created, we check if it | |
62 | -- is equal to Watch_Node, and if so, call New_Node_Breakpoint. You have | |
63 | -- presumably set a breakpoint on New_Node_Breakpoint. Note that the | |
64 | -- initial value of Node_Id'First - 1 ensures that by default, no node | |
65 | -- will be equal to Watch_Node. | |
66 | ||
67 | procedure nn; | |
68 | pragma Export (Ada, nn); | |
69 | procedure New_Node_Breakpoint renames nn; | |
70 | -- This doesn't do anything interesting; it's just for setting breakpoint | |
71 | -- on as explained above. | |
72 | ||
73 | procedure nnd (N : Node_Id); | |
74 | pragma Export (Ada, nnd); | |
99e30ba8 BD |
75 | -- For debugging. If debugging is turned on, New_Node and New_Entity (etc.) |
76 | -- call this. If debug flag N is turned on, this prints out the new node. | |
1e4b06a8 BD |
77 | -- |
78 | -- If Node = Watch_Node, this prints out the new node and calls | |
79 | -- New_Node_Breakpoint. Otherwise, does nothing. | |
80 | ||
81 | procedure Node_Debug_Output (Op : String; N : Node_Id); | |
82 | -- Called by nnd; writes Op followed by information about N | |
83 | ||
84 | ------------------------- | |
85 | -- New_Node_Breakpoint -- | |
86 | ------------------------- | |
87 | ||
88 | procedure nn is | |
89 | begin | |
90 | Write_Str ("Watched node "); | |
91 | Write_Int (Int (Watch_Node)); | |
92 | Write_Eol; | |
93 | end nn; | |
94 | ||
95 | ------------------------------- | |
96 | -- New_Node_Debugging_Output -- | |
97 | ------------------------------- | |
98 | ||
99 | procedure nnd (N : Node_Id) is | |
100 | Node_Is_Watched : constant Boolean := N = Watch_Node; | |
101 | ||
102 | begin | |
103 | if Debug_Flag_N or else Node_Is_Watched then | |
104 | Node_Debug_Output ("Node", N); | |
105 | ||
106 | if Node_Is_Watched then | |
107 | New_Node_Breakpoint; | |
108 | end if; | |
109 | end if; | |
110 | end nnd; | |
111 | ||
112 | procedure New_Node_Debugging_Output (N : Node_Id) is | |
113 | begin | |
114 | pragma Debug (nnd (N)); | |
115 | end New_Node_Debugging_Output; | |
116 | ||
117 | ----------------------- | |
118 | -- Node_Debug_Output -- | |
119 | ----------------------- | |
120 | ||
121 | procedure Node_Debug_Output (Op : String; N : Node_Id) is | |
122 | begin | |
123 | Write_Str (Op); | |
124 | ||
125 | if Nkind (N) in N_Entity then | |
126 | Write_Str (" entity"); | |
127 | else | |
128 | Write_Str (" node"); | |
129 | end if; | |
130 | ||
131 | Write_Str (" Id = "); | |
132 | Write_Int (Int (N)); | |
133 | Write_Str (" "); | |
134 | Write_Location (Sloc (N)); | |
135 | Write_Str (" "); | |
136 | Write_Str (Node_Kind'Image (Nkind (N))); | |
137 | Write_Eol; | |
138 | end Node_Debug_Output; | |
139 | ||
898edf75 BD |
140 | ------------------------------- |
141 | -- Parent-related operations -- | |
142 | ------------------------------- | |
143 | ||
144 | procedure Copy_Parent (To, From : Node_Or_Entity_Id) is | |
145 | begin | |
146 | if Atree.Present (To) and Atree.Present (From) then | |
147 | Atree.Set_Parent (To, Atree.Parent (From)); | |
148 | else | |
149 | pragma Assert | |
150 | (if Atree.Present (To) then Atree.No (Atree.Parent (To))); | |
151 | end if; | |
152 | end Copy_Parent; | |
153 | ||
154 | function Parent_Kind (N : Node_Id) return Node_Kind is | |
155 | begin | |
156 | if Atree.No (N) then | |
157 | return N_Empty; | |
158 | else | |
159 | return Nkind (Atree.Parent (N)); | |
160 | end if; | |
161 | end Parent_Kind; | |
162 | ||
76f9c7f4 BD |
163 | ------------------------- |
164 | -- Iterator Procedures -- | |
165 | ------------------------- | |
166 | ||
167 | procedure Next_Entity (N : in out Node_Id) is | |
168 | begin | |
169 | N := Next_Entity (N); | |
170 | end Next_Entity; | |
171 | ||
172 | procedure Next_Named_Actual (N : in out Node_Id) is | |
173 | begin | |
174 | N := Next_Named_Actual (N); | |
175 | end Next_Named_Actual; | |
176 | ||
177 | procedure Next_Rep_Item (N : in out Node_Id) is | |
178 | begin | |
179 | N := Next_Rep_Item (N); | |
180 | end Next_Rep_Item; | |
181 | ||
182 | procedure Next_Use_Clause (N : in out Node_Id) is | |
183 | begin | |
184 | N := Next_Use_Clause (N); | |
185 | end Next_Use_Clause; | |
186 | ||
187 | ------------------ | |
188 | -- End_Location -- | |
189 | ------------------ | |
190 | ||
191 | function End_Location (N : Node_Id) return Source_Ptr is | |
42b39995 | 192 | L : constant Valid_Uint := End_Span (N); |
76f9c7f4 | 193 | begin |
42b39995 | 194 | return Source_Ptr (Int (Sloc (N)) + UI_To_Int (L)); |
76f9c7f4 BD |
195 | end End_Location; |
196 | ||
197 | -------------------- | |
198 | -- Get_Pragma_Arg -- | |
199 | -------------------- | |
200 | ||
201 | function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is | |
202 | begin | |
203 | if Nkind (Arg) = N_Pragma_Argument_Association then | |
204 | return Expression (Arg); | |
205 | else | |
206 | return Arg; | |
207 | end if; | |
208 | end Get_Pragma_Arg; | |
209 | ||
210 | ---------------------- | |
211 | -- Set_End_Location -- | |
212 | ---------------------- | |
213 | ||
214 | procedure Set_End_Location (N : Node_Id; S : Source_Ptr) is | |
215 | begin | |
216 | Set_End_Span (N, | |
217 | UI_From_Int (Int (S) - Int (Sloc (N)))); | |
218 | end Set_End_Location; | |
219 | ||
220 | -------------------------- | |
221 | -- Pragma_Name_Unmapped -- | |
222 | -------------------------- | |
223 | ||
224 | function Pragma_Name_Unmapped (N : Node_Id) return Name_Id is | |
225 | begin | |
226 | return Chars (Pragma_Identifier (N)); | |
227 | end Pragma_Name_Unmapped; | |
228 | ||
229 | ------------------------------------ | |
230 | -- Helpers for Walk_Sinfo_Fields* -- | |
231 | ------------------------------------ | |
232 | ||
233 | function Get_Node_Field_Union is new | |
234 | Atree.Atree_Private_Part.Get_32_Bit_Field (Union_Id) with Inline; | |
235 | procedure Set_Node_Field_Union is new | |
236 | Atree.Atree_Private_Part.Set_32_Bit_Field (Union_Id) with Inline; | |
237 | ||
238 | use Seinfo; | |
239 | ||
240 | function Is_In_Union_Id (F_Kind : Field_Kind) return Boolean is | |
76f9c7f4 | 241 | -- True if the field type is one that can be converted to Types.Union_Id |
36e38022 BD |
242 | (case F_Kind is |
243 | when Node_Id_Field | |
244 | | List_Id_Field | |
245 | | Elist_Id_Field | |
246 | | Name_Id_Field | |
247 | | String_Id_Field | |
248 | | Valid_Uint_Field | |
249 | | Unat_Field | |
250 | | Upos_Field | |
251 | | Nonzero_Uint_Field | |
252 | | Uint_Field | |
253 | | Ureal_Field | |
254 | | Union_Id_Field => True, | |
255 | when Flag_Field | |
256 | | Node_Kind_Type_Field | |
257 | | Entity_Kind_Type_Field | |
258 | | Source_Ptr_Field | |
259 | | Small_Paren_Count_Type_Field | |
260 | | Convention_Id_Field | |
261 | | Component_Alignment_Kind_Field | |
262 | | Mechanism_Type_Field => False); | |
76f9c7f4 BD |
263 | |
264 | ----------------------- | |
265 | -- Walk_Sinfo_Fields -- | |
266 | ----------------------- | |
267 | ||
268 | procedure Walk_Sinfo_Fields (N : Node_Id) is | |
269 | Fields : Node_Field_Array renames | |
270 | Node_Field_Table (Nkind (N)).all; | |
271 | ||
272 | begin | |
273 | for J in Fields'Range loop | |
f54fb769 | 274 | if Fields (J) /= F_Link then -- Don't walk Parent! |
76f9c7f4 BD |
275 | declare |
276 | Desc : Field_Descriptor renames | |
99e30ba8 | 277 | Field_Descriptors (Fields (J)); |
034c3117 BD |
278 | pragma Assert (Desc.Type_Only = No_Type_Only); |
279 | -- Type_Only is for entities | |
76f9c7f4 BD |
280 | begin |
281 | if Is_In_Union_Id (Desc.Kind) then | |
282 | Action (Get_Node_Field_Union (N, Desc.Offset)); | |
283 | end if; | |
284 | end; | |
285 | end if; | |
286 | end loop; | |
287 | end Walk_Sinfo_Fields; | |
288 | ||
289 | -------------------------------- | |
290 | -- Walk_Sinfo_Fields_Pairwise -- | |
291 | -------------------------------- | |
292 | ||
293 | procedure Walk_Sinfo_Fields_Pairwise (N1, N2 : Node_Id) is | |
294 | pragma Assert (Nkind (N1) = Nkind (N2)); | |
295 | ||
296 | Fields : Node_Field_Array renames | |
297 | Node_Field_Table (Nkind (N1)).all; | |
298 | ||
299 | begin | |
300 | for J in Fields'Range loop | |
f54fb769 | 301 | if Fields (J) /= F_Link then -- Don't walk Parent! |
76f9c7f4 BD |
302 | declare |
303 | Desc : Field_Descriptor renames | |
99e30ba8 | 304 | Field_Descriptors (Fields (J)); |
034c3117 BD |
305 | pragma Assert (Desc.Type_Only = No_Type_Only); |
306 | -- Type_Only is for entities | |
76f9c7f4 BD |
307 | begin |
308 | if Is_In_Union_Id (Desc.Kind) then | |
309 | Set_Node_Field_Union | |
310 | (N1, Desc.Offset, | |
311 | Transform (Get_Node_Field_Union (N2, Desc.Offset))); | |
312 | end if; | |
313 | end; | |
314 | end if; | |
315 | end loop; | |
316 | end Walk_Sinfo_Fields_Pairwise; | |
317 | ||
318 | --------------------- | |
319 | -- Map_Pragma_Name -- | |
320 | --------------------- | |
321 | ||
322 | -- We don't want to introduce a dependence on some hash table package or | |
323 | -- similar, so we use a simple array of Key => Value pairs, and do a linear | |
324 | -- search. Linear search is plenty efficient, given that we don't expect | |
325 | -- more than a couple of entries in the mapping. | |
326 | ||
327 | type Name_Pair is record | |
328 | Key : Name_Id; | |
329 | Value : Name_Id; | |
330 | end record; | |
331 | ||
332 | type Pragma_Map_Index is range 1 .. 100; | |
333 | Pragma_Map : array (Pragma_Map_Index) of Name_Pair; | |
334 | Last_Pair : Pragma_Map_Index'Base range 0 .. Pragma_Map_Index'Last := 0; | |
335 | ||
336 | procedure Map_Pragma_Name (From, To : Name_Id) is | |
337 | begin | |
338 | if Last_Pair = Pragma_Map'Last then | |
339 | raise Too_Many_Pragma_Mappings; | |
340 | end if; | |
341 | ||
342 | Last_Pair := Last_Pair + 1; | |
343 | Pragma_Map (Last_Pair) := (Key => From, Value => To); | |
344 | end Map_Pragma_Name; | |
345 | ||
346 | ----------------- | |
347 | -- Pragma_Name -- | |
348 | ----------------- | |
349 | ||
350 | function Pragma_Name (N : Node_Id) return Name_Id is | |
351 | Result : constant Name_Id := Pragma_Name_Unmapped (N); | |
352 | begin | |
353 | for J in Pragma_Map'First .. Last_Pair loop | |
354 | if Result = Pragma_Map (J).Key then | |
355 | return Pragma_Map (J).Value; | |
356 | end if; | |
357 | end loop; | |
358 | ||
359 | return Result; | |
360 | end Pragma_Name; | |
361 | ||
362 | end Sinfo.Utils; |