[Ada] Ada 2020: Raise expressions in limited contexts (AI12-0172)

This patch adds support for the use of raise expressions in more
limited contexts (as described in the Ada Isssue AI12-0172).

2019-09-17  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_ch3.adb (Build_Record_Init_Proc): Do not generate code to
	adjust the tag component when the record is initialized with a
	raise expression.
	* sem_aggr.adb (Valid_Limited_Ancestor): Return True for
	N_Raise_Expression nodes.
	(Valid_Ancestor_Type): Return True for raise expressions.
	* sem_ch3.adb (Analyze_Component_Declaration): Do not report an
	error when a component is initialized with a raise expression.
	* sem_ch4.adb (Analyze_Qualified_Expression): Do not report an
	error when the aggregate has a raise expression.

gcc/testsuite/

	* gnat.dg/limited4.adb: New testcase.

From-SVN: r275776

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index fb1f7f5a2ff4601c851abc270f578d8c87b99d44..2855751d857a58be922c2786bce526a1996cdc85 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,16 @@
+2019-09-17  Javier Miranda  <miranda@adacore.com>
+
+       * exp_ch3.adb (Build_Record_Init_Proc): Do not generate code to
+       adjust the tag component when the record is initialized with a
+       raise expression.
+       * sem_aggr.adb (Valid_Limited_Ancestor): Return True for
+       N_Raise_Expression nodes.
+       (Valid_Ancestor_Type): Return True for raise expressions.
+       * sem_ch3.adb (Analyze_Component_Declaration): Do not report an
+       error when a component is initialized with a raise expression.
+       * sem_ch4.adb (Analyze_Qualified_Expression): Do not report an
+       error when the aggregate has a raise expression.
+
 2019-09-17  Piotr Trojanek  <trojanek@adacore.com>
 
        * ali.ads: Fix casing in comment.

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 87636002aa08202262135715a0a02dcdf771b468..b08f51c31da2ff7eb5817e66404c4d1e47829feb 100644 (file)
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -1922,9 +1922,15 @@ package body Exp_Ch3 is
 
          --  Adjust the tag if tagged (because of possible view conversions).
          --  Suppress the tag adjustment when not Tagged_Type_Expansion because
-         --  tags are represented implicitly in objects.
+         --  tags are represented implicitly in objects, and when the record is
+         --  initialized with a raise expression.
 
-         if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
+         if Is_Tagged_Type (Typ)
+           and then Tagged_Type_Expansion
+           and then Nkind (Exp) /= N_Raise_Expression
+           and then (Nkind (Exp) /= N_Qualified_Expression
+                       or else Nkind (Expression (Exp)) /= N_Raise_Expression)
+         then
             Append_To (Res,
               Make_Assignment_Statement (Default_Loc,
                 Name       =>

diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index bc801215d9511f3bb8a1170e7b8934fd46ae4cd8..87fe050bb4c0b1bdbb374ecd5c27cec5bb6723e0 100644 (file)
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -3158,6 +3158,9 @@ package body Sem_Aggr is
          elsif Nkind (Anc) = N_Qualified_Expression then
             return Valid_Limited_Ancestor (Expression (Anc));
 
+         elsif Nkind (Anc) = N_Raise_Expression then
+            return True;
+
          else
             return False;
          end if;
@@ -3199,6 +3202,13 @@ package body Sem_Aggr is
             then
                return True;
 
+            --  The parent type may be a raise expression (which is legal in
+            --  any expression context).
+
+            elsif A_Type = Raise_Type then
+               A_Type := Etype (Imm_Type);
+               return True;
+
             else
                Imm_Type := Etype (Base_Type (Imm_Type));
             end if;

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 6af941910085ec7bf303a78499fc6a91517267c9..86b6e0d3d5901a2bba628146ca70d17308c134ed 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2047,10 +2047,23 @@ package body Sem_Ch3 is
          end if;
       end if;
 
+      --  Avoid reporting spurious errors if the component is initialized with
+      --  a raise expression (which is legal in any expression context)
+
+      if Present (E)
+        and then
+          (Nkind (E) = N_Raise_Expression
+             or else (Nkind (E) = N_Qualified_Expression
+                        and then Nkind (Expression (E)) = N_Raise_Expression))
+      then
+         null;
+
       --  The parent type may be a private view with unknown discriminants,
       --  and thus unconstrained. Regular components must be constrained.
 
-      if not Is_Definite_Subtype (T) and then Chars (Id) /= Name_uParent then
+      elsif not Is_Definite_Subtype (T)
+        and then Chars (Id) /= Name_uParent
+      then
          if Is_Class_Wide_Type (T) then
             Error_Msg_N
                ("class-wide subtype with unknown discriminants" &

diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 0dccd33a5e40f9aa8ed9358d541a9b0a7c2238b4..313398a7921f02bff588be7631bc1bcff5202c91 100644 (file)
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -4001,7 +4001,9 @@ package body Sem_Ch4 is
 
       if Is_Class_Wide_Type (T) then
          if not Is_Overloaded (Expr) then
-            if Base_Type (Etype (Expr)) /= Base_Type (T) then
+            if Base_Type (Etype (Expr)) /= Base_Type (T)
+              and then Etype (Expr) /= Raise_Type
+            then
                if Nkind (Expr) = N_Aggregate then
                   Error_Msg_N ("type of aggregate cannot be class-wide", Expr);
                else

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b701f9e29e5e49a1c708478598cfd09e8d13d316..30c75dfea8f78e2af206132ca89467048e50d3e3 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2019-09-17  Javier Miranda  <miranda@adacore.com>
+
+       * gnat.dg/limited4.adb: New testcase.
+
 2019-09-17  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gnat.dg/pack25.adb: New testcase.

diff --git a/gcc/testsuite/gnat.dg/limited4.adb b/gcc/testsuite/gnat.dg/limited4.adb
new file mode 100644 (file)
index 0000000..1a8ec97
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/limited4.adb
@@ -0,0 +1,58 @@
+--  { dg-do compile }
+procedure Limited4 is
+    TBD_Error : exception;
+
+    type Lim_Rec is limited record
+        A : Integer;
+        B : Boolean;
+    end record;
+
+    type Lim_Tagged is tagged limited record
+        R : Lim_Rec;
+        N : Natural;
+    end record;
+
+    type Lim_Ext is new Lim_Tagged with record
+       G : Natural;
+    end record;
+
+    --  a) initialization expression of a CW object_declaration
+
+    Obj1 : Lim_Tagged'Class := (raise TBD_Error);
+    Obj2 : Lim_Tagged'Class := Lim_Tagged'Class'(raise TBD_Error);
+
+    --  b) initialization expression of a CW component_declaration
+
+    type Rec is record
+       Comp01 : Lim_Tagged'Class := (raise TBD_Error);
+       Comp02 : Lim_Tagged'Class := Lim_Tagged'Class'((raise TBD_Error));
+    end record;
+
+    --  c) the expression of a record_component_association
+
+    Obj : Lim_Tagged := (R => raise TBD_Error, N => 4);
+
+    --  d) the expression for an ancestor_part of an extension_aggregate
+
+    Ext1 : Lim_Ext := ((raise TBD_Error) with G => 0);
+    Ext2 : Lim_Ext := (Lim_Tagged'(raise TBD_Error) with G => 0);
+
+    --  e) default_expression or actual parameter for a formal object of
+    --     mode in
+
+    function Do_Test1 (Obj : Lim_Tagged) return Boolean is
+    begin
+       return True;
+    end;
+
+    function Do_Test2
+      (Obj : Lim_Tagged := (raise TBD_Error)) return Boolean is
+    begin
+       return True;
+    end;
+
+    Check : Boolean;
+begin
+    Check := Do_Test1 (raise TBD_Error);
+    Check := Do_Test2;
+end;
\ No newline at end of file