This fixes a weird error given by the compiler on an access attribute applied
to the component of the result of a function call, if the called function
returns an access type designating a record containing the component declared
as aliased, and is overloaded with another function returning another access
type designating also a record containing a second component of the same name
but not declared as aliased.
The compiler wrongly complains that the prefix of the attribute is not declared
as aliased because the check is applied to a random interpretation (depending
on the declaration order among other things) of the overloaded component. The
fix simply defers the check until after the right interpretation is chosen.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
2017-09-18 Eric Botcazou <ebotca...@adacore.com>
* sem_attr.adb (Analyze_Access_Attribute): Move check for the presence
of the "aliased" keyword on the prefix from here to...
(Resolve_Attribute) <Attribute_Access>: ...here. Remove useless call
to Check_No_Implicit_Aliasing.
* sinfo.ads (Non_Aliased_Prefix): Delete.
(Set_Non_Aliased_Prefix): Likewise.
* sinfo.adb (Non_Aliased_Prefix): Delete.
(Set_Non_Aliased_Prefix): Likewise.
gcc/testsuite/
2017-09-18 Eric Botcazou <ebotca...@adacore.com>
* gnat.dg/overload.ads, gnat.dg/overload.adb: New testcase.
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 252907)
+++ sem_attr.adb (working copy)
@@ -1074,49 +1074,6 @@
end if;
end loop;
end;
-
- -- Check for aliased view. We allow a nonaliased prefix when within
- -- an instance because the prefix may have been a tagged formal
- -- object, which is defined to be aliased even when the actual
- -- might not be (other instance cases will have been caught in the
- -- generic). Similarly, within an inlined body we know that the
- -- attribute is legal in the original subprogram, and therefore
- -- legal in the expansion.
-
- if not Is_Aliased_View (P)
- and then not In_Instance
- and then not In_Inlined_Body
- and then Comes_From_Source (N)
- then
- -- Here we have a non-aliased view. This is illegal unless we
- -- have the case of Unrestricted_Access, where for now we allow
- -- this (we will reject later if expected type is access to an
- -- unconstrained array with a thin pointer).
-
- -- No need for an error message on a generated access reference
- -- for the controlling argument in a dispatching call: error will
- -- be reported when resolving the call.
-
- if Aname /= Name_Unrestricted_Access then
- Error_Attr_P ("prefix of % attribute must be aliased");
- Check_No_Implicit_Aliasing (P);
-
- -- For Unrestricted_Access, record that prefix is not aliased
- -- to simplify legality check later on.
-
- else
- Set_Non_Aliased_Prefix (N);
- end if;
-
- -- If we have an aliased view, and we have Unrestricted_Access, then
- -- output a warning that Unchecked_Access would have been fine, and
- -- change the node to be Unchecked_Access.
-
- else
- -- For now, hold off on this change ???
-
- null;
- end if;
end Analyze_Access_Attribute;
----------------------------------
@@ -11120,24 +11077,56 @@
end if;
end if;
- -- Check for unrestricted access where expected type is a thin
- -- pointer to an unconstrained array.
+ -- Check for aliased view. We allow a nonaliased prefix when in
+ -- an instance because the prefix may have been a tagged formal
+ -- object, which is defined to be aliased even when the actual
+ -- might not be (other instance cases will have been caught in
+ -- the generic). Similarly, within an inlined body we know that
+ -- the attribute is legal in the original subprogram, therefore
+ -- legal in the expansion.
- if Non_Aliased_Prefix (N)
- and then Has_Size_Clause (Typ)
- and then RM_Size (Typ) = System_Address_Size
+ if not (Is_Entity_Name (P)
+ and then Is_Overloadable (Entity (P)))
+ and then not (Nkind (P) = N_Selected_Component
+ and then
+ Is_Overloadable (Entity (Selector_Name (P))))
+ and then not Is_Aliased_View (P)
+ and then not In_Instance
+ and then not In_Inlined_Body
+ and then Comes_From_Source (N)
then
- declare
- DT : constant Entity_Id := Designated_Type (Typ);
- begin
- if Is_Array_Type (DT) and then not Is_Constrained (DT) then
- Error_Msg_N
- ("illegal use of Unrestricted_Access attribute", P);
- Error_Msg_N
- ("\attempt to generate thin pointer to unaliased "
- & "object", P);
- end if;
- end;
+ -- Here we have a non-aliased view. This is illegal unless we
+ -- have the case of Unrestricted_Access, where for now we allow
+ -- this (we will reject later if expected type is access to an
+ -- unconstrained array with a thin pointer).
+
+ -- No need for an error message on a generated access reference
+ -- for the controlling argument in a dispatching call: error
+ -- will be reported when resolving the call.
+
+ if Attr_Id /= Attribute_Unrestricted_Access then
+ Error_Msg_N ("prefix of % attribute must be aliased", P);
+
+ -- Check for unrestricted access where expected type is a thin
+ -- pointer to an unconstrained array.
+
+ elsif Has_Size_Clause (Typ)
+ and then RM_Size (Typ) = System_Address_Size
+ then
+ declare
+ DT : constant Entity_Id := Designated_Type (Typ);
+ begin
+ if Is_Array_Type (DT)
+ and then not Is_Constrained (DT)
+ then
+ Error_Msg_N
+ ("illegal use of Unrestricted_Access attribute", P);
+ Error_Msg_N
+ ("\attempt to generate thin pointer to unaliased "
+ & "object", P);
+ end if;
+ end;
+ end if;
end if;
-- Mark that address of entity is taken in case of
Index: sinfo.adb
===================================================================
--- sinfo.adb (revision 252907)
+++ sinfo.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2464,14 +2464,6 @@
return Flag17 (N);
end No_Truncation;
- function Non_Aliased_Prefix
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference);
- return Flag18 (N);
- end Non_Aliased_Prefix;
-
function Null_Excluding_Subtype
(N : Node_Id) return Boolean is
begin
@@ -5774,14 +5766,6 @@
Set_Flag17 (N, Val);
end Set_No_Truncation;
- procedure Set_Non_Aliased_Prefix
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference);
- Set_Flag18 (N, Val);
- end Set_Non_Aliased_Prefix;
-
procedure Set_Null_Excluding_Subtype
(N : Node_Id; Val : Boolean := True) is
begin
Index: sinfo.ads
===================================================================
--- sinfo.ads (revision 252907)
+++ sinfo.ads (working copy)
@@ -2083,13 +2083,6 @@
-- is used for properly setting out of range values for use by pragmas
-- Initialize_Scalars and Normalize_Scalars.
- -- Non_Aliased_Prefix (Flag18-Sem)
- -- Present in N_Attribute_Reference nodes. Set only for the case of an
- -- Unrestricted_Access reference whose prefix is non-aliased, which is
- -- the case that is permitted for Unrestricted_Access except when the
- -- expected type is a thin pointer to unconstrained array. This flag is
- -- to assist in detecting this illegal use of Unrestricted_Access.
-
-- Null_Excluding_Subtype (Flag16)
-- Present in N_Access_To_Object_Definition. Indicates that the subtype
-- indication carries a null-exclusion indicator, which is distinct from
@@ -3944,7 +3937,6 @@
-- Do_Overflow_Check (Flag17-Sem)
-- Header_Size_Added (Flag11-Sem)
-- Must_Be_Byte_Aligned (Flag14-Sem)
- -- Non_Aliased_Prefix (Flag18-Sem)
-- Redundant_Use (Flag13-Sem)
-- plus fields for expression
@@ -9732,9 +9724,6 @@
function No_Truncation
(N : Node_Id) return Boolean; -- Flag17
- function Non_Aliased_Prefix
- (N : Node_Id) return Boolean; -- Flag18
-
function Null_Excluding_Subtype
(N : Node_Id) return Boolean; -- Flag16
@@ -10791,9 +10780,6 @@
procedure Set_No_Truncation
(N : Node_Id; Val : Boolean := True); -- Flag17
- procedure Set_Non_Aliased_Prefix
- (N : Node_Id; Val : Boolean := True); -- Flag18
-
procedure Set_Null_Excluding_Subtype
(N : Node_Id; Val : Boolean := True); -- Flag16
@@ -13129,7 +13115,6 @@
pragma Inline (No_Minimize_Eliminate);
pragma Inline (No_Side_Effect_Removal);
pragma Inline (No_Truncation);
- pragma Inline (Non_Aliased_Prefix);
pragma Inline (Null_Excluding_Subtype);
pragma Inline (Null_Exclusion_Present);
pragma Inline (Null_Exclusion_In_Return_Present);
@@ -13478,7 +13463,6 @@
pragma Inline (Set_No_Minimize_Eliminate);
pragma Inline (Set_No_Side_Effect_Removal);
pragma Inline (Set_No_Truncation);
- pragma Inline (Set_Non_Aliased_Prefix);
pragma Inline (Set_Null_Excluding_Subtype);
pragma Inline (Set_Null_Exclusion_Present);
pragma Inline (Set_Null_Exclusion_In_Return_Present);
Index: ../testsuite/gnat.dg/overload.adb
===================================================================
--- ../testsuite/gnat.dg/overload.adb (revision 0)
+++ ../testsuite/gnat.dg/overload.adb (revision 0)
@@ -0,0 +1,23 @@
+-- { dg-do compile }
+
+package body Overload is
+
+ function Get (I : Integer) return Ptr1 is
+ P : Ptr1 := null;
+ begin
+ return P;
+ end;
+
+ function Get (I : Integer) return Ptr2 is
+ P : Ptr2 := null;
+ begin
+ return P;
+ end;
+
+ function F (I : Integer) return Ptr1 is
+ P : Ptr1 := Get (I).Data'Access;
+ begin
+ return P;
+ end;
+
+end Overload;
Index: ../testsuite/gnat.dg/overload.ads
===================================================================
--- ../testsuite/gnat.dg/overload.ads (revision 0)
+++ ../testsuite/gnat.dg/overload.ads (revision 0)
@@ -0,0 +1,20 @@
+package Overload is
+
+ type Rec1 is record
+ Data : Integer;
+ end record;
+ type Ptr1 is access all Rec1;
+
+ type Rec2 is record
+ Data : aliased Rec1;
+ end record;
+
+ type Ptr2 is access Rec2;
+
+ function Get (I : Integer) return Ptr1;
+
+ function Get (I : Integer) return Ptr2;
+
+ function F (I : Integer) return Ptr1;
+
+end Overload;
