-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Checks; use Checks;
with Einfo; use Einfo;
with Errout; use Errout;
-with Exp_Ch9;
+with Exp_Ch9; use Exp_Ch9;
with Elists; use Elists;
with Freeze; use Freeze;
-with Itypes; use Itypes;
with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
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_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Style;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-- count the entries (checking the static requirement), and compare with
-- the given maximum.
- procedure Check_Overriding_Indicator (Def : Node_Id);
- -- Ada 2005 (AI-397): Check the overriding indicator of entries and
- -- subprograms of protected or task types. Def is the definition of
- -- the protected or task type.
+ procedure Check_Interfaces (N : Node_Id; T : Entity_Id);
+ -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node.
+ -- Complete decoration of T and check legality of the covered interfaces.
+
+ procedure Check_Triggering_Statement
+ (Trigger : Node_Id;
+ Error_Node : Node_Id;
+ Is_Dispatching : out Boolean);
+ -- Examine the triggering statement of a select statement, conditional or
+ -- timed entry call. If Trigger is a dispatching call, return its status
+ -- in Is_Dispatching and check whether the primitive belongs to a limited
+ -- interface. If it does not, emit an error at Error_Node.
function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
-- Find entity in corresponding task or protected declaration. Use full
-- view if first declaration was for an incomplete type.
procedure Install_Declarations (Spec : Entity_Id);
- -- Utility to make visible in corresponding body the entities defined
- -- in task, protected type declaration, or entry declaration.
+ -- Utility to make visible in corresponding body the entities defined in
+ -- task, protected type declaration, or entry declaration.
-----------------------------
-- Analyze_Abort_Statement --
begin
Tasking_Used := True;
+ Check_SPARK_Restriction ("abort statement is not allowed", N);
+
T_Name := First (Names (N));
while Present (T_Name) loop
Analyze (T_Name);
- if not Is_Task_Type (Etype (T_Name)) then
- Error_Msg_N ("expect task name for ABORT", T_Name);
- return;
- else
+ if Is_Task_Type (Etype (T_Name))
+ or else (Ada_Version >= Ada_2005
+ and then Ekind (Etype (T_Name)) = E_Class_Wide_Type
+ and then Is_Interface (Etype (T_Name))
+ and then Is_Task_Interface (Etype (T_Name)))
+ then
Resolve (T_Name);
+ else
+ if Ada_Version >= Ada_2005 then
+ Error_Msg_N ("expect task name or task interface class-wide "
+ & "object for ABORT", T_Name);
+ else
+ Error_Msg_N ("expect task name for ABORT", T_Name);
+ end if;
+
+ return;
end if;
Next (T_Name);
Kind : Entity_Kind;
Task_Nam : Entity_Id;
- -----------------------
- -- Actual_Index_Type --
- -----------------------
-
- function Actual_Index_Type (E : Entity_Id) return Entity_Id;
- -- If the bounds of an entry family depend on task discriminants,
- -- create a new index type where a discriminant is replaced by the
- -- local variable that renames it in the task body.
-
- function Actual_Index_Type (E : Entity_Id) return Entity_Id is
- Typ : constant Entity_Id := Entry_Index_Type (E);
- Lo : constant Node_Id := Type_Low_Bound (Typ);
- Hi : constant Node_Id := Type_High_Bound (Typ);
- New_T : Entity_Id;
-
- function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
- -- If bound is discriminant reference, replace with corresponding
- -- local variable of the same name.
-
- -----------------------------
- -- Actual_Discriminant_Ref --
- -----------------------------
-
- function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
- Typ : constant Entity_Id := Etype (Bound);
- Ref : Node_Id;
-
- begin
- if not Is_Entity_Name (Bound)
- or else Ekind (Entity (Bound)) /= E_Discriminant
- then
- return Bound;
-
- else
- Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound)));
- Analyze (Ref);
- Resolve (Ref, Typ);
- return Ref;
- end if;
- end Actual_Discriminant_Ref;
-
- -- Start of processing for Actual_Index_Type
-
- begin
- if not Has_Discriminants (Task_Nam)
- or else (not Is_Entity_Name (Lo)
- and then not Is_Entity_Name (Hi))
- then
- return Entry_Index_Type (E);
- else
- New_T := Create_Itype (Ekind (Typ), N);
- Set_Etype (New_T, Base_Type (Typ));
- Set_Size_Info (New_T, Typ);
- Set_RM_Size (New_T, RM_Size (Typ));
- Set_Scalar_Range (New_T,
- Make_Range (Sloc (N),
- Low_Bound => Actual_Discriminant_Ref (Lo),
- High_Bound => Actual_Discriminant_Ref (Hi)));
-
- return New_T;
- end if;
- end Actual_Index_Type;
-
- -- Start of processing for Analyze_Accept_Statement
-
begin
Tasking_Used := True;
+ Check_SPARK_Restriction ("accept statement is not allowed", N);
-- Entry name is initialized to Any_Id. It should get reset to the
-- matching entry entity. An error is signalled if it is not reset.
return;
end if;
- -- In order to process the parameters, we create a defining
- -- identifier that can be used as the name of the scope. The
- -- name of the accept statement itself is not a defining identifier,
- -- and we cannot use its name directly because the task may have
- -- any number of accept statements for the same entry.
+ -- In order to process the parameters, we create a defining identifier
+ -- that can be used as the name of the scope. The name of the accept
+ -- statement itself is not a defining identifier, and we cannot use
+ -- its name directly because the task may have any number of accept
+ -- statements for the same entry.
if Present (Index) then
Accept_Id := New_Internal_Entity
Set_Accept_Address (Accept_Id, New_Elmt_List);
if Present (Formals) then
- New_Scope (Accept_Id);
+ Push_Scope (Accept_Id);
Process_Formals (Formals, N);
Create_Extra_Formals (Accept_Id);
End_Scope;
end if;
- -- We set the default expressions processed flag because we don't
- -- need default expression functions. This is really more like a
- -- body entity than a spec entity anyway.
+ -- We set the default expressions processed flag because we don't need
+ -- default expression functions. This is really more like body entity
+ -- than a spec entity anyway.
Set_Default_Expressions_Processed (Accept_Id);
Style.Check_Identifier (Nam, Entry_Nam);
end if;
- -- Verify that the entry is not hidden by a procedure declared in
- -- the current block (pathological but possible).
+ -- Verify that the entry is not hidden by a procedure declared in the
+ -- current block (pathological but possible).
if Current_Scope /= Task_Nam then
declare
begin
E1 := First_Entity (Current_Scope);
-
while Present (E1) loop
-
if Ekind (E1) = E_Procedure
and then Chars (E1) = Chars (Entry_Nam)
and then Type_Conformant (E1, Entry_Nam)
if Entry_Nam = Scope_Stack.Table (J).Entity then
Error_Msg_N ("duplicate accept statement for same entry", N);
end if;
-
end loop;
declare
Error_Msg_N ("missing entry index in accept for entry family", N);
else
Analyze_And_Resolve (Index, Entry_Index_Type (E));
- Apply_Range_Check (Index, Actual_Index_Type (E));
+ Apply_Range_Check (Index, Entry_Index_Type (E));
end if;
elsif Present (Index) then
Error_Msg_N ("invalid entry index in accept for simple entry", N);
end if;
- -- If label declarations present, analyze them. They are declared
- -- in the enclosing task, but their enclosing scope is the entry itself,
- -- so that goto's to the label are recognized as local to the accept.
+ -- If label declarations present, analyze them. They are declared in the
+ -- enclosing task, but their enclosing scope is the entry itself, so
+ -- that goto's to the label are recognized as local to the accept.
if Present (Declarations (N)) then
-
declare
Decl : Node_Id;
Id : Entity_Id;
begin
Decl := First (Declarations (N));
-
while Present (Decl) loop
Analyze (Decl);
end;
end if;
- -- If statements are present, they must be analyzed in the context
- -- of the entry, so that references to formals are correctly resolved.
- -- We also have to add the declarations that are required by the
- -- expansion of the accept statement in this case if expansion active.
+ -- If statements are present, they must be analyzed in the context of
+ -- the entry, so that references to formals are correctly resolved. We
+ -- also have to add the declarations that are required by the expansion
+ -- of the accept statement in this case if expansion active.
+
+ -- In the case of a select alternative of a selective accept, the
+ -- expander references the address declaration even if there is no
+ -- statement list.
- -- In the case of a select alternative of a selective accept,
- -- the expander references the address declaration even if there
- -- is no statement list.
-- We also need to create the renaming declarations for the local
- -- variables that will replace references to the formals within
- -- the accept.
+ -- variables that will replace references to the formals within the
+ -- accept statement.
Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
-- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
-- fields on all entry formals (this loop ignores all other entities).
- -- Reset Set_Referenced and Has_Pragma_Unreferenced as well, so that
- -- we can post accurate warnings on each accept statement for the same
- -- entry.
+ -- Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as
+ -- well, so that we can post accurate warnings on each accept statement
+ -- for the same entry.
E := First_Entity (Entry_Nam);
while Present (E) loop
if Is_Formal (E) then
- Set_Never_Set_In_Source (E, True);
- Set_Is_True_Constant (E, False);
- Set_Current_Value (E, Empty);
- Set_Referenced (E, False);
- Set_Has_Pragma_Unreferenced (E, False);
+ Set_Never_Set_In_Source (E, True);
+ Set_Is_True_Constant (E, False);
+ Set_Current_Value (E, Empty);
+ Set_Referenced (E, False);
+ Set_Referenced_As_LHS (E, False);
+ Set_Referenced_As_Out_Parameter (E, False);
+ Set_Has_Pragma_Unreferenced (E, False);
end if;
Next_Entity (E);
-- Analyze statements if present
if Present (Stats) then
- New_Scope (Entry_Nam);
+ Push_Scope (Entry_Nam);
Install_Declarations (Entry_Nam);
Set_Actual_Subtypes (N, Current_Scope);
---------------------------------
procedure Analyze_Asynchronous_Select (N : Node_Id) is
+ Is_Disp_Select : Boolean := False;
+ Trigger : Node_Id;
+
begin
Tasking_Used := True;
+ Check_SPARK_Restriction ("select statement is not allowed", N);
Check_Restriction (Max_Asynchronous_Select_Nesting, N);
Check_Restriction (No_Select_Statements, N);
- -- Analyze the statements. We analyze statements in the abortable part
- -- first, because this is the section that is executed first, and that
- -- way our remembering of saved values and checks is accurate.
+ if Ada_Version >= Ada_2005 then
+ Trigger := Triggering_Statement (Triggering_Alternative (N));
+
+ Analyze (Trigger);
+
+ -- Ada 2005 (AI-345): Check for a potential dispatching select
+
+ Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
+ end if;
+
+ -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous
+ -- select will have to duplicate the triggering statements. Postpone
+ -- the analysis of the statements till expansion. Analyze only if the
+ -- expander is disabled in order to catch any semantic errors.
+
+ if Is_Disp_Select then
+ if not Expander_Active then
+ Analyze_Statements (Statements (Abortable_Part (N)));
+ Analyze (Triggering_Alternative (N));
+ end if;
+
+ -- Analyze the statements. We analyze statements in the abortable part,
+ -- because this is the section that is executed first, and that way our
+ -- remembering of saved values and checks is accurate.
- Analyze_Statements (Statements (Abortable_Part (N)));
- Analyze (Triggering_Alternative (N));
+ else
+ Analyze_Statements (Statements (Abortable_Part (N)));
+ Analyze (Triggering_Alternative (N));
+ end if;
end Analyze_Asynchronous_Select;
------------------------------------
------------------------------------
procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
+ Trigger : constant Node_Id :=
+ Entry_Call_Statement (Entry_Call_Alternative (N));
+ Is_Disp_Select : Boolean := False;
+
begin
- Check_Restriction (No_Select_Statements, N);
Tasking_Used := True;
- Analyze (Entry_Call_Alternative (N));
- Analyze_Statements (Else_Statements (N));
+ Check_SPARK_Restriction ("select statement is not allowed", N);
+ Check_Restriction (No_Select_Statements, N);
+
+ -- Ada 2005 (AI-345): The trigger may be a dispatching call
+
+ if Ada_Version >= Ada_2005 then
+ Analyze (Trigger);
+ Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
+ end if;
+
+ if List_Length (Else_Statements (N)) = 1
+ and then Nkind (First (Else_Statements (N))) in N_Delay_Statement
+ then
+ Error_Msg_N
+ ("suspicious form of conditional entry call?!", N);
+ Error_Msg_N
+ ("\`SELECT OR` may be intended rather than `SELECT ELSE`!", N);
+ end if;
+
+ -- Postpone the analysis of the statements till expansion. Analyze only
+ -- if the expander is disabled in order to catch any semantic errors.
+
+ if Is_Disp_Select then
+ if not Expander_Active then
+ Analyze (Entry_Call_Alternative (N));
+ Analyze_Statements (Else_Statements (N));
+ end if;
+
+ -- Regular select analysis
+
+ else
+ Analyze (Entry_Call_Alternative (N));
+ Analyze_Statements (Else_Statements (N));
+ end if;
end Analyze_Conditional_Entry_Call;
--------------------------------
procedure Analyze_Delay_Alternative (N : Node_Id) is
Expr : Node_Id;
+ Typ : Entity_Id;
begin
Tasking_Used := True;
Analyze_List (Pragmas_Before (N));
end if;
- if Nkind (Parent (N)) = N_Selective_Accept
- or else Nkind (Parent (N)) = N_Timed_Entry_Call
- then
+ if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then
Expr := Expression (Delay_Statement (N));
- -- defer full analysis until the statement is expanded, to insure
+ -- Defer full analysis until the statement is expanded, to insure
-- that generated code does not move past the guard. The delay
-- expression is only evaluated if the guard is open.
if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
- Pre_Analyze_And_Resolve (Expr, Standard_Duration);
-
+ Preanalyze_And_Resolve (Expr, Standard_Duration);
else
- Pre_Analyze_And_Resolve (Expr);
+ Preanalyze_And_Resolve (Expr);
end if;
- if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement and then
- not Is_RTE (Base_Type (Etype (Expr)), RO_CA_Time) and then
- not Is_RTE (Base_Type (Etype (Expr)), RO_RT_Time)
+ Typ := First_Subtype (Etype (Expr));
+
+ if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement
+ and then not Is_RTE (Typ, RO_CA_Time)
+ and then not Is_RTE (Typ, RO_RT_Time)
then
Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
end if;
Check_Restriction (No_Fixed_Point, Expr);
+
else
Analyze (Delay_Statement (N));
end if;
procedure Analyze_Delay_Relative (N : Node_Id) is
E : constant Node_Id := Expression (N);
-
begin
- Check_Restriction (No_Relative_Delay, N);
Tasking_Used := True;
+ Check_SPARK_Restriction ("delay statement is not allowed", N);
+ Check_Restriction (No_Relative_Delay, N);
Check_Restriction (No_Delay, N);
Check_Potentially_Blocking_Operation (N);
Analyze_And_Resolve (E, Standard_Duration);
-------------------------
procedure Analyze_Delay_Until (N : Node_Id) is
- E : constant Node_Id := Expression (N);
+ E : constant Node_Id := Expression (N);
+ Typ : Entity_Id;
begin
Tasking_Used := True;
+ Check_SPARK_Restriction ("delay statement is not allowed", N);
Check_Restriction (No_Delay, N);
Check_Potentially_Blocking_Operation (N);
Analyze (E);
+ Typ := First_Subtype (Etype (E));
- if not Is_RTE (Base_Type (Etype (E)), RO_CA_Time) and then
- not Is_RTE (Base_Type (Etype (E)), RO_RT_Time)
+ if not Is_RTE (Typ, RO_CA_Time) and then
+ not Is_RTE (Typ, RO_RT_Time)
then
Error_Msg_N ("expect Time types for `DELAY UNTIL`", E);
end if;
Stats : constant Node_Id := Handled_Statement_Sequence (N);
Formals : constant Node_Id := Entry_Body_Formal_Part (N);
P_Type : constant Entity_Id := Current_Scope;
- Entry_Name : Entity_Id;
E : Entity_Id;
+ Entry_Name : Entity_Id;
begin
Tasking_Used := True;
(Entry_Index_Specification (Formals)));
else
- -- The elaboration of the entry body does not recompute
- -- the bounds of the index, which may have side effects.
- -- Inherit the bounds from the entry declaration. This
- -- is critical if the entry has a per-object constraint.
- -- If a bound is given by a discriminant, it must be
- -- reanalyzed in order to capture the discriminal of the
- -- current entry, rather than that of the protected type.
+ -- The elaboration of the entry body does not recompute the
+ -- bounds of the index, which may have side effects. Inherit
+ -- the bounds from the entry declaration. This is critical
+ -- if the entry has a per-object constraint. If a bound is
+ -- given by a discriminant, it must be reanalyzed in order
+ -- to capture the discriminal of the current entry, rather
+ -- than that of the protected type.
declare
Index_Spec : constant Node_Id :=
then
Set_Etype (Def, Empty);
Set_Analyzed (Def, False);
- Set_Discrete_Subtype_Definition (Index_Spec, Def);
+
+ -- Keep the original subtree to ensure a properly
+ -- formed tree (e.g. for ASIS use).
+
+ Rewrite
+ (Discrete_Subtype_Definition (Index_Spec), Def);
+
Set_Analyzed (Low_Bound (Def), False);
Set_Analyzed (High_Bound (Def), False);
end if;
Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
- New_Scope (Entry_Name);
+ Push_Scope (Entry_Name);
- Exp_Ch9.Expand_Entry_Body_Declarations (N);
Install_Declarations (Entry_Name);
Set_Actual_Subtypes (N, Current_Scope);
-- The entity for the protected subprogram corresponding to the entry
-- has been created. We retain the name of this entity in the entry
-- body, for use when the corresponding subprogram body is created.
- -- Note that entry bodies have to corresponding_spec, and there is no
+ -- Note that entry bodies have no corresponding_spec, and there is no
-- easy link back in the tree between the entry body and the entity for
- -- the entry itself.
+ -- the entry itself, which is why we must propagate some attributes
+ -- explicitly from spec to body.
+
+ Set_Protected_Body_Subprogram
+ (Id, Protected_Body_Subprogram (Entry_Name));
- Set_Protected_Body_Subprogram (Id,
- Protected_Body_Subprogram (Entry_Name));
+ Set_Entry_Parameters_Type
+ (Id, Entry_Parameters_Type (Entry_Name));
+
+ -- Add a declaration for the Protection object, renaming declarations
+ -- for the discriminals and privals and finally a declaration for the
+ -- entry family index (if applicable).
+
+ if Full_Expander_Active
+ and then Is_Protected_Type (P_Type)
+ then
+ Install_Private_Data_Declarations
+ (Sloc (N), Entry_Name, P_Type, N, Decls);
+ end if;
if Present (Decls) then
Analyze_Declarations (Decls);
+ Inspect_Deferred_Constant_Completion (Decls);
end if;
if Present (Stats) then
-- At the same time, we set the flags on the spec entities to suppress
-- any warnings on the spec formals, since we also scan the spec.
+ -- Finally, we propagate the Entry_Component attribute to the body
+ -- formals, for use in the renaming declarations created later for the
+ -- formals (see exp_ch9.Add_Formal_Renamings).
declare
- E1 : Entity_Id;
- E2 : Entity_Id;
+ E1 : Entity_Id;
+ E2 : Entity_Id;
begin
E1 := First_Entity (Entry_Name);
Next_Entity (E2);
end loop;
- -- If no matching body entity, then we already had
- -- a detected error of some kind, so just forget
- -- about worrying about these warnings.
+ -- If no matching body entity, then we already had a detected
+ -- error of some kind, so just don't worry about these warnings.
if No (E2) then
goto Continue;
Set_Referenced (E2, Referenced (E1));
Set_Referenced (E1);
+ Set_Entry_Component (E2, Entry_Component (E1));
<<Continue>>
Next_Entity (E1);
then
End_Scope;
end if;
-
end Analyze_Entry_Body;
------------------------------------
if Present (Index) then
Analyze (Index);
+
+ -- The entry index functions like a loop variable, thus it is known
+ -- to have a valid value.
+
+ Set_Is_Known_Valid (Defining_Identifier (Index));
end if;
if Present (Formals) then
Set_Scope (Id, Current_Scope);
- New_Scope (Id);
+ Push_Scope (Id);
Process_Formals (Formals, Parent (N));
End_Scope;
end if;
begin
Tasking_Used := True;
+ Check_SPARK_Restriction ("entry call is not allowed", N);
if Present (Pragmas_Before (N)) then
Analyze_List (Pragmas_Before (N));
if Nkind (Call) = N_Attribute_Reference then
-- Possibly a stream attribute, but definitely illegal. Other
- -- illegalitles, such as procedure calls, are diagnosed after
+ -- illegalities, such as procedure calls, are diagnosed after
-- resolution.
Error_Msg_N ("entry call alternative requires an entry call", Call);
-------------------------------
procedure Analyze_Entry_Declaration (N : Node_Id) is
- Formals : constant List_Id := Parameter_Specifications (N);
- Id : constant Entity_Id := Defining_Identifier (N);
D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N);
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
+ Formals : constant List_Id := Parameter_Specifications (N);
begin
- Generate_Definition (Id);
+ Generate_Definition (Def_Id);
+ Set_Contract (Def_Id, Make_Contract (Sloc (Def_Id)));
Tasking_Used := True;
+ -- Case of no discrete subtype definition
+
if No (D_Sdef) then
- Set_Ekind (Id, E_Entry);
+ Set_Ekind (Def_Id, E_Entry);
+
+ -- Processing for discrete subtype definition present
+
else
- Enter_Name (Id);
- Set_Ekind (Id, E_Entry_Family);
+ Enter_Name (Def_Id);
+ Set_Ekind (Def_Id, E_Entry_Family);
Analyze (D_Sdef);
- Make_Index (D_Sdef, N, Id);
+ Make_Index (D_Sdef, N, Def_Id);
+
+ -- Check subtype with predicate in entry family
+
+ Bad_Predicated_Subtype_Use
+ ("subtype& has predicate, not allowed in entry family",
+ D_Sdef, Etype (D_Sdef));
+
+ -- Check entry family static bounds outside allowed limits
+
+ -- Note: originally this check was not performed here, but in that
+ -- case the check happens deep in the expander, and the message is
+ -- posted at the wrong location, and omitted in -gnatc mode.
+ -- If the type of the entry index is a generic formal, no check
+ -- is possible. In an instance, the check is not static and a run-
+ -- time exception will be raised if the bounds are unreasonable.
+
+ declare
+ PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index);
+ LB : constant Uint := Expr_Value (Type_Low_Bound (PEI));
+ UB : constant Uint := Expr_Value (Type_High_Bound (PEI));
+
+ LBR : Node_Id;
+ UBR : Node_Id;
+
+ begin
+
+ -- No bounds checking if the type is generic or if previous error.
+ -- In an instance the check is dynamic.
+
+ if Is_Generic_Type (Etype (D_Sdef))
+ or else In_Instance
+ or else Error_Posted (D_Sdef)
+ then
+ goto Skip_LB;
+
+ elsif Nkind (D_Sdef) = N_Range then
+ LBR := Low_Bound (D_Sdef);
+
+ elsif Is_Entity_Name (D_Sdef)
+ and then Is_Type (Entity (D_Sdef))
+ then
+ LBR := Type_Low_Bound (Entity (D_Sdef));
+
+ else
+ goto Skip_LB;
+ end if;
+
+ if Is_Static_Expression (LBR)
+ and then Expr_Value (LBR) < LB
+ then
+ Error_Msg_Uint_1 := LB;
+ Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef);
+ end if;
+
+ <<Skip_LB>>
+ if Is_Generic_Type (Etype (D_Sdef))
+ or else In_Instance
+ or else Error_Posted (D_Sdef)
+ then
+ goto Skip_UB;
+
+ elsif Nkind (D_Sdef) = N_Range then
+ UBR := High_Bound (D_Sdef);
+
+ elsif Is_Entity_Name (D_Sdef)
+ and then Is_Type (Entity (D_Sdef))
+ then
+ UBR := Type_High_Bound (Entity (D_Sdef));
+
+ else
+ goto Skip_UB;
+ end if;
+
+ if Is_Static_Expression (UBR)
+ and then Expr_Value (UBR) > UB
+ then
+ Error_Msg_Uint_1 := UB;
+ Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef);
+ end if;
+
+ <<Skip_UB>>
+ null;
+ end;
end if;
- Set_Etype (Id, Standard_Void_Type);
- Set_Convention (Id, Convention_Entry);
- Set_Accept_Address (Id, New_Elmt_List);
+ -- Decorate Def_Id
+
+ Set_Etype (Def_Id, Standard_Void_Type);
+ Set_Convention (Def_Id, Convention_Entry);
+ Set_Accept_Address (Def_Id, New_Elmt_List);
+
+ -- Process formals
if Present (Formals) then
- Set_Scope (Id, Current_Scope);
- New_Scope (Id);
+ Set_Scope (Def_Id, Current_Scope);
+ Push_Scope (Def_Id);
Process_Formals (Formals, N);
- Create_Extra_Formals (Id);
+ Create_Extra_Formals (Def_Id);
End_Scope;
end if;
- if Ekind (Id) = E_Entry then
- New_Overloaded_Entity (Id);
+ if Ekind (Def_Id) = E_Entry then
+ New_Overloaded_Entity (Def_Id);
+ end if;
+
+ Generate_Reference_To_Formals (Def_Id);
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Def_Id);
end if;
end Analyze_Entry_Declaration;
-- Analyze_Entry_Index_Specification --
---------------------------------------
- -- The defining_Identifier of the entry index specification is local
- -- to the entry body, but must be available in the entry barrier,
- -- which is evaluated outside of the entry body. The index is eventually
- -- renamed as a run-time object, so is visibility is strictly a front-end
- -- concern. In order to make it available to the barrier, we create
- -- an additional scope, as for a loop, whose only declaration is the
- -- index name. This loop is not attached to the tree and does not appear
- -- as an entity local to the protected type, so its existence need only
- -- be knwown to routines that process entry families.
+ -- The Defining_Identifier of the entry index specification is local to the
+ -- entry body, but it must be available in the entry barrier which is
+ -- evaluated outside of the entry body. The index is eventually renamed as
+ -- a run-time object, so is visibility is strictly a front-end concern. In
+ -- order to make it available to the barrier, we create an additional
+ -- scope, as for a loop, whose only declaration is the index name. This
+ -- loop is not attached to the tree and does not appear as an entity local
+ -- to the protected type, so its existence need only be known to routines
+ -- that process entry families.
procedure Analyze_Entry_Index_Specification (N : Node_Id) is
Iden : constant Node_Id := Defining_Identifier (N);
Def : constant Node_Id := Discrete_Subtype_Definition (N);
- Loop_Id : constant Entity_Id :=
- Make_Defining_Identifier (Sloc (N),
- Chars => New_Internal_Name ('L'));
+ Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L');
begin
Tasking_Used := True;
Set_Ekind (Loop_Id, E_Loop);
Set_Scope (Loop_Id, Current_Scope);
- New_Scope (Loop_Id);
+ Push_Scope (Loop_Id);
Enter_Name (Iden);
Set_Ekind (Iden, E_Entry_Index_Parameter);
Set_Etype (Iden, Etype (Def));
----------------------------
procedure Analyze_Protected_Body (N : Node_Id) is
- Body_Id : constant Entity_Id := Defining_Identifier (N);
- Last_E : Entity_Id;
+ Body_Id : constant Entity_Id := Defining_Identifier (N);
+ Last_E : Entity_Id;
Spec_Id : Entity_Id;
-- This is initially the entity of the protected object or protected
Ref_Id : Entity_Id;
-- This is the entity of the protected object or protected type
- -- involved, and is the entity used for cross-reference purposes
- -- (it differs from Spec_Id in the case of a single protected
- -- object, since Spec_Id is set to the protected type in this case).
+ -- involved, and is the entity used for cross-reference purposes (it
+ -- differs from Spec_Id in the case of a single protected object, since
+ -- Spec_Id is set to the protected type in this case).
begin
Tasking_Used := True;
Spec_Id := Etype (Spec_Id);
end if;
- New_Scope (Spec_Id);
+ Push_Scope (Spec_Id);
Set_Corresponding_Spec (N, Spec_Id);
Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
Set_Has_Completion (Spec_Id);
Install_Declarations (Spec_Id);
- Exp_Ch9.Expand_Protected_Body_Declarations (N, Spec_Id);
+ Expand_Protected_Body_Declarations (N, Spec_Id);
Last_E := Last_Entity (Spec_Id);
Analyze_Declarations (Declarations (N));
- -- For visibility purposes, all entities in the body are private.
- -- Set First_Private_Entity accordingly, if there was no private
- -- part in the protected declaration.
+ -- For visibility purposes, all entities in the body are private. Set
+ -- First_Private_Entity accordingly, if there was no private part in the
+ -- protected declaration.
if No (First_Private_Entity (Spec_Id)) then
if Present (Last_E) then
E : Entity_Id;
L : Entity_Id;
+ procedure Undelay_Itypes (T : Entity_Id);
+ -- Itypes created for the private components of a protected type
+ -- do not receive freeze nodes, because there is no scope in which
+ -- they can be elaborated, and they can depend on discriminants of
+ -- the enclosed protected type. Given that the components can be
+ -- composite types with inner components, we traverse recursively
+ -- the private components of the protected type, and indicate that
+ -- all itypes within are frozen. This ensures that no freeze nodes
+ -- will be generated for them.
+ --
+ -- On the other hand, components of the corresponding record are
+ -- frozen (or receive itype references) as for other records.
+
+ --------------------
+ -- Undelay_Itypes --
+ --------------------
+
+ procedure Undelay_Itypes (T : Entity_Id) is
+ Comp : Entity_Id;
+
+ begin
+ if Is_Protected_Type (T) then
+ Comp := First_Private_Entity (T);
+ elsif Is_Record_Type (T) then
+ Comp := First_Entity (T);
+ else
+ return;
+ end if;
+
+ while Present (Comp) loop
+ if Is_Type (Comp)
+ and then Is_Itype (Comp)
+ then
+ Set_Has_Delayed_Freeze (Comp, False);
+ Set_Is_Frozen (Comp);
+
+ if Is_Record_Type (Comp)
+ or else Is_Protected_Type (Comp)
+ then
+ Undelay_Itypes (Comp);
+ end if;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+ end Undelay_Itypes;
+
+ -- Start of processing for Analyze_Protected_Definition
+
begin
Tasking_Used := True;
+ Check_SPARK_Restriction ("protected definition is not allowed", N);
Analyze_Declarations (Visible_Declarations (N));
if Present (Private_Declarations (N))
if Present (L) then
Set_First_Private_Entity (Current_Scope, Next_Entity (L));
-
else
Set_First_Private_Entity (Current_Scope,
First_Entity (Current_Scope));
end if;
E := First_Entity (Current_Scope);
-
while Present (E) loop
-
- if Ekind (E) = E_Function
- or else Ekind (E) = E_Procedure
- then
+ if Ekind_In (E, E_Function, E_Procedure) then
Set_Convention (E, Convention_Protected);
elsif Is_Task_Type (Etype (E))
Next_Entity (E);
end loop;
+ Undelay_Itypes (Current_Scope);
+
Check_Max_Entries (N, Max_Protected_Entries);
Process_End_Label (N, 'e', Current_Scope);
- Check_Overriding_Indicator (N);
end Analyze_Protected_Definition;
- ----------------------------
- -- Analyze_Protected_Type --
- ----------------------------
+ ----------------------------------------
+ -- Analyze_Protected_Type_Declaration --
+ ----------------------------------------
- procedure Analyze_Protected_Type (N : Node_Id) is
- E : Entity_Id;
- T : Entity_Id;
- Def_Id : constant Entity_Id := Defining_Identifier (N);
- Iface : Node_Id;
- Iface_Def : Node_Id;
- Iface_Typ : Entity_Id;
+ procedure Analyze_Protected_Type_Declaration (N : Node_Id) is
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
+ E : Entity_Id;
+ T : Entity_Id;
begin
if No_Run_Time_Mode then
Error_Msg_CRT ("protected type", N);
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Def_Id);
+ end if;
+
return;
end if;
T := Find_Type_Name (N);
- if Ekind (T) = E_Incomplete_Type then
+ -- In the case of an incomplete type, use the full view, unless it's not
+ -- present (as can occur for an incomplete view from a limited with).
+
+ if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
T := Full_View (T);
Set_Completion_Referenced (T);
end if;
Set_Etype (T, T);
Set_Has_Delayed_Freeze (T, True);
Set_Stored_Constraint (T, No_Elist);
- New_Scope (T);
-
- -- Ada 2005 (AI-345)
-
- if Present (Interface_List (N)) then
- Iface := First (Interface_List (N));
-
- while Present (Iface) loop
- Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
- Iface_Def := Type_Definition (Parent (Iface_Typ));
-
- if not Is_Interface (Iface_Typ) then
- Error_Msg_NE ("(Ada 2005) & must be an interface",
- Iface, Iface_Typ);
-
- else
- -- Ada 2005 (AI-251): "The declaration of a specific
- -- descendant of an interface type freezes the interface
- -- type" RM 13.14
-
- Freeze_Before (N, Etype (Iface));
-
- -- Ada 2005 (AI-345): Protected types can only implement
- -- limited, synchronized or protected interfaces.
+ Push_Scope (T);
- if Limited_Present (Iface_Def)
- or else Synchronized_Present (Iface_Def)
- or else Protected_Present (Iface_Def)
- then
- null;
-
- elsif Task_Present (Iface_Def) then
- Error_Msg_N ("(Ada 2005) protected type cannot implement a "
- & "task interface", Iface);
-
- else
- Error_Msg_N ("(Ada 2005) protected type cannot implement a "
- & "non-limited interface", Iface);
- end if;
- end if;
-
- Next (Iface);
- end loop;
+ if Ada_Version >= Ada_2005 then
+ Check_Interfaces (N, T);
end if;
if Present (Discriminant_Specifications (N)) then
if Has_Discriminants (T) then
-- Install discriminants. Also, verify conformance of
- -- discriminants of previous and current view. ???
+ -- discriminants of previous and current view. ???
Install_Declarations (T);
else
Set_Is_Constrained (T, not Has_Discriminants (T));
+ -- If aspects are present, analyze them now. They can make references
+ -- to the discriminants of the type, but not to any components.
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Def_Id);
+ end if;
+
Analyze (Protected_Definition (N));
+ -- In the case where the protected type is declared at a nested level
+ -- and the No_Local_Protected_Objects restriction applies, issue a
+ -- warning that objects of the type will violate the restriction.
+
+ if Restriction_Check_Required (No_Local_Protected_Objects)
+ and then not Is_Library_Level_Entity (T)
+ and then Comes_From_Source (T)
+ then
+ Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects);
+
+ if Error_Msg_Sloc = No_Location then
+ Error_Msg_N
+ ("objects of this type will violate " &
+ "`No_Local_Protected_Objects`?", N);
+ else
+ Error_Msg_N
+ ("objects of this type will violate " &
+ "`No_Local_Protected_Objects`?#", N);
+ end if;
+ end if;
+
-- Protected types with entries are controlled (because of the
-- Protection component if nothing else), same for any protected type
-- with interrupt handlers. Note that we need to analyze the protected
Set_Has_Controlled_Component (T, True);
end if;
- -- The Ekind of components is E_Void during analysis to detect
- -- illegal uses. Now it can be set correctly.
+ -- The Ekind of components is E_Void during analysis to detect illegal
+ -- uses. Now it can be set correctly.
E := First_Entity (Current_Scope);
-
while Present (E) loop
if Ekind (E) = E_Void then
Set_Ekind (E, E_Component);
End_Scope;
+ -- Case of a completion of a private declaration
+
if T /= Def_Id
and then Is_Private_Type (Def_Id)
- and then Has_Discriminants (Def_Id)
- and then Expander_Active
then
- Exp_Ch9.Expand_N_Protected_Type_Declaration (N);
- Process_Full_View (N, T, Def_Id);
+ -- Deal with preelaborable initialization. Note that this processing
+ -- is done by Process_Full_View, but as can be seen below, in this
+ -- case the call to Process_Full_View is skipped if any serious
+ -- errors have occurred, and we don't want to lose this check.
+
+ if Known_To_Have_Preelab_Init (Def_Id) then
+ Set_Must_Have_Preelab_Init (T);
+ end if;
+
+ -- Create corresponding record now, because some private dependents
+ -- may be subtypes of the partial view.
+
+ -- Skip if errors are present, to prevent cascaded messages
+
+ if Serious_Errors_Detected = 0
+
+ -- Also skip if expander is not active
+
+ and then Full_Expander_Active
+ then
+ Expand_N_Protected_Type_Declaration (N);
+ Process_Full_View (N, T, Def_Id);
+ end if;
end if;
- end Analyze_Protected_Type;
+ end Analyze_Protected_Type_Declaration;
---------------------
-- Analyze_Requeue --
---------------------
procedure Analyze_Requeue (N : Node_Id) is
- Count : Natural := 0;
- Entry_Name : Node_Id := Name (N);
- Entry_Id : Entity_Id;
- I : Interp_Index;
- It : Interp;
- Enclosing : Entity_Id;
- Target_Obj : Node_Id := Empty;
- Req_Scope : Entity_Id;
- Outer_Ent : Entity_Id;
+ Count : Natural := 0;
+ Entry_Name : Node_Id := Name (N);
+ Entry_Id : Entity_Id;
+ I : Interp_Index;
+ Is_Disp_Req : Boolean;
+ It : Interp;
+ Enclosing : Entity_Id;
+ Target_Obj : Node_Id := Empty;
+ Req_Scope : Entity_Id;
+ Outer_Ent : Entity_Id;
begin
+ Tasking_Used := True;
+ Check_SPARK_Restriction ("requeue statement is not allowed", N);
Check_Restriction (No_Requeue_Statements, N);
Check_Unreachable_Code (N);
- Tasking_Used := True;
Enclosing := Empty;
for J in reverse 0 .. Scope_Stack.Last loop
Enclosing := Scope_Stack.Table (J).Entity;
exit when Is_Entry (Enclosing);
- if Ekind (Enclosing) /= E_Block
- and then Ekind (Enclosing) /= E_Loop
- then
+ if not Ekind_In (Enclosing, E_Block, E_Loop) then
Error_Msg_N ("requeue must appear within accept or entry body", N);
return;
end if;
Entry_Name := Selector_Name (Entry_Name);
end if;
- -- If an explicit target object is given then we have to check
- -- the restrictions of 9.5.4(6).
+ -- If an explicit target object is given then we have to check the
+ -- restrictions of 9.5.4(6).
if Present (Target_Obj) then
pragma Assert (Present (Outer_Ent));
- -- Check that the accessibility level of the target object
- -- is not greater or equal to the outermost enclosing accept
- -- statement (or entry body) unless it is a parameter of the
- -- innermost enclosing accept statement (or entry body).
+ -- Check that the accessibility level of the target object is not
+ -- greater or equal to the outermost enclosing accept statement (or
+ -- entry body) unless it is a parameter of the innermost enclosing
+ -- accept statement (or entry body).
if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
and then
-- Overloaded case, find right interpretation
if Is_Overloaded (Entry_Name) then
- Get_First_Interp (Entry_Name, I, It);
Entry_Id := Empty;
+ -- Loop over candidate interpretations and filter out any that are
+ -- not parameterless, are not type conformant, are not entries, or
+ -- do not come from source.
+
+ Get_First_Interp (Entry_Name, I, It);
while Present (It.Nam) loop
- if No (First_Formal (It.Nam))
- or else Subtype_Conformant (Enclosing, It.Nam)
- then
+ -- Note: we test type conformance here, not subtype conformance.
+ -- Subtype conformance will be tested later on, but it is better
+ -- for error output in some cases not to do that here.
+
+ if (No (First_Formal (It.Nam))
+ or else (Type_Conformant (Enclosing, It.Nam)))
+ and then Ekind (It.Nam) = E_Entry
+ then
-- Ada 2005 (AI-345): Since protected and task types have
-- primitive entry wrappers, we only consider source entries.
-- Non-overloaded cases
- -- For the case of a reference to an element of an entry family,
- -- the Entry_Name is an indexed component.
+ -- For the case of a reference to an element of an entry family, the
+ -- Entry_Name is an indexed component.
elsif Nkind (Entry_Name) = N_Indexed_Component then
end if;
-- If we had a requeue of the form REQUEUE A (B), then the parser
- -- accepted it (because it could have been a requeue on an entry
- -- index. If A turns out not to be an entry family, then the analysis
- -- of A (B) turned it into a function call.
+ -- accepted it (because it could have been a requeue on an entry index.
+ -- If A turns out not to be an entry family, then the analysis of A (B)
+ -- turned it into a function call.
elsif Nkind (Entry_Name) = N_Function_Call then
Error_Msg_N
Entry_Id := Entity (Entry_Name);
end if;
+ -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The
+ -- target type must be a concurrent interface class-wide type and the
+ -- target must be a procedure, flagged by pragma Implemented.
+
+ Is_Disp_Req :=
+ Ada_Version >= Ada_2012
+ and then Present (Target_Obj)
+ and then Is_Class_Wide_Type (Etype (Target_Obj))
+ and then Is_Concurrent_Interface (Etype (Target_Obj))
+ and then Ekind (Entry_Id) = E_Procedure
+ and then Has_Rep_Pragma (Entry_Id, Name_Implemented);
+
-- Resolve entry, and check that it is subtype conformant with the
-- enclosing construct if this construct has formals (RM 9.5.4(5)).
+ -- Ada 2005 (AI05-0030): Do not emit an error for this specific case.
- if not Is_Entry (Entry_Id) then
+ if not Is_Entry (Entry_Id)
+ and then not Is_Disp_Req
+ then
Error_Msg_N ("expect entry name in requeue statement", Name (N));
+
elsif Ekind (Entry_Id) = E_Entry_Family
and then Nkind (Entry_Name) /= N_Indexed_Component
then
Generate_Reference (Entry_Id, Entry_Name);
if Present (First_Formal (Entry_Id)) then
- Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
+ if VM_Target = JVM_Target then
+ Error_Msg_N
+ ("arguments unsupported in requeue statement",
+ First_Formal (Entry_Id));
+ return;
+ end if;
+
+ -- Ada 2012 (AI05-0030): Perform type conformance after skipping
+ -- the first parameter of Entry_Id since it is the interface
+ -- controlling formal.
+
+ if Ada_Version >= Ada_2012
+ and then Is_Disp_Req
+ then
+ declare
+ Enclosing_Formal : Entity_Id;
+ Target_Formal : Entity_Id;
+
+ begin
+ Enclosing_Formal := First_Formal (Enclosing);
+ Target_Formal := Next_Formal (First_Formal (Entry_Id));
+ while Present (Enclosing_Formal)
+ and then Present (Target_Formal)
+ loop
+ if not Conforming_Types
+ (T1 => Etype (Enclosing_Formal),
+ T2 => Etype (Target_Formal),
+ Ctype => Subtype_Conformant)
+ then
+ Error_Msg_Node_2 := Target_Formal;
+ Error_Msg_NE
+ ("formal & is not subtype conformant with &" &
+ "in dispatching requeue", N, Enclosing_Formal);
+ end if;
+
+ Next_Formal (Enclosing_Formal);
+ Next_Formal (Target_Formal);
+ end loop;
+ end;
+ else
+ Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
+ end if;
-- Processing for parameters accessed by the requeue
declare
- Ent : Entity_Id := First_Formal (Enclosing);
+ Ent : Entity_Id;
begin
+ Ent := First_Formal (Enclosing);
while Present (Ent) loop
- -- For OUT or IN OUT parameter, the effect of the requeue
- -- is to assign the parameter a value on exit from the
- -- requeued body, so we can set it as source assigned.
- -- We also clear the Is_True_Constant indication. We do
- -- not need to clear Current_Value, since the effect of
- -- the requeue is to perform an unconditional goto so
- -- that any further references will not occur anyway.
-
- if Ekind (Ent) = E_Out_Parameter
- or else
- Ekind (Ent) = E_In_Out_Parameter
- then
+ -- For OUT or IN OUT parameter, the effect of the requeue is
+ -- to assign the parameter a value on exit from the requeued
+ -- body, so we can set it as source assigned. We also clear
+ -- the Is_True_Constant indication. We do not need to clear
+ -- Current_Value, since the effect of the requeue is to
+ -- perform an unconditional goto so that any further
+ -- references will not occur anyway.
+
+ if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then
Set_Never_Set_In_Source (Ent, False);
Set_Is_True_Constant (Ent, False);
end if;
-- For all parameters, the requeue acts as a reference,
- -- since the value of the parameter is passed to the
- -- new entry, so we want to suppress unreferenced warnings.
+ -- since the value of the parameter is passed to the new
+ -- entry, so we want to suppress unreferenced warnings.
Set_Referenced (Ent);
Next_Formal (Ent);
Alt_Count : Uint := Uint_0;
begin
- Check_Restriction (No_Select_Statements, N);
Tasking_Used := True;
+ Check_SPARK_Restriction ("select statement is not allowed", N);
+ Check_Restriction (No_Select_Statements, N);
+
+ -- Loop to analyze alternatives
Alt := First (Alts);
while Present (Alt) loop
end if;
end Analyze_Selective_Accept;
- ------------------------------
- -- Analyze_Single_Protected --
- ------------------------------
+ ------------------------------------------
+ -- Analyze_Single_Protected_Declaration --
+ ------------------------------------------
- procedure Analyze_Single_Protected (N : Node_Id) is
+ procedure Analyze_Single_Protected_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Id : constant Node_Id := Defining_Identifier (N);
T : Entity_Id;
T_Decl : Node_Id;
O_Decl : Node_Id;
- O_Name : constant Entity_Id := New_Copy (Id);
+ O_Name : constant Entity_Id := Id;
begin
Generate_Definition (Id);
Tasking_Used := True;
- -- The node is rewritten as a protected type declaration,
- -- in exact analogy with what is done with single tasks.
+ -- The node is rewritten as a protected type declaration, in exact
+ -- analogy with what is done with single tasks.
T :=
Make_Defining_Identifier (Sloc (Id),
Protected_Definition => Relocate_Node (Protected_Definition (N)),
Interface_List => Interface_List (N));
- -- Ada 2005 (AI-399): Mark the object as aliased. Required to use
- -- the attribute 'access
-
O_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => O_Name,
- Aliased_Present => Ada_Version >= Ada_05,
Object_Definition => Make_Identifier (Loc, Chars (T)));
Rewrite (N, T_Decl);
Insert_After (N, O_Decl);
Mark_Rewrite_Insertion (O_Decl);
- -- Enter names of type and object before analysis, because the name
- -- of the object may be used in its own body.
+ -- Enter names of type and object before analysis, because the name of
+ -- the object may be used in its own body.
Enter_Name (T);
Set_Ekind (T, E_Protected_Type);
Set_Ekind (O_Name, E_Variable);
Set_Etype (O_Name, T);
- -- Instead of calling Analyze on the new node, call directly
- -- the proper analysis procedure. Otherwise the node would be
- -- expanded twice, with disastrous result.
+ -- Instead of calling Analyze on the new node, call the proper analysis
+ -- procedure directly. Otherwise the node would be expanded twice, with
+ -- disastrous result.
- Analyze_Protected_Type (N);
- end Analyze_Single_Protected;
+ Analyze_Protected_Type_Declaration (N);
- -------------------------
- -- Analyze_Single_Task --
- -------------------------
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
+ end Analyze_Single_Protected_Declaration;
+
+ -------------------------------------
+ -- Analyze_Single_Task_Declaration --
+ -------------------------------------
- procedure Analyze_Single_Task (N : Node_Id) is
+ procedure Analyze_Single_Task_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Id : constant Node_Id := Defining_Identifier (N);
T : Entity_Id;
T_Decl : Node_Id;
O_Decl : Node_Id;
- O_Name : constant Entity_Id := New_Copy (Id);
+ O_Name : constant Entity_Id := Id;
begin
Generate_Definition (Id);
Tasking_Used := True;
- -- The node is rewritten as a task type declaration, followed
- -- by an object declaration of that anonymous task type.
+ -- The node is rewritten as a task type declaration, followed by an
+ -- object declaration of that anonymous task type.
T :=
Make_Defining_Identifier (Sloc (Id),
Task_Definition => Relocate_Node (Task_Definition (N)),
Interface_List => Interface_List (N));
- -- Ada 2005 (AI-399): Mark the object as aliased. Required to use
- -- the attribute 'access
+ -- We use the original defining identifier of the single task in the
+ -- generated object declaration, so that debugging information can
+ -- be attached to it when compiling with -gnatD. The parent of the
+ -- entity is the new object declaration. The single_task_declaration
+ -- is not used further in semantics or code generation, but is scanned
+ -- when generating debug information, and therefore needs the updated
+ -- Sloc information for the entity (see Sprint). Aspect specifications
+ -- are moved from the single task node to the object declaration node.
O_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => O_Name,
- Aliased_Present => Ada_Version >= Ada_05,
Object_Definition => Make_Identifier (Loc, Chars (T)));
Rewrite (N, T_Decl);
Insert_After (N, O_Decl);
Mark_Rewrite_Insertion (O_Decl);
- -- Enter names of type and object before analysis, because the name
- -- of the object may be used in its own body.
+ -- Enter names of type and object before analysis, because the name of
+ -- the object may be used in its own body.
Enter_Name (T);
Set_Ekind (T, E_Task_Type);
Set_Ekind (O_Name, E_Variable);
Set_Etype (O_Name, T);
- -- Instead of calling Analyze on the new node, call directly
- -- the proper analysis procedure. Otherwise the node would be
- -- expanded twice, with disastrous result.
+ -- Instead of calling Analyze on the new node, call the proper analysis
+ -- procedure directly. Otherwise the node would be expanded twice, with
+ -- disastrous result.
- Analyze_Task_Type (N);
- end Analyze_Single_Task;
+ Analyze_Task_Type_Declaration (N);
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
+ end Analyze_Single_Task_Declaration;
-----------------------
-- Analyze_Task_Body --
procedure Analyze_Task_Body (N : Node_Id) is
Body_Id : constant Entity_Id := Defining_Identifier (N);
+ Decls : constant List_Id := Declarations (N);
+ HSS : constant Node_Id := Handled_Statement_Sequence (N);
Last_E : Entity_Id;
Spec_Id : Entity_Id;
- -- This is initially the entity of the task or task type involved,
- -- but is replaced by the task type always in the case of a single
- -- task declaration, since this is the proper scope to be used.
+ -- This is initially the entity of the task or task type involved, but
+ -- is replaced by the task type always in the case of a single task
+ -- declaration, since this is the proper scope to be used.
Ref_Id : Entity_Id;
- -- This is the entity of the task or task type, and is the entity
- -- used for cross-reference purposes (it differs from Spec_Id in
- -- the case of a single task, since Spec_Id is set to the task type)
+ -- This is the entity of the task or task type, and is the entity used
+ -- for cross-reference purposes (it differs from Spec_Id in the case of
+ -- a single task, since Spec_Id is set to the task type)
begin
Tasking_Used := True;
Spec_Id := Etype (Spec_Id);
end if;
- New_Scope (Spec_Id);
+ Push_Scope (Spec_Id);
Set_Corresponding_Spec (N, Spec_Id);
Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
Set_Has_Completion (Spec_Id);
Install_Declarations (Spec_Id);
Last_E := Last_Entity (Spec_Id);
- Analyze_Declarations (Declarations (N));
+ Analyze_Declarations (Decls);
+ Inspect_Deferred_Constant_Completion (Decls);
- -- For visibility purposes, all entities in the body are private.
- -- Set First_Private_Entity accordingly, if there was no private
- -- part in the protected declaration.
+ -- For visibility purposes, all entities in the body are private. Set
+ -- First_Private_Entity accordingly, if there was no private part in the
+ -- protected declaration.
if No (First_Private_Entity (Spec_Id)) then
if Present (Last_E) then
end if;
end if;
- Analyze (Handled_Statement_Sequence (N));
+ -- Mark all handlers as not suitable for local raise optimization,
+ -- since this optimization causes difficulties in a task context.
+
+ if Present (Exception_Handlers (HSS)) then
+ declare
+ Handlr : Node_Id;
+ begin
+ Handlr := First (Exception_Handlers (HSS));
+ while Present (Handlr) loop
+ Set_Local_Raise_Not_OK (Handlr);
+ Next (Handlr);
+ end loop;
+ end;
+ end if;
+
+ -- Now go ahead and complete analysis of the task body
+
+ Analyze (HSS);
Check_Completion (Body_Id);
Check_References (Body_Id);
Check_References (Spec_Id);
begin
Ent := First_Entity (Spec_Id);
-
while Present (Ent) loop
if Is_Entry (Ent)
and then not Entry_Accepted (Ent)
end loop;
end;
- Process_End_Label (Handled_Statement_Sequence (N), 't', Ref_Id);
+ Process_End_Label (HSS, 't', Ref_Id);
End_Scope;
end Analyze_Task_Body;
begin
Tasking_Used := True;
+ Check_SPARK_Restriction ("task definition is not allowed", N);
if Present (Visible_Declarations (N)) then
Analyze_Declarations (Visible_Declarations (N));
Check_Max_Entries (N, Max_Task_Entries);
Process_End_Label (N, 'e', Current_Scope);
- Check_Overriding_Indicator (N);
end Analyze_Task_Definition;
- -----------------------
- -- Analyze_Task_Type --
- -----------------------
+ -----------------------------------
+ -- Analyze_Task_Type_Declaration --
+ -----------------------------------
- procedure Analyze_Task_Type (N : Node_Id) is
- T : Entity_Id;
- Def_Id : constant Entity_Id := Defining_Identifier (N);
- Iface : Node_Id;
- Iface_Def : Node_Id;
- Iface_Typ : Entity_Id;
+ procedure Analyze_Task_Type_Declaration (N : Node_Id) is
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
+ T : Entity_Id;
begin
Check_Restriction (No_Tasking, N);
T := Find_Type_Name (N);
Generate_Definition (T);
+ -- In the case of an incomplete type, use the full view, unless it's not
+ -- present (as can occur for an incomplete view from a limited with).
+ -- Initialize the Corresponding_Record_Type (which overlays the Private
+ -- Dependents field of the incomplete view).
+
if Ekind (T) = E_Incomplete_Type then
- T := Full_View (T);
- Set_Completion_Referenced (T);
+ if Present (Full_View (T)) then
+ T := Full_View (T);
+ Set_Completion_Referenced (T);
+
+ else
+ Set_Ekind (T, E_Task_Type);
+ Set_Corresponding_Record_Type (T, Empty);
+ end if;
end if;
Set_Ekind (T, E_Task_Type);
Set_Etype (T, T);
Set_Has_Delayed_Freeze (T, True);
Set_Stored_Constraint (T, No_Elist);
- New_Scope (T);
-
- -- Ada 2005 (AI-345)
-
- if Present (Interface_List (N)) then
- Iface := First (Interface_List (N));
- while Present (Iface) loop
- Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
- Iface_Def := Type_Definition (Parent (Iface_Typ));
-
- if not Is_Interface (Iface_Typ) then
- Error_Msg_NE ("(Ada 2005) & must be an interface",
- Iface, Iface_Typ);
+ Push_Scope (T);
- else
- -- Ada 2005 (AI-251): The declaration of a specific descendant
- -- of an interface type freezes the interface type (RM 13.14).
-
- Freeze_Before (N, Etype (Iface));
-
- -- Ada 2005 (AI-345): Task types can only implement limited,
- -- synchronized or task interfaces.
-
- if Limited_Present (Iface_Def)
- or else Synchronized_Present (Iface_Def)
- or else Task_Present (Iface_Def)
- then
- null;
-
- elsif Protected_Present (Iface_Def) then
- Error_Msg_N ("(Ada 2005) task type cannot implement a " &
- "protected interface", Iface);
-
- else
- Error_Msg_N ("(Ada 2005) task type cannot implement a " &
- "non-limited interface", Iface);
- end if;
- end if;
-
- Next (Iface);
- end loop;
+ if Ada_Version >= Ada_2005 then
+ Check_Interfaces (N, T);
end if;
if Present (Discriminant_Specifications (N)) then
if Has_Discriminants (T) then
-- Install discriminants. Also, verify conformance of
- -- discriminants of previous and current view. ???
+ -- discriminants of previous and current view. ???
Install_Declarations (T);
else
Set_Is_Constrained (T, not Has_Discriminants (T));
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Def_Id);
+ end if;
+
if Present (Task_Definition (N)) then
Analyze_Task_Definition (Task_Definition (N));
end if;
- if not Is_Library_Level_Entity (T) then
- Check_Restriction (No_Task_Hierarchy, N);
+ -- In the case where the task type is declared at a nested level and the
+ -- No_Task_Hierarchy restriction applies, issue a warning that objects
+ -- of the type will violate the restriction.
+
+ if Restriction_Check_Required (No_Task_Hierarchy)
+ and then not Is_Library_Level_Entity (T)
+ and then Comes_From_Source (T)
+ then
+ Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy);
+
+ if Error_Msg_Sloc = No_Location then
+ Error_Msg_N
+ ("objects of this type will violate `No_Task_Hierarchy`?", N);
+ else
+ Error_Msg_N
+ ("objects of this type will violate `No_Task_Hierarchy`?#", N);
+ end if;
end if;
End_Scope;
+ -- Case of a completion of a private declaration
+
if T /= Def_Id
and then Is_Private_Type (Def_Id)
- and then Has_Discriminants (Def_Id)
- and then Expander_Active
then
- Exp_Ch9.Expand_N_Task_Type_Declaration (N);
- Process_Full_View (N, T, Def_Id);
+ -- Deal with preelaborable initialization. Note that this processing
+ -- is done by Process_Full_View, but as can be seen below, in this
+ -- case the call to Process_Full_View is skipped if any serious
+ -- errors have occurred, and we don't want to lose this check.
+
+ if Known_To_Have_Preelab_Init (Def_Id) then
+ Set_Must_Have_Preelab_Init (T);
+ end if;
+
+ -- Create corresponding record now, because some private dependents
+ -- may be subtypes of the partial view.
+
+ -- Skip if errors are present, to prevent cascaded messages
+
+ if Serious_Errors_Detected = 0
+
+ -- Also skip if expander is not active
+
+ and then Full_Expander_Active
+ then
+ Expand_N_Task_Type_Declaration (N);
+ Process_Full_View (N, T, Def_Id);
+ end if;
end if;
- end Analyze_Task_Type;
+ end Analyze_Task_Type_Declaration;
-----------------------------------
-- Analyze_Terminate_Alternative --
------------------------------
procedure Analyze_Timed_Entry_Call (N : Node_Id) is
+ Trigger : constant Node_Id :=
+ Entry_Call_Statement (Entry_Call_Alternative (N));
+ Is_Disp_Select : Boolean := False;
+
begin
- Check_Restriction (No_Select_Statements, N);
Tasking_Used := True;
- Analyze (Entry_Call_Alternative (N));
- Analyze (Delay_Alternative (N));
+ Check_SPARK_Restriction ("select statement is not allowed", N);
+ Check_Restriction (No_Select_Statements, N);
+
+ -- Ada 2005 (AI-345): The trigger may be a dispatching call
+
+ if Ada_Version >= Ada_2005 then
+ Analyze (Trigger);
+ Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
+ end if;
+
+ -- Postpone the analysis of the statements till expansion. Analyze only
+ -- if the expander is disabled in order to catch any semantic errors.
+
+ if Is_Disp_Select then
+ if not Expander_Active then
+ Analyze (Entry_Call_Alternative (N));
+ Analyze (Delay_Alternative (N));
+ end if;
+
+ -- Regular select analysis
+
+ else
+ Analyze (Entry_Call_Alternative (N));
+ Analyze (Delay_Alternative (N));
+ end if;
end Analyze_Timed_Entry_Call;
------------------------------------
end if;
Analyze (Trigger);
+
if Comes_From_Source (Trigger)
- and then Nkind (Trigger) /= N_Delay_Until_Statement
- and then Nkind (Trigger) /= N_Delay_Relative_Statement
+ and then Nkind (Trigger) not in N_Delay_Statement
and then Nkind (Trigger) /= N_Entry_Call_Statement
then
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_N
("triggering statement must be delay or entry call", Trigger);
- -- Ada 2005 (AI-345): If a procedure_call_statement is used
- -- for a procedure_or_entry_call, the procedure_name or pro-
- -- cedure_prefix of the procedure_call_statement shall denote
- -- an entry renamed by a procedure, or (a view of) a primitive
- -- subprogram of a limited interface whose first parameter is
- -- a controlling parameter.
+ -- Ada 2005 (AI-345): If a procedure_call_statement is used for a
+ -- procedure_or_entry_call, the procedure_name or procedure_prefix
+ -- of the procedure_call_statement shall denote an entry renamed by a
+ -- procedure, or (a view of) a primitive subprogram of a limited
+ -- interface whose first parameter is a controlling parameter.
elsif Nkind (Trigger) = N_Procedure_Call_Statement
and then not Is_Renamed_Entry (Entity (Name (Trigger)))
-- Entry family with non-static bounds
else
- -- If restriction is set, then this is an error
-
- if Restrictions.Set (R) then
- Error_Msg_N
- ("static subtype required by Restriction pragma",
- DSD);
+ -- Record an unknown count restriction, and if the
+ -- restriction is active, post a message or warning.
- -- Otherwise we record an unknown count restriction
-
- else
- Check_Restriction (R, D);
- end if;
+ Check_Restriction (R, D);
end if;
end;
end if;
end if;
end Check_Max_Entries;
- --------------------------------
- -- Check_Overriding_Indicator --
- --------------------------------
+ ----------------------
+ -- Check_Interfaces --
+ ----------------------
- procedure Check_Overriding_Indicator (Def : Node_Id) is
- Aliased_Hom : Entity_Id;
- Decl : Node_Id;
- Def_Id : Entity_Id;
- Hom : Entity_Id;
- Ifaces : constant List_Id := Interface_List (Parent (Def));
- Overrides : Boolean;
- Spec : Node_Id;
- Vis_Decls : constant List_Id := Visible_Declarations (Def);
-
- function Matches_Prefixed_View_Profile
- (Ifaces : List_Id;
- Entry_Params : List_Id;
- Proc_Params : List_Id) return Boolean;
- -- Ada 2005 (AI-397): Determine if an entry parameter profile matches
- -- the prefixed view profile of an abstract procedure. Also determine
- -- whether the abstract procedure belongs to an implemented interface.
-
- -----------------------------------
- -- Matches_Prefixed_View_Profile --
- -----------------------------------
-
- function Matches_Prefixed_View_Profile
- (Ifaces : List_Id;
- Entry_Params : List_Id;
- Proc_Params : List_Id) return Boolean
- is
- Entry_Param : Node_Id;
- Proc_Param : Node_Id;
- Proc_Param_Typ : Entity_Id;
-
- function Includes_Interface
- (Iface : Entity_Id;
- Ifaces : List_Id) return Boolean;
- -- Determine if an interface is contained in a list of interfaces
-
- ------------------------
- -- Includes_Interface --
- ------------------------
-
- function Includes_Interface
- (Iface : Entity_Id;
- Ifaces : List_Id) return Boolean
- is
- Ent : Entity_Id;
+ procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is
+ Iface : Node_Id;
+ Iface_Typ : Entity_Id;
- begin
- Ent := First (Ifaces);
+ begin
+ pragma Assert
+ (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration));
- while Present (Ent) loop
- if Etype (Ent) = Iface then
- return True;
- end if;
+ if Present (Interface_List (N)) then
+ Set_Is_Tagged_Type (T);
- Next (Ent);
- end loop;
+ Iface := First (Interface_List (N));
+ while Present (Iface) loop
+ Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
+
+ if not Is_Interface (Iface_Typ) then
+ Error_Msg_NE
+ ("(Ada 2005) & must be an interface", Iface, Iface_Typ);
- return False;
- end Includes_Interface;
+ else
+ -- Ada 2005 (AI-251): "The declaration of a specific descendant
+ -- of an interface type freezes the interface type" RM 13.14.
- -- Start of processing for Matches_Prefixed_View_Profile
+ Freeze_Before (N, Etype (Iface));
- begin
- Proc_Param := First (Proc_Params);
- Proc_Param_Typ := Etype (Parameter_Type (Proc_Param));
+ if Nkind (N) = N_Protected_Type_Declaration then
- -- The first parameter of the abstract procedure must be of an
- -- interface type. The task or protected type must also implement
- -- that interface.
+ -- Ada 2005 (AI-345): Protected types can only implement
+ -- limited, synchronized, or protected interfaces (note that
+ -- the predicate Is_Limited_Interface includes synchronized
+ -- and protected interfaces).
- if not Is_Interface (Proc_Param_Typ)
- or else not Includes_Interface (Proc_Param_Typ, Ifaces)
- then
- return False;
- end if;
+ if Is_Task_Interface (Iface_Typ) then
+ Error_Msg_N ("(Ada 2005) protected type cannot implement "
+ & "a task interface", Iface);
- Entry_Param := First (Entry_Params);
- Proc_Param := Next (Proc_Param);
- while Present (Entry_Param)
- and then Present (Proc_Param)
- loop
- -- The two parameters must be mode conformant and have the exact
- -- same types.
+ elsif not Is_Limited_Interface (Iface_Typ) then
+ Error_Msg_N ("(Ada 2005) protected type cannot implement "
+ & "a non-limited interface", Iface);
+ end if;
- if In_Present (Entry_Param) /= In_Present (Proc_Param)
- or else Out_Present (Entry_Param) /= Out_Present (Proc_Param)
- or else Etype (Parameter_Type (Entry_Param)) /=
- Etype (Parameter_Type (Proc_Param))
- then
- return False;
+ else pragma Assert (Nkind (N) = N_Task_Type_Declaration);
+
+ -- Ada 2005 (AI-345): Task types can only implement limited,
+ -- synchronized, or task interfaces (note that the predicate
+ -- Is_Limited_Interface includes synchronized and task
+ -- interfaces).
+
+ if Is_Protected_Interface (Iface_Typ) then
+ Error_Msg_N ("(Ada 2005) task type cannot implement a " &
+ "protected interface", Iface);
+
+ elsif not Is_Limited_Interface (Iface_Typ) then
+ Error_Msg_N ("(Ada 2005) task type cannot implement a " &
+ "non-limited interface", Iface);
+ end if;
+ end if;
end if;
- Next (Entry_Param);
- Next (Proc_Param);
+ Next (Iface);
end loop;
+ end if;
- -- One of the lists is longer than the other
+ if not Has_Private_Declaration (T) then
+ return;
+ end if;
- if Present (Entry_Param) or else Present (Proc_Param) then
- return False;
- end if;
+ -- Additional checks on full-types associated with private type
+ -- declarations. Search for the private type declaration.
- return True;
- end Matches_Prefixed_View_Profile;
+ declare
+ Full_T_Ifaces : Elist_Id;
+ Iface : Node_Id;
+ Priv_T : Entity_Id;
+ Priv_T_Ifaces : Elist_Id;
- -- Start of processing for Check_Overriding_Indicator
+ begin
+ Priv_T := First_Entity (Scope (T));
+ loop
+ pragma Assert (Present (Priv_T));
- begin
- if Present (Ifaces) then
- Decl := First (Vis_Decls);
- while Present (Decl) loop
+ if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then
+ exit when Full_View (Priv_T) = T;
+ end if;
- -- Consider entries with either "overriding" or "not overriding"
- -- indicator present.
+ Next_Entity (Priv_T);
+ end loop;
- if Nkind (Decl) = N_Entry_Declaration
- and then (Must_Override (Decl)
- or else
- Must_Not_Override (Decl))
- then
- Def_Id := Defining_Identifier (Decl);
+ -- In case of synchronized types covering interfaces the private type
+ -- declaration must be limited.
- Overrides := False;
+ if Present (Interface_List (N))
+ and then not Is_Limited_Type (Priv_T)
+ then
+ Error_Msg_Sloc := Sloc (Priv_T);
+ Error_Msg_N ("(Ada 2005) limited type declaration expected for " &
+ "private type#", T);
+ end if;
- Hom := Homonym (Def_Id);
- while Present (Hom) loop
+ -- RM 7.3 (7.1/2): If the full view has a partial view that is
+ -- tagged then check RM 7.3 subsidiary rules.
- -- The current entry may override a procedure from an
- -- implemented interface.
+ if Is_Tagged_Type (Priv_T)
+ and then not Error_Posted (N)
+ then
+ -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged
+ -- type if and only if the full type is a synchronized tagged type
- if Ekind (Hom) = E_Procedure
- and then (Is_Abstract (Hom)
- or else
- Null_Present (Parent (Hom)))
- then
- Aliased_Hom := Hom;
+ if Is_Synchronized_Tagged_Type (Priv_T)
+ and then not Is_Synchronized_Tagged_Type (T)
+ then
+ Error_Msg_N
+ ("(Ada 2005) full view must be a synchronized tagged " &
+ "type (RM 7.3 (7.2/2))", Priv_T);
- while Present (Alias (Aliased_Hom)) loop
- Aliased_Hom := Alias (Aliased_Hom);
- end loop;
+ elsif Is_Synchronized_Tagged_Type (T)
+ and then not Is_Synchronized_Tagged_Type (Priv_T)
+ then
+ Error_Msg_N
+ ("(Ada 2005) partial view must be a synchronized tagged " &
+ "type (RM 7.3 (7.2/2))", T);
+ end if;
- if Matches_Prefixed_View_Profile (Ifaces,
- Parameter_Specifications (Decl),
- Parameter_Specifications (Parent (Aliased_Hom)))
- then
- Overrides := True;
- exit;
- end if;
- end if;
+ -- RM 7.3 (7.3/2): The partial view shall be a descendant of an
+ -- interface type if and only if the full type is descendant of
+ -- the interface type.
- Hom := Homonym (Hom);
- end loop;
+ if Present (Interface_List (N))
+ or else (Is_Tagged_Type (Priv_T)
+ and then Has_Interfaces
+ (Priv_T, Use_Full_View => False))
+ then
+ if Is_Tagged_Type (Priv_T) then
+ Collect_Interfaces
+ (Priv_T, Priv_T_Ifaces, Use_Full_View => False);
+ end if;
- if Overrides then
- if Must_Not_Override (Decl) then
- Error_Msg_NE ("entry& is overriding", Def_Id, Def_Id);
- end if;
- else
- if Must_Override (Decl) then
- Error_Msg_NE ("entry& is not overriding", Def_Id, Def_Id);
- end if;
+ if Is_Tagged_Type (T) then
+ Collect_Interfaces (T, Full_T_Ifaces);
end if;
- -- Consider subprograms with either "overriding" or "not
- -- overriding" indicator present.
+ Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
- elsif Nkind (Decl) = N_Subprogram_Declaration
- and then (Must_Override (Specification (Decl))
- or else
- Must_Not_Override (Specification (Decl)))
- then
- Spec := Specification (Decl);
- Def_Id := Defining_Unit_Name (Spec);
-
- Overrides := False;
-
- Hom := Homonym (Def_Id);
- while Present (Hom) loop
-
- -- Function
-
- if Ekind (Def_Id) = E_Function
- and then Ekind (Hom) = E_Function
- and then Is_Abstract (Hom)
- and then Matches_Prefixed_View_Profile (Ifaces,
- Parameter_Specifications (Spec),
- Parameter_Specifications (Parent (Hom)))
- and then Etype (Result_Definition (Spec)) =
- Etype (Result_Definition (Parent (Hom)))
- then
- Overrides := True;
- exit;
-
- -- Procedure
-
- elsif Ekind (Def_Id) = E_Procedure
- and then Ekind (Hom) = E_Procedure
- and then (Is_Abstract (Hom)
- or else
- Null_Present (Parent (Hom)))
- and then Matches_Prefixed_View_Profile (Ifaces,
- Parameter_Specifications (Spec),
- Parameter_Specifications (Parent (Hom)))
- then
- Overrides := True;
- exit;
- end if;
+ if Present (Iface) then
+ Error_Msg_NE
+ ("interface & not implemented by full type " &
+ "(RM-2005 7.3 (7.3/2))", Priv_T, Iface);
+ end if;
- Hom := Homonym (Hom);
- end loop;
+ Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
- if Overrides then
- if Must_Not_Override (Spec) then
- Error_Msg_NE
- ("subprogram& is overriding", Def_Id, Def_Id);
- end if;
- else
- if Must_Override (Spec) then
- Error_Msg_NE
- ("subprogram& is not overriding", Def_Id, Def_Id);
- end if;
+ if Present (Iface) then
+ Error_Msg_NE
+ ("interface & not implemented by partial " &
+ "view (RM-2005 7.3 (7.3/2))", T, Iface);
end if;
end if;
+ end if;
+ end;
+ end Check_Interfaces;
- Next (Decl);
- end loop;
+ --------------------------------
+ -- Check_Triggering_Statement --
+ --------------------------------
- -- The protected or task type is not implementing an interface,
- -- we need to check for the presence of "overriding" entries or
- -- subprograms and flag them as erroneous.
+ procedure Check_Triggering_Statement
+ (Trigger : Node_Id;
+ Error_Node : Node_Id;
+ Is_Dispatching : out Boolean)
+ is
+ Param : Node_Id;
- else
- Decl := First (Vis_Decls);
+ begin
+ Is_Dispatching := False;
- while Present (Decl) loop
- if Nkind (Decl) = N_Entry_Declaration
- and then Must_Override (Decl)
- then
- Def_Id := Defining_Identifier (Decl);
- Error_Msg_NE ("entry& is not overriding", Def_Id, Def_Id);
+ -- It is not possible to have a dispatching trigger if we are not in
+ -- Ada 2005 mode.
- elsif Nkind (Decl) = N_Subprogram_Declaration
- and then Must_Override (Specification (Decl))
- then
- Def_Id := Defining_Identifier (Specification (Decl));
- Error_Msg_NE ("subprogram& is not overriding", Def_Id, Def_Id);
- end if;
+ if Ada_Version >= Ada_2005
+ and then Nkind (Trigger) = N_Procedure_Call_Statement
+ and then Present (Parameter_Associations (Trigger))
+ then
+ Param := First (Parameter_Associations (Trigger));
- Next (Decl);
- end loop;
+ if Is_Controlling_Actual (Param)
+ and then Is_Interface (Etype (Param))
+ then
+ if Is_Limited_Record (Etype (Param)) then
+ Is_Dispatching := True;
+ else
+ Error_Msg_N
+ ("dispatching operation of limited or synchronized " &
+ "interface required (RM 9.7.2(3))!", Error_Node);
+ end if;
+ end if;
end if;
- end Check_Overriding_Indicator;
+ end Check_Triggering_Statement;
--------------------------
-- Find_Concurrent_Spec --
procedure Install_Declarations (Spec : Entity_Id) is
E : Entity_Id;
Prev : Entity_Id;
-
begin
E := First_Entity (Spec);
-
while Present (E) loop
Prev := Current_Entity (E);
Set_Current_Entity (E);
OSDN Git Service
