From dd4d8a71980487ddb4ac6c1ad0a1b8fb6c143592 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Thu, 4 Jul 2019 08:06:19 +0000 Subject: [PATCH] [Ada] Assertion failure on Default_Initial_Condition This patch prevents the association of a Default_Initial_Condition with an incomplete type whose full view is the private type or private extension subject to the aspect/pragma. 2019-07-04 Hristian Kirtchev gcc/ada/ * sem_util.adb (Propagate_DIC_Attributes): Do not propagate the Default_Initial_Condition attributes to an incomplete type. gcc/testsuite/ * gnat.dg/default_initial_condition.adb, gnat.dg/default_initial_condition_pack.adb, gnat.dg/default_initial_condition_pack.ads: New testcase. From-SVN: r273059 --- gcc/ada/ChangeLog | 5 +++++ gcc/ada/sem_util.adb | 7 +++++++ gcc/testsuite/ChangeLog | 6 ++++++ gcc/testsuite/gnat.dg/default_initial_condition.adb | 12 ++++++++++++ gcc/testsuite/gnat.dg/default_initial_condition_pack.adb | 7 +++++++ gcc/testsuite/gnat.dg/default_initial_condition_pack.ads | 12 ++++++++++++ 6 files changed, 49 insertions(+) create mode 100644 gcc/testsuite/gnat.dg/default_initial_condition.adb create mode 100644 gcc/testsuite/gnat.dg/default_initial_condition_pack.adb create mode 100644 gcc/testsuite/gnat.dg/default_initial_condition_pack.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index be26421..2925c84 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2019-07-04 Hristian Kirtchev + + * sem_util.adb (Propagate_DIC_Attributes): Do not propagate the + Default_Initial_Condition attributes to an incomplete type. + 2019-07-04 Ed Schonberg * sem_attr.adb (Check_Array_Type): An array type attribute such diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4d19c61..868e93e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -23327,6 +23327,13 @@ package body Sem_Util is if From_Typ = Typ then return; + + -- Nothing to do when the destination denotes an incomplete type + -- because the DIC is associated with the current instance of a + -- private type, thus it can never apply to an incomplete type. + + elsif Is_Incomplete_Type (Typ) then + return; end if; DIC_Proc := DIC_Procedure (From_Typ); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index dd22271..2b1a479 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2019-07-04 Hristian Kirtchev + + * gnat.dg/default_initial_condition.adb, + gnat.dg/default_initial_condition_pack.adb, + gnat.dg/default_initial_condition_pack.ads: New testcase. + 2019-07-04 Ed Schonberg * gnat.dg/aspect2.adb, gnat.dg/aspect2.ads: New testcase. diff --git a/gcc/testsuite/gnat.dg/default_initial_condition.adb b/gcc/testsuite/gnat.dg/default_initial_condition.adb new file mode 100644 index 0000000..5ba94a6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/default_initial_condition.adb @@ -0,0 +1,12 @@ +-- { dg-do run } +-- { dg-options "-gnata" } + +with Default_Initial_Condition_Pack; use Default_Initial_Condition_Pack; + +procedure Default_Initial_Condition is + Obj : T; +begin + if not DIC_Called then + raise Program_Error; + end if; +end Default_Initial_Condition; diff --git a/gcc/testsuite/gnat.dg/default_initial_condition_pack.adb b/gcc/testsuite/gnat.dg/default_initial_condition_pack.adb new file mode 100644 index 0000000..abcd491 --- /dev/null +++ b/gcc/testsuite/gnat.dg/default_initial_condition_pack.adb @@ -0,0 +1,7 @@ +package body Default_Initial_Condition_Pack is + function Is_OK (Val : T) return Boolean is + begin + DIC_Called := True; + return True; + end Is_OK; +end Default_Initial_Condition_Pack; diff --git a/gcc/testsuite/gnat.dg/default_initial_condition_pack.ads b/gcc/testsuite/gnat.dg/default_initial_condition_pack.ads new file mode 100644 index 0000000..c461bf2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/default_initial_condition_pack.ads @@ -0,0 +1,12 @@ +package Default_Initial_Condition_Pack is + type T; + type T is private + with Default_Initial_Condition => Is_OK (T); + + function Is_OK (Val : T) return Boolean; + + DIC_Called : Boolean := False; + +private + type T is null record; +end Default_Initial_Condition_Pack; -- 2.7.4