| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |
