+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch12.adb (Qualify_Universal_Operands): New routine.
+ (Save_References_In_Operator): Add explicit qualifications in
+ the generic template for all operands of universal type.
+ * sem_type.adb (Disambiguate): Update the call to Matches.
+ (Matches): Reimplemented.
+ * sem_util.ads, sem_util.adb (Yields_Universal_Type): New routine.
+
2016-04-20 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Rep_Item_Too_Late): Better error message for
-- global because it is used to denote a specific compilation unit at
-- the time the instantiations will be analyzed.
+ procedure Qualify_Universal_Operands
+ (Op : Node_Id;
+ Func_Call : Node_Id);
+ -- Op denotes a binary or unary operator in generic template Templ. Node
+ -- Func_Call is the function call alternative of the operator within the
+ -- the analyzed copy of the template. Change each operand which yields a
+ -- universal type by wrapping it into a qualified expression
+ --
+ -- Actual_Typ'(Operand)
+ --
+ -- where Actual_Typ is the type of corresponding actual parameter of
+ -- Operand in Func_Call.
+
procedure Reset_Entity (N : Node_Id);
-- Save semantic information on global entity so that it is not resolved
-- again at instantiation time.
end if;
end Is_Global;
+ --------------------------------
+ -- Qualify_Universal_Operands --
+ --------------------------------
+
+ procedure Qualify_Universal_Operands
+ (Op : Node_Id;
+ Func_Call : Node_Id)
+ is
+ procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id);
+ -- Rewrite operand Opnd as a qualified expression of the form
+ --
+ -- Actual_Typ'(Opnd)
+ --
+ -- where Actual is the corresponding actual parameter of Opnd in
+ -- function call Func_Call.
+
+ function Qualify_Type
+ (Loc : Source_Ptr;
+ Typ : Entity_Id) return Node_Id;
+ -- Qualify type Typ by creating a selected component of the form
+ --
+ -- Scope_Of_Typ.Typ
+
+ ---------------------
+ -- Qualify_Operand --
+ ---------------------
+
+ procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Opnd);
+ Typ : constant Entity_Id := Etype (Actual);
+ Mark : Node_Id;
+
+ begin
+ -- Qualify the operand when it is of a universal type. Note that
+ -- the template is unanalyzed and it is not possible to directly
+ -- query the type. This transformation is not done when the type
+ -- of the actual is internally generated because the type will be
+ -- regenerated in the instance.
+
+ if Yields_Universal_Type (Opnd)
+ and then Comes_From_Source (Typ)
+ and then not Is_Hidden (Typ)
+ then
+ -- The type of the actual may be a global reference. Save this
+ -- information by creating a reference to it.
+
+ if Is_Global (Typ) then
+ Mark := New_Occurrence_Of (Typ, Loc);
+
+ -- Otherwise rely on resolution to find the proper type within
+ -- the instance.
+
+ else
+ Mark := Qualify_Type (Loc, Typ);
+ end if;
+
+ Rewrite (Opnd,
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => Mark,
+ Expression => Relocate_Node (Opnd)));
+ end if;
+ end Qualify_Operand;
+
+ ------------------
+ -- Qualify_Type --
+ ------------------
+
+ function Qualify_Type
+ (Loc : Source_Ptr;
+ Typ : Entity_Id) return Node_Id
+ is
+ Scop : constant Entity_Id := Scope (Typ);
+ Result : Node_Id;
+
+ begin
+ Result := Make_Identifier (Loc, Chars (Typ));
+
+ if Present (Scop) and then Scop /= Standard_Standard then
+ Result :=
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Chars (Scop)),
+ Selector_Name => Result);
+ end if;
+
+ return Result;
+ end Qualify_Type;
+
+ -- Local variables
+
+ Actuals : constant List_Id := Parameter_Associations (Func_Call);
+
+ -- Start of processing for Qualify_Universal_Operands
+
+ begin
+ if Nkind (Op) in N_Binary_Op then
+ Qualify_Operand (Left_Opnd (Op), First (Actuals));
+ Qualify_Operand (Right_Opnd (Op), Next (First (Actuals)));
+
+ elsif Nkind (Op) in N_Unary_Op then
+ Qualify_Operand (Right_Opnd (Op), First (Actuals));
+ end if;
+ end Qualify_Universal_Operands;
+
------------------
-- Reset_Entity --
------------------
Reset_Entity (N);
-- The analysis of the generic copy transformed the operator into
- -- some other construct. Propagate the changes to the template.
+ -- some other construct. Propagate the changes to the template if
+ -- applicable.
else
N2 := Get_Associated_Node (N);
-- The operator resoved to a function call
if Nkind (N2) = N_Function_Call then
+
+ -- Add explicit qualifications in the generic template for
+ -- all operands of universal type. This aids resolution by
+ -- preserving the actual type of a literal or an attribute
+ -- that yields a universal result.
+
+ Qualify_Universal_Operands (N, N2);
+
E := Entity (Name (N2));
if Present (E) and then Is_Global (E) then
Set_Etype (N, Etype (N2));
else
Set_Associated_Node (N, Empty);
- Set_Etype (N, Empty);
+ Set_Etype (N, Empty);
end if;
-- The operator was folded into a literal
-- the generic. Within the instance the actual is represented by a
-- constructed subprogram renaming.
- function Matches (Actual, Formal : Node_Id) return Boolean;
- -- Look for exact type match in an instance, to remove spurious
- -- ambiguities when two formal types have the same actual.
+ function Matches (Op : Node_Id; Func_Id : Entity_Id) return Boolean;
+ -- Determine whether function Func_Id is an exact match for binary or
+ -- unary operator Op.
function Operand_Type return Entity_Id;
- -- Determine type of operand for an equality operation, to apply
- -- Ada 2005 rules to equality on anonymous access types.
+ -- Determine type of operand for an equality operation, to apply Ada
+ -- 2005 rules to equality on anonymous access types.
function Standard_Operator return Boolean;
-- Check whether subprogram is predefined operator declared in Standard.
-- Matches --
-------------
- function Matches (Actual, Formal : Node_Id) return Boolean is
- T1 : constant Entity_Id := Etype (Actual);
- T2 : constant Entity_Id := Etype (Formal);
+ function Matches (Op : Node_Id; Func_Id : Entity_Id) return Boolean is
+ function Matching_Types
+ (Opnd_Typ : Entity_Id;
+ Formal_Typ : Entity_Id) return Boolean;
+ -- Determine whether operand type Opnd_Typ and formal parameter type
+ -- Formal_Typ are either the same or compatible.
+
+ --------------------
+ -- Matching_Types --
+ --------------------
+
+ function Matching_Types
+ (Opnd_Typ : Entity_Id;
+ Formal_Typ : Entity_Id) return Boolean
+ is
+ begin
+ -- A direct match
+
+ if Opnd_Typ = Formal_Typ then
+ return True;
+
+ -- Any integer type matches universal integer
+
+ elsif Opnd_Typ = Universal_Integer
+ and then Is_Integer_Type (Formal_Typ)
+ then
+ return True;
+
+ -- Any floating point type matches universal real
+
+ elsif Opnd_Typ = Universal_Real
+ and then Is_Floating_Point_Type (Formal_Typ)
+ then
+ return True;
+
+ -- The type of the formal parameter maps a generic actual type to
+ -- a generic formal type. If the operand type is the type being
+ -- mapped in an instance, then this is a match.
+
+ elsif Is_Generic_Actual_Type (Formal_Typ)
+ and then Etype (Formal_Typ) = Opnd_Typ
+ then
+ return True;
+
+ -- ??? There are possibly other cases to consider
+
+ else
+ return False;
+ end if;
+ end Matching_Types;
+
+ -- Local variables
+
+ F1 : constant Entity_Id := First_Formal (Func_Id);
+ F1_Typ : constant Entity_Id := Etype (F1);
+ F2 : constant Entity_Id := Next_Formal (F1);
+ F2_Typ : constant Entity_Id := Etype (F2);
+ Lop_Typ : constant Entity_Id := Etype (Left_Opnd (Op));
+ Rop_Typ : constant Entity_Id := Etype (Right_Opnd (Op));
+
+ -- Start of processing for Matches
+
begin
- return T1 = T2
- or else
- (Is_Numeric_Type (T2)
- and then (T1 = Universal_Real or else T1 = Universal_Integer));
+ if Lop_Typ = F1_Typ then
+ return Matching_Types (Rop_Typ, F2_Typ);
+
+ elsif Rop_Typ = F2_Typ then
+ return Matching_Types (Lop_Typ, F1_Typ);
+
+ -- Otherwise this is not a good match bechause each operand-formal
+ -- pair is compatible only on base type basis which is not specific
+ -- enough.
+
+ else
+ return False;
+ end if;
end Matches;
------------------
It1 := It;
Nam1 := It.Nam;
+
while I /= I2 loop
Get_Next_Interp (I, It);
end loop;
end;
elsif Nkind (N) in N_Binary_Op then
- if Matches (Left_Opnd (N), First_Formal (Nam1))
- and then
- Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
- then
+ if Matches (N, Nam1) then
return It1;
else
return It2;
end if;
end Yields_Synchronized_Object;
+ ---------------------------
+ -- Yields_Universal_Type --
+ ---------------------------
+
+ function Yields_Universal_Type (N : Node_Id) return Boolean is
+ Nam : Name_Id;
+
+ begin
+ -- Integer and real literals are of a universal type
+
+ if Nkind_In (N, N_Integer_Literal, N_Real_Literal) then
+ return True;
+
+ -- The values of certain attributes are of a universal type
+
+ elsif Nkind (N) = N_Attribute_Reference then
+ Nam := Attribute_Name (N);
+
+ return
+ Nam = Name_Aft
+ or else Nam = Name_Alignment
+ or else Nam = Name_Component_Size
+ or else Nam = Name_Count
+ or else Nam = Name_Delta
+ or else Nam = Name_Digits
+ or else Nam = Name_Exponent
+ or else Nam = Name_First_Bit
+ or else Nam = Name_Fore
+ or else Nam = Name_Last_Bit
+ or else Nam = Name_Length
+ or else Nam = Name_Machine_Emax
+ or else Nam = Name_Machine_Emin
+ or else Nam = Name_Machine_Mantissa
+ or else Nam = Name_Machine_Radix
+ or else Nam = Name_Max_Alignment_For_Allocation
+ or else Nam = Name_Max_Size_In_Storage_Elements
+ or else Nam = Name_Model_Emin
+ or else Nam = Name_Model_Epsilon
+ or else Nam = Name_Model_Mantissa
+ or else Nam = Name_Model_Small
+ or else Nam = Name_Modulus
+ or else Nam = Name_Pos
+ or else Nam = Name_Position
+ or else Nam = Name_Safe_First
+ or else Nam = Name_Safe_Last
+ or else Nam = Name_Scale
+ or else Nam = Name_Size
+ or else Nam = Name_Small
+ or else Nam = Name_Wide_Wide_Width
+ or else Nam = Name_Wide_Width
+ or else Nam = Name_Width;
+
+ -- ??? There are possibly other cases to consider
+
+ else
+ return False;
+ end if;
+ end Yields_Universal_Type;
+
end Sem_Util;
-- * A synchronized interface type
-- * A task type
+ function Yields_Universal_Type (N : Node_Id) return Boolean;
+ -- Determine whether unanalyzed node N yields a universal type
+
end Sem_Util;
projects / thirdparty / gcc.git / commitdiff
