[Ada] Spurious error with predicate and class-wide object
Pierre-Marie de Rodat
derodat@adacore.com
Mon Oct 9 19:59:00 GMT 2017
This patch removes a spurious error on a call to a function that applies
to a predicated tagged type, when the actual in the call is class-wide.
The argument must be converted to be type-specific, given that the predicate
function is not dispatching and cannot accept a class-wide actual.
Executing:
gnatmake -q -gnata main
main
must yield:
Predicate checked
Predicate checked
Predicate checked
Predicate checked
Predicate checked
Predicate checked
---
with Predicate_Ints; use Predicate_Ints;
procedure Main is
Thing1 : Int := (0, 100, 50);
Thing2 : Approx_Int := (0, 100, 50, 13);
begin
Call_Bump (Thing1);
Call_Bump (Thing2);
end;
---
package Predicate_Ints is
type Int is tagged record
Min, Max, Value : Integer;
end record
with Predicate => Value in Min .. Max and then Checked;
procedure Bump (Arg : in out Int);
procedure Call_Bump (Arg : in out Int'Class);
function Checked return Boolean;
type Approx_Int is new Int with record
Precision : Natural;
end record;
end Predicate_Ints;
---
with Text_IO; use Text_IO;
package body Predicate_Ints is
function Checked return Boolean is
begin
Put_Line ("Predicate checked");
return True;
end;
procedure Bump (Arg : in out Int) is
begin
Arg.Value := Arg.Value + 1;
end Bump;
procedure Call_Bump (Arg : in out Int'Class) is
begin
Arg.Bump;
end Call_Bump;
end Predicate_Ints;
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-10-09 Ed Schonberg <schonberg@adacore.com>
* exp_util.adb (Make_Predicate_Call): If the type of the expression to
which the predicate check applies is tagged, convert the expression to
that type. This is in most cases a no-op, but is relevant if the
expression is clas-swide, because the predicate function being invoked
is not a primitive of the type and cannot take a class-wide actual.
-------------- next part --------------
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 253559)
+++ exp_util.adb (working copy)
@@ -9305,11 +9305,23 @@
-- Case of calling normal predicate function
- Call :=
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Func_Id, Loc),
- Parameter_Associations => New_List (Relocate_Node (Expr)));
+ -- If the type is tagged, the expression may be class-wide, in which
+ -- case it has to be converted to its root type, given that the
+ -- generated predicate function is not dispatching.
+ if Is_Tagged_Type (Typ) then
+ Call :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Func_Id, Loc),
+ Parameter_Associations =>
+ New_List (Convert_To (Typ, Relocate_Node (Expr))));
+ else
+ Call :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Func_Id, Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
+ end if;
+
Restore_Ghost_Mode (Saved_GM);
return Call;
More information about the Gcc-patches
mailing list