From: Javier Miranda Date: Tue, 17 Sep 2019 07:59:53 +0000 (+0000) Subject: [Ada] Ada 2020: Raise expressions in limited contexts (AI12-0172) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=327940801d612d563781e5b58063889d247058b4;p=gcc.git [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 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 fb1f7f5a2ff..2855751d857 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2019-09-17 Javier Miranda + + * 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 * ali.ads: Fix casing in comment. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 87636002aa0..b08f51c31da 100644 --- 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 bc801215d95..87fe050bb4c 100644 --- 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 6af94191008..86b6e0d3d59 100644 --- 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 0dccd33a5e4..313398a7921 100644 --- 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 b701f9e29e5..30c75dfea8f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-09-17 Javier Miranda + + * gnat.dg/limited4.adb: New testcase. + 2019-09-17 Eric Botcazou * 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 index 00000000000..1a8ec97f91c --- /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