From: Ed Schonberg Date: Mon, 8 Jul 2019 08:13:48 +0000 (+0000) Subject: [Ada] Crash on timed entry call with a delay given by a type conversion X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=1bb2e1d96eb23d2289765cd0fd9ef10b7a3b7ea3;p=gcc.git [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 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 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e6eac08a802..1650732e2d6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2019-07-08 Ed Schonberg + + * 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 * 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 03f133f05b2..e742ec3818c 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 a0b6bb4d71f..25f6636f5f2 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-07-08 Ed Schonberg + + * gnat.dg/entry1.adb, gnat.dg/entry1.ads: New testcase. + 2019-07-08 Ed Schonberg * gnat.dg/fixed_delete.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/entry1.adb b/gcc/testsuite/gnat.dg/entry1.adb new file mode 100644 index 00000000000..7577a267124 --- /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 00000000000..7dcc7b5c38d --- /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;