[Ada] Crash on timed entry call with a delay given by a type conversion

This patch fixes a compiler crash in the compiler on a timed entry call
whose delay expression is a type conversion, when FLoat_Overflow checks
are enabled.

2019-07-08  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* exp_ch9.adb (Expand_N_Timed_Entry_Call): Do not insert twice
	the assignment statement that computes the delay value, to
	prevent improper tree sharing when the value is a type
	conversion and Float_Overflow checks are enabled.

gcc/testsuite/

	* gnat.dg/entry1.adb, gnat.dg/entry1.ads: New testcase.

From-SVN: r273210

5 files changed, 103 insertions, 12 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index e6eac08..1650732 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2019-07-08  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch9.adb (Expand_N_Timed_Entry_Call): Do not insert twice
+	the assignment statement that computes the delay value, to
+	prevent improper tree sharing when the value is a type
+	conversion and Float_Overflow checks are enabled.
+
 2019-07-08  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* bindo.adb: Update the section on terminology to include new
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 03f133f..e742ec3 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -3887,6 +3887,7 @@ package body Exp_Ch9 is
 
          if Unprotected then
             Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
+            Set_Ekind (Defining_Identifier (New_Param), Ekind (Formal));
          end if;
 
          Append (New_Param, New_Plist);
@@ -10711,7 +10712,7 @@ package body Exp_Ch9 is
               Make_Defining_Identifier (Eloc,
                 New_External_Name (Chars (Ename), 'A', Num_Accept));
 
-            --  Link the acceptor to the original receiving entry
+            --  Link the acceptor to the original receiving entry.
 
             Set_Ekind           (PB_Ent, E_Procedure);
             Set_Receiving_Entry (PB_Ent, Eent);
@@ -12658,14 +12659,6 @@ package body Exp_Ch9 is
           Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc),
           Expression          => D_Disc));
 
-      --  Do the assignment at this stage only because the evaluation of the
-      --  expression must not occur earlier (see ACVC C97302A).
-
-      Append_To (Stmts,
-        Make_Assignment_Statement (Loc,
-          Name       => New_Occurrence_Of (D, Loc),
-          Expression => D_Conv));
-
       --  Parameter block processing
 
       --  Manually create the parameter block for dispatching calls. In the
@@ -12673,6 +12666,13 @@ package body Exp_Ch9 is
       --  to Build_Simple_Entry_Call.
 
       if Is_Disp_Select then
+         --  Compute the delay at this stage because the evaluation of
+         --  its expression must not occur earlier (see ACVC C97302A).
+
+         Append_To (Stmts,
+           Make_Assignment_Statement (Loc,
+             Name       => New_Occurrence_Of (D, Loc),
+             Expression => D_Conv));
 
          --  Tagged kind processing, generate:
          --    K : Ada.Tags.Tagged_Kind :=
@@ -12855,8 +12855,8 @@ package body Exp_Ch9 is
             Next (Stmt);
          end loop;
 
-         --  Do the assignment at this stage only because the evaluation
-         --  of the expression must not occur earlier (see ACVC C97302A).
+         --  Compute the delay at this stage because the evaluation of
+         --  its expression must not occur earlier (see ACVC C97302A).
 
          Insert_Before (Stmt,
            Make_Assignment_Statement (Loc,
@@ -14882,7 +14882,8 @@ package body Exp_Ch9 is
 
          --  Ditto for a package declaration or a full type declaration, etc.
 
-         elsif Nkind (N) = N_Package_Declaration
+         elsif
+           (Nkind (N) = N_Package_Declaration and then N /= Specification (N))
            or else Nkind (N) in N_Declaration
            or else Nkind (N) in N_Renaming_Declaration
          then
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a0b6bb4..25f6636 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,9 @@
 2019-07-08  Ed Schonberg  <schonberg@adacore.com>
 
+	* gnat.dg/entry1.adb, gnat.dg/entry1.ads: New testcase.
+
+2019-07-08  Ed Schonberg  <schonberg@adacore.com>
+
 	* gnat.dg/fixed_delete.adb: New testcase.
 
 2019-07-08  Javier Miranda  <miranda@adacore.com>
diff --git a/gcc/testsuite/gnat.dg/entry1.adb b/gcc/testsuite/gnat.dg/entry1.adb
new file mode 100644
index 0000000..7577a26
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/entry1.adb
@@ -0,0 +1,75 @@
+--  { dg-do compile }
+--  { dg-options "-gnateF" }
+
+PACKAGE BODY Entry1 IS
+
+   PROTECTED TYPE key_buffer IS
+
+      PROCEDURE clear;
+
+      ENTRY incr;
+      ENTRY put (val : IN Natural);
+      ENTRY get (val : OUT Natural);
+
+   PRIVATE
+
+      -- Stores Key states (key state controller)
+      -- purpose: exclusive access
+      max_len : Natural := 10;
+
+      cnt : Natural := 0;
+
+   END key_buffer;
+
+   PROTECTED BODY key_buffer IS
+
+      PROCEDURE clear IS
+      BEGIN
+         cnt := 0;
+      END clear;
+
+      ENTRY incr WHEN cnt < max_len IS
+      BEGIN
+         cnt := cnt + 1;
+      END;
+
+      ENTRY put (val : IN Natural) WHEN cnt < max_len IS
+      BEGIN
+         cnt := val;
+      END put;
+
+      ENTRY get (val : OUT Natural) WHEN cnt > 0 IS
+      BEGIN
+         val := cnt;
+      END get;
+
+   END key_buffer;
+
+   my_buffer : key_buffer;
+
+   FUNCTION pt2 (t : IN Float) RETURN Natural IS
+      c : Natural;
+      t2 : duration := duration (t);
+   BEGIN
+      SELECT
+         my_buffer.get (c);
+         RETURN c;
+      OR
+         DELAY t2;
+         RETURN 0;
+      END SELECT;
+   END pt2;
+
+   FUNCTION pt (t : IN Float) RETURN Natural IS
+      c : Natural;
+   BEGIN
+      SELECT
+         my_buffer.get (c);
+         RETURN c;
+      OR
+         DELAY Duration (t);
+         RETURN 0;
+      END SELECT;
+   END pt;
+
+END Entry1;
diff --git a/gcc/testsuite/gnat.dg/entry1.ads b/gcc/testsuite/gnat.dg/entry1.ads
new file mode 100644
index 0000000..7dcc7b5
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/entry1.ads
@@ -0,0 +1,4 @@
+PACKAGE Entry1 IS
+   FUNCTION pt (t : IN Float) RETURN Natural;
+   FUNCTION pt2 (t : IN Float) RETURN Natural;
+END Entry1;