with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_SCIL; use Sem_SCIL;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
and then Comes_From_Source (N)
and then not In_Instance_Body
then
- if not OK_For_Limited_Init (Expression (E)) then
+ if not OK_For_Limited_Init (Type_Id, Expression (E)) then
Error_Msg_N ("initialization not allowed for limited types", N);
Explain_Limited_Type (Type_Id, N);
end if;
Condition : constant Node_Id := First (Expressions (N));
Then_Expr : constant Node_Id := Next (Condition);
Else_Expr : constant Node_Id := Next (Then_Expr);
+
begin
+ if Comes_From_Source (N) then
+ Check_Compiler_Unit (N);
+ end if;
+
Analyze_Expression (Condition);
Analyze_Expression (Then_Expr);
- Analyze_Expression (Else_Expr);
- Set_Etype (N, Etype (Then_Expr));
+
+ if Present (Else_Expr) then
+ Analyze_Expression (Else_Expr);
+ end if;
+
+ if not Is_Overloaded (Then_Expr) then
+ Set_Etype (N, Etype (Then_Expr));
+ else
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Set_Etype (N, Any_Type);
+ Get_First_Interp (Then_Expr, I, It);
+ while Present (It.Nam) loop
+ if Has_Compatible_Type (Else_Expr, It.Typ) then
+ Add_One_Interp (N, It.Typ, It.Typ);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
end Analyze_Conditional_Expression;
-------------------------
Set_Etype (L, T_F);
end if;
-
end Try_One_Interp;
+ procedure Analyze_Set_Membership;
+ -- If a set of alternatives is present, analyze each and find the
+ -- common type to which they must all resolve.
+
+ ----------------------------
+ -- Analyze_Set_Membership --
+ ----------------------------
+
+ procedure Analyze_Set_Membership is
+ Alt : Node_Id;
+ Index : Interp_Index;
+ It : Interp;
+ Candidate_Interps : Node_Id;
+ Common_Type : Entity_Id := Empty;
+
+ begin
+ Analyze (L);
+ Candidate_Interps := L;
+
+ if not Is_Overloaded (L) then
+ Common_Type := Etype (L);
+
+ Alt := First (Alternatives (N));
+ while Present (Alt) loop
+ Analyze (Alt);
+
+ if not Has_Compatible_Type (Alt, Common_Type) then
+ Wrong_Type (Alt, Common_Type);
+ end if;
+
+ Next (Alt);
+ end loop;
+
+ else
+ Alt := First (Alternatives (N));
+ while Present (Alt) loop
+ Analyze (Alt);
+ if not Is_Overloaded (Alt) then
+ Common_Type := Etype (Alt);
+
+ else
+ Get_First_Interp (Alt, Index, It);
+ while Present (It.Typ) loop
+ if not
+ Has_Compatible_Type (Candidate_Interps, It.Typ)
+ then
+ Remove_Interp (Index);
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+
+ Get_First_Interp (Alt, Index, It);
+
+ if No (It.Typ) then
+ Error_Msg_N ("alternative has no legal type", Alt);
+ return;
+ end if;
+
+ -- If alternative is not overloaded, we have a unique type
+ -- for all of them.
+
+ Set_Etype (Alt, It.Typ);
+ Get_Next_Interp (Index, It);
+
+ if No (It.Typ) then
+ Set_Is_Overloaded (Alt, False);
+ Common_Type := Etype (Alt);
+ end if;
+
+ Candidate_Interps := Alt;
+ end if;
+
+ Next (Alt);
+ end loop;
+ end if;
+
+ Set_Etype (N, Standard_Boolean);
+
+ if Present (Common_Type) then
+ Set_Etype (L, Common_Type);
+ Set_Is_Overloaded (L, False);
+
+ else
+ Error_Msg_N ("cannot resolve membership operation", N);
+ end if;
+ end Analyze_Set_Membership;
+
-- Start of processing for Analyze_Membership_Op
begin
Analyze_Expression (L);
+ if No (R)
+ and then Extensions_Allowed
+ then
+ Analyze_Set_Membership;
+ return;
+ end if;
+
if Nkind (R) = N_Range
or else (Nkind (R) = N_Attribute_Reference
and then Attribute_Name (R) = Name_Range)
Set_Etype (N, Standard_Boolean);
if Comes_From_Source (N)
+ and then Present (Right_Opnd (N))
and then Is_CPP_Class (Etype (Etype (Right_Opnd (N))))
then
Error_Msg_N ("membership test not applicable to cpp-class types", N);
return;
end if;
- -- An indexing requires at least one actual.
+ -- An indexing requires at least one actual
if not Is_Empty_List (Actuals)
and then
if Report and not Is_Indexed and not Is_Indirect then
-- Ada 2005 (AI-251): Complete the error notification
- -- to help new Ada 2005 users
+ -- to help new Ada 2005 users.
if Is_Class_Wide_Type (Etype (Formal))
and then Is_Interface (Etype (Etype (Formal)))
Set_Etype (N, Etype (Comp));
Set_Etype (Nam, It.Typ);
- -- For access type case, introduce explicit deference for
- -- more uniform treatment of entry calls. Do this only
- -- once if several interpretations yield an access type.
+ -- For access type case, introduce explicit dereference for
+ -- more uniform treatment of entry calls. Do this only once
+ -- if several interpretations yield an access type.
if Is_Access_Type (Etype (Nam))
and then Nkind (Nam) /= N_Explicit_Dereference
Set_Original_Discriminant (Sel, Comp);
end if;
- -- For access type case, introduce explicit deference for more
- -- uniform treatment of entry calls.
+ -- For access type case, introduce explicit dereference for
+ -- more uniform treatment of entry calls.
if Is_Access_Type (Etype (Name)) then
Insert_Explicit_Dereference (Name);
T : Entity_Id;
begin
+ -- Check if the expression is a function call for which we need to
+ -- adjust a SCIL dispatching node.
+
+ if Generate_SCIL
+ and then Nkind (Expr) = N_Function_Call
+ then
+ Adjust_SCIL_Node (N, Expr);
+ end if;
+
-- If Conversion_OK is set, then the Etype is already set, and the
-- only processing required is to analyze the expression. This is
-- used to construct certain "illegal" conversions which are not
-- subprogram because that list starts with the subprogram formals.
-- We retrieve the candidate operations from the generic declaration.
+ function Is_Private_Overriding (Op : Entity_Id) return Boolean;
+ -- An operation that overrides an inherited operation in the private
+ -- part of its package may be hidden, but if the inherited operation
+ -- is visible a direct call to it will dispatch to the private one,
+ -- which is therefore a valid candidate.
+
function Valid_First_Argument_Of (Op : Entity_Id) return Boolean;
-- Verify that the prefix, dereferenced if need be, is a valid
-- controlling argument in a call to Op. The remaining actuals
end if;
end Collect_Generic_Type_Ops;
+ ---------------------------
+ -- Is_Private_Overriding --
+ ---------------------------
+
+ function Is_Private_Overriding (Op : Entity_Id) return Boolean is
+ Visible_Op : constant Entity_Id := Homonym (Op);
+
+ begin
+ return Present (Visible_Op)
+ and then not Comes_From_Source (Visible_Op)
+ and then Alias (Visible_Op) = Op
+ and then not Is_Hidden (Visible_Op);
+ end Is_Private_Overriding;
+
-----------------------------
-- Valid_First_Argument_Of --
-----------------------------
if (Present (Interface_Alias (Prim_Op))
and then Is_Ancestor (Find_Dispatching_Type
(Alias (Prim_Op)), Corr_Type))
- or else
- -- Do not consider hidden primitives unless the type is
- -- in an open scope or we are within an instance, where
- -- visibility is known to be correct.
+ -- Do not consider hidden primitives unless the type is in an
+ -- open scope or we are within an instance, where visibility
+ -- is known to be correct, or else if this is an overriding
+ -- operation in the private part for an inherited operation.
- (Is_Hidden (Prim_Op)
- and then not Is_Immediately_Visible (Obj_Type)
- and then not In_Instance)
+ or else (Is_Hidden (Prim_Op)
+ and then not Is_Immediately_Visible (Obj_Type)
+ and then not In_Instance
+ and then not Is_Private_Overriding (Prim_Op))
then
goto Continue;
end if;
OSDN Git Service
