gcc/ada/sinfo-utils.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                           S I N F O . U T I L S                          --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--           Copyright (C) 2020-2022, Free Software Foundation, Inc.        --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Atree;  use Atree;
with Debug;  use Debug;
with Output; use Output;
with Seinfo;
with Sinput; use Sinput;

package body Sinfo.Utils is

   ---------------
   -- Debugging --
   ---------------

   --  Suppose you find that node 12345 is messed up. You might want to find
   --  the code that created that node. There are two ways to do this:

   --  One way is to set a conditional breakpoint on New_Node_Debugging_Output
   --  (nickname "nnd"):
   --     break nnd if n = 12345
   --  and run gnat1 again from the beginning.

   --  The other way is to set a breakpoint near the beginning (e.g. on
   --  gnat1drv), and run. Then set Watch_Node (nickname "ww") to 12345 in gdb:
   --     ww := 12345
   --  and set a breakpoint on New_Node_Breakpoint (nickname "nn"). Continue.

   --  Either way, gnat1 will stop when node 12345 is created, or certain other
   --  interesting operations are performed, such as Rewrite. To see exactly
   --  which operations, search for "pragma Debug" below.

   --  The second method is much faster if the amount of Ada code being
   --  compiled is large.

   ww : Node_Id'Base := Node_Low_Bound - 1;
   pragma Export (Ada, ww);
   Watch_Node : Node_Id'Base renames ww;
   --  Node to "watch"; that is, whenever a node is created, we check if it
   --  is equal to Watch_Node, and if so, call New_Node_Breakpoint. You have
   --  presumably set a breakpoint on New_Node_Breakpoint. Note that the
   --  initial value of Node_Id'First - 1 ensures that by default, no node
   --  will be equal to Watch_Node.

   procedure nn;
   pragma Export (Ada, nn);
   procedure New_Node_Breakpoint renames nn;
   --  This doesn't do anything interesting; it's just for setting breakpoint
   --  on as explained above.

   procedure nnd (N : Node_Id);
   pragma Export (Ada, nnd);
   --  For debugging. If debugging is turned on, New_Node and New_Entity (etc.)
   --  call this. If debug flag N is turned on, this prints out the new node.
   --
   --  If Node = Watch_Node, this prints out the new node and calls
   --  New_Node_Breakpoint. Otherwise, does nothing.

   procedure Node_Debug_Output (Op : String; N : Node_Id);
   --  Called by nnd; writes Op followed by information about N

   -------------------------
   -- New_Node_Breakpoint --
   -------------------------

   procedure nn is
   begin
      Write_Str ("Watched node ");
      Write_Int (Int (Watch_Node));
      Write_Eol;
   end nn;

   -------------------------------
   -- New_Node_Debugging_Output --
   -------------------------------

   procedure nnd (N : Node_Id) is
      Node_Is_Watched : constant Boolean := N = Watch_Node;

   begin
      if Debug_Flag_N or else Node_Is_Watched then
         Node_Debug_Output ("Node", N);

         if Node_Is_Watched then
            New_Node_Breakpoint;
         end if;
      end if;
   end nnd;

   procedure New_Node_Debugging_Output (N : Node_Id) is
   begin
      pragma Debug (nnd (N));
   end New_Node_Debugging_Output;

   -----------------------
   -- Node_Debug_Output --
   -----------------------

   procedure Node_Debug_Output (Op : String; N : Node_Id) is
   begin
      Write_Str (Op);

      if Nkind (N) in N_Entity then
         Write_Str (" entity");
      else
         Write_Str (" node");
      end if;

      Write_Str (" Id = ");
      Write_Int (Int (N));
      Write_Str ("  ");
      Write_Location (Sloc (N));
      Write_Str ("  ");
      Write_Str (Node_Kind'Image (Nkind (N)));
      Write_Eol;
   end Node_Debug_Output;

   -------------------------------
   -- Parent-related operations --
   -------------------------------

   procedure Copy_Parent (To, From : Node_Or_Entity_Id) is
   begin
      if Atree.Present (To) and Atree.Present (From) then
         Atree.Set_Parent (To, Atree.Parent (From));
      else
         pragma Assert
           (if Atree.Present (To) then Atree.No (Atree.Parent (To)));
      end if;
   end Copy_Parent;

   function Parent_Kind (N : Node_Id) return Node_Kind is
   begin
      if Atree.No (N) then
         return N_Empty;
      else
         return Nkind (Atree.Parent (N));
      end if;
   end Parent_Kind;

   -------------------------
   -- Iterator Procedures --
   -------------------------

   procedure Next_Entity       (N : in out Node_Id) is
   begin
      N := Next_Entity (N);
   end Next_Entity;

   procedure Next_Named_Actual (N : in out Node_Id) is
   begin
      N := Next_Named_Actual (N);
   end Next_Named_Actual;

   procedure Next_Rep_Item     (N : in out Node_Id) is
   begin
      N := Next_Rep_Item (N);
   end Next_Rep_Item;

   procedure Next_Use_Clause   (N : in out Node_Id) is
   begin
      N := Next_Use_Clause (N);
   end Next_Use_Clause;

   ------------------
   -- End_Location --
   ------------------

   function End_Location (N : Node_Id) return Source_Ptr is
      L : constant Valid_Uint := End_Span (N);
   begin
      return Source_Ptr (Int (Sloc (N)) + UI_To_Int (L));
   end End_Location;

   --------------------
   -- Get_Pragma_Arg --
   --------------------

   function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is
   begin
      if Nkind (Arg) = N_Pragma_Argument_Association then
         return Expression (Arg);
      else
         return Arg;
      end if;
   end Get_Pragma_Arg;

   ----------------------
   -- Set_End_Location --
   ----------------------

   procedure Set_End_Location (N : Node_Id; S : Source_Ptr) is
   begin
      Set_End_Span (N,
        UI_From_Int (Int (S) - Int (Sloc (N))));
   end Set_End_Location;

   --------------------------
   -- Pragma_Name_Unmapped --
   --------------------------

   function Pragma_Name_Unmapped (N : Node_Id) return Name_Id is
   begin
      return Chars (Pragma_Identifier (N));
   end Pragma_Name_Unmapped;

   ------------------------------------
   -- Helpers for Walk_Sinfo_Fields* --
   ------------------------------------

   function Get_Node_Field_Union is new
     Atree.Atree_Private_Part.Get_32_Bit_Field (Union_Id) with Inline;
   procedure Set_Node_Field_Union is new
     Atree.Atree_Private_Part.Set_32_Bit_Field (Union_Id) with Inline;

   use Seinfo;

   function Is_In_Union_Id (F_Kind : Field_Kind) return Boolean is
   --  True if the field type is one that can be converted to Types.Union_Id
     (case F_Kind is
       when Node_Id_Field
          | List_Id_Field
          | Elist_Id_Field
          | Name_Id_Field
          | String_Id_Field
          | Valid_Uint_Field
          | Unat_Field
          | Upos_Field
          | Nonzero_Uint_Field
          | Uint_Field
          | Ureal_Field
          | Union_Id_Field => True,
       when Flag_Field
          | Node_Kind_Type_Field
          | Entity_Kind_Type_Field
          | Source_Ptr_Field
          | Small_Paren_Count_Type_Field
          | Convention_Id_Field
          | Component_Alignment_Kind_Field
          | Mechanism_Type_Field => False);

   -----------------------
   -- Walk_Sinfo_Fields --
   -----------------------

   procedure Walk_Sinfo_Fields (N : Node_Id) is
      Fields : Node_Field_Array renames
        Node_Field_Table (Nkind (N)).all;

   begin
      for J in Fields'Range loop
         if Fields (J) /= F_Link then -- Don't walk Parent!
            declare
               Desc : Field_Descriptor renames
                 Field_Descriptors (Fields (J));
               pragma Assert (Desc.Type_Only = No_Type_Only);
               --  Type_Only is for entities
            begin
               if Is_In_Union_Id (Desc.Kind) then
                  Action (Get_Node_Field_Union (N, Desc.Offset));
               end if;
            end;
         end if;
      end loop;
   end Walk_Sinfo_Fields;

   --------------------------------
   -- Walk_Sinfo_Fields_Pairwise --
   --------------------------------

   procedure Walk_Sinfo_Fields_Pairwise (N1, N2 : Node_Id) is
      pragma Assert (Nkind (N1) = Nkind (N2));

      Fields : Node_Field_Array renames
        Node_Field_Table (Nkind (N1)).all;

   begin
      for J in Fields'Range loop
         if Fields (J) /= F_Link then -- Don't walk Parent!
            declare
               Desc : Field_Descriptor renames
                 Field_Descriptors (Fields (J));
               pragma Assert (Desc.Type_Only = No_Type_Only);
               --  Type_Only is for entities
            begin
               if Is_In_Union_Id (Desc.Kind) then
                  Set_Node_Field_Union
                    (N1, Desc.Offset,
                     Transform (Get_Node_Field_Union (N2, Desc.Offset)));
               end if;
            end;
         end if;
      end loop;
   end Walk_Sinfo_Fields_Pairwise;

   ---------------------
   -- Map_Pragma_Name --
   ---------------------

   --  We don't want to introduce a dependence on some hash table package or
   --  similar, so we use a simple array of Key => Value pairs, and do a linear
   --  search. Linear search is plenty efficient, given that we don't expect
   --  more than a couple of entries in the mapping.

   type Name_Pair is record
      Key   : Name_Id;
      Value : Name_Id;
   end record;

   type Pragma_Map_Index is range 1 .. 100;
   Pragma_Map : array (Pragma_Map_Index) of Name_Pair;
   Last_Pair : Pragma_Map_Index'Base range 0 .. Pragma_Map_Index'Last := 0;

   procedure Map_Pragma_Name (From, To : Name_Id) is
   begin
      if Last_Pair = Pragma_Map'Last then
         raise Too_Many_Pragma_Mappings;
      end if;

      Last_Pair := Last_Pair + 1;
      Pragma_Map (Last_Pair) := (Key => From, Value => To);
   end Map_Pragma_Name;

   -----------------
   -- Pragma_Name --
   -----------------

   function Pragma_Name (N : Node_Id) return Name_Id is
      Result : constant Name_Id := Pragma_Name_Unmapped (N);
   begin
      for J in Pragma_Map'First .. Last_Pair loop
         if Result = Pragma_Map (J).Key then
            return Pragma_Map (J).Value;
         end if;
      end loop;

      return Result;
   end Pragma_Name;

end Sinfo.Utils;