------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 1 3 -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2013, 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))); -- If the clause is not generated by an aspect, insert -- the assignment here. Freezing rules ensure that this -- is safe, or clause will have been rejected already. if Is_List_Member (N) then Insert_After (N, Assign); -- Otherwise, insert assignment after task declaration. else Insert_After (Parent (Storage_Size_Variable (Entity (N))), Assign); end if; 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; -- All other freezing actions 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;