mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-13 08:29:53 +00:00
481 lines
15 KiB
Ada
481 lines
15 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- G E N _ I L . 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. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
package body Gen_IL.Internals is
|
|
|
|
---------
|
|
-- Nil --
|
|
---------
|
|
|
|
procedure Nil (T : Node_Or_Entity_Type) is
|
|
begin
|
|
null;
|
|
end Nil;
|
|
|
|
--------------------
|
|
-- Node_Or_Entity --
|
|
--------------------
|
|
|
|
function Node_Or_Entity (Root : Root_Type) return String is
|
|
begin
|
|
if Root = Node_Kind then
|
|
return "Node";
|
|
else
|
|
return "Entity";
|
|
end if;
|
|
end Node_Or_Entity;
|
|
|
|
------------------------------
|
|
-- Num_Concrete_Descendants --
|
|
------------------------------
|
|
|
|
function Num_Concrete_Descendants
|
|
(T : Node_Or_Entity_Type) return Natural is
|
|
begin
|
|
return Concrete_Type'Pos (Type_Table (T).Last) -
|
|
Concrete_Type'Pos (Type_Table (T).First) + 1;
|
|
end Num_Concrete_Descendants;
|
|
|
|
function First_Abstract (Root : Root_Type) return Abstract_Type is
|
|
(case Root is
|
|
when Node_Kind => Abstract_Node'First,
|
|
when others => Abstract_Entity'First); -- Entity_Kind
|
|
function Last_Abstract (Root : Root_Type) return Abstract_Type is
|
|
(case Root is
|
|
when Node_Kind => Abstract_Node'Last,
|
|
when others => Abstract_Entity'Last); -- Entity_Kind
|
|
|
|
function First_Concrete (Root : Root_Type) return Concrete_Type is
|
|
(case Root is
|
|
when Node_Kind => Concrete_Node'First,
|
|
when others => Concrete_Entity'First); -- Entity_Kind
|
|
function Last_Concrete (Root : Root_Type) return Concrete_Type is
|
|
(case Root is
|
|
when Node_Kind => Concrete_Node'Last,
|
|
when others => Concrete_Entity'Last); -- Entity_Kind
|
|
|
|
function First_Field (Root : Root_Type) return Field_Enum is
|
|
(case Root is
|
|
when Node_Kind => Node_Field'First,
|
|
when others => Entity_Field'First); -- Entity_Kind
|
|
function Last_Field (Root : Root_Type) return Field_Enum is
|
|
(case Root is
|
|
when Node_Kind => Node_Field'Last,
|
|
when others => Entity_Field'Last); -- Entity_Kind
|
|
|
|
-----------------------
|
|
-- Verify_Type_Table --
|
|
-----------------------
|
|
|
|
procedure Verify_Type_Table is
|
|
begin
|
|
for T in Node_Or_Entity_Type loop
|
|
if Type_Table (T) /= null then
|
|
if not Type_Table (T).Is_Union then
|
|
case T is
|
|
when Concrete_Node | Concrete_Entity =>
|
|
pragma Assert (Type_Table (T).First = T);
|
|
pragma Assert (Type_Table (T).Last = T);
|
|
|
|
when Abstract_Node | Abstract_Entity =>
|
|
pragma Assert
|
|
(Type_Table (T).First < Type_Table (T).Last);
|
|
|
|
when Type_Boundaries =>
|
|
null;
|
|
end case;
|
|
end if;
|
|
end if;
|
|
end loop;
|
|
end Verify_Type_Table;
|
|
|
|
--------------
|
|
-- Id_Image --
|
|
--------------
|
|
|
|
function Id_Image (T : Type_Enum) return String is
|
|
begin
|
|
case T is
|
|
when Flag =>
|
|
return "Boolean";
|
|
when Node_Kind =>
|
|
return "Node_Id";
|
|
when Entity_Kind =>
|
|
return "Entity_Id";
|
|
when Node_Kind_Type =>
|
|
return "Node_Kind";
|
|
when Entity_Kind_Type =>
|
|
return "Entity_Kind";
|
|
when others =>
|
|
return Image (T) & "_Id";
|
|
end case;
|
|
end Id_Image;
|
|
|
|
----------------------
|
|
-- Get_Set_Id_Image --
|
|
----------------------
|
|
|
|
function Get_Set_Id_Image (T : Type_Enum) return String is
|
|
begin
|
|
case T is
|
|
when Node_Kind =>
|
|
return "Node_Id";
|
|
when Entity_Kind =>
|
|
return "Entity_Id";
|
|
when Node_Kind_Type =>
|
|
return "Node_Kind";
|
|
when Entity_Kind_Type =>
|
|
return "Entity_Kind";
|
|
when others =>
|
|
return Image (T);
|
|
end case;
|
|
end Get_Set_Id_Image;
|
|
|
|
-----------
|
|
-- Image --
|
|
-----------
|
|
|
|
function Image (T : Opt_Type_Enum) return String is
|
|
begin
|
|
case T is
|
|
-- We special case the following; otherwise the compiler will give
|
|
-- "wrong case" warnings in compiler code.
|
|
|
|
when N_Pop_xxx_Label =>
|
|
return "N_Pop_xxx_Label";
|
|
|
|
when N_Push_Pop_xxx_Label =>
|
|
return "N_Push_Pop_xxx_Label";
|
|
|
|
when N_Push_xxx_Label =>
|
|
return "N_Push_xxx_Label";
|
|
|
|
when N_Raise_xxx_Error =>
|
|
return "N_Raise_xxx_Error";
|
|
|
|
when N_SCIL_Node =>
|
|
return "N_SCIL_Node";
|
|
|
|
when N_SCIL_Dispatch_Table_Tag_Init =>
|
|
return "N_SCIL_Dispatch_Table_Tag_Init";
|
|
|
|
when N_SCIL_Dispatching_Call =>
|
|
return "N_SCIL_Dispatching_Call";
|
|
|
|
when N_SCIL_Membership_Test =>
|
|
return "N_SCIL_Membership_Test";
|
|
|
|
when others =>
|
|
return Capitalize (T'Img);
|
|
end case;
|
|
end Image;
|
|
|
|
------------------
|
|
-- Image_Sans_N --
|
|
------------------
|
|
|
|
function Image_Sans_N (T : Opt_Type_Enum) return String is
|
|
Im : constant String := Image (T);
|
|
pragma Assert (Im (1 .. 2) = "N_");
|
|
begin
|
|
return Im (3 .. Im'Last);
|
|
end Image_Sans_N;
|
|
|
|
-------------------------
|
|
-- Put_Types_With_Bars --
|
|
-------------------------
|
|
|
|
procedure Put_Types_With_Bars (S : in out Sink; U : Type_Vector) is
|
|
First_Time : Boolean := True;
|
|
begin
|
|
Increase_Indent (S, 3);
|
|
|
|
for T of U loop
|
|
if First_Time then
|
|
First_Time := False;
|
|
else
|
|
Put (S, LF & "| ");
|
|
end if;
|
|
|
|
Put (S, Image (T));
|
|
end loop;
|
|
|
|
Decrease_Indent (S, 3);
|
|
end Put_Types_With_Bars;
|
|
|
|
----------------------------
|
|
-- Put_Type_Ids_With_Bars --
|
|
----------------------------
|
|
|
|
procedure Put_Type_Ids_With_Bars (S : in out Sink; U : Type_Vector) is
|
|
First_Time : Boolean := True;
|
|
begin
|
|
Increase_Indent (S, 3);
|
|
|
|
for T of U loop
|
|
if First_Time then
|
|
First_Time := False;
|
|
else
|
|
Put (S, LF & "| ");
|
|
end if;
|
|
|
|
Put (S, Id_Image (T));
|
|
end loop;
|
|
|
|
Decrease_Indent (S, 3);
|
|
end Put_Type_Ids_With_Bars;
|
|
|
|
-----------
|
|
-- Image --
|
|
-----------
|
|
|
|
function Image (F : Opt_Field_Enum) return String is
|
|
begin
|
|
case F is
|
|
-- Special cases for the same reason as in the above Image
|
|
-- function for Opt_Type_Enum.
|
|
|
|
when Alloc_For_BIP_Return =>
|
|
return "Alloc_For_BIP_Return";
|
|
when Assignment_OK =>
|
|
return "Assignment_OK";
|
|
when Backwards_OK =>
|
|
return "Backwards_OK";
|
|
when BIP_Initialization_Call =>
|
|
return "BIP_Initialization_Call";
|
|
when Body_Needed_For_SAL =>
|
|
return "Body_Needed_For_SAL";
|
|
when Conversion_OK =>
|
|
return "Conversion_OK";
|
|
when CR_Discriminant =>
|
|
return "CR_Discriminant";
|
|
when DTC_Entity =>
|
|
return "DTC_Entity";
|
|
when DT_Entry_Count =>
|
|
return "DT_Entry_Count";
|
|
when DT_Offset_To_Top_Func =>
|
|
return "DT_Offset_To_Top_Func";
|
|
when DT_Position =>
|
|
return "DT_Position";
|
|
when Forwards_OK =>
|
|
return "Forwards_OK";
|
|
when Has_Inherited_DIC =>
|
|
return "Has_Inherited_DIC";
|
|
when Has_Own_DIC =>
|
|
return "Has_Own_DIC";
|
|
when Has_RACW =>
|
|
return "Has_RACW";
|
|
when Has_SP_Choice =>
|
|
return "Has_SP_Choice";
|
|
when Ignore_SPARK_Mode_Pragmas =>
|
|
return "Ignore_SPARK_Mode_Pragmas";
|
|
when Is_Constr_Subt_For_UN_Aliased =>
|
|
return "Is_Constr_Subt_For_UN_Aliased";
|
|
when Is_CPP_Class =>
|
|
return "Is_CPP_Class";
|
|
when Is_CUDA_Kernel =>
|
|
return "Is_CUDA_Kernel";
|
|
when Is_DIC_Procedure =>
|
|
return "Is_DIC_Procedure";
|
|
when Is_Discrim_SO_Function =>
|
|
return "Is_Discrim_SO_Function";
|
|
when Is_Elaboration_Checks_OK_Id =>
|
|
return "Is_Elaboration_Checks_OK_Id";
|
|
when Is_Elaboration_Checks_OK_Node =>
|
|
return "Is_Elaboration_Checks_OK_Node";
|
|
when Is_Elaboration_Warnings_OK_Id =>
|
|
return "Is_Elaboration_Warnings_OK_Id";
|
|
when Is_Elaboration_Warnings_OK_Node =>
|
|
return "Is_Elaboration_Warnings_OK_Node";
|
|
when Is_Known_Guaranteed_ABE =>
|
|
return "Is_Known_Guaranteed_ABE";
|
|
when Is_RACW_Stub_Type =>
|
|
return "Is_RACW_Stub_Type";
|
|
when Is_SPARK_Mode_On_Node =>
|
|
return "Is_SPARK_Mode_On_Node";
|
|
when Local_Raise_Not_OK =>
|
|
return "Local_Raise_Not_OK";
|
|
when LSP_Subprogram =>
|
|
return "LSP_Subprogram";
|
|
when OK_To_Rename =>
|
|
return "OK_To_Rename";
|
|
when Referenced_As_LHS =>
|
|
return "Referenced_As_LHS";
|
|
when RM_Size =>
|
|
return "RM_Size";
|
|
when SCIL_Controlling_Tag =>
|
|
return "SCIL_Controlling_Tag";
|
|
when SCIL_Entity =>
|
|
return "SCIL_Entity";
|
|
when SCIL_Tag_Value =>
|
|
return "SCIL_Tag_Value";
|
|
when SCIL_Target_Prim =>
|
|
return "SCIL_Target_Prim";
|
|
when Shift_Count_OK =>
|
|
return "Shift_Count_OK";
|
|
when SPARK_Aux_Pragma =>
|
|
return "SPARK_Aux_Pragma";
|
|
when SPARK_Aux_Pragma_Inherited =>
|
|
return "SPARK_Aux_Pragma_Inherited";
|
|
when SPARK_Pragma =>
|
|
return "SPARK_Pragma";
|
|
when SPARK_Pragma_Inherited =>
|
|
return "SPARK_Pragma_Inherited";
|
|
when Split_PPC =>
|
|
return "Split_PPC";
|
|
when SSO_Set_High_By_Default =>
|
|
return "SSO_Set_High_By_Default";
|
|
when SSO_Set_Low_By_Default =>
|
|
return "SSO_Set_Low_By_Default";
|
|
when TSS_Elist =>
|
|
return "TSS_Elist";
|
|
|
|
when others =>
|
|
return Capitalize (F'Img);
|
|
end case;
|
|
end Image;
|
|
|
|
function Image (Default : Field_Default_Value) return String is
|
|
(Capitalize (Default'Img));
|
|
|
|
-----------------
|
|
-- Value_Image --
|
|
-----------------
|
|
|
|
function Value_Image (Default : Field_Default_Value) return String is
|
|
begin
|
|
if Default = No_Default then
|
|
return Image (Default);
|
|
|
|
else
|
|
-- Strip off the prefix
|
|
|
|
declare
|
|
Im : constant String := Image (Default);
|
|
Prefix : constant String := "Default_";
|
|
begin
|
|
pragma Assert (Im (1 .. Prefix'Length) = Prefix);
|
|
return Im (Prefix'Length + 1 .. Im'Last);
|
|
end;
|
|
end if;
|
|
end Value_Image;
|
|
|
|
-------------------
|
|
-- Iterate_Types --
|
|
-------------------
|
|
|
|
procedure Iterate_Types
|
|
(Root : Node_Or_Entity_Type;
|
|
Pre, Post : not null access procedure (T : Node_Or_Entity_Type) :=
|
|
Nil'Access)
|
|
is
|
|
procedure Recursive (T : Node_Or_Entity_Type);
|
|
-- Recursive walk
|
|
|
|
procedure Recursive (T : Node_Or_Entity_Type) is
|
|
begin
|
|
Pre (T);
|
|
|
|
for Child of Type_Table (T).Children loop
|
|
Recursive (Child);
|
|
end loop;
|
|
|
|
Post (T);
|
|
end Recursive;
|
|
|
|
begin
|
|
Recursive (Root);
|
|
end Iterate_Types;
|
|
|
|
-------------------
|
|
-- Is_Descendant --
|
|
-------------------
|
|
|
|
function Is_Descendant (Ancestor, Descendant : Node_Or_Entity_Type)
|
|
return Boolean is
|
|
begin
|
|
if Ancestor = Descendant then
|
|
return True;
|
|
|
|
elsif Descendant in Root_Type then
|
|
return False;
|
|
|
|
else
|
|
return Is_Descendant (Ancestor, Type_Table (Descendant).Parent);
|
|
end if;
|
|
end Is_Descendant;
|
|
|
|
------------------------
|
|
-- Put_Type_Hierarchy --
|
|
------------------------
|
|
|
|
procedure Put_Type_Hierarchy (S : in out Sink; Root : Root_Type) is
|
|
Level : Natural := 0;
|
|
|
|
function Indentation return String is ((1 .. 3 * Level => ' '));
|
|
-- Indentation string of space characters. We can't use the Indent
|
|
-- primitive, because we want this indentation after the "--".
|
|
|
|
procedure Pre (T : Node_Or_Entity_Type);
|
|
procedure Post (T : Node_Or_Entity_Type);
|
|
-- Pre and Post actions passed to Iterate_Types
|
|
|
|
procedure Pre (T : Node_Or_Entity_Type) is
|
|
begin
|
|
Put (S, "-- " & Indentation & Image (T) & LF);
|
|
Level := Level + 1;
|
|
end Pre;
|
|
|
|
procedure Post (T : Node_Or_Entity_Type) is
|
|
begin
|
|
Level := Level - 1;
|
|
|
|
-- Put out an "end" line only if there are many descendants, for
|
|
-- an arbitrary definition of "many".
|
|
|
|
if Num_Concrete_Descendants (T) > 10 then
|
|
Put (S, "-- " & Indentation & "end " & Image (T) & LF);
|
|
end if;
|
|
end Post;
|
|
|
|
N_Or_E : constant String :=
|
|
(case Root is
|
|
when Node_Kind => "nodes",
|
|
when others => "entities"); -- Entity_Kind
|
|
|
|
-- Start of processing for Put_Type_Hierarchy
|
|
|
|
begin
|
|
Put (S, "-- Type hierarchy for " & N_Or_E & LF);
|
|
Put (S, "--" & LF);
|
|
|
|
Iterate_Types (Root, Pre'Access, Post'Access);
|
|
|
|
Put (S, "--" & LF);
|
|
Put (S, "-- End type hierarchy for " & N_Or_E & LF & LF);
|
|
end Put_Type_Hierarchy;
|
|
|
|
end Gen_IL.Internals;
|