+2017-01-06 Yannick Moy <moy@adacore.com>
+
+ * ghost.adb Minor fixing of references to SPARK RM.
+ (Check_Ghost_Context): Check whether reference is to a lvalue
+ before issuing an error about violation of SPARK RM 6.9(13)
+ when declaration has Ghost policy Check and reference has Ghost
+ policy Ignore.
+ * sem_util.adb Minor indentation.
+ * sem_ch10.adb (Analyze_Package_Body_Stub, Analyze_Protected_Body_Stub,
+ Analyze_Task_Body_Stub): Set Ekind of the defining identifier.
+ * sem_util.ads (Unique_Defining_Entity): Document the result
+ for package body stubs.
+
+2017-01-06 Tristan Gingold <gingold@adacore.com>
+
+ * raise-gcc.c (abort): Macro to call Abort_Propagation.
+ * s-tpoben.ads (Protected_Entry_Queue_Max_Access): Make it access
+ constant.
+ * exp_ch9.adb (Expand_N_Protected_Type_Declaration):
+ Do not generate the Entry_Max_Queue_Lengths_Array if all default
+ values.
+ * exp_util.adb (Corresponding_Runtime_Package): Consider
+ Max_Queue_Length pragma.
+
2017-01-06 Justin Squirek <squirek@adacore.com>
* exp_ch9.adb (Expand_N_Protected_Type_Declaration):
-- type. This object is later passed to the appropriate protected object
-- initialization routine.
- declare
- Max : Uint;
- Maxs : constant List_Id := New_List;
- Count : Int;
- Item : Entity_Id;
- Maxs_Id : Entity_Id;
- Max_Vals : Node_Id;
-
- begin
- if Has_Entries (Prot_Typ) then
+ if Has_Entries (Prot_Typ) then
+ declare
+ Need_Array : Boolean := False;
+ Maxs : List_Id;
+ Count : Int;
+ Item : Entity_Id;
+ Maxs_Id : Entity_Id;
+ Max_Vals : Node_Id;
- -- Gather the Max_Queue_Length values of all entries in a list. A
- -- value of zero indicates that the entry has no limitation on its
- -- queue length.
+ begin
+ -- First check if there is any Max_Queue_Length pragma
- Count := 0;
Item := First_Entity (Prot_Typ);
while Present (Item) loop
- if Is_Entry (Item) then
- Count := Count + 1;
- Max := Get_Max_Queue_Length (Item);
-
- -- The package System_Tasking_Protected_Objects_Single_Entry
- -- is only used in cases where queue length is 1, so if this
- -- package is being used and there is a value supplied for
- -- it print an error message and halt compilation.
-
- if Max /= 0
- and then Corresponding_Runtime_Package (Prot_Typ) =
- System_Tasking_Protected_Objects_Single_Entry
- then
- Error_Msg_N
- ("max_queue_length cannot be applied to entries under "
- & "the Ravenscar profile", Item);
- raise Program_Error;
- end if;
-
- Append_To (Maxs, Make_Integer_Literal (Loc, Intval => Max));
+ if Is_Entry (Item) and then Has_Max_Queue_Length (Item) then
+ Need_Array := True;
+ exit;
end if;
-
Next_Entity (Item);
end loop;
- case Corresponding_Runtime_Package (Prot_Typ) is
- when System_Tasking_Protected_Objects_Entries =>
-
- -- Create the declaration of the array object. Generate:
-
- -- Maxs_Id : aliased Protected_Entry_Queue_Max_Array
- -- (1 .. Count) := (..., ...);
-
- Maxs_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Prot_Typ), 'B'));
-
- Max_Vals :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Maxs_Id,
- Aliased_Present => True,
- Object_Definition =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Protected_Entry_Queue_Max_Array), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Range (Loc,
- Make_Integer_Literal (Loc, 1),
- Make_Integer_Literal (Loc, Count))))),
- Expression => Make_Aggregate (Loc, Maxs));
-
- -- A pointer to this array will be placed in the
- -- corresponding record by its initialization procedure so
- -- this needs to be analyzed here.
+ -- Gather the Max_Queue_Length values of all entries in a list. A
+ -- value of zero indicates that the entry has no limitation on its
+ -- queue length.
- Insert_After (Current_Node, Max_Vals);
- Current_Node := Max_Vals;
- Analyze (Max_Vals);
+ if Need_Array then
+ Maxs := New_List;
+ Count := 0;
+ Item := First_Entity (Prot_Typ);
+ while Present (Item) loop
+ if Is_Entry (Item) then
+ Count := Count + 1;
+ Append_To (Maxs,
+ Make_Integer_Literal (Loc,
+ Get_Max_Queue_Length (Item)));
+ end if;
- Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxs_Id);
+ Next_Entity (Item);
+ end loop;
- when System_Tasking_Protected_Objects_Single_Entry =>
+ -- Create the declaration of the array object. Generate:
- -- If this section is entered this means the package
- -- System_Tasking_Protected_Objects_Single_Entry is being
- -- used and that it correctly has no Max_Queue_Length
- -- specified, so fall through and continue normally.
+ -- Maxs_Id : aliased Protected_Entry_Queue_Max_Array
+ -- (1 .. Count) := (..., ...);
- null;
+ Maxs_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Prot_Typ), 'B'));
- when others =>
- raise Program_Error;
- end case;
- end if;
- end;
+ Max_Vals :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Maxs_Id,
+ Aliased_Present => True,
+ Constant_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (RTE (RE_Protected_Entry_Queue_Max_Array), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Range (Loc,
+ Make_Integer_Literal (Loc, 1),
+ Make_Integer_Literal (Loc, Count))))),
+ Expression => Make_Aggregate (Loc, Maxs));
+
+ -- A pointer to this array will be placed in the
+ -- corresponding record by its initialization procedure so
+ -- this needs to be analyzed here.
+
+ Insert_After (Current_Node, Max_Vals);
+ Current_Node := Max_Vals;
+ Analyze (Max_Vals);
+
+ Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxs_Id);
+ end if;
+ end;
+ end if;
-- Emit declaration for Entry_Bodies_Array, now that the addresses of
-- all protected subprograms have been collected.
raise Program_Error;
end case;
- -- Entry_Queue_Maxs parameter. This is a pointer to an array of
+ -- Entry_Queue_Maxs parameter. This is an access to an array of
-- naturals representing the entry queue maximums for each entry
- -- in the protected type. Zero represents no max.
+ -- in the protected type. Zero represents no max. The access is
+ -- null if there is no limit for all entries (usual case).
if Has_Entry
and then Pkg_Id /= System_Tasking_Protected_Objects_Single_Entry
then
- Append_To (Args,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of
- (Entry_Max_Queue_Lengths_Array (Ptyp), Loc),
- Attribute_Name => Name_Unrestricted_Access));
+ if Present (Entry_Max_Queue_Lengths_Array (Ptyp)) then
+ Append_To (Args,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (Entry_Max_Queue_Lengths_Array (Ptyp), Loc),
+ Attribute_Name => Name_Unrestricted_Access));
+ else
+ Append_To (Args, Make_Null (Loc));
+ end if;
-- Edge cases exist where entry initialization functions are
-- called, but no entries exist, so null is appended.
-----------------------------------
function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
+
+ function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean;
+ -- Return True if protected type T has one entry and the maximum queue
+ -- length is one.
+
+ --------------------------------
+ -- Has_One_Entry_And_No_Queue --
+ --------------------------------
+
+ function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean is
+ Is_First : Boolean := True;
+ Ent : Entity_Id;
+ begin
+ Ent := First_Entity (T);
+ while Present (Ent) loop
+ if Is_Entry (Ent) then
+ if not Is_First then
+ -- More than one entry
+
+ return False;
+ end if;
+
+ if not Restriction_Active (No_Entry_Queue)
+ and then Get_Max_Queue_Length (Ent) /= Uint_1
+ then
+ -- Max queue length is not 1
+
+ return False;
+ end if;
+
+ Is_First := False;
+ end if;
+
+ Ent := Next_Entity (Ent);
+ end loop;
+
+ return True;
+ end Has_One_Entry_And_No_Queue;
+
Pkg_Id : RTU_Id := RTU_Null;
begin
or else Has_Interrupt_Handler (Typ)
then
if Abort_Allowed
- or else Restriction_Active (No_Entry_Queue) = False
or else Restriction_Active (No_Select_Statements) = False
- or else Number_Entries (Typ) > 1
+ or else not Has_One_Entry_And_No_Queue (Typ)
or else (Has_Attach_Handler (Typ)
and then not Restricted_Profile)
then
-------------------------
procedure Check_Ghost_Context (Ghost_Id : Entity_Id; Ghost_Ref : Node_Id) is
- procedure Check_Ghost_Policy (Id : Entity_Id; Err_N : Node_Id);
+ procedure Check_Ghost_Policy (Id : Entity_Id; Ref : Node_Id);
-- Verify that the Ghost policy at the point of declaration of entity Id
- -- matches the policy at the point of reference. If this is not the case
- -- emit an error at Err_N.
+ -- matches the policy at the point of reference Ref. If this is not the
+ -- case emit an error at Ref.
function Is_OK_Ghost_Context (Context : Node_Id) return Boolean;
-- Determine whether node Context denotes a Ghost-friendly context where
-- Check_Ghost_Policy --
------------------------
- procedure Check_Ghost_Policy (Id : Entity_Id; Err_N : Node_Id) is
+ procedure Check_Ghost_Policy (Id : Entity_Id; Ref : Node_Id) is
Policy : constant Name_Id := Policy_In_Effect (Name_Ghost);
begin
-- The Ghost policy in effect a the point of declaration and at the
-- point of use must match (SPARK RM 6.9(13)).
- if Is_Checked_Ghost_Entity (Id) and then Policy = Name_Ignore then
- Error_Msg_Sloc := Sloc (Err_N);
+ if Is_Checked_Ghost_Entity (Id)
+ and then Policy = Name_Ignore
+ and then May_Be_Lvalue (Ref)
+ then
+ Error_Msg_Sloc := Sloc (Ref);
- Error_Msg_N ("incompatible ghost policies in effect", Err_N);
- Error_Msg_NE ("\& declared with ghost policy `Check`", Err_N, Id);
- Error_Msg_NE ("\& used # with ghost policy `Ignore`", Err_N, Id);
+ Error_Msg_N ("incompatible ghost policies in effect", Ref);
+ Error_Msg_NE ("\& declared with ghost policy `Check`", Ref, Id);
+ Error_Msg_NE ("\& used # with ghost policy `Ignore`", Ref, Id);
elsif Is_Ignored_Ghost_Entity (Id) and then Policy = Name_Check then
- Error_Msg_Sloc := Sloc (Err_N);
+ Error_Msg_Sloc := Sloc (Ref);
- Error_Msg_N ("incompatible ghost policies in effect", Err_N);
- Error_Msg_NE ("\& declared with ghost policy `Ignore`", Err_N, Id);
- Error_Msg_NE ("\& used # with ghost policy `Check`", Err_N, Id);
+ Error_Msg_N ("incompatible ghost policies in effect", Ref);
+ Error_Msg_NE ("\& declared with ghost policy `Ignore`", Ref, Id);
+ Error_Msg_NE ("\& used # with ghost policy `Check`", Ref, Id);
end if;
end Check_Ghost_Policy;
Check_Ghost_Policy (Ghost_Id, Ghost_Ref);
-- Otherwise the Ghost entity appears in a non-Ghost context and affects
- -- its behavior or value (SPARK RM 6.9(11,12)).
+ -- its behavior or value (SPARK RM 6.9(10,11)).
else
Error_Msg_N ("ghost entity cannot appear in this context", Ghost_Ref);
extern void __gnat_unhandled_except_handler (_Unwind_Exception *);
#ifdef CERT
+/* Called in case of error during propagation. */
+extern void __gnat_raise_abort (void) __attribute__ ((noreturn));
#define abort() __gnat_raise_abort()
-static void __gnat_raise_abort(void)
-{
- while (1)
- ;
-}
#endif
#include "unwind-pe.h"
array (Positive_Protected_Entry_Index range <>) of Natural;
type Protected_Entry_Queue_Max_Access is
- access all Protected_Entry_Queue_Max_Array;
+ access constant Protected_Entry_Queue_Max_Array;
-- The following declarations define an array that contains the string
-- names of entries and entry family members, together with an associated
Set_Has_Completion (Nam);
Set_Scope (Defining_Entity (N), Current_Scope);
+ Set_Ekind (Defining_Entity (N), E_Package_Body);
Set_Corresponding_Spec_Of_Stub (N, Nam);
Generate_Reference (Nam, Id, 'b');
Analyze_Proper_Body (N, Nam);
else
Set_Scope (Defining_Entity (N), Current_Scope);
+ Set_Ekind (Defining_Entity (N), E_Protected_Body);
Set_Has_Completion (Etype (Nam));
Set_Corresponding_Spec_Of_Stub (N, Nam);
Generate_Reference (Nam, Defining_Identifier (N), 'b');
else
Set_Scope (Defining_Entity (N), Current_Scope);
+ Set_Ekind (Defining_Entity (N), E_Task_Body);
Generate_Reference (Nam, Defining_Identifier (N), 'b');
Set_Corresponding_Spec_Of_Stub (N, Nam);
--------------------------
function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
+ pragma Assert (Is_Entry (Id));
Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
begin
-- A value of 0 represents no maximum specified, and entries and entry
-- families with no Max_Queue_Length aspect or pragma default to it.
- if not Has_Max_Queue_Length (Id) or else not Present (Prag) then
+ if not Present (Prag) then
return Uint_0;
end if;
when N_Assignment_Statement =>
return N = Name (P);
- -- Function call arguments are never lvalues
+ -- Function call arguments are never lvalues
when N_Function_Call =>
return False;
-- Return the entity which represents declaration N, so that different
-- views of the same entity have the same unique defining entity:
-- * entry declaration and entry body
- -- * package spec and body
- -- * protected type declaration, protected body stub and protected body
+ -- * package spec, package body, and package body stub
+ -- * protected type declaration, protected body and protected body stub
-- * private view and full view of a deferred constant
-- * private view and full view of a type
- -- * subprogram declaration, subprogram stub and subprogram body
- -- * task type declaration, task body stub and task body
+ -- * subprogram declaration, subprogram and subprogram body stub
+ -- * task type declaration, task body and task body stub
-- In other cases, return the defining entity for N.
function Unique_Entity (E : Entity_Id) return Entity_Id;
projects / gcc.git / commitdiff