diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/exp_cg.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/exp_cg.adb | 673 |
1 files changed, 0 insertions, 673 deletions
diff --git a/gcc-4.8/gcc/ada/exp_cg.adb b/gcc-4.8/gcc/ada/exp_cg.adb deleted file mode 100644 index 076783f71..000000000 --- a/gcc-4.8/gcc/ada/exp_cg.adb +++ /dev/null @@ -1,673 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- E X P _ C G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2012, 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 Einfo; use Einfo; -with Elists; use Elists; -with Exp_Disp; use Exp_Disp; -with Exp_Dbug; use Exp_Dbug; -with Exp_Tss; use Exp_Tss; -with Lib; use Lib; -with Namet; use Namet; -with Opt; use Opt; -with Output; use Output; -with Sem_Aux; use Sem_Aux; -with Sem_Disp; use Sem_Disp; -with Sem_Type; use Sem_Type; -with Sem_Util; use Sem_Util; -with Sinfo; use Sinfo; -with Sinput; use Sinput; -with Snames; use Snames; -with System; use System; -with Table; -with Uintp; use Uintp; - -package body Exp_CG is - - -- We duplicate here some declarations from packages Interfaces.C and - -- Interfaces.C_Streams because adding their dependence to the frontend - -- causes bootstrapping problems with old versions of the compiler. - - subtype FILEs is System.Address; - -- Corresponds to the C type FILE* - - subtype C_chars is System.Address; - -- Pointer to null-terminated array of characters - - function fputs (Strng : C_chars; Stream : FILEs) return Integer; - pragma Import (C, fputs, "fputs"); - - -- Import the file stream associated with the "ci" output file. Done to - -- generate the output in the file created and left opened by routine - -- toplev.c before calling gnat1drv. - - Callgraph_Info_File : FILEs; - pragma Import (C, Callgraph_Info_File); - - package Call_Graph_Nodes is new Table.Table ( - Table_Component_Type => Node_Id, - Table_Index_Type => Natural, - Table_Low_Bound => 1, - Table_Initial => 50, - Table_Increment => 100, - Table_Name => "Call_Graph_Nodes"); - -- This table records nodes associated with dispatching calls and tagged - -- type declarations found in the main compilation unit. Used as an - -- auxiliary storage because the call-graph output requires fully qualified - -- names and they are not available until the backend is called. - - function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean; - -- Determines if E is a predefined primitive operation. - -- Note: This routine should replace the routine with the same name that is - -- currently available in exp_disp because it extends its functionality to - -- handle fully qualified names ??? - - function Slot_Number (Prim : Entity_Id) return Uint; - -- Returns the slot number associated with Prim. For predefined primitives - -- the slot is returned as a negative number. - - procedure Write_Output (Str : String); - -- Used to print a line in the output file (this is used as the - -- argument for a call to Set_Special_Output in package Output). - - procedure Write_Call_Info (Call : Node_Id); - -- Subsidiary of Generate_CG_Output that generates the output associated - -- with a dispatching call. - - procedure Write_Type_Info (Typ : Entity_Id); - -- Subsidiary of Generate_CG_Output that generates the output associated - -- with a tagged type declaration. - - ------------------------ - -- Generate_CG_Output -- - ------------------------ - - procedure Generate_CG_Output is - N : Node_Id; - - begin - -- No output if the "ci" output file has not been previously opened - -- by toplev.c - - if Callgraph_Info_File = Null_Address then - return; - end if; - - -- Setup write routine, create the output file and generate the output - - Set_Special_Output (Write_Output'Access); - - for J in Call_Graph_Nodes.First .. Call_Graph_Nodes.Last loop - N := Call_Graph_Nodes.Table (J); - - if Nkind (N) in N_Subprogram_Call then - Write_Call_Info (N); - - else pragma Assert (Nkind (N) = N_Defining_Identifier); - - -- The type may be a private untagged type whose completion is - -- tagged, in which case we must use the full tagged view. - - if not Is_Tagged_Type (N) and then Is_Private_Type (N) then - N := Full_View (N); - end if; - - pragma Assert (Is_Tagged_Type (N)); - - Write_Type_Info (N); - end if; - end loop; - - Set_Special_Output (null); - end Generate_CG_Output; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - Call_Graph_Nodes.Init; - end Initialize; - - ----------------------------------------- - -- Is_Predefined_Dispatching_Operation -- - ----------------------------------------- - - function Is_Predefined_Dispatching_Operation - (E : Entity_Id) return Boolean - is - function Homonym_Suffix_Length (E : Entity_Id) return Natural; - -- Returns the length of the homonym suffix corresponding to E. - -- Note: This routine relies on the functionality provided by routines - -- of Exp_Dbug. Further work needed here to decide if it should be - -- located in that package??? - - --------------------------- - -- Homonym_Suffix_Length -- - --------------------------- - - function Homonym_Suffix_Length (E : Entity_Id) return Natural is - Prefix_Length : constant := 2; - -- Length of prefix "__" - - H : Entity_Id; - Nr : Nat := 1; - - begin - if not Has_Homonym (E) then - return 0; - - else - H := Homonym (E); - while Present (H) loop - if Scope (H) = Scope (E) then - Nr := Nr + 1; - end if; - - H := Homonym (H); - end loop; - - if Nr = 1 then - return 0; - - -- Prefix "__" followed by number - - else - declare - Result : Natural := Prefix_Length + 1; - - begin - while Nr >= 10 loop - Result := Result + 1; - Nr := Nr / 10; - end loop; - - return Result; - end; - end if; - end if; - end Homonym_Suffix_Length; - - -- Local variables - - Full_Name : constant String := Get_Name_String (Chars (E)); - Suffix_Length : Natural; - TSS_Name : TSS_Name_Type; - - -- Start of processing for Is_Predefined_Dispatching_Operation - - begin - if not Is_Dispatching_Operation (E) then - return False; - end if; - - -- Search for and strip suffix for body-nested package entities - - Suffix_Length := Homonym_Suffix_Length (E); - for J in reverse Full_Name'First + 2 .. Full_Name'Last loop - if Full_Name (J) = 'X' then - - -- Include the "X", "Xb", "Xn", ... in the part of the - -- suffix to be removed. - - Suffix_Length := Suffix_Length + Full_Name'Last - J + 1; - exit; - end if; - - exit when Full_Name (J) /= 'b' and then Full_Name (J) /= 'n'; - end loop; - - -- Most predefined primitives have internally generated names. Equality - -- must be treated differently; the predefined operation is recognized - -- as a homogeneous binary operator that returns Boolean. - - if Full_Name'Length > TSS_Name_Type'Length then - TSS_Name := - TSS_Name_Type - (Full_Name - (Full_Name'Last - TSS_Name'Length - Suffix_Length + 1 - .. Full_Name'Last - Suffix_Length)); - - if TSS_Name = TSS_Stream_Read - or else TSS_Name = TSS_Stream_Write - or else TSS_Name = TSS_Stream_Input - or else TSS_Name = TSS_Stream_Output - or else TSS_Name = TSS_Deep_Adjust - or else TSS_Name = TSS_Deep_Finalize - then - return True; - - elsif not Has_Fully_Qualified_Name (E) then - if Chars (E) = Name_uSize - or else Chars (E) = Name_uAlignment - or else - (Chars (E) = Name_Op_Eq - and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) - or else Chars (E) = Name_uAssign - or else Is_Predefined_Interface_Primitive (E) - then - return True; - end if; - - -- Handle fully qualified names - - else - declare - type Names_Table is array (Positive range <>) of Name_Id; - - Predef_Names_95 : constant Names_Table := - (Name_uSize, - Name_uAlignment, - Name_Op_Eq, - Name_uAssign); - - Predef_Names_05 : constant Names_Table := - (Name_uDisp_Asynchronous_Select, - Name_uDisp_Conditional_Select, - Name_uDisp_Get_Prim_Op_Kind, - Name_uDisp_Get_Task_Id, - Name_uDisp_Requeue, - Name_uDisp_Timed_Select); - - begin - for J in Predef_Names_95'Range loop - Get_Name_String (Predef_Names_95 (J)); - - -- The predefined primitive operations are identified by the - -- names "_size", "_alignment", etc. If we try a pattern - -- matching against this string, we can wrongly match other - -- primitive operations like "get_size". To avoid this, we - -- add the "__" scope separator, which can only prepend - -- predefined primitive operations because other primitive - -- operations can neither start with an underline nor - -- contain two consecutive underlines in its name. - - if Full_Name'Last - Suffix_Length > Name_Len + 2 - and then - Full_Name - (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1 - .. Full_Name'Last - Suffix_Length) = - "__" & Name_Buffer (1 .. Name_Len) - then - -- For the equality operator the type of the two operands - -- must also match. - - return Predef_Names_95 (J) /= Name_Op_Eq - or else - Etype (First_Formal (E)) = Etype (Last_Formal (E)); - end if; - end loop; - - if Ada_Version >= Ada_2005 then - for J in Predef_Names_05'Range loop - Get_Name_String (Predef_Names_05 (J)); - - if Full_Name'Last - Suffix_Length > Name_Len + 2 - and then - Full_Name - (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1 - .. Full_Name'Last - Suffix_Length) = - "__" & Name_Buffer (1 .. Name_Len) - then - return True; - end if; - end loop; - end if; - end; - end if; - end if; - - return False; - end Is_Predefined_Dispatching_Operation; - - ---------------------- - -- Register_CG_Node -- - ---------------------- - - procedure Register_CG_Node (N : Node_Id) is - begin - if Nkind (N) in N_Subprogram_Call then - if Current_Scope = Main_Unit_Entity - or else Entity_Is_In_Main_Unit (Current_Scope) - then - -- Register a copy of the dispatching call node. Needed since the - -- node containing a dispatching call is rewritten by the - -- expander. - - declare - Copy : constant Node_Id := New_Copy (N); - Par : Node_Id; - - begin - -- Determine the enclosing scope to use when generating the - -- call graph. This must be done now to avoid problems with - -- control structures that may be rewritten during expansion. - - Par := Parent (N); - while Nkind (Par) /= N_Subprogram_Body - and then Nkind (Parent (Par)) /= N_Compilation_Unit - loop - Par := Parent (Par); - pragma Assert (Present (Par)); - end loop; - - Set_Parent (Copy, Par); - Call_Graph_Nodes.Append (Copy); - end; - end if; - - else pragma Assert (Nkind (N) = N_Defining_Identifier); - if Entity_Is_In_Main_Unit (N) then - Call_Graph_Nodes.Append (N); - end if; - end if; - end Register_CG_Node; - - ----------------- - -- Slot_Number -- - ----------------- - - function Slot_Number (Prim : Entity_Id) return Uint is - E : constant Entity_Id := Ultimate_Alias (Prim); - begin - if Is_Predefined_Dispatching_Operation (E) then - return -DT_Position (E); - else - return DT_Position (E); - end if; - end Slot_Number; - - ------------------ - -- Write_Output -- - ------------------ - - procedure Write_Output (Str : String) is - Nul : constant Character := Character'First; - Line : String (Str'First .. Str'Last + 1); - Errno : Integer; - - begin - -- Add the null character to the string as required by fputs - - Line := Str & Nul; - Errno := fputs (Line'Address, Callgraph_Info_File); - pragma Assert (Errno >= 0); - end Write_Output; - - --------------------- - -- Write_Call_Info -- - --------------------- - - procedure Write_Call_Info (Call : Node_Id) is - Ctrl_Arg : constant Node_Id := Controlling_Argument (Call); - Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); - Prim : constant Entity_Id := Entity (Sinfo.Name (Call)); - P : constant Node_Id := Parent (Call); - - begin - Write_Str ("edge: { sourcename: "); - Write_Char ('"'); - - -- The parent node is the construct that contains the call: subprogram - -- body or library-level package. Display the qualified name of the - -- entity of the construct. For a subprogram, it is the entity of the - -- spec, which carries a homonym counter when it is overloaded. - - if Nkind (P) = N_Subprogram_Body - and then not Acts_As_Spec (P) - then - Get_External_Name (Corresponding_Spec (P), Has_Suffix => False); - - else - Get_External_Name (Defining_Entity (P), Has_Suffix => False); - end if; - - Write_Str (Name_Buffer (1 .. Name_Len)); - - if Nkind (P) = N_Package_Declaration then - Write_Str ("___elabs"); - - elsif Nkind (P) = N_Package_Body then - Write_Str ("___elabb"); - end if; - - Write_Char ('"'); - Write_Eol; - - -- The targetname is a triple: - -- N: the index in a vtable used for dispatch - -- V: the type who's vtable is used - -- S: the static type of the expression - - Write_Str (" targetname: "); - Write_Char ('"'); - - pragma Assert (No (Interface_Alias (Prim))); - - -- The check on Is_Ancestor is done here to avoid problems with - -- renamings of primitives. For example: - - -- type Root is tagged ... - -- procedure Base (Obj : Root); - -- procedure Base2 (Obj : Root) renames Base; - - if Present (Alias (Prim)) - and then - Is_Ancestor - (Find_Dispatching_Type (Ultimate_Alias (Prim)), - Root_Type (Ctrl_Typ), - Use_Full_View => True) - then - -- This is a special case in which we generate in the ci file the - -- slot number of the renaming primitive (i.e. Base2) but instead of - -- generating the name of this renaming entity we reference directly - -- the renamed entity (i.e. Base). - - Write_Int (UI_To_Int (Slot_Number (Prim))); - Write_Char (':'); - Write_Name - (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim)))); - else - Write_Int (UI_To_Int (Slot_Number (Prim))); - Write_Char (':'); - Write_Name (Chars (Root_Type (Ctrl_Typ))); - end if; - - Write_Char (','); - Write_Name (Chars (Root_Type (Ctrl_Typ))); - - Write_Char ('"'); - Write_Eol; - - Write_Str (" label: "); - Write_Char ('"'); - Write_Location (Sloc (Call)); - Write_Char ('"'); - Write_Eol; - - Write_Char ('}'); - Write_Eol; - end Write_Call_Info; - - --------------------- - -- Write_Type_Info -- - --------------------- - - procedure Write_Type_Info (Typ : Entity_Id) is - Elmt : Elmt_Id; - Prim : Node_Id; - - Parent_Typ : Entity_Id; - Separator_Needed : Boolean := False; - - begin - -- Initialize Parent_Typ handling private types - - Parent_Typ := Etype (Typ); - - if Present (Full_View (Parent_Typ)) then - Parent_Typ := Full_View (Parent_Typ); - end if; - - Write_Str ("class {"); - Write_Eol; - - Write_Str (" classname: "); - Write_Char ('"'); - Write_Name (Chars (Typ)); - Write_Char ('"'); - Write_Eol; - - Write_Str (" label: "); - Write_Char ('"'); - Write_Name (Chars (Typ)); - Write_Char ('\'); - Write_Location (Sloc (Typ)); - Write_Char ('"'); - Write_Eol; - - if Parent_Typ /= Typ then - Write_Str (" parent: "); - Write_Char ('"'); - Write_Name (Chars (Parent_Typ)); - - -- Note: Einfo prefix not needed if this routine is moved to - -- exp_disp??? - - if Present (Einfo.Interfaces (Typ)) - and then not Is_Empty_Elmt_List (Einfo.Interfaces (Typ)) - then - Elmt := First_Elmt (Einfo.Interfaces (Typ)); - while Present (Elmt) loop - Write_Str (", "); - Write_Name (Chars (Node (Elmt))); - Next_Elmt (Elmt); - end loop; - end if; - - Write_Char ('"'); - Write_Eol; - end if; - - Write_Str (" virtuals: "); - Write_Char ('"'); - - Elmt := First_Elmt (Primitive_Operations (Typ)); - while Present (Elmt) loop - Prim := Node (Elmt); - - -- Skip internal entities associated with overridden interface - -- primitives, and also inherited primitives. - - if Present (Interface_Alias (Prim)) - or else - (Present (Alias (Prim)) - and then Find_Dispatching_Type (Prim) /= - Find_Dispatching_Type (Alias (Prim))) - then - goto Continue; - end if; - - -- Do not generate separator for output of first primitive - - if Separator_Needed then - Write_Str ("\n"); - Write_Eol; - Write_Str (" "); - else - Separator_Needed := True; - end if; - - Write_Int (UI_To_Int (Slot_Number (Prim))); - Write_Char (':'); - - -- Handle renamed primitives - - if Present (Alias (Prim)) then - Write_Name (Chars (Ultimate_Alias (Prim))); - else - Write_Name (Chars (Prim)); - end if; - - -- Display overriding of parent primitives - - if Present (Overridden_Operation (Prim)) - and then - Is_Ancestor - (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ, - Use_Full_View => True) - then - Write_Char (','); - Write_Int - (UI_To_Int (Slot_Number (Overridden_Operation (Prim)))); - Write_Char (':'); - Write_Name - (Chars (Find_Dispatching_Type (Overridden_Operation (Prim)))); - end if; - - -- Display overriding of interface primitives - - if Has_Interfaces (Typ) then - declare - Prim_Elmt : Elmt_Id; - Prim_Op : Node_Id; - Int_Alias : Entity_Id; - - begin - Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); - while Present (Prim_Elmt) loop - Prim_Op := Node (Prim_Elmt); - Int_Alias := Interface_Alias (Prim_Op); - - if Present (Int_Alias) - and then - not Is_Ancestor (Find_Dispatching_Type (Int_Alias), Typ, - Use_Full_View => True) - and then (Alias (Prim_Op)) = Prim - then - Write_Char (','); - Write_Int (UI_To_Int (Slot_Number (Int_Alias))); - Write_Char (':'); - Write_Name (Chars (Find_Dispatching_Type (Int_Alias))); - end if; - - Next_Elmt (Prim_Elmt); - end loop; - end; - end if; - - <<Continue>> - Next_Elmt (Elmt); - end loop; - - Write_Char ('"'); - Write_Eol; - - Write_Char ('}'); - Write_Eol; - end Write_Type_Info; - -end Exp_CG; |