--- gcc/ada/exp_ch3.adb +++ 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 => --- gcc/ada/sem_aggr.adb +++ 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; --- gcc/ada/sem_ch3.adb +++ 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" & --- gcc/ada/sem_ch4.adb +++ 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 --- /dev/null new file mode 100644 +++ 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