diff options
Diffstat (limited to 'gcc-4.8.3/gcc/ada/exp_alfa.adb')
-rw-r--r-- | gcc-4.8.3/gcc/ada/exp_alfa.adb | 321 |
1 files changed, 321 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/exp_alfa.adb b/gcc-4.8.3/gcc/ada/exp_alfa.adb new file mode 100644 index 000000000..69a6e2b0c --- /dev/null +++ b/gcc-4.8.3/gcc/ada/exp_alfa.adb @@ -0,0 +1,321 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A L F A -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 Exp_Attr; use Exp_Attr; +with Exp_Ch4; use Exp_Ch4; +with Exp_Ch6; use Exp_Ch6; +with Exp_Dbug; use Exp_Dbug; +with Exp_Util; use Exp_Util; +with Nlists; use Nlists; +with Rtsfind; use Rtsfind; +with Sem_Aux; use Sem_Aux; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; + +package body Exp_Alfa is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Expand_Alfa_Call (N : Node_Id); + -- This procedure contains common processing for function and procedure + -- calls: + -- * expansion of actuals to introduce necessary temporaries + -- * replacement of renaming by subprogram renamed + + procedure Expand_Alfa_N_Attribute_Reference (N : Node_Id); + -- Expand attributes 'Old and 'Result only + + procedure Expand_Alfa_N_In (N : Node_Id); + -- Expand set membership into individual ones + + procedure Expand_Alfa_N_Object_Renaming_Declaration (N : Node_Id); + -- Perform name evaluation for a renamed object + + procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id); + -- Insert conversion on function return if necessary + + procedure Expand_Alfa_Simple_Function_Return (N : Node_Id); + -- Expand simple return from function + + procedure Expand_Potential_Renaming (N : Node_Id); + -- N denotes a N_Identifier or N_Expanded_Name. If N references a renaming, + -- replace N with the renamed object. + + ----------------- + -- Expand_Alfa -- + ----------------- + + procedure Expand_Alfa (N : Node_Id) is + begin + case Nkind (N) is + when N_Attribute_Reference => + Expand_Alfa_N_Attribute_Reference (N); + + -- Qualification of entity names in formal verification mode + -- is limited to the addition of a suffix for homonyms (see + -- Exp_Dbug.Qualify_Entity_Name). We used to qualify entity names + -- as full expansion does, but this was removed as this prevents the + -- verification back-end from using a short name for debugging and + -- user interaction. The verification back-end already takes care + -- of qualifying names when needed. + + when N_Block_Statement | + N_Package_Body | + N_Package_Declaration | + N_Subprogram_Body => + Qualify_Entity_Names (N); + + when N_Subprogram_Call => + Expand_Alfa_Call (N); + + when N_Expanded_Name | + N_Identifier => + Expand_Potential_Renaming (N); + + when N_In => + Expand_Alfa_N_In (N); + + -- A NOT IN B gets transformed to NOT (A IN B). This is the same + -- expansion used in the normal case, so shared the code. + + when N_Not_In => + Expand_N_Not_In (N); + + when N_Object_Renaming_Declaration => + Expand_Alfa_N_Object_Renaming_Declaration (N); + + when N_Simple_Return_Statement => + Expand_Alfa_N_Simple_Return_Statement (N); + + -- In Alfa mode, no other constructs require expansion + + when others => + null; + end case; + end Expand_Alfa; + + ---------------------- + -- Expand_Alfa_Call -- + ---------------------- + + procedure Expand_Alfa_Call (N : Node_Id) is + Call_Node : constant Node_Id := N; + Parent_Subp : Entity_Id; + Subp : Entity_Id; + + begin + -- Ignore if previous error + + if Nkind (Call_Node) in N_Has_Etype + and then Etype (Call_Node) = Any_Type + then + return; + end if; + + -- Call using access to subprogram with explicit dereference + + if Nkind (Name (Call_Node)) = N_Explicit_Dereference then + Subp := Etype (Name (Call_Node)); + Parent_Subp := Empty; + + -- Case of call to simple entry, where the Name is a selected component + -- whose prefix is the task, and whose selector name is the entry name + + elsif Nkind (Name (Call_Node)) = N_Selected_Component then + Subp := Entity (Selector_Name (Name (Call_Node))); + Parent_Subp := Empty; + + -- Case of call to member of entry family, where Name is an indexed + -- component, with the prefix being a selected component giving the + -- task and entry family name, and the index being the entry index. + + elsif Nkind (Name (Call_Node)) = N_Indexed_Component then + Subp := Entity (Selector_Name (Prefix (Name (Call_Node)))); + Parent_Subp := Empty; + + -- Normal case + + else + Subp := Entity (Name (Call_Node)); + Parent_Subp := Alias (Subp); + end if; + + -- Various expansion activities for actuals are carried out + + Expand_Actuals (N, Subp); + + -- If the subprogram is a renaming, replace it in the call with the name + -- of the actual subprogram being called. + + if Present (Parent_Subp) then + Parent_Subp := Ultimate_Alias (Parent_Subp); + + -- The below setting of Entity is suspect, see F109-018 discussion??? + + Set_Entity (Name (Call_Node), Parent_Subp); + end if; + end Expand_Alfa_Call; + + --------------------------------------- + -- Expand_Alfa_N_Attribute_Reference -- + --------------------------------------- + + procedure Expand_Alfa_N_Attribute_Reference (N : Node_Id) is + Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); + + begin + case Id is + when Attribute_Old | + Attribute_Result => + Expand_N_Attribute_Reference (N); + + when others => + null; + end case; + end Expand_Alfa_N_Attribute_Reference; + + ---------------------- + -- Expand_Alfa_N_In -- + ---------------------- + + procedure Expand_Alfa_N_In (N : Node_Id) is + begin + if Present (Alternatives (N)) then + Expand_Set_Membership (N); + end if; + end Expand_Alfa_N_In; + + ----------------------------------------------- + -- Expand_Alfa_N_Object_Renaming_Declaration -- + ----------------------------------------------- + + procedure Expand_Alfa_N_Object_Renaming_Declaration (N : Node_Id) is + begin + -- Unconditionally remove all side effects from the name + + Evaluate_Name (Name (N)); + end Expand_Alfa_N_Object_Renaming_Declaration; + + ------------------------------------------- + -- Expand_Alfa_N_Simple_Return_Statement -- + ------------------------------------------- + + procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id) is + begin + -- Defend against previous errors (i.e. the return statement calls a + -- function that is not available in configurable runtime). + + if Present (Expression (N)) + and then Nkind (Expression (N)) = N_Empty + then + return; + end if; + + -- Distinguish the function and non-function cases: + + case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is + + when E_Function | + E_Generic_Function => + Expand_Alfa_Simple_Function_Return (N); + + when E_Procedure | + E_Generic_Procedure | + E_Entry | + E_Entry_Family | + E_Return_Statement => + null; + + when others => + raise Program_Error; + end case; + + exception + when RE_Not_Available => + return; + end Expand_Alfa_N_Simple_Return_Statement; + + ---------------------------------------- + -- Expand_Alfa_Simple_Function_Return -- + ---------------------------------------- + + procedure Expand_Alfa_Simple_Function_Return (N : Node_Id) is + Scope_Id : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (N)); + -- The function we are returning from + + R_Type : constant Entity_Id := Etype (Scope_Id); + -- The result type of the function + + Exp : constant Node_Id := Expression (N); + pragma Assert (Present (Exp)); + + Exptyp : constant Entity_Id := Etype (Exp); + -- The type of the expression (not necessarily the same as R_Type) + + begin + -- Check the result expression of a scalar function against the subtype + -- of the function by inserting a conversion. This conversion must + -- eventually be performed for other classes of types, but for now it's + -- only done for scalars. + -- ??? + + if Is_Scalar_Type (Exptyp) then + Rewrite (Exp, Convert_To (R_Type, Exp)); + + -- The expression is resolved to ensure that the conversion gets + -- expanded to generate a possible constraint check. + + Analyze_And_Resolve (Exp, R_Type); + end if; + end Expand_Alfa_Simple_Function_Return; + + ------------------------------- + -- Expand_Potential_Renaming -- + ------------------------------- + + procedure Expand_Potential_Renaming (N : Node_Id) is + E : constant Entity_Id := Entity (N); + T : constant Entity_Id := Etype (N); + + begin + -- Replace a reference to a renaming with the actual renamed object + + if Ekind (E) in Object_Kind and then Present (Renamed_Object (E)) then + Rewrite (N, New_Copy_Tree (Renamed_Object (E))); + Reset_Analyzed_Flags (N); + Analyze_And_Resolve (N, T); + end if; + end Expand_Potential_Renaming; + +end Exp_Alfa; |