------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S I N F O . U T I L S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2020-2025, 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 GNAT.Lists;
with Output; use Output;
with Seinfo;
with Sinput; use Sinput;
package body Sinfo.Utils is
function Spec_Lib_Unit
(N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id
is
pragma Assert (Unit (N) in N_Lib_Unit_Body_Id);
begin
return Val : constant Opt_N_Compilation_Unit_Id :=
Spec_Or_Body_Lib_Unit (N)
do
pragma Assert
(if Present (Val) then
Unit (Val) in N_Lib_Unit_Declaration_Id
| N_Lib_Unit_Renaming_Declaration_Id -- only in case of error
or else (N = Val
and then Unit (N) in N_Subprogram_Body_Id
and then Acts_As_Spec (N)));
end return;
end Spec_Lib_Unit;
procedure Set_Spec_Lib_Unit (N, Val : N_Compilation_Unit_Id) is
pragma Assert (Unit (N) in N_Lib_Unit_Body_Id);
pragma Assert
(Unit (Val) in N_Lib_Unit_Declaration_Id
| N_Lib_Unit_Renaming_Declaration_Id -- only in case of error
or else (N = Val
and then Unit (N) in N_Subprogram_Body_Id
and then Acts_As_Spec (N)));
begin
Set_Library_Unit (N, Val);
end Set_Spec_Lib_Unit;
function Body_Lib_Unit
(N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id
is
pragma Assert
(Unit (N) in N_Lib_Unit_Declaration_Id
| N_Lib_Unit_Renaming_Declaration_Id); -- only in case of error
begin
return Val : constant Opt_N_Compilation_Unit_Id :=
Spec_Or_Body_Lib_Unit (N)
do
pragma Assert
(if Present (Val) then Unit (Val) in N_Lib_Unit_Body_Id);
end return;
end Body_Lib_Unit;
procedure Set_Body_Lib_Unit (N, Val : N_Compilation_Unit_Id) is
pragma Assert
(Unit (N) in N_Lib_Unit_Declaration_Id
| N_Lib_Unit_Renaming_Declaration_Id); -- only in case of error
pragma Assert (Unit (Val) in N_Lib_Unit_Body_Id);
begin
Set_Library_Unit (N, Val);
end Set_Body_Lib_Unit;
function Spec_Or_Body_Lib_Unit
(N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id
is
pragma Assert
(Unit (N) in
N_Lib_Unit_Declaration_Id | N_Lib_Unit_Body_Id
| N_Lib_Unit_Renaming_Declaration_Id);
begin
return Other_Comp_Unit (N);
end Spec_Or_Body_Lib_Unit;
function Subunit_Parent
(N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id
is
pragma Assert (Unit (N) in N_Subunit_Id);
begin
return Val : constant Opt_N_Compilation_Unit_Id := Other_Comp_Unit (N) do
pragma Assert
(if Present (Val) then
Unit (Val) in N_Lib_Unit_Body_Id | N_Subunit_Id);
end return;
end Subunit_Parent;
procedure Set_Subunit_Parent (N, Val : N_Compilation_Unit_Id) is
pragma Assert (Unit (N) in N_Subunit_Id);
pragma Assert (Unit (Val) in N_Lib_Unit_Body_Id | N_Subunit_Id);
begin
Set_Library_Unit (N, Val);
end Set_Subunit_Parent;
function Other_Comp_Unit
(N : N_Compilation_Unit_Id) return Opt_N_Compilation_Unit_Id
is
pragma Assert (N in N_Compilation_Unit_Id);
Val : constant Opt_N_Compilation_Unit_Id := Library_Unit (N);
begin
if Unit (N) in N_Subunit_Id then
pragma Assert
(if Present (Val) then
Unit (Val) in N_Lib_Unit_Body_Id | N_Subunit_Id);
end if;
return Library_Unit (N);
end Other_Comp_Unit;
function Stub_Subunit
(N : N_Body_Stub_Id) return Opt_N_Compilation_Unit_Id is
begin
return Val : constant Opt_N_Compilation_Unit_Id := Library_Unit (N) do
pragma Assert (if Present (Val) then Unit (Val) in N_Subunit_Id);
end return;
end Stub_Subunit;
procedure Set_Stub_Subunit
(N : N_Body_Stub_Id; Val : N_Compilation_Unit_Id)
is
pragma Assert (Unit (Val) in N_Subunit_Id);
begin
Set_Library_Unit (N, Val);
end Set_Stub_Subunit;
function Withed_Lib_Unit
(N : N_With_Clause_Id) return Opt_N_Compilation_Unit_Id is
begin
return Val : constant Opt_N_Compilation_Unit_Id := Library_Unit (N) do
pragma Assert
(if Present (Val) then
Unit (Val) in N_Lib_Unit_Declaration_Id
| N_Lib_Unit_Renaming_Declaration_Id
| N_Package_Body_Id | N_Subprogram_Body_Id
| N_Null_Statement_Id); -- for ignored ghost code
end return;
end Withed_Lib_Unit;
procedure Set_Withed_Lib_Unit
(N : N_With_Clause_Id; Val : N_Compilation_Unit_Id)
is
pragma Assert
(Unit (Val) in N_Lib_Unit_Declaration_Id
| N_Lib_Unit_Renaming_Declaration_Id
| N_Package_Body_Id | N_Subprogram_Body_Id);
begin
Set_Library_Unit (N, Val);
end Set_Withed_Lib_Unit;
---------------
-- 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 "New_Node_Debugging_Output" in Atree.
-- 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 Sloc (N) + Source_Ptr (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;
procedure Destroy_Element (Elem : in out Union_Id);
-- Does not do anything but is used to instantiate
-- GNAT.Lists.Doubly_Linked_Lists.
---------------------
-- Destroy_Element --
---------------------
procedure Destroy_Element (Elem : in out Union_Id) is
begin
null;
end Destroy_Element;
package Lists is
new GNAT.Lists.Doubly_Linked_Lists
(Element_Type => Union_Id, "=" => "=",
Destroy_Element => Destroy_Element, Check_Tampering => False);
----------------------------
-- Lowest_Common_Ancestor --
----------------------------
function Lowest_Common_Ancestor (N1, N2 : Node_Id) return Union_Id is
function Path_From_Root (N : Node_Id) return Lists.Doubly_Linked_List;
--------------------
-- Path_From_Root --
--------------------
function Path_From_Root (N : Node_Id) return Lists.Doubly_Linked_List is
L : constant Lists.Doubly_Linked_List := Lists.Create;
X : Union_Id := Union_Id (N);
begin
while X /= Union_Id (Empty) loop
Lists.Prepend (L, X);
X := Parent_Or_List_Containing (X);
end loop;
return L;
end Path_From_Root;
L1 : Lists.Doubly_Linked_List := Path_From_Root (N1);
L2 : Lists.Doubly_Linked_List := Path_From_Root (N2);
X1, X2 : Union_Id;
Common_Ancestor : Union_Id := Union_Id (Empty);
begin
while not Lists.Is_Empty (L1) and then not Lists.Is_Empty (L2) loop
X1 := Lists.First (L1);
Lists.Delete_First (L1);
X2 := Lists.First (L2);
Lists.Delete_First (L2);
exit when X1 /= X2;
Common_Ancestor := X1;
end loop;
Lists.Destroy (L1);
Lists.Destroy (L2);
return Common_Ancestor;
end Lowest_Common_Ancestor;
----------------------
-- Set_End_Location --
----------------------
procedure Set_End_Location (N : Node_Id; S : Source_Ptr) is
begin
Set_End_Span (N,
UI_From_Int (Int (S - 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_File_Index_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;