OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

exp_ch3.adb (Check_Attr): New subprogram.

Browse Source 
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 2005-03-18 12:48:35 +01:00 committed by Arnaud Charlet
parent 2b59968790
commit d2d3604c74
3 changed files with 133 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

153
gcc/ada/exp_ch3.adb
View File

@ -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;

33
gcc/ada/exp_strm.adb
View File

@ -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

8
gcc/ada/sem_attr.adb
View File

@ -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;