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
26with Atree;  use Atree;
27with Debug;  use Debug;
28with Output; use Output;
29with Seinfo;
30with Sinput; use Sinput;
31
32package body Sinfo.Utils is
33
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_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.
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 (etc.)
76   --  call 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
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
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
192      L : constant Valid_Uint := End_Span (N);
193   begin
194      return Source_Ptr (Int (Sloc (N)) + UI_To_Int (L));
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
241   --  True if the field type is one that can be converted to Types.Union_Id
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);
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
274         if Fields (J) /= F_Link then -- Don't walk Parent!
275            declare
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
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
301         if Fields (J) /= F_Link then -- Don't walk Parent!
302            declare
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
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
362end Sinfo.Utils;
363