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

3 files changed, 134 insertions, 62 deletions

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index b3517bf..9aa83aa 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -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.
-
-      --  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;
+      --  Specs for dispatching stream attributes.
+
+      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,32 +6019,38 @@ 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);
-            Append_To (Res, Decl);
-         end if;
+      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 No (TSS (Tag_Typ, TSS_Stream_Write)) then
-            Build_Record_Write_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)
+      --  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 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_Output)) then
-               Build_Record_Or_Elementary_Output_Procedure
-                 (Loc, Tag_Typ, Decl, Ent);
-               Append_To (Res, Decl);
-            end if;
+         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;
       end if;
 
@@ -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;
diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb
index a38ce46..c587534 100644
--- a/gcc/ada/exp_strm.adb
+++ b/gcc/ada/exp_strm.adb
@@ -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
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index a391113..f10ec25 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -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;