From: Justin Squirek <squirek@adacore.com>
Date: Thu, 11 Jul 2019 08:01:30 +0000 (+0000)
Subject: [Ada] No warning for guaranteed accessibility check failures
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=ccf173059688499749a30b3252cc3c4ea4ab0d0c;p=gcc.git

[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  <squirek@adacore.com>

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
---

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  <squirek@adacore.com>
+
+	* checks.adb (Apply_Accessibility_Check): Add check for constant
+	folded conditions on accessibility checks.
+
 2019-07-11  Arnaud Charlet  <charlet@adacore.com>
 
 	* 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  <squirek@adacore.com>
+
+	* gnat.dg/access7.adb: New testcase.
+
 2019-07-11  Yannick Moy  <moy@adacore.com>
 
 	* 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;