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
-- the call may be overloaded with both interpretations.
function Try_Object_Operation (N : Node_Id) return Boolean;
- -- Ada 2005 (AI-252): Support the object.operation notation
+ -- 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.
procedure wpo (T : Entity_Id);
pragma Warnings (Off, wpo);
E : Node_Id := Expression (N);
Acc_Type : Entity_Id;
Type_Id : Entity_Id;
+ P : Node_Id;
+ C : Node_Id;
begin
+ -- 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 appearence 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;
+ -- Analyze the allocator
+
if Nkind (E) = N_Qualified_Expression then
Acc_Type := Create_Itype (E_Allocator_Type, N);
Set_Etype (Acc_Type, Acc_Type);
-- partial view, it cannot receive a discriminant constraint,
-- and the allocated object is unconstrained.
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
and then Has_Constrained_Partial_View (Base_Typ)
then
Error_Msg_N
-- 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);
+
+ -- Check that an allocator with task parts isn't for a nested access
+ -- type when restriction No_Task_Hierarchy applies.
+
+ if not Is_Library_Level_Entity (Acc_Type) then
+ Check_Restriction (No_Task_Hierarchy, N);
+ end if;
+ end if;
+
+ -- Check that an allocator of a nested access type doesn't create a
+ -- protected object when restriction No_Local_Protected_Objects applies.
+ -- We don't have an equivalent to Has_Task for protected types, so only
+ -- cases where the designated type itself is a protected type are
+ -- currently checked. ???
+
+ if Is_Protected_Type (Designated_Type (Acc_Type))
+ and then not Is_Library_Level_Entity (Acc_Type)
+ then
+ Check_Restriction (No_Local_Protected_Objects, N);
end if;
-- If the No_Streams restriction is set, check that the type of the
-- Has_Stream just for efficiency reasons. There is no point in
-- spending time on a Has_Stream check if the restriction is not set.
- if Restrictions.Set (No_Streams) then
+ if Restriction_Check_Required (No_Streams) then
if Has_Stream (Designated_Type (Acc_Type)) then
Check_Restriction (No_Streams, N);
end if;
-- 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);
P_T := Base_Type (Etype (P));
- if Is_Entity_Name (P)
- or else Nkind (P) = N_Operator_Symbol
- then
+ if Is_Entity_Name (P) then
U_N := Entity (P);
if Is_Type (U_N) then
Analyze_Expression (L);
if No (R)
- and then Extensions_Allowed
+ and then Ada_Version >= Ada_2012
then
Analyze_Set_Membership;
return;
-- 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
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_Parent (Ent, N);
+
+ Iterator :=
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification => Loop_Parameter_Specification (N));
+
+ Push_Scope (Ent);
+ Analyze_Iteration_Scheme (Iterator);
+ Analyze (Condition (N));
+ End_Scope;
+
+ Set_Etype (N, Standard_Boolean);
+ end Analyze_Quantified_Expression;
+
-------------------
-- Analyze_Range --
-------------------
-- It is not clear if that can ever occur, but in case it does, we will
-- generate an error message. Not clear if this message can ever be
-- generated, and pretty clear that it represents a bug if it is, still
- -- seems worth checking!
+ -- seems worth checking, except in CodePeer mode where we do not really
+ -- care and don't want to bother the user.
T := Etype (P);
if Is_Entity_Name (P)
and then Is_Object_Reference (P)
+ and then not CodePeer_Mode
then
E := Entity (P);
T := Etype (P);
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 --
------------------------------
if Is_Access_Type (Prefix_Type) then
- -- A RACW object can never be used as prefix of a selected
- -- component since that means it is dereferenced without
- -- being a controlling operand of a dispatching operation
- -- (RM E.2.2(16/1)). Before reporting an error, we must check
- -- whether this is actually a dispatching call in prefix form.
+ -- A RACW object can never be used as prefix of a selected component
+ -- since that means it is dereferenced without being a controlling
+ -- operand of a dispatching operation (RM E.2.2(16/1)). Before
+ -- reporting an error, we must check whether this is actually a
+ -- dispatching call in prefix form.
if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type)
and then Comes_From_Source (N)
-- this case gigi generates all the checks and can find the
-- necessary bounds information.
- -- We also do not need an actual subtype for the case of
- -- a first, last, length, or range attribute applied to a
+ -- We also do not need an actual subtype for the case of a
+ -- first, last, length, or range attribute applied to a
-- non-packed array, since gigi can again get the bounds in
-- these cases (gigi cannot handle the packed case, since it
-- has the bounds of the packed array type, not the original
-- 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
-- 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
-- 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
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 addtional 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
- -- Check whether this is a component of the base type
- -- which is absent from a statically constrained subtype.
- -- This will raise constraint error at run-time, but is
- -- not a compile-time error. When the selector is illegal
- -- for base type as well fall through and generate a
- -- compilation error anyway.
+ -- Check whether this is a component of the base type which
+ -- is absent from a statically constrained subtype. This will
+ -- raise constraint error at run time, but is not a compile-
+ -- time error. When the selector is illegal for base type as
+ -- well fall through and generate a compilation error anyway.
Comp := First_Component (Base_Type (Prefix_Type));
while Present (Comp) loop
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
-- 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;
-- 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
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
N_Function_Call);
Loc : constant Source_Ptr := Sloc (N);
Obj : constant Node_Id := Prefix (N);
- Subprog : constant Node_Id :=
- Make_Identifier (Sloc (Selector_Name (N)),
- Chars => Chars (Selector_Name (N)));
+
+ Subprog : constant Node_Id :=
+ Make_Identifier (Sloc (Selector_Name (N)),
+ Chars => Chars (Selector_Name (N)));
-- Identifier on which possible interpretations will be collected
Report_Error : Boolean := False;
else
Analyze (Node_To_Replace);
- -- If the operation has been rewritten into a call, which may
- -- get subsequently an explicit dereference, preserve the
- -- type on the original node (selected component or indexed
- -- component) for subsequent legality tests, e.g. Is_Variable.
- -- which examines the original node.
+ -- If the operation has been rewritten into a call, which may get
+ -- subsequently an explicit dereference, preserve the type on the
+ -- original node (selected component or indexed component) for
+ -- subsequent legality tests, e.g. Is_Variable. which examines
+ -- the original node.
if Nkind (Node_To_Replace) = N_Function_Call then
Set_Etype
and then N = Prefix (Parent_Node)
then
Node_To_Replace := Parent_Node;
-
Actuals := Expressions (Parent_Node);
Actual := First (Actuals);
OSDN Git Service
