diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index b3517bf18ba..9aa83aa51dd 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -285,10 +285,14 @@ package body Exp_Ch3 is -- Freeze entities of all predefined primitive operations. This is needed -- because the bodies of these operations do not normally do any freezeing. - function Stream_Operations_OK (Typ : Entity_Id) return Boolean; - -- Check whether stream operations must be emitted for a given type. - -- Various restrictions prevent the generation of these operations, as - -- a useful optimization or for certification purposes. + function Stream_Operation_OK + (Typ : Entity_Id; + Operation : TSS_Name_Type) return Boolean; + -- Check whether the named stream operation must be emitted for a given + -- type. The rules for inheritance of stream attributes by type extensions + -- are enforced by this function. Furthermore, various restrictions prevent + -- the generation of these operations, as a useful optimization or for + -- certification purposes. -------------------------- -- Adjust_Discriminants -- @@ -3012,23 +3016,32 @@ package body Exp_Ch3 is Par_Read : constant Boolean := Present (TSS (Par, TSS_Stream_Read)); Par_Write : constant Boolean := Present (TSS (Par, TSS_Stream_Write)); + procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type); + -- Check that Comp has a user-specified Nam stream attribute + + procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is + begin + if No (TSS (Base_Type (Etype (Comp)), TSS_Nam)) then + Error_Msg_Name_1 := Nam; + Error_Msg_N + ("|component& in limited extension must have% attribute", Comp); + end if; + end Check_Attr; + begin if Par_Read or else Par_Write then Comp := First_Component (Typ); while Present (Comp) loop if Comes_From_Source (Comp) - and then Original_Record_Component (Comp) = Comp + and then Original_Record_Component (Comp) = Comp and then Is_Limited_Type (Etype (Comp)) then - if (Par_Read and then - No (TSS (Base_Type (Etype (Comp)), TSS_Stream_Read))) - or else - (Par_Write and then - No (TSS (Base_Type (Etype (Comp)), TSS_Stream_Write))) - then - Error_Msg_N - ("|component must have Stream attribute", - Parent (Comp)); + if Par_Read then + Check_Attr (Name_Read, TSS_Stream_Read); + end if; + + if Par_Write then + Check_Attr (Name_Write, TSS_Stream_Write); end if; end if; @@ -5543,22 +5556,24 @@ package body Exp_Ch3 is Ret_Type => Standard_Integer)); - -- Specs for dispatching stream attributes. We skip these for limited - -- types, since there is no question of dispatching in the limited case. + -- Specs for dispatching stream attributes. - -- We also skip these operations if dispatching is not available - -- or if streams are not available (since what's the point?) - - if Stream_Operations_OK (Tag_Typ) then - Append_To (Res, - Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Read)); - Append_To (Res, - Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Write)); - Append_To (Res, - Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Input)); - Append_To (Res, - Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Output)); - end if; + declare + Stream_Op_TSS_Names : + constant array (Integer range <>) of TSS_Name_Type := + (TSS_Stream_Read, + TSS_Stream_Write, + TSS_Stream_Input, + TSS_Stream_Output); + begin + for Op in Stream_Op_TSS_Names'Range loop + if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then + Append_To (Res, + Predef_Stream_Attr_Spec (Loc, Tag_Typ, + Stream_Op_TSS_Names (Op))); + end if; + end loop; + end; -- Spec of "=" if expanded if the type is not limited and if a -- user defined "=" was not already declared for the non-full @@ -6004,33 +6019,39 @@ package body Exp_Ch3 is -- non-limited types (in the limited case there is no dispatching). -- We also skip them if dispatching or finalization are not available. - if Stream_Operations_OK (Tag_Typ) then - if No (TSS (Tag_Typ, TSS_Stream_Read)) then - Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent); + if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read) + and then No (TSS (Tag_Typ, TSS_Stream_Read)) + then + Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write) + and then No (TSS (Tag_Typ, TSS_Stream_Write)) + then + Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + -- Skip bodies of _Input and _Output for the abstract case, since + -- the corresponding specs are abstract (see Predef_Spec_Or_Body) + + if not Is_Abstract (Tag_Typ) then + if Stream_Operation_OK (Tag_Typ, TSS_Stream_Input) + and then No (TSS (Tag_Typ, TSS_Stream_Input)) + then + Build_Record_Or_Elementary_Input_Function + (Loc, Tag_Typ, Decl, Ent); Append_To (Res, Decl); end if; - if No (TSS (Tag_Typ, TSS_Stream_Write)) then - Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent); + if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output) + and then No (TSS (Tag_Typ, TSS_Stream_Output)) + then + Build_Record_Or_Elementary_Output_Procedure + (Loc, Tag_Typ, Decl, Ent); Append_To (Res, Decl); end if; - - -- Skip bodies of _Input and _Output for the abstract case, since - -- the corresponding specs are abstract (see Predef_Spec_Or_Body) - - if not Is_Abstract (Tag_Typ) then - if No (TSS (Tag_Typ, TSS_Stream_Input)) then - Build_Record_Or_Elementary_Input_Function - (Loc, Tag_Typ, Decl, Ent); - Append_To (Res, Decl); - end if; - - if No (TSS (Tag_Typ, TSS_Stream_Output)) then - Build_Record_Or_Elementary_Output_Procedure - (Loc, Tag_Typ, Decl, Ent); - Append_To (Res, Decl); - end if; - end if; end if; if not Is_Limited_Type (Tag_Typ) then @@ -6216,17 +6237,35 @@ package body Exp_Ch3 is return Res; end Predefined_Primitive_Freeze; - -------------------------- - -- Stream_Operations_OK -- - -------------------------- + ------------------------- + -- Stream_Operation_OK -- + ------------------------- + + function Stream_Operation_OK + (Typ : Entity_Id; + Operation : TSS_Name_Type) return Boolean + is + Has_Inheritable_Stream_Attribute : Boolean := False; - function Stream_Operations_OK (Typ : Entity_Id) return Boolean is begin + if Is_Limited_Type (Typ) + and then Is_Tagged_Type (Typ) + and then Is_Derived_Type (Typ) + then + -- Special case of a limited type extension: a default implementation + -- of the stream attributes Read and Write exists if the attribute + -- has been specified for an ancestor type. + + Has_Inheritable_Stream_Attribute := + Present (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation)); + end if; + return - not Is_Limited_Type (Typ) + not (Is_Limited_Type (Typ) + and then not Has_Inheritable_Stream_Attribute) and then RTE_Available (RE_Tag) and then RTE_Available (RE_Root_Stream_Type) and then not Restriction_Active (No_Dispatch) and then not Restriction_Active (No_Streams); - end Stream_Operations_OK; + end Stream_Operation_OK; end Exp_Ch3; diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index a38ce46007a..c5875348494 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -26,6 +26,7 @@ with Atree; use Atree; with Einfo; use Einfo; +with Exp_Tss; use Exp_Tss; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -36,7 +37,6 @@ with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; with Ttypes; use Ttypes; -with Exp_Tss; use Exp_Tss; with Uintp; use Uintp; package body Exp_Strm is @@ -1173,6 +1173,11 @@ package body Exp_Strm is Stms : List_Id; Typt : Entity_Id; + In_Limited_Extension : Boolean := False; + -- Set to True while processing the record extension definition + -- for an extension of a limited type (for which an ancestor type + -- has an explicit Nam attribute definition). + function Make_Component_List_Attributes (CL : Node_Id) return List_Id; -- Returns a sequence of attributes to process the components that -- are referenced in the given component list. @@ -1254,7 +1259,29 @@ package body Exp_Strm is -------------------------- function Make_Field_Attribute (C : Entity_Id) return Node_Id is + Field_Typ : constant Entity_Id := Stream_Base_Type (Etype (C)); + + TSS_Names : constant array (Name_Input .. Name_Write) of + TSS_Name_Type := + (Name_Read => TSS_Stream_Read, + Name_Write => TSS_Stream_Write, + Name_Input => TSS_Stream_Input, + Name_Output => TSS_Stream_Output, + others => TSS_Null); + pragma Assert (TSS_Names (Nam) /= TSS_Null); + begin + if In_Limited_Extension + and then Is_Limited_Type (Field_Typ) + and then No (Find_Inherited_TSS (Field_Typ, TSS_Names (Nam))) + then + -- The declaration is illegal per 13.13.2(9/1), and this is + -- enforced in Exp_Ch3.Check_Stream_Attributes. Keep the + -- caller happy by returning a null statement. + + return Make_Null_Statement (Loc); + end if; + return Make_Attribute_Reference (Loc, Prefix => @@ -1331,6 +1358,10 @@ package body Exp_Strm is if Nkind (Rdef) = N_Derived_Type_Definition then Rdef := Record_Extension_Part (Rdef); + + if Is_Limited_Type (Typt) then + In_Limited_Extension := True; + end if; end if; if Present (Component_List (Rdef)) then diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index a3911138a0b..f10ec25c707 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1244,12 +1244,14 @@ package body Sem_Attr is Btyp := Implementation_Base_Type (P_Type); -- Stream attributes not allowed on limited types unless the - -- stream attribute was generated by the expander (in which - -- case the underlying type will be used, as described in Sinfo). + -- attribute reference was generated by the expander (in which + -- case the underlying type will be used, as described in Sinfo), + -- or the attribute was specified explicitly for the type itself + -- or one of its ancestors. if Is_Limited_Type (P_Type) and then Comes_From_Source (N) - and then not Present (TSS (Btyp, Nam)) + and then not Present (Find_Inherited_TSS (Btyp, Nam)) and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert) then Error_Msg_Name_1 := Aname;