with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch11; use Exp_Ch11;
with Exp_Ch6; use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug;
with Exp_Smem; use Exp_Smem;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Hostparm;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch11; use Sem_Ch11;
with Sem_Elab; use Sem_Elab;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Types; use Types;
with Uintp; use Uintp;
package body Exp_Ch9 is
function Actual_Index_Expression
(Sloc : Source_Ptr;
Ent : Entity_Id;
Index : Node_Id;
Tsk : Entity_Id) return Node_Id;
function Index_Constant_Declaration
(N : Node_Id;
Index_Id : Entity_Id;
Prot : Entity_Id) return List_Id;
procedure Add_Object_Pointer
(Decls : List_Id;
Pid : Entity_Id;
Loc : Source_Ptr);
function Build_Accept_Body (Astat : Node_Id) return Node_Id;
function Build_Barrier_Function
(N : Node_Id;
Ent : Entity_Id;
Pid : Node_Id) return Node_Id;
function Build_Barrier_Function_Specification
(Def_Id : Entity_Id;
Loc : Source_Ptr) return Node_Id;
function Build_Corresponding_Record
(N : Node_Id;
Ctyp : Node_Id;
Loc : Source_Ptr) return Node_Id;
function Build_Entry_Count_Expression
(Concurrent_Type : Node_Id;
Component_List : List_Id;
Loc : Source_Ptr) return Node_Id;
function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
function Build_Protected_Entry
(N : Node_Id;
Ent : Entity_Id;
Pid : Node_Id) return Node_Id;
function Build_Protected_Entry_Specification
(Def_Id : Entity_Id;
Ent_Id : Entity_Id;
Loc : Source_Ptr) return Node_Id;
function Build_Protected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id;
function Build_Protected_Spec
(N : Node_Id;
Obj_Type : Entity_Id;
Unprotected : Boolean := False;
Ident : Entity_Id) return List_Id;
function Build_Selected_Name
(Prefix, Selector : Name_Id;
Append_Char : Character := ' ') return Name_Id;
procedure Build_Simple_Entry_Call
(N : Node_Id;
Concval : Node_Id;
Ename : Node_Id;
Index : Node_Id);
function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id;
function Build_Unprotected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id) return Node_Id;
procedure Collect_Entry_Families
(Loc : Source_Ptr;
Cdecls : List_Id;
Current_Node : in out Node_Id;
Conctyp : Entity_Id);
function Family_Offset
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
Ttyp : Entity_Id) return Node_Id;
function Family_Size
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
Ttyp : Entity_Id) return Node_Id;
procedure Extract_Entry
(N : Node_Id;
Concval : out Node_Id;
Ename : out Node_Id;
Index : out Node_Id);
function Find_Task_Or_Protected_Pragma
(T : Node_Id;
P : Name_Id) return Node_Id;
procedure Update_Prival_Subtypes (N : Node_Id);
function Actual_Index_Expression
(Sloc : Source_Ptr;
Ent : Entity_Id;
Index : Node_Id;
Tsk : Entity_Id) return Node_Id
is
Ttyp : constant Entity_Id := Etype (Tsk);
Expr : Node_Id;
Num : Node_Id;
Lo : Node_Id;
Hi : Node_Id;
Prev : Entity_Id;
S : Node_Id;
function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id;
function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
Typ : constant Entity_Id := Etype (Bound);
B : Node_Id;
begin
if not Is_Entity_Name (Bound)
or else Ekind (Entity (Bound)) /= E_Discriminant
then
if Nkind (Bound) = N_Attribute_Reference then
return Bound;
else
B := New_Copy_Tree (Bound);
end if;
else
B :=
Make_Selected_Component (Sloc,
Prefix => New_Copy_Tree (Tsk),
Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc));
Analyze_And_Resolve (B, Typ);
end if;
return
Make_Attribute_Reference (Sloc,
Attribute_Name => Name_Pos,
Prefix => New_Occurrence_Of (Etype (Bound), Sloc),
Expressions => New_List (B));
end Actual_Discriminant_Ref;
begin
return
Make_Op_Subtract (Sloc,
Left_Opnd => Actual_Discriminant_Ref (Hi),
Right_Opnd => Actual_Discriminant_Ref (Lo));
end Actual_Family_Offset;
begin
Num := Make_Integer_Literal (Sloc, 1);
if Present (Index) then
S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
Expr :=
Make_Op_Add (Sloc,
Left_Opnd => Num,
Right_Opnd =>
Actual_Family_Offset (
Make_Attribute_Reference (Sloc,
Attribute_Name => Name_Pos,
Prefix => New_Reference_To (Base_Type (S), Sloc),
Expressions => New_List (Relocate_Node (Index))),
Type_Low_Bound (S)));
else
Expr := Num;
end if;
Prev := First_Entity (Ttyp);
while Chars (Prev) /= Chars (Ent)
or else (Ekind (Prev) /= Ekind (Ent))
or else not Sem_Ch6.Type_Conformant (Ent, Prev)
loop
if Ekind (Prev) = E_Entry then
Set_Intval (Num, Intval (Num) + 1);
elsif Ekind (Prev) = E_Entry_Family then
S :=
Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
Lo := Type_Low_Bound (S);
Hi := Type_High_Bound (S);
Expr :=
Make_Op_Add (Sloc,
Left_Opnd => Expr,
Right_Opnd =>
Make_Op_Add (Sloc,
Left_Opnd =>
Actual_Family_Offset (Hi, Lo),
Right_Opnd =>
Make_Integer_Literal (Sloc, 1)));
else
null;
end if;
Next_Entity (Prev);
end loop;
return Expr;
end Actual_Index_Expression;
procedure Add_Discriminal_Declarations
(Decls : List_Id;
Typ : Entity_Id;
Name : Name_Id;
Loc : Source_Ptr)
is
D : Entity_Id;
begin
if Has_Discriminants (Typ) then
D := First_Discriminant (Typ);
while Present (D) loop
Prepend_To (Decls,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Discriminal (D),
Subtype_Mark => New_Reference_To (Etype (D), Loc),
Name =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name),
Selector_Name => Make_Identifier (Loc, Chars (D)))));
Next_Discriminant (D);
end loop;
end if;
end Add_Discriminal_Declarations;
procedure Add_Object_Pointer
(Decls : List_Id;
Pid : Entity_Id;
Loc : Source_Ptr)
is
Obj_Ptr : Node_Id;
begin
Obj_Ptr :=
Make_Defining_Identifier (Loc,
Chars =>
New_External_Name
(Chars (Corresponding_Record_Type (Pid)), 'P'));
Prepend_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uObject),
Object_Definition => New_Reference_To (Obj_Ptr, Loc),
Expression =>
Unchecked_Convert_To (Obj_Ptr,
Make_Identifier (Loc, Name_uO))));
Prepend_To (Decls,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Obj_Ptr,
Type_Definition => Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Reference_To (Corresponding_Record_Type (Pid), Loc))));
end Add_Object_Pointer;
procedure Add_Private_Declarations
(Decls : List_Id;
Typ : Entity_Id;
Name : Name_Id;
Loc : Source_Ptr)
is
Def : constant Node_Id := Protected_Definition (Parent (Typ));
Body_Ent : constant Entity_Id := Corresponding_Body (Parent (Typ));
P : Node_Id;
Pdef : Entity_Id;
begin
pragma Assert (Nkind (Def) = N_Protected_Definition);
if Present (Private_Declarations (Def)) then
P := First (Private_Declarations (Def));
while Present (P) loop
if Nkind (P) = N_Component_Declaration then
Pdef := Defining_Identifier (P);
Prepend_To (Decls,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Prival (Pdef),
Subtype_Mark => New_Reference_To (Etype (Pdef), Loc),
Name =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name),
Selector_Name => Make_Identifier (Loc, Chars (Pdef)))));
end if;
Next (P);
end loop;
end if;
declare
Protection_Type : RE_Id;
begin
if Has_Attach_Handler (Typ) then
if Restricted_Profile then
if Has_Entries (Typ) then
Protection_Type := RE_Protection_Entry;
else
Protection_Type := RE_Protection;
end if;
else
Protection_Type := RE_Static_Interrupt_Protection;
end if;
elsif Has_Interrupt_Handler (Typ) then
Protection_Type := RE_Dynamic_Interrupt_Protection;
elsif Has_Entries (Typ) then
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Typ) > 1
then
Protection_Type := RE_Protection_Entries;
else
Protection_Type := RE_Protection_Entry;
end if;
else
Protection_Type := RE_Protection;
end if;
Prepend_To (Decls,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Object_Ref (Body_Ent),
Subtype_Mark => New_Reference_To (RTE (Protection_Type), Loc),
Name =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name),
Selector_Name => Make_Identifier (Loc, Name_uObject))));
end;
end Add_Private_Declarations;
function Build_Accept_Body (Astat : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Astat);
Stats : constant Node_Id := Handled_Statement_Sequence (Astat);
New_S : Node_Id;
Hand : Node_Id;
Call : Node_Id;
Ohandle : Node_Id;
begin
Call := Build_Runtime_Call (Loc, RE_Complete_Rendezvous);
Insert_Before (Last (Statements (Stats)), Call);
Analyze (Call);
if Present (Exception_Handlers (Stats)) then
Hand := First (Exception_Handlers (Stats));
while Present (Hand) loop
Call := Build_Runtime_Call (Loc, RE_Complete_Rendezvous);
Append (Call, Statements (Hand));
Analyze (Call);
Next (Hand);
end loop;
New_S :=
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence => Stats)));
else
New_S := Stats;
end if;
Ohandle := Make_Others_Choice (Loc);
Set_All_Others (Ohandle);
Set_Exception_Handlers (New_S,
New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (Ohandle),
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
RTE (RE_Exceptional_Complete_Rendezvous), Loc),
Parameter_Associations => New_List (
Make_Function_Call (Loc,
Name => New_Reference_To (
RTE (RE_Get_GNAT_Exception), Loc))))))));
Set_Parent (New_S, Astat); Analyze_Exception_Handlers (Exception_Handlers (New_S));
Expand_Exception_Handlers (New_S);
return New_S;
end Build_Accept_Body;
procedure Build_Activation_Chain_Entity (N : Node_Id) is
P : Node_Id;
B : Node_Id;
Decls : List_Id;
begin
P := Parent (N);
while Nkind (P) /= N_Subprogram_Body
and then Nkind (P) /= N_Package_Declaration
and then Nkind (P) /= N_Package_Body
and then Nkind (P) /= N_Block_Statement
and then Nkind (P) /= N_Task_Body
loop
P := Parent (P);
end loop;
B := P;
if Nkind (P) = N_Package_Body then
P := Unit_Declaration_Node (Corresponding_Spec (P));
Decls := Declarations (B);
elsif Nkind (P) = N_Package_Declaration then
Decls := Visible_Declarations (Specification (B));
else
Decls := Declarations (B);
end if;
if No (Activation_Chain_Entity (P)) then
Set_Activation_Chain_Entity
(P, Make_Defining_Identifier (Sloc (N), Name_uChain));
Prepend_To (Decls,
Make_Object_Declaration (Sloc (P),
Defining_Identifier => Activation_Chain_Entity (P),
Aliased_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Activation_Chain), Sloc (P))));
Analyze (First (Decls));
end if;
end Build_Activation_Chain_Entity;
function Build_Barrier_Function
(N : Node_Id;
Ent : Entity_Id;
Pid : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N);
Index_Spec : constant Node_Id := Entry_Index_Specification
(Ent_Formals);
Op_Decls : constant List_Id := New_List;
Bdef : Entity_Id;
Bspec : Node_Id;
begin
Bdef :=
Make_Defining_Identifier (Loc, Chars (Barrier_Function (Ent)));
Bspec := Build_Barrier_Function_Specification (Bdef, Loc);
Add_Discriminal_Declarations (Op_Decls, Pid, Name_uObject, Loc);
Add_Private_Declarations (Op_Decls, Pid, Name_uObject, Loc);
Add_Object_Pointer (Op_Decls, Pid, Loc);
if Present (Index_Spec) then
declare
Index_Id : constant Entity_Id := Defining_Identifier (Index_Spec);
Index_Con : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('J'));
begin
Set_Entry_Index_Constant (Index_Id, Index_Con);
Append_List_To (Op_Decls,
Index_Constant_Declaration (N, Index_Id, Pid));
end;
end if;
return
Make_Subprogram_Body (Loc,
Specification => Bspec,
Declarations => Op_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Return_Statement (Loc,
Expression => Condition (Ent_Formals)))));
end Build_Barrier_Function;
function Build_Barrier_Function_Specification
(Def_Id : Entity_Id;
Loc : Source_Ptr) return Node_Id
is
begin
Set_Needs_Debug_Info (Def_Id);
return Make_Function_Specification (Loc,
Defining_Unit_Name => Def_Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE),
Parameter_Type =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc));
end Build_Barrier_Function_Specification;
function Build_Call_With_Task
(N : Node_Id;
E : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
begin
return
Make_Function_Call (Loc,
Name => New_Reference_To (E, Loc),
Parameter_Associations => New_List (Concurrent_Ref (N)));
end Build_Call_With_Task;
function Build_Corresponding_Record
(N : Node_Id;
Ctyp : Entity_Id;
Loc : Source_Ptr) return Node_Id
is
Rec_Ent : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_External_Name (Chars (Ctyp), 'V'));
Disc : Entity_Id;
Dlist : List_Id;
New_Disc : Entity_Id;
Cdecls : List_Id;
begin
Set_Corresponding_Record_Type (Ctyp, Rec_Ent);
Set_Ekind (Rec_Ent, E_Record_Type);
Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp));
Set_Is_Concurrent_Record_Type (Rec_Ent, True);
Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp);
Set_Stored_Constraint (Rec_Ent, No_Elist);
Cdecls := New_List;
if Present (Discriminant_Specifications (N)) then
Dlist := New_List;
Disc := First_Discriminant (Ctyp);
while Present (Disc) loop
New_Disc := CR_Discriminant (Disc);
Append_To (Dlist,
Make_Discriminant_Specification (Loc,
Defining_Identifier => New_Disc,
Discriminant_Type =>
New_Occurrence_Of (Etype (Disc), Loc),
Expression =>
New_Copy (Discriminant_Default_Value (Disc))));
Next_Discriminant (Disc);
end loop;
else
Dlist := No_List;
end if;
return
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Rec_Ent,
Discriminant_Specifications => Dlist,
Type_Definition =>
Make_Record_Definition (Loc,
Component_List =>
Make_Component_List (Loc,
Component_Items => Cdecls),
Limited_Present => True));
end Build_Corresponding_Record;
function Build_Entry_Count_Expression
(Concurrent_Type : Node_Id;
Component_List : List_Id;
Loc : Source_Ptr) return Node_Id
is
Eindx : Nat;
Ent : Entity_Id;
Ecount : Node_Id;
Comp : Node_Id;
Lo : Node_Id;
Hi : Node_Id;
Typ : Entity_Id;
begin
Ent := First_Entity (Concurrent_Type);
Eindx := 0;
while Present (Ent) loop
if Ekind (Ent) = E_Entry then
Eindx := Eindx + 1;
end if;
Next_Entity (Ent);
end loop;
Ecount := Make_Integer_Literal (Loc, Eindx);
Ent := First_Entity (Concurrent_Type);
Comp := First (Component_List);
while Present (Ent) loop
if Ekind (Ent) = E_Entry_Family then
while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop
Next (Comp);
end loop;
Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
Hi := Type_High_Bound (Typ);
Lo := Type_Low_Bound (Typ);
Ecount :=
Make_Op_Add (Loc,
Left_Opnd => Ecount,
Right_Opnd => Family_Size (Loc, Hi, Lo, Concurrent_Type));
end if;
Next_Entity (Ent);
end loop;
return Ecount;
end Build_Entry_Count_Expression;
function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Ent : Entity_Id;
E_Typ : Entity_Id;
Has_F : Boolean := False;
Index : Nat;
If_St : Node_Id := Empty;
Lo : Node_Id;
Hi : Node_Id;
Decls : List_Id := New_List;
Ret : Node_Id;
Spec : Node_Id;
Siz : Node_Id := Empty;
procedure Add_If_Clause (Expr : Node_Id);
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
procedure Add_If_Clause (Expr : Node_Id) is
Cond : Node_Id;
Stats : constant List_Id :=
New_List (
Make_Return_Statement (Loc,
Expression => Make_Integer_Literal (Loc, Index + 1)));
begin
Index := Index + 1;
if No (Siz) then
Siz := Expr;
else
Siz :=
Make_Op_Add (Loc,
Left_Opnd => Siz,
Right_Opnd => Expr);
end if;
Cond :=
Make_Op_Le (Loc,
Left_Opnd => Make_Identifier (Loc, Name_uE),
Right_Opnd => Siz);
if No (If_St) then
If_St :=
Make_Implicit_If_Statement (Typ,
Condition => Cond,
Then_Statements => Stats,
Elsif_Parts => New_List);
Ret := If_St;
else
Append (
Make_Elsif_Part (Loc,
Condition => Cond,
Then_Statements => Stats),
Elsif_Parts (If_St));
end if;
end Add_If_Clause;
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
B : Node_Id;
begin
if Is_Entity_Name (Bound)
and then Ekind (Entity (Bound)) = E_Discriminant
then
B :=
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Corresponding_Record_Type (Typ),
Make_Explicit_Dereference (Loc,
Make_Identifier (Loc, Name_uObject))),
Selector_Name => Make_Identifier (Loc, Chars (Bound)));
Set_Etype (B, Etype (Entity (Bound)));
else
B := New_Copy_Tree (Bound);
end if;
return B;
end Convert_Discriminant_Ref;
begin
Spec := Build_Find_Body_Index_Spec (Typ);
Ent := First_Entity (Typ);
while Present (Ent) loop
if Ekind (Ent) = E_Entry_Family then
Has_F := True;
exit;
end if;
Next_Entity (Ent);
end loop;
if not Has_F then
Ret :=
Make_Return_Statement (Loc,
Expression => Make_Identifier (Loc, Name_uE));
else
Index := 0;
Siz := Empty;
Ent := First_Entity (Typ);
Add_Object_Pointer (Decls, Typ, Loc);
while Present (Ent) loop
if Ekind (Ent) = E_Entry then
Add_If_Clause (Make_Integer_Literal (Loc, 1));
elsif Ekind (Ent) = E_Entry_Family then
E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ));
Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ));
Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ));
end if;
Next_Entity (Ent);
end loop;
if Index = 1 then
Decls := New_List;
Ret :=
Make_Return_Statement (Loc,
Expression => Make_Integer_Literal (Loc, 1));
elsif Nkind (Ret) = N_If_Statement then
declare
Nod : constant Node_Id := Last (Elsif_Parts (Ret));
begin
Remove (Nod);
Set_Else_Statements (Ret, Then_Statements (Nod));
end;
end if;
end if;
return
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Ret)));
end Build_Find_Body_Index;
function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), 'F'));
Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO);
Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE);
begin
return
Make_Function_Specification (Loc,
Defining_Unit_Name => Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Parm1,
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Parm2,
Parameter_Type =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
Subtype_Mark => New_Occurrence_Of (
RTE (RE_Protected_Entry_Index), Loc));
end Build_Find_Body_Index_Spec;
procedure Build_Master_Entity (E : Entity_Id) is
Loc : constant Source_Ptr := Sloc (E);
P : Node_Id;
Decl : Node_Id;
S : Entity_Id;
begin
S := Scope (E);
if Ada_Version >= Ada_05 then
while Is_Internal (S) loop
S := Scope (S);
end loop;
end if;
if Has_Master_Entity (S)
or else Restriction_Active (No_Task_Hierarchy)
then
return;
end if;
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uMaster),
Constant_Present => True,
Object_Definition => New_Reference_To (RTE (RE_Master_Id), Loc),
Expression =>
Make_Explicit_Dereference (Loc,
New_Reference_To (RTE (RE_Current_Master), Loc)));
P := Parent (E);
Insert_Before (P, Decl);
Analyze (Decl);
if Ada_Version >= Ada_05 then
Set_Has_Master_Entity (S);
else
Set_Has_Master_Entity (Scope (E));
end if;
while Nkind (P) /= N_Compilation_Unit loop
P := Parent (P);
if Nkind (P) = N_Task_Body
or else Nkind (P) = N_Block_Statement
or else Nkind (P) = N_Subprogram_Body
then
Set_Is_Task_Master (P, True);
return;
elsif Nkind (Parent (P)) = N_Subunit then
P := Corresponding_Stub (Parent (P));
end if;
end loop;
end Build_Master_Entity;
function Build_Protected_Entry
(N : Node_Id;
Ent : Entity_Id;
Pid : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Op_Decls : constant List_Id := New_List;
Edef : Entity_Id;
Espec : Node_Id;
Op_Stats : List_Id;
Ohandle : Node_Id;
Complete : Node_Id;
begin
Edef :=
Make_Defining_Identifier (Loc,
Chars => Chars (Protected_Body_Subprogram (Ent)));
Espec := Build_Protected_Entry_Specification (Edef, Empty, Loc);
Add_Object_Pointer (Op_Decls, Pid, Loc);
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Pid) > 1
then
Complete := New_Reference_To (RTE (RE_Complete_Entry_Body), Loc);
else
Complete :=
New_Reference_To (RTE (RE_Complete_Single_Entry_Body), Loc);
end if;
Op_Stats := New_List (
Make_Block_Statement (Loc,
Declarations => Declarations (N),
Handled_Statement_Sequence =>
Handled_Statement_Sequence (N)),
Make_Procedure_Call_Statement (Loc,
Name => Complete,
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uObject),
Selector_Name =>
Make_Identifier (Loc, Name_uObject)),
Attribute_Name => Name_Unchecked_Access))));
if Restriction_Active (No_Exception_Handlers) then
return
Make_Subprogram_Body (Loc,
Specification => Espec,
Declarations => Op_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Op_Stats));
else
Ohandle := Make_Others_Choice (Loc);
Set_All_Others (Ohandle);
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Pid) > 1
then
Complete :=
New_Reference_To (RTE (RE_Exceptional_Complete_Entry_Body), Loc);
else
Complete := New_Reference_To (
RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc);
end if;
return
Make_Subprogram_Body (Loc,
Specification => Espec,
Declarations => Op_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Op_Stats,
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (Ohandle),
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => Complete,
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uObject),
Selector_Name =>
Make_Identifier (Loc, Name_uObject)),
Attribute_Name => Name_Unchecked_Access),
Make_Function_Call (Loc,
Name => New_Reference_To (
RTE (RE_Get_GNAT_Exception), Loc)))))))));
end if;
end Build_Protected_Entry;
function Build_Protected_Entry_Specification
(Def_Id : Entity_Id;
Ent_Id : Entity_Id;
Loc : Source_Ptr) return Node_Id
is
P : Entity_Id;
begin
Set_Needs_Debug_Info (Def_Id);
P := Make_Defining_Identifier (Loc, Name_uP);
if Present (Ent_Id) then
Append_Elmt (P, Accept_Address (Ent_Id));
end if;
return Make_Procedure_Specification (Loc,
Defining_Unit_Name => Def_Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => P,
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE),
Parameter_Type =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))));
end Build_Protected_Entry_Specification;
function Build_Protected_Spec
(N : Node_Id;
Obj_Type : Entity_Id;
Unprotected : Boolean := False;
Ident : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
Formal : Entity_Id;
New_Plist : List_Id;
New_Param : Node_Id;
begin
New_Plist := New_List;
Formal := First_Formal (Ident);
while Present (Formal) loop
New_Param :=
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
In_Present => In_Present (Parent (Formal)),
Out_Present => Out_Present (Parent (Formal)),
Parameter_Type =>
New_Reference_To (Etype (Formal), Loc));
if Unprotected then
Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
end if;
Append (New_Param, New_Plist);
Next_Formal (Formal);
end loop;
Prepend_To (New_Plist,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uObject),
In_Present => True,
Out_Present =>
(Etype (Ident) = Standard_Void_Type
and then not Is_RTE (Obj_Type, RE_Address)),
Parameter_Type => New_Reference_To (Obj_Type, Loc)));
return New_Plist;
end Build_Protected_Spec;
function Build_Protected_Sub_Specification
(N : Node_Id;
Prottyp : Entity_Id;
Unprotected : Boolean := False) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Decl : Node_Id;
Protnm : constant Name_Id := Chars (Prottyp);
Ident : Entity_Id;
Nam : Name_Id;
New_Id : Entity_Id;
New_Plist : List_Id;
Append_Char : Character;
New_Spec : Node_Id;
begin
if Ekind
(Defining_Unit_Name (Specification (N))) = E_Subprogram_Body
then
Decl := Unit_Declaration_Node (Corresponding_Spec (N));
else
Decl := N;
end if;
Ident := Defining_Unit_Name (Specification (Decl));
Nam := Chars (Ident);
New_Plist := Build_Protected_Spec
(Decl, Corresponding_Record_Type (Prottyp),
Unprotected, Ident);
if Unprotected then
Append_Char := 'N';
else
Append_Char := 'P';
end if;
New_Id :=
Make_Defining_Identifier (Loc,
Chars => Build_Selected_Name (Protnm, Nam, Append_Char));
Set_Needs_Debug_Info (New_Id);
if Nkind (Specification (Decl)) = N_Procedure_Specification then
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name => New_Id,
Parameter_Specifications => New_Plist);
else
New_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => New_Id,
Parameter_Specifications => New_Plist,
Subtype_Mark => New_Copy (Subtype_Mark (Specification (Decl))));
Set_Return_Present (Defining_Unit_Name (New_Spec));
return New_Spec;
end if;
end Build_Protected_Sub_Specification;
function Build_Protected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Op_Spec : Node_Id;
P_Op_Spec : Node_Id;
Uactuals : List_Id;
Pformal : Node_Id;
Unprot_Call : Node_Id;
Sub_Body : Node_Id;
Lock_Name : Node_Id;
Lock_Stmt : Node_Id;
Service_Name : Node_Id;
R : Node_Id;
Return_Stmt : Node_Id := Empty; Pre_Stmts : List_Id := No_List; Stmts : List_Id;
Object_Parm : Node_Id;
Exc_Safe : Boolean;
function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is
function Has_Side_Effect (N : Node_Id) return Boolean;
function Has_Side_Effect (N : Node_Id) return Boolean is
Stmt : Node_Id := N;
Expr : Node_Id;
function Is_Call_Or_Raise (N : Node_Id) return Boolean;
function Is_Call_Or_Raise (N : Node_Id) return Boolean is
begin
return Nkind (N) = N_Procedure_Call_Statement
or else Nkind (N) = N_Function_Call
or else Nkind (N) = N_Raise_Statement
or else Nkind (N) = N_Raise_Constraint_Error
or else Nkind (N) = N_Raise_Program_Error
or else Nkind (N) = N_Raise_Storage_Error;
end Is_Call_Or_Raise;
begin
while Present (Stmt) loop
if Is_Call_Or_Raise (Stmt) then
return True;
end if;
if Nkind (Stmt) = N_Object_Declaration then
Expr := Expression (Stmt);
if Present (Expr) and then Is_Call_Or_Raise (Expr) then
return True;
end if;
end if;
Next (Stmt);
end loop;
return False;
end Has_Side_Effect;
begin
if not Access_Checks_Suppressed (Empty)
or else not Discriminant_Checks_Suppressed (Empty)
or else not Range_Checks_Suppressed (Empty)
or else not Index_Checks_Suppressed (Empty)
or else Opt.Stack_Checking_Enabled
then
return False;
end if;
if Has_Side_Effect (First (Declarations (Subprogram)))
or else
Has_Side_Effect (
First (Statements (Handled_Statement_Sequence (Subprogram))))
then
return False;
else
return True;
end if;
end Is_Exception_Safe;
begin
Op_Spec := Specification (N);
Exc_Safe := Is_Exception_Safe (N);
P_Op_Spec :=
Build_Protected_Sub_Specification (N,
Pid, Unprotected => False);
Uactuals := New_List;
Pformal := First (Parameter_Specifications (P_Op_Spec));
while Present (Pformal) loop
Append (
Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))),
Uactuals);
Next (Pformal);
end loop;
if Nkind (Op_Spec) = N_Function_Specification then
if Exc_Safe then
R := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Unprot_Call :=
Make_Object_Declaration (Loc,
Defining_Identifier => R,
Constant_Present => True,
Object_Definition => New_Copy (Subtype_Mark (N_Op_Spec)),
Expression =>
Make_Function_Call (Loc,
Name => Make_Identifier (Loc,
Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals));
Return_Stmt := Make_Return_Statement (Loc,
Expression => New_Reference_To (R, Loc));
else
Unprot_Call := Make_Return_Statement (Loc,
Expression => Make_Function_Call (Loc,
Name =>
Make_Identifier (Loc,
Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals));
end if;
else
Unprot_Call := Make_Procedure_Call_Statement (Loc,
Name =>
Make_Identifier (Loc,
Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals);
end if;
if not Exc_Safe then
Unprot_Call := Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Unprot_Call)));
end if;
if Has_Entries (Pid)
or else Has_Interrupt_Handler (Pid)
or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
then
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Pid) > 1
then
Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc);
Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc);
else
Lock_Name := New_Reference_To (RTE (RE_Lock_Entry), Loc);
Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
end if;
else
Lock_Name := New_Reference_To (RTE (RE_Lock), Loc);
Service_Name := New_Reference_To (RTE (RE_Unlock), Loc);
end if;
Object_Parm :=
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uObject),
Selector_Name =>
Make_Identifier (Loc, Name_uObject)),
Attribute_Name => Name_Unchecked_Access);
Lock_Stmt := Make_Procedure_Call_Statement (Loc,
Name => Lock_Name,
Parameter_Associations => New_List (Object_Parm));
if Abort_Allowed then
Stmts := New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Defer), Loc),
Parameter_Associations => Empty_List),
Lock_Stmt);
else
Stmts := New_List (Lock_Stmt);
end if;
if not Exc_Safe then
Append (Unprot_Call, Stmts);
else
if Nkind (Op_Spec) = N_Function_Specification then
Pre_Stmts := Stmts;
Stmts := Empty_List;
else
Append (Unprot_Call, Stmts);
end if;
Append (
Make_Procedure_Call_Statement (Loc,
Name => Service_Name,
Parameter_Associations =>
New_List (New_Copy_Tree (Object_Parm))),
Stmts);
if Abort_Allowed then
Append (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc),
Parameter_Associations => Empty_List),
Stmts);
end if;
if Nkind (Op_Spec) = N_Function_Specification then
Append (Return_Stmt, Stmts);
Append (Make_Block_Statement (Loc,
Declarations => New_List (Unprot_Call),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts)), Pre_Stmts);
Stmts := Pre_Stmts;
end if;
end if;
Sub_Body :=
Make_Subprogram_Body (Loc,
Declarations => Empty_List,
Specification => P_Op_Spec,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
if not Exc_Safe then
Set_Is_Protected_Subprogram_Body (Sub_Body);
end if;
return Sub_Body;
end Build_Protected_Subprogram_Body;
procedure Build_Protected_Subprogram_Call
(N : Node_Id;
Name : Node_Id;
Rec : Node_Id;
External : Boolean := True)
is
Loc : constant Source_Ptr := Sloc (N);
Sub : constant Entity_Id := Entity (Name);
New_Sub : Node_Id;
Params : List_Id;
begin
if External then
New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc);
else
New_Sub :=
New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc);
end if;
if Present (Parameter_Associations (N)) then
Params := New_Copy_List_Tree (Parameter_Associations (N));
else
Params := New_List;
end if;
Prepend (Rec, Params);
if Ekind (Sub) = E_Procedure then
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Sub,
Parameter_Associations => Params));
else
pragma Assert (Ekind (Sub) = E_Function);
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Sub,
Parameter_Associations => Params));
end if;
if External
and then Nkind (Rec) = N_Unchecked_Type_Conversion
and then Is_Entity_Name (Expression (Rec))
and then Is_Shared_Passive (Entity (Expression (Rec)))
then
Add_Shared_Var_Lock_Procs (N);
end if;
end Build_Protected_Subprogram_Call;
function Build_Selected_Name
(Prefix, Selector : Name_Id;
Append_Char : Character := ' ') return Name_Id
is
Select_Buffer : String (1 .. Hostparm.Max_Name_Length);
Select_Len : Natural;
begin
Get_Name_String (Selector);
Select_Len := Name_Len;
Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len);
Get_Name_String (Prefix);
if Name_Buffer (Name_Len) = 'T' then
Name_Len := Name_Len - 1;
end if;
Name_Buffer (Name_Len + 1) := '_';
Name_Buffer (Name_Len + 2) := '_';
Name_Len := Name_Len + 2;
for J in 1 .. Select_Len loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Select_Buffer (J);
end loop;
if Append_Char /= ' ' then
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Append_Char;
end if;
return Name_Find;
end Build_Selected_Name;
procedure Build_Simple_Entry_Call
(N : Node_Id;
Concval : Node_Id;
Ename : Node_Id;
Index : Node_Id)
is
begin
Expand_Call (N);
declare
Loc : constant Source_Ptr := Sloc (N);
Parms : constant List_Id := Parameter_Associations (N);
Stats : constant List_Id := New_List;
Pdecl : Node_Id;
Xdecl : Node_Id;
Decls : List_Id;
Conctyp : Node_Id;
Ent : Entity_Id;
Ent_Acc : Entity_Id;
P : Entity_Id;
X : Entity_Id;
Plist : List_Id;
Parm1 : Node_Id;
Parm2 : Node_Id;
Parm3 : Node_Id;
Call : Node_Id;
Actual : Node_Id;
Formal : Node_Id;
N_Node : Node_Id;
N_Var : Node_Id;
Comm_Name : Entity_Id;
begin
Ent := Entity (Ename);
Ent_Acc := Entry_Parameters_Type (Ent);
Conctyp := Etype (Concval);
if Is_Access_Type (Conctyp) then
Conctyp := Designated_Type (Conctyp);
end if;
if Is_Protected_Type (Conctyp)
and then Is_Subprogram (Entity (Ename))
then
if not Is_Eliminated (Entity (Ename)) then
Build_Protected_Subprogram_Call
(N, Ename, Convert_Concurrent (Concval, Conctyp));
Analyze (N);
end if;
return;
end if;
Parm1 := Concurrent_Ref (Concval);
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else not Is_Protected_Type (Conctyp)
or else Number_Entries (Conctyp) > 1
then
X := Make_Defining_Identifier (Loc, Name_uX);
Xdecl :=
Make_Object_Declaration (Loc,
Defining_Identifier => X,
Object_Definition =>
New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
Expression => Actual_Index_Expression (
Loc, Entity (Ename), Index, Concval));
Decls := New_List (Xdecl);
Parm2 := New_Reference_To (X, Loc);
else
Xdecl := Empty;
Decls := New_List;
Parm2 := Empty;
end if;
if No (Parms) then
Parm3 := New_Reference_To (RTE (RE_Null_Address), Loc);
P := Empty;
else
Plist := New_List;
Actual := First_Actual (N);
Formal := First_Formal (Ent);
while Present (Actual) loop
if Is_By_Copy_Type (Etype (Actual)) then
N_Node :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('J')),
Aliased_Present => True,
Object_Definition =>
New_Reference_To (Etype (Formal), Loc));
if Ekind (Formal) /= E_Out_Parameter then
N_Var :=
New_Reference_To (Defining_Identifier (N_Node), Loc);
Set_Assignment_OK (N_Var);
Append_To (Stats,
Make_Assignment_Statement (Loc,
Name => N_Var,
Expression => Relocate_Node (Actual)));
end if;
Append (N_Node, Decls);
Append_To (Plist,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Prefix =>
New_Reference_To (Defining_Identifier (N_Node), Loc)));
else
Append_To (Plist,
Make_Reference (Loc, Prefix => Relocate_Node (Actual)));
end if;
Next_Actual (Actual);
Next_Formal_With_Extras (Formal);
end loop;
P := Make_Defining_Identifier (Loc, Name_uP);
Pdecl :=
Make_Object_Declaration (Loc,
Defining_Identifier => P,
Object_Definition =>
New_Reference_To (Designated_Type (Ent_Acc), Loc),
Expression =>
Make_Aggregate (Loc, Expressions => Plist));
Parm3 :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
Prefix => New_Reference_To (P, Loc));
Append (Pdecl, Decls);
end if;
if Is_Protected_Type (Conctyp) then
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Conctyp) > 1
then
Set_Object_Definition (Xdecl,
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc));
if No (Decls) then
Decls := New_List;
end if;
Comm_Name :=
Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Comm_Name,
Object_Definition =>
New_Reference_To (RTE (RE_Communication_Block), Loc)));
Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Prefix => Parm1),
Parm2,
Parm3,
New_Reference_To (RTE (RE_Simple_Call), Loc),
New_Occurrence_Of (Comm_Name, Loc)));
else
Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
RTE (RE_Protected_Single_Entry_Call), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Prefix => Parm1),
Parm3,
New_Reference_To (RTE (RE_Simple_Call), Loc)));
end if;
else
Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Call_Simple), Loc),
Parameter_Associations => New_List (Parm1, Parm2, Parm3));
end if;
Append_To (Stats, Call);
if Present (Parms) then
Actual := First_Actual (N);
Formal := First_Formal (Ent);
Set_Assignment_OK (Actual);
while Present (Actual) loop
if Is_By_Copy_Type (Etype (Actual))
and then Ekind (Formal) /= E_In_Parameter
then
N_Node :=
Make_Assignment_Statement (Loc,
Name => New_Copy (Actual),
Expression =>
Make_Explicit_Dereference (Loc,
Make_Selected_Component (Loc,
Prefix => New_Reference_To (P, Loc),
Selector_Name =>
Make_Identifier (Loc, Chars (Formal)))));
Set_Assignment_OK (Name (N_Node));
if (Nkind (Parent (N)) = N_Triggering_Alternative
and then N = Triggering_Statement (Parent (N)))
or else
(Nkind (Parent (N)) = N_Entry_Call_Alternative
and then N = Entry_Call_Statement (Parent (N)))
then
if No (Statements (Parent (N))) then
Set_Statements (Parent (N), New_List);
end if;
Prepend (N_Node, Statements (Parent (N)));
else
Insert_After (Call, N_Node);
end if;
end if;
Next_Actual (Actual);
Next_Formal_With_Extras (Formal);
end loop;
end if;
Rewrite (N,
Make_Block_Statement (Loc,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stats)));
Analyze (N);
end;
end Build_Simple_Entry_Call;
procedure Build_Task_Activation_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Chain : Entity_Id;
Call : Node_Id;
Name : Node_Id;
P : Node_Id;
begin
if Nkind (N) = N_Package_Body then
P := Corresponding_Spec (N);
loop
P := Parent (P);
exit when Nkind (P) = N_Package_Declaration;
end loop;
Chain := Activation_Chain_Entity (P);
else
Chain := Activation_Chain_Entity (N);
end if;
if Present (Chain) then
if Restricted_Profile then
Name := New_Reference_To (RTE (RE_Activate_Restricted_Tasks), Loc);
else
Name := New_Reference_To (RTE (RE_Activate_Tasks), Loc);
end if;
Call :=
Make_Procedure_Call_Statement (Loc,
Name => Name,
Parameter_Associations =>
New_List (Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Chain, Loc),
Attribute_Name => Name_Unchecked_Access)));
if Nkind (N) = N_Package_Declaration then
if Present (Corresponding_Body (N)) then
null;
elsif Present (Private_Declarations (Specification (N))) then
Append (Call, Private_Declarations (Specification (N)));
else
Append (Call, Visible_Declarations (Specification (N)));
end if;
else
if Present (Handled_Statement_Sequence (N)) then
declare
Stm : Node_Id;
begin
Stm := First (Statements (Handled_Statement_Sequence (N)));
if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then
Next (Stm);
end if;
Insert_Before (Stm, Call);
end;
else
Set_Handled_Statement_Sequence (N,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Call)));
end if;
end if;
Analyze (Call);
Check_Task_Activation (N);
end if;
end Build_Task_Activation_Call;
procedure Build_Task_Allocate_Block
(Actions : List_Id;
N : Node_Id;
Args : List_Id)
is
T : constant Entity_Id := Entity (Expression (N));
Init : constant Entity_Id := Base_Init_Proc (T);
Loc : constant Source_Ptr := Sloc (N);
Chain : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_uChain);
Blkent : Entity_Id;
Block : Node_Id;
begin
Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Block :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc),
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Chain,
Aliased_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Activation_Chain), Loc))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Init, Loc),
Parameter_Associations => Args),
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Chain, Loc),
Attribute_Name => Name_Unchecked_Access))))),
Has_Created_Identifier => True,
Is_Task_Allocation_Block => True);
Append_To (Actions,
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Blkent,
Label_Construct => Block));
Append_To (Actions, Block);
Set_Activation_Chain_Entity (Block, Chain);
end Build_Task_Allocate_Block;
procedure Build_Task_Allocate_Block_With_Init_Stmts
(Actions : List_Id;
N : Node_Id;
Init_Stmts : List_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Chain : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_uChain);
Blkent : Entity_Id;
Block : Node_Id;
begin
Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Append_To (Init_Stmts,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Chain, Loc),
Attribute_Name => Name_Unchecked_Access))));
Block :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc),
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Chain,
Aliased_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Activation_Chain), Loc))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts),
Has_Created_Identifier => True,
Is_Task_Allocation_Block => True);
Append_To (Actions,
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Blkent,
Label_Construct => Block));
Append_To (Actions, Block);
Set_Activation_Chain_Entity (Block, Chain);
end Build_Task_Allocate_Block_With_Init_Stmts;
function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (T);
Nam : constant Name_Id := Chars (T);
Tdec : constant Node_Id := Declaration_Node (T);
Ent : Entity_Id;
begin
Ent :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Nam, 'B'));
Set_Is_Internal (Ent);
if No (Task_Body_Procedure (Tdec)) then
Set_Task_Body_Procedure (Tdec, Ent);
end if;
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Ent,
Parameter_Specifications =>
New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uTask),
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
New_Reference_To
(Corresponding_Record_Type (T), Loc)))));
end Build_Task_Proc_Specification;
function Build_Unprotected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
N_Op_Spec : Node_Id;
Op_Decls : List_Id;
begin
Op_Decls := Declarations (N);
N_Op_Spec :=
Build_Protected_Sub_Specification
(N, Pid, Unprotected => True);
return
Make_Subprogram_Body (Loc,
Specification => N_Op_Spec,
Declarations => Op_Decls,
Handled_Statement_Sequence =>
Handled_Statement_Sequence (N));
end Build_Unprotected_Subprogram_Body;
procedure Collect_Entry_Families
(Loc : Source_Ptr;
Cdecls : List_Id;
Current_Node : in out Node_Id;
Conctyp : Entity_Id)
is
Efam : Entity_Id;
Efam_Decl : Node_Id;
Efam_Type : Entity_Id;
begin
Efam := First_Entity (Conctyp);
while Present (Efam) loop
if Ekind (Efam) = E_Entry_Family then
Efam_Type :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('F'));
Efam_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Efam_Type,
Type_Definition =>
Make_Unconstrained_Array_Definition (Loc,
Subtype_Marks => (New_List (
New_Occurrence_Of (
Base_Type
(Etype (Discrete_Subtype_Definition
(Parent (Efam)))), Loc))),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Reference_To (Standard_Character, Loc))));
Insert_After (Current_Node, Efam_Decl);
Current_Node := Efam_Decl;
Analyze (Efam_Decl);
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars (Efam)),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Efam_Type, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
New_Occurrence_Of
(Etype (Discrete_Subtype_Definition
(Parent (Efam))), Loc)))))));
end if;
Next_Entity (Efam);
end loop;
end Collect_Entry_Families;
function Concurrent_Ref (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
Ntyp : constant Entity_Id := Etype (N);
Dtyp : Entity_Id;
Sel : Name_Id;
function Is_Current_Task (T : Entity_Id) return Boolean;
function Is_Current_Task (T : Entity_Id) return Boolean is
Scop : Entity_Id;
begin
Scop := Current_Scope;
while Present (Scop)
and then Scop /= Standard_Standard
loop
if Scop = T then
return True;
elsif Is_Task_Type (Scop) then
return False;
elsif Is_Overloadable (Scop)
and then In_Open_Scopes (T)
then
return False;
else
Scop := Scope (Scop);
end if;
end loop;
raise Program_Error;
end Is_Current_Task;
begin
if Is_Access_Type (Ntyp) then
Dtyp := Designated_Type (Ntyp);
if Is_Protected_Type (Dtyp) then
Sel := Name_uObject;
else
Sel := Name_uTask_Id;
end if;
return
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Corresponding_Record_Type (Dtyp),
Make_Explicit_Dereference (Loc, N)),
Selector_Name => Make_Identifier (Loc, Sel));
elsif Is_Entity_Name (N)
and then Is_Concurrent_Type (Entity (N))
then
if Is_Task_Type (Entity (N)) then
if Is_Current_Task (Entity (N)) then
return
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Self), Loc));
else
declare
Decl : Node_Id;
T_Self : constant Entity_Id
:= Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
T_Body : constant Node_Id
:= Parent (Corresponding_Body (Parent (Entity (N))));
begin
Decl := Make_Object_Declaration (Loc,
Defining_Identifier => T_Self,
Object_Definition =>
New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Self), Loc)));
Prepend (Decl, Declarations (T_Body));
Analyze (Decl);
Set_Scope (T_Self, Entity (N));
return New_Occurrence_Of (T_Self, Loc);
end;
end if;
else
pragma Assert (Is_Protected_Type (Entity (N)));
return
New_Reference_To (
Object_Ref (Corresponding_Body (Parent (Base_Type (Ntyp)))),
Loc);
end if;
else
pragma Assert (Is_Concurrent_Type (Ntyp));
if Is_Protected_Type (Ntyp) then
Sel := Name_uObject;
else
Sel := Name_uTask_Id;
end if;
return
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Corresponding_Record_Type (Ntyp),
New_Copy_Tree (N)),
Selector_Name => Make_Identifier (Loc, Sel));
end if;
end Concurrent_Ref;
function Convert_Concurrent
(N : Node_Id;
Typ : Entity_Id) return Node_Id
is
begin
if not Is_Concurrent_Type (Typ) then
return N;
else
return
Unchecked_Convert_To (Corresponding_Record_Type (Typ),
New_Copy_Tree (N));
end if;
end Convert_Concurrent;
function Entry_Index_Expression
(Sloc : Source_Ptr;
Ent : Entity_Id;
Index : Node_Id;
Ttyp : Entity_Id) return Node_Id
is
Expr : Node_Id;
Num : Node_Id;
Lo : Node_Id;
Hi : Node_Id;
Prev : Entity_Id;
S : Node_Id;
begin
Num := Make_Integer_Literal (Sloc, 1);
if Present (Index) then
S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
Expr :=
Make_Op_Add (Sloc,
Left_Opnd => Num,
Right_Opnd =>
Family_Offset (
Sloc,
Make_Attribute_Reference (Sloc,
Attribute_Name => Name_Pos,
Prefix => New_Reference_To (Base_Type (S), Sloc),
Expressions => New_List (Relocate_Node (Index))),
Type_Low_Bound (S),
Ttyp));
else
Expr := Num;
end if;
Prev := First_Entity (Ttyp);
while Chars (Prev) /= Chars (Ent)
or else (Ekind (Prev) /= Ekind (Ent))
or else not Sem_Ch6.Type_Conformant (Ent, Prev)
loop
if Ekind (Prev) = E_Entry then
Set_Intval (Num, Intval (Num) + 1);
elsif Ekind (Prev) = E_Entry_Family then
S :=
Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
Lo := Type_Low_Bound (S);
Hi := Type_High_Bound (S);
Expr :=
Make_Op_Add (Sloc,
Left_Opnd => Expr,
Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp));
else
null;
end if;
Next_Entity (Prev);
end loop;
return Expr;
end Entry_Index_Expression;
procedure Establish_Task_Master (N : Node_Id) is
Call : Node_Id;
begin
if Restriction_Active (No_Task_Hierarchy) = False then
Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
Prepend_To (Declarations (N), Call);
Analyze (Call);
end if;
end Establish_Task_Master;
procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ann : Entity_Id := Empty;
Adecl : Node_Id;
Lab_Id : Node_Id;
Lab : Node_Id;
Ldecl : Node_Id;
Ldecl2 : Node_Id;
begin
if Expander_Active then
if Opt.Task_Dispatching_Policy = 'F' and then
not Present (Handled_Statement_Sequence (N))
then
Set_Handled_Statement_Sequence (N,
Make_Handled_Sequence_Of_Statements (Loc,
New_List (Make_Null_Statement (Loc))));
end if;
if Present (Handled_Statement_Sequence (N)) then
Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L'));
Set_Entity (Lab_Id,
Make_Defining_Identifier (Loc, Chars (Lab_Id)));
Lab := Make_Label (Loc, Lab_Id);
Ldecl :=
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Entity (Lab_Id),
Label_Construct => Lab);
Append (Lab, Statements (Handled_Statement_Sequence (N)));
Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L'));
Set_Entity (Lab_Id,
Make_Defining_Identifier (Loc, Chars (Lab_Id)));
Lab := Make_Label (Loc, Lab_Id);
Ldecl2 :=
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Entity (Lab_Id),
Label_Construct => Lab);
Append (Lab, Statements (Handled_Statement_Sequence (N)));
else
Ldecl := Empty;
Ldecl2 := Empty;
end if;
if Is_List_Member (N) then
if Present (Handled_Statement_Sequence (N)) then
Ann :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('A'));
Adecl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Ann,
Object_Definition =>
New_Reference_To (RTE (RE_Address), Loc));
Insert_Before (N, Adecl);
Analyze (Adecl);
Insert_Before (N, Ldecl);
Analyze (Ldecl);
Insert_Before (N, Ldecl2);
Analyze (Ldecl2);
end if;
else
declare
Acc_Alt : constant Node_Id := Parent (N);
Sel_Acc : constant Node_Id := Parent (Acc_Alt);
Alt : Node_Id;
begin
pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative);
pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept);
if Present (Handled_Statement_Sequence (N)) then
Prepend (Ldecl2,
Statements (Handled_Statement_Sequence (N)));
Analyze (Ldecl2);
Prepend (Ldecl,
Statements (Handled_Statement_Sequence (N)));
Analyze (Ldecl);
end if;
Alt := First (Select_Alternatives (Sel_Acc));
while Nkind (Alt) /= N_Accept_Alternative loop
Next (Alt);
end loop;
if N = Accept_Statement (Alt) then
Ann :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Adecl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Ann,
Object_Definition =>
New_Reference_To (RTE (RE_Address), Loc));
Insert_Before (Sel_Acc, Adecl);
Analyze (Adecl);
else
Ann :=
Node (Last_Elmt (Accept_Address
(Entity (Entry_Direct_Name (Accept_Statement (Alt))))));
end if;
end;
end if;
if Present (Ann) then
Append_Elmt (Ann, Accept_Address (Ent));
Set_Needs_Debug_Info (Ann);
end if;
if Present (Parameter_Specifications (N))
and then Present (Handled_Statement_Sequence (N))
then
declare
Formal : Entity_Id;
New_F : Entity_Id;
Comp : Entity_Id;
Decl : Node_Id;
begin
New_Scope (Ent);
Formal := First_Formal (Ent);
while Present (Formal) loop
Comp := Entry_Component (Formal);
New_F :=
Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
Set_Etype (New_F, Etype (Formal));
Set_Scope (New_F, Ent);
Set_Needs_Debug_Info (New_F);
if Ekind (Formal) = E_In_Parameter then
Set_Ekind (New_F, E_Constant);
else
Set_Ekind (New_F, E_Variable);
Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
end if;
Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
Decl :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => New_F,
Subtype_Mark => New_Reference_To (Etype (Formal), Loc),
Name =>
Make_Explicit_Dereference (Loc,
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Entry_Parameters_Type (Ent),
New_Reference_To (Ann, Loc)),
Selector_Name =>
New_Reference_To (Comp, Loc))));
if No (Declarations (N)) then
Set_Declarations (N, New_List);
end if;
Append (Decl, Declarations (N));
Set_Renamed_Object (Formal, New_F);
Next_Formal (Formal);
end loop;
End_Scope;
end;
end if;
end if;
end Expand_Accept_Declarations;
procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Comps : List_Id;
T : constant Entity_Id := Defining_Identifier (N);
D_T : constant Entity_Id := Designated_Type (T);
D_T2 : constant Entity_Id := Make_Defining_Identifier
(Loc, New_Internal_Name ('D'));
E_T : constant Entity_Id := Make_Defining_Identifier
(Loc, New_Internal_Name ('E'));
P_List : constant List_Id := Build_Protected_Spec
(N, RTE (RE_Address), False, D_T);
Decl1 : Node_Id;
Decl2 : Node_Id;
Def1 : Node_Id;
begin
if Nkind (Type_Definition (N)) = N_Access_Function_Definition then
Def1 :=
Make_Access_Function_Definition (Loc,
Parameter_Specifications => P_List,
Subtype_Mark => New_Copy (Subtype_Mark (Type_Definition (N))));
else
Def1 :=
Make_Access_Procedure_Definition (Loc,
Parameter_Specifications => P_List);
end if;
Decl1 :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => D_T2,
Type_Definition => Def1);
Analyze (Decl1);
Insert_After (N, Decl1);
Comps := New_List (
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_Internal_Name ('P')),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Address), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication => New_Occurrence_Of (D_T2, Loc))));
Decl2 :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => E_T,
Type_Definition =>
Make_Record_Definition (Loc,
Component_List =>
Make_Component_List (Loc,
Component_Items => Comps)));
Analyze (Decl2);
Insert_After (Decl1, Decl2);
Set_Equivalent_Type (T, E_T);
end Expand_Access_Protected_Subprogram_Type;
procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Prot : constant Entity_Id := Scope (Ent);
Spec_Decl : constant Node_Id := Parent (Prot);
Cond : constant Node_Id :=
Condition (Entry_Body_Formal_Part (N));
Func : Node_Id;
B_F : Node_Id;
Body_Decl : Node_Id;
begin
if No_Run_Time_Mode then
Error_Msg_CRT ("entry barrier", N);
return;
end if;
if Expander_Active then
B_F := Build_Barrier_Function (N, Ent, Prot);
Func := Barrier_Function (Ent);
Set_Corresponding_Spec (B_F, Func);
Body_Decl := Parent (Corresponding_Body (Spec_Decl));
if Nkind (Parent (Body_Decl)) = N_Subunit then
Body_Decl := Corresponding_Stub (Parent (Body_Decl));
end if;
Insert_Before_And_Analyze (Body_Decl, B_F);
Update_Prival_Subtypes (B_F);
Set_Privals (Spec_Decl, N, Loc);
Set_Discriminals (Spec_Decl);
Set_Scope (Func, Scope (Prot));
else
Analyze_And_Resolve (Cond, Any_Boolean);
end if;
if Is_Entity_Name (Cond) then
if Entity (Cond) = Standard_False
or else
Entity (Cond) = Standard_True
then
return;
elsif not Expander_Active
and then Scope (Entity (Cond)) = Current_Scope
then
return;
elsif Present (Renamed_Object (Entity (Cond)))
and then
Nkind (Renamed_Object (Entity (Cond))) = N_Selected_Component
and then
Chars
(Prefix
(Prefix (Renamed_Object (Entity (Cond))))) = Name_uObject
then
return;
end if;
end if;
Check_Restriction (Simple_Barriers, Cond);
end Expand_Entry_Barrier;
procedure Expand_Entry_Body_Declarations (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Index_Spec : Node_Id;
begin
if Expander_Active then
Index_Spec :=
Entry_Index_Specification (Entry_Body_Formal_Part (N));
if Present (Index_Spec) then
Set_Entry_Index_Constant (
Defining_Identifier (Index_Spec),
Make_Defining_Identifier (Loc, New_Internal_Name ('J')));
end if;
end if;
end Expand_Entry_Body_Declarations;
procedure Expand_N_Abort_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Tlist : constant List_Id := Names (N);
Count : Nat;
Aggr : Node_Id;
Tasknm : Node_Id;
begin
Aggr := Make_Aggregate (Loc, Component_Associations => New_List);
Count := 0;
Tasknm := First (Tlist);
while Present (Tasknm) loop
Count := Count + 1;
Append_To (Component_Associations (Aggr),
Make_Component_Association (Loc,
Choices => New_List (
Make_Integer_Literal (Loc, Count)),
Expression => Concurrent_Ref (Tasknm)));
Next (Tasknm);
end loop;
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Tasks), Loc),
Parameter_Associations => New_List (
Make_Qualified_Expression (Loc,
Subtype_Mark => New_Reference_To (RTE (RE_Task_List), Loc),
Expression => Aggr))));
Analyze (N);
end Expand_N_Abort_Statement;
procedure Expand_N_Accept_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Stats : constant Node_Id := Handled_Statement_Sequence (N);
Ename : constant Node_Id := Entry_Direct_Name (N);
Eindx : constant Node_Id := Entry_Index (N);
Eent : constant Entity_Id := Entity (Ename);
Acstack : constant Elist_Id := Accept_Address (Eent);
Ann : constant Entity_Id := Node (Last_Elmt (Acstack));
Ttyp : constant Entity_Id := Etype (Scope (Eent));
Blkent : Entity_Id;
Call : Node_Id;
Block : Node_Id;
function Null_Statements (Stats : List_Id) return Boolean;
function Null_Statements (Stats : List_Id) return Boolean is
Stmt : Node_Id;
begin
Stmt := First (Stats);
while Nkind (Stmt) /= N_Empty
and then (Nkind (Stmt) = N_Null_Statement
or else
Nkind (Stmt) = N_Label)
loop
Next (Stmt);
end loop;
return Nkind (Stmt) = N_Empty;
end Null_Statements;
begin
if not Is_List_Member (N) then
pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative);
return;
elsif Opt.Task_Dispatching_Policy /= 'F'
and then (No (Stats) or else Null_Statements (Statements (Stats)))
then
declare
D : Node_Id;
Next_D : Node_Id;
begin
D := First (Declarations (N));
while Present (D) loop
Next_D := Next (D);
if Nkind (D) = N_Object_Renaming_Declaration then
Remove (D);
end if;
D := Next_D;
end loop;
end;
if Present (Declarations (N)) then
Insert_Actions (N, Declarations (N));
end if;
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Accept_Trivial), Loc),
Parameter_Associations => New_List (
Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp))));
Analyze (N);
if Present (Stats) then
Remove_Last_Elmt (Acstack);
end if;
else
Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Set_Ekind (Blkent, E_Block);
Set_Etype (Blkent, Standard_Void_Type);
Set_Scope (Blkent, Current_Scope);
Block :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc),
Declarations => Declarations (N),
Handled_Statement_Sequence => Build_Accept_Body (N));
Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Accept_Call), Loc),
Parameter_Associations => New_List (
Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp),
New_Reference_To (Ann, Loc)));
if Parent (Stats) = N then
Prepend (Call, Statements (Stats));
else
Set_Declarations
(Parent (Stats),
New_List (Call));
end if;
Analyze (Call);
New_Scope (Blkent);
declare
D : Node_Id;
Next_D : Node_Id;
Typ : Entity_Id;
begin
D := First (Declarations (N));
while Present (D) loop
Next_D := Next (D);
if Nkind (D) = N_Object_Renaming_Declaration then
Remove (D);
Typ := Entity (Subtype_Mark (D));
Insert_After (Call, D);
Analyze (D);
if Is_Class_Wide_Type (Typ) then
Set_Etype (Defining_Identifier (D), Typ);
end if;
end if;
D := Next_D;
end loop;
end;
End_Scope;
Rewrite (N, Block);
Analyze (N);
Remove_Last_Elmt (Acstack);
end if;
end Expand_N_Accept_Statement;
procedure Expand_N_Asynchronous_Select (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Trig : constant Node_Id := Triggering_Alternative (N);
Abrt : constant Node_Id := Abortable_Part (N);
Tstats : constant List_Id := Statements (Trig);
Astats : constant List_Id := Statements (Abrt);
Ecall : Node_Id;
Concval : Node_Id;
Ename : Node_Id;
Index : Node_Id;
Hdle : List_Id;
Decls : List_Id;
Decl : Node_Id;
Parms : List_Id;
Parm : Node_Id;
Call : Node_Id;
Stmts : List_Id;
Enqueue_Call : Node_Id;
Stmt : Node_Id;
B : Entity_Id;
Pdef : Entity_Id;
Dblock_Ent : Entity_Id;
N_Orig : Node_Id;
Abortable_Block : Node_Id;
Cancel_Param : Entity_Id;
Blkent : Entity_Id;
Target_Undefer : RE_Id;
Undefer_Args : List_Id := No_List;
begin
Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Ecall := Triggering_Statement (Trig);
if Nkind (Ecall) = N_Block_Statement then
Ecall := First (Statements (Handled_Statement_Sequence (Ecall)));
while Nkind (Ecall) /= N_Procedure_Call_Statement
and then Nkind (Ecall) /= N_Entry_Call_Statement
loop
Next (Ecall);
end loop;
end if;
if Nkind (Ecall) = N_Procedure_Call_Statement then
Dblock_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
Pdef := Entity (Name (Ecall));
if Is_RTE (Pdef, RO_CA_Delay_For) then
Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Duration), Loc);
elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Calendar), Loc);
else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc);
end if;
Append_To (Parameter_Associations (Ecall),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Dblock_Ent, Loc),
Attribute_Name => Name_Unchecked_Access));
Hdle := New_List (
Make_Exception_Handler (Loc,
Exception_Choices =>
New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
Prepend_To (Astats,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
Abortable_Block :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Astats),
Has_Created_Identifier => True,
Is_Asynchronous_Call_Block => True);
Rewrite (Ecall,
Make_Implicit_If_Statement (N,
Condition => Make_Function_Call (Loc,
Name => Enqueue_Call,
Parameter_Associations => Parameter_Associations (Ecall)),
Then_Statements =>
New_List (Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Blkent,
Label_Construct => Abortable_Block),
Abortable_Block),
Exception_Handlers => Hdle)))));
Stmts := New_List (Ecall);
Append_To (Stmts,
Make_Implicit_If_Statement (N,
Condition => Make_Function_Call (Loc,
Name => New_Reference_To (
RTE (RE_Timed_Out), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Dblock_Ent, Loc),
Attribute_Name => Name_Unchecked_Access))),
Then_Statements => Tstats));
Set_Entry_Cancel_Parameter (Blkent, Dblock_Ent);
Rewrite (N,
Make_Block_Statement (Loc,
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Dblock_Ent,
Aliased_Present => True,
Object_Definition => New_Reference_To (
RTE (RE_Delay_Block), Loc))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
Analyze (N);
return;
else
N_Orig := N;
end if;
Extract_Entry (Ecall, Concval, Ename, Index);
Build_Simple_Entry_Call (Ecall, Concval, Ename, Index);
Stmts := Statements (Handled_Statement_Sequence (Ecall));
Decls := Declarations (Ecall);
if Is_Protected_Type (Etype (Concval)) then
Decl := First (Decls);
while Present (Decl)
and then (Nkind (Decl) /= N_Object_Declaration
or else not Is_RTE
(Etype (Object_Definition (Decl)), RE_Communication_Block))
loop
Next (Decl);
end loop;
pragma Assert (Present (Decl));
Cancel_Param := Defining_Identifier (Decl);
Stmt := First (Stmts);
while Nkind (Stmt) /= N_Procedure_Call_Statement loop
Next (Stmt);
end loop;
Call := Stmt;
Parm := First (Parameter_Associations (Call));
while Present (Parm)
and then not Is_RTE (Etype (Parm), RE_Call_Modes)
loop
Next (Parm);
end loop;
pragma Assert (Present (Parm));
Rewrite (Parm, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
Analyze (Parm);
Append_To (Stmts,
Make_Implicit_If_Statement (N,
Condition => Make_Function_Call (Loc,
Name => New_Reference_To (
RTE (RE_Enqueued), Loc),
Parameter_Associations => New_List (
New_Reference_To (Cancel_Param, Loc))),
Then_Statements => Astats));
Abortable_Block :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts),
Has_Created_Identifier => True,
Is_Asynchronous_Call_Block => True);
if Hostparm.Java_VM then
Target_Undefer := RE_Update_Exception;
Undefer_Args :=
New_List (Make_Function_Call (Loc,
Name => New_Occurrence_Of
(RTE (RE_Current_Target_Exception), Loc)));
else
Target_Undefer := RE_Abort_Undefer;
end if;
Stmts := New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Blkent,
Label_Construct => Abortable_Block),
Abortable_Block),
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
Exception_Choices =>
New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
RTE (Target_Undefer), Loc),
Parameter_Associations => Undefer_Args)))))),
Make_Implicit_If_Statement (N,
Condition => Make_Op_Not (Loc,
Right_Opnd =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Cancel_Param, Loc)))),
Then_Statements => Tstats));
else
if No (Decls) then
Decls := New_List;
end if;
B := Make_Defining_Identifier (Loc, Name_uB);
Prepend_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => B,
Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
Cancel_Param := Make_Defining_Identifier (Loc, Name_uC);
Prepend_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Cancel_Param,
Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
Stmt := First (Stmts);
while Nkind (Stmt) /= N_Procedure_Call_Statement loop
Next (Stmt);
end loop;
Call := Stmt;
Hdle := New_List (
Make_Exception_Handler (Loc,
Exception_Choices =>
New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
Prepend_To (Astats,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
Abortable_Block :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Astats),
Has_Created_Identifier => True,
Is_Asynchronous_Call_Block => True);
Insert_After (Call,
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Blkent,
Label_Construct => Abortable_Block),
Abortable_Block),
Exception_Handlers => Hdle)));
Parms := Parameter_Associations (Call);
Append_To (Parms, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
Append_To (Parms, New_Reference_To (B, Loc));
Rewrite (Call,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
Parameter_Associations => Parms));
Append_To (Stmts,
Make_Implicit_If_Statement (N,
Condition => Make_Op_Not (Loc,
New_Reference_To (Cancel_Param, Loc)),
Then_Statements => Tstats));
Prepend_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Defer), Loc),
Parameter_Associations => Empty_List));
end if;
Set_Entry_Cancel_Parameter (Blkent, Cancel_Param);
Rewrite (N_Orig,
Make_Block_Statement (Loc,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
Analyze (N_Orig);
end Expand_N_Asynchronous_Select;
procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Alt : constant Node_Id := Entry_Call_Alternative (N);
Blk : Node_Id := Entry_Call_Statement (Alt);
Transient_Blk : Node_Id;
Parms : List_Id;
Parm : Node_Id;
Call : Node_Id;
Stmts : List_Id;
B : Entity_Id;
Decl : Node_Id;
Stmt : Node_Id;
begin
Transient_Blk :=
First_Real_Statement (Handled_Statement_Sequence (Blk));
if Present (Transient_Blk)
and then
Nkind (Transient_Blk) = N_Block_Statement
then
Blk := Transient_Blk;
end if;
Stmts := Statements (Handled_Statement_Sequence (Blk));
Stmt := First (Stmts);
while Nkind (Stmt) /= N_Procedure_Call_Statement loop
Next (Stmt);
end loop;
Call := Stmt;
Parms := Parameter_Associations (Call);
if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then
Parm := First (Parms);
while Present (Parm)
and then not Is_RTE (Etype (Parm), RE_Call_Modes)
loop
Next (Parm);
end loop;
pragma Assert (Present (Parm));
Rewrite (Parm, New_Reference_To (RTE (RE_Conditional_Call), Loc));
Analyze (Parm);
Decl := First (Declarations (Blk));
while Present (Decl)
and then not
Is_RTE (Etype (Object_Definition (Decl)), RE_Communication_Block)
loop
Next (Decl);
end loop;
Append_To (Stmts,
Make_Implicit_If_Statement (N,
Condition => Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Cancelled), Loc),
Parameter_Associations => New_List (
New_Reference_To (Defining_Identifier (Decl), Loc))),
Then_Statements => Else_Statements (N),
Else_Statements => Statements (Alt)));
else
B := Make_Defining_Identifier (Loc, Name_uB);
if No (Declarations (Blk)) then
Set_Declarations (Blk, New_List);
end if;
Prepend_To (Declarations (Blk),
Make_Object_Declaration (Loc,
Defining_Identifier => B,
Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
Append_To (Parms, New_Reference_To (RTE (RE_Conditional_Call), Loc));
Append_To (Parms, New_Reference_To (B, Loc));
Rewrite (Call,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
Parameter_Associations => Parms));
Append_To (Stmts,
Make_Implicit_If_Statement (N,
Condition => New_Reference_To (B, Loc),
Then_Statements => Statements (Alt),
Else_Statements => Else_Statements (N)));
end if;
Rewrite (N,
Make_Block_Statement (Loc,
Declarations => Declarations (Blk),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
Analyze (N);
end Expand_N_Conditional_Entry_Call;
procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
begin
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RO_CA_Delay_For), Loc),
Parameter_Associations => New_List (Expression (N))));
Analyze (N);
end Expand_N_Delay_Relative_Statement;
procedure Expand_N_Delay_Until_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : Entity_Id;
begin
if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then
Typ := RTE (RO_CA_Delay_Until);
else
Typ := RTE (RO_RT_Delay_Until);
end if;
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Typ, Loc),
Parameter_Associations => New_List (Expression (N))));
Analyze (N);
end Expand_N_Delay_Until_Statement;
procedure Expand_N_Entry_Body (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Dec : constant Node_Id := Parent (Current_Scope);
Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N);
Index_Spec : constant Node_Id :=
Entry_Index_Specification (Ent_Formals);
Next_Op : Node_Id;
First_Decl : constant Node_Id := First (Declarations (N));
Index_Decl : List_Id;
begin
Add_Discriminal_Declarations
(Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc);
Add_Private_Declarations
(Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc);
if Present (Index_Spec) then
Index_Decl :=
Index_Constant_Declaration
(N,
Defining_Identifier (Index_Spec), Defining_Identifier (Dec));
if Present (First_Decl) then
Insert_List_Before (First_Decl, Index_Decl);
else
Append_List_To (Declarations (N), Index_Decl);
end if;
end if;
Next_Op := Next_Protected_Operation (N);
if Present (Next_Op) then
Set_Privals (Dec, Next_Op, Loc);
Set_Discriminals (Dec);
end if;
end Expand_N_Entry_Body;
procedure Expand_N_Entry_Call_Statement (N : Node_Id) is
Concval : Node_Id;
Ename : Node_Id;
Index : Node_Id;
begin
if No_Run_Time_Mode then
Error_Msg_CRT ("entry call", N);
return;
end if;
if (Nkind (Parent (N)) /= N_Triggering_Alternative
or else N /= Triggering_Statement (Parent (N)))
and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative
or else N /= Entry_Call_Statement (Parent (N))
or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call)
then
Extract_Entry (N, Concval, Ename, Index);
Build_Simple_Entry_Call (N, Concval, Ename, Index);
end if;
end Expand_N_Entry_Call_Statement;
procedure Expand_N_Entry_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Entry_Ent : constant Entity_Id := Defining_Identifier (N);
Components : List_Id;
Formal : Node_Id;
Ftype : Entity_Id;
Last_Decl : Node_Id;
Component : Entity_Id;
Ctype : Entity_Id;
Decl : Node_Id;
Rec_Ent : Entity_Id;
Acc_Ent : Entity_Id;
begin
Formal := First_Formal (Entry_Ent);
Last_Decl := N;
if Present (Formal) then
Components := New_List;
while Present (Formal) loop
Set_Is_Entry_Formal (Formal);
Component :=
Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
Set_Entry_Component (Formal, Component);
Set_Entry_Formal (Component, Formal);
Ftype := Etype (Formal);
Ctype :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Ctype,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Constant_Present => Ekind (Formal) = E_In_Parameter,
Subtype_Indication => New_Reference_To (Ftype, Loc)));
Insert_After (Last_Decl, Decl);
Last_Decl := Decl;
Append_To (Components,
Make_Component_Declaration (Loc,
Defining_Identifier => Component,
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication => New_Reference_To (Ctype, Loc))));
Next_Formal_With_Extras (Formal);
end loop;
Rec_Ent :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Rec_Ent,
Type_Definition =>
Make_Record_Definition (Loc,
Component_List =>
Make_Component_List (Loc,
Component_Items => Components)));
Insert_After (Last_Decl, Decl);
Last_Decl := Decl;
Acc_Ent :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent);
Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Acc_Ent,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Subtype_Indication => New_Reference_To (Rec_Ent, Loc)));
Insert_After (Last_Decl, Decl);
Last_Decl := Decl;
end if;
end Expand_N_Entry_Declaration;
procedure Expand_N_Protected_Body (N : Node_Id) is
Pid : constant Entity_Id := Corresponding_Spec (N);
Has_Entries : Boolean := False;
Op_Decl : Node_Id;
Op_Body : Node_Id;
Op_Id : Entity_Id;
New_Op_Body : Node_Id;
Current_Node : Node_Id;
Num_Entries : Natural := 0;
begin
if No_Run_Time_Mode then
Error_Msg_CRT ("protected body", N);
return;
end if;
if Nkind (Parent (N)) = N_Subunit then
Current_Node := Corresponding_Stub (Parent (N));
else
Current_Node := N;
end if;
Op_Body := First (Declarations (N));
Rewrite (N, Make_Null_Statement (Sloc (N)));
Analyze (N);
while Present (Op_Body) loop
case Nkind (Op_Body) is
when N_Subprogram_Declaration =>
null;
when N_Subprogram_Body =>
if not Is_Eliminated (Defining_Entity (Op_Body))
and then not Is_Eliminated (Corresponding_Spec (Op_Body))
then
New_Op_Body :=
Build_Unprotected_Subprogram_Body (Op_Body, Pid);
Insert_After (Current_Node, New_Op_Body);
Current_Node := New_Op_Body;
Analyze (New_Op_Body);
Update_Prival_Subtypes (New_Op_Body);
if Present (Corresponding_Spec (Op_Body)) then
Op_Decl :=
Unit_Declaration_Node (Corresponding_Spec (Op_Body));
if Nkind (Parent (Op_Decl)) = N_Protected_Definition
and then
(List_Containing (Op_Decl) =
Visible_Declarations (Parent (Op_Decl))
or else
Is_Interrupt_Handler
(Corresponding_Spec (Op_Body)))
then
New_Op_Body :=
Build_Protected_Subprogram_Body (
Op_Body, Pid, Specification (New_Op_Body));
Insert_After (Current_Node, New_Op_Body);
Analyze (New_Op_Body);
end if;
end if;
end if;
when N_Entry_Body =>
Op_Id := Defining_Identifier (Op_Body);
Has_Entries := True;
Num_Entries := Num_Entries + 1;
New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid);
Insert_After (Current_Node, New_Op_Body);
Current_Node := New_Op_Body;
Analyze (New_Op_Body);
Update_Prival_Subtypes (New_Op_Body);
when N_Implicit_Label_Declaration =>
null;
when N_Itype_Reference =>
Insert_After (Current_Node, New_Copy (Op_Body));
when N_Freeze_Entity =>
New_Op_Body := New_Copy (Op_Body);
if Present (Entity (Op_Body))
and then Freeze_Node (Entity (Op_Body)) = Op_Body
then
Set_Freeze_Node (Entity (Op_Body), New_Op_Body);
end if;
Insert_After (Current_Node, New_Op_Body);
Current_Node := New_Op_Body;
Analyze (New_Op_Body);
when N_Pragma =>
New_Op_Body := New_Copy (Op_Body);
Insert_After (Current_Node, New_Op_Body);
Current_Node := New_Op_Body;
Analyze (New_Op_Body);
when N_Object_Declaration =>
pragma Assert (not Comes_From_Source (Op_Body));
New_Op_Body := New_Copy (Op_Body);
Insert_After (Current_Node, New_Op_Body);
Current_Node := New_Op_Body;
Analyze (New_Op_Body);
when others =>
raise Program_Error;
end case;
Next (Op_Body);
end loop;
if Has_Entries
and then (Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Num_Entries > 1)
then
New_Op_Body := Build_Find_Body_Index (Pid);
Insert_After (Current_Node, New_Op_Body);
Analyze (New_Op_Body);
end if;
end Expand_N_Protected_Body;
procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Prottyp : constant Entity_Id := Defining_Identifier (N);
Protnm : constant Name_Id := Chars (Prottyp);
Pdef : constant Node_Id := Protected_Definition (N);
Rec_Decl : Node_Id;
Cdecls : List_Id;
Discr_Map : constant Elist_Id := New_Elmt_List;
Priv : Node_Id;
Pent : Entity_Id;
New_Priv : Node_Id;
Comp : Node_Id;
Comp_Id : Entity_Id;
Sub : Node_Id;
Current_Node : Node_Id := N;
Bdef : Entity_Id := Empty; Edef : Entity_Id := Empty; Entries_Aggr : Node_Id;
Body_Id : Entity_Id;
Body_Arr : Node_Id;
E_Count : Int;
Object_Comp : Node_Id;
procedure Register_Handler;
procedure Register_Handler is
Prot_Proc : constant Entity_Id :=
Defining_Unit_Name
(Specification (Current_Node));
Proc_Address : constant Node_Id :=
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prot_Proc, Loc),
Attribute_Name => Name_Address);
RTS_Call : constant Entity_Id :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (
RTE (RE_Register_Interrupt_Handler), Loc),
Parameter_Associations =>
New_List (Proc_Address));
begin
Append_Freeze_Action (Prot_Proc, RTS_Call);
end Register_Handler;
begin
if Present (Corresponding_Record_Type (Prottyp)) then
return;
else
Rec_Decl := Build_Corresponding_Record (N, Prottyp, Loc);
Cdecls := Component_Items
(Component_List (Type_Definition (Rec_Decl)));
end if;
Qualify_Entity_Names (N);
if Has_Discriminants (Prottyp) then
declare
Disc : Entity_Id;
Decl : Node_Id;
begin
Disc := First_Discriminant (Prottyp);
Decl := First (Discriminant_Specifications (Rec_Decl));
while Present (Disc) loop
Append_Elmt (Discriminal (Disc), Discr_Map);
Append_Elmt (Defining_Identifier (Decl), Discr_Map);
Next_Discriminant (Disc);
Next (Decl);
end loop;
end;
end if;
Collect_Entry_Families (Loc, Cdecls, Current_Node, Prottyp);
declare
Ritem : Node_Id;
Num_Attach_Handler : Int := 0;
Protection_Subtype : Node_Id;
Entry_Count_Expr : constant Node_Id :=
Build_Entry_Count_Expression
(Prottyp, Cdecls, Loc);
begin
if Has_Attach_Handler (Prottyp) then
Ritem := First_Rep_Item (Prottyp);
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
and then Chars (Ritem) = Name_Attach_Handler
then
Num_Attach_Handler := Num_Attach_Handler + 1;
end if;
Next_Rep_Item (Ritem);
end loop;
if Restricted_Profile then
if Has_Entries (Prottyp) then
Protection_Subtype :=
New_Reference_To (RTE (RE_Protection_Entry), Loc);
else
Protection_Subtype :=
New_Reference_To (RTE (RE_Protection), Loc);
end if;
else
Protection_Subtype :=
Make_Subtype_Indication
(Sloc => Loc,
Subtype_Mark =>
New_Reference_To
(RTE (RE_Static_Interrupt_Protection), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (
Sloc => Loc,
Constraints => New_List (
Entry_Count_Expr,
Make_Integer_Literal (Loc, Num_Attach_Handler))));
end if;
elsif Has_Interrupt_Handler (Prottyp) then
Protection_Subtype :=
Make_Subtype_Indication (
Sloc => Loc,
Subtype_Mark => New_Reference_To
(RTE (RE_Dynamic_Interrupt_Protection), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (
Sloc => Loc,
Constraints => New_List (Entry_Count_Expr)));
elsif Has_Entries (Prottyp) then
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Prottyp) > 1
then
Protection_Subtype :=
Make_Subtype_Indication (
Sloc => Loc,
Subtype_Mark =>
New_Reference_To (RTE (RE_Protection_Entries), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (
Sloc => Loc,
Constraints => New_List (Entry_Count_Expr)));
else
Protection_Subtype :=
New_Reference_To (RTE (RE_Protection_Entry), Loc);
end if;
else
Protection_Subtype := New_Reference_To (RTE (RE_Protection), Loc);
end if;
Object_Comp :=
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uObject),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => True,
Subtype_Indication => Protection_Subtype));
end;
pragma Assert (Present (Pdef));
if Present (Private_Declarations (Pdef)) then
Priv := First (Private_Declarations (Pdef));
while Present (Priv) loop
if Nkind (Priv) = N_Component_Declaration then
Pent := Defining_Identifier (Priv);
New_Priv :=
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Sloc (Pent), Chars (Pent)),
Component_Definition =>
Make_Component_Definition (Sloc (Pent),
Aliased_Present => False,
Subtype_Indication =>
New_Copy_Tree (Subtype_Indication
(Component_Definition (Priv)),
Discr_Map)),
Expression => Expression (Priv));
Append_To (Cdecls, New_Priv);
elsif Nkind (Priv) = N_Subprogram_Declaration then
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
(Priv, Prottyp, Unprotected => True));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Set_Protected_Body_Subprogram
(Defining_Unit_Name (Specification (Priv)),
Defining_Unit_Name (Specification (Sub)));
Current_Node := Sub;
if Is_Interrupt_Handler
(Defining_Unit_Name (Specification (Priv)))
then
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
(Priv, Prottyp, Unprotected => False));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Current_Node := Sub;
if not Restricted_Profile then
Register_Handler;
end if;
end if;
end if;
Next (Priv);
end loop;
end if;
Append_To (Cdecls, Object_Comp);
Insert_After (Current_Node, Rec_Decl);
Current_Node := Rec_Decl;
Analyze (Rec_Decl, Suppress => All_Checks);
if Has_Entries (Prottyp) then
Entries_Aggr :=
Make_Aggregate (Loc, Expressions => New_List);
else
Entries_Aggr := Empty;
end if;
E_Count := 0;
Comp := First (Visible_Declarations (Pdef));
while Present (Comp) loop
if Nkind (Comp) = N_Subprogram_Declaration
and then not Is_Eliminated (Defining_Entity (Comp))
then
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
(Comp, Prottyp, Unprotected => True));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Set_Protected_Body_Subprogram
(Defining_Unit_Name (Specification (Comp)),
Defining_Unit_Name (Specification (Sub)));
Current_Node := Sub;
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
(Comp, Prottyp, Unprotected => False));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Current_Node := Sub;
if not Restricted_Profile
and then Is_Interrupt_Handler
(Defining_Unit_Name (Specification (Comp)))
then
Register_Handler;
end if;
elsif Nkind (Comp) = N_Entry_Declaration then
E_Count := E_Count + 1;
Comp_Id := Defining_Identifier (Comp);
Set_Privals_Chain (Comp_Id, New_Elmt_List);
Edef :=
Make_Defining_Identifier (Loc,
Build_Selected_Name
(Protnm,
New_External_Name (Chars (Comp_Id), Suffix_Index => -1),
'E'));
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Entry_Specification (Edef, Comp_Id, Loc));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Set_Protected_Body_Subprogram (
Defining_Identifier (Comp),
Defining_Unit_Name (Specification (Sub)));
Current_Node := Sub;
Bdef :=
Make_Defining_Identifier (Loc,
Build_Selected_Name
(Protnm,
New_External_Name (Chars (Comp_Id), Suffix_Index => -1),
'B'));
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Barrier_Function_Specification (Bdef, Loc));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Set_Protected_Body_Subprogram (Bdef, Bdef);
Set_Barrier_Function (Comp_Id, Bdef);
Set_Scope (Bdef, Scope (Comp_Id));
Current_Node := Sub;
Append (
Make_Aggregate (Loc,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Bdef, Loc),
Attribute_Name => Name_Unrestricted_Access),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Edef, Loc),
Attribute_Name => Name_Unrestricted_Access))),
Expressions (Entries_Aggr));
end if;
Next (Comp);
end loop;
if Present (Private_Declarations (Pdef)) then
Comp := First (Private_Declarations (Pdef));
while Present (Comp) loop
if Nkind (Comp) = N_Entry_Declaration then
E_Count := E_Count + 1;
Comp_Id := Defining_Identifier (Comp);
Set_Privals_Chain (Comp_Id, New_Elmt_List);
Edef :=
Make_Defining_Identifier (Loc,
Build_Selected_Name
(Protnm,
New_External_Name (Chars (Comp_Id), Suffix_Index => -1),
'E'));
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Entry_Specification (Edef, Comp_Id, Loc));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Set_Protected_Body_Subprogram (
Defining_Identifier (Comp),
Defining_Unit_Name (Specification (Sub)));
Current_Node := Sub;
Bdef :=
Make_Defining_Identifier (Loc,
Build_Selected_Name
(Protnm,
New_External_Name (Chars (Comp_Id), Suffix_Index => -1),
'B'));
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Barrier_Function_Specification (Bdef, Loc));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Set_Protected_Body_Subprogram (Bdef, Bdef);
Set_Barrier_Function (Comp_Id, Bdef);
Set_Scope (Bdef, Scope (Comp_Id));
Current_Node := Sub;
Append (
Make_Aggregate (Loc,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Bdef, Loc),
Attribute_Name => Name_Unrestricted_Access),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Edef, Loc),
Attribute_Name => Name_Unrestricted_Access))),
Expressions (Entries_Aggr));
end if;
Next (Comp);
end loop;
end if;
if Has_Entries (Prottyp) then
Body_Id := Make_Defining_Identifier (Sloc (Prottyp),
New_External_Name (Chars (Prottyp), 'A'));
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else E_Count > 1
then
Body_Arr := Make_Object_Declaration (Loc,
Defining_Identifier => Body_Id,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (
RTE (RE_Protected_Entry_Body_Array), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Range (Loc,
Make_Integer_Literal (Loc, 1),
Make_Integer_Literal (Loc, E_Count))))),
Expression => Entries_Aggr);
else
Body_Arr := Make_Object_Declaration (Loc,
Defining_Identifier => Body_Id,
Aliased_Present => True,
Object_Definition => New_Reference_To (RTE (RE_Entry_Body), Loc),
Expression =>
Make_Aggregate (Loc,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Bdef, Loc),
Attribute_Name => Name_Unrestricted_Access),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Edef, Loc),
Attribute_Name => Name_Unrestricted_Access))));
end if;
Insert_After (Current_Node, Body_Arr);
Current_Node := Body_Arr;
Analyze (Body_Arr);
Set_Entry_Bodies_Array (Prottyp, Body_Id);
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else E_Count > 1
then
Sub :=
Make_Subprogram_Declaration (Loc,
Specification => Build_Find_Body_Index_Spec (Prottyp));
Insert_After (Current_Node, Sub);
Analyze (Sub);
end if;
end if;
end Expand_N_Protected_Type_Declaration;
procedure Expand_N_Requeue_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Acc_Stat : Node_Id;
Concval : Node_Id;
Ename : Node_Id;
Index : Node_Id;
Conctyp : Entity_Id;
Oldtyp : Entity_Id;
Lab_Node : Node_Id;
Rcall : Node_Id;
Abortable : Node_Id;
Skip_Stat : Node_Id;
Self_Param : Node_Id;
New_Param : Node_Id;
Params : List_Id;
RTS_Call : Entity_Id;
begin
Abortable :=
New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc);
Extract_Entry (N, Concval, Ename, Index);
Conctyp := Etype (Concval);
New_Param := Concurrent_Ref (Concval);
Params := New_List (
Entry_Index_Expression (Loc, Entity (Ename), Index, Conctyp),
Abortable);
Oldtyp := Current_Scope;
loop
if Is_Task_Type (Oldtyp) then
if Is_Task_Type (Conctyp) then
RTS_Call := RTE (RE_Requeue_Task_Entry);
else
pragma Assert (Is_Protected_Type (Conctyp));
RTS_Call := RTE (RE_Requeue_Task_To_Protected_Entry);
New_Param :=
Make_Attribute_Reference (Loc,
Prefix => New_Param,
Attribute_Name => Name_Unchecked_Access);
end if;
Prepend (New_Param, Params);
exit;
elsif Is_Protected_Type (Oldtyp) then
Self_Param :=
Make_Attribute_Reference (Loc,
Prefix => Concurrent_Ref (New_Occurrence_Of (Oldtyp, Loc)),
Attribute_Name => Name_Unchecked_Access);
if Is_Task_Type (Conctyp) then
RTS_Call := RTE (RE_Requeue_Protected_To_Task_Entry);
else
pragma Assert (Is_Protected_Type (Conctyp));
RTS_Call := RTE (RE_Requeue_Protected_Entry);
New_Param :=
Make_Attribute_Reference (Loc,
Prefix => New_Param,
Attribute_Name => Name_Unchecked_Access);
end if;
Prepend (New_Param, Params);
Prepend (Self_Param, Params);
exit;
else
Oldtyp := Scope (Oldtyp);
end if;
end loop;
Rcall := Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTS_Call, Loc),
Parameter_Associations => Params);
Rewrite (N, Rcall);
Analyze (N);
if Is_Protected_Type (Oldtyp) then
Skip_Stat := Make_Return_Statement (Loc);
else
Acc_Stat := Parent (N);
while Nkind (Acc_Stat) /= N_Accept_Statement loop
Acc_Stat := Parent (Acc_Stat);
end loop;
Lab_Node :=
Prev (Last (Statements (Handled_Statement_Sequence (Acc_Stat))));
pragma Assert (Nkind (Lab_Node) = N_Label);
Skip_Stat :=
Make_Goto_Statement (Loc,
Name => New_Occurrence_Of (Entity (Identifier (Lab_Node)), Loc));
end if;
Set_Analyzed (Skip_Stat);
Insert_After (N, Skip_Stat);
end Expand_N_Requeue_Statement;
procedure Expand_N_Selective_Accept (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Alts : constant List_Id := Select_Alternatives (N);
Accept_Case : List_Id;
Accept_List : constant List_Id := New_List;
Alt : Node_Id;
Alt_List : constant List_Id := New_List;
Alt_Stats : List_Id;
Ann : Entity_Id := Empty;
Block : Node_Id;
Check_Guard : Boolean := True;
Decls : constant List_Id := New_List;
Stats : constant List_Id := New_List;
Body_List : constant List_Id := New_List;
Trailing_List : constant List_Id := New_List;
Choices : List_Id;
Else_Present : Boolean := False;
Terminate_Alt : Node_Id := Empty;
Select_Mode : Node_Id;
Delay_Case : List_Id;
Delay_Count : Integer := 0;
Delay_Val : Entity_Id;
Delay_Index : Entity_Id;
Delay_Min : Entity_Id;
Delay_Num : Int := 1;
Delay_Alt_List : List_Id := New_List;
Delay_List : constant List_Id := New_List;
D : Entity_Id;
M : Entity_Id;
First_Delay : Boolean := True;
Guard_Open : Entity_Id;
End_Lab : Node_Id;
Index : Int := 1;
Lab : Node_Id;
Num_Alts : Int;
Num_Accept : Nat := 0;
Proc : Node_Id;
Q : Node_Id;
Time_Type : Entity_Id;
X : Node_Id;
Select_Call : Node_Id;
Qnam : constant Entity_Id :=
Make_Defining_Identifier (Loc, New_External_Name ('S', 0));
Xnam : constant Entity_Id :=
Make_Defining_Identifier (Loc, New_External_Name ('J', 1));
function Accept_Or_Raise return List_Id;
procedure Add_Accept (Alt : Node_Id);
function Make_And_Declare_Label (Num : Int) return Node_Id;
function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id;
procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int);
procedure Process_Accept_Alternative
(Alt : Node_Id;
Index : Int;
Proc : Node_Id);
function Accept_Or_Raise return List_Id is
Cond : Node_Id;
Stats : List_Id;
J : constant Entity_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('J'));
begin
Cond := Make_Op_Ne (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => Make_Indexed_Component (Loc,
Prefix => New_Reference_To (Qnam, Loc),
Expressions => New_List (New_Reference_To (J, Loc))),
Selector_Name => Make_Identifier (Loc, Name_S)),
Right_Opnd =>
New_Reference_To (RTE (RE_Null_Task_Entry), Loc));
Stats := New_List (
Make_Implicit_Loop_Statement (N,
Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => J,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Qnam, Loc),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, 1))))),
Statements => New_List (
Make_Implicit_If_Statement (N,
Condition => Cond,
Then_Statements => New_List (
Make_Select_Call (
New_Reference_To (RTE (RE_Simple_Mode), Loc)),
Make_Exit_Statement (Loc))))));
Append_To (Stats,
Make_Raise_Program_Error (Loc,
Condition => Make_Op_Eq (Loc,
Left_Opnd => New_Reference_To (Xnam, Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_No_Rendezvous), Loc)),
Reason => PE_All_Guards_Closed));
return Stats;
end Accept_Or_Raise;
procedure Add_Accept (Alt : Node_Id) is
Acc_Stm : constant Node_Id := Accept_Statement (Alt);
Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm);
Eent : constant Entity_Id := Entity (Ename);
Index : constant Node_Id := Entry_Index (Acc_Stm);
Null_Body : Node_Id;
Proc_Body : Node_Id;
PB_Ent : Entity_Id;
Expr : Node_Id;
Call : Node_Id;
begin
if No (Ann) then
Ann := Node (Last_Elmt (Accept_Address (Eent)));
end if;
if Present (Condition (Alt)) then
Expr :=
Make_Conditional_Expression (Loc, New_List (
Condition (Alt),
Entry_Index_Expression (Loc, Eent, Index, Scope (Eent)),
New_Reference_To (RTE (RE_Null_Task_Entry), Loc)));
else
Expr :=
Entry_Index_Expression
(Loc, Eent, Index, Scope (Eent));
end if;
if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
Null_Body := New_Reference_To (Standard_False, Loc);
if Abort_Allowed then
Call := Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc));
Insert_Before (First (Statements (Handled_Statement_Sequence (
Accept_Statement (Alt)))), Call);
Analyze (Call);
end if;
PB_Ent :=
Make_Defining_Identifier (Sloc (Ename),
New_External_Name (Chars (Ename), 'A', Num_Accept));
Set_Needs_Debug_Info (PB_Ent, Comes_From_Source (Alt));
Proc_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => PB_Ent),
Declarations => Declarations (Acc_Stm),
Handled_Statement_Sequence =>
Build_Accept_Body (Accept_Statement (Alt)));
Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt));
Append (Proc_Body, Body_List);
else
Null_Body := New_Reference_To (Standard_True, Loc);
if Present (Declarations (Acc_Stm)) then
Insert_Actions (N, Declarations (Acc_Stm));
end if;
end if;
Append_To (Accept_List,
Make_Aggregate (Loc, Expressions => New_List (Null_Body, Expr)));
Num_Accept := Num_Accept + 1;
end Add_Accept;
function Make_And_Declare_Label (Num : Int) return Node_Id is
Lab_Id : Node_Id;
begin
Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num));
Lab :=
Make_Label (Loc, Lab_Id);
Append_To (Decls,
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars (Lab_Id)),
Label_Construct => Lab));
return Lab;
end Make_And_Declare_Label;
function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is
Params : constant List_Id := New_List;
begin
Append (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Qnam, Loc),
Attribute_Name => Name_Unchecked_Access),
Params);
Append (Select_Mode, Params);
Append (New_Reference_To (Ann, Loc), Params);
Append (New_Reference_To (Xnam, Loc), Params);
return
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Selective_Wait), Loc),
Parameter_Associations => Params);
end Make_Select_Call;
procedure Process_Accept_Alternative
(Alt : Node_Id;
Index : Int;
Proc : Node_Id)
is
Choices : List_Id := No_List;
Alt_Stats : List_Id;
begin
Adjust_Condition (Condition (Alt));
Alt_Stats := No_List;
if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
Choices := New_List (
Make_Integer_Literal (Loc, Index));
Alt_Stats := New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
Defining_Unit_Name (Specification (Proc)), Loc)));
end if;
if Statements (Alt) /= Empty_List then
if No (Alt_Stats) then
Choices := New_List (
Make_Integer_Literal (Loc, Index));
Alt_Stats := New_List;
end if;
Lab := Make_And_Declare_Label (Index);
Append_To (Alt_Stats,
Make_Goto_Statement (Loc,
Name => New_Copy (Identifier (Lab))));
Append (Lab, Trailing_List);
Append_List (Statements (Alt), Trailing_List);
Append_To (Trailing_List,
Make_Goto_Statement (Loc,
Name => New_Copy (Identifier (End_Lab))));
end if;
if Present (Alt_Stats) then
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => Choices,
Statements => Alt_Stats));
end if;
end Process_Accept_Alternative;
procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is
Choices : List_Id;
Cond : Node_Id;
Delay_Alt : List_Id;
begin
Adjust_Condition (Condition (Alt));
if Delay_Count = 1
or else First_Delay
then
First_Delay := False;
Delay_Alt := New_List (
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Delay_Min, Loc),
Expression => Expression (Delay_Statement (Alt))));
if Delay_Count > 1 then
Append_To (Delay_Alt,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Delay_Index, Loc),
Expression => Make_Integer_Literal (Loc, Index)));
end if;
else
Delay_Alt := New_List (
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Delay_Val, Loc),
Expression => Expression (Delay_Statement (Alt))));
if Time_Type = Standard_Duration then
Cond :=
Make_Op_Lt (Loc,
Left_Opnd => New_Reference_To (Delay_Val, Loc),
Right_Opnd => New_Reference_To (Delay_Min, Loc));
else
Cond :=
Make_Function_Call (Loc,
Name => Make_Selected_Component (Loc,
Prefix => New_Reference_To (Scope (Time_Type), Loc),
Selector_Name =>
Make_Operator_Symbol (Loc,
Chars => Name_Op_Lt,
Strval => No_String)),
Parameter_Associations =>
New_List (
New_Reference_To (Delay_Val, Loc),
New_Reference_To (Delay_Min, Loc)));
Set_Entity (Prefix (Name (Cond)), Scope (Time_Type));
end if;
Append_To (Delay_Alt,
Make_Implicit_If_Statement (N,
Condition => Cond,
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Delay_Min, Loc),
Expression => New_Reference_To (Delay_Val, Loc)),
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Delay_Index, Loc),
Expression => Make_Integer_Literal (Loc, Index)))));
end if;
if Check_Guard then
Append_To (Delay_Alt,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Guard_Open, Loc),
Expression => New_Reference_To (Standard_True, Loc)));
end if;
if Present (Condition (Alt)) then
Delay_Alt := New_List (
Make_Implicit_If_Statement (N,
Condition => Condition (Alt),
Then_Statements => Delay_Alt));
end if;
Append_List (Delay_Alt, Delay_List);
if Present (Statements (Alt)) then
if Delay_Count = 1 then
Append_List (Statements (Alt), Delay_Alt_List);
else
Choices := New_List (
Make_Integer_Literal (Loc, Index));
Append_To (Delay_Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => Choices,
Statements => Statements (Alt)));
end if;
elsif Delay_Count = 1 then
Delay_Alt_List := New_List (
Make_Goto_Statement (Loc,
Name => New_Copy (Identifier (End_Lab))));
end if;
end Process_Delay_Alternative;
begin
Num_Alts := 0;
Alt := First (Alts);
while Present (Alt) loop
if Nkind (Alt) = N_Accept_Alternative then
Add_Accept (Alt);
elsif Nkind (Alt) = N_Delay_Alternative then
Delay_Count := Delay_Count + 1;
if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then
Time_Type := Standard_Duration;
else
Time_Type := Etype (Expression (Delay_Statement (Alt)));
if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time)
or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)
then
null;
else
Error_Msg_NE (
"& is not a time type ('R'M 9.6(6))",
Expression (Delay_Statement (Alt)), Time_Type);
Time_Type := Standard_Duration;
Set_Etype (Expression (Delay_Statement (Alt)), Any_Type);
end if;
end if;
if No (Condition (Alt)) then
Check_Guard := False;
end if;
elsif Nkind (Alt) = N_Terminate_Alternative then
Adjust_Condition (Condition (Alt));
Terminate_Alt := Alt;
end if;
Num_Alts := Num_Alts + 1;
Next (Alt);
end loop;
Else_Present := Present (Else_Statements (N));
Q :=
Make_Object_Declaration (Loc,
Defining_Identifier => Qnam,
Object_Definition =>
New_Reference_To (RTE (RE_Accept_List), Loc),
Aliased_Present => True,
Expression =>
Make_Qualified_Expression (Loc,
Subtype_Mark =>
New_Reference_To (RTE (RE_Accept_List), Loc),
Expression =>
Make_Aggregate (Loc, Expressions => Accept_List)));
Append (Q, Decls);
X :=
Make_Object_Declaration (Loc,
Defining_Identifier => Xnam,
Object_Definition =>
New_Reference_To (RTE (RE_Select_Index), Loc),
Expression =>
New_Reference_To (RTE (RE_No_Rendezvous), Loc));
Append (X, Decls);
if Delay_Count > 0 then
Delay_Val :=
Make_Defining_Identifier (Loc, New_External_Name ('D', 1));
Delay_Index :=
Make_Defining_Identifier (Loc, New_External_Name ('D', 2));
Delay_Min :=
Make_Defining_Identifier (Loc, New_External_Name ('D', 3));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Delay_Val,
Object_Definition => New_Reference_To (Time_Type, Loc)));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Delay_Index,
Object_Definition => New_Reference_To (Standard_Integer, Loc),
Expression => Make_Integer_Literal (Loc, 0)));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Delay_Min,
Object_Definition => New_Reference_To (Time_Type, Loc),
Expression =>
Unchecked_Convert_To (Time_Type,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Underlying_Type (Time_Type), Loc),
Attribute_Name => Name_Last))));
D := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
M := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
declare
Discr : Entity_Id;
begin
if Time_Type = Standard_Duration then
Discr := Make_Integer_Literal (Loc, 0);
elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
Discr := Make_Integer_Literal (Loc, 1);
else
pragma Assert
(Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
Discr := Make_Integer_Literal (Loc, 2);
end if;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => D,
Object_Definition =>
New_Reference_To (Standard_Duration, Loc)));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => M,
Object_Definition =>
New_Reference_To (Standard_Integer, Loc),
Expression => Discr));
end;
if Check_Guard then
Guard_Open :=
Make_Defining_Identifier (Loc, New_External_Name ('G', 1));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Guard_Open,
Object_Definition => New_Reference_To (Standard_Boolean, Loc),
Expression => New_Reference_To (Standard_False, Loc)));
end if;
else
M := Empty;
D := Empty;
end if;
if Present (Terminate_Alt) then
if Present (Condition (Terminate_Alt)) then
Select_Mode := Make_Conditional_Expression (Loc,
New_List (Condition (Terminate_Alt),
New_Reference_To (RTE (RE_Terminate_Mode), Loc),
New_Reference_To (RTE (RE_Simple_Mode), Loc)));
else
Select_Mode := New_Reference_To (RTE (RE_Terminate_Mode), Loc);
end if;
elsif Else_Present or Delay_Count > 0 then
Select_Mode := New_Reference_To (RTE (RE_Else_Mode), Loc);
else
Select_Mode := New_Reference_To (RTE (RE_Simple_Mode), Loc);
end if;
Select_Call := Make_Select_Call (Select_Mode);
Append (Select_Call, Stats);
End_Lab := Make_And_Declare_Label (Num_Alts + 1);
Choices := New_List (New_Reference_To (RTE (RE_No_Rendezvous), Loc));
if Else_Present then
Lab := Make_And_Declare_Label (0);
Alt_Stats := New_List (
Make_Goto_Statement (Loc,
Name => New_Copy (Identifier (Lab))));
Append (Lab, Trailing_List);
Append_List (Else_Statements (N), Trailing_List);
Append_To (Trailing_List,
Make_Goto_Statement (Loc,
Name => New_Copy (Identifier (End_Lab))));
else
Alt_Stats := New_List (
Make_Goto_Statement (Loc,
Name => New_Copy (Identifier (End_Lab))));
end if;
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => Choices,
Statements => Alt_Stats));
Alt := First (Select_Alternatives (N));
Proc := First (Body_List);
while Present (Alt) loop
if Nkind (Alt) = N_Accept_Alternative then
Process_Accept_Alternative (Alt, Index, Proc);
Index := Index + 1;
if Present
(Handled_Statement_Sequence (Accept_Statement (Alt)))
then
Next (Proc);
end if;
elsif Nkind (Alt) = N_Delay_Alternative then
Process_Delay_Alternative (Alt, Delay_Num);
Delay_Num := Delay_Num + 1;
end if;
Next (Alt);
end loop;
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices =>
New_List (Make_Others_Choice (Loc)),
Statements =>
New_List (Make_Goto_Statement (Loc,
Name => New_Copy (Identifier (End_Lab))))));
Accept_Case := New_List (
Make_Case_Statement (Loc,
Expression => New_Reference_To (Xnam, Loc),
Alternatives => Alt_List));
Append_List (Trailing_List, Accept_Case);
Append (End_Lab, Accept_Case);
Append_List (Body_List, Decls);
if Delay_Count > 1 then
Append_To (Delay_Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices =>
New_List (Make_Others_Choice (Loc)),
Statements =>
New_List (Make_Null_Statement (Loc))));
Delay_Case := New_List (
Make_Case_Statement (Loc,
Expression => New_Reference_To (Delay_Index, Loc),
Alternatives => Delay_Alt_List));
else
Delay_Case := Delay_Alt_List;
end if;
if Delay_Count = 0 then
Append_List (Accept_Case, Stats);
else
declare
Cases : Node_Id;
Stmt : Node_Id;
Parms : List_Id;
Parm : Node_Id;
Conv : Node_Id;
begin
if Time_Type = Standard_Duration then
Conv := New_Reference_To (Delay_Min, Loc);
elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
Conv := Make_Function_Call (Loc,
New_Reference_To (RTE (RO_CA_To_Duration), Loc),
New_List (New_Reference_To (Delay_Min, Loc)));
else
pragma Assert
(Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
Conv := Make_Function_Call (Loc,
New_Reference_To (RTE (RO_RT_To_Duration), Loc),
New_List (New_Reference_To (Delay_Min, Loc)));
end if;
Stmt := Make_Assignment_Statement (Loc,
Name => New_Reference_To (D, Loc),
Expression => Conv);
Parms := Parameter_Associations (Select_Call);
Parm := First (Parms);
while Present (Parm)
and then Parm /= Select_Mode
loop
Next (Parm);
end loop;
pragma Assert (Present (Parm));
Rewrite (Parm, New_Reference_To (RTE (RE_Delay_Mode), Loc));
Analyze (Parm);
Next (Parm);
Insert_After (Parm, New_Reference_To (M, Loc));
Insert_After (Parm, New_Reference_To (D, Loc));
Rewrite (Select_Call,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Timed_Selective_Wait), Loc),
Parameter_Associations => Parms));
Insert_List_Before (Select_Call, Delay_List);
if Check_Guard then
Stmt :=
Make_Implicit_If_Statement (N,
Condition => New_Reference_To (Guard_Open, Loc),
Then_Statements =>
New_List (New_Copy_Tree (Stmt),
New_Copy_Tree (Select_Call)),
Else_Statements => Accept_Or_Raise);
Rewrite (Select_Call, Stmt);
else
Insert_Before (Select_Call, Stmt);
end if;
Cases :=
Make_Implicit_If_Statement (N,
Condition => Make_Op_Eq (Loc,
Left_Opnd => New_Reference_To (Xnam, Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_No_Rendezvous), Loc)),
Then_Statements => Delay_Case,
Else_Statements => Accept_Case);
Append (Cases, Stats);
end;
end if;
Block :=
Make_Block_Statement (Loc,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stats));
Rewrite (N, Block);
Analyze (N);
Alt := First (Alts);
while Present (Alt) loop
if Nkind (Alt) = N_Accept_Alternative then
Remove_Last_Elmt (Accept_Address
(Entity (Entry_Direct_Name (Accept_Statement (Alt)))));
end if;
Next (Alt);
end loop;
end Expand_N_Selective_Accept;
procedure Expand_N_Single_Task_Declaration (N : Node_Id) is
begin
raise Program_Error;
end Expand_N_Single_Task_Declaration;
procedure Expand_N_Task_Body (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ttyp : constant Entity_Id := Corresponding_Spec (N);
Call : Node_Id;
New_N : Node_Id;
begin
Add_Discriminal_Declarations (Declarations (N), Ttyp, Name_uTask, Loc);
if Abort_Allowed then
Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
Insert_Before
(First (Statements (Handled_Statement_Sequence (N))), Call);
Analyze (Call);
end if;
if Restricted_Profile then
Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation);
else
Call := Build_Runtime_Call (Loc, RE_Complete_Activation);
end if;
Insert_Before
(First_Real_Statement (Handled_Statement_Sequence (N)), Call);
Analyze (Call);
New_N :=
Make_Subprogram_Body (Loc,
Specification => Build_Task_Proc_Specification (Ttyp),
Declarations => Declarations (N),
Handled_Statement_Sequence => Handled_Statement_Sequence (N));
if Delay_Cleanups (Ttyp) then
Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N));
Set_Is_Task_Master (New_N, Is_Task_Master (N));
end if;
Rewrite (N, New_N);
Analyze (N);
if Nkind (Parent (N)) /= N_Subunit then
Insert_After (N,
Make_Assignment_Statement (Loc,
Name =>
Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')),
Expression => New_Reference_To (Standard_True, Loc)));
end if;
end Expand_N_Task_Body;
procedure Expand_N_Task_Type_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N));
Tasknm : constant Name_Id := Chars (Tasktyp);
Taskdef : constant Node_Id := Task_Definition (N);
Proc_Spec : Node_Id;
Rec_Decl : Node_Id;
Rec_Ent : Entity_Id;
Cdecls : List_Id;
Elab_Decl : Node_Id;
Size_Decl : Node_Id;
Body_Decl : Node_Id;
Task_Size : Node_Id;
Ent_Stack : Entity_Id;
Decl_Stack : Node_Id;
begin
if Present (Corresponding_Record_Type (Tasktyp)) then
return;
end if;
Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc);
Rec_Ent := Defining_Identifier (Rec_Decl);
Cdecls := Component_Items (Component_List
(Type_Definition (Rec_Decl)));
Qualify_Entity_Names (N);
Elab_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Sloc (Tasktyp),
Chars => New_External_Name (Tasknm, 'E')),
Aliased_Present => True,
Object_Definition => New_Reference_To (Standard_Boolean, Loc),
Expression => New_Reference_To (Standard_False, Loc));
Insert_After (N, Elab_Decl);
Set_Storage_Size_Variable (Tasktyp,
Make_Defining_Identifier (Sloc (Tasktyp),
Chars => New_External_Name (Tasknm, 'Z')));
if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) and then
Is_Static_Expression (Expression (First (
Pragma_Argument_Associations (Find_Task_Or_Protected_Pragma (
Taskdef, Name_Storage_Size)))))
then
Size_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Storage_Size_Variable (Tasktyp),
Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc),
Expression =>
Convert_To (RTE (RE_Size_Type),
Relocate_Node (
Expression (First (
Pragma_Argument_Associations (
Find_Task_Or_Protected_Pragma
(Taskdef, Name_Storage_Size)))))));
else
Size_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Storage_Size_Variable (Tasktyp),
Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc),
Expression => New_Reference_To (RTE (RE_Unspecified_Size), Loc));
end if;
Insert_After (Elab_Decl, Size_Decl);
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uTask_Id),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication => New_Reference_To (RTE (RO_ST_Task_Id),
Loc))));
if Restricted_Profile then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uATCB),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => True,
Subtype_Indication => Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of
(RTE (RE_Ada_Task_Control_Block), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints =>
New_List (Make_Integer_Literal (Loc, 0)))))));
end if;
if Restricted_Profile
and then Preallocated_Stacks_On_Target
then
Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack);
if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
Task_Size := Relocate_Node (
Expression (First (
Pragma_Argument_Associations (
Find_Task_Or_Protected_Pragma
(Taskdef, Name_Storage_Size)))));
else
Task_Size :=
New_Reference_To (RTE (RE_Default_Stack_Size), Loc);
end if;
Decl_Stack := Make_Component_Declaration (Loc,
Defining_Identifier => Ent_Stack,
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => True,
Subtype_Indication => Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound => Convert_To (RTE (RE_Storage_Offset),
Task_Size)))))));
Append_To (Cdecls, Decl_Stack);
end if;
Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
if Present (Taskdef) and then Has_Priority_Pragma (Taskdef) then
declare
Prag : constant Node_Id :=
Find_Task_Or_Protected_Pragma (Taskdef, Name_Priority);
Expr : Node_Id;
begin
Expr := First (Pragma_Argument_Associations (Prag));
if Nkind (Expr) = N_Pragma_Argument_Association then
Expr := Expression (Expr);
end if;
Expr := New_Copy_Tree (Expr);
if Chars (Prag) = Name_Priority
and then not GNAT_Mode
then
Rewrite (Expr, Convert_To (RTE (RE_Priority), Expr));
else
Rewrite (Expr, Convert_To (RTE (RE_Any_Priority), Expr));
end if;
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uPriority),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication => New_Reference_To (Standard_Integer,
Loc)),
Expression => Expr));
end;
end if;
if Present (Taskdef)
and then Has_Storage_Size_Pragma (Taskdef)
then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uSize),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication => New_Reference_To (RTE (RE_Size_Type),
Loc)),
Expression =>
Convert_To (RTE (RE_Size_Type),
Relocate_Node (
Expression (First (
Pragma_Argument_Associations (
Find_Task_Or_Protected_Pragma
(Taskdef, Name_Storage_Size))))))));
end if;
if Present (Taskdef) and then Has_Task_Info_Pragma (Taskdef) then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uTask_Info),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Reference_To (RTE (RE_Task_Info_Type), Loc)),
Expression => New_Copy (
Expression (First (
Pragma_Argument_Associations (
Find_Task_Or_Protected_Pragma
(Taskdef, Name_Task_Info)))))));
end if;
Insert_After (Size_Decl, Rec_Decl);
Analyze (Rec_Decl);
Proc_Spec := Build_Task_Proc_Specification (Tasktyp);
Body_Decl :=
Make_Subprogram_Declaration (Loc,
Specification => Proc_Spec);
Insert_After (Rec_Decl, Body_Decl);
Set_Needs_Debug_Info
(Defining_Entity (Proc_Spec), Comes_From_Source (Original_Node (N)));
declare
L : constant List_Id := Freeze_Entity (Rec_Ent, Loc);
begin
if Is_Non_Empty_List (L) then
Insert_List_After (Body_Decl, L);
end if;
end;
Expand_Previous_Access_Type (Tasktyp);
end Expand_N_Task_Type_Declaration;
procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
E_Call : Node_Id :=
Entry_Call_Statement (Entry_Call_Alternative (N));
E_Stats : constant List_Id :=
Statements (Entry_Call_Alternative (N));
D_Stat : constant Node_Id :=
Delay_Statement (Delay_Alternative (N));
D_Stats : constant List_Id :=
Statements (Delay_Alternative (N));
Stmts : List_Id;
Stmt : Node_Id;
Parms : List_Id;
Parm : Node_Id;
Concval : Node_Id;
Ename : Node_Id;
Index : Node_Id;
Decls : List_Id;
Disc : Node_Id;
Conv : Node_Id;
B : Entity_Id;
D : Entity_Id;
Dtyp : Entity_Id;
M : Entity_Id;
Call : Node_Id;
Dummy : Node_Id;
begin
if Nkind (E_Call) = N_Block_Statement then
E_Call := First (Statements (Handled_Statement_Sequence (E_Call)));
while Nkind (E_Call) /= N_Procedure_Call_Statement
and then Nkind (E_Call) /= N_Entry_Call_Statement
loop
Next (E_Call);
end loop;
end if;
Extract_Entry (E_Call, Concval, Ename, Index);
Build_Simple_Entry_Call (E_Call, Concval, Ename, Index);
Stmts := Statements (Handled_Statement_Sequence (E_Call));
Decls := Declarations (E_Call);
if No (Decls) then
Decls := New_List;
end if;
Dtyp := Base_Type (Etype (Expression (D_Stat)));
if Nkind (D_Stat) = N_Delay_Relative_Statement then
Disc := Make_Integer_Literal (Loc, 0);
Conv := Relocate_Node (Expression (D_Stat));
elsif Is_RTE (Dtyp, RO_CA_Time) then
Disc := Make_Integer_Literal (Loc, 1);
Conv := Make_Function_Call (Loc,
New_Reference_To (RTE (RO_CA_To_Duration), Loc),
New_List (New_Copy (Expression (D_Stat))));
else pragma Assert (Is_RTE (Dtyp, RO_RT_Time));
Disc := Make_Integer_Literal (Loc, 2);
Conv := Make_Function_Call (Loc,
New_Reference_To (RTE (RO_RT_To_Duration), Loc),
New_List (New_Copy (Expression (D_Stat))));
end if;
D := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
M := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => D,
Object_Definition => New_Reference_To (Standard_Duration, Loc)));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => M,
Object_Definition => New_Reference_To (Standard_Integer, Loc),
Expression => Disc));
B := Make_Defining_Identifier (Loc, Name_uB);
Prepend_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => B,
Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
Stmt := First (Stmts);
while Nkind (Stmt) /= N_Procedure_Call_Statement loop
Next (Stmt);
end loop;
Insert_Before (Stmt,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (D, Loc),
Expression => Conv));
Call := Stmt;
Parms := Parameter_Associations (Call);
if Is_Protected_Type (Etype (Concval)) then
Parm := First (Parms);
while Present (Parm)
and then not Is_RTE (Etype (Parm), RE_Call_Modes)
loop
Next (Parm);
end loop;
Dummy := Remove_Next (Next (Parm));
Dummy := Next (Parm);
pragma Assert (Present (Parm));
Rewrite (Parm, New_Reference_To (D, Loc));
Rewrite (Dummy, New_Reference_To (M, Loc));
Append_To (Parms, New_Reference_To (B, Loc));
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Etype (Concval)) > 1
then
Rewrite (Call,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
Parameter_Associations => Parms));
else
Parm := First (Parms);
while Present (Parm)
and then not Is_RTE (Etype (Parm), RE_Protected_Entry_Index)
loop
Next (Parm);
end loop;
Remove (Parm);
Rewrite (Call,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
Parameter_Associations => Parms));
end if;
else
Append_To (Parms, New_Reference_To (D, Loc));
Append_To (Parms, New_Reference_To (M, Loc));
Append_To (Parms, New_Reference_To (B, Loc));
Rewrite (Call,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
Parameter_Associations => Parms));
end if;
Append_To (Stmts,
Make_Implicit_If_Statement (N,
Condition => New_Reference_To (B, Loc),
Then_Statements => E_Stats,
Else_Statements => D_Stats));
Rewrite (N,
Make_Block_Statement (Loc,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
Analyze (N);
end Expand_N_Timed_Entry_Call;
procedure Expand_Protected_Body_Declarations
(N : Node_Id;
Spec_Id : Entity_Id)
is
Op : Node_Id;
begin
if No_Run_Time_Mode then
Error_Msg_CRT ("protected body", N);
return;
elsif Expander_Active then
Op := First_Protected_Operation (Declarations (N));
if Present (Op) then
Set_Discriminals (Parent (Spec_Id));
Set_Privals (Parent (Spec_Id), Op, Sloc (N));
end if;
end if;
end Expand_Protected_Body_Declarations;
function External_Subprogram (E : Entity_Id) return Entity_Id is
Subp : constant Entity_Id := Protected_Body_Subprogram (E);
Decl : constant Node_Id := Unit_Declaration_Node (E);
begin
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;
procedure Extract_Entry
(N : Node_Id;
Concval : out Node_Id;
Ename : out Node_Id;
Index : out Node_Id)
is
Nam : constant Node_Id := Name (N);
begin
if Nkind (Nam) = N_Selected_Component then
Concval := Prefix (Nam);
Ename := Selector_Name (Nam);
Index := Empty;
else
pragma Assert (Nkind (Nam) = N_Indexed_Component);
Concval := Prefix (Prefix (Nam));
Ename := Selector_Name (Prefix (Nam));
Index := First (Expressions (Nam));
end if;
end Extract_Entry;
function Family_Offset
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
Ttyp : Entity_Id) return Node_Id
is
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Bound);
B : Node_Id;
D : Entity_Id;
begin
if Is_Entity_Name (Bound)
and then Ekind (Entity (Bound)) = E_Discriminant
then
if Is_Task_Type (Ttyp)
and then Has_Completion (Ttyp)
then
B := Make_Identifier (Loc, Chars (Entity (Bound)));
Find_Direct_Name (B);
elsif Is_Protected_Type (Ttyp) then
D := First_Discriminant (Ttyp);
while Chars (D) /= Chars (Entity (Bound)) loop
Next_Discriminant (D);
end loop;
B := New_Reference_To (Discriminal (D), Loc);
else
B := New_Reference_To (Discriminal (Entity (Bound)), Loc);
end if;
elsif Nkind (Bound) = N_Attribute_Reference then
return Bound;
else
B := New_Copy_Tree (Bound);
end if;
return
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Pos,
Prefix => New_Occurrence_Of (Etype (Bound), Loc),
Expressions => New_List (B));
end Convert_Discriminant_Ref;
begin
return
Make_Op_Subtract (Loc,
Left_Opnd => Convert_Discriminant_Ref (Hi),
Right_Opnd => Convert_Discriminant_Ref (Lo));
end Family_Offset;
function Family_Size
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
Ttyp : Entity_Id) return Node_Id
is
Ityp : Entity_Id;
begin
if Is_Task_Type (Ttyp) then
Ityp := RTE (RE_Task_Entry_Index);
else
Ityp := RTE (RE_Protected_Entry_Index);
end if;
return
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ityp, Loc),
Attribute_Name => Name_Max,
Expressions => New_List (
Make_Op_Add (Loc,
Left_Opnd =>
Family_Offset (Loc, Hi, Lo, Ttyp),
Right_Opnd =>
Make_Integer_Literal (Loc, 1)),
Make_Integer_Literal (Loc, 0)));
end Family_Size;
function Find_Task_Or_Protected_Pragma
(T : Node_Id;
P : Name_Id) return Node_Id
is
N : Node_Id;
begin
N := First (Visible_Declarations (T));
while Present (N) loop
if Nkind (N) = N_Pragma then
if Chars (N) = P then
return N;
elsif P = Name_Priority
and then Chars (N) = Name_Interrupt_Priority
then
return N;
else
Next (N);
end if;
else
Next (N);
end if;
end loop;
N := First (Private_Declarations (T));
while Present (N) loop
if Nkind (N) = N_Pragma then
if Chars (N) = P then
return N;
elsif P = Name_Priority
and then Chars (N) = Name_Interrupt_Priority
then
return N;
else
Next (N);
end if;
else
Next (N);
end if;
end loop;
raise Program_Error;
end Find_Task_Or_Protected_Pragma;
function First_Protected_Operation (D : List_Id) return Node_Id is
First_Op : Node_Id;
begin
First_Op := First (D);
while Present (First_Op)
and then Nkind (First_Op) /= N_Subprogram_Body
and then Nkind (First_Op) /= N_Entry_Body
loop
Next (First_Op);
end loop;
return First_Op;
end First_Protected_Operation;
function Index_Constant_Declaration
(N : Node_Id;
Index_Id : Entity_Id;
Prot : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
Decls : constant List_Id := New_List;
Index_Con : constant Entity_Id := Entry_Index_Constant (Index_Id);
Index_Typ : Entity_Id;
Hi : Node_Id := Type_High_Bound (Etype (Index_Id));
Lo : Node_Id := Type_Low_Bound (Etype (Index_Id));
function Replace_Discriminant (Bound : Node_Id) return Node_Id;
function Replace_Discriminant (Bound : Node_Id) return Node_Id is
begin
if Nkind (Bound) = N_Identifier
and then Ekind (Entity (Bound)) = E_Constant
and then Present (Discriminal_Link (Entity (Bound)))
then
return Make_Identifier (Loc, Chars (Entity (Bound)));
else
return Duplicate_Subexpr (Bound);
end if;
end Replace_Discriminant;
begin
Set_Discriminal_Link (Index_Con, Index_Id);
if Is_Entity_Name (
Original_Node (Discrete_Subtype_Definition (Parent (Index_Id))))
then
Index_Typ := Etype (Index_Id);
else
Hi := Replace_Discriminant (Hi);
Lo := Replace_Discriminant (Lo);
Index_Typ := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
Append (
Make_Subtype_Declaration (Loc,
Defining_Identifier => Index_Typ,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Base_Type (Etype (Index_Id)), Loc),
Constraint =>
Make_Range_Constraint (Loc,
Range_Expression => Make_Range (Loc, Lo, Hi)))),
Decls);
end if;
Append (
Make_Object_Declaration (Loc,
Defining_Identifier => Index_Con,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Index_Typ, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Index_Typ, Loc),
Attribute_Name => Name_Val,
Expressions => New_List (
Make_Op_Add (Loc,
Left_Opnd =>
Make_Op_Subtract (Loc,
Left_Opnd => Make_Identifier (Loc, Name_uE),
Right_Opnd =>
Entry_Index_Expression (Loc,
Defining_Identifier (N), Empty, Prot)),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Index_Typ, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Index_Typ, Loc),
Attribute_Name => Name_First))))))),
Decls);
return Decls;
end Index_Constant_Declaration;
function Make_Initialize_Protection
(Protect_Rec : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Protect_Rec);
P_Arr : Entity_Id;
Pdef : Node_Id;
Pdec : Node_Id;
Ptyp : constant Node_Id :=
Corresponding_Concurrent_Type (Protect_Rec);
Args : List_Id;
L : constant List_Id := New_List;
Has_Entry : constant Boolean := Has_Entries (Ptyp);
Restricted : constant Boolean := Restricted_Profile;
begin
Pdec := Parent (Ptyp);
while Nkind (Pdec) /= N_Protected_Type_Declaration
and then Nkind (Pdec) /= N_Single_Protected_Declaration
loop
Next (Pdec);
end loop;
Pdef := Protected_Definition (Pdec);
Args := New_List;
Append_To (Args,
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uObject)),
Attribute_Name => Name_Unchecked_Access));
if Present (Pdef)
and then Has_Priority_Pragma (Pdef)
then
Append_To (Args,
Duplicate_Subexpr_No_Checks
(Expression
(First
(Pragma_Argument_Associations
(Find_Task_Or_Protected_Pragma (Pdef, Name_Priority))))));
elsif Has_Interrupt_Handler (Ptyp)
or else Has_Attach_Handler (Ptyp)
then
Append_To (Args,
New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc));
else
Append_To (Args,
New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
end if;
if Has_Entry
or else Has_Interrupt_Handler (Ptyp)
or else Has_Attach_Handler (Ptyp)
then
if Has_Entry or else not Restricted then
Append_To (Args,
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Attribute_Name => Name_Address));
end if;
if Has_Entry then
P_Arr := Entry_Bodies_Array (Ptyp);
Append_To (Args,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (P_Arr, Loc),
Attribute_Name => Name_Unrestricted_Access));
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Ptyp) > 1
then
while Ekind (P_Arr) /= E_Function loop
Next_Entity (P_Arr);
end loop;
Append_To (Args,
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (P_Arr, Loc),
Attribute_Name => Name_Unrestricted_Access));
end if;
elsif not Restricted then
Append_To (Args, Make_Null (Loc));
Append_To (Args, Make_Null (Loc));
end if;
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Ptyp) > 1
then
Append_To (L,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
RTE (RE_Initialize_Protection_Entries), Loc),
Parameter_Associations => Args));
elsif not Has_Entry and then Restricted then
Append_To (L,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
RTE (RE_Initialize_Protection), Loc),
Parameter_Associations => Args));
else
Append_To (L,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
RTE (RE_Initialize_Protection_Entry), Loc),
Parameter_Associations => Args));
end if;
else
Append_To (L,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc),
Parameter_Associations => Args));
end if;
if Has_Attach_Handler (Ptyp) then
declare
Args : constant List_Id := New_List;
Table : constant List_Id := New_List;
Ritem : Node_Id := First_Rep_Item (Ptyp);
begin
if not Restricted then
Append_To (Args,
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uObject)),
Attribute_Name => Name_Unchecked_Access));
end if;
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
and then Chars (Ritem) = Name_Attach_Handler
then
declare
Handler : constant Node_Id :=
First (Pragma_Argument_Associations (Ritem));
Interrupt : constant Node_Id := Next (Handler);
Expr : constant Node_Id := Expression (Interrupt);
begin
Append_To (Table,
Make_Aggregate (Loc, Expressions => New_List (
Unchecked_Convert_To
(RTE (RE_System_Interrupt_Id), Expr),
Make_Attribute_Reference (Loc,
Prefix => Make_Selected_Component (Loc,
Make_Identifier (Loc, Name_uInit),
Duplicate_Subexpr_No_Checks
(Expression (Handler))),
Attribute_Name => Name_Access))));
end;
end if;
Next_Rep_Item (Ritem);
end loop;
Append_To (Args, Make_Aggregate (Loc, Table));
Append_To (L,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Install_Handlers), Loc),
Parameter_Associations => Args));
end;
end if;
return L;
end Make_Initialize_Protection;
function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Task_Rec);
Name : Node_Id;
Tdef : Node_Id;
Tdec : Node_Id;
Ttyp : Node_Id;
Tnam : Name_Id;
Args : List_Id;
Ecount : Node_Id;
begin
Ttyp := Corresponding_Concurrent_Type (Task_Rec);
Tnam := Chars (Ttyp);
Tdec := Parent (Ttyp);
while Nkind (Tdec) /= N_Task_Type_Declaration
and then Nkind (Tdec) /= N_Single_Task_Declaration
loop
Next (Tdec);
end loop;
Tdef := Task_Definition (Tdec);
Args := New_List;
if Present (Tdef) and then Has_Priority_Pragma (Tdef) then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uPriority)));
else
Append_To (Args,
New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
end if;
if Restricted_Profile then
if Preallocated_Stacks_On_Target then
Append_To (Args,
Make_Attribute_Reference (Loc,
Prefix => Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name =>
Make_Identifier (Loc, Name_uStack)),
Attribute_Name => Name_Address));
else
Append_To (Args,
New_Reference_To (RTE (RE_Null_Address), Loc));
end if;
end if;
if Present (Tdef)
and then Has_Storage_Size_Pragma (Tdef)
then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uSize)));
else
Append_To (Args,
New_Reference_To (Storage_Size_Variable (Ttyp), Loc));
end if;
if Present (Tdef)
and then Has_Task_Info_Pragma (Tdef)
then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uTask_Info)));
else
Append_To (Args,
New_Reference_To (RTE (RE_Unspecified_Task_Info), Loc));
end if;
if not Restricted_Profile then
Ecount := Build_Entry_Count_Expression (
Ttyp,
Component_Items (Component_List (
Type_Definition (Parent (
Corresponding_Record_Type (Ttyp))))),
Loc);
Append_To (Args, Ecount);
if Restriction_Active (No_Task_Hierarchy) = False then
Append_To (Args, Make_Identifier (Loc, Name_uMaster));
else
Append_To (Args, Make_Integer_Literal (Loc, 3));
end if;
end if;
Append_To (Args,
Unchecked_Convert_To (RTE (RE_Task_Procedure_Access),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Get_Task_Body_Procedure (Ttyp), Loc),
Attribute_Name => Name_Address)));
Append_To (Args,
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Attribute_Name => Name_Address));
Append_To (Args,
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')),
Attribute_Name => Name_Unchecked_Access));
Append_To (Args, Make_Identifier (Loc, Name_uChain));
if Present (Tdef)
and then Has_Task_Name_Pragma (Tdef)
then
Append_To (Args,
New_Copy (
Expression (First (
Pragma_Argument_Associations (
Find_Task_Or_Protected_Pragma
(Tdef, Name_Task_Name))))));
else
Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
end if;
Append_To (Args,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id)));
if Restricted_Profile then
Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc);
else
Name := New_Reference_To (RTE (RE_Create_Task), Loc);
end if;
return Make_Procedure_Call_Statement (Loc,
Name => Name, Parameter_Associations => Args);
end Make_Task_Create_Call;
function Next_Protected_Operation (N : Node_Id) return Node_Id is
Next_Op : Node_Id;
begin
Next_Op := Next (N);
while Present (Next_Op)
and then Nkind (Next_Op) /= N_Subprogram_Body
and then Nkind (Next_Op) /= N_Entry_Body
loop
Next (Next_Op);
end loop;
return Next_Op;
end Next_Protected_Operation;
procedure Set_Discriminals (Dec : Node_Id) is
D : Entity_Id;
Pdef : Entity_Id;
D_Minal : Entity_Id;
begin
pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration);
Pdef := Defining_Identifier (Dec);
if Has_Discriminants (Pdef) then
D := First_Discriminant (Pdef);
while Present (D) loop
D_Minal :=
Make_Defining_Identifier (Sloc (D),
Chars => New_External_Name (Chars (D), 'D'));
Set_Ekind (D_Minal, E_Constant);
Set_Etype (D_Minal, Etype (D));
Set_Scope (D_Minal, Pdef);
Set_Discriminal (D, D_Minal);
Set_Discriminal_Link (D_Minal, D);
Next_Discriminant (D);
end loop;
end if;
end Set_Discriminals;
procedure Set_Privals
(Dec : Node_Id;
Op : Node_Id;
Loc : Source_Ptr)
is
P_Decl : Node_Id;
P_Id : Entity_Id;
Priv : Entity_Id;
Def : Node_Id;
Body_Ent : Entity_Id;
Prec_Decl : constant Node_Id :=
Parent (Corresponding_Record_Type
(Defining_Identifier (Dec)));
Prec_Def : constant Entity_Id := Type_Definition (Prec_Decl);
Obj_Decl : Node_Id;
P_Subtype : Entity_Id;
Assoc_L : constant Elist_Id := New_Elmt_List;
Op_Id : Entity_Id;
begin
pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration);
pragma Assert
(Nkind (Op) = N_Subprogram_Body or else Nkind (Op) = N_Entry_Body);
Def := Protected_Definition (Dec);
if Present (Private_Declarations (Def)) then
P_Decl := First (Private_Declarations (Def));
while Present (P_Decl) loop
if Nkind (P_Decl) = N_Component_Declaration then
P_Id := Defining_Identifier (P_Decl);
Priv :=
Make_Defining_Identifier (Loc,
New_External_Name (Chars (P_Id), 'P'));
Set_Ekind (Priv, E_Variable);
Set_Etype (Priv, Etype (P_Id));
Set_Scope (Priv, Scope (P_Id));
Set_Esize (Priv, Esize (Etype (P_Id)));
Set_Alignment (Priv, Alignment (Etype (P_Id)));
if Is_Itype (Etype (P_Id)) then
Append_Elmt (P_Id, Assoc_L);
Append_Elmt (Priv, Assoc_L);
if Nkind (Op) = N_Entry_Body then
Op_Id := Defining_Identifier (Op);
else
Op_Id := Defining_Unit_Name (Specification (Op));
end if;
Discard_Node
(New_Copy_Tree (P_Decl, Assoc_L, New_Scope => Op_Id));
end if;
Set_Protected_Operation (P_Id, Op);
Set_Prival (P_Id, Priv);
end if;
Next (P_Decl);
end loop;
end if;
Body_Ent := Corresponding_Body (Dec);
Priv :=
Make_Defining_Identifier (Sloc (Body_Ent),
Chars => New_External_Name (Chars (Body_Ent), 'R'));
Obj_Decl := First (Component_Items (Component_List (Prec_Def)));
while Chars (Defining_Identifier (Obj_Decl)) /= Name_uObject loop
Next (Obj_Decl);
end loop;
P_Subtype := Etype (Defining_Identifier (Obj_Decl));
Set_Ekind (Priv, E_Variable);
Set_Etype (Priv, P_Subtype);
Set_Is_Aliased (Priv);
Set_Object_Ref (Body_Ent, Priv);
end Set_Privals;
procedure Update_Prival_Subtypes (N : Node_Id) is
function Process (N : Node_Id) return Traverse_Result;
procedure Update_Array_Bounds (E : Entity_Id);
procedure Update_Index_Types (N : Node_Id);
function Process (N : Node_Id) return Traverse_Result is
begin
if Is_Entity_Name (N) then
declare
E : constant Entity_Id := Entity (N);
begin
if Present (E)
and then (Ekind (E) = E_Constant
or else Ekind (E) = E_Variable)
and then Nkind (Parent (E)) = N_Object_Renaming_Declaration
and then not Is_Scalar_Type (Etype (E))
and then Etype (N) /= Etype (E)
then
Set_Etype (N, Etype (Entity (Original_Node (N))));
Update_Index_Types (N);
elsif Present (E)
and then Ekind (E) = E_Constant
and then Present (Discriminal_Link (E))
then
Set_Etype (N, Etype (E));
end if;
end;
return OK;
elsif Nkind (N) = N_Defining_Identifier
or else Nkind (N) = N_Defining_Operator_Symbol
or else Nkind (N) = N_Defining_Character_Literal
then
return Skip;
elsif Nkind (N) = N_String_Literal then
return OK;
elsif Nkind (N) = N_Object_Declaration
and then Is_Itype (Etype (Defining_Identifier (N)))
and then Is_Array_Type (Etype (Defining_Identifier (N)))
then
Update_Array_Bounds (Etype (Defining_Identifier (N)));
return OK;
elsif Nkind (N) in N_Has_Etype
and then Present (Etype (N))
and then Is_Array_Type (Etype (N))
and then Nkind (N) = N_Selected_Component
and then Has_Discriminants (Etype (Prefix (N)))
then
Set_Etype (N, Base_Type (Etype (N)));
Update_Index_Types (N);
return OK;
else
if Nkind (N) in N_Has_Etype
and then Present (Etype (N))
and then Is_Itype (Etype (N)) then
if Is_Array_Type (Etype (N)) then
Update_Array_Bounds (Etype (N));
elsif Is_Scalar_Type (Etype (N)) then
Update_Prival_Subtypes (Type_Low_Bound (Etype (N)));
Update_Prival_Subtypes (Type_High_Bound (Etype (N)));
end if;
end if;
return OK;
end if;
end Process;
procedure Update_Array_Bounds (E : Entity_Id) is
Ind : Node_Id;
begin
Ind := First_Index (E);
while Present (Ind) loop
Update_Prival_Subtypes (Type_Low_Bound (Etype (Ind)));
Update_Prival_Subtypes (Type_High_Bound (Etype (Ind)));
Next_Index (Ind);
end loop;
end Update_Array_Bounds;
procedure Update_Index_Types (N : Node_Id) is
Indx1 : Node_Id;
I_Typ : Node_Id;
begin
if Nkind (Parent (N)) = N_Indexed_Component
and then
not Is_Bit_Packed_Array (Etype (Prefix (Parent (N))))
then
Indx1 := First (Expressions (Parent (N)));
I_Typ := First_Index (Etype (N));
while Present (Indx1) and then Present (I_Typ) loop
if not Is_Entity_Name (Indx1) then
Set_Etype (Indx1, Base_Type (Etype (I_Typ)));
end if;
Next (Indx1);
Next_Index (I_Typ);
end loop;
end if;
end Update_Index_Types;
procedure Traverse is new Traverse_Proc;
begin
Traverse (N);
end Update_Prival_Subtypes;
end Exp_Ch9;