diff options
Diffstat (limited to 'gcc/ada/gen_il-internals.adb')
| -rw-r--r-- | gcc/ada/gen_il-internals.adb | 480 |
1 files changed, 480 insertions, 0 deletions
diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb new file mode 100644 index 0000000..d77fe7a --- /dev/null +++ b/gcc/ada/gen_il-internals.adb @@ -0,0 +1,480 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G E N _ I L . U T I L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020-2021, 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. + + 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 and capitalize it + + 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; |