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 <kirtc...@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.
Index: sem_ch12.adb
===================================================================
--- sem_ch12.adb (revision 235254)
+++ sem_ch12.adb (working copy)
@@ -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;
Index: sinfo.adb
===================================================================
--- sinfo.adb (revision 235243)
+++ sinfo.adb (working copy)
@@ -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
Index: sinfo.ads
===================================================================
--- sinfo.ads (revision 235247)
+++ sinfo.ads (working copy)
@@ -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);
