-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- 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 2, or (at your option) any later ver- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
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 Stand; use Stand;
-with Stringt; use Stringt;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
+with Validsw; use Validsw;
package body Exp_Ch13 is
- procedure Expand_External_Tag_Definition (N : Node_Id);
- -- The code to assign and register an external tag must be elaborated
- -- after the dispatch table has been created, so the expansion of the
- -- attribute definition node is delayed until after the type is frozen.
-
------------------------------------------
-- Expand_N_Attribute_Definition_Clause --
------------------------------------------
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 a
- -- variable to which an address clause is applied. The
- -- expression may itself have been rewritten if the type is a
- -- packed array, so we need to examine whether the original
- -- node is in the source.
+ -- 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
- Set_Expression (Decl, Empty);
+ 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;
-- 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 initialze this value.
+ -- assignment statement to initialize this value.
elsif Is_Access_Type (Ent) then
- V := Make_Defining_Identifier (Loc,
- New_External_Name (Chars (Ent), 'V'));
+ -- We don't need the variable for a storage size of zero
- 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))));
+ if not No_Pool_Assigned (Ent) then
+ V :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Ent), 'V'));
- Set_Storage_Size_Variable (Ent, Entity_Id (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
null;
end case;
-
end Expand_N_Attribute_Definition_Clause;
- -------------------------------------
- -- Expand_External_Tag_Definition --
- -------------------------------------
+ -----------------------------
+ -- Expand_N_Free_Statement --
+ -----------------------------
- procedure Expand_External_Tag_Definition (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Ent : constant Entity_Id := Entity (Name (N));
- E : Entity_Id;
- Old_Val : String_Id := Strval (Expr_Value_S (Expression (N)));
- New_Val : String_Id;
+ 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;
- -- For the rep clause "for x'external_tag use y" generate:
+ -- Do not create a specialized Deallocate since .NET/JVM compilers do
+ -- not support pools and address arithmetic.
- -- xV : constant string := y;
- -- Set_External_Tag (x'tag, xV'Address);
- -- Register_Tag (x'tag);
+ elsif VM_Target /= No_VM then
+ return;
+ end if;
- -- note that register_tag has been delayed up to now because
- -- the external_tag must be set before registering.
+ -- Use the base type to perform the check for finalization master
- -- Create a new nul terminated string if it is not already
+ Typ := Etype (Expr);
- if String_Length (Old_Val) > 0
- and then Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
+ 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
- New_Val := Old_Val;
- else
- Start_String (Old_Val);
- Store_String_Char (Get_Char_Code (ASCII.NUL));
- New_Val := End_String;
+ Typ := Full_View (Typ);
end if;
- E :=
- Make_Defining_Identifier (Loc,
- New_External_Name (Chars (Ent), 'A'));
-
- -- The generated actions must be elaborated at the subsequent
- -- freeze point, not at the point of the attribute definition.
-
- Append_Freeze_Action (Ent,
- Make_Object_Declaration (Loc,
- Defining_Identifier => E,
- Constant_Present => True,
- Object_Definition =>
- New_Reference_To (Standard_String, Loc),
- Expression =>
- Make_String_Literal (Loc, Strval => New_Val)));
-
- Append_Freeze_Actions (Ent, New_List (
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Tag,
- Prefix => New_Occurrence_Of (Ent, Loc)),
-
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => New_Occurrence_Of (E, Loc)))),
-
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Tag,
- Prefix => New_Occurrence_Of (Ent, Loc))))));
- end Expand_External_Tag_Definition;
+ -- 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;
- S : Entity_Id;
In_Other_Scope : Boolean;
In_Outer_Scope : Boolean;
Decl : Node_Id;
+ Delete : Boolean := False;
begin
- -- For object, with address clause, check alignment is OK
+ -- 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 Is_Object (E) then
- Apply_Alignment_Check (E, N);
+ if Present (Aitem) then
+ pragma Assert (Is_Delayed_Aspect (Aitem));
+ Insert_Before (N, Aitem);
+ end if;
+ end if;
- -- Only other items requiring any front end action are
- -- types and subprograms.
+ 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;
E_Scope := Scope (E);
- -- 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.
+ -- This is an error protection against previous errors
+
+ if No (E_Scope) then
+ 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))
+ 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;
- S := Current_Scope;
- while S /= Standard_Standard and then S /= E_Scope loop
- S := Scope (S);
- end loop;
+ -- 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.
- In_Other_Scope := not (S = E_Scope);
- In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_Scope);
+ 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
- New_Scope (E_Scope);
- Install_Visible_Declarations (E_Scope);
+ 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 Ekind (E_Scope) = E_Package or else
- Ekind (E_Scope) = E_Generic_Package or else
- Is_Protected_Type (E_Scope) or else
+ 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);
-- can properly override any corresponding inherited operations.
elsif In_Outer_Scope then
- New_Scope (E_Scope);
+ Push_Scope (E_Scope);
end if;
-- If type, freeze the type
if Is_Type (E) then
- Freeze_Type (N);
+ Delete := Freeze_Type (N);
-- And for enumeration type, build the enumeration tables
if Is_Enumeration_Type (E) then
Build_Enumeration_Image_Tables (E, N);
-
- elsif Is_Tagged_Type (E)
- and then Is_First_Subtype (E)
- then
-
- -- Check for a definition of External_Tag, whose expansion must
- -- be delayed until the dispatch table is built.
-
- declare
- Def : Node_Id :=
- Get_Attribute_Definition_Clause (E, Attribute_External_Tag);
- begin
- if Present (Def) then
- Expand_External_Tag_Definition (Def);
- end if;
- end;
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.
+ -- 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 (Chars (Defining_Entity (Decl)) = Name_uInit_Proc
- or else Chars (Defining_Entity (Decl)) = Name_uAssign)
+ and then (Is_Init_Proc (Defining_Entity (Decl))
+ or else
+ Chars (Defining_Entity (Decl)) = Name_uAssign)
then
Analyze (Decl);
and then Present (Corresponding_Spec (Decl))
and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
then
- New_Scope (Scope (Corresponding_Spec (Decl)));
+ 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;
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);
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;
-------------------------------------------
AtM_Nod : Node_Id;
begin
- if Present (Mod_Clause (N)) then
+ 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));
OSDN Git Service
