===================================================================
@@ -7293,6 +7293,20 @@
Set_Entity (New_N, Entity (Assoc));
Check_Private_View (N);
+ -- The node is a reference to a global type and acts as the
+ -- subtype mark of a qualified expression created in order
+ -- to aid resolution of accidental overloading in instances.
+ -- Since N is a reference to a type, the Associated_Node of
+ -- N denotes an entity rather than another identifier. See
+ -- Qualify_Universal_Operands for details.
+
+ elsif Nkind (N) = N_Identifier
+ and then Nkind (Parent (N)) = N_Qualified_Expression
+ and then Subtype_Mark (Parent (N)) = N
+ and then Is_Qualified_Universal_Literal (Parent (N))
+ then
+ Set_Entity (New_N, Assoc);
+
-- The name in the call may be a selected component if the
-- call has not been analyzed yet, as may be the case for
-- pre/post conditions in a generic unit.
@@ -13982,6 +13996,7 @@
Loc : constant Source_Ptr := Sloc (Opnd);
Typ : constant Entity_Id := Etype (Actual);
Mark : Node_Id;
+ Qual : Node_Id;
begin
-- Qualify the operand when it is of a universal type. Note that
@@ -14007,10 +14022,19 @@
Mark := Qualify_Type (Loc, Typ);
end if;
- Rewrite (Opnd,
+ Qual :=
Make_Qualified_Expression (Loc,
Subtype_Mark => Mark,
- Expression => Relocate_Node (Opnd)));
+ Expression => Relocate_Node (Opnd));
+
+ -- Mark the qualification to distinguish it from other source
+ -- constructs and signal the instantiation mechanism that this
+ -- node requires special processing. See Copy_Generic_Node for
+ -- details.
+
+ Set_Is_Qualified_Universal_Literal (Qual);
+
+ Rewrite (Opnd, Qual);
end if;
end Qualify_Operand;
===================================================================
@@ -1982,6 +1982,14 @@
return Flag7 (N);
end Is_Protected_Subprogram_Body;
+ function Is_Qualified_Universal_Literal
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Qualified_Expression);
+ return Flag4 (N);
+ end Is_Qualified_Universal_Literal;
+
function Is_Static_Coextension
(N : Node_Id) return Boolean is
begin
@@ -5229,6 +5237,14 @@
Set_Flag7 (N, Val);
end Set_Is_Protected_Subprogram_Body;
+ procedure Set_Is_Qualified_Universal_Literal
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Qualified_Expression);
+ Set_Flag4 (N, Val);
+ end Set_Is_Qualified_Universal_Literal;
+
procedure Set_Is_Static_Coextension
(N : Node_Id; Val : Boolean := True) is
begin
===================================================================
@@ -1710,6 +1710,12 @@
-- handler to make sure that the associated protected object is unlocked
-- when the subprogram completes.
+ -- Is_Qualified_Universal_Literal (Flag4-Sem)
+ -- Present in N_Qualified_Expression nodes. Set when the qualification is
+ -- converting a universal literal to a specific type. Such qualifiers aid
+ -- the resolution of accidental overloading of binary or unary operators
+ -- which may occur in instances.
+
-- Is_Static_Coextension (Flag14-Sem)
-- Present in N_Allocator nodes. Set if the allocator is a coextension
-- of an object allocated on the stack rather than the heap.
@@ -4542,6 +4548,7 @@
-- Subtype_Mark (Node4)
-- Expression (Node3) expression or aggregate
-- plus fields for expression
+ -- Is_Qualified_Universal_Literal (Flag4-Sem)
--------------------
-- 4.8 Allocator --
@@ -9399,6 +9406,9 @@
function Is_Protected_Subprogram_Body
(N : Node_Id) return Boolean; -- Flag7
+ function Is_Qualified_Universal_Literal
+ (N : Node_Id) return Boolean; -- Flag4
+
function Is_Static_Coextension
(N : Node_Id) return Boolean; -- Flag14
@@ -10437,6 +10447,9 @@
procedure Set_Is_Protected_Subprogram_Body
(N : Node_Id; Val : Boolean := True); -- Flag7
+ procedure Set_Is_Qualified_Universal_Literal
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
procedure Set_Is_Static_Coextension
(N : Node_Id; Val : Boolean := True); -- Flag14
@@ -12819,6 +12832,7 @@
pragma Inline (Is_Power_Of_2_For_Shift);
pragma Inline (Is_Prefixed_Call);
pragma Inline (Is_Protected_Subprogram_Body);
+ pragma Inline (Is_Qualified_Universal_Literal);
pragma Inline (Is_Static_Coextension);
pragma Inline (Is_Static_Expression);
pragma Inline (Is_Subprogram_Descriptor);
@@ -13160,6 +13174,7 @@
pragma Inline (Set_Is_Power_Of_2_For_Shift);
pragma Inline (Set_Is_Prefixed_Call);
pragma Inline (Set_Is_Protected_Subprogram_Body);
+ pragma Inline (Set_Is_Qualified_Universal_Literal);
pragma Inline (Set_Is_Static_Coextension);
pragma Inline (Set_Is_Static_Expression);
pragma Inline (Set_Is_Subprogram_Descriptor);
This patch updates the instantiation machinery to properly preserve a reference to a global type in a qualified expression used to convert a universal literal to a specific type, and propagate it to the instantiated template. ------------ -- Source -- ------------ -- types.ads package Types is type Uint is private; type Int is range -2**31 .. +2**31 - 1; function "+" (Left : Uint; Right : Uint) return Uint; function "+" (Left : Int; Right : Uint) return Uint; function "+" (Left : Uint; Right : Int) return Uint; function "*" (Left : Uint; Right : Uint) return Uint; function "*" (Left : Int; Right : Uint) return Uint; function "*" (Left : Uint; Right : Int) return Uint; private Uint_Low_Bound : constant := 600_000_000; Uint_High_Bound : constant := 2_099_999_999; type Uint is new Int range Uint_Low_Bound .. Uint_High_Bound; No_Uint : constant Uint := Uint (Uint_Low_Bound); end Types; -- types.adb package body Types is function "+" (Left : Uint; Right : Uint) return Uint is begin return No_Uint; end "+"; function "+" (Left : Int; Right : Uint) return Uint is begin return No_Uint; end "+"; function "+" (Left : Uint; Right : Int) return Uint is begin return No_Uint; end "+"; function "*" (Left : Uint; Right : Uint) return Uint is begin return No_Uint; end "+"; function "*" (Left : Int; Right : Uint) return Uint is begin return No_Uint; end "+"; function "*" (Left : Uint; Right : Int) return Uint is begin return No_Uint; end "+"; end Types; -- types_gen.ads generic package Types_Gen is procedure Compute; end Types_Gen; -- types_gen.adb with Types; use Types; package body Types_Gen is procedure Compute is UI_Int_Value : Uint; begin UI_Int_Value := UI_Int_Value * 10 + 20; end Compute; end Types_Gen; -- types_inst.ads with Types_Gen; package Types_Inst is new Types_Gen; ----------------- -- Compilation -- ----------------- $ gcc -c -gnatct types_inst.ads Tested on x86_64-pc-linux-gnu, committed on trunk 2016-04-20 Hristian Kirtchev <kirtchev@adacore.com> * sem_ch12.adb (Copy_Generic_Node): Handle the special qualification installed for universal literals that act as operands in binary or unary operators. (Qualify_Operand): Mark the qualification to signal the instantiation mechanism how to handle global reference propagation. * sinfo.adb (Is_Qualified_Universal_Literal): New routine. (Set_Is_Qualified_Universal_Literal): New routine. * sinfo.ads New attribute Is_Qualified_Universal_Literal along with occurrences in nodes. (Is_Qualified_Universal_Literal): New routine along with pragma Inline. (Set_Is_Qualified_Universal_Literal): New routine along with pragma Inline.