1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S I N F O . U T I L S --
9 -- Copyright (C) 2020-2023, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Debug
; use Debug
;
28 with Output
; use Output
;
30 with Sinput
; use Sinput
;
32 package body Sinfo
.Utils
is
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:
41 -- One way is to set a conditional breakpoint on New_Node_Debugging_Output
43 -- break nnd if n = 12345
44 -- and run gnat1 again from the beginning.
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:
49 -- and set a breakpoint on New_Node_Breakpoint (nickname "nn"). Continue.
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 "New_Node_Debugging_Output" in Atree.
55 -- The second method is much faster if the amount of Ada code being
58 ww
: Node_Id
'Base := Node_Low_Bound
- 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.
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.
73 procedure nnd
(N
: Node_Id
);
74 pragma Export
(Ada
, nnd
);
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.
78 -- If Node = Watch_Node, this prints out the new node and calls
79 -- New_Node_Breakpoint. Otherwise, does nothing.
81 procedure Node_Debug_Output
(Op
: String; N
: Node_Id
);
82 -- Called by nnd; writes Op followed by information about N
84 -------------------------
85 -- New_Node_Breakpoint --
86 -------------------------
90 Write_Str
("Watched node ");
91 Write_Int
(Int
(Watch_Node
));
95 -------------------------------
96 -- New_Node_Debugging_Output --
97 -------------------------------
99 procedure nnd
(N
: Node_Id
) is
100 Node_Is_Watched
: constant Boolean := N
= Watch_Node
;
103 if Debug_Flag_N
or else Node_Is_Watched
then
104 Node_Debug_Output
("Node", N
);
106 if Node_Is_Watched
then
112 procedure New_Node_Debugging_Output
(N
: Node_Id
) is
114 pragma Debug
(nnd
(N
));
115 end New_Node_Debugging_Output
;
117 -----------------------
118 -- Node_Debug_Output --
119 -----------------------
121 procedure Node_Debug_Output
(Op
: String; N
: Node_Id
) is
125 if Nkind
(N
) in N_Entity
then
126 Write_Str
(" entity");
131 Write_Str
(" Id = ");
134 Write_Location
(Sloc
(N
));
136 Write_Str
(Node_Kind
'Image (Nkind
(N
)));
138 end Node_Debug_Output
;
140 -------------------------------
141 -- Parent-related operations --
142 -------------------------------
144 procedure Copy_Parent
(To
, From
: Node_Or_Entity_Id
) is
146 if Atree
.Present
(To
) and Atree
.Present
(From
) then
147 Atree
.Set_Parent
(To
, Atree
.Parent
(From
));
150 (if Atree
.Present
(To
) then Atree
.No
(Atree
.Parent
(To
)));
154 function Parent_Kind
(N
: Node_Id
) return Node_Kind
is
159 return Nkind
(Atree
.Parent
(N
));
163 -------------------------
164 -- Iterator Procedures --
165 -------------------------
167 procedure Next_Entity
(N
: in out Node_Id
) is
169 N
:= Next_Entity
(N
);
172 procedure Next_Named_Actual
(N
: in out Node_Id
) is
174 N
:= Next_Named_Actual
(N
);
175 end Next_Named_Actual
;
177 procedure Next_Rep_Item
(N
: in out Node_Id
) is
179 N
:= Next_Rep_Item
(N
);
182 procedure Next_Use_Clause
(N
: in out Node_Id
) is
184 N
:= Next_Use_Clause
(N
);
191 function End_Location
(N
: Node_Id
) return Source_Ptr
is
192 L
: constant Valid_Uint
:= End_Span
(N
);
194 return Sloc
(N
) + Source_Ptr
(UI_To_Int
(L
));
201 function Get_Pragma_Arg
(Arg
: Node_Id
) return Node_Id
is
203 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
204 return Expression
(Arg
);
210 ----------------------
211 -- Set_End_Location --
212 ----------------------
214 procedure Set_End_Location
(N
: Node_Id
; S
: Source_Ptr
) is
217 UI_From_Int
(Int
(S
- Sloc
(N
))));
218 end Set_End_Location
;
220 --------------------------
221 -- Pragma_Name_Unmapped --
222 --------------------------
224 function Pragma_Name_Unmapped
(N
: Node_Id
) return Name_Id
is
226 return Chars
(Pragma_Identifier
(N
));
227 end Pragma_Name_Unmapped
;
229 ------------------------------------
230 -- Helpers for Walk_Sinfo_Fields* --
231 ------------------------------------
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
;
240 function Is_In_Union_Id
(F_Kind
: Field_Kind
) return Boolean is
241 -- True if the field type is one that can be converted to Types.Union_Id
254 | Union_Id_Field
=> True,
256 | Node_Kind_Type_Field
257 | Entity_Kind_Type_Field
259 | Small_Paren_Count_Type_Field
260 | Convention_Id_Field
261 | Component_Alignment_Kind_Field
262 | Mechanism_Type_Field
=> False);
264 -----------------------
265 -- Walk_Sinfo_Fields --
266 -----------------------
268 procedure Walk_Sinfo_Fields
(N
: Node_Id
) is
269 Fields
: Node_Field_Array
renames
270 Node_Field_Table
(Nkind
(N
)).all;
273 for J
in Fields
'Range loop
274 if Fields
(J
) /= F_Link
then -- Don't walk Parent!
276 Desc
: Field_Descriptor
renames
277 Field_Descriptors
(Fields
(J
));
278 pragma Assert
(Desc
.Type_Only
= No_Type_Only
);
279 -- Type_Only is for entities
281 if Is_In_Union_Id
(Desc
.Kind
) then
282 Action
(Get_Node_Field_Union
(N
, Desc
.Offset
));
287 end Walk_Sinfo_Fields
;
289 --------------------------------
290 -- Walk_Sinfo_Fields_Pairwise --
291 --------------------------------
293 procedure Walk_Sinfo_Fields_Pairwise
(N1
, N2
: Node_Id
) is
294 pragma Assert
(Nkind
(N1
) = Nkind
(N2
));
296 Fields
: Node_Field_Array
renames
297 Node_Field_Table
(Nkind
(N1
)).all;
300 for J
in Fields
'Range loop
301 if Fields
(J
) /= F_Link
then -- Don't walk Parent!
303 Desc
: Field_Descriptor
renames
304 Field_Descriptors
(Fields
(J
));
305 pragma Assert
(Desc
.Type_Only
= No_Type_Only
);
306 -- Type_Only is for entities
308 if Is_In_Union_Id
(Desc
.Kind
) then
311 Transform
(Get_Node_Field_Union
(N2
, Desc
.Offset
)));
316 end Walk_Sinfo_Fields_Pairwise
;
318 ---------------------
319 -- Map_Pragma_Name --
320 ---------------------
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.
327 type Name_Pair
is record
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;
336 procedure Map_Pragma_Name
(From
, To
: Name_Id
) is
338 if Last_Pair
= Pragma_Map
'Last then
339 raise Too_Many_Pragma_Mappings
;
342 Last_Pair
:= Last_Pair
+ 1;
343 Pragma_Map
(Last_Pair
) := (Key
=> From
, Value
=> To
);
350 function Pragma_Name
(N
: Node_Id
) return Name_Id
is
351 Result
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
353 for J
in Pragma_Map
'First .. Last_Pair
loop
354 if Result
= Pragma_Map
(J
).Key
then
355 return Pragma_Map
(J
).Value
;