diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/exp_ch13.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/exp_ch13.adb | 651 |
1 files changed, 0 insertions, 651 deletions
diff --git a/gcc-4.8/gcc/ada/exp_ch13.adb b/gcc-4.8/gcc/ada/exp_ch13.adb deleted file mode 100644 index 141e144ab..000000000 --- a/gcc-4.8/gcc/ada/exp_ch13.adb +++ /dev/null @@ -1,651 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- E X P _ C H 1 3 -- --- -- --- 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 Checks; use Checks; -with Einfo; use Einfo; -with Exp_Ch3; use Exp_Ch3; -with Exp_Ch6; use Exp_Ch6; -with Exp_Imgv; use Exp_Imgv; -with Exp_Tss; use Exp_Tss; -with Exp_Util; use Exp_Util; -with Namet; use Namet; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Opt; use Opt; -with Restrict; use Restrict; -with Rident; use Rident; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Ch7; use Sem_Ch7; -with Sem_Ch8; use Sem_Ch8; -with Sem_Eval; use Sem_Eval; -with Sem_Util; use Sem_Util; -with Sinfo; use Sinfo; -with Snames; use Snames; -with Targparm; use Targparm; -with Tbuild; use Tbuild; -with Uintp; use Uintp; -with Validsw; use Validsw; - -package body Exp_Ch13 is - - ------------------------------------------ - -- Expand_N_Attribute_Definition_Clause -- - ------------------------------------------ - - -- Expansion action depends on attribute involved - - procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Exp : constant Node_Id := Expression (N); - Ent : Entity_Id; - V : Node_Id; - - begin - Ent := Entity (Name (N)); - - if Is_Type (Ent) then - Ent := Underlying_Type (Ent); - end if; - - case Get_Attribute_Id (Chars (N)) is - - ------------- - -- Address -- - ------------- - - when Attribute_Address => - - -- If there is an initialization which did not come from the - -- source program, then it is an artifact of our expansion, and we - -- suppress it. The case we are most concerned about here is the - -- initialization of a packed array to all false, which seems - -- inappropriate for variable to which an address clause is - -- applied. The expression may itself have been rewritten if the - -- type is packed array, so we need to examine whether the - -- original node is in the source. An exception though is the case - -- of an access variable which is default initialized to null, and - -- such initialization is retained. - - -- Furthermore, if the initialization is the equivalent aggregate - -- of the type initialization procedure, it replaces an implicit - -- call to the init proc, and must be respected. Note that for - -- packed types we do not build equivalent aggregates. - - -- Also, if Init_Or_Norm_Scalars applies, then we need to retain - -- any default initialization for objects of scalar types and - -- types with scalar components. Normally a composite type will - -- have an init_proc in the presence of Init_Or_Norm_Scalars, - -- so when that flag is set we have just have to do a test for - -- scalar and string types (the predefined string types such as - -- String and Wide_String don't have an init_proc). - - declare - Decl : constant Node_Id := Declaration_Node (Ent); - Typ : constant Entity_Id := Etype (Ent); - - begin - if Nkind (Decl) = N_Object_Declaration - and then Present (Expression (Decl)) - and then Nkind (Expression (Decl)) /= N_Null - and then - not Comes_From_Source (Original_Node (Expression (Decl))) - then - if Present (Base_Init_Proc (Typ)) - and then - Present (Static_Initialization (Base_Init_Proc (Typ))) - then - null; - - elsif Init_Or_Norm_Scalars - and then - (Is_Scalar_Type (Typ) or else Is_String_Type (Typ)) - then - null; - - else - Set_Expression (Decl, Empty); - end if; - - -- An object declaration to which an address clause applies - -- has a delayed freeze, but the address expression itself - -- must be elaborated at the point it appears. If the object - -- is controlled, additional checks apply elsewhere. - - elsif Nkind (Decl) = N_Object_Declaration - and then not Needs_Constant_Address (Decl, Typ) - then - Remove_Side_Effects (Exp); - end if; - end; - - --------------- - -- Alignment -- - --------------- - - when Attribute_Alignment => - - -- As required by Gigi, we guarantee that the operand is an - -- integer literal (this simplifies things in Gigi). - - if Nkind (Exp) /= N_Integer_Literal then - Rewrite - (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp))); - end if; - - ------------------ - -- Storage_Size -- - ------------------ - - when Attribute_Storage_Size => - - -- If the type is a task type, then assign the value of the - -- storage size to the Size variable associated with the task. - -- Insert the assignment right after the declaration of the Size - -- variable. - - -- Generate: - - -- task_typeZ := expression - - if Ekind (Ent) = E_Task_Type then - declare - Assign : Node_Id; - - begin - Assign := - Make_Assignment_Statement (Loc, - Name => - New_Reference_To (Storage_Size_Variable (Ent), Loc), - Expression => - Convert_To (RTE (RE_Size_Type), Expression (N))); - - Insert_After - (Parent (Storage_Size_Variable (Entity (N))), Assign); - - Analyze (Assign); - end; - - -- For Storage_Size for an access type, create a variable to hold - -- the value of the specified size with name typeV and expand an - -- assignment statement to initialize this value. - - elsif Is_Access_Type (Ent) then - - -- We don't need the variable for a storage size of zero - - if not No_Pool_Assigned (Ent) then - V := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Ent), 'V')); - - -- Insert the declaration of the object - - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => V, - Object_Definition => - New_Reference_To (RTE (RE_Storage_Offset), Loc), - Expression => - Convert_To (RTE (RE_Storage_Offset), Expression (N)))); - - Set_Storage_Size_Variable (Ent, Entity_Id (V)); - end if; - end if; - - -- Other attributes require no expansion - - when others => - null; - - end case; - end Expand_N_Attribute_Definition_Clause; - - ----------------------------- - -- Expand_N_Free_Statement -- - ----------------------------- - - procedure Expand_N_Free_Statement (N : Node_Id) is - Expr : constant Node_Id := Expression (N); - Typ : Entity_Id; - - begin - -- Certain run-time configurations and targets do not provide support - -- for controlled types. - - if Restriction_Active (No_Finalization) then - return; - - -- Do not create a specialized Deallocate since .NET/JVM compilers do - -- not support pools and address arithmetic. - - elsif VM_Target /= No_VM then - return; - end if; - - -- Use the base type to perform the check for finalization master - - Typ := Etype (Expr); - - if Ekind (Typ) = E_Access_Subtype then - Typ := Etype (Typ); - end if; - - -- Handle private access types - - if Is_Private_Type (Typ) - and then Present (Full_View (Typ)) - then - Typ := Full_View (Typ); - end if; - - -- Do not create a custom Deallocate when freeing an object with - -- suppressed finalization. In such cases the object is never attached - -- to a master, so it does not need to be detached. Use a regular free - -- statement instead. - - if No (Finalization_Master (Typ)) then - return; - end if; - - -- Use a temporary to store the result of a complex expression. Perform - -- the following transformation: - -- - -- Free (Complex_Expression); - -- - -- Temp : constant Type_Of_Expression := Complex_Expression; - -- Free (Temp); - - if Nkind (Expr) /= N_Identifier then - declare - Expr_Typ : constant Entity_Id := Etype (Expr); - Loc : constant Source_Ptr := Sloc (N); - New_Expr : Node_Id; - Temp_Id : Entity_Id; - - begin - Temp_Id := Make_Temporary (Loc, 'T'); - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => Temp_Id, - Object_Definition => - New_Reference_To (Expr_Typ, Loc), - Expression => - Relocate_Node (Expr))); - - New_Expr := New_Reference_To (Temp_Id, Loc); - Set_Etype (New_Expr, Expr_Typ); - - Set_Expression (N, New_Expr); - end; - end if; - - -- Create a custom Deallocate for a controlled object. This routine - -- ensures that the hidden list header will be deallocated along with - -- the actual object. - - Build_Allocate_Deallocate_Proc (N, Is_Allocate => False); - end Expand_N_Free_Statement; - - ---------------------------- - -- Expand_N_Freeze_Entity -- - ---------------------------- - - procedure Expand_N_Freeze_Entity (N : Node_Id) is - E : constant Entity_Id := Entity (N); - E_Scope : Entity_Id; - In_Other_Scope : Boolean; - In_Outer_Scope : Boolean; - Decl : Node_Id; - Delete : Boolean := False; - - begin - -- If there are delayed aspect specifications, we insert them just - -- before the freeze node. They are already analyzed so we don't need - -- to reanalyze them (they were analyzed before the type was frozen), - -- but we want them in the tree for the back end, and so that the - -- listing from sprint is clearer on where these occur logically. - - if Has_Delayed_Aspects (E) then - declare - Aitem : Node_Id; - Ritem : Node_Id; - - begin - -- Look for aspect specs for this entity - - Ritem := First_Rep_Item (E); - while Present (Ritem) loop - if Nkind (Ritem) = N_Aspect_Specification - and then Entity (Ritem) = E - then - Aitem := Aspect_Rep_Item (Ritem); - - -- Skip this for aspects (e.g. Current_Value) for which - -- there is no corresponding pragma or attribute. - - if Present (Aitem) then - pragma Assert (Is_Delayed_Aspect (Aitem)); - Insert_Before (N, Aitem); - end if; - end if; - - Next_Rep_Item (Ritem); - end loop; - end; - end if; - - -- Processing for objects with address clauses - - if Is_Object (E) and then Present (Address_Clause (E)) then - Apply_Address_Clause_Check (E, N); - return; - - -- Only other items requiring any front end action are types and - -- subprograms. - - elsif not Is_Type (E) and then not Is_Subprogram (E) then - return; - end if; - - -- Here E is a type or a subprogram - - E_Scope := Scope (E); - - -- This is an error protection against previous errors - - if No (E_Scope) then - Check_Error_Detected; - return; - end if; - - -- Remember that we are processing a freezing entity and its freezing - -- nodes. This flag (non-zero = set) is used to avoid the need of - -- climbing through the tree while processing the freezing actions (ie. - -- to avoid generating spurious warnings or to avoid killing constant - -- indications while processing the code associated with freezing - -- actions). We use a counter to deal with nesting. - - Inside_Freezing_Actions := Inside_Freezing_Actions + 1; - - -- If we are freezing entities defined in protected types, they belong - -- in the enclosing scope, given that the original type has been - -- expanded away. The same is true for entities in task types, in - -- particular the parameter records of entries (Entities in bodies are - -- all frozen within the body). If we are in the task body, this is a - -- proper scope. If we are within a subprogram body, the proper scope - -- is the corresponding spec. This may happen for itypes generated in - -- the bodies of protected operations. - - if Ekind (E_Scope) = E_Protected_Type - or else (Ekind (E_Scope) = E_Task_Type - and then not Has_Completion (E_Scope)) - then - E_Scope := Scope (E_Scope); - - elsif Ekind (E_Scope) = E_Subprogram_Body then - E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope)); - end if; - - -- If the scope of the entity is in open scopes, it is the current one - -- or an enclosing one, including a loop, a block, or a subprogram. - - if In_Open_Scopes (E_Scope) then - In_Other_Scope := False; - In_Outer_Scope := E_Scope /= Current_Scope; - - -- Otherwise it is a local package or a different compilation unit - - else - In_Other_Scope := True; - In_Outer_Scope := False; - end if; - - -- If the entity being frozen is defined in a scope that is not - -- currently on the scope stack, we must establish the proper - -- visibility before freezing the entity and related subprograms. - - if In_Other_Scope then - Push_Scope (E_Scope); - - -- Finalizers are little odd in terms of freezing. The spec of the - -- procedure appears in the declarations while the body appears in - -- the statement part of a single construct. Since the finalizer must - -- be called by the At_End handler of the construct, the spec is - -- manually frozen right after its declaration. The only side effect - -- of this action appears in contexts where the construct is not in - -- its final resting place. These contexts are: - - -- * Entry bodies - The declarations and statements are moved to - -- the procedure equivalen of the entry. - -- * Protected subprograms - The declarations and statements are - -- moved to the non-protected version of the subprogram. - -- * Task bodies - The declarations and statements are moved to the - -- task body procedure. - - -- Visible declarations do not need to be installed in these three - -- cases since it does not make semantic sense to do so. All entities - -- referenced by a finalizer are visible and already resolved, plus - -- the enclosing scope may not have visible declarations at all. - - if Ekind (E) = E_Procedure - and then Is_Finalizer (E) - and then - (Is_Entry (E_Scope) - or else (Is_Subprogram (E_Scope) - and then Is_Protected_Type (Scope (E_Scope))) - or else Is_Task_Type (E_Scope)) - then - null; - else - Install_Visible_Declarations (E_Scope); - end if; - - if Is_Package_Or_Generic_Package (E_Scope) or else - Is_Protected_Type (E_Scope) or else - Is_Task_Type (E_Scope) - then - Install_Private_Declarations (E_Scope); - end if; - - -- If the entity is in an outer scope, then that scope needs to - -- temporarily become the current scope so that operations created - -- during type freezing will be declared in the right scope and - -- can properly override any corresponding inherited operations. - - elsif In_Outer_Scope then - Push_Scope (E_Scope); - end if; - - -- If type, freeze the type - - if Is_Type (E) then - Delete := Freeze_Type (N); - - -- And for enumeration type, build the enumeration tables - - if Is_Enumeration_Type (E) then - Build_Enumeration_Image_Tables (E, N); - end if; - - -- If subprogram, freeze the subprogram - - elsif Is_Subprogram (E) then - Freeze_Subprogram (N); - - -- Ada 2005 (AI-251): Remove the freezing node associated with the - -- entities internally used by the frontend to register primitives - -- covering abstract interfaces. The call to Freeze_Subprogram has - -- already expanded the code that fills the corresponding entry in - -- its secondary dispatch table and therefore the code generator - -- has nothing else to do with this freezing node. - - Delete := Present (Interface_Alias (E)); - end if; - - -- Analyze actions generated by freezing. The init_proc contains source - -- expressions that may raise Constraint_Error, and the assignment - -- procedure for complex types needs checks on individual component - -- assignments, but all other freezing actions should be compiled with - -- all checks off. - - if Present (Actions (N)) then - Decl := First (Actions (N)); - while Present (Decl) loop - if Nkind (Decl) = N_Subprogram_Body - and then (Is_Init_Proc (Defining_Entity (Decl)) - or else - Chars (Defining_Entity (Decl)) = Name_uAssign) - then - Analyze (Decl); - - -- A subprogram body created for a renaming_as_body completes - -- a previous declaration, which may be in a different scope. - -- Establish the proper scope before analysis. - - elsif Nkind (Decl) = N_Subprogram_Body - and then Present (Corresponding_Spec (Decl)) - and then Scope (Corresponding_Spec (Decl)) /= Current_Scope - then - Push_Scope (Scope (Corresponding_Spec (Decl))); - Analyze (Decl, Suppress => All_Checks); - Pop_Scope; - - -- We treat generated equality specially, if validity checks are - -- enabled, in order to detect components default-initialized - -- with invalid values. - - elsif Nkind (Decl) = N_Subprogram_Body - and then Chars (Defining_Entity (Decl)) = Name_Op_Eq - and then Validity_Checks_On - and then Initialize_Scalars - then - declare - Save_Force : constant Boolean := Force_Validity_Checks; - begin - Force_Validity_Checks := True; - Analyze (Decl); - Force_Validity_Checks := Save_Force; - end; - - else - Analyze (Decl, Suppress => All_Checks); - end if; - - Next (Decl); - end loop; - end if; - - -- If we are to delete this N_Freeze_Entity, do so by rewriting so that - -- a loop on all nodes being inserted will work propertly. - - if Delete then - Rewrite (N, Make_Null_Statement (Sloc (N))); - end if; - - -- Pop scope if we installed one for the analysis - - if In_Other_Scope then - if Ekind (Current_Scope) = E_Package then - End_Package_Scope (E_Scope); - else - End_Scope; - end if; - - elsif In_Outer_Scope then - Pop_Scope; - end if; - - -- Restore previous value of the nesting-level counter that records - -- whether we are inside a (possibly nested) call to this procedure. - - Inside_Freezing_Actions := Inside_Freezing_Actions - 1; - end Expand_N_Freeze_Entity; - - ------------------------------------------- - -- Expand_N_Record_Representation_Clause -- - ------------------------------------------- - - -- The only expansion required is for the case of a mod clause present, - -- which is removed, and translated into an alignment representation - -- clause inserted immediately after the record rep clause with any - -- initial pragmas inserted at the start of the component clause list. - - procedure Expand_N_Record_Representation_Clause (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Rectype : constant Entity_Id := Entity (Identifier (N)); - Mod_Val : Uint; - Citems : List_Id; - Repitem : Node_Id; - AtM_Nod : Node_Id; - - begin - if Present (Mod_Clause (N)) and then not Ignore_Rep_Clauses then - Mod_Val := Expr_Value (Expression (Mod_Clause (N))); - Citems := Pragmas_Before (Mod_Clause (N)); - - if Present (Citems) then - Append_List_To (Citems, Component_Clauses (N)); - Set_Component_Clauses (N, Citems); - end if; - - AtM_Nod := - Make_Attribute_Definition_Clause (Loc, - Name => New_Reference_To (Base_Type (Rectype), Loc), - Chars => Name_Alignment, - Expression => Make_Integer_Literal (Loc, Mod_Val)); - - Set_From_At_Mod (AtM_Nod); - Insert_After (N, AtM_Nod); - Set_Mod_Clause (N, Empty); - end if; - - -- If the record representation clause has no components, then - -- completely remove it. Note that we also have to remove - -- ourself from the Rep Item list. - - if Is_Empty_List (Component_Clauses (N)) then - if First_Rep_Item (Rectype) = N then - Set_First_Rep_Item (Rectype, Next_Rep_Item (N)); - else - Repitem := First_Rep_Item (Rectype); - while Present (Next_Rep_Item (Repitem)) loop - if Next_Rep_Item (Repitem) = N then - Set_Next_Rep_Item (Repitem, Next_Rep_Item (N)); - exit; - end if; - - Next_Rep_Item (Repitem); - end loop; - end if; - - Rewrite (N, - Make_Null_Statement (Loc)); - end if; - end Expand_N_Record_Representation_Clause; - -end Exp_Ch13; |