From ccf173059688499749a30b3252cc3c4ea4ab0d0c Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Thu, 11 Jul 2019 08:01:30 +0000 Subject: [PATCH] [Ada] No warning for guaranteed accessibility check failures This patch corrects the generation of dynamic accessibility checks which are guaranteed to trigger errors during run time so as to give the user proper warning during unit compiliation. 2019-07-11 Justin Squirek gcc/ada/ * checks.adb (Apply_Accessibility_Check): Add check for constant folded conditions on accessibility checks. gcc/testsuite/ * gnat.dg/access7.adb: New testcase. From-SVN: r273381 --- gcc/ada/ChangeLog | 5 ++ gcc/ada/checks.adb | 25 ++++++++-- gcc/testsuite/ChangeLog | 4 ++ gcc/testsuite/gnat.dg/access7.adb | 79 +++++++++++++++++++++++++++++++ 4 files changed, 108 insertions(+), 5 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/access7.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 703280c2d01..9104658a008 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2019-07-11 Justin Squirek + + * checks.adb (Apply_Accessibility_Check): Add check for constant + folded conditions on accessibility checks. + 2019-07-11 Arnaud Charlet * libgnarl/g-thread.ads, libgnarl/g-thread.adb (Get_Thread): diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 601b932a1f3..7ca66bdbb60 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -577,6 +577,7 @@ package body Checks is Typ : Entity_Id; Insert_Node : Node_Id) is + Check_Cond : Node_Id; Loc : constant Source_Ptr := Sloc (N); Param_Ent : Entity_Id := Param_Entity (N); Param_Level : Node_Id; @@ -638,15 +639,29 @@ package body Checks is -- Raise Program_Error if the accessibility level of the access -- parameter is deeper than the level of the target access type. + Check_Cond := Make_Op_Gt (Loc, + Left_Opnd => Param_Level, + Right_Opnd => Type_Level); + Insert_Action (Insert_Node, Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => Param_Level, - Right_Opnd => Type_Level), - Reason => PE_Accessibility_Check_Failed)); + Condition => Check_Cond, + Reason => PE_Accessibility_Check_Failed)); Analyze_And_Resolve (N); + + -- If constant folding has happened on the condition for the + -- generated error, then warn about it being unconditional. + + if Nkind (Check_Cond) = N_Identifier + and then Entity (Check_Cond) = Standard_True + then + Error_Msg_Warn := SPARK_Mode /= On; + Error_Msg_N + ("accessibility check fails<<", N); + Error_Msg_N + ("\Program_Error [<<", N); + end if; end if; end Apply_Accessibility_Check; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 24ecc217f73..3b393fb60cd 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-07-11 Justin Squirek + + * gnat.dg/access7.adb: New testcase. + 2019-07-11 Yannick Moy * gnat.dg/warn21.adb, gnat.dg/warn21.ads: New testcase. diff --git a/gcc/testsuite/gnat.dg/access7.adb b/gcc/testsuite/gnat.dg/access7.adb new file mode 100644 index 00000000000..e4813121878 --- /dev/null +++ b/gcc/testsuite/gnat.dg/access7.adb @@ -0,0 +1,79 @@ +-- { dg-do run } + +with Interfaces; use Interfaces; + +procedure Access7 is + type t_p_string is access constant String; + subtype t_hash is Unsigned_32; + + -- Return a hash value for a given string + function hash(s: String) return t_hash is + h: t_hash := 0; + g: t_hash; + begin + for i in s'Range loop + h := Shift_Left(h, 4) + t_hash'(Character'Pos(s(i))); + g := h and 16#F000_0000#; + if (h and g) /= 0 then + h := h xor ((Shift_Right(g, 24) and 16#FF#) or g); + end if; + end loop; + return h; + end hash; + + type hash_entry is record + v: t_p_string; + hash: t_hash; + next: access hash_entry; + end record; + + type hashtable is array(t_hash range <>) of access hash_entry; + + protected pool is + procedure allocate (sp: out t_p_string; s: String; h: t_hash); + private + tab: hashtable(0..199999-1) := (others => null); + end pool; + + protected body pool is + procedure allocate(sp: out t_p_string; s: String; h: t_hash) is + p: access hash_entry; + slot: t_hash; + begin + slot := h mod tab'Length; + p := tab(slot); + while p /= null loop + -- quickly check hash, then length, only then slow comparison + if p.hash = h and then p.v.all'Length = s'Length + and then p.v.all = s + then + sp := p.v; -- shared string + return; + end if; + p := p.next; + end loop; + -- add to table + p := new hash_entry'(v => new String'(s), + hash => h, + next => tab(slot)); + tab(slot) := p; -- { dg-warning "accessibility check fails|Program_Error will be raised at run time" } + sp := p.v; -- shared string + end allocate; + end pool; + + -- Return the pooled string equal to a given String + function new_p_string(s: String) return t_p_string is + sp: t_p_string; + begin + pool.allocate(sp, s, hash(s)); + return sp; + end new_p_string; + + foo_string : t_p_string; +begin + foo_string := new_p_string("foo"); + raise Constraint_Error; +exception + when Program_Error => + null; +end Access7; -- 2.30.2