-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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 Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch5; use Sem_Ch5;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
-- the operand of the operator node.
procedure Ambiguous_Operands (N : Node_Id);
- -- for equality, membership, and comparison operators with overloaded
+ -- For equality, membership, and comparison operators with overloaded
-- arguments, list possible interpretations.
procedure Analyze_One_Call
-- Ada 2005: implementation of AI-310. An abstract non-dispatching
-- operation is not a candidate interpretation.
+ function Try_Container_Indexing
+ (N : Node_Id;
+ Prefix : Node_Id;
+ Expr : Node_Id) return Boolean;
+ -- AI05-0139: Generalized indexing to support iterators over containers
+
function Try_Indexed_Call
(N : Node_Id;
Nam : Entity_Id;
-- 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);
Nam := Opnd;
elsif Nkind (Opnd) = N_Function_Call then
Nam := Name (Opnd);
- else
+ elsif Ada_Version >= Ada_2012 then
+ declare
+ It : Interp;
+ I : Interp_Index;
+
+ begin
+ Get_First_Interp (Opnd, I, It);
+ while Present (It.Nam) loop
+ if Has_Implicit_Dereference (It.Typ) then
+ Error_Msg_N
+ ("can be interpreted as implicit dereference", Opnd);
+ return;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+
return;
end if;
E : Node_Id := Expression (N);
Acc_Type : Entity_Id;
Type_Id : Entity_Id;
+ P : Node_Id;
+ C : Node_Id;
begin
+ Check_SPARK_Restriction ("allocator is not allowed", N);
+
+ -- Deal with allocator restrictions
+
-- In accordance with H.4(7), the No_Allocators restriction only applies
- -- to user-written allocators.
+ -- to user-written allocators. The same consideration applies to the
+ -- No_Allocators_Before_Elaboration restriction.
if Comes_From_Source (N) then
Check_Restriction (No_Allocators, N);
+
+ -- Processing for No_Allocators_After_Elaboration, loop to look at
+ -- enclosing context, checking task case and main subprogram case.
+
+ C := N;
+ P := Parent (C);
+ while Present (P) loop
+
+ -- In both cases we need a handled sequence of statements, where
+ -- the occurrence of the allocator is within the statements.
+
+ if Nkind (P) = N_Handled_Sequence_Of_Statements
+ and then Is_List_Member (C)
+ and then List_Containing (C) = Statements (P)
+ then
+ -- Check for allocator within task body, this is a definite
+ -- violation of No_Allocators_After_Elaboration we can detect.
+
+ if Nkind (Original_Node (Parent (P))) = N_Task_Body then
+ Check_Restriction (No_Allocators_After_Elaboration, N);
+ exit;
+ end if;
+
+ -- The other case is appearance in a subprogram body. This may
+ -- be a violation if this is a library level subprogram, and it
+ -- turns out to be used as the main program, but only the
+ -- binder knows that, so just record the occurrence.
+
+ if Nkind (Original_Node (Parent (P))) = N_Subprogram_Body
+ and then Nkind (Parent (Parent (P))) = N_Compilation_Unit
+ then
+ Set_Has_Allocator (Current_Sem_Unit);
+ end if;
+ end if;
+
+ C := P;
+ P := Parent (C);
+ end loop;
end if;
+ -- Ada 2012 (AI05-0111-3): Analyze the subpool_specification, if
+ -- any. The expected type for the name is any type. A non-overloading
+ -- rule then requires it to be of a type descended from
+ -- System.Storage_Pools.Subpools.Subpool_Handle.
+
+ -- This isn't exactly what the AI says, but it seems to be the right
+ -- rule. The AI should be fixed.???
+
+ declare
+ Subpool : constant Node_Id := Subpool_Handle_Name (N);
+
+ begin
+ if Present (Subpool) then
+ Analyze (Subpool);
+
+ if Is_Overloaded (Subpool) then
+ Error_Msg_N ("ambiguous subpool handle", Subpool);
+ end if;
+
+ -- Check that Etype (Subpool) is descended from Subpool_Handle
+
+ Resolve (Subpool);
+ end if;
+ end;
+
+ -- Analyze the qualified expression or subtype indication
+
if Nkind (E) = N_Qualified_Expression then
Acc_Type := Create_Itype (E_Allocator_Type, N);
Set_Etype (Acc_Type, Acc_Type);
Find_Type (Subtype_Mark (E));
-- Analyze the qualified expression, and apply the name resolution
- -- rule given in 4.7 (3).
+ -- rule given in 4.7(3).
Analyze (E);
Type_Id := Etype (E);
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
-- partial view, it cannot receive a discriminant constraint,
-- and the allocated object is unconstrained.
- elsif Ada_Version >= Ada_05
- and then Has_Constrained_Partial_View (Base_Typ)
+ elsif Ada_Version >= Ada_2005
+ 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;
-- be a null object, and we can insert an unconditional raise
-- before the allocator.
+ -- Ada 2012 (AI-104): A not null indication here is altogether
+ -- illegal.
+
if Can_Never_Be_Null (Type_Id) then
declare
Not_Null_Check : constant Node_Id :=
Make_Raise_Constraint_Error (Sloc (E),
Reason => CE_Null_Not_Allowed);
+
begin
- if Expander_Active then
+ if Ada_Version >= Ada_2012 then
+ Error_Msg_N
+ ("an uninitialized allocator cannot have"
+ & " a null exclusion", N);
+
+ elsif Expander_Active then
Insert_Action (N, Not_Null_Check);
Analyze (Not_Null_Check);
+
else
Error_Msg_N ("null value not allowed here?", E);
end if;
Error_Msg_N
("initialization required in class-wide allocation", N);
else
- if Ada_Version < Ada_05
+ if Ada_Version < Ada_2005
and then Is_Limited_Type (Type_Id)
then
Error_Msg_N ("unconstrained allocation not allowed", N);
Check_Restriction (No_Tasking, N);
Check_Restriction (Max_Tasks, N);
Check_Restriction (No_Task_Allocators, N);
+ end if;
- -- Check that an allocator with task parts isn't for a nested access
- -- type when restriction No_Task_Hierarchy applies.
+ -- AI05-0013-1: No_Nested_Finalization forbids allocators if the access
+ -- type is nested, and the designated type needs finalization. The rule
+ -- is conservative in that class-wide types need finalization.
- if not Is_Library_Level_Entity (Acc_Type) then
- Check_Restriction (No_Task_Hierarchy, N);
- end if;
+ if Needs_Finalization (Designated_Type (Acc_Type))
+ and then not Is_Library_Level_Entity (Acc_Type)
+ then
+ Check_Restriction (No_Nested_Finalization, N);
end if;
-- Check that an allocator of a nested access type doesn't create a
-- Flag indicates whether an interpretation of the prefix is a
-- parameterless call that returns an access_to_subprogram.
+ procedure Check_Mixed_Parameter_And_Named_Associations;
+ -- Check that parameter and named associations are not mixed. This is
+ -- a restriction in SPARK mode.
+
function Name_Denotes_Function return Boolean;
-- If the type of the name is an access to subprogram, this may be the
-- type of a name, or the return type of the function being called. If
procedure No_Interpretation;
-- Output error message when no valid interpretation exists
+ --------------------------------------------------
+ -- Check_Mixed_Parameter_And_Named_Associations --
+ --------------------------------------------------
+
+ procedure Check_Mixed_Parameter_And_Named_Associations is
+ Actual : Node_Id;
+ Named_Seen : Boolean;
+
+ begin
+ Named_Seen := False;
+
+ Actual := First (Actuals);
+ while Present (Actual) loop
+ case Nkind (Actual) is
+ when N_Parameter_Association =>
+ if Named_Seen then
+ Check_SPARK_Restriction
+ ("named association cannot follow positional one",
+ Actual);
+ exit;
+ end if;
+ when others =>
+ Named_Seen := True;
+ end case;
+
+ Next (Actual);
+ end loop;
+ end Check_Mixed_Parameter_And_Named_Associations;
+
---------------------------
-- Name_Denotes_Function --
---------------------------
-- Start of processing for Analyze_Call
begin
+ if Restriction_Check_Required (SPARK) then
+ Check_Mixed_Parameter_And_Named_Associations;
+ end if;
+
-- Initialize the type of the result of the call to the error type,
-- which will be reset if the type is successfully resolved.
-- If this is an indirect call, the return type of the access_to
-- subprogram may be an incomplete type. At the point of the call,
- -- use the full type if available, and at the same time update
- -- the return type of the access_to_subprogram.
+ -- use the full type if available, and at the same time update the
+ -- return type of the access_to_subprogram.
if Success
and then Nkind (Nam) = N_Explicit_Dereference
-- Name may be call that returns an access to subprogram, or more
-- generally an overloaded expression one of whose interpretations
- -- yields an access to subprogram. If the name is an entity, we
- -- do not dereference, because the node is a call that returns
- -- the access type: note difference between f(x), where the call
- -- may return an access subprogram type, and f(x)(y), where the
- -- type returned by the call to f is implicitly dereferenced to
- -- analyze the outer call.
+ -- yields an access to subprogram. If the name is an entity, we do
+ -- not dereference, because the node is a call that returns the
+ -- access type: note difference between f(x), where the call may
+ -- return an access subprogram type, and f(x)(y), where the type
+ -- returned by the call to f is implicitly dereferenced to analyze
+ -- the outer call.
if Is_Access_Type (Nam_Ent) then
Nam_Ent := Designated_Type (Nam_Ent);
Exp_Type : Entity_Id;
Exp_Btype : Entity_Id;
- Last_Choice : Nat;
Dont_Care : Boolean;
Others_Present : Boolean;
Process_Associated_Node => No_OP);
use Case_Choices_Processing;
- Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
-
-----------------------------
-- Non_Static_Choice_Error --
-----------------------------
Get_First_Interp (FirstX, I, It);
while Present (It.Nam) loop
- -- For each intepretation of the first expression, we only
- -- add the intepretation if every other expression in the
+ -- For each interpretation of the first expression, we only
+ -- add the interpretation if every other expression in the
-- case expression alternatives has a compatible type.
Alt := Next (First (Alternatives (N)));
-- Call instantiated Analyze_Choices which does the rest of the work
- Analyze_Choices
- (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
+ Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
if Exp_Type = Universal_Integer and then not Others_Present then
Error_Msg_N
return;
end if;
+ Check_SPARK_Restriction ("conditional expression is not allowed", N);
+
Else_Expr := Next (Then_Expr);
if Comes_From_Source (N) then
begin
Set_Etype (N, Any_Type);
+
+ -- Shouldn't the following statement be down in the ELSE of the
+ -- following loop? ???
+
Get_First_Interp (Then_Expr, I, It);
- while Present (It.Nam) loop
- -- For each possible intepretation of the Then Expression,
- -- add it only if the else expression has a compatible type.
+ -- if no Else_Expression the conditional must be boolean
- -- Is this right if Else_Expr is empty?
+ if No (Else_Expr) then
+ Set_Etype (N, Standard_Boolean);
- if Has_Compatible_Type (Else_Expr, It.Typ) then
- Add_One_Interp (N, It.Typ, It.Typ);
- end if;
+ -- Else_Expression Present. For each possible intepretation of
+ -- the Then_Expression, add it only if the Else_Expression has
+ -- a compatible type.
- Get_Next_Interp (I, It);
- end loop;
+ else
+ 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 if;
end;
end if;
end Analyze_Conditional_Expression;
-- Start of processing for Analyze_Explicit_Dereference
begin
+ -- 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.
+
+ if Alfa_Mode then
+ Alfa.Generate_Dereference (N);
+ end if;
+
Analyze (P);
Set_Etype (N, Any_Type);
then
return;
+ elsif Try_Container_Indexing (N, P, Exp) then
+ return;
+
elsif Array_Type = Any_Type then
Set_Etype (N, Any_Type);
end loop;
Set_Etype (N, Component_Type (Array_Type));
+ Check_Implicit_Dereference (N, Etype (N));
if Present (Index) then
Error_Msg_N
end loop;
if Found and then No (Index) and then No (Exp) then
- Add_One_Interp (N,
- Etype (Component_Type (Typ)),
- Etype (Component_Type (Typ)));
+ declare
+ CT : constant Entity_Id :=
+ Base_Type (Component_Type (Typ));
+ begin
+ Add_One_Interp (N, CT, CT);
+ Check_Implicit_Dereference (N, CT);
+ end;
end if;
+
+ elsif Try_Container_Indexing (N, P, First (Exprs)) then
+ return;
+
end if;
Get_Next_Interp (I, It);
P_T := Base_Type (Etype (P));
- if Is_Entity_Name (P)
- or else Nkind (P) = N_Operator_Symbol
- then
+ if Is_Entity_Name (P) and then Present (Entity (P)) then
U_N := Entity (P);
if Is_Type (U_N) then
---------------------------
procedure Analyze_Membership_Op (N : Node_Id) is
- L : constant Node_Id := Left_Opnd (N);
- R : constant Node_Id := Right_Opnd (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
Index : Interp_Index;
It : Interp;
Analyze_Expression (L);
if No (R)
- and then Ada_Version >= Ada_12
+ and then Ada_Version >= Ada_2012
then
Analyze_Set_Membership;
return;
end loop;
end if;
- -- If not a range, it can only be a subtype mark, or else there
- -- is a more basic error, to be diagnosed in Find_Type.
+ -- If not a range, it can be a subtype mark, or else it is a degenerate
+ -- membership test with a singleton value, i.e. a test for equality,
+ -- if the types are compatible.
else
- Find_Type (R);
+ Analyze (R);
- if Is_Entity_Name (R) then
+ if Is_Entity_Name (R)
+ and then Is_Type (Entity (R))
+ then
+ Find_Type (R);
Check_Fully_Declared (Entity (R), R);
+
+ elsif Ada_Version >= Ada_2012
+ and then Has_Compatible_Type (R, Etype (L))
+ then
+ if Nkind (N) = N_In then
+ Rewrite (N,
+ Make_Op_Eq (Loc,
+ Left_Opnd => L,
+ Right_Opnd => R));
+ else
+ Rewrite (N,
+ Make_Op_Ne (Loc,
+ Left_Opnd => L,
+ Right_Opnd => R));
+ end if;
+
+ Analyze (N);
+ return;
+
+ else
+ -- In all versions of the language, if we reach this point there
+ -- is a previous error that will be diagnosed below.
+
+ Find_Type (R);
end if;
end if;
procedure Analyze_Null (N : Node_Id) is
begin
+ Check_SPARK_Restriction ("null is not allowed", N);
+
Set_Etype (N, Any_Access);
end Analyze_Null;
procedure Indicate_Name_And_Type is
begin
Add_One_Interp (N, Nam, Etype (Nam));
+ Check_Implicit_Dereference (N, Etype (Nam));
Success := True;
-- If the prefix of the call is a name, indicate the entity
-- being called is noted on the selector.
if not Is_Type (Nam) then
- if Is_Entity_Name (Name (N))
- or else Nkind (Name (N)) = N_Operator_Symbol
- then
+ if Is_Entity_Name (Name (N)) then
Set_Entity (Name (N), Nam);
elsif Nkind (Name (N)) = N_Selected_Component then
Actual := First_Actual (N);
Formal := First_Formal (Nam);
- -- If we are analyzing a call rewritten from object notation,
- -- skip first actual, which may be rewritten later as an
- -- explicit dereference.
+ -- If we are analyzing a call rewritten from object notation, skip
+ -- first actual, which may be rewritten later as an explicit
+ -- dereference.
if Must_Skip then
Next_Actual (Actual);
if All_Errors_Mode then
Error_Msg_Sloc := Sloc (Nam);
+ if Etype (Formal) = Any_Type then
+ Error_Msg_N
+ ("there is no legal actual parameter", Actual);
+ end if;
+
if Is_Overloadable (Nam)
and then Present (Alias (Nam))
and then not Comes_From_Source (Nam)
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;
T := It.Typ;
end if;
- if Is_Record_Type (T) then
+ -- Locate the component. For a private prefix the selector can denote
+ -- a discriminant.
+
+ if Is_Record_Type (T) or else Is_Private_Type (T) then
-- If the prefix is a class-wide type, the visible components are
-- those of the base type.
Set_Entity (Sel, Comp);
Set_Etype (Sel, Etype (Comp));
Add_One_Interp (N, Etype (Comp), Etype (Comp));
+ Check_Implicit_Dereference (N, Etype (Comp));
-- This also specifies a candidate to resolve the name.
-- Further overloading will be resolved from context.
Set_Etype (N, T);
end Analyze_Qualified_Expression;
+ -----------------------------------
+ -- Analyze_Quantified_Expression --
+ -----------------------------------
+
+ procedure Analyze_Quantified_Expression (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Ent : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Loop, Current_Scope, Sloc (N), 'L');
+
+ Iterator : Node_Id;
+
+ begin
+ Set_Etype (Ent, Standard_Void_Type);
+ Set_Scope (Ent, Current_Scope);
+ Set_Parent (Ent, N);
+
+ Check_SPARK_Restriction ("quantified expression is not allowed", N);
+
+ -- If expansion is enabled (and not in Alfa mode), the condition is
+ -- analyzed after rewritten as a loop. So we only need to set the type.
+
+ if Operating_Mode /= Check_Semantics
+ and then not Alfa_Mode
+ then
+ Set_Etype (N, Standard_Boolean);
+ return;
+ end if;
+
+ if Present (Loop_Parameter_Specification (N)) then
+ Iterator :=
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Loop_Parameter_Specification (N));
+ else
+ Iterator :=
+ Make_Iteration_Scheme (Loc,
+ Iterator_Specification =>
+ Iterator_Specification (N));
+ end if;
+
+ Push_Scope (Ent);
+ Set_Parent (Iterator, N);
+ Analyze_Iteration_Scheme (Iterator);
+
+ -- The loop specification may have been converted into an iterator
+ -- specification during its analysis. Update the quantified node
+ -- accordingly.
+
+ if Present (Iterator_Specification (Iterator)) then
+ Set_Iterator_Specification
+ (N, Iterator_Specification (Iterator));
+ Set_Loop_Parameter_Specification (N, Empty);
+ end if;
+
+ Analyze (Condition (N));
+ End_Scope;
+ Set_Etype (N, Standard_Boolean);
+ end Analyze_Quantified_Expression;
+
-------------------
-- Analyze_Range --
-------------------
-- 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 --
Is_Single_Concurrent_Object : Boolean;
-- Set True if the prefix is a single task or a single protected object
+ procedure Find_Component_In_Instance (Rec : Entity_Id);
+ -- In an instance, a component of a private extension may not be visible
+ -- while it was visible in the generic. Search candidate scope for a
+ -- component with the proper identifier. This is only done if all other
+ -- searches have failed. When the match is found (it always will be),
+ -- the Etype of both N and Sel are set from this component, and the
+ -- entity of Sel is set to reference this component.
+
function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean;
-- It is known that the parent of N denotes a subprogram call. Comp
-- is an overloadable component of the concurrent type of the prefix.
-- conformant. If the parent node is not analyzed yet it may be an
-- indexed component rather than a function call.
+ --------------------------------
+ -- Find_Component_In_Instance --
+ --------------------------------
+
+ procedure Find_Component_In_Instance (Rec : Entity_Id) is
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (Rec);
+ while Present (Comp) loop
+ if Chars (Comp) = Chars (Sel) then
+ Set_Entity_With_Style_Check (Sel, Comp);
+ Set_Etype (Sel, Etype (Comp));
+ Set_Etype (N, Etype (Comp));
+ return;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ -- This must succeed because code was legal in the generic
+
+ raise Program_Error;
+ end Find_Component_In_Instance;
+
------------------------------
-- Has_Mode_Conformant_Spec --
------------------------------
-- be done transitively, so note the new original discriminant.
if Nkind (Sel) = N_Identifier
+ and then In_Instance
and then Present (Original_Discriminant (Sel))
then
Comp := Find_Corresponding_Discriminant (Sel, Prefix_Type);
New_Occurrence_Of (Comp, Sloc (N)));
Set_Original_Discriminant (Selector_Name (N), Comp);
Set_Etype (N, Etype (Comp));
+ Check_Implicit_Dereference (N, Etype (Comp));
if Is_Access_Type (Etype (Name)) then
Insert_Explicit_Dereference (Name);
Set_Etype (N, Etype (Comp));
end if;
+ Check_Implicit_Dereference (N, Etype (N));
return;
end if;
-- which can appear in expanded code in a tag check.
if Ekind (Type_To_Use) = E_Record_Type_With_Private
- and then Chars (Selector_Name (N)) /= Name_uTag
+ and then Chars (Selector_Name (N)) /= Name_uTag
then
exit when Comp = Last_Entity (Type_To_Use);
end if;
-- Ada 2005 (AI05-0030): In the case of dispatching requeue, the
-- selected component should resolve to a name.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Is_Tagged_Type (Prefix_Type)
and then not Is_Concurrent_Type (Prefix_Type)
then
Set_Etype (Sel, Etype (Comp));
Set_Etype (N, Etype (Comp));
+ Check_Implicit_Dereference (N, Etype (N));
if Is_Generic_Type (Prefix_Type)
or else Is_Generic_Type (Root_Type (Prefix_Type))
-- Before declaring an error, check whether this is tagged
-- private type and a call to a primitive operation.
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
and then Is_Tagged_Type (Prefix_Type)
and then Try_Object_Operation (N)
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;
-- visible entities are plausible interpretations, check whether
-- there is some other primitive operation with that name.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Is_Tagged_Type (Prefix_Type)
then
if (Etype (N) = Any_Type
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.
Analyze_Selected_Component (N);
return;
+ -- Similarly, if this is the actual for a formal derived type, the
+ -- component inherited from the generic parent may not be visible
+ -- in the actual, but the selected component is legal.
+
elsif Ekind (Prefix_Type) = E_Record_Subtype_With_Private
and then Is_Generic_Actual_Type (Prefix_Type)
and then Present (Full_View (Prefix_Type))
then
- -- Similarly, if this the actual for a formal derived type, the
- -- component inherited from the generic parent may not be visible
- -- in the actual, but the selected component is legal.
- declare
- Comp : Entity_Id;
+ Find_Component_In_Instance
+ (Generic_Parent_Type (Parent (Prefix_Type)));
+ return;
- begin
- Comp :=
- First_Component (Generic_Parent_Type (Parent (Prefix_Type)));
- while Present (Comp) loop
- if Chars (Comp) = Chars (Sel) then
- Set_Entity_With_Style_Check (Sel, Comp);
- Set_Etype (Sel, Etype (Comp));
- Set_Etype (N, Etype (Comp));
- return;
- end if;
+ -- Finally, the formal and the actual may be private extensions,
+ -- but the generic is declared in a child unit of the parent, and
+ -- an additional step is needed to retrieve the proper scope.
- Next_Component (Comp);
- end loop;
+ elsif In_Instance
+ and then Present (Parent_Subtype (Etype (Base_Type (Prefix_Type))))
+ then
+ Find_Component_In_Instance
+ (Parent_Subtype (Etype (Base_Type (Prefix_Type))));
+ return;
- pragma Assert (Etype (N) /= Any_Type);
- end;
+ -- Component not found, specialize error message when appropriate
else
if Ekind (Prefix_Type) = E_Record_Subtype then
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
+ if Comes_From_Source (N) then
+ Check_SPARK_Restriction ("slice is not allowed", N);
+ end if;
+
Analyze (P);
Analyze (D);
pragma Warnings (Off, Boolean);
begin
- if Ada_Version >= Ada_05 then
+ if Ada_Version >= Ada_2005 then
Actual := First_Actual (N);
while Present (Actual) loop
null;
else
- -- Save candidate type for subsquent error message, if any
+ -- Save candidate type for subsequent error message, if any
if not Is_Limited_Type (T1) then
Candidate_Type := T1;
-- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
-- Do not allow anonymous access types in equality operators.
- if Ada_Version < Ada_05
+ if Ada_Version < Ada_2005
and then Ekind (T1) = E_Anonymous_Access_Type
then
return;
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)
or else Is_Array_Type (Etype (L))
or else Is_Array_Type (Etype (R)))
then
-
if Nkind (N) = N_Op_Concat then
if Etype (L) /= Any_Composite
and then Is_Array_Type (Etype (L))
Error_Msg_NE -- CODEFIX
("operator for} is not directly visible!",
N, First_Subtype (Candidate_Type));
- Error_Msg_N -- CODEFIX
- ("use clause would make operation legal!", N);
+
+ declare
+ U : constant Node_Id :=
+ Cunit (Get_Source_Unit (Candidate_Type));
+ begin
+ if Unit_Is_Visible (U) then
+ Error_Msg_N -- CODEFIX
+ ("use clause would make operation legal!", N);
+ else
+ Error_Msg_NE -- CODEFIX
+ ("add with_clause and use_clause for&!",
+ N, Defining_Entity (Unit (U)));
+ end if;
+ end;
return;
-- If either operand is a junk operand (e.g. package name), then
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.
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
or else Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (It.Nam)))
then
-- predefined operators when addresses are involved since this
-- case is handled separately.
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
and then not Address_Kludge
then
while Present (It.Nam) loop
end if;
end Remove_Abstract_Operations;
+ ----------------------------
+ -- Try_Container_Indexing --
+ ----------------------------
+
+ function Try_Container_Indexing
+ (N : Node_Id;
+ Prefix : Node_Id;
+ Expr : Node_Id) return Boolean
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Disc : Entity_Id;
+ Func : Entity_Id;
+ Func_Name : Node_Id;
+ Indexing : Node_Id;
+
+ begin
+
+ -- Check whether type has a specified indexing aspect
+
+ Func_Name := Empty;
+
+ if Is_Variable (Prefix) then
+ Func_Name := Find_Aspect (Etype (Prefix), Aspect_Variable_Indexing);
+ end if;
+
+ 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.
+
+ if No (Func_Name) then
+
+ -- The prefix itself may be an indexing of a container
+ -- rewrite as such and re-analyze.
+
+ if Has_Implicit_Dereference (Etype (Prefix)) then
+ Build_Explicit_Dereference
+ (Prefix, First_Discriminant (Etype (Prefix)));
+ return Try_Container_Indexing (N, Prefix, Expr);
+
+ else
+ return False;
+ end if;
+ end if;
+
+ if not Is_Overloaded (Func_Name) then
+ Func := Entity (Func_Name);
+ Indexing := Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Func, Loc),
+ Parameter_Associations =>
+ New_List (Relocate_Node (Prefix), Relocate_Node (Expr)));
+ Rewrite (N, Indexing);
+ Analyze (N);
+
+ -- The return type of the indexing function is a reference type, so
+ -- add the dereference as a possible interpretation.
+
+ 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;
+
+ else
+ Indexing := Make_Function_Call (Loc,
+ Name => Make_Identifier (Loc, Chars (Func_Name)),
+ Parameter_Associations =>
+ New_List (Relocate_Node (Prefix), Relocate_Node (Expr)));
+
+ Rewrite (N, Indexing);
+
+ declare
+ I : Interp_Index;
+ It : Interp;
+ Success : Boolean;
+
+ begin
+ Get_First_Interp (Func_Name, I, It);
+ Set_Etype (N, Any_Type);
+ while Present (It.Nam) loop
+ 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
+
+ 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;
+
+ 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_Indirect_Call --
-----------------------
and then Is_Type (Entity (Actual))
and then No (Next (Actual))
then
- Rewrite (N,
- Make_Slice (Loc,
- Prefix => Make_Function_Call (Loc,
- Name => Relocate_Node (Name (N))),
- Discrete_Range =>
- New_Occurrence_Of (Entity (Actual), Sloc (Actual))));
+ -- A single actual that is a type name indicates a slice if the
+ -- type is discrete, and an error otherwise.
+
+ if Is_Discrete_Type (Entity (Actual)) then
+ Rewrite (N,
+ Make_Slice (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name => Relocate_Node (Name (N))),
+ Discrete_Range =>
+ New_Occurrence_Of (Entity (Actual), Sloc (Actual))));
+
+ Analyze (N);
+
+ else
+ Error_Msg_N ("invalid use of type in expression", Actual);
+ Set_Etype (N, Any_Type);
+ end if;
- Analyze (N);
return True;
elsif not Has_Compatible_Type (Actual, Etype (Index)) then
-- 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;
if Present (Arr_Type) then
- -- Verify that the actuals (excluding the object)
- -- match the types of the indices.
+ -- Verify that the actuals (excluding the object) match the types
+ -- of the indexes.
declare
Actual : 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
Hom := Current_Entity (Subprog);
- -- Find operation whose first parameter is of the class-wide
- -- type, a subtype thereof, or an anonymous access to same.
+ -- Find a non-hidden operation whose first parameter is of the
+ -- class-wide type, a subtype thereof, or an anonymous access
+ -- to same.
while Present (Hom) loop
- if (Ekind (Hom) = E_Procedure
- or else
- Ekind (Hom) = E_Function)
+ if Ekind_In (Hom, E_Procedure, E_Function)
+ and then not Is_Hidden (Hom)
and then Scope (Hom) = Scope (Anc_Type)
and then Present (First_Formal (Hom))
and then
(Designated_Type (Etype (First_Formal (Hom)))) =
Cls_Type))
then
+ -- If the context is a procedure call, ignore functions
+ -- in the name of the call.
+
+ if Ekind (Hom) = E_Function
+ and then Nkind (Parent (N)) = N_Procedure_Call_Statement
+ 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);
Set_Is_Overloaded (Call_Node, False);
Success := False;
end if;
end if;
- Hom := Homonym (Hom);
+ <<Next_Hom>>
+ Hom := Homonym (Hom);
end loop;
end Traverse_Homonyms;
-- 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;
-----------------------------
or else
(Ekind (Typ) = E_Anonymous_Access_Type
- and then Designated_Type (Typ) = Base_Type (Corr_Type));
+ and then
+ Base_Type (Designated_Type (Typ)) = Base_Type (Corr_Type));
end Valid_First_Argument_Of;
-- Start of processing for Try_Primitive_Operation
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
