exp_ch3.adb (Check_Attr): New subprogram.
2005-03-17 Thomas Quinot <quinot@adacore.com> * exp_ch3.adb (Check_Attr): New subprogram. (Check_Stream_Attribute): Move the code for 13.13.2(9/1) enforcement into a new Check_Attr subprogram, in order to provide a more explanatory error message (including the name of the missing attribute). (Stream_Operation_OK): Renamed from Stream_Operations_OK. This subprogram determines whether a default implementation exists for a given stream attribute. (Make_Predefined_Primitive_Specs, Predefined_Primitive_Bodies): Determine whether to generate a default implementation for each stream attribute separately, as this depends on the specific attribute. * exp_strm.adb (Make_Field_Attribute): For the case of an illegal limited extension where a stream attribute is missing for a limited component (which will have been flagged in Exp_Ch3.Sem_Attr), do not generate a bogus reference to the missing attribute to prevent cascaded errors. Instead, generate a null statement. * sem_attr.adb (Check_Stream_Attribute): A stream attribute is available for a limited type if it has been specified for an ancestor of the type. From-SVN: r96666
This commit is contained in:
Thomas Quinot
Arnaud Charlet
parent
2b59968790
commit
d2d3604c74
@ -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;
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user