+2014-07-29 Robert Dewar <dewar@adacore.com>
+
+ * sem_util.adb, sem_util.ads, sem_res.adb, exp_ch6.adb: Invert
+ predicate No_Predicate_Test_On_Arguments, new name is
+ Predicate_Tests_On_Arguments (with the opposite sense).
+
+2014-07-29 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_attr.adb (Resolve_Attribute): Clean up the code for
+ attribute 'Access. Do not generate an elaboration flag for a
+ stand alone expression function. The expression of an expression
+ function is now frozen when the expression function appears as
+ the prefix of attribute 'Access.
+ * sem_ch6.adb (Analyze_Expression_Function): Remove local
+ variable New_Decl and update all references to it after the
+ rewriting has taken place. Establish the linkages between the
+ generated spec and body.
+
2014-07-29 Robert Dewar <dewar@adacore.com>
* sem_prag.adb (ip, rv): Prevent from being optimized away.
-- Skip predicate checks for special cases
- and then not No_Predicate_Test_On_Arguments (Subp)
+ and then Predicate_Tests_On_Arguments (Subp)
then
Append_To (Post_Call,
Make_Predicate_Check (Atyp, Actual));
-- used so that we can abandon the processing so we don't run into
-- trouble with cascaded errors.
- -- The following array is the list of attributes defined in the Ada 83 RM:
+ -- The following array is the list of attributes defined in the Ada 83 RM.
+ -- In Ada 83 mode, these are the only recognized attributes. In other Ada
+ -- modes all these attributes are recognized, even if removed in Ada 95.
Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_Address |
Set_Address_Taken (Entity (P));
end if;
- if Is_Entity_Name (P) then
+ -- Deal with possible elaboration check
+
+ if Is_Entity_Name (P) and then Is_Subprogram (Entity (P)) then
declare
- E : constant Entity_Id := Entity (P);
- Decl : Node_Id;
- Flag : Entity_Id;
+ Subp_Id : constant Entity_Id := Entity (P);
+ Scop : constant Entity_Id := Scope (Subp_Id);
+ Subp_Decl : constant Node_Id :=
+ Unit_Declaration_Node (Subp_Id);
+
+ Flag_Id : Entity_Id;
+ HSS : Node_Id;
+ Stmt : Node_Id;
-- If the access has been taken and the body of the subprogram
-- has not been see yet, indirect calls must be protected with
-- a subprogram the body will appear in the same declarative
-- part, and we must insert a check in the eventual body itself
-- using the elaboration flag that we generate now. The check
- -- is then inserted when the body is expanded.
+ -- is then inserted when the body is expanded. This processing
+ -- is not needed for a stand alone expression function because
+ -- the internally generated spec and body are always inserted
+ -- as a pair in the same declarative list.
begin
- if Is_Subprogram (E)
- and then Expander_Active
- and then Comes_From_Source (E)
+ if Expander_Active
+ and then Comes_From_Source (Subp_Id)
and then Comes_From_Source (N)
- and then In_Open_Scopes (Scope (E))
- and then
- Ekind_In (Scope (E), E_Block, E_Procedure, E_Function)
- and then not Has_Completion (E)
- and then No (Elaboration_Entity (E))
- and then Nkind (Unit_Declaration_Node (E)) =
- N_Subprogram_Declaration
+ and then In_Open_Scopes (Scop)
+ and then Ekind_In (Scop, E_Block, E_Procedure, E_Function)
+ and then not Has_Completion (Subp_Id)
+ and then No (Elaboration_Entity (Subp_Id))
+ and then Nkind (Subp_Decl) = N_Subprogram_Declaration
+ and then Nkind (Original_Node (Subp_Decl)) /=
+ N_Expression_Function
then
-- Create elaboration variable for it
- Flag := Make_Temporary (Loc, 'E');
- Decl :=
+ Flag_Id := Make_Temporary (Loc, 'E');
+ Set_Elaboration_Entity (Subp_Id, Flag_Id);
+ Set_Is_Frozen (Flag_Id);
+
+ -- Insert declaration for flag after subprogram
+ -- declaration. Note that attribute reference may
+ -- appear within a nested scope.
+
+ Insert_After_And_Analyze (Subp_Decl,
Make_Object_Declaration (Loc,
- Defining_Identifier => Flag,
+ Defining_Identifier => Flag_Id,
Object_Definition =>
New_Occurrence_Of (Standard_Short_Integer, Loc),
Expression =>
- Make_Integer_Literal (Loc, Uint_0));
- Set_Elaboration_Entity (E, Flag);
- Set_Is_Frozen (Flag);
+ Make_Integer_Literal (Loc, Uint_0)));
+ end if;
- -- Insert declaration for flag after subprogram
- -- declaration. Note that attribute reference may
- -- appear within a nested scope.
+ -- Taking the 'Access of an expression function freezes its
+ -- expression (RM 13.14 10.3/3). This does not apply to an
+ -- expression function that acts as a completion because the
+ -- generated body is immediately analyzed and the expression
+ -- is automatically frozen.
+
+ if Ekind (Subp_Id) = E_Function
+ and then Nkind (Subp_Decl) = N_Subprogram_Declaration
+ and then Nkind (Original_Node (Subp_Decl)) =
+ N_Expression_Function
+ and then Present (Corresponding_Body (Subp_Decl))
+ and then not Analyzed (Corresponding_Body (Subp_Decl))
+ then
+ HSS :=
+ Handled_Statement_Sequence
+ (Unit_Declaration_Node
+ (Corresponding_Body (Subp_Decl)));
+
+ if Present (HSS) then
+ Stmt := First (Statements (HSS));
- Insert_After (Unit_Declaration_Node (E), Decl);
- Analyze (Decl);
+ if Nkind (Stmt) = N_Simple_Return_Statement then
+ Freeze_Expression (Expression (Stmt));
+ end if;
+ end if;
end if;
end;
end if;
-- declaration is completed. Def_Id is needed to analyze the spec.
New_Body : Node_Id;
- New_Decl : Node_Id;
New_Spec : Node_Id;
Ret : Node_Id;
("an expression function is not a legal protected operation", N);
end if;
- New_Decl :=
- Make_Subprogram_Declaration (Loc, Specification => Spec);
-
- Rewrite (N, New_Decl);
+ Rewrite (N, Make_Subprogram_Declaration (Loc, Specification => Spec));
-- Correct the parent pointer of the aspect specification list to
-- reference the rewritten node.
end if;
Analyze (N);
- Set_Is_Inlined (Defining_Entity (New_Decl));
+ Set_Is_Inlined (Defining_Entity (N));
+
+ -- Establish the linkages between the spec and the body. These are
+ -- used when the expression function acts as the prefix of attribute
+ -- 'Access in order to freeze the original expression which has been
+ -- moved to the generated body.
+
+ Set_Corresponding_Body (N, Defining_Entity (New_Body));
+ Set_Corresponding_Spec (New_Body, Defining_Entity (N));
-- To prevent premature freeze action, insert the new body at the end
-- of the current declarations, or at the end of the package spec.
declare
Decls : List_Id := List_Containing (N);
Par : constant Node_Id := Parent (Decls);
- Id : constant Entity_Id := Defining_Entity (New_Decl);
+ Id : constant Entity_Id := Defining_Entity (N);
begin
if Nkind (Par) = N_Package_Specification
if Nkind (Decl) = N_Subprogram_Body then
Spec := Corresponding_Spec (Decl);
- if not No (Spec) then
+ if Present (Spec) then
Decl := Unit_Declaration_Node (Spec);
end if;
end if;
-- Apply predicate tests except in certain special cases. Note
-- that it might be more consistent to apply these only when
-- expansion is active (in Exp_Ch6.Expand_Actuals), as we do
- -- for the outbound predicate tests.
+ -- for the outbound predicate tests ???
- if not No_Predicate_Test_On_Arguments (Nam) then
+ if Predicate_Tests_On_Arguments (Nam) then
Apply_Predicate_Check (A, F_Typ);
end if;
Actual_Id := Next_Actual (Actual_Id);
end Next_Actual;
- ------------------------------------
- -- No_Predicate_Test_On_Arguments --
- ------------------------------------
-
- function No_Predicate_Test_On_Arguments (Subp : Entity_Id) return Boolean is
- begin
- -- Do not test predicates on call to generated default Finalize, since
- -- we are not interested in whether something we are finalizing (and
- -- typically destroying) satisfies its predicates.
-
- if Chars (Subp) = Name_Finalize
- and then not Comes_From_Source (Subp)
- then
- return True;
-
- -- Do not test predicates on call to Init_Proc, since if needed the
- -- predicate test will occur at some other point.
-
- elsif Is_Init_Proc (Subp) then
- return True;
-
- -- Do not test predicates on call to predicate function, since this
- -- would cause infinite recursion.
-
- elsif Ekind (Subp) = E_Function
- and then (Is_Predicate_Function (Subp)
- or else
- Is_Predicate_Function_M (Subp))
- then
- return True;
-
- -- For now, no other cases
-
- else
- return False;
- end if;
- end No_Predicate_Test_On_Arguments;
-
---------------------
-- No_Scalar_Parts --
---------------------
end if;
end Original_Corresponding_Operation;
+ ----------------------------------
+ -- Predicate_Tests_On_Arguments --
+ ----------------------------------
+
+ function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is
+ begin
+ -- Do not test predicates on call to generated default Finalize, since
+ -- we are not interested in whether something we are finalizing (and
+ -- typically destroying) satisfies its predicates.
+
+ if Chars (Subp) = Name_Finalize
+ and then not Comes_From_Source (Subp)
+ then
+ return False;
+
+ -- Do not test predicates on call to Init_Proc, since if needed the
+ -- predicate test will occur at some other point.
+
+ elsif Is_Init_Proc (Subp) then
+ return False;
+
+ -- Do not test predicates on call to predicate function, since this
+ -- would cause infinite recursion.
+
+ elsif Ekind (Subp) = E_Function
+ and then (Is_Predicate_Function (Subp)
+ or else
+ Is_Predicate_Function_M (Subp))
+ then
+ return False;
+
+ -- For now, no other exceptions
+
+ else
+ return True;
+ end if;
+ end Predicate_Tests_On_Arguments;
+
-----------------------
-- Private_Component --
-----------------------
-- Note that the result produced is always an expression, not a parameter
-- association node, even if named notation was used.
- function No_Predicate_Test_On_Arguments (Subp : Entity_Id) return Boolean;
- -- Subp is the entity for a subprogram call. This function returns True to
- -- eliminate predicate tests on the input or output arguments in a call to
- -- this subprogram. See body for exact cases currently covered.
-
function No_Scalar_Parts (T : Entity_Id) return Boolean;
-- Tests if type T can be determined at compile time to have no scalar
-- parts in the sense of the Valid_Scalars attribute. Returns True if
-- Name_uPre, Name_uPost, Name_uInvariant, or Name_uType_Invariant being
-- returned to represent the corresponding aspects with x'Class names.
+ function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean;
+ -- Subp is the entity for a subprogram call. This function returns True if
+ -- predicate tests are required for the arguments in this call (this is the
+ -- normal case). It returns False for special cases where these predicate
+ -- tests should be skipped (see body for details).
+
function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean;
-- Returns True if the names of both entities correspond with matching
-- primitives. This routine includes support for the case in which one
projects / gcc.git / commitdiff