@@ -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;
@@ -927,6 +933,24 @@ package body Exp_Attr is
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
@@ -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
@@ -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
@@ -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 --
-------------------------
@@ -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;