[Ada] Warn on 'in out' param containing access in predefined private type

gcc/ada/

	* sem_util.adb, sem_util.ads (Has_Access_Values): New formal
	Include_Internal to indicate whether internal types should be
	included.
	* sem_warn.adb (Check_References): Change E_Out_Parameter to
	Formal_Kind, to match the comment about Spec_Entity.  Pass
	Include_Internal => False to Has_Access_Values, so that we warn
	on types with access values that happen to be in internal types,
	such as Unbounded_String.
	* sem_attr.adb (Attribute_Has_Access_Values): Pass
	Include_Internal => True to Has_Access_Values, to preserve
	existing behavior.
	* libgnat/g-rewdat.adb (Do_Output): Change B from 'in out' to
	'in', to avoid warning enabled by the change to sem_warn.adb.
	* libgnat/s-objrea.adb (Check_Read_Offset): Change S from 'in
	out' to 'in', to avoid warning enabled by the change to
	sem_warn.adb.

diff --git a/gcc/ada/libgnat/g-rewdat.adb b/gcc/ada/libgnat/g-rewdat.adb
index c257afa4c4f8b8b107c7ed1c05ad0cd2e240505a..3b4a0d02b4139845592a0d6efb6dd9b408076576 100644 (file)
--- a/gcc/ada/libgnat/g-rewdat.adb
+++ b/gcc/ada/libgnat/g-rewdat.adb
@@ -37,7 +37,7 @@ package body GNAT.Rewrite_Data is
    subtype SEO is Stream_Element_Offset;
 
    procedure Do_Output
-     (B      : in out Buffer;
+     (B      : Buffer;
       Data   : Stream_Element_Array;
       Output : not null access procedure (Data : Stream_Element_Array));
    --  Do the actual output. This ensures that we properly send the data
@@ -81,7 +81,7 @@ package body GNAT.Rewrite_Data is
    ---------------
 
    procedure Do_Output
-     (B      : in out Buffer;
+     (B      : Buffer;
       Data   : Stream_Element_Array;
       Output : not null access procedure (Data : Stream_Element_Array))
    is

diff --git a/gcc/ada/libgnat/s-objrea.adb b/gcc/ada/libgnat/s-objrea.adb
index 50be05a17920b837066cceb64ddc6b8aa3e28032..b5ca32fdbc9b5b696afe944525d1be6a4977b921 100644 (file)
--- a/gcc/ada/libgnat/s-objrea.adb
+++ b/gcc/ada/libgnat/s-objrea.adb
@@ -47,7 +47,7 @@ package body System.Object_Reader is
    function Trim_Trailing_Nuls (Str : String) return String;
    --  Return a copy of a string with any trailing NUL characters truncated
 
-   procedure Check_Read_Offset (S : in out Mapped_Stream; Size : uint32);
+   procedure Check_Read_Offset (S : Mapped_Stream; Size : uint32);
    --  Check that the SIZE bytes at the current offset are still in the stream
 
    -------------------------------------
@@ -1931,7 +1931,7 @@ package body System.Object_Reader is
       return To_String_Ptr_Len (Read (S));
    end Read;
 
-   procedure Check_Read_Offset (S : in out Mapped_Stream; Size : uint32) is
+   procedure Check_Read_Offset (S : Mapped_Stream; Size : uint32) is
    begin
       if S.Off + Offset (Size) > Offset (Last (S.Region)) then
          raise IO_Error with "could not read from object file";

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 63b0f09ea5d464662ce0e7ece87945532b48bd06..07ce4883fd4ef580c34ff26750a781a0915b033f 100644 (file)
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -8830,7 +8830,9 @@ package body Sem_Attr is
 
       when Attribute_Has_Access_Values =>
          Rewrite (N, New_Occurrence_Of
-           (Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc));
+           (Boolean_Literals
+             (Has_Access_Values (P_Root_Type, Include_Internal => True)),
+              Loc));
          Analyze_And_Resolve (N, Standard_Boolean);
 
       -----------------------

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index b71efde8567641fff2fa0f338ea24bb7c6c513a8..47b6a93e1503ec5f91d729405744da4d003777e9 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -11539,7 +11539,9 @@ package body Sem_Util is
    -- Has_Access_Values --
    -----------------------
 
-   function Has_Access_Values (T : Entity_Id) return Boolean is
+   function Has_Access_Values
+     (T : Entity_Id; Include_Internal : Boolean) return Boolean
+   is
       Typ : constant Entity_Id := Underlying_Type (T);
 
    begin
@@ -11552,11 +11554,17 @@ package body Sem_Util is
       if No (Typ) then
          return False;
 
+      elsif not Include_Internal
+        and then T /= Typ
+        and then In_Internal_Unit (Typ)
+      then
+         return False;
+
       elsif Is_Access_Type (Typ) then
          return True;
 
       elsif Is_Array_Type (Typ) then
-         return Has_Access_Values (Component_Type (Typ));
+         return Has_Access_Values (Component_Type (Typ), Include_Internal);
 
       elsif Is_Record_Type (Typ) then
          declare
@@ -11571,7 +11579,7 @@ package body Sem_Util is
                --  Check for access component, tag field does not count, even
                --  though it is implemented internally using an access type.
 
-               if Has_Access_Values (Etype (Comp))
+               if Has_Access_Values (Etype (Comp), Include_Internal)
                  and then Chars (Comp) /= Name_uTag
                then
                   return True;

diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index b8ad3820185dcc4a114d457d4e4a0e0bb235dcf7..1d4bd16896818caa948f6439c9879c9e907459d2 100644 (file)
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1312,7 +1312,8 @@ package Sem_Util is
    --  limited, packed array and other implementation types.  If Include_PAT
    --  is False, don't look inside packed array types.
 
-   function Has_Access_Values (T : Entity_Id) return Boolean;
+   function Has_Access_Values
+     (T : Entity_Id; Include_Internal : Boolean) return Boolean;
    --  Returns true if type or subtype T is an access type, or has a component
    --  (at any recursive level) that is an access type. This is a conservative
    --  predicate, if it is not known whether or not T contains access values
@@ -1320,6 +1321,9 @@ package Sem_Util is
    --  Note that tagged types return False. Even though the tag is implemented
    --  as an access type internally, this function tests only for access types
    --  known to the programmer. See also Has_Tagged_Component.
+   --
+   --  If Include_Internal is False, we return False for internal private types
+   --  whose full type contains access types.
 
    function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean;
    --  Returns True if Typ has one or more anonymous access discriminants

diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index 728927433dab7a3166cac88fd7c4c8e74474ac91..e85f49301756fb640f6ff8188b9a3674482abdd0 100644 (file)
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -1182,7 +1182,7 @@ package body Sem_Warn is
                --  First gather any Unset_Reference indication for E1. In the
                --  case of a parameter, it is the Spec_Entity that is relevant.
 
-               if Ekind (E1) = E_Out_Parameter
+               if Ekind (E1) in Formal_Kind
                  and then Present (Spec_Entity (E1))
                then
                   UR := Unset_Reference (Spec_Entity (E1));
@@ -1354,10 +1354,13 @@ package body Sem_Warn is
                      --  Suppress warning if composite type contains any access
                      --  component, since the logical effect of modifying a
                      --  parameter may be achieved by modifying a referenced
-                     --  object.
+                     --  object. This rationale does not apply to internal
+                     --  private types, so we warn even if a component is of
+                     --  something like Unbounded_String.
 
                      elsif Is_Composite_Type (E1T)
-                       and then Has_Access_Values (E1T)
+                       and then Has_Access_Values
+                         (E1T, Include_Internal => False)
                      then
                         null;
 
@@ -3090,7 +3093,7 @@ package body Sem_Warn is
             --  Here we generate the warning
 
             else
-               --  If -gnatwk is set then output message that we could be IN
+               --  If -gnatwk is set then output message that it could be IN
 
                if not Is_Trivial_Subprogram (Scope (E1)) then
                   if Warn_On_Constant then