diff options
Diffstat (limited to 'gcc-4.7/gcc/ada/exp_ch8.adb')
| -rw-r--r-- | gcc-4.7/gcc/ada/exp_ch8.adb | 331 |
1 files changed, 331 insertions, 0 deletions
diff --git a/gcc-4.7/gcc/ada/exp_ch8.adb b/gcc-4.7/gcc/ada/exp_ch8.adb new file mode 100644 index 000000000..a0e9d4cf1 --- /dev/null +++ b/gcc-4.7/gcc/ada/exp_ch8.adb @@ -0,0 +1,331 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2011, 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_Ch4; use Exp_Ch4; +with Exp_Ch6; use Exp_Ch6; +with Exp_Dbug; use Exp_Dbug; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +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_Ch8 is + + --------------------------------------------- + -- Expand_N_Exception_Renaming_Declaration -- + --------------------------------------------- + + procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is + Decl : constant Node_Id := Debug_Renaming_Declaration (N); + begin + if Present (Decl) then + Insert_Action (N, Decl); + end if; + end Expand_N_Exception_Renaming_Declaration; + + ------------------------------------------ + -- Expand_N_Object_Renaming_Declaration -- + ------------------------------------------ + + -- Most object renaming cases can be done by just capturing the address + -- of the renamed object. The cases in which this is not true are when + -- this address is not computable, since it involves extraction of a + -- packed array element, or of a record component to which a component + -- clause applies (that can specify an arbitrary bit boundary), or where + -- the enclosing record itself has a non-standard representation. + + -- In these two cases, we pre-evaluate the renaming expression, by + -- extracting and freezing the values of any subscripts, and then we + -- set the flag Is_Renaming_Of_Object which means that any reference + -- to the object will be handled by macro substitution in the front + -- end, and the back end will know to ignore the renaming declaration. + + -- An additional odd case that requires processing by expansion is + -- the renaming of a discriminant of a mutable record type. The object + -- is a constant because it renames something that cannot be assigned to, + -- but in fact the underlying value can change and must be reevaluated + -- at each reference. Gigi does have a notion of a "constant view" of + -- an object, and therefore the front-end must perform the expansion. + -- For simplicity, and to bypass some obscure code-generation problem, + -- we use macro substitution for all renamed discriminants, whether the + -- enclosing type is constrained or not. + + -- The other special processing required is for the case of renaming + -- of an object of a class wide type, where it is necessary to build + -- the appropriate subtype for the renamed object. + -- More comments needed for this para ??? + + procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is + Nam : constant Node_Id := Name (N); + Decl : Node_Id; + T : Entity_Id; + + function Evaluation_Required (Nam : Node_Id) return Boolean; + -- Determines whether it is necessary to do static name evaluation for + -- renaming of Nam. It is considered necessary if evaluating the name + -- involves indexing a packed array, or extracting a component of a + -- record to which a component clause applies. Note that we are only + -- interested in these operations if they occur as part of the name + -- itself, subscripts are just values that are computed as part of the + -- evaluation, so their form is unimportant. + + ------------------------- + -- Evaluation_Required -- + ------------------------- + + function Evaluation_Required (Nam : Node_Id) return Boolean is + begin + if Nkind_In (Nam, N_Indexed_Component, N_Slice) then + if Is_Packed (Etype (Prefix (Nam))) then + return True; + else + return Evaluation_Required (Prefix (Nam)); + end if; + + elsif Nkind (Nam) = N_Selected_Component then + declare + Rec_Type : constant Entity_Id := Etype (Prefix (Nam)); + + begin + if Present (Component_Clause (Entity (Selector_Name (Nam)))) + or else Has_Non_Standard_Rep (Rec_Type) + then + return True; + + elsif Ekind (Entity (Selector_Name (Nam))) = E_Discriminant + and then Is_Record_Type (Rec_Type) + and then not Is_Concurrent_Record_Type (Rec_Type) + then + return True; + + else + return Evaluation_Required (Prefix (Nam)); + end if; + end; + + else + return False; + end if; + end Evaluation_Required; + + -- Start of processing for Expand_N_Object_Renaming_Declaration + + begin + -- Perform name evaluation if required + + if Evaluation_Required (Nam) then + Evaluate_Name (Nam); + Set_Is_Renaming_Of_Object (Defining_Identifier (N)); + end if; + + -- Deal with construction of subtype in class-wide case + + T := Etype (Defining_Identifier (N)); + + if Is_Class_Wide_Type (T) then + Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N)); + Find_Type (Subtype_Mark (N)); + Set_Etype (Defining_Identifier (N), Entity (Subtype_Mark (N))); + + -- Freeze the class-wide subtype here to ensure that the subtype + -- and equivalent type are frozen before the renaming. + + Freeze_Before (N, Entity (Subtype_Mark (N))); + end if; + + -- Ada 2005 (AI-318-02): If the renamed object is a call to a build-in- + -- place function, then a temporary return object needs to be created + -- and access to it must be passed to the function. Currently we limit + -- such functions to those with inherently limited result subtypes, but + -- eventually we plan to expand the functions that are treated as + -- build-in-place to include other composite result types. + + if Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function_Call (Nam) + then + Make_Build_In_Place_Call_In_Anonymous_Context (Nam); + end if; + + -- Create renaming entry for debug information + + Decl := Debug_Renaming_Declaration (N); + + if Present (Decl) then + Insert_Action (N, Decl); + end if; + end Expand_N_Object_Renaming_Declaration; + + ------------------------------------------- + -- Expand_N_Package_Renaming_Declaration -- + ------------------------------------------- + + procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is + Decl : constant Node_Id := Debug_Renaming_Declaration (N); + + begin + if Present (Decl) then + + -- If we are in a compilation unit, then this is an outer + -- level declaration, and must have a scope of Standard + + if Nkind (Parent (N)) = N_Compilation_Unit then + declare + Aux : constant Node_Id := Aux_Decls_Node (Parent (N)); + + begin + Push_Scope (Standard_Standard); + + if No (Actions (Aux)) then + Set_Actions (Aux, New_List (Decl)); + else + Append (Decl, Actions (Aux)); + end if; + + Analyze (Decl); + + -- Enter the debug variable in the qualification list, which + -- must be done at this point because auxiliary declarations + -- occur at the library level and aren't associated with a + -- normal scope. + + Qualify_Entity_Names (Decl); + + Pop_Scope; + end; + + -- Otherwise, just insert after the package declaration + + else + Insert_Action (N, Decl); + end if; + end if; + end Expand_N_Package_Renaming_Declaration; + + ---------------------------------------------- + -- Expand_N_Subprogram_Renaming_Declaration -- + ---------------------------------------------- + + procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is + Nam : constant Node_Id := Name (N); + + begin + -- When the prefix of the name is a function call, we must force the + -- call to be made by removing side effects from the call, since we + -- must only call the function once. + + if Nkind (Nam) = N_Selected_Component + and then Nkind (Prefix (Nam)) = N_Function_Call + then + Remove_Side_Effects (Prefix (Nam)); + + -- For an explicit dereference, the prefix must be captured to prevent + -- reevaluation on calls through the renaming, which could result in + -- calling the wrong subprogram if the access value were to be changed. + + elsif Nkind (Nam) = N_Explicit_Dereference then + Force_Evaluation (Prefix (Nam)); + end if; + + -- Check whether this is a renaming of a predefined equality on an + -- untagged record type (AI05-0123). + + if Is_Entity_Name (Nam) + and then Chars (Entity (Nam)) = Name_Op_Eq + and then Scope (Entity (Nam)) = Standard_Standard + and then Ada_Version >= Ada_2012 + then + declare + Loc : constant Source_Ptr := Sloc (N); + Id : constant Entity_Id := Defining_Entity (N); + Typ : constant Entity_Id := Etype (First_Formal (Id)); + + Decl : Node_Id; + Body_Id : constant Entity_Id := + Make_Defining_Identifier (Sloc (N), Chars (Id)); + + begin + if Is_Record_Type (Typ) + and then not Is_Tagged_Type (Typ) + and then not Is_Frozen (Typ) + then + -- Build body for renamed equality, to capture its current + -- meaning. It may be redefined later, but the renaming is + -- elaborated where it occurs. This is technically known as + -- Squirreling semantics. Renaming is rewritten as a subprogram + -- declaration, and the body is inserted at the end of the + -- current declaration list to prevent premature freezing. + + Set_Alias (Id, Empty); + Set_Has_Completion (Id, False); + Rewrite (N, + Make_Subprogram_Declaration (Sloc (N), + Specification => Specification (N))); + Set_Has_Delayed_Freeze (Id); + + Decl := Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Body_Id, + Parameter_Specifications => + Copy_Parameter_List (Id), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)), + Declarations => Empty_List, + Handled_Statement_Sequence => Empty); + + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Expand_Record_Equality + (Id, + Typ => Typ, + Lhs => + Make_Identifier (Loc, Chars (First_Formal (Id))), + Rhs => + Make_Identifier + (Loc, Chars (Next_Formal (First_Formal (Id)))), + Bodies => Declarations (Decl)))))); + + Append (Decl, List_Containing (N)); + Set_Debug_Info_Needed (Body_Id); + end if; + end; + end if; + end Expand_N_Subprogram_Renaming_Declaration; + +end Exp_Ch8; |