From fcef060c9b321edcb24a56616588e712c22029ba Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Mon, 19 Aug 2019 08:37:18 +0000 Subject: [PATCH] [Ada] Crash on object initialization that is call to expression function This patch fixes a compiler abort on an object declaration for a class-wide type whose expression is a call to an expression function that returns type extension. 2019-08-19 Ed Schonberg gcc/ada/ * sem_res.adb (Resolve_Call): A call to an expression function freezes when expander is active, unless the call appears within the body of another expression function, gcc/testsuite/ * gnat.dg/expr_func9.adb: New testcase. From-SVN: r274662 --- gcc/ada/ChangeLog | 6 ++++++ gcc/ada/sem_res.adb | 4 +++- gcc/testsuite/ChangeLog | 4 ++++ gcc/testsuite/gnat.dg/expr_func9.adb | 24 ++++++++++++++++++++++++ 4 files changed, 37 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gnat.dg/expr_func9.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 932ff97f2c1..1f490b3efe1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2019-08-19 Ed Schonberg + + * sem_res.adb (Resolve_Call): A call to an expression function + freezes when expander is active, unless the call appears within + the body of another expression function, + 2019-08-19 Dmitriy Anisimkov * libgnat/s-os_lib.ads, libgnat/s-os_lib.adb (To_Ada, To_C): New diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 8f2e35894d4..7a52b90c98f 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6314,13 +6314,15 @@ package body Sem_Res is -- an expression function may appear when it is part of a default -- expression in a call to an initialization procedure, and must be -- frozen now, even if the body is inserted at a later point. + -- Otherwise, the call freezes the expression if expander is active, + -- for example as part of an object declaration. if Is_Entity_Name (Subp) and then not In_Spec_Expression and then not Is_Expression_Function_Or_Completion (Current_Scope) and then (not Is_Expression_Function_Or_Completion (Entity (Subp)) - or else Scope (Entity (Subp)) = Current_Scope) + or else Expander_Active) then if Is_Expression_Function (Entity (Subp)) then diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 127a223f238..2dd707d36c6 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-08-19 Ed Schonberg + + * gnat.dg/expr_func9.adb: New testcase. + 2019-08-19 Bob Duff * gnat.dg/valid_scalars2.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/expr_func9.adb b/gcc/testsuite/gnat.dg/expr_func9.adb new file mode 100644 index 00000000000..4bfa21dc647 --- /dev/null +++ b/gcc/testsuite/gnat.dg/expr_func9.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure Expr_Func9 is + + type Root is interface; + + type Child1 is new Root with null record; + + type Child2 is new Root with record + I2 : Integer; + end record; + + function Create (I : Integer) return Child2 is (I2 => I); + + I : Root'Class := + (if False + then Child1'(null record) + else + Create (1)); + +begin + null; +end Expr_Func9; -- 2.30.2