-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
with Sem_Ch5; use Sem_Ch5;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Tbuild; use Tbuild;
+with Uintp; use Uintp;
package body Sem_Ch4 is
-- subprogram, and the call F (X) interpreted as F.all (X). In this case
-- the call may be overloaded with both interpretations.
- function Try_Object_Operation (N : Node_Id) return Boolean;
+ function Try_Object_Operation
+ (N : Node_Id;
+ CW_Test_Only : Boolean := False) return Boolean;
-- Ada 2005 (AI-252): Support the object.operation notation. If node N
-- is a call in this notation, it is transformed into a normal subprogram
-- call where the prefix is a parameter, and True is returned. If node
- -- N is not of this form, it is unchanged, and False is returned.
+ -- N is not of this form, it is unchanged, and False is returned. if
+ -- CW_Test_Only is true then N is an N_Selected_Component node which
+ -- is part of a call to an entry or procedure of a tagged concurrent
+ -- type and this routine is invoked to search for class-wide subprograms
+ -- conflicting with the target entity.
procedure wpo (T : Entity_Id);
pragma Warnings (Off, wpo);
Resolve (Expression (E), Type_Id);
+ -- Allocators generated by the build-in-place expansion mechanism
+ -- are explicitly marked as coming from source but do not need to be
+ -- checked for limited initialization. To exclude this case, ensure
+ -- that the parent of the allocator is a source node.
+
if Is_Limited_Type (Type_Id)
and then Comes_From_Source (N)
+ and then Comes_From_Source (Parent (N))
and then not In_Instance_Body
then
if not OK_For_Limited_Init (Type_Id, Expression (E)) then
-- and the allocated object is unconstrained.
elsif Ada_Version >= Ada_2005
- and then Has_Constrained_Partial_View (Base_Typ)
+ and then Effectively_Has_Constrained_Partial_View
+ (Typ => Base_Typ,
+ Scop => Current_Scope)
then
Error_Msg_N
- ("constraint no allowed when type " &
+ ("constraint not allowed when type " &
"has a constrained partial view", Constraint (E));
end if;
-- Start of processing for Analyze_Explicit_Dereference
begin
- Check_SPARK_Restriction ("explicit dereference is not allowed", N);
+ -- If source node, check SPARK restriction. We guard this with the
+ -- source node check, because ???
+
+ if Comes_From_Source (N) then
+ Check_SPARK_Restriction ("explicit dereference is not allowed", N);
+ end if;
-- In formal verification mode, keep track of all reads and writes
-- through explicit dereferences.
end if;
end Analyze_Membership_Op;
+ -----------------
+ -- Analyze_Mod --
+ -----------------
+
+ procedure Analyze_Mod (N : Node_Id) is
+ begin
+ -- A special warning check, if we have an expression of the form:
+ -- expr mod 2 * literal
+ -- where literal is 64 or less, then probably what was meant was
+ -- expr mod 2 ** literal
+ -- so issue an appropriate warning.
+
+ if Warn_On_Suspicious_Modulus_Value
+ and then Nkind (Right_Opnd (N)) = N_Integer_Literal
+ and then Intval (Right_Opnd (N)) = Uint_2
+ and then Nkind (Parent (N)) = N_Op_Multiply
+ and then Nkind (Right_Opnd (Parent (N))) = N_Integer_Literal
+ and then Intval (Right_Opnd (Parent (N))) <= Uint_64
+ then
+ Error_Msg_N
+ ("suspicious MOD value, was '*'* intended'??", Parent (N));
+ end if;
+
+ -- Remaining processing is same as for other arithmetic operators
+
+ Analyze_Arithmetic_Op (N);
+ end Analyze_Mod;
+
----------------------
-- Analyze_Negation --
----------------------
if Present (Next_Actual (Act2)) then
return;
+ end if;
- elsif Op_Name = Name_Op_Add
- or else Op_Name = Name_Op_Subtract
- or else Op_Name = Name_Op_Multiply
- or else Op_Name = Name_Op_Divide
- or else Op_Name = Name_Op_Mod
- or else Op_Name = Name_Op_Rem
- or else Op_Name = Name_Op_Expon
- then
- Find_Arithmetic_Types (Act1, Act2, Op_Id, N);
+ -- Otherwise action depends on operator
- elsif Op_Name = Name_Op_And
- or else Op_Name = Name_Op_Or
- or else Op_Name = Name_Op_Xor
- then
- Find_Boolean_Types (Act1, Act2, Op_Id, N);
+ case Op_Name is
+ when Name_Op_Add |
+ Name_Op_Subtract |
+ Name_Op_Multiply |
+ Name_Op_Divide |
+ Name_Op_Mod |
+ Name_Op_Rem |
+ Name_Op_Expon =>
+ Find_Arithmetic_Types (Act1, Act2, Op_Id, N);
- elsif Op_Name = Name_Op_Lt
- or else Op_Name = Name_Op_Le
- or else Op_Name = Name_Op_Gt
- or else Op_Name = Name_Op_Ge
- then
- Find_Comparison_Types (Act1, Act2, Op_Id, N);
+ when Name_Op_And |
+ Name_Op_Or |
+ Name_Op_Xor =>
+ Find_Boolean_Types (Act1, Act2, Op_Id, N);
- elsif Op_Name = Name_Op_Eq
- or else Op_Name = Name_Op_Ne
- then
- Find_Equality_Types (Act1, Act2, Op_Id, N);
+ when Name_Op_Lt |
+ Name_Op_Le |
+ Name_Op_Gt |
+ Name_Op_Ge =>
+ Find_Comparison_Types (Act1, Act2, Op_Id, N);
- elsif Op_Name = Name_Op_Concat then
- Find_Concatenation_Types (Act1, Act2, Op_Id, N);
+ when Name_Op_Eq |
+ Name_Op_Ne =>
+ Find_Equality_Types (Act1, Act2, Op_Id, N);
- -- Is this else null correct, or should it be an abort???
+ when Name_Op_Concat =>
+ Find_Concatenation_Types (Act1, Act2, Op_Id, N);
- else
- null;
- end if;
+ -- Is this when others, or should it be an abort???
+
+ when others =>
+ null;
+ end case;
-- Unary operator case
else
- if Op_Name = Name_Op_Subtract or else
- Op_Name = Name_Op_Add or else
- Op_Name = Name_Op_Abs
- then
- Find_Unary_Types (Act1, Op_Id, N);
+ case Op_Name is
+ when Name_Op_Subtract |
+ Name_Op_Add |
+ Name_Op_Abs =>
+ Find_Unary_Types (Act1, Op_Id, N);
- elsif
- Op_Name = Name_Op_Not
- then
- Find_Negation_Types (Act1, Op_Id, N);
+ when Name_Op_Not =>
+ Find_Negation_Types (Act1, Op_Id, N);
- -- Is this else null correct, or should it be an abort???
+ -- Is this when others correct, or should it be an abort???
- else
- null;
- end if;
+ when others =>
+ null;
+ end case;
end if;
end Analyze_Operator_Call;
-- of the high bound.
procedure Check_Universal_Expression (N : Node_Id);
- -- In Ada83, reject bounds of a universal range that are not
- -- literals or entity names.
+ -- In Ada 83, reject bounds of a universal range that are not literals
+ -- or entity names.
-----------------------
-- Check_Common_Type --
elsif Is_Record_Type (Prefix_Type) then
-- Find component with given name
+ -- In an instance, if the node is known as a prefixed call, do
+ -- not examine components whose visibility may be accidental.
- while Present (Comp) loop
+ while Present (Comp) and then not Is_Prefixed_Call (N) loop
if Chars (Comp) = Chars (Sel)
and then Is_Visible_Component (Comp)
then
Set_Entity_With_Style_Check (Sel, Comp);
Generate_Reference (Comp, Sel);
+ -- The selector is not overloadable, so we have a candidate
+ -- interpretation.
+
+ Has_Candidate := True;
+
else
goto Next_Comp;
end if;
then
return;
end if;
+
+ -- Ada 2012 (AI05-0090-1): If we found a candidate of a call to an
+ -- entry or procedure of a tagged concurrent type we must check
+ -- if there are class-wide subprograms covering the primitive. If
+ -- true then Try_Object_Operation reports the error.
+
+ if Has_Candidate
+ and then Is_Concurrent_Type (Prefix_Type)
+ and then Nkind (Parent (N)) = N_Procedure_Call_Statement
+
+ -- Duplicate the call. This is required to avoid problems with
+ -- the tree transformations performed by Try_Object_Operation.
+
+ and then
+ Try_Object_Operation
+ (N => Sinfo.Name (New_Copy_Tree (Parent (N))),
+ CW_Test_Only => True)
+ then
+ return;
+ end if;
end if;
if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then
+
-- Case of a prefix of a protected type: selector might denote
-- an invisible private component.
Error_Msg_Node_2 := First_Subtype (Prefix_Type);
Error_Msg_NE ("no selector& for}", N, Sel);
+ -- Add information in the case of an incomplete prefix
+
+ if Is_Incomplete_Type (Type_To_Use) then
+ declare
+ Inc : constant Entity_Id := First_Subtype (Type_To_Use);
+
+ begin
+ if From_With_Type (Scope (Type_To_Use)) then
+ Error_Msg_NE
+ ("\limited view of& has no components", N, Inc);
+
+ else
+ Error_Msg_NE
+ ("\premature usage of incomplete type&", N, Inc);
+
+ if Nkind (Parent (Inc)) =
+ N_Incomplete_Type_Declaration
+ then
+ -- Record location of premature use in entity so that
+ -- a continuation message is generated when the
+ -- completion is seen.
+
+ Set_Premature_Use (Parent (Inc), N);
+ end if;
+ end if;
+ end;
+ end if;
+
Check_Misspelled_Selector (Type_To_Use, Sel);
end if;
-- Start of processing for Analyze_Slice
begin
- Check_SPARK_Restriction ("slice is not allowed", N);
+ if Comes_From_Source (N) then
+ Check_SPARK_Restriction ("slice is not allowed", N);
+ end if;
Analyze (P);
Analyze (D);
return;
end if;
- -- If we have infix notation, the operator must be usable.
- -- Within an instance, if the type is already established we
- -- know it is correct.
+ -- If we have infix notation, the operator must be usable. Within
+ -- an instance, if the type is already established we know it is
+ -- correct. If an operand is universal it is compatible with any
+ -- numeric type.
+
-- In Ada 2005, the equality on anonymous access types is declared
-- in Standard, and is always visible.
elsif In_Open_Scopes (Scope (Bas))
or else Is_Potentially_Use_Visible (Bas)
or else In_Use (Bas)
- or else (In_Use (Scope (Bas))
- and then not Is_Hidden (Bas))
+ or else (In_Use (Scope (Bas)) and then not Is_Hidden (Bas))
or else (In_Instance
- and then First_Subtype (T1) = First_Subtype (Etype (R)))
+ and then
+ (First_Subtype (T1) = First_Subtype (Etype (R))
+ or else
+ (Is_Numeric_Type (T1)
+ and then Is_Universal_Numeric_Type (Etype (R)))))
or else Ekind (T1) = E_Anonymous_Access_Type
then
null;
end if;
if T1 /= Standard_Void_Type
- and then not Is_Limited_Type (T1)
- and then not Is_Limited_Composite (T1)
and then Has_Compatible_Type (R, T1)
+ and then
+ ((not Is_Limited_Type (T1)
+ and then not Is_Limited_Composite (T1))
+
+ or else
+ (Is_Array_Type (T1)
+ and then not Is_Limited_Type (Component_Type (T1))
+ and then Available_Full_View_Of_Component (T1)))
then
if Found
and then Base_Type (T1) /= Base_Type (T_F)
First_Subtype (Base_Type (Etype (R))) /= Standard_Integer
and then Base_Type (Etype (R)) /= Universal_Integer
then
- Error_Msg_NE
- ("exponent must be of type Natural, found}", R, Etype (R));
+ if Ada_Version >= Ada_2012
+ and then Has_Dimension_System (Etype (L))
+ then
+ Error_Msg_NE
+ ("exponent for dimensioned type must be a rational" &
+ ", found}", R, Etype (R));
+ else
+ Error_Msg_NE
+ ("exponent must be of type Natural, found}", R, Etype (R));
+ end if;
+
return;
end if;
begin
if Is_Overloaded (N) then
+ if Debug_Flag_V then
+ Write_Str ("Remove_Abstract_Operations: ");
+ Write_Overloads (N);
+ end if;
+
Get_First_Interp (N, I, It);
while Present (It.Nam) loop
Remove_Interp (I);
exit;
- -- In Ada 2005, this operation does not participate in Overload
+ -- In Ada 2005, this operation does not participate in overload
-- resolution. If the operation is defined in a predefined
-- unit, it is one of the operations declared abstract in some
-- variants of System, and it must be removed as well.
end loop;
end if;
end if;
+
+ if Debug_Flag_V then
+ Write_Str ("Remove_Abstract_Operations done: ");
+ Write_Overloads (N);
+ end if;
end if;
end Remove_Abstract_Operations;
Func : Entity_Id;
Func_Name : Node_Id;
Indexing : Node_Id;
- Is_Var : Boolean;
- Ritem : Node_Id;
begin
- -- Check whether type has a specified indexing aspect.
+ -- Check whether type has a specified indexing aspect
Func_Name := Empty;
- Is_Var := False;
-
- Ritem := First_Rep_Item (Etype (Prefix));
- while Present (Ritem) loop
- if Nkind (Ritem) = N_Aspect_Specification then
- -- Prefer Variable_Indexing, but will settle for Constant.
-
- if Get_Aspect_Id (Chars (Identifier (Ritem))) =
- Aspect_Constant_Indexing
- then
- Func_Name := Expression (Ritem);
-
- elsif Get_Aspect_Id (Chars (Identifier (Ritem))) =
- Aspect_Variable_Indexing
- then
- Func_Name := Expression (Ritem);
- Is_Var := True;
- exit;
- end if;
- end if;
+ if Is_Variable (Prefix) then
+ Func_Name := Find_Aspect (Etype (Prefix), Aspect_Variable_Indexing);
+ end if;
- Next_Rep_Item (Ritem);
- end loop;
+ if No (Func_Name) then
+ Func_Name := Find_Aspect (Etype (Prefix), Aspect_Constant_Indexing);
+ end if;
-- If aspect does not exist the expression is illegal. Error is
-- diagnosed in caller.
end if;
end if;
- if Is_Var
- and then not Is_Variable (Prefix)
- then
- Error_Msg_N ("Variable indexing cannot be applied to a constant", N);
- end if;
-
if not Is_Overloaded (Func_Name) then
Func := Entity (Func_Name);
Indexing := Make_Function_Call (Loc,
Rewrite (N, Indexing);
Analyze (N);
- -- The return type of the indexing function is a reference type, so
- -- add the dereference as a possible interpretation.
+ -- If the return type of the indexing function is a reference type,
+ -- add the dereference as a possible interpretation. Note that the
+ -- indexing aspect may be a function that returns the element type
+ -- with no intervening implicit dereference.
- Disc := First_Discriminant (Etype (Func));
- while Present (Disc) loop
- if Has_Implicit_Dereference (Disc) then
- Add_One_Interp (N, Disc, Designated_Type (Etype (Disc)));
- exit;
- end if;
+ if Has_Discriminants (Etype (Func)) then
+ Disc := First_Discriminant (Etype (Func));
+ while Present (Disc) loop
+ if Has_Implicit_Dereference (Disc) then
+ Add_One_Interp (N, Disc, Designated_Type (Etype (Disc)));
+ exit;
+ end if;
- Next_Discriminant (Disc);
- end loop;
+ Next_Discriminant (Disc);
+ end loop;
+ end if;
else
Indexing := Make_Function_Call (Loc,
Analyze_One_Call (N, It.Nam, False, Success);
if Success then
Set_Etype (Name (N), It.Typ);
+ Set_Entity (Name (N), It.Nam);
- -- Add implicit dereference interpretation.
+ -- Add implicit dereference interpretation
- Disc := First_Discriminant (Etype (It.Nam));
+ if Has_Discriminants (Etype (It.Nam)) then
+ Disc := First_Discriminant (Etype (It.Nam));
+ while Present (Disc) loop
+ if Has_Implicit_Dereference (Disc) then
+ Add_One_Interp
+ (N, Disc, Designated_Type (Etype (Disc)));
+ exit;
+ end if;
- while Present (Disc) loop
- if Has_Implicit_Dereference (Disc) then
- Add_One_Interp
- (N, Disc, Designated_Type (Etype (Disc)));
- exit;
- end if;
+ Next_Discriminant (Disc);
+ end loop;
+ end if;
- Next_Discriminant (Disc);
- end loop;
+ exit;
end if;
Get_Next_Interp (I, It);
end loop;
end;
end if;
+ if Etype (N) = Any_Type then
+ Error_Msg_NE ("container cannot be indexed with&", N, Etype (Expr));
+ Rewrite (N, New_Occurrence_Of (Any_Id, Loc));
+ else
+ Analyze (N);
+ end if;
+
return True;
end Try_Container_Indexing;
-- Try_Object_Operation --
--------------------------
- function Try_Object_Operation (N : Node_Id) return Boolean is
+ function Try_Object_Operation
+ (N : Node_Id; CW_Test_Only : Boolean := False) return Boolean
+ is
K : constant Node_Kind := Nkind (Parent (N));
Is_Subprg_Call : constant Boolean := Nkind_In
(K, N_Procedure_Call_Statement,
Call : Node_Id;
Subp : Entity_Id) return Entity_Id;
-- If the subprogram is a valid interpretation, record it, and add
- -- to the list of interpretations of Subprog.
+ -- to the list of interpretations of Subprog. Otherwise return Empty.
procedure Complete_Object_Operation
(Call_Node : Node_Id;
First_Actual := First (Parameter_Associations (Call_Node));
-- For cross-reference purposes, treat the new node as being in
- -- the source if the original one is.
+ -- the source if the original one is. Set entity and type, even
+ -- though they may be overwritten during resolution if overloaded.
Set_Comes_From_Source (Subprog, Comes_From_Source (N));
Set_Comes_From_Source (Call_Node, Comes_From_Source (N));
and then not Inside_A_Generic
then
Set_Entity (Selector_Name (N), Entity (Subprog));
+ Set_Etype (Selector_Name (N), Etype (Entity (Subprog)));
end if;
-- If need be, rewrite first actual as an explicit dereference
----------------------
procedure Report_Ambiguity (Op : Entity_Id) is
- Access_Formal : constant Boolean :=
- Is_Access_Type (Etype (First_Formal (Op)));
Access_Actual : constant Boolean :=
Is_Access_Type (Etype (Prefix (N)));
+ Access_Formal : Boolean := False;
begin
Error_Msg_Sloc := Sloc (Op);
+ if Present (First_Formal (Op)) then
+ Access_Formal := Is_Access_Type (Etype (First_Formal (Op)));
+ end if;
+
if Access_Formal and then not Access_Actual then
if Nkind (Parent (Op)) = N_Full_Type_Declaration then
Error_Msg_N
-- Find a non-hidden operation whose first parameter is of the
-- class-wide type, a subtype thereof, or an anonymous access
- -- to same.
+ -- to same. If in an instance, the operation can be considered
+ -- even if hidden (it may be hidden because the instantiation is
+ -- expanded after the containing package has been analyzed).
while Present (Hom) loop
if Ekind_In (Hom, E_Procedure, E_Function)
- and then not Is_Hidden (Hom)
+ and then (not Is_Hidden (Hom) or else In_Instance)
and then Scope (Hom) = Scope (Anc_Type)
and then Present (First_Formal (Hom))
and then
and then N = Name (Parent (N))
then
goto Next_Hom;
+
+ -- If the context is a function call, ignore procedures
+ -- in the name of the call.
+
+ elsif Ekind (Hom) = E_Procedure
+ and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
+ then
+ goto Next_Hom;
end if;
Set_Etype (Call_Node, Any_Type);
-- Start of processing for Try_Class_Wide_Operation
begin
+ -- If we are searching only for conflicting class-wide subprograms
+ -- then initialize directly Matching_Op with the target entity.
+
+ if CW_Test_Only then
+ Matching_Op := Entity (Selector_Name (N));
+ end if;
+
-- Loop through ancestor types (including interfaces), traversing
-- the homonym chain of the subprogram, trying out those homonyms
-- whose first formal has the class-wide type of the ancestor, or
return;
end if;
- if Try_Primitive_Operation
- (Call_Node => New_Call_Node,
- Node_To_Replace => Node_To_Replace)
- or else
- Try_Class_Wide_Operation
- (Call_Node => New_Call_Node,
- Node_To_Replace => Node_To_Replace)
- then
- null;
- end if;
+ declare
+ Dup_Call_Node : constant Node_Id := New_Copy (New_Call_Node);
+ CW_Result : Boolean;
+ Prim_Result : Boolean;
+ pragma Unreferenced (CW_Result);
+
+ begin
+ if not CW_Test_Only then
+ Prim_Result :=
+ Try_Primitive_Operation
+ (Call_Node => New_Call_Node,
+ Node_To_Replace => Node_To_Replace);
+ end if;
+
+ -- Check if there is a class-wide subprogram covering the
+ -- primitive. This check must be done even if a candidate
+ -- was found in order to report ambiguous calls.
+
+ if not (Prim_Result) then
+ CW_Result :=
+ Try_Class_Wide_Operation
+ (Call_Node => New_Call_Node,
+ Node_To_Replace => Node_To_Replace);
+
+ -- If we found a primitive we search for class-wide subprograms
+ -- using a duplicate of the call node (done to avoid missing its
+ -- decoration if there is no ambiguity).
+
+ else
+ CW_Result :=
+ Try_Class_Wide_Operation
+ (Call_Node => Dup_Call_Node,
+ Node_To_Replace => Node_To_Replace);
+ end if;
+ end;
end Try_One_Prefix_Interpretation;
-----------------------------
end if;
if Etype (New_Call_Node) /= Any_Type then
- Complete_Object_Operation
- (Call_Node => New_Call_Node,
- Node_To_Replace => Node_To_Replace);
- return True;
+
+ -- No need to complete the tree transformations if we are only
+ -- searching for conflicting class-wide subprograms
+
+ if CW_Test_Only then
+ return False;
+ else
+ Complete_Object_Operation
+ (Call_Node => New_Call_Node,
+ Node_To_Replace => Node_To_Replace);
+ return True;
+ end if;
elsif Present (Candidate) then
OSDN Git Service
