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.
Tested on x86_64-pc-linux-gnu, committed on trunk
2019-07-08 Ed Schonberg <schonb...@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.--- gcc/ada/exp_ch9.adb
+++ 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
--- /dev/null
new file mode 100644
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
