Skip to content

R
riscv-gcc-1
Commit cc2c4c65 by Eric Botcazou Committed by Arnaud Charlet
Options

exp_ch9.ads, [...] (Family_Offset): Add new 'Cap' boolean parameter. 

2007-04-06  Eric Botcazou <botcazou@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* exp_ch9.ads, exp_ch9.adb (Family_Offset): Add new 'Cap' boolean
	parameter. If it is set to true, return a result capped according to
	the global upper bound for the index of an entry family.
	(Family_Size): Add new 'Cap' boolean parameter. Pass it to Family_Offset
	(Build_Find_Body_Index): Adjust for above change.
	(Entry_Index_Expression): Likewise.
	(Is_Potentially_Large_Family): New function extracted from...
	(Collect_Entry_Families): ...here. Call it to detect whether the family
	is potentially large.
	(Build_Entry_Count_Expression): If the family is potentially large, call
	Family_Size with 'Cap' set to true.
	(Expand_N_Protected_Type_Declaration, Expand_N_Protected_Body): Generate
	a protected version of an operation declared in the private part of
	a protected object, because they may be invoked through a callback.
	(Set_Privals): If the type of a private component is an anonymous access
	type, do not create a new itype for each protected body.
	If the body of a protected operation creates
	controlled types (including allocators for class-widetypes), the
	body of the corresponding protected subprogram must include a
	finalization list.
	(Build_Activation_Chain_Entity): Build the chain entity for extended
	return statements.
	(Type_Conformant_Parameters): Use common predicate Conforming_Types
	to determine whether operation overrides an inherited primitive.
	(Build_Wrapper_Spec): Add code to examine the parents while looking
	for a possible overriding candidate.
	(Build_Simple_Entry_Call): Set No_Initialization on the object used to
	hold an actual parameter value since its initialization is separated
	from the the declaration. Prevents errors on null-excluding access
	formals.

From-SVN: r123564
parent afe4375b
Showing with 294 additions and 136 deletions
gcc/ada/exp_ch9.adb
...@@ -285,21 +285,25 @@ package body Exp_Ch9 is ...@@ -285,21 +285,25 @@ package body Exp_Ch9 is
(Loc : Source_Ptr; (Loc : Source_Ptr;
Hi : Node_Id; Hi : Node_Id;
Lo : Node_Id; Lo : Node_Id;
Ttyp : Entity_Id) return Node_Id; Ttyp : Entity_Id;
Cap : Boolean) return Node_Id;
-- Compute (Hi - Lo) for two entry family indices. Hi is the index in -- Compute (Hi - Lo) for two entry family indices. Hi is the index in
-- an accept statement, or the upper bound in the discrete subtype of -- an accept statement, or the upper bound in the discrete subtype of
-- an entry declaration. Lo is the corresponding lower bound. Ttyp is -- an entry declaration. Lo is the corresponding lower bound. Ttyp is
-- the concurrent type of the entry. -- the concurrent type of the entry. If Cap is true, the result is
-- capped according to Entry_Family_Bound.
function Family_Size function Family_Size
(Loc : Source_Ptr; (Loc : Source_Ptr;
Hi : Node_Id; Hi : Node_Id;
Lo : Node_Id; Lo : Node_Id;
Ttyp : Entity_Id) return Node_Id; Ttyp : Entity_Id;
Cap : Boolean) return Node_Id;
-- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in
-- a family, and handle properly the superflat case. This is equivalent -- a family, and handle properly the superflat case. This is equivalent
-- to the use of 'Length on the index type, but must use Family_Offset -- to the use of 'Length on the index type, but must use Family_Offset
-- to handle properly the case of bounds that depend on discriminants. -- to handle properly the case of bounds that depend on discriminants.
-- If Cap is true, the result is capped according to Entry_Family_Bound.
procedure Extract_Dispatching_Call procedure Extract_Dispatching_Call
(N : Node_Id; (N : Node_Id;
...@@ -339,6 +343,12 @@ package body Exp_Ch9 is ...@@ -339,6 +343,12 @@ package body Exp_Ch9 is
-- E - <<index of first family member>> + -- E - <<index of first family member>> +
-- Protected_Entry_Index (Index_Type'Pos (Index_Type'First))); -- Protected_Entry_Index (Index_Type'Pos (Index_Type'First)));
function Is_Potentially_Large_Family
(Base_Index : Entity_Id;
Conctyp : Entity_Id;
Lo : Node_Id;
Hi : Node_Id) return Boolean;
function Parameter_Block_Pack function Parameter_Block_Pack
(Loc : Source_Ptr; (Loc : Source_Ptr;
Blk_Typ : Entity_Id; Blk_Typ : Entity_Id;
...@@ -457,19 +467,19 @@ package body Exp_Ch9 is ...@@ -457,19 +467,19 @@ package body Exp_Ch9 is
-- Start of processing for Actual_Index_Expression -- Start of processing for Actual_Index_Expression
begin begin
-- The queues of entries and entry families appear in textual -- The queues of entries and entry families appear in textual order in
-- order in the associated record. The entry index is computed as -- the associated record. The entry index is computed as the sum of the
-- the sum of the number of queues for all entries that precede the -- number of queues for all entries that precede the designated one, to
-- designated one, to which is added the index expression, if this -- which is added the index expression, if this expression denotes a
-- expression denotes a member of a family. -- member of a family.
-- The following is a place holder for the count of simple entries -- The following is a place holder for the count of simple entries
Num := Make_Integer_Literal (Sloc, 1); Num := Make_Integer_Literal (Sloc, 1);
-- We construct an expression which is a series of addition -- We construct an expression which is a series of addition operations.
-- operations. See comments in Entry_Index_Expression, which is -- See comments in Entry_Index_Expression, which is identical in
-- identical in structure. -- structure.
if Present (Index) then if Present (Index) then
S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
...@@ -818,7 +828,7 @@ package body Exp_Ch9 is ...@@ -818,7 +828,7 @@ package body Exp_Ch9 is
Set_Exception_Handlers (New_S, Set_Exception_Handlers (New_S,
New_List ( New_List (
Make_Exception_Handler (Loc, Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Ohandle), Exception_Choices => New_List (Ohandle),
Statements => New_List ( Statements => New_List (
...@@ -846,8 +856,8 @@ package body Exp_Ch9 is ...@@ -846,8 +856,8 @@ package body Exp_Ch9 is
procedure Build_Activation_Chain_Entity (N : Node_Id) is procedure Build_Activation_Chain_Entity (N : Node_Id) is
P : Node_Id; P : Node_Id;
B : Node_Id;
Decls : List_Id; Decls : List_Id;
Chain : Entity_Id;
begin begin
-- Loop to find enclosing construct containing activation chain variable -- Loop to find enclosing construct containing activation chain variable
...@@ -859,38 +869,54 @@ package body Exp_Ch9 is ...@@ -859,38 +869,54 @@ package body Exp_Ch9 is
and then Nkind (P) /= N_Package_Body and then Nkind (P) /= N_Package_Body
and then Nkind (P) /= N_Block_Statement and then Nkind (P) /= N_Block_Statement
and then Nkind (P) /= N_Task_Body and then Nkind (P) /= N_Task_Body
and then Nkind (P) /= N_Extended_Return_Statement
loop loop
P := Parent (P); P := Parent (P);
end loop; end loop;
-- If we are in a package body, the activation chain variable is -- If we are in a package body, the activation chain variable is
-- allocated in the corresponding spec. First, we save the package -- declared in the body, but the Activation_Chain_Entity is attached to
-- body node because we enter the new entity in its Declarations list. -- the spec.
B := P;
if Nkind (P) = N_Package_Body then if Nkind (P) = N_Package_Body then
Decls := Declarations (P);
P := Unit_Declaration_Node (Corresponding_Spec (P)); P := Unit_Declaration_Node (Corresponding_Spec (P));
Decls := Declarations (B);
elsif Nkind (P) = N_Package_Declaration then elsif Nkind (P) = N_Package_Declaration then
Decls := Visible_Declarations (Specification (B)); Decls := Visible_Declarations (Specification (P));
elsif Nkind (P) = N_Extended_Return_Statement then
Decls := Return_Object_Declarations (P);
else else
Decls := Declarations (B); Decls := Declarations (P);
end if; end if;
-- If activation chain entity not already declared, declare it -- If activation chain entity not already declared, declare it
if No (Activation_Chain_Entity (P)) then if Nkind (P) = N_Extended_Return_Statement
Set_Activation_Chain_Entity or else No (Activation_Chain_Entity (P))
(P, Make_Defining_Identifier (Sloc (N), Name_uChain)); then
Chain := Make_Defining_Identifier (Sloc (N), Name_uChain);
-- An extended return statement is not really a task activator, but
-- it does have an activation chain on which to store the tasks
-- temporarily. On successful return, the tasks on this chain are
-- moved to the chain passed in by the
-- caller. N_Extended_Return_Statement does not have an
-- Activation_Chain_Entity, because we do not want to build a call
-- to Activate_Tasks; task activation is the responsibility of the
-- caller.
if Nkind (P) /= N_Extended_Return_Statement then
Set_Activation_Chain_Entity (P, Chain);
end if;
Prepend_To (Decls, Prepend_To (Decls,
Make_Object_Declaration (Sloc (P), Make_Object_Declaration (Sloc (P),
Defining_Identifier => Activation_Chain_Entity (P), Defining_Identifier => Chain,
Aliased_Present => True, Aliased_Present => True,
Object_Definition => Object_Definition =>
New_Reference_To (RTE (RE_Activation_Chain), Sloc (P)))); New_Reference_To (RTE (RE_Activation_Chain), Sloc (P))));
Analyze (First (Decls)); Analyze (First (Decls));
...@@ -1111,6 +1137,7 @@ package body Exp_Ch9 is ...@@ -1111,6 +1137,7 @@ package body Exp_Ch9 is
Lo : Node_Id; Lo : Node_Id;
Hi : Node_Id; Hi : Node_Id;
Typ : Entity_Id; Typ : Entity_Id;
Large : Boolean;
begin begin
-- Count number of non-family entries -- Count number of non-family entries
...@@ -1140,11 +1167,13 @@ package body Exp_Ch9 is ...@@ -1140,11 +1167,13 @@ package body Exp_Ch9 is
Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
Hi := Type_High_Bound (Typ); Hi := Type_High_Bound (Typ);
Lo := Type_Low_Bound (Typ); Lo := Type_Low_Bound (Typ);
Large := Is_Potentially_Large_Family
(Base_Type (Typ), Concurrent_Type, Lo, Hi);
Ecount := Ecount :=
Make_Op_Add (Loc, Make_Op_Add (Loc,
Left_Opnd => Ecount, Left_Opnd => Ecount,
Right_Opnd => Family_Size (Loc, Hi, Lo, Concurrent_Type)); Right_Opnd => Family_Size
(Loc, Hi, Lo, Concurrent_Type, Large));
end if; end if;
Next_Entity (Ent); Next_Entity (Ent);
...@@ -1440,13 +1469,12 @@ package body Exp_Ch9 is ...@@ -1440,13 +1469,12 @@ package body Exp_Ch9 is
while Present (Prim_Op_Param) while Present (Prim_Op_Param)
and then Present (Proc_Param) and then Present (Proc_Param)
loop loop
-- The two parameters must be mode conformant and have -- The two parameters must be mode conformant
-- the exact same types.
if Ekind (Defining_Identifier (Prim_Op_Param)) /= if not Conforming_Types (
Ekind (Defining_Identifier (Proc_Param)) Etype (Parameter_Type (Prim_Op_Param)),
or else Etype (Parameter_Type (Prim_Op_Param)) /= Etype (Parameter_Type (Proc_Param)),
Etype (Parameter_Type (Proc_Param)) Mode_Conformant)
then then
return False; return False;
end if; end if;
...@@ -1542,51 +1570,90 @@ package body Exp_Ch9 is ...@@ -1542,51 +1570,90 @@ package body Exp_Ch9 is
-- The mode is determined by the first parameter of the interface-level -- The mode is determined by the first parameter of the interface-level
-- procedure that the current entry is trying to override. -- procedure that the current entry is trying to override.
pragma Assert (Present (Abstract_Interfaces pragma Assert (Is_Non_Empty_List (Abstract_Interface_List (Obj_Typ)));
(Corresponding_Record_Type (Scope (Proc_Nam)))));
Iface_Elmt :=
First_Elmt (Abstract_Interfaces
(Corresponding_Record_Type (Scope (Proc_Nam))));
-- We must examine all the protected operations of the implemented -- We must examine all the protected operations of the implemented
-- interfaces in order to discover a possible overriding candidate. -- interfaces in order to discover a possible overriding candidate.
Examine_Interfaces : while Present (Iface_Elmt) loop Iface := Etype (First (Abstract_Interface_List (Obj_Typ)));
Iface := Node (Iface_Elmt);
Examine_Parents : loop
if Present (Primitive_Operations (Iface)) then if Present (Primitive_Operations (Iface)) then
Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
while Present (Iface_Prim_Op_Elmt) loop while Present (Iface_Prim_Op_Elmt) loop
Iface_Prim_Op := Node (Iface_Prim_Op_Elmt); Iface_Prim_Op := Node (Iface_Prim_Op_Elmt);
while Present (Alias (Iface_Prim_Op)) loop if not Is_Predefined_Dispatching_Operation (Iface_Prim_Op) then
Iface_Prim_Op := Alias (Iface_Prim_Op); while Present (Alias (Iface_Prim_Op)) loop
end loop; Iface_Prim_Op := Alias (Iface_Prim_Op);
end loop;
-- The current primitive operation can be overriden by the -- The current primitive operation can be overriden by the
-- generated entry wrapper. -- generated entry wrapper.
if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then
First_Param := First_Param := First (Parameter_Specifications
First (Parameter_Specifications (Parent (Iface_Prim_Op))); (Parent (Iface_Prim_Op)));
exit Examine_Interfaces; goto Found;
end if;
end if; end if;
Next_Elmt (Iface_Prim_Op_Elmt); Next_Elmt (Iface_Prim_Op_Elmt);
end loop; end loop;
end if; end if;
Next_Elmt (Iface_Elmt); exit Examine_Parents when Etype (Iface) = Iface;
end loop Examine_Interfaces;
-- Return if no interface primitive can be overriden Iface := Etype (Iface);
end loop Examine_Parents;
if No (First_Param) then if Present (Abstract_Interfaces
return Empty; (Corresponding_Record_Type (Scope (Proc_Nam))))
then
Iface_Elmt := First_Elmt
(Abstract_Interfaces
(Corresponding_Record_Type (Scope (Proc_Nam))));
Examine_Interfaces : while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
if Present (Primitive_Operations (Iface)) then
Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
while Present (Iface_Prim_Op_Elmt) loop
Iface_Prim_Op := Node (Iface_Prim_Op_Elmt);
if not Is_Predefined_Dispatching_Operation
(Iface_Prim_Op)
then
while Present (Alias (Iface_Prim_Op)) loop
Iface_Prim_Op := Alias (Iface_Prim_Op);
end loop;
-- The current primitive operation can be overriden by
-- the generated entry wrapper.
if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then
First_Param := First (Parameter_Specifications
(Parent (Iface_Prim_Op)));
goto Found;
end if;
end if;
Next_Elmt (Iface_Prim_Op_Elmt);
end loop;
end if;
Next_Elmt (Iface_Elmt);
end loop Examine_Interfaces;
end if; end if;
-- Return if no interface primitive can be overriden
return Empty;
<<Found>>
New_Formals := Replicate_Entry_Formals (Loc, Formals); New_Formals := Replicate_Entry_Formals (Loc, Formals);
-- ??? Certain source packages contain protected or task types that do -- ??? Certain source packages contain protected or task types that do
...@@ -1802,7 +1869,7 @@ package body Exp_Ch9 is ...@@ -1802,7 +1869,7 @@ package body Exp_Ch9 is
E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ)); Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ));
Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ)); Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ));
Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ)); Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False));
end if; end if;
Next_Entity (Ent); Next_Entity (Ent);
...@@ -2047,7 +2114,7 @@ package body Exp_Ch9 is ...@@ -2047,7 +2114,7 @@ package body Exp_Ch9 is
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => Op_Stats, Statements => Op_Stats,
Exception_Handlers => New_List ( Exception_Handlers => New_List (
Make_Exception_Handler (Loc, Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Ohandle), Exception_Choices => New_List (Ohandle),
Statements => New_List ( Statements => New_List (
...@@ -2833,6 +2900,12 @@ package body Exp_Ch9 is ...@@ -2833,6 +2900,12 @@ package body Exp_Ch9 is
Object_Definition => Object_Definition =>
New_Reference_To (Etype (Formal), Loc)); New_Reference_To (Etype (Formal), Loc));
-- Mark the object as not needing initialization since the
-- initialization is performed separately, avoiding errors
-- on cases such as formals of null-excluding access types.
Set_No_Initialization (N_Node);
-- We have to make an assignment statement separate for the -- We have to make an assignment statement separate for the
-- case of limited type. We cannot assign it unless the -- case of limited type. We cannot assign it unless the
-- Assignment_OK flag is set first. -- Assignment_OK flag is set first.
...@@ -3079,7 +3152,7 @@ package body Exp_Ch9 is ...@@ -3079,7 +3152,7 @@ package body Exp_Ch9 is
begin begin
-- Get the activation chain entity. Except in the case of a package -- Get the activation chain entity. Except in the case of a package
-- body, this is in the node that w as passed. For a package body, we -- body, this is in the node that was passed. For a package body, we
-- have to find the corresponding package declaration node. -- have to find the corresponding package declaration node.
if Nkind (N) = N_Package_Body then if Nkind (N) = N_Package_Body then
...@@ -3375,15 +3448,8 @@ package body Exp_Ch9 is ...@@ -3375,15 +3448,8 @@ package body Exp_Ch9 is
begin begin
Get_Index_Bounds Get_Index_Bounds
(Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi); (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi);
if Scope (Bas) = Standard_Standard
and then Bas = Base_Type (Standard_Integer) if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then
and then Has_Discriminants (Conctyp)
and then Present
(Discriminant_Default_Value (First_Discriminant (Conctyp)))
and then
(Denotes_Discriminant (Lo, True)
or else Denotes_Discriminant (Hi, True))
then
Bas := Bas :=
Make_Defining_Identifier (Loc, New_Internal_Name ('B')); Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
Bas_Decl := Bas_Decl :=
...@@ -3696,7 +3762,8 @@ package body Exp_Ch9 is ...@@ -3696,7 +3762,8 @@ package body Exp_Ch9 is
Prefix => New_Reference_To (Base_Type (S), Sloc), Prefix => New_Reference_To (Base_Type (S), Sloc),
Expressions => New_List (Relocate_Node (Index))), Expressions => New_List (Relocate_Node (Index))),
Type_Low_Bound (S), Type_Low_Bound (S),
Ttyp)); Ttyp,
False));
else else
Expr := Num; Expr := Num;
end if; end if;
...@@ -3721,7 +3788,7 @@ package body Exp_Ch9 is ...@@ -3721,7 +3788,7 @@ package body Exp_Ch9 is
Expr := Expr :=
Make_Op_Add (Sloc, Make_Op_Add (Sloc,
Left_Opnd => Expr, Left_Opnd => Expr,
Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp)); Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False));
-- Other components are anonymous types to be ignored -- Other components are anonymous types to be ignored
...@@ -5288,7 +5355,7 @@ package body Exp_Ch9 is ...@@ -5288,7 +5355,7 @@ package body Exp_Ch9 is
-- Create the inner block to protect the abortable part -- Create the inner block to protect the abortable part
Hdle := New_List ( Hdle := New_List (
Make_Exception_Handler (Loc, Make_Implicit_Exception_Handler (Loc,
Exception_Choices => Exception_Choices =>
New_List (New_Reference_To (Stand.Abort_Signal, Loc)), New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
Statements => New_List ( Statements => New_List (
...@@ -5470,7 +5537,7 @@ package body Exp_Ch9 is ...@@ -5470,7 +5537,7 @@ package body Exp_Ch9 is
-- exception -- exception
Exception_Handlers => New_List ( Exception_Handlers => New_List (
Make_Exception_Handler (Loc, Make_Implicit_Exception_Handler (Loc,
-- when Abort_Signal => -- when Abort_Signal =>
-- Abort_Undefer.all; -- Abort_Undefer.all;
...@@ -5538,7 +5605,7 @@ package body Exp_Ch9 is ...@@ -5538,7 +5605,7 @@ package body Exp_Ch9 is
-- Create the inner block to protect the abortable part -- Create the inner block to protect the abortable part
Hdle := New_List ( Hdle := New_List (
Make_Exception_Handler (Loc, Make_Implicit_Exception_Handler (Loc,
Exception_Choices => Exception_Choices =>
New_List (New_Reference_To (Stand.Abort_Signal, Loc)), New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
Statements => New_List ( Statements => New_List (
...@@ -6421,8 +6488,8 @@ package body Exp_Ch9 is ...@@ -6421,8 +6488,8 @@ package body Exp_Ch9 is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Pid : constant Entity_Id := Corresponding_Spec (N); Pid : constant Entity_Id := Corresponding_Spec (N);
Has_Entries : Boolean := False; Has_Entries : Boolean := False;
Op_Decl : Node_Id;
Op_Body : Node_Id; Op_Body : Node_Id;
Op_Decl : Node_Id;
Op_Id : Entity_Id; Op_Id : Entity_Id;
Disp_Op_Body : Node_Id; Disp_Op_Body : Node_Id;
New_Op_Body : Node_Id; New_Op_Body : Node_Id;
...@@ -6556,29 +6623,47 @@ package body Exp_Ch9 is ...@@ -6556,29 +6623,47 @@ package body Exp_Ch9 is
New_Op_Body := New_Op_Body :=
Build_Unprotected_Subprogram_Body (Op_Body, Pid); Build_Unprotected_Subprogram_Body (Op_Body, Pid);
-- Propagate the finalization chain to the new body.
-- In the unlikely event that the subprogram contains a
-- declaration or allocator for an object that requires
-- finalization, the corresponding chain is created when
-- analyzing the body, and attached to its entity. This
-- entity is not further elaborated, and so the chain
-- properly belongs to the newly created subprogram body.
if Present
(Finalization_Chain_Entity (Defining_Entity (Op_Body)))
then
Set_Finalization_Chain_Entity
(Protected_Body_Subprogram
(Corresponding_Spec (Op_Body)),
Finalization_Chain_Entity (Defining_Entity (Op_Body)));
Set_Analyzed
(Handled_Statement_Sequence (New_Op_Body), False);
end if;
Insert_After (Current_Node, New_Op_Body); Insert_After (Current_Node, New_Op_Body);
Current_Node := New_Op_Body; Current_Node := New_Op_Body;
Analyze (New_Op_Body); Analyze (New_Op_Body);
Update_Prival_Subtypes (New_Op_Body); Update_Prival_Subtypes (New_Op_Body);
-- Build the corresponding protected operation only if -- Build the corresponding protected operation. It may
-- this is a visible operation of the type, or if it is -- appear that this is needed only this is a visible
-- an interrupt handler. Otherwise it is only callable -- operation of the type, or if it is an interrupt handler,
-- from within the object, and the unprotected version -- and this was the strategy used previously in GNAT.
-- is sufficient. -- However, the operation may be exported through a
-- 'Access to an external caller. This is the common idiom
-- in code that uses the Ada 2005 Timing_Events package
-- As a result we need to produce the protected body for
-- both visible and private operations.
if Present (Corresponding_Spec (Op_Body)) then if Present (Corresponding_Spec (Op_Body)) then
Op_Decl := Op_Decl :=
Unit_Declaration_Node (Corresponding_Spec (Op_Body)); Unit_Declaration_Node (Corresponding_Spec (Op_Body));
if Nkind (Parent (Op_Decl)) = N_Protected_Definition if
and then Nkind (Parent (Op_Decl)) = N_Protected_Definition
(List_Containing (Op_Decl) =
Visible_Declarations (Parent (Op_Decl))
or else
Is_Interrupt_Handler
(Corresponding_Spec (Op_Body)))
then then
New_Op_Body := New_Op_Body :=
Build_Protected_Subprogram_Body ( Build_Protected_Subprogram_Body (
...@@ -6591,7 +6676,7 @@ package body Exp_Ch9 is ...@@ -6591,7 +6676,7 @@ package body Exp_Ch9 is
-- Generate an overriding primitive operation body for -- Generate an overriding primitive operation body for
-- this subprogram if the protected type implements -- this subprogram if the protected type implements
-- an inerface. -- an interface.
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then Present (Abstract_Interfaces ( and then Present (Abstract_Interfaces (
...@@ -7093,19 +7178,19 @@ package body Exp_Ch9 is ...@@ -7093,19 +7178,19 @@ package body Exp_Ch9 is
Current_Node := Sub; Current_Node := Sub;
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
(Priv, Prottyp, Protected_Mode));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Current_Node := Sub;
if Is_Interrupt_Handler if Is_Interrupt_Handler
(Defining_Unit_Name (Specification (Priv))) (Defining_Unit_Name (Specification (Priv)))
then then
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
(Priv, Prottyp, Protected_Mode));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Current_Node := Sub;
if not Restricted_Profile then if not Restricted_Profile then
Register_Handler; Register_Handler;
end if; end if;
...@@ -8331,7 +8416,7 @@ package body Exp_Ch9 is ...@@ -8331,7 +8416,7 @@ package body Exp_Ch9 is
-- and the parameter references have already been expanded to be direct -- and the parameter references have already been expanded to be direct
-- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore, -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
-- any embedded tasking statements (which would normally be illegal in -- any embedded tasking statements (which would normally be illegal in
-- procedures, have been converted to calls to the tasking runtime so -- procedures), have been converted to calls to the tasking runtime so
-- there is no problem in putting them into procedures. -- there is no problem in putting them into procedures.
-- The original accept statement has been expanded into a block in -- The original accept statement has been expanded into a block in
...@@ -9173,11 +9258,37 @@ package body Exp_Ch9 is ...@@ -9173,11 +9258,37 @@ package body Exp_Ch9 is
Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack); Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack);
if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
Task_Size := Relocate_Node ( declare
Expression (First ( Expr_N : constant Node_Id :=
Pragma_Argument_Associations ( Expression (First (
Find_Task_Or_Protected_Pragma Pragma_Argument_Associations (
(Taskdef, Name_Storage_Size))))); Find_Task_Or_Protected_Pragma
(Taskdef, Name_Storage_Size))));
Etyp : constant Entity_Id := Etype (Expr_N);
P : constant Node_Id := Parent (Expr_N);
begin
-- The stack is defined inside the corresponding record.
-- Therefore if the size of the stack is set by means of
-- a discriminant, we must reference the discriminant of the
-- corresponding record type.
if Nkind (Expr_N) in N_Has_Entity
and then Present (Discriminal_Link (Entity (Expr_N)))
then
Task_Size :=
New_Reference_To
(CR_Discriminant (Discriminal_Link (Entity (Expr_N))),
Loc);
Set_Parent (Task_Size, P);
Set_Etype (Task_Size, Etyp);
Set_Analyzed (Task_Size);
else
Task_Size := Relocate_Node (Expr_N);
end if;
end;
else else
Task_Size := Task_Size :=
New_Reference_To (RTE (RE_Default_Stack_Size), Loc); New_Reference_To (RTE (RE_Default_Stack_Size), Loc);
...@@ -10050,23 +10161,15 @@ package body Exp_Ch9 is ...@@ -10050,23 +10161,15 @@ package body Exp_Ch9 is
function External_Subprogram (E : Entity_Id) return Entity_Id is function External_Subprogram (E : Entity_Id) return Entity_Id is
Subp : constant Entity_Id := Protected_Body_Subprogram (E); Subp : constant Entity_Id := Protected_Body_Subprogram (E);
Decl : constant Node_Id := Unit_Declaration_Node (E);
begin begin
-- If the protected operation is defined in the visible part of the -- The internal and external subprograms follow each other on the
-- protected type, or if it is an interrupt handler, the internal and -- entity chain. Note that previously private operations had no
-- external subprograms follow each other on the entity chain. If the -- separate external subprogram. We now create one in all cases,
-- operation is defined in the private part of the type, there is no -- because a private operation may actually appear in an external
-- need for a separate locking version of the operation, and internal -- call, through a 'Access reference used for a callback.
-- calls use the protected_body_subprogram directly.
return Next_Entity (Subp);
if List_Containing (Decl) = Visible_Declarations (Parent (Decl))
or else Is_Interrupt_Handler (E)
then
return Next_Entity (Subp);
else
return (Subp);
end if;
end External_Subprogram; end External_Subprogram;
------------------------------ ------------------------------
...@@ -10160,14 +10263,19 @@ package body Exp_Ch9 is ...@@ -10160,14 +10263,19 @@ package body Exp_Ch9 is
(Loc : Source_Ptr; (Loc : Source_Ptr;
Hi : Node_Id; Hi : Node_Id;
Lo : Node_Id; Lo : Node_Id;
Ttyp : Entity_Id) return Node_Id Ttyp : Entity_Id;
Cap : Boolean) return Node_Id
is is
Ityp : Entity_Id;
Real_Hi : Node_Id;
Real_Lo : Node_Id;
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-- If one of the bounds is a reference to a discriminant, replace with -- If one of the bounds is a reference to a discriminant, replace with
-- corresponding discriminal of type. Within the body of a task retrieve -- corresponding discriminal of type. Within the body of a task retrieve
-- the renamed discriminant by simple visibility, using its generated -- the renamed discriminant by simple visibility, using its generated
-- name. Within a protected object, find the original dis- criminant and -- name. Within a protected object, find the original discriminant and
-- replace it with the discriminal of the current prot- ected operation. -- replace it with the discriminal of the current protected operation.
------------------------------ ------------------------------
-- Convert_Discriminant_Ref -- -- Convert_Discriminant_Ref --
...@@ -10217,10 +10325,34 @@ package body Exp_Ch9 is ...@@ -10217,10 +10325,34 @@ package body Exp_Ch9 is
-- Start of processing for Family_Offset -- Start of processing for Family_Offset
begin begin
return Real_Hi := Convert_Discriminant_Ref (Hi);
Make_Op_Subtract (Loc, Real_Lo := Convert_Discriminant_Ref (Lo);
Left_Opnd => Convert_Discriminant_Ref (Hi),
Right_Opnd => Convert_Discriminant_Ref (Lo)); if Cap then
if Is_Task_Type (Ttyp) then
Ityp := RTE (RE_Task_Entry_Index);
else
Ityp := RTE (RE_Protected_Entry_Index);
end if;
Real_Hi :=
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ityp, Loc),
Attribute_Name => Name_Min,
Expressions => New_List (
Real_Hi,
Make_Integer_Literal (Loc, Entry_Family_Bound - 1)));
Real_Lo :=
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ityp, Loc),
Attribute_Name => Name_Max,
Expressions => New_List (
Real_Lo,
Make_Integer_Literal (Loc, -Entry_Family_Bound)));
end if;
return Make_Op_Subtract (Loc, Real_Hi, Real_Lo);
end Family_Offset; end Family_Offset;
----------------- -----------------
...@@ -10231,7 +10363,8 @@ package body Exp_Ch9 is ...@@ -10231,7 +10363,8 @@ package body Exp_Ch9 is
(Loc : Source_Ptr; (Loc : Source_Ptr;
Hi : Node_Id; Hi : Node_Id;
Lo : Node_Id; Lo : Node_Id;
Ttyp : Entity_Id) return Node_Id Ttyp : Entity_Id;
Cap : Boolean) return Node_Id
is is
Ityp : Entity_Id; Ityp : Entity_Id;
...@@ -10249,7 +10382,7 @@ package body Exp_Ch9 is ...@@ -10249,7 +10382,7 @@ package body Exp_Ch9 is
Expressions => New_List ( Expressions => New_List (
Make_Op_Add (Loc, Make_Op_Add (Loc,
Left_Opnd => Left_Opnd =>
Family_Offset (Loc, Hi, Lo, Ttyp), Family_Offset (Loc, Hi, Lo, Ttyp, Cap),
Right_Opnd => Right_Opnd =>
Make_Integer_Literal (Loc, 1)), Make_Integer_Literal (Loc, 1)),
Make_Integer_Literal (Loc, 0))); Make_Integer_Literal (Loc, 0)));
...@@ -10328,6 +10461,27 @@ package body Exp_Ch9 is ...@@ -10328,6 +10461,27 @@ package body Exp_Ch9 is
return First_Op; return First_Op;
end First_Protected_Operation; end First_Protected_Operation;
---------------------------------
-- Is_Potentially_Large_Family --
---------------------------------
function Is_Potentially_Large_Family
(Base_Index : Entity_Id;
Conctyp : Entity_Id;
Lo : Node_Id;
Hi : Node_Id) return Boolean
is
begin
return Scope (Base_Index) = Standard_Standard
and then Base_Index = Base_Type (Standard_Integer)
and then Has_Discriminants (Conctyp)
and then Present
(Discriminant_Default_Value (First_Discriminant (Conctyp)))
and then
(Denotes_Discriminant (Lo, True)
or else Denotes_Discriminant (Hi, True));
end Is_Potentially_Large_Family;
-------------------------------- --------------------------------
-- Index_Constant_Declaration -- -- Index_Constant_Declaration --
-------------------------------- --------------------------------
...@@ -11219,8 +11373,16 @@ package body Exp_Ch9 is ...@@ -11219,8 +11373,16 @@ package body Exp_Ch9 is
-- new itype for the corresponding prival in each protected -- new itype for the corresponding prival in each protected
-- operation, to avoid scoping problems. We create new itypes -- operation, to avoid scoping problems. We create new itypes
-- by copying the tree for the component definition. -- by copying the tree for the component definition.
-- (Ada 2005) If the itype is an anonymous access type created
if Is_Itype (Etype (P_Id)) then -- for an access definition for a component, it is declared in
-- the enclosing scope, and we do no create a local version of
-- it, to prevent scoping anomalies in gigi.
if Is_Itype (Etype (P_Id))
and then not
(Is_Access_Type (Etype (P_Id))
and then Is_Local_Anonymous_Access (Etype (P_Id)))
then
Append_Elmt (P_Id, Assoc_L); Append_Elmt (P_Id, Assoc_L);
Append_Elmt (Priv, Assoc_L); Append_Elmt (Priv, Assoc_L);
......
gcc/ada/exp_ch9.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -77,11 +77,7 @@ package Exp_Ch9 is ...@@ -77,11 +77,7 @@ package Exp_Ch9 is
-- (other than allocators to tasks) this routine ensures that an activation -- (other than allocators to tasks) this routine ensures that an activation
-- chain has been declared in the appropriate scope, building the required -- chain has been declared in the appropriate scope, building the required
-- declaration for the chain variable if not. The name of this variable -- declaration for the chain variable if not. The name of this variable
-- is always _Chain and it is accessed by name. This procedure also adds -- is always _Chain and it is accessed by name.
-- an appropriate call to Activate_Tasks to activate the tasks for this
-- activation chain. It does not however deal with the call needed in the
-- case of allocators to Expunge_Unactivated_Tasks, this is separately
-- handled in the Expand_Task_Allocator routine.
function Build_Call_With_Task (N : Node_Id; E : Entity_Id) return Node_Id; function Build_Call_With_Task (N : Node_Id; E : Entity_Id) return Node_Id;
-- N is a node representing the name of a task or an access to a task. -- N is a node representing the name of a task or an access to a task.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment