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

[Ada] Implement AI12-0030: Stream attribute availability 

gcc/ada/

	* sem_util.ads, sem_util.adb: Declare and implement a new
	predicate, Derivation_Too_Early_To_Inherit.  This function
	indicates whether a given derived type fails to inherit a given
	streaming-related attribute from its parent type because the
	declaration of the derived type precedes the corresponding
	attribute_definition_clause of the parent.
	* exp_tss.adb (Find_Inherited_TSS): Call
	Derivation_Too_Early_To_Inherit instead of unconditionally
	assuming that a parent type's streaming attribute is available
	for inheritance by an immediate descendant type.
	* sem_attr.adb (Stream_Attribute_Available): Call
	Derivation_Too_Early_To_Inherit instead of unconditionally
	assuming that a parent type's streaming attribute is available
	for inheritance by an immediate descendant type.
	* exp_attr.adb (Default_Streaming_Unavailable): A new predicate;
	given a type, indicates whether predefined (as opposed to
	user-defined) streaming operations for the type should be
	implemented by raising Program_Error.
	(Expand_N_Attribute_Reference): For each of the 4
	streaming-related attributes (i.e., Read, Write, Input, Output),
	after determining that no user-defined implementation is
	available (including a Stream_Convert pragma), call
	Default_Streaming_Unavailable; if that call returns True, then
	implement the streaming operation as "raise Program_Error;".
This commit is contained in:
Steve Baird 2020-08-18 13:51:37 -07:00 committed by Pierre-Marie de Rodat
parent 46e5478350
commit 29f2d76c65
5 changed files with 163 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
gcc/ada/exp_attr.adb
View File

@ -136,6 +136,12 @@ package body Exp_Attr is
-- special-case code that shuffles partial and full views in the middle
-- of semantic analysis and expansion.
function Default_Streaming_Unavailable (Typ : Entity_Id) return Boolean;
--
-- In most cases, references to unavailable streaming attributes
-- are rejected at compile time. In some obscure cases involving
-- generics and formal derived types, the problem is dealt with at runtime.
procedure Expand_Access_To_Protected_Op
(N : Node_Id;
Pref : Node_Id;
@ -926,6 +932,24 @@ package body Exp_Attr is
end if;
end Compile_Stream_Body_In_Scope;
-----------------------------------
-- Default_Streaming_Unavailable --
-----------------------------------
function Default_Streaming_Unavailable (Typ : Entity_Id) return Boolean is
Btyp : constant Entity_Id := Implementation_Base_Type (Typ);
begin
if Is_Immutably_Limited_Type (Btyp)
and then not Is_Tagged_Type (Btyp)
and then not (Ekind (Btyp) = E_Record_Type
and then Present (Corresponding_Concurrent_Type (Btyp)))
then
pragma Assert (In_Instance_Body);
return True;
end if;
return False;
end Default_Streaming_Unavailable;
-----------------------------------
-- Expand_Access_To_Protected_Op --
-----------------------------------
@ -3954,6 +3978,18 @@ package body Exp_Attr is
Analyze_And_Resolve (N, B_Type);
return;
-- Limited types
elsif Default_Streaming_Unavailable (U_Type) then
-- Do the same thing here as is done above in the
-- case where a No_Streams restriction is active.
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Stream_Operation_Not_Allowed));
Set_Etype (N, B_Type);
return;
-- Elementary types
elsif Is_Elementary_Type (U_Type) then
@ -5074,6 +5110,18 @@ package body Exp_Attr is
Analyze (N);
return;
-- Limited types
elsif Default_Streaming_Unavailable (U_Type) then
-- Do the same thing here as is done above in the
-- case where a No_Streams restriction is active.
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Stream_Operation_Not_Allowed));
Set_Etype (N, Standard_Void_Type);
return;
-- For elementary types, we call the W_xxx routine directly. Note
-- that the effect of Write and Output is identical for the case
-- of an elementary type (there are no discriminants or bounds).
@ -5907,6 +5955,18 @@ package body Exp_Attr is
Analyze (N);
return;
-- Limited types
elsif Default_Streaming_Unavailable (U_Type) then
-- Do the same thing here as is done above in the
-- case where a No_Streams restriction is active.
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Stream_Operation_Not_Allowed));
Set_Etype (N, B_Type);
return;
-- For elementary types, we call the I_xxx routine using the first
-- parameter and then assign the result into the second parameter.
-- We set Assignment_OK to deal with the conversion case.
@ -7516,6 +7576,18 @@ package body Exp_Attr is
Analyze (N);
return;
-- Limited types
elsif Default_Streaming_Unavailable (U_Type) then
-- Do the same thing here as is done above in the
-- case where a No_Streams restriction is active.
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Stream_Operation_Not_Allowed));
Set_Etype (N, U_Type);
return;
-- For elementary types, we call the W_xxx routine directly
elsif Is_Elementary_Type (U_Type) then

8
gcc/ada/exp_tss.adb
View File

@ -164,7 +164,13 @@ package body Exp_Tss is
-- If Typ is a derived type, it may inherit attributes from an ancestor
if No (Proc) and then Is_Derived_Type (Btyp) then
Proc := Find_Inherited_TSS (Etype (Btyp), Nam);
if not Derivation_Too_Early_To_Inherit (Btyp, Nam) then
Proc := Find_Inherited_TSS (Etype (Btyp), Nam);
elsif Is_Derived_Type (Etype (Btyp)) then
-- Skip one link in the derivation chain
Proc := Find_Inherited_TSS
(Etype (Base_Type (Etype (Btyp))), Nam);
end if;
end if;
-- If nothing else, use the TSS of the root type

14
gcc/ada/sem_attr.adb
View File

@ -12409,11 +12409,17 @@ package body Sem_Attr is
-- applies to an ancestor type.
while Etype (Etyp) /= Etyp loop
Etyp := Etype (Etyp);
declare
Derived_Type : constant Entity_Id := Etyp;
begin
Etyp := Etype (Etyp);
if Has_Stream_Attribute_Definition (Etyp, Nam) then
return True;
end if;
if Has_Stream_Attribute_Definition (Etyp, Nam) then
if not Derivation_Too_Early_To_Inherit (Derived_Type, Nam) then
return True;
end if;
end if;
end;
end loop;
if Ada_Version < Ada_2005 then

66
gcc/ada/sem_util.adb
View File

@ -50,6 +50,7 @@ with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
@ -7288,6 +7289,71 @@ package body Sem_Util is
return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
end Depends_On_Discriminant;
-------------------------------------
-- Derivation_Too_Early_To_Inherit --
-------------------------------------
function Derivation_Too_Early_To_Inherit
(Typ : Entity_Id; Streaming_Op : TSS_Name_Type) return Boolean is
Btyp : constant Entity_Id := Implementation_Base_Type (Typ);
Parent_Type : Entity_Id;
begin
if Is_Derived_Type (Btyp) then
Parent_Type := Implementation_Base_Type (Etype (Btyp));
pragma Assert (Parent_Type /= Btyp);
if Has_Stream_Attribute_Definition
(Parent_Type, Streaming_Op)
and then In_Same_Extended_Unit (Btyp, Parent_Type)
and then Instantiation (Get_Source_File_Index (Sloc (Btyp))) =
Instantiation (Get_Source_File_Index (Sloc (Parent_Type)))
then
declare
-- ??? Avoid code duplication here with
-- Sem_Cat.Has_Stream_Attribute_Definition by introducing a
-- new function to be called from both places?
Rep_Item : Node_Id := First_Rep_Item (Parent_Type);
Real_Rep : Node_Id;
Found : Boolean := False;
begin
while Present (Rep_Item) loop
Real_Rep := Rep_Item;
if Nkind (Rep_Item) = N_Aspect_Specification then
Real_Rep := Aspect_Rep_Item (Rep_Item);
end if;
if Nkind (Real_Rep) = N_Attribute_Definition_Clause then
case Chars (Real_Rep) is
when Name_Read =>
Found := Streaming_Op = TSS_Stream_Read;
when Name_Write =>
Found := Streaming_Op = TSS_Stream_Write;
when Name_Input =>
Found := Streaming_Op = TSS_Stream_Input;
when Name_Output =>
Found := Streaming_Op = TSS_Stream_Output;
when others =>
null;
end case;
end if;
if Found then
return Earlier_In_Extended_Unit (Btyp, Real_Rep);
end if;
Next_Rep_Item (Rep_Item);
end loop;
end;
end if;
end if;
return False;
end Derivation_Too_Early_To_Inherit;
-------------------------
-- Designate_Same_Unit --
-------------------------

8
gcc/ada/sem_util.ads
View File

@ -665,6 +665,14 @@ package Sem_Util is
-- indication or a scalar subtype where one of the bounds is a
-- discriminant.
function Derivation_Too_Early_To_Inherit
(Typ : Entity_Id; Streaming_Op : TSS_Name_Type) return Boolean;
-- Returns True if Typ is a derived type, the given Streaming_Op
-- (one of Read, Write, Input, or Output) is explicitly specified
-- for Typ's parent type, and that attribute specification is *not*
-- inherited by Typ because the declaration of Typ precedes that
-- of the attribute specification.
function Designate_Same_Unit
(Name1 : Node_Id;
Name2 : Node_Id) return Boolean;