[Ada] Implement AI12-0036 (a new legality check for instantiations)

Message ID 20191212100431.GA114743@adacore.com
State New
Headers show
Series
  • [Ada] Implement AI12-0036 (a new legality check for instantiations)
Related show

Commit Message

Pierre-Marie de Rodat Dec. 12, 2019, 10:04 a.m.
AI12-0036 is a binding interpretation which adds the following legality
rule:

   The actual type for a formal derived type shall be tagged if and only
   if the formal derived type is a private extension.

Implement this new compile-time check. The check is implemented without
checking the value of Ada_Version because the AI is a binding
intepretation, and because the possible consequences of failing to
detect a violation may be severe.

Tested on x86_64-pc-linux-gnu, committed on trunk

2019-12-12  Steve Baird  <baird@adacore.com>

gcc/ada/

	* sem_ch12.adb
	(Instantiate_Type.Validate_Derived_Type_Instance): Implement the
	legality check of AI12-0036

Patch

--- gcc/ada/sem_ch12.adb
+++ gcc/ada/sem_ch12.adb
@@ -13166,6 +13166,35 @@  package body Sem_Ch12 is
                Abandon_Instantiation (Actual);
             end if;
          end if;
+
+         --  Don't check Ada_Version here (for now) because AI12-0036 is
+         --  a binding interpretation; this decision may be reversed if
+         --  the situation turns out to be similar to that of the preceding
+         --  Is_Limited_Type test (see preceding comment).
+
+         declare
+            Formal_Is_Private_Extension : constant Boolean :=
+              Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration;
+
+            Actual_Is_Tagged : constant Boolean := Is_Tagged_Type (Act_T);
+         begin
+            if Actual_Is_Tagged /= Formal_Is_Private_Extension then
+               if In_Instance then
+                  null;
+               else
+                  if Actual_Is_Tagged then
+                     Error_Msg_NE
+                       ("actual for & cannot be a tagged type",
+                        Actual, Gen_T);
+                  else
+                     Error_Msg_NE
+                       ("actual for & must be a tagged type",
+                        Actual, Gen_T);
+                  end if;
+                  Abandon_Instantiation (Actual);
+               end if;
+            end if;
+         end;
       end Validate_Derived_Type_Instance;
 
       ----------------------------------------