diff options
author | Javier Miranda <miranda@adacore.com> | 2019-09-17 07:59:53 +0000 |
---|---|---|
committer | Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> | 2019-09-17 07:59:53 +0000 |
commit | 327940801d612d563781e5b58063889d247058b4 (patch) | |
tree | 6b276c14793087a13b68c1e4a127d7569d26b2e6 | |
parent | 92167df3c9735de9c62bab9bf325618febc75198 (diff) | |
download | gcc-327940801d612d563781e5b58063889d247058b4.zip gcc-327940801d612d563781e5b58063889d247058b4.tar.gz gcc-327940801d612d563781e5b58063889d247058b4.tar.bz2 |
[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
-rw-r--r-- | gcc/ada/ChangeLog | 13 | ||||
-rw-r--r-- | gcc/ada/exp_ch3.adb | 10 | ||||
-rw-r--r-- | gcc/ada/sem_aggr.adb | 10 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 15 | ||||
-rw-r--r-- | gcc/ada/sem_ch4.adb | 4 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 4 | ||||
-rw-r--r-- | gcc/testsuite/gnat.dg/limited4.adb | 58 |
7 files changed, 110 insertions, 4 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fb1f7f5..2855751 100644 --- 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 8763600..b08f51c 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 bc80121..87fe050 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 6af9419..86b6e0d 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 0dccd33..313398a 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 b701f9e..30c75df 100644 --- 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 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 |