diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/exp_ch8.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/exp_ch8.adb | 354 |
1 files changed, 0 insertions, 354 deletions
diff --git a/gcc-4.8/gcc/ada/exp_ch8.adb b/gcc-4.8/gcc/ada/exp_ch8.adb deleted file mode 100644 index 3b5c7d3ae..000000000 --- a/gcc-4.8/gcc/ada/exp_ch8.adb +++ /dev/null @@ -1,354 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- E X P _ C H 8 -- --- -- --- 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_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 - Loc : constant Source_Ptr := Sloc (N); - Id : constant Entity_Id := Defining_Entity (N); - - function Build_Body_For_Renaming return Node_Id; - -- Build and return the body for the renaming declaration of an equality - -- or inequality operator. - - ----------------------------- - -- Build_Body_For_Renaming -- - ----------------------------- - - function Build_Body_For_Renaming return Node_Id is - Body_Id : Entity_Id; - Decl : Node_Id; - - begin - Set_Alias (Id, Empty); - Set_Has_Completion (Id, False); - Rewrite (N, - Make_Subprogram_Declaration (Sloc (N), - Specification => Specification (N))); - Set_Has_Delayed_Freeze (Id); - - Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id)); - Set_Debug_Info_Needed (Body_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); - - return Decl; - end Build_Body_For_Renaming; - - -- Local variables - - Nam : constant Node_Id := Name (N); - - -- Start of processing for Expand_N_Subprogram_Renaming_Declaration - - 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; - - -- Handle cases where we build a body for a renamed equality - - if Is_Entity_Name (Nam) - and then Chars (Entity (Nam)) = Name_Op_Eq - and then Scope (Entity (Nam)) = Standard_Standard - then - declare - Left : constant Entity_Id := First_Formal (Id); - Right : constant Entity_Id := Next_Formal (Left); - Typ : constant Entity_Id := Etype (Left); - Decl : Node_Id; - - begin - -- Check whether this is a renaming of a predefined equality on an - -- untagged record type (AI05-0123). - - if Ada_Version >= Ada_2012 - and then 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. - - Decl := Build_Body_For_Renaming; - - 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 (Left)), - Rhs => Make_Identifier (Loc, Chars (Right)), - Bodies => Declarations (Decl)))))); - - Append (Decl, List_Containing (N)); - end if; - end; - end if; - end Expand_N_Subprogram_Renaming_Declaration; - -end Exp_Ch8; |