[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 703280c2d01875fee3e7ea4fb9decdcebcb7b4fe..9104658a0089699edda143908482b5b1b6fe80f0 100644 (file)
--- 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 601b932a1f391d422a2f61b30b5f8a0cf437ab2c..7ca66bdbb608fad0dbad36c165998127a1024bf0 100644 (file)
--- 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 24ecc217f73411f2d09fb28bed60d7f59ef9af83..3b393fb60cdfc2a9d5b642fc280a64a61753b1ae 100644 (file)
--- 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 (file)
index 0000000..e481312
--- /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;