This patch corrects the generation of predicate checks to handle the case where
Predicate_Failure appears as a pragma.
------------
-- Source --
------------
-- main.adb
with Ada.Assertions; use Ada.Assertions;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Text_IO; use Ada.Text_IO;
procedure Main is
subtype Even_Asp is Integer
with Predicate => Even_Asp mod 2 = 0,
Predicate_Failure => "Even_Asp failed";
subtype Even_Prag is Integer
with Predicate => Even_Prag mod 2 = 0;
pragma Predicate_Failure (Even_Prag, "Even_Prag failed");
begin
begin
declare
Val : constant Even_Asp := 1;
begin
Put_Line ("ERROR: Even_Asp: did not fail");
end;
exception
when AE : Assertion_Error => Put_Line (Exception_Message (AE));
when others => Put_Line ("ERROR: Even_Asp: raised unexpected error");
end;
begin
declare
Val : constant Even_Prag := 3;
begin
Put_Line ("ERROR: Even_Prag: did not fail");
end;
exception
when AE : Assertion_Error => Put_Line (Exception_Message (AE));
when others => Put_Line ("ERROR: Even_Prag: raised unexpected error");
end;
end Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q main.adb
$ ./main
Even_Asp failed
Even_Prag failed
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-01-11 Hristian Kirtchev <kirtc...@adacore.com>
gcc/ada/
* exp_util.adb (Add_Failure_Expression): New routine.
(Make_Predicate_Check): Reimplement the handling of Predicate_Failure.
* sem_util.adb (Is_Current_Instance): Code cleanup.--- gcc/ada/exp_util.adb
+++ gcc/ada/exp_util.adb
@@ -9310,36 +9310,172 @@ package body Exp_Util is
(Typ : Entity_Id;
Expr : Node_Id) return Node_Id
is
- procedure Replace_Subtype_Reference (N : Node_Id);
- -- Replace current occurrences of the subtype to which a dynamic
- -- predicate applies, by the expression that triggers a predicate
- -- check. This is needed for aspect Predicate_Failure, for which
- -- we do not generate a wrapper procedure, but simply modify the
- -- expression for the pragma of the predicate check.
+ Loc : constant Source_Ptr := Sloc (Expr);
- --------------------------------
- -- Replace_Subtype_Reference --
- --------------------------------
+ procedure Add_Failure_Expression (Args : List_Id);
+ -- Add the failure expression of pragma Predicate_Failure (if any) to
+ -- list Args.
+
+ ----------------------------
+ -- Add_Failure_Expression --
+ ----------------------------
+
+ procedure Add_Failure_Expression (Args : List_Id) is
+ function Failure_Expression return Node_Id;
+ pragma Inline (Failure_Expression);
+ -- Find aspect or pragma Predicate_Failure that applies to type Typ
+ -- and return its expression. Return Empty if no such annotation is
+ -- available.
+
+ function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean;
+ pragma Inline (Is_OK_PF_Aspect);
+ -- Determine whether aspect Asp is a suitable Predicate_Failure
+ -- aspect that applies to type Typ.
+
+ function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean;
+ pragma Inline (Is_OK_PF_Pragma);
+ -- Determine whether pragma Prag is a suitable Predicate_Failure
+ -- pragma that applies to type Typ.
+
+ procedure Replace_Subtype_Reference (N : Node_Id);
+ -- Replace the current instance of type Typ denoted by N with
+ -- expression Expr.
+
+ ------------------------
+ -- Failure_Expression --
+ ------------------------
+
+ function Failure_Expression return Node_Id is
+ Item : Node_Id;
+
+ begin
+ -- The management of the rep item chain involves "inheritance" of
+ -- parent type chains. If a parent [sub]type is already subject to
+ -- pragma Predicate_Failure, then the pragma will also appear in
+ -- the chain of the child [sub]type, which in turn may possess a
+ -- pragma of its own. Avoid order-dependent issues by inspecting
+ -- the rep item chain directly. Note that routine Get_Pragma may
+ -- return a parent pragma.
+
+ Item := First_Rep_Item (Typ);
+ while Present (Item) loop
+
+ -- Predicate_Failure appears as an aspect
+
+ if Nkind (Item) = N_Aspect_Specification
+ and then Is_OK_PF_Aspect (Item)
+ then
+ return Expression (Item);
+
+ -- Predicate_Failure appears as a pragma
+
+ elsif Nkind (Item) = N_Pragma
+ and then Is_OK_PF_Pragma (Item)
+ then
+ return
+ Get_Pragma_Arg
+ (Next (First (Pragma_Argument_Associations (Item))));
+ end if;
+
+ Item := Next_Rep_Item (Item);
+ end loop;
+
+ return Empty;
+ end Failure_Expression;
+
+ ---------------------
+ -- Is_OK_PF_Aspect --
+ ---------------------
+
+ function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean is
+ begin
+ -- To qualify, the aspect must apply to the type subjected to the
+ -- predicate check.
+
+ return
+ Chars (Identifier (Asp)) = Name_Predicate_Failure
+ and then Present (Entity (Asp))
+ and then Entity (Asp) = Typ;
+ end Is_OK_PF_Aspect;
+
+ ---------------------
+ -- Is_OK_PF_Pragma --
+ ---------------------
+
+ function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean is
+ Args : constant List_Id := Pragma_Argument_Associations (Prag);
+ Typ_Arg : Node_Id;
+
+ begin
+ -- Nothing to do when the pragma does not denote Predicate_Failure
+
+ if Pragma_Name (Prag) /= Name_Predicate_Failure then
+ return False;
+
+ -- Nothing to do when the pragma lacks arguments, in which case it
+ -- is illegal.
+
+ elsif No (Args) or else Is_Empty_List (Args) then
+ return False;
+ end if;
+
+ Typ_Arg := Get_Pragma_Arg (First (Args));
+
+ -- To qualify, the local name argument of the pragma must denote
+ -- the type subjected to the predicate check.
+
+ return
+ Is_Entity_Name (Typ_Arg)
+ and then Present (Entity (Typ_Arg))
+ and then Entity (Typ_Arg) = Typ;
+ end Is_OK_PF_Pragma;
+
+ --------------------------------
+ -- Replace_Subtype_Reference --
+ --------------------------------
+
+ procedure Replace_Subtype_Reference (N : Node_Id) is
+ begin
+ Rewrite (N, New_Copy_Tree (Expr));
+
+ -- We want to treat the node as if it comes from source, so that
+ -- ASIS will not ignore it.
+
+ Set_Comes_From_Source (N, True);
+ end Replace_Subtype_Reference;
+
+ procedure Replace_Subtype_References is
+ new Replace_Type_References_Generic (Replace_Subtype_Reference);
+
+ -- Local variables
+
+ PF_Expr : constant Node_Id := Failure_Expression;
+ Expr : Node_Id;
+
+ -- Start of processing for Add_Failure_Expression
- procedure Replace_Subtype_Reference (N : Node_Id) is
begin
- Rewrite (N, New_Copy_Tree (Expr));
+ if Present (PF_Expr) then
- -- We want to treat the node as if it comes from source, so
- -- that ASIS will not ignore it.
+ -- Replace any occurrences of the current instance of the type
+ -- with the object subjected to the predicate check.
- Set_Comes_From_Source (N, True);
- end Replace_Subtype_Reference;
+ Expr := New_Copy_Tree (PF_Expr);
+ Replace_Subtype_References (Expr, Typ);
- procedure Replace_Subtype_References is
- new Replace_Type_References_Generic (Replace_Subtype_Reference);
+ -- The failure expression appears as the third argument of the
+ -- Check pragma.
+
+ Append_To (Args,
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Expr));
+ end if;
+ end Add_Failure_Expression;
-- Local variables
- Loc : constant Source_Ptr := Sloc (Expr);
- Arg_List : List_Id;
- Fail_Expr : Node_Id;
- Nam : Name_Id;
+ Args : List_Id;
+ Nam : Name_Id;
-- Start of processing for Make_Predicate_Check
@@ -9370,31 +9506,21 @@ package body Exp_Util is
Nam := Name_Predicate;
end if;
- Arg_List := New_List (
+ Args := New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Make_Identifier (Loc, Nam)),
Make_Pragma_Argument_Association (Loc,
Expression => Make_Predicate_Call (Typ, Expr)));
- -- If subtype has Predicate_Failure defined, add the correponding
- -- expression as an additional pragma parameter, after replacing
- -- current instances with the expression being checked.
-
- if Has_Aspect (Typ, Aspect_Predicate_Failure) then
- Fail_Expr :=
- New_Copy_Tree
- (Expression (Find_Aspect (Typ, Aspect_Predicate_Failure)));
- Replace_Subtype_References (Fail_Expr, Typ);
+ -- If the subtype is subject to pragma Predicate_Failure, add the
+ -- failure expression as an additional parameter.
- Append_To (Arg_List,
- Make_Pragma_Argument_Association (Loc,
- Expression => Fail_Expr));
- end if;
+ Add_Failure_Expression (Args);
return
Make_Pragma (Loc,
Chars => Name_Check,
- Pragma_Argument_Associations => Arg_List);
+ Pragma_Argument_Associations => Args);
end Make_Predicate_Check;
------------------------------- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -13318,8 +13318,8 @@ package body Sem_Util is
begin
-- Simplest case: entity is a concurrent type and we are currently
- -- inside the body. This will eventually be expanded into a
- -- call to Self (for tasks) or _object (for protected objects).
+ -- inside the body. This will eventually be expanded into a call to
+ -- Self (for tasks) or _object (for protected objects).
if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then
return True;
@@ -13350,8 +13350,7 @@ package body Sem_Util is
return True;
elsif Nkind (P) = N_Pragma
- and then
- Get_Pragma_Id (P) = Pragma_Predicate_Failure
+ and then Get_Pragma_Id (P) = Pragma_Predicate_Failure
then
return True;
end if;
