[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;".

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 301479d..d3468d5 100644 (file)
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -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

diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb
index b640843..40943fb 100644 (file)
--- a/gcc/ada/exp_tss.adb
+++ b/gcc/ada/exp_tss.adb
@@ -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

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index db34cae..c80cc06 100644 (file)
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -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

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 1115dfc..30c5376 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -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 --
    -------------------------

diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index fdc4797..bcc7fd7 100644 (file)
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -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;