-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, 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- --
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
-with Elists; use Elists;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Imgv; use Exp_Imgv;
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_Ch3; use Sem_Ch3;
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 Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Validsw; use Validsw;
package body Exp_Ch13 is
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Build_Predicate_Function
- (Typ : Entity_Id;
- FDecl : out Node_Id;
- FBody : out Node_Id);
- -- If Typ has predicates (indicated by Has_Predicates being set for Typ,
- -- then either there are pragma Invariant entries on the rep chain for the
- -- type (note that Predicate aspects are converted to pragam Predicate), or
- -- there are inherited aspects from a parent type, or ancestor subtypes,
- -- or interfaces. This procedure builds the spec and body for the Predicate
- -- function that tests these predicates, returning them in PDecl and Pbody
- -- and setting Predicate_Procedure for Typ. In some error situations no
- -- procedure is built, in which case PDecl/PBody are empty on return.
-
- ------------------------------
- -- Build_Predicate_Function --
- ------------------------------
-
- -- The procedure that is constructed here has the form
-
- -- function typPredicate (Ixxx : typ) return Boolean is
- -- begin
- -- return
- -- exp1 and then exp2 and then ...
- -- and then typ1Predicate (typ1 (Ixxx))
- -- and then typ2Predicate (typ2 (Ixxx))
- -- and then ...;
- -- end typPredicate;
-
- -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that
- -- this is the point at which these expressions get analyzed, providing the
- -- required delay, and typ1, typ2, are entities from which predicates are
- -- inherited. Note that we do NOT generate Check pragmas, that's because we
- -- use this function even if checks are off, e.g. for membership tests.
-
- procedure Build_Predicate_Function
- (Typ : Entity_Id;
- FDecl : out Node_Id;
- FBody : out Node_Id)
- is
- Loc : constant Source_Ptr := Sloc (Typ);
- Spec : Node_Id;
- SId : Entity_Id;
-
- Expr : Node_Id;
- -- This is the expression for the return statement in the function. It
- -- is build by connecting the component predicates with AND THEN.
-
- procedure Add_Call (T : Entity_Id);
- -- Includes a call to the predicate function for type T in Expr if T
- -- has predicates and Predicate_Function (T) is non-empty.
-
- procedure Add_Predicates;
- -- Appends expressions for any Predicate pragmas in the rep item chain
- -- Typ to Expr. Note that we look only at items for this exact entity.
- -- Inheritance of predicates for the parent type is done by calling the
- -- Predicate_Function of the parent type, using Add_Call above.
-
- Object_Name : constant Name_Id := New_Internal_Name ('I');
- -- Name for argument of Predicate procedure
-
- --------------
- -- Add_Call --
- --------------
-
- procedure Add_Call (T : Entity_Id) is
- Exp : Node_Id;
-
- begin
- if Present (T) and then Present (Predicate_Function (T)) then
- Exp :=
- Make_Predicate_Call
- (T,
- Convert_To (T,
- Make_Identifier (Loc, Chars => Object_Name)));
-
- if No (Expr) then
- Expr := Exp;
- else
- Expr :=
- Make_And_Then (Loc,
- Left_Opnd => Relocate_Node (Expr),
- Right_Opnd => Exp);
- end if;
- end if;
- end Add_Call;
-
- --------------------
- -- Add_Predicates --
- --------------------
-
- procedure Add_Predicates is
- Ritem : Node_Id;
- Arg1 : Node_Id;
- Arg2 : Node_Id;
-
- function Replace_Node (N : Node_Id) return Traverse_Result;
- -- Process single node for traversal to replace type references
-
- procedure Replace_Type is new Traverse_Proc (Replace_Node);
- -- Traverse an expression changing every occurrence of an entity
- -- reference to type T with a reference to the object argument.
-
- ------------------
- -- Replace_Node --
- ------------------
-
- function Replace_Node (N : Node_Id) return Traverse_Result is
- begin
- -- Case of entity name referencing the type
-
- if Is_Entity_Name (N) and then Entity (N) = Typ then
-
- -- Replace with object
-
- Rewrite (N,
- Make_Identifier (Loc,
- Chars => Object_Name));
-
- -- All done with this node
-
- return Skip;
-
- -- Not an occurrence of the type entity, keep going
-
- else
- return OK;
- end if;
- end Replace_Node;
-
- -- Start of processing for Add_Predicates
-
- begin
- Ritem := First_Rep_Item (Typ);
- while Present (Ritem) loop
- if Nkind (Ritem) = N_Pragma
- and then Pragma_Name (Ritem) = Name_Predicate
- then
- Arg1 := First (Pragma_Argument_Associations (Ritem));
- Arg2 := Next (Arg1);
-
- Arg1 := Get_Pragma_Arg (Arg1);
- Arg2 := Get_Pragma_Arg (Arg2);
-
- -- We need to replace any occurrences of the name of the type
- -- with references to the object. We do this by first doing a
- -- preanalysis, to identify all the entities, then we traverse
- -- looking for the type entity, doing the needed substitution.
- -- The preanalysis is done with the special OK_To_Reference
- -- flag set on the type, so that if we get an occurrence of
- -- this type, it will be recognized as legitimate.
-
- Set_OK_To_Reference (Typ, True);
- Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
- Set_OK_To_Reference (Typ, False);
- Replace_Type (Arg2);
-
- -- See if this predicate pragma is for the current type
-
- if Entity (Arg1) = Typ then
-
- -- We have a match, add the expression
-
- if No (Expr) then
- Expr := Relocate_Node (Arg2);
- else
- Expr :=
- Make_And_Then (Loc,
- Left_Opnd => Relocate_Node (Expr),
- Right_Opnd => Relocate_Node (Arg2));
- end if;
- end if;
- end if;
-
- Next_Rep_Item (Ritem);
- end loop;
- end Add_Predicates;
-
- -- Start of processing for Build_Predicate_Function
-
- begin
- -- Initialize for construction of statement list
-
- Expr := Empty;
- FDecl := Empty;
- FBody := Empty;
-
- -- Return if already built or if type does not have predicates
-
- if not Has_Predicates (Typ)
- or else Present (Predicate_Function (Typ))
- then
- return;
- end if;
-
- -- Add Predicates for the current type
-
- Add_Predicates;
-
- -- Deal with ancestor subtype and parent type
-
- declare
- Atyp : constant Entity_Id := Ancestor_Subtype (Typ);
-
- begin
- -- If ancestor subtype present, add its predicates
-
- if Present (Atyp) then
- Add_Call (Atyp);
-
- -- Else if this is derived, add predicates of parent type
-
- elsif Is_Derived_Type (Typ) then
- Add_Call (Etype (Base_Type (Typ)));
- end if;
- end;
-
- -- Add predicates of any interfaces of a tagged type
-
- if Is_Tagged_Type (Typ) then
- declare
- Iface_List : Elist_Id;
- Elmt : Elmt_Id;
-
- begin
- Collect_Interfaces (Typ, Iface_List);
-
- if Present (Iface_List) then
- loop
- Elmt := First_Elmt (Iface_List);
- exit when No (Elmt);
-
- Add_Call (Node (Elmt));
- Remove_Elmt (Iface_List, Elmt);
- end loop;
- end if;
- end;
- end if;
-
- if Present (Expr) then
-
- -- Build function declaration
-
- pragma Assert (Has_Predicates (Typ));
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
- Set_Has_Predicates (SId);
- Set_Predicate_Function (Typ, SId);
-
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars => Object_Name),
- Parameter_Type => New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
-
- FDecl :=
- Make_Subprogram_Declaration (Loc,
- Specification => Spec);
-
- -- Build function body
-
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
-
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars => Object_Name),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
-
- FBody :=
- Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression => Expr))));
- end if;
- end Build_Predicate_Function;
-
------------------------------------------
-- Expand_N_Attribute_Definition_Clause --
------------------------------------------
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;
- S : Entity_Id;
In_Other_Scope : Boolean;
In_Outer_Scope : Boolean;
Decl : 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 then
+ if Nkind (Ritem) = N_Aspect_Specification
+ and then Entity (Ritem) = E
+ then
Aitem := Aspect_Rep_Item (Ritem);
- pragma Assert (Is_Delayed_Aspect (Aitem));
- Insert_Before (N, Aitem);
+
+ -- 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);
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);
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.
+
+ 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
- In_Other_Scope := not (S = E_Scope);
- In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_Scope);
+ 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
if In_Other_Scope then
Push_Scope (E_Scope);
- Install_Visible_Declarations (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
Rewrite (N, Make_Null_Statement (Sloc (N)));
end if;
- -- If freezing a type entity which has predicates, this is where we
- -- build and insert the predicate function for the type.
-
- if Is_Type (E) and then Has_Predicates (E) then
- declare
- FDecl : Node_Id;
- FBody : Node_Id;
-
- begin
- Build_Predicate_Function (E, FDecl, FBody);
-
- if Present (FDecl) then
- Insert_After (N, FBody);
- Insert_After (N, FDecl);
- end if;
- end;
- end if;
-
-- Pop scope if we installed one for the analysis
if In_Other_Scope then
OSDN Git Service
