]>
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 | ||
26 | with 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 | ||
58 | ww : Node_Id'Base := Node_Id'First - 1; | |
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); | |
75 | -- For debugging. If debugging is turned on, New_Node and New_Entity call | |
76 | -- this. If debug flag N is turned on, this prints out the new node. | |
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 | ||
76f9c7f4 BD |
140 | ------------------------- |
141 | -- Iterator Procedures -- | |
142 | ------------------------- | |
143 | ||
144 | procedure Next_Entity (N : in out Node_Id) is | |
145 | begin | |
146 | N := Next_Entity (N); | |
147 | end Next_Entity; | |
148 | ||
149 | procedure Next_Named_Actual (N : in out Node_Id) is | |
150 | begin | |
151 | N := Next_Named_Actual (N); | |
152 | end Next_Named_Actual; | |
153 | ||
154 | procedure Next_Rep_Item (N : in out Node_Id) is | |
155 | begin | |
156 | N := Next_Rep_Item (N); | |
157 | end Next_Rep_Item; | |
158 | ||
159 | procedure Next_Use_Clause (N : in out Node_Id) is | |
160 | begin | |
161 | N := Next_Use_Clause (N); | |
162 | end Next_Use_Clause; | |
163 | ||
164 | ------------------ | |
165 | -- End_Location -- | |
166 | ------------------ | |
167 | ||
168 | function End_Location (N : Node_Id) return Source_Ptr is | |
169 | L : constant Uint := End_Span (N); | |
170 | begin | |
171 | if L = No_Uint then | |
172 | return No_Location; | |
173 | else | |
174 | return Source_Ptr (Int (Sloc (N)) + UI_To_Int (L)); | |
175 | end if; | |
176 | end End_Location; | |
177 | ||
178 | -------------------- | |
179 | -- Get_Pragma_Arg -- | |
180 | -------------------- | |
181 | ||
182 | function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is | |
183 | begin | |
184 | if Nkind (Arg) = N_Pragma_Argument_Association then | |
185 | return Expression (Arg); | |
186 | else | |
187 | return Arg; | |
188 | end if; | |
189 | end Get_Pragma_Arg; | |
190 | ||
191 | ---------------------- | |
192 | -- Set_End_Location -- | |
193 | ---------------------- | |
194 | ||
195 | procedure Set_End_Location (N : Node_Id; S : Source_Ptr) is | |
196 | begin | |
197 | Set_End_Span (N, | |
198 | UI_From_Int (Int (S) - Int (Sloc (N)))); | |
199 | end Set_End_Location; | |
200 | ||
201 | -------------------------- | |
202 | -- Pragma_Name_Unmapped -- | |
203 | -------------------------- | |
204 | ||
205 | function Pragma_Name_Unmapped (N : Node_Id) return Name_Id is | |
206 | begin | |
207 | return Chars (Pragma_Identifier (N)); | |
208 | end Pragma_Name_Unmapped; | |
209 | ||
210 | ------------------------------------ | |
211 | -- Helpers for Walk_Sinfo_Fields* -- | |
212 | ------------------------------------ | |
213 | ||
214 | function Get_Node_Field_Union is new | |
215 | Atree.Atree_Private_Part.Get_32_Bit_Field (Union_Id) with Inline; | |
216 | procedure Set_Node_Field_Union is new | |
217 | Atree.Atree_Private_Part.Set_32_Bit_Field (Union_Id) with Inline; | |
218 | ||
219 | use Seinfo; | |
220 | ||
221 | function Is_In_Union_Id (F_Kind : Field_Kind) return Boolean is | |
222 | (F_Kind in Node_Id_Field | |
223 | | List_Id_Field | |
224 | | Elist_Id_Field | |
225 | | Name_Id_Field | |
226 | | String_Id_Field | |
227 | | Uint_Field | |
228 | | Ureal_Field | |
229 | | Union_Id_Field); | |
230 | -- True if the field type is one that can be converted to Types.Union_Id | |
231 | ||
232 | ----------------------- | |
233 | -- Walk_Sinfo_Fields -- | |
234 | ----------------------- | |
235 | ||
236 | procedure Walk_Sinfo_Fields (N : Node_Id) is | |
237 | Fields : Node_Field_Array renames | |
238 | Node_Field_Table (Nkind (N)).all; | |
239 | ||
240 | begin | |
241 | for J in Fields'Range loop | |
f54fb769 | 242 | if Fields (J) /= F_Link then -- Don't walk Parent! |
76f9c7f4 BD |
243 | declare |
244 | Desc : Field_Descriptor renames | |
245 | Node_Field_Descriptors (Fields (J)); | |
246 | begin | |
247 | if Is_In_Union_Id (Desc.Kind) then | |
248 | Action (Get_Node_Field_Union (N, Desc.Offset)); | |
249 | end if; | |
250 | end; | |
251 | end if; | |
252 | end loop; | |
253 | end Walk_Sinfo_Fields; | |
254 | ||
255 | -------------------------------- | |
256 | -- Walk_Sinfo_Fields_Pairwise -- | |
257 | -------------------------------- | |
258 | ||
259 | procedure Walk_Sinfo_Fields_Pairwise (N1, N2 : Node_Id) is | |
260 | pragma Assert (Nkind (N1) = Nkind (N2)); | |
261 | ||
262 | Fields : Node_Field_Array renames | |
263 | Node_Field_Table (Nkind (N1)).all; | |
264 | ||
265 | begin | |
266 | for J in Fields'Range loop | |
f54fb769 | 267 | if Fields (J) /= F_Link then -- Don't walk Parent! |
76f9c7f4 BD |
268 | declare |
269 | Desc : Field_Descriptor renames | |
270 | Node_Field_Descriptors (Fields (J)); | |
271 | begin | |
272 | if Is_In_Union_Id (Desc.Kind) then | |
273 | Set_Node_Field_Union | |
274 | (N1, Desc.Offset, | |
275 | Transform (Get_Node_Field_Union (N2, Desc.Offset))); | |
276 | end if; | |
277 | end; | |
278 | end if; | |
279 | end loop; | |
280 | end Walk_Sinfo_Fields_Pairwise; | |
281 | ||
282 | --------------------- | |
283 | -- Map_Pragma_Name -- | |
284 | --------------------- | |
285 | ||
286 | -- We don't want to introduce a dependence on some hash table package or | |
287 | -- similar, so we use a simple array of Key => Value pairs, and do a linear | |
288 | -- search. Linear search is plenty efficient, given that we don't expect | |
289 | -- more than a couple of entries in the mapping. | |
290 | ||
291 | type Name_Pair is record | |
292 | Key : Name_Id; | |
293 | Value : Name_Id; | |
294 | end record; | |
295 | ||
296 | type Pragma_Map_Index is range 1 .. 100; | |
297 | Pragma_Map : array (Pragma_Map_Index) of Name_Pair; | |
298 | Last_Pair : Pragma_Map_Index'Base range 0 .. Pragma_Map_Index'Last := 0; | |
299 | ||
300 | procedure Map_Pragma_Name (From, To : Name_Id) is | |
301 | begin | |
302 | if Last_Pair = Pragma_Map'Last then | |
303 | raise Too_Many_Pragma_Mappings; | |
304 | end if; | |
305 | ||
306 | Last_Pair := Last_Pair + 1; | |
307 | Pragma_Map (Last_Pair) := (Key => From, Value => To); | |
308 | end Map_Pragma_Name; | |
309 | ||
310 | ----------------- | |
311 | -- Pragma_Name -- | |
312 | ----------------- | |
313 | ||
314 | function Pragma_Name (N : Node_Id) return Name_Id is | |
315 | Result : constant Name_Id := Pragma_Name_Unmapped (N); | |
316 | begin | |
317 | for J in Pragma_Map'First .. Last_Pair loop | |
318 | if Result = Pragma_Map (J).Key then | |
319 | return Pragma_Map (J).Value; | |
320 | end if; | |
321 | end loop; | |
322 | ||
323 | return Result; | |
324 | end Pragma_Name; | |
325 | ||
326 | end Sinfo.Utils; |