-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
-- for the discriminals and privals and finally a declaration for the
-- entry family index (if applicable).
- if Expander_Active
- and then not ALFA_Mode
+ if Full_Expander_Active
and then Is_Protected_Type (P_Type)
then
Install_Private_Data_Declarations
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;
-- Decorate Def_Id
begin
if No_Run_Time_Mode then
Error_Msg_CRT ("protected type", N);
- goto Leave;
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Def_Id);
+ end if;
+
+ return;
end if;
Tasking_Used := True;
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
-- Also skip if expander is not active
- and then Expander_Active
-
- -- Also skip if in ALFA mode, this expansion is not needed
-
- and then not ALFA_Mode
+ and then Full_Expander_Active
then
Expand_N_Protected_Type_Declaration (N);
Process_Full_View (N, T, Def_Id);
end if;
end if;
-
- <<Leave>>
- if Has_Aspects (N) then
- Analyze_Aspect_Specifications (N, Def_Id);
- end if;
end Analyze_Protected_Type_Declaration;
---------------------
Defining_Identifier => O_Name,
Object_Definition => Make_Identifier (Loc, Chars (T)));
- Move_Aspects (N, O_Decl);
Rewrite (N, T_Decl);
Insert_After (N, O_Decl);
Mark_Rewrite_Insertion (O_Decl);
Defining_Identifier => O_Name,
Object_Definition => Make_Identifier (Loc, Chars (T)));
- Move_Aspects (N, O_Decl);
Rewrite (N, T_Decl);
Insert_After (N, O_Decl);
Mark_Rewrite_Insertion (O_Decl);
-- 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 and then Present (Full_View (T)) then
- T := Full_View (T);
- Set_Completion_Referenced (T);
+ if Ekind (T) = E_Incomplete_Type then
+ 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_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;
-- Also skip if expander is not active
- and then Expander_Active
-
- -- Or if in ALFA mode, this expansion is not needed
- and then not ALFA_Mode
+ and then Full_Expander_Active
then
Expand_N_Task_Type_Declaration (N);
Process_Full_View (N, T, Def_Id);
end if;
end if;
-
- if Has_Aspects (N) then
- Analyze_Aspect_Specifications (N, Def_Id);
- end if;
end Analyze_Task_Type_Declaration;
-----------------------------------
-- 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 " &
OSDN Git Service
