From: Javier Miranda <mira...@adacore.com>
gcc/ada/
* exp_intr.adb
(Expand_Dispatching_Constructor_Call): Report an error on
unsupported dispatching constructor calls and report a warning on
calls that may fail at run time.
gcc/testsuite/
* gnat.dg/abstract1.ads: Cleanup whitespaces.
* gnat.dg/abstract1.adb: Likewise and add -gnatws to silence new
warning.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_intr.adb | 44 +++++++++++++++++++++++++++++
gcc/testsuite/gnat.dg/abstract1.adb | 14 +++++----
gcc/testsuite/gnat.dg/abstract1.ads | 6 ++--
3 files changed, 55 insertions(+), 9 deletions(-)
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index bd987f089e1..cb9b5be1090 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -24,13 +24,16 @@
------------------------------------------------------------------------------
with Atree; use Atree;
+with Aspects; use Aspects;
with Checks; use Checks;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
+with Errout; use Errout;
with Expander; use Expander;
with Exp_Atag; use Exp_Atag;
+with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11;
with Exp_Code; use Exp_Code;
@@ -277,6 +280,47 @@ package body Exp_Intr is
Result_Typ : Entity_Id;
begin
+ pragma Assert (Is_Class_Wide_Type (Etype (Entity (Name (N)))));
+
+ -- Report case where we know that the generated code is wrong; that
+ -- is a dispatching constructor call whose controlling type has tasks
+ -- but its root type does not have tasks. In such case the constructor
+ -- subprogram of the root type does not have extra formals but the
+ -- constructor of the derivation must have extra formals.
+
+ if not Global_No_Tasking
+ and then not No_Run_Time_Mode
+ and then Is_Build_In_Place_Function (Entity (Name (N)))
+ and then not Has_Task (Root_Type (Etype (Entity (Name (N)))))
+ and then not Has_Aspect (Root_Type (Etype (Entity (Name (N)))),
+ Aspect_No_Task_Parts)
+ then
+ -- Case 1: Explicit tag reference (which allows static check)
+
+ if Nkind (Tag_Arg) = N_Identifier
+ and then Present (Entity (Tag_Arg))
+ and then Is_Tag (Entity (Tag_Arg))
+ then
+ if Has_Task (Related_Type (Entity (Tag_Arg))) then
+ Error_Msg_N ("unsupported dispatching constructor call", N);
+ Error_Msg_NE
+ ("\work around this problem by defining task component "
+ & "type& using access-to-task-type",
+ N, Related_Type (Entity (Tag_Arg)));
+ end if;
+
+ -- Case 2: Dynamic tag which may fail at run time
+
+ else
+ Error_Msg_N
+ ("unsupported dispatching constructor call if the type "
+ & "of the built object has task components??", N);
+ Error_Msg_N
+ ("\work around this problem by replacing task components "
+ & "with access-to-task-type components??", N);
+ end if;
+ end if;
+
-- Remove side effects from tag argument early, before rewriting
-- the dispatching constructor call, as Remove_Side_Effects relies
-- on Tag_Arg's Parent link properly attached to the tree (once the
diff --git a/gcc/testsuite/gnat.dg/abstract1.adb
b/gcc/testsuite/gnat.dg/abstract1.adb
index 97508fac2b8..36f75e9d495 100644
--- a/gcc/testsuite/gnat.dg/abstract1.adb
+++ b/gcc/testsuite/gnat.dg/abstract1.adb
@@ -1,18 +1,20 @@
-- { dg-do compile }
+-- { dg-options "-gnatws" }
+
with Ada.Tags.Generic_Dispatching_Constructor; use Ada.Tags;
package body abstract1 is
-
+
function New_T (Stream : not null access Root_Stream_Type'Class)
return T'Class is
function Construct is
new Generic_Dispatching_Constructor (T, Root_Stream_Type'Class,
Input);
E : constant String := String'Input (Stream);
I : constant Tag := Internal_Tag (E);
-
+
begin
return Construct (I, Stream);
end New_T;
-
+
function Input (Stream : not null access Root_Stream_Type'Class)
return IT is
begin
@@ -20,12 +22,12 @@ package body abstract1 is
Integer'Read (Stream, O.I);
end return;
end Input;
-
+
function Input (Stream : not null access Root_Stream_Type'Class)
return FT is
begin
return O : FT do
Float'Read (Stream, O.F);
- end return;
- end Input;
+ end return;
+ end Input;
end abstract1;
diff --git a/gcc/testsuite/gnat.dg/abstract1.ads
b/gcc/testsuite/gnat.dg/abstract1.ads
index bad9ee69874..de14d77a948 100644
--- a/gcc/testsuite/gnat.dg/abstract1.ads
+++ b/gcc/testsuite/gnat.dg/abstract1.ads
@@ -3,15 +3,15 @@ package abstract1 is
type T is abstract tagged limited null record;
function Input (Stream : not null access Root_Stream_Type'Class) return T
is abstract;
-
+
function New_T (Stream : not null access Root_Stream_Type'Class)
return T'Class;
-
+
type IT is limited new T with record
I : Integer;
end record;
function Input (Stream : not null access Root_Stream_Type'Class) return IT;
-
+
type FT is limited new T with record
F : Float;
end record;
--
2.34.1
