===================================================================
@@ -13785,6 +13785,44 @@
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 --
---------------------
===================================================================
@@ -1582,6 +1582,11 @@
-- 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
===================================================================
@@ -4044,35 +4044,29 @@
return;
end if;
- -- Apply appropriate range checks for in, out, and in-out
- -- parameters. Out and in-out parameters also need a separate
- -- check, if there is a type conversion, to make sure the return
- -- value meets the constraints of the variable before the
- -- conversion.
+ -- Apply appropriate constraint/predicate checks for IN [OUT] case
- -- Gigi looks at the check flag and uses the appropriate types.
- -- For now since one flag is used there is an optimization which
- -- might not be done in the In Out case since Gigi does not do
- -- any analysis. More thought required about this ???
-
if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then
- -- Apply predicate checks, unless this is a call to the
- -- predicate check function itself, which would cause an
- -- infinite recursion, or it is a call to an initialization
- -- procedure whose operand is of course an unfinished object.
+ -- 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.
- if not (Ekind (Nam) = E_Function
- and then (Is_Predicate_Function (Nam)
- or else
- Is_Predicate_Function_M (Nam)))
- and then not Is_Init_Proc (Nam)
- then
+ if not No_Predicate_Test_On_Arguments (Nam) then
Apply_Predicate_Check (A, F_Typ);
end if;
-- Apply required constraint checks
+ -- Gigi looks at the check flag and uses the appropriate types.
+ -- For now since one flag is used there is an optimization
+ -- which might not be done in the IN OUT case since Gigi does
+ -- not do any analysis. More thought required about this ???
+
+ -- In fact is this comment obsolete??? doesn't the expander now
+ -- generate all these tests anyway???
+
if Is_Scalar_Type (Etype (A)) then
Apply_Scalar_Range_Check (A, F_Typ);
@@ -4138,7 +4132,13 @@
end if;
end if;
+ -- Checks for OUT parameters and IN OUT parameters
+
if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then
+
+ -- If there is a type conversion, to make sure the return value
+ -- meets the constraints of the variable before the conversion.
+
if Nkind (A) = N_Type_Conversion then
if Is_Scalar_Type (A_Typ) then
Apply_Scalar_Range_Check
@@ -4148,6 +4148,9 @@
(Expression (A), Etype (Expression (A)), A_Typ);
end if;
+ -- If no conversion apply scalar range checks and length checks
+ -- base on the subtype of the actual (NOT that of the formal).
+
else
if Is_Scalar_Type (F_Typ) then
Apply_Scalar_Range_Check (A, A_Typ, F_Typ);
@@ -4159,6 +4162,10 @@
Apply_Range_Check (A, A_Typ, F_Typ);
end if;
end if;
+
+ -- Note: we do not apply the predicate checks for the case of
+ -- OUT and IN OUT parameters. They are instead applied in the
+ -- Expand_Actuals routine in Exp_Ch6.
end if;
-- An actual associated with an access parameter is implicitly
===================================================================
@@ -23,7 +23,6 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -190,6 +189,9 @@
-- For non-scalar objects that are possibly unaligned, add call by copy
-- code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
--
+ -- For OUT and IN OUT parameters, add predicate checks after the call
+ -- based on the predicates of the actual type.
+ --
-- The parameter N is IN OUT because in some cases, the expansion code
-- rewrites the call as an expression actions with the call inside. In
-- this case N is reset to point to the inside call so that the caller
@@ -1082,19 +1084,18 @@
Init := Empty;
Indic :=
Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (F_Typ, Loc),
+ Subtype_Mark => New_Occurrence_Of (F_Typ, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Var, Loc),
+ Prefix => New_Occurrence_Of (Var, Loc),
Attribute_Name => Name_First),
High_Bound =>
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Var, Loc),
+ Prefix => New_Occurrence_Of (Var, Loc),
Attribute_Name => Name_Last)))));
else
@@ -1720,7 +1721,7 @@
Add_Call_By_Copy_Code;
end if;
- -- RM 3.2.4 (23/3) : A predicate is checked on in-out and out
+ -- RM 3.2.4 (23/3): A predicate is checked on in-out and out
-- by-reference parameters on exit from the call. If the actual
-- is a derived type and the operation is inherited, the body
-- of the operation will not contain a call to the predicate
@@ -1732,29 +1733,34 @@
-- for subtype conversion on assignment, but we can generate the
-- required check now.
- -- Note that this is needed only if the subtype of the actual has
- -- an explicit predicate aspect, not if it inherits them from a
- -- base type or ancestor. The check is also superfluous if the
- -- subtype is elaborated before the body of the subprogram, but
- -- this is harder to verify, and there may be a redundant check.
-
-- Note also that Subp may be either a subprogram entity for
-- direct calls, or a type entity for indirect calls, which must
-- be handled separately because the name does not denote an
-- overloadable entity.
- if not Is_Init_Proc (Subp)
- and then (Has_Aspect (E_Actual, Aspect_Predicate)
- or else
- Has_Aspect (E_Actual, Aspect_Dynamic_Predicate)
- or else
- Has_Aspect (E_Actual, Aspect_Static_Predicate))
- and then Present (Predicate_Function (E_Actual))
- then
- Append_To (Post_Call,
- Make_Predicate_Check (E_Actual, Actual));
- end if;
+ declare
+ Aund : constant Entity_Id := Underlying_Type (E_Actual);
+ Atyp : Entity_Id;
+ begin
+ if No (Aund) then
+ Atyp := E_Actual;
+ else
+ Atyp := Aund;
+ end if;
+
+ if Has_Predicates (Atyp)
+ and then Present (Predicate_Function (Atyp))
+
+ -- Skip predicate checks for special cases
+
+ and then not No_Predicate_Test_On_Arguments (Subp)
+ then
+ Append_To (Post_Call,
+ Make_Predicate_Check (Atyp, Actual));
+ end if;
+ end;
+
-- Processing for IN parameters
else
This fix is inspired by ACATS test C324002, which tests that predicate tests for OUT and IN OUT parameters are properly applied. They were missed in some cases, and applied when they should not be to Finalize procedures. The following three tests (cutdown versions of C324002) compile and execute quietly: 1. with Ada.Assertions; use Ada.Assertions; 2. procedure PredByRef1 is 3. pragma Assertion_Policy (Check); 4. type R is tagged record 5. X : Integer; 6. end record 7. with Dynamic_Predicate => R.X mod 2 = 0; 8. 9. RV : R := (X => 0); 10. 11. procedure P (Arg : in out R) is 12. begin 13. Arg.X := Arg.X + 1; 14. end; 15. 16. begin 17. P (RV); 18. raise Program_Error; 19. exception 20. when Assertion_Error => null; 21. end PredByRef1; 1. with Ada.Assertions; use Ada.Assertions; 2. with Ada.Finalization; use Ada.Finalization; 3. procedure PredByRef2 is 4. pragma Assertion_Policy (Check); 5. type R is new Controlled with record 6. X : Integer := 0; 7. end record 8. with Dynamic_Predicate => R.X mod 2 = 0; 9. 10. RV : R; 11. 12. procedure P (Arg : in out R) is 13. begin 14. Arg.X := Arg.X + 1; 15. end; 16. 17. begin 18. P (RV); 19. raise Program_Error; 20. exception 21. when Assertion_Error => null; 22. end PredByRef2; 1. with Ada.Finalization; 2. with Ada.Assertions; use Ada.Assertions; 3. procedure PredByRef3 is 4. pragma Assertion_Policy (Check); 5. type String_Access is access all String; 6. 7. type Unbounded_String is new 8. Ada.Finalization.Controlled with record 9. Length : Natural := 100; 10. end record; 11. 12. subtype Max_10_Char_String is Unbounded_String 13. with Dynamic_Predicate => 14. Max_10_Char_String.Length <= 10; 15. 16. procedure Set_Unbounded_String 17. (Target : out Unbounded_String) is 18. begin 19. Target.Length := 200; 20. end Set_Unbounded_String; 21. 22. Our_Data : array (1 .. 10) of Max_10_Char_String 23. begin 24. Set_Unbounded_String (Our_Data(6)); 25. raise Program_Error; 26. exception 27. when Assertion_Error => null; 28. end PredByRef3; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-29 Robert Dewar <dewar@adacore.com> * exp_ch6.adb (Add_Call_By_Copy_Code): Minor reformatting (Expand_Actuals): Make sure predicate checks are properly applied for the case of OUT or IN OUT parameters. * sem_res.adb: Minor reformatting (Resolve_Actuals): Skip predicate tests on arguments for Finalize * sem_util.adb (No_Predicate_Test_On_Arguments): Returns True if predicate tests on subprogram arguments should be skipped. * sem_util.ads (No_Predicate_Test_On_Arguments): New function