ada: Flag unsupported dispatching constructor calls

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.

diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index bd987f0..cb9b5be 100644 (file)
--- 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 97508fa..36f75e9 100644 (file)
--- 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 bad9ee6..de14d77 100644 (file)
--- 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;