[COMMITTED] ada: Fix spurious error on call to function returning private in generic
Checks
Commit Message
From: Eric Botcazou <ebotcazou@adacore.com>
The spurious error is given on a call to a parameterless function returning
a private type, present in the body of a generic construct both declared and
instantiated in the presence of the full view of the type, because this full
view is not properly restored for the instantiation.
This is supposed to be handled by the Has_Private_View mechanism, but it is
bypassed here because the call to the parameterless function is first parsed
as a simple identifier before being later analyzed as a function call.
Fixing this first issue uncovered another one, whereby the Has_Private_View
flag was not properly set on an operator returning a private type that ends
up being later resolved as a function call.
Finally a small loophole in Eval_Attribute exposed by the change also needs
to be plugged.
gcc/ada/
* sem_attr.adb (Eval_Attribute): Add more exceptions to the early
return for a prefix which is a nonfrozen generic actual type.
* sem_ch12.adb (Copy_Generic_Node): Also check private views in the
case of an entity name or operator analyzed as a function call.
(Set_Global_Type): Make it a child of Save_Global_References.
(Save_References_In_Operator): In the case where the operator has
been turned into a function call, call Set_Global_Type on the entity
if it is global.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_attr.adb | 8 ++-
gcc/ada/sem_ch12.adb | 113 ++++++++++++++++++++++---------------------
2 files changed, 63 insertions(+), 58 deletions(-)
@@ -8437,9 +8437,13 @@ package body Sem_Attr is
-- However, the attribute Unconstrained_Array must be evaluated,
-- since it is documented to be a static attribute (and can for
-- example appear in a Compile_Time_Warning pragma). The frozen
- -- status of the type does not affect its evaluation.
+ -- status of the type does not affect its evaluation. Likewise
+ -- for attributes intended to be used with generic definitions.
- and then Id /= Attribute_Unconstrained_Array
+ and then Id not in Attribute_Unconstrained_Array
+ | Attribute_Has_Access_Values
+ | Attribute_Has_Discriminants
+ | Attribute_Has_Tagged_Values
then
return;
end if;
@@ -8178,6 +8178,7 @@ package body Sem_Ch12 is
and then Is_Entity_Name (Name (Assoc))
then
Set_Entity (New_N, Entity (Name (Assoc)));
+ Check_Private_View (N);
elsif Nkind (Assoc) in N_Entity
and then (Expander_Active
@@ -15716,6 +15717,13 @@ package body Sem_Ch12 is
-- This is the recursive procedure that does the work, once the
-- enclosing generic scope has been established.
+ procedure Set_Global_Type (N : Node_Id; N2 : Node_Id);
+ -- If the type of N2 is global to the generic unit, save the type in
+ -- the generic node. Just as we perform name capture for explicit
+ -- references within the generic, we must capture the global types
+ -- of local entities because they may participate in resolution in
+ -- the instance.
+
---------------
-- Is_Global --
---------------
@@ -15909,67 +15917,12 @@ package body Sem_Ch12 is
------------------
procedure Reset_Entity (N : Node_Id) is
- procedure Set_Global_Type (N : Node_Id; N2 : Node_Id);
- -- If the type of N2 is global to the generic unit, save the type in
- -- the generic node. Just as we perform name capture for explicit
- -- references within the generic, we must capture the global types
- -- of local entities because they may participate in resolution in
- -- the instance.
-
function Top_Ancestor (E : Entity_Id) return Entity_Id;
-- Find the ultimate ancestor of the current unit. If it is not a
-- generic unit, then the name of the current unit in the prefix of
-- an expanded name must be replaced with its generic homonym to
-- ensure that it will be properly resolved in an instance.
- ---------------------
- -- Set_Global_Type --
- ---------------------
-
- procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is
- Typ : constant Entity_Id := Etype (N2);
-
- begin
- Set_Etype (N, Typ);
-
- -- If the entity of N is not the associated node, this is a
- -- nested generic and it has an associated node as well, whose
- -- type is already the full view (see below). Indicate that the
- -- original node has a private view.
-
- if Entity (N) /= N2 and then Has_Private_View (Entity (N)) then
- Set_Has_Private_View (N);
- end if;
-
- -- If not a private type, nothing else to do
-
- if not Is_Private_Type (Typ) then
- null;
-
- -- If it is a derivation of a private type in a context where no
- -- full view is needed, nothing to do either.
-
- elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then
- null;
-
- -- Otherwise mark the type for flipping and use the full view when
- -- available.
-
- else
- Set_Has_Private_View (N);
-
- if Present (Full_View (Typ)) then
- Set_Etype (N2, Full_View (Typ));
- end if;
- end if;
-
- if Is_Floating_Point_Type (Typ)
- and then Has_Dimension_System (Typ)
- then
- Copy_Dimensions (N2, N);
- end if;
- end Set_Global_Type;
-
------------------
-- Top_Ancestor --
------------------
@@ -16678,7 +16631,7 @@ package body Sem_Ch12 is
E := Entity (Name (N2));
if Present (E) and then Is_Global (E) then
- Set_Etype (N, Etype (N2));
+ Set_Global_Type (N, N2);
else
Set_Associated_Node (N, Empty);
Set_Etype (N, Empty);
@@ -16845,6 +16798,54 @@ package body Sem_Ch12 is
end if;
end Save_References;
+ ---------------------
+ -- Set_Global_Type --
+ ---------------------
+
+ procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is
+ Typ : constant Entity_Id := Etype (N2);
+
+ begin
+ Set_Etype (N, Typ);
+
+ -- If the entity of N is not the associated node, this is a
+ -- nested generic and it has an associated node as well, whose
+ -- type is already the full view (see below). Indicate that the
+ -- original node has a private view.
+
+ if Entity (N) /= N2 and then Has_Private_View (Entity (N)) then
+ Set_Has_Private_View (N);
+ end if;
+
+ -- If not a private type, nothing else to do
+
+ if not Is_Private_Type (Typ) then
+ null;
+
+ -- If it is a derivation of a private type in a context where no
+ -- full view is needed, nothing to do either.
+
+ elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then
+ null;
+
+ -- Otherwise mark the type for flipping and use the full view when
+ -- available.
+
+ else
+ Set_Has_Private_View (N);
+
+ if Present (Full_View (Typ)) then
+ Set_Etype (N2, Full_View (Typ));
+ end if;
+ end if;
+
+ if Is_Floating_Point_Type (Typ)
+ and then Has_Dimension_System (Typ)
+ then
+ Copy_Dimensions (N2, N);
+ end if;
+ end Set_Global_Type;
+
-- Start of processing for Save_Global_References
begin