-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, 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 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 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;
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 Is_Task_Type (Etype (T_Name))
- or else (Ada_Version >= Ada_05
+ 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_05 then
+ if Ada_Version >= Ada_2005 then
Error_Msg_N ("expect task name or task interface class-wide "
& "object for ABORT", T_Name);
else
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.
-
- -----------------------
- -- Actual_Index_Type --
- -----------------------
-
- 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
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
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);
- if Ada_Version >= Ada_05 then
+ if Ada_Version >= Ada_2005 then
Trigger := Triggering_Statement (Triggering_Alternative (N));
Analyze (Trigger);
Is_Disp_Select : Boolean := False;
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);
-- Ada 2005 (AI-345): The trigger may be a dispatching call
- if Ada_Version >= Ada_05 then
+ if Ada_Version >= Ada_2005 then
Analyze (Trigger);
Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
end if;
-- 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;
Typ := First_Subtype (Etype (Expr));
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);
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);
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;
Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
Push_Scope (Entry_Name);
- Exp_Ch9.Expand_Entry_Body_Declarations (N);
Install_Declarations (Entry_Name);
Set_Actual_Subtypes (N, Current_Scope);
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
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);
- Push_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 (Id);
+ Generate_Reference_To_Formals (Def_Id);
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Def_Id);
+ end if;
end Analyze_Entry_Declaration;
---------------------------------------
-- 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
+ -- 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_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);
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))
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);
end Analyze_Protected_Definition;
- ----------------------------
- -- Analyze_Protected_Type --
- ----------------------------
+ ----------------------------------------
+ -- Analyze_Protected_Type_Declaration --
+ ----------------------------------------
- procedure Analyze_Protected_Type (N : Node_Id) is
+ 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_Stored_Constraint (T, No_Elist);
Push_Scope (T);
- if Ada_Version >= Ada_05 then
+ if Ada_Version >= Ada_2005 then
Check_Interfaces (N, T);
end if;
Set_Is_Constrained (T, not Has_Discriminants (T));
- -- Perform minimal expansion of protected type while inside a generic.
- -- The corresponding record is needed for various semantic checks.
+ -- If aspects are present, analyze them now. They can make references
+ -- to the discriminants of the type, but not to any components.
- if Ada_Version >= Ada_05
- and then Inside_A_Generic
- then
- Insert_After_And_Analyze (N,
- Build_Corresponding_Record (N, T, Sloc (T)));
+ 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
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.
+ -- may be subtypes of the partial view.
+
+ -- Skip if errors are present, to prevent cascaded messages
if Serious_Errors_Detected = 0
- and then Expander_Active
+
+ -- 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 --
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_Id := Entity (Entry_Name);
end if;
- -- Ada 2005 (AI05-0030): Potential dispatching requeue statement. The
+ -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The
-- target type must be a concurrent interface class-wide type and the
- -- entry name must be a procedure, flagged by pragma Implemented_By_
- -- Entry.
+ -- target must be a procedure, flagged by pragma Implemented.
Is_Disp_Req :=
- Ada_Version >= Ada_05
+ 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 Implemented_By_Entry (Entry_Id);
+ 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)).
Generate_Reference (Entry_Id, Entry_Name);
if Present (First_Formal (Entry_Id)) then
- if VM_Target = JVM_Target and then not Inspector_Mode then
+ if VM_Target = JVM_Target then
Error_Msg_N
("arguments unsupported in requeue statement",
First_Formal (Entry_Id));
return;
end if;
- -- Ada 2005 (AI05-0030): Perform type conformance after skipping
+ -- Ada 2012 (AI05-0030): Perform type conformance after skipping
-- the first parameter of Entry_Id since it is the interface
-- controlling formal.
- if Is_Disp_Req then
+ if Ada_Version >= Ada_2012
+ and then Is_Disp_Req
+ then
declare
Enclosing_Formal : Entity_Id;
Target_Formal : Entity_Id;
-- 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
+ 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;
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
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;
-- 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;
-- 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).
+ -- 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,
-- 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;
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
begin
Tasking_Used := True;
+ Check_SPARK_Restriction ("task definition is not allowed", N);
if Present (Visible_Declarations (N)) then
Analyze_Declarations (Visible_Declarations (N));
Process_End_Label (N, 'e', Current_Scope);
end Analyze_Task_Definition;
- -----------------------
- -- Analyze_Task_Type --
- -----------------------
+ -----------------------------------
+ -- Analyze_Task_Type_Declaration --
+ -----------------------------------
- procedure Analyze_Task_Type (N : Node_Id) is
+ procedure Analyze_Task_Type_Declaration (N : Node_Id) is
Def_Id : constant Entity_Id := Defining_Identifier (N);
T : Entity_Id;
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_Stored_Constraint (T, No_Elist);
Push_Scope (T);
- if Ada_Version >= Ada_05 then
+ if Ada_Version >= Ada_2005 then
Check_Interfaces (N, T);
end if;
Set_Is_Constrained (T, not Has_Discriminants (T));
- -- Perform minimal expansion of the task type while inside a generic
- -- context. The corresponding record is needed for various semantic
- -- checks.
-
- if Inside_A_Generic then
- Insert_After_And_Analyze (N,
- Build_Corresponding_Record (N, T, Sloc (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;
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.
+ -- may be subtypes of the partial view.
+
+ -- Skip if errors are present, to prevent cascaded messages
if Serious_Errors_Detected = 0
- and then Expander_Active
+
+ -- 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 --
Is_Disp_Select : Boolean := False;
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);
-- Ada 2005 (AI-345): The trigger may be a dispatching call
- if Ada_Version >= Ada_05 then
+ if Ada_Version >= Ada_2005 then
Analyze (Trigger);
Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
end if;
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
+ -- 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.
-- 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;
-- declaration must be limited.
if Present (Interface_List (N))
- and then not Is_Limited_Record (Priv_T)
+ 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 " &
if Present (Interface_List (N))
or else (Is_Tagged_Type (Priv_T)
- and then Has_Abstract_Interfaces
- (Priv_T, Use_Full_View => False))
+ and then Has_Interfaces
+ (Priv_T, Use_Full_View => False))
then
if Is_Tagged_Type (Priv_T) then
- Collect_Abstract_Interfaces
+ Collect_Interfaces
(Priv_T, Priv_T_Ifaces, Use_Full_View => False);
end if;
if Is_Tagged_Type (T) then
- Collect_Abstract_Interfaces (T, Full_T_Ifaces);
+ Collect_Interfaces (T, Full_T_Ifaces);
end if;
Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
if Present (Iface) then
- Error_Msg_NE ("interface & not implemented by full type " &
- "(RM-2005 7.3 (7.3/2))", Priv_T, Iface);
+ Error_Msg_NE
+ ("interface & not implemented by full type " &
+ "(RM-2005 7.3 (7.3/2))", Priv_T, Iface);
end if;
Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
if Present (Iface) then
- Error_Msg_NE ("interface & not implemented by partial " &
- "view (RM-2005 7.3 (7.3/2))", T, Iface);
+ Error_Msg_NE
+ ("interface & not implemented by partial " &
+ "view (RM-2005 7.3 (7.3/2))", T, Iface);
end if;
end if;
end if;
-- It is not possible to have a dispatching trigger if we are not in
-- Ada 2005 mode.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Nkind (Trigger) = N_Procedure_Call_Statement
and then Present (Parameter_Associations (Trigger))
then
OSDN Git Service
