@@ -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
@@ -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";
@@ -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);
-----------------------
@@ -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;
@@ -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
@@ -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
Normally the warnings: warning: formal parameter "..." is not modified warning: mode could be "in" instead of "in out" are disabled if the type contains components of an access type. This patch enables such warnings if the only such components are in internal private types. Tested on x86_64-pc-linux-gnu, committed on trunk 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.