-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Exp_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;
-- Build a specification for a function implementing
-- the protected entry barrier of the specified entry body.
- function Build_Corresponding_Record
- (N : Node_Id;
- Ctyp : Node_Id;
- Loc : Source_Ptr) return Node_Id;
- -- Common to tasks and protected types. Copy discriminant specifications,
- -- build record declaration. N is the type declaration, Ctyp is the
- -- concurrent entity (task type or protected type).
-
function Build_Entry_Count_Expression
(Concurrent_Type : Node_Id;
Component_List : List_Id;
-- For each entry family in a concurrent type, create an anonymous array
-- type of the right size, and add a component to the corresponding_record.
+ function Copy_Result_Type (Res : Node_Id) return Node_Id;
+ -- Copy the result type of a function specification, when building the
+ -- internal operation corresponding to a protected function, or when
+ -- expanding an access to protected function. If the result is an anonymous
+ -- access to subprogram itself, we need to create a new signature with the
+ -- same parameter names and the same resolved types, but with new entities
+ -- for the formals.
+
function Family_Offset
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
- Ttyp : Entity_Id) return Node_Id;
+ Ttyp : Entity_Id;
+ Cap : Boolean) return Node_Id;
-- Compute (Hi - Lo) for two entry family indices. Hi is the index in
-- an accept statement, or the upper bound in the discrete subtype of
-- an entry declaration. Lo is the corresponding lower bound. Ttyp is
- -- the concurrent type of the entry.
+ -- the concurrent type of the entry. If Cap is true, the result is
+ -- capped according to Entry_Family_Bound.
function Family_Size
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
- Ttyp : Entity_Id) return Node_Id;
+ Ttyp : Entity_Id;
+ Cap : Boolean) return Node_Id;
-- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in
-- a family, and handle properly the superflat case. This is equivalent
-- to the use of 'Length on the index type, but must use Family_Offset
-- to handle properly the case of bounds that depend on discriminants.
+ -- If Cap is true, the result is capped according to Entry_Family_Bound.
procedure Extract_Dispatching_Call
(N : Node_Id;
-- E - <<index of first family member>> +
-- Protected_Entry_Index (Index_Type'Pos (Index_Type'First)));
+ function Is_Potentially_Large_Family
+ (Base_Index : Entity_Id;
+ Conctyp : Entity_Id;
+ Lo : Node_Id;
+ Hi : Node_Id) return Boolean;
+
function Parameter_Block_Pack
(Loc : Source_Ptr;
Blk_Typ : Entity_Id;
-- Start of processing for Actual_Index_Expression
begin
- -- The queues of entries and entry families appear in textual
- -- order in the associated record. The entry index is computed as
- -- the sum of the number of queues for all entries that precede the
- -- designated one, to which is added the index expression, if this
- -- expression denotes a member of a family.
+ -- The queues of entries and entry families appear in textual order in
+ -- the associated record. The entry index is computed as the sum of the
+ -- number of queues for all entries that precede the designated one, to
+ -- which is added the index expression, if this expression denotes a
+ -- member of a family.
-- The following is a place holder for the count of simple entries
Num := Make_Integer_Literal (Sloc, 1);
- -- We construct an expression which is a series of addition
- -- operations. See comments in Entry_Index_Expression, which is
- -- identical in structure.
+ -- We construct an expression which is a series of addition operations.
+ -- See comments in Entry_Index_Expression, which is identical in
+ -- structure.
if Present (Index) then
S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
while Present (P) loop
if Nkind (P) = N_Component_Declaration then
Pdef := Defining_Identifier (P);
+
+ -- The privals are declared before the current body is
+ -- analyzed. for visibility reasons. Set their Sloc so
+ -- that it is consistent with their renaming declaration,
+ -- to prevent anomalies in gdb.
+
+ -- This kludgy model for privals should be redesigned ???
+
+ Set_Sloc (Prival (Pdef), Loc);
+
Decl :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Prival (Pdef),
Protection_Type := RE_Protection;
end if;
+ -- Adjust Sloc, as for the other privals
+
+ Set_Sloc (Object_Ref (Body_Ent), Loc);
+
Decl :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Object_Ref (Body_Ent),
Set_Exception_Handlers (New_S,
New_List (
- Make_Exception_Handler (Loc,
+ Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Ohandle),
Statements => New_List (
procedure Build_Activation_Chain_Entity (N : Node_Id) is
P : Node_Id;
- B : Node_Id;
Decls : List_Id;
+ Chain : Entity_Id;
begin
-- Loop to find enclosing construct containing activation chain variable
and then Nkind (P) /= N_Package_Body
and then Nkind (P) /= N_Block_Statement
and then Nkind (P) /= N_Task_Body
+ and then Nkind (P) /= N_Extended_Return_Statement
loop
P := Parent (P);
end loop;
-- If we are in a package body, the activation chain variable is
- -- allocated in the corresponding spec. First, we save the package
- -- body node because we enter the new entity in its Declarations list.
-
- B := P;
+ -- declared in the body, but the Activation_Chain_Entity is attached to
+ -- the spec.
if Nkind (P) = N_Package_Body then
+ Decls := Declarations (P);
P := Unit_Declaration_Node (Corresponding_Spec (P));
- Decls := Declarations (B);
elsif Nkind (P) = N_Package_Declaration then
- Decls := Visible_Declarations (Specification (B));
+ Decls := Visible_Declarations (Specification (P));
+
+ elsif Nkind (P) = N_Extended_Return_Statement then
+ Decls := Return_Object_Declarations (P);
else
- Decls := Declarations (B);
+ Decls := Declarations (P);
end if;
-- If activation chain entity not already declared, declare it
- if No (Activation_Chain_Entity (P)) then
- Set_Activation_Chain_Entity
- (P, Make_Defining_Identifier (Sloc (N), Name_uChain));
+ if Nkind (P) = N_Extended_Return_Statement
+ or else No (Activation_Chain_Entity (P))
+ then
+ Chain := Make_Defining_Identifier (Sloc (N), Name_uChain);
+
+ -- Note: An extended return statement is not really a task activator,
+ -- but it does have an activation chain on which to store the tasks
+ -- temporarily. On successful return, the tasks on this chain are
+ -- moved to the chain passed in by the caller. We do not build an
+ -- Activatation_Chain_Entity for an N_Extended_Return_Statement,
+ -- because we do not want to build a call to Activate_Tasks. Task
+ -- activation is the responsibility of the caller.
+
+ if Nkind (P) /= N_Extended_Return_Statement then
+ Set_Activation_Chain_Entity (P, Chain);
+ end if;
Prepend_To (Decls,
Make_Object_Declaration (Sloc (P),
- Defining_Identifier => Activation_Chain_Entity (P),
+ Defining_Identifier => Chain,
Aliased_Present => True,
- Object_Definition =>
+ Object_Definition =>
New_Reference_To (RTE (RE_Activation_Chain), Sloc (P))));
Analyze (First (Decls));
Lo : Node_Id;
Hi : Node_Id;
Typ : Entity_Id;
+ Large : Boolean;
begin
-- Count number of non-family entries
Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
Hi := Type_High_Bound (Typ);
Lo := Type_Low_Bound (Typ);
-
+ Large := Is_Potentially_Large_Family
+ (Base_Type (Typ), Concurrent_Type, Lo, Hi);
Ecount :=
Make_Op_Add (Loc,
Left_Opnd => Ecount,
- Right_Opnd => Family_Size (Loc, Hi, Lo, Concurrent_Type));
+ Right_Opnd => Family_Size
+ (Loc, Hi, Lo, Concurrent_Type, Large));
end if;
Next_Entity (Ent);
Proc_Param_Specs : List_Id) return Boolean
is
Prim_Op_Param : Node_Id;
+ Prim_Op_Typ : Entity_Id;
Proc_Param : Node_Id;
+ Proc_Typ : Entity_Id;
+
+ function Find_Parameter_Type (Param : Node_Id) return Entity_Id;
+ -- Return the controlling type denoted by a formal parameter
+
+ -------------------------
+ -- Find_Parameter_Type --
+ -------------------------
+
+ function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
+ begin
+ if Nkind (Param) /= N_Parameter_Specification then
+ return Empty;
+
+ elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
+ return Etype (Subtype_Mark (Parameter_Type (Param)));
+
+ else
+ return Etype (Parameter_Type (Param));
+ end if;
+ end Find_Parameter_Type;
+
+ -- Start of processing for Type_Conformant_Parameters
begin
-- Skip the first parameter of the primitive operation
while Present (Prim_Op_Param)
and then Present (Proc_Param)
loop
- -- The two parameters must be mode conformant and have
- -- the exact same types.
+ Prim_Op_Typ := Find_Parameter_Type (Prim_Op_Param);
+ Proc_Typ := Find_Parameter_Type (Proc_Param);
- if Ekind (Defining_Identifier (Prim_Op_Param)) /=
- Ekind (Defining_Identifier (Proc_Param))
- or else Etype (Parameter_Type (Prim_Op_Param)) /=
- Etype (Parameter_Type (Proc_Param))
+ -- The two parameters must be mode conformant
+
+ if not Conforming_Types
+ (Prim_Op_Typ, Proc_Typ, Mode_Conformant)
then
return False;
end if;
-- The mode is determined by the first parameter of the interface-level
-- procedure that the current entry is trying to override.
- pragma Assert (Present (Abstract_Interfaces
- (Corresponding_Record_Type (Scope (Proc_Nam)))));
-
- Iface_Elmt :=
- First_Elmt (Abstract_Interfaces
- (Corresponding_Record_Type (Scope (Proc_Nam))));
+ pragma Assert (Is_Non_Empty_List (Abstract_Interface_List (Obj_Typ)));
-- We must examine all the protected operations of the implemented
-- interfaces in order to discover a possible overriding candidate.
- Examine_Interfaces : while Present (Iface_Elmt) loop
- Iface := Node (Iface_Elmt);
+ Iface := Etype (First (Abstract_Interface_List (Obj_Typ)));
+ Examine_Parents : loop
if Present (Primitive_Operations (Iface)) then
Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
while Present (Iface_Prim_Op_Elmt) loop
Iface_Prim_Op := Node (Iface_Prim_Op_Elmt);
- while Present (Alias (Iface_Prim_Op)) loop
- Iface_Prim_Op := Alias (Iface_Prim_Op);
- end loop;
+ if not Is_Predefined_Dispatching_Operation (Iface_Prim_Op) then
+ while Present (Alias (Iface_Prim_Op)) loop
+ Iface_Prim_Op := Alias (Iface_Prim_Op);
+ end loop;
- -- The current primitive operation can be overriden by the
- -- generated entry wrapper.
+ -- The current primitive operation can be overriden by the
+ -- generated entry wrapper.
- if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then
- First_Param :=
- First (Parameter_Specifications (Parent (Iface_Prim_Op)));
+ if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then
+ First_Param := First (Parameter_Specifications
+ (Parent (Iface_Prim_Op)));
- exit Examine_Interfaces;
+ goto Found;
+ end if;
end if;
Next_Elmt (Iface_Prim_Op_Elmt);
end loop;
end if;
- Next_Elmt (Iface_Elmt);
- end loop Examine_Interfaces;
+ exit Examine_Parents when Etype (Iface) = Iface;
- -- Return if no interface primitive can be overriden
+ Iface := Etype (Iface);
+ end loop Examine_Parents;
- if No (First_Param) then
- return Empty;
+ if Present (Abstract_Interfaces
+ (Corresponding_Record_Type (Scope (Proc_Nam))))
+ then
+ Iface_Elmt := First_Elmt
+ (Abstract_Interfaces
+ (Corresponding_Record_Type (Scope (Proc_Nam))));
+ Examine_Interfaces : while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ if Present (Primitive_Operations (Iface)) then
+ Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
+ while Present (Iface_Prim_Op_Elmt) loop
+ Iface_Prim_Op := Node (Iface_Prim_Op_Elmt);
+
+ if not Is_Predefined_Dispatching_Operation
+ (Iface_Prim_Op)
+ then
+ while Present (Alias (Iface_Prim_Op)) loop
+ Iface_Prim_Op := Alias (Iface_Prim_Op);
+ end loop;
+
+ -- The current primitive operation can be overriden by
+ -- the generated entry wrapper.
+
+ if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then
+ First_Param := First (Parameter_Specifications
+ (Parent (Iface_Prim_Op)));
+
+ goto Found;
+ end if;
+ end if;
+
+ Next_Elmt (Iface_Prim_Op_Elmt);
+ end loop;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop Examine_Interfaces;
end if;
+ -- Return if no interface primitive can be overriden
+
+ return Empty;
+
+ <<Found>>
+
New_Formals := Replicate_Entry_Formals (Loc, Formals);
-- ??? Certain source packages contain protected or task types that do
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));
+ Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False));
end if;
Next_Entity (Ent);
Ent : Entity_Id;
Pid : Node_Id) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (N);
+
+ End_Lab : constant Node_Id :=
+ End_Label (Handled_Statement_Sequence (N));
+ End_Loc : constant Source_Ptr :=
+ Sloc (Last (Statements (Handled_Statement_Sequence (N))));
+ -- Used for the generated call to Complete_Entry_Body
+
+ Han_Loc : Source_Ptr;
+ -- Used for the exception handler, inserted at end of the body
+
Op_Decls : constant List_Id := New_List;
Edef : Entity_Id;
Espec : Node_Id;
Complete : Node_Id;
begin
+ -- Set the source location on the exception handler only when debugging
+ -- the expanded code (see Make_Implicit_Exception_Handler).
+
+ if Debug_Generated_Code then
+ Han_Loc := End_Loc;
+ else
+ Han_Loc := No_Location;
+ end if;
+
Edef :=
Make_Defining_Identifier (Loc,
Chars => Chars (Protected_Body_Subprogram (Ent)));
Handled_Statement_Sequence =>
Handled_Statement_Sequence (N)),
- Make_Procedure_Call_Statement (Loc,
+ Make_Procedure_Call_Statement (End_Loc,
Name => Complete,
Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
+ Make_Attribute_Reference (End_Loc,
Prefix =>
- Make_Selected_Component (Loc,
+ Make_Selected_Component (End_Loc,
Prefix =>
- Make_Identifier (Loc, Name_uObject),
+ Make_Identifier (End_Loc, Name_uObject),
Selector_Name =>
- Make_Identifier (Loc, Name_uObject)),
- Attribute_Name => Name_Unchecked_Access))));
+ Make_Identifier (End_Loc, Name_uObject)),
+ Attribute_Name => Name_Unchecked_Access))));
+
+ -- When exceptions can not be propagated, we never need to call
+ -- Exception_Complete_Entry_Body
- if Restriction_Active (No_Exception_Handlers) then
+ if No_Exception_Handlers_Set then
return
Make_Subprogram_Body (Loc,
Specification => Espec,
Declarations => Op_Decls,
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Op_Stats));
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Op_Stats,
+ End_Label => End_Lab));
else
Ohandle := Make_Others_Choice (Loc);
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Op_Stats,
+ End_Label => End_Lab,
Exception_Handlers => New_List (
- Make_Exception_Handler (Loc,
+ Make_Implicit_Exception_Handler (Han_Loc,
Exception_Choices => New_List (Ohandle),
Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
+ Make_Procedure_Call_Statement (Han_Loc,
Name => Complete,
Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
+ Make_Attribute_Reference (Han_Loc,
Prefix =>
- Make_Selected_Component (Loc,
+ Make_Selected_Component (Han_Loc,
Prefix =>
- Make_Identifier (Loc, Name_uObject),
+ Make_Identifier (Han_Loc, Name_uObject),
Selector_Name =>
- Make_Identifier (Loc, Name_uObject)),
+ Make_Identifier (Han_Loc, Name_uObject)),
Attribute_Name => Name_Unchecked_Access),
- Make_Function_Call (Loc,
+ Make_Function_Call (Han_Loc,
Name => New_Reference_To (
RTE (RE_Get_GNAT_Exception), Loc)))))))));
end if;
Parameter_Specifications => New_Plist);
else
+ -- We need to create a new specification for the anonymous
+ -- subprogram type.
+
New_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => New_Id,
Parameter_Specifications => New_Plist,
Result_Definition =>
- New_Copy (Result_Definition (Specification (Decl))));
+ Copy_Result_Type (Result_Definition (Specification (Decl))));
+
Set_Return_Present (Defining_Unit_Name (New_Spec));
return New_Spec;
end if;
Object_Definition =>
New_Reference_To (Etype (Formal), Loc));
+ -- Mark the object as not needing initialization since the
+ -- initialization is performed separately, avoiding errors
+ -- on cases such as formals of null-excluding access types.
+
+ Set_No_Initialization (N_Node);
+
-- We have to make an assignment statement separate for the
-- case of limited type. We cannot assign it unless the
-- Assignment_OK flag is set first.
--------------------------------
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;
+ Loc : constant Source_Ptr := Sloc (N);
+ Chain : Entity_Id;
+ Call : Node_Id;
+ Name : Node_Id;
+ P : Node_Id;
begin
-- Get the activation chain entity. Except in the case of a package
- -- body, this is in the node that w as passed. For a package body, we
+ -- body, this is in the node that was passed. For a package body, we
-- have to find the corresponding package declaration node.
if Nkind (N) = N_Package_Body then
P := Corresponding_Spec (N);
-
loop
P := Parent (P);
exit when Nkind (P) = N_Package_Declaration;
else
if Present (Handled_Statement_Sequence (N)) then
- -- The call goes at the start of the statement sequence, but
+ -- The call goes at the start of the statement sequence
-- after the start of exception range label if one is present.
declare
begin
Stm := First (Statements (Handled_Statement_Sequence (N)));
+ -- A special case, skip exception range label if one is
+ -- present (from front end zcx processing).
+
if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then
Next (Stm);
end if;
+ -- Another special case, if the first statement is a block
+ -- from optimization of a local raise to a goto, then the
+ -- call goes inside this block.
+
+ if Nkind (Stm) = N_Block_Statement
+ and then Exception_Junk (Stm)
+ then
+ Stm :=
+ First (Statements (Handled_Statement_Sequence (Stm)));
+ end if;
+
+ -- Insertion point is after any exception label pushes,
+ -- since we want it covered by any local handlers.
+
+ while Nkind (Stm) in N_Push_xxx_Label loop
+ Next (Stm);
+ end loop;
+
+ -- Now we have the proper insertion point
+
Insert_Before (Stm, Call);
end;
begin
Get_Index_Bounds
(Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi);
- if Scope (Bas) = Standard_Standard
- and then Bas = Base_Type (Standard_Integer)
- and then Has_Discriminants (Conctyp)
- and then Present
- (Discriminant_Default_Value (First_Discriminant (Conctyp)))
- and then
- (Denotes_Discriminant (Lo, True)
- or else Denotes_Discriminant (Hi, True))
- then
+
+ if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then
Bas :=
Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
Bas_Decl :=
end loop;
end Collect_Entry_Families;
+ ----------------------
+ -- Copy_Result_Type --
+ ----------------------
+
+ function Copy_Result_Type (Res : Node_Id) return Node_Id is
+ New_Res : constant Node_Id := New_Copy_Tree (Res);
+ Par_Spec : Node_Id;
+ Formal : Entity_Id;
+
+ begin
+ if Nkind (New_Res) = N_Access_Definition then
+
+ -- Provide new entities for the formals
+
+ Par_Spec := First (Parameter_Specifications
+ (Access_To_Subprogram_Definition (New_Res)));
+ while Present (Par_Spec) loop
+ Formal := Defining_Identifier (Par_Spec);
+ Set_Defining_Identifier (Par_Spec,
+ Make_Defining_Identifier (Sloc (Formal), Chars (Formal)));
+ Next (Par_Spec);
+ end loop;
+ end if;
+
+ return New_Res;
+ end Copy_Result_Type;
+
--------------------
-- Concurrent_Ref --
--------------------
Prefix => New_Reference_To (Base_Type (S), Sloc),
Expressions => New_List (Relocate_Node (Index))),
Type_Low_Bound (S),
- Ttyp));
+ Ttyp,
+ False));
else
Expr := Num;
end if;
Expr :=
Make_Op_Add (Sloc,
Left_Opnd => Expr,
- Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp));
+ Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False));
-- Other components are anonymous types to be ignored
New_F : Entity_Id;
begin
- New_Scope (Ent);
+ Push_Scope (Ent);
Formal := First_Formal (Ent);
while Present (Formal) loop
Def1 :=
Make_Access_Function_Definition (Loc,
Parameter_Specifications => P_List,
- Result_Definition =>
- New_Copy (Result_Definition (Type_Definition (N))));
+ Result_Definition =>
+ Copy_Result_Type (Result_Definition (Type_Definition (N))));
else
Def1 :=
if Ada_Version >= Ada_05
and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type
- and then Is_Interface (Etype (Tasknm))
+ and then Is_Interface (Etype (Tasknm))
and then Is_Task_Interface (Etype (Tasknm))
then
Append_To (Component_Associations (Aggr),
Make_Integer_Literal (Loc, Count)),
Expression =>
- -- Tasknm._disp_get_task_id
+ -- Task_Id (Tasknm._disp_get_task_id)
- Make_Selected_Component (Loc,
- Prefix =>
- New_Copy_Tree (Tasknm),
- Selector_Name =>
- Make_Identifier (Loc, Name_uDisp_Get_Task_Id))));
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Reference_To (RTE (RO_ST_Task_Id), Loc),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Copy_Tree (Tasknm),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
else
Append_To (Component_Associations (Aggr),
Analyze (Call);
- New_Scope (Blkent);
+ Push_Scope (Blkent);
declare
D : Node_Id;
-- B : Boolean := False;
-- Bnn : Communication_Block;
-- C : Ada.Tags.Prim_Op_Kind;
+ -- D : Dummy_Communication_Block;
-- K : Ada.Tags.Tagged_Kind :=
-- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
-- P : Parameters := (Param1 .. ParamN);
-- begin
-- begin
-- _Disp_Asynchronous_Select
- -- (<object>, S, P'address, Bnn, B);
+ -- (<object>, S, P'address, D, B);
+ -- Bnn := Communication_Block (D);
-- Param1 := P.Param1;
-- ...
-- Abort_Defer;
-- _Disp_Asynchronous_Select
- -- (<object>, S, P'address, Bnn, B);
+ -- (<object>, S, P'address, D, B);
+ -- Bnn := Communication_Bloc (D);
-- Param1 := P.Param1;
-- ...
-- K : Ada.Tags.Tagged_Kind :=
-- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
+ -- Dummy communication block, generate:
+ -- D : Dummy_Communication_Block;
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uD),
+ Object_Definition =>
+ New_Reference_To (
+ RTE (RE_Dummy_Communication_Block), Loc)));
+
K := Build_K (Loc, Decls, Obj);
-- Parameter block processing
Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
-- Generate:
- -- _Disp_Asynchronous_Select (<object>, S, P'address, Bnn, B);
+ -- Bnn := Communication_Block (D);
+
+ Prepend_To (Cleanup_Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Reference_To (Bnn, Loc),
+ Expression =>
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Communication_Block), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uD))));
+
+ -- Generate:
+ -- _Disp_Asynchronous_Select (<object>, S, P'address, D, B);
Prepend_To (Cleanup_Stmts,
Make_Procedure_Call_Statement (Loc,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (P, Loc),
Attribute_Name => Name_Address),
- New_Reference_To (Bnn, Loc),
+ Make_Identifier (Loc, Name_uD),
New_Reference_To (B, Loc))));
-- Generate:
TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
-- Generate:
- -- _Disp_Asynchronous_Select (<object>, S, P'address, Bnn, B);
+ -- Bnn := Communication_Block (D);
+
+ Append_To (TaskE_Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Reference_To (Bnn, Loc),
+ Expression =>
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Communication_Block), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uD))));
+
+ -- Generate:
+ -- _Disp_Asynchronous_Select (<object>, S, P'address, D, B);
Prepend_To (TaskE_Stmts,
Make_Procedure_Call_Statement (Loc,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (P, Loc),
Attribute_Name => Name_Address),
- New_Reference_To (Bnn, Loc),
+ Make_Identifier (Loc, Name_uD),
New_Reference_To (B, Loc))));
-- Generate:
-- Create the inner block to protect the abortable part
Hdle := New_List (
- Make_Exception_Handler (Loc,
+ Make_Implicit_Exception_Handler (Loc,
Exception_Choices =>
New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
Statements => New_List (
Has_Created_Identifier => True,
Is_Asynchronous_Call_Block => True);
- -- For the JVM call Update_Exception instead of Abort_Undefer.
+ -- For the VM call Update_Exception instead of Abort_Undefer.
-- See 4jexcept.ads for an explanation.
- if Hostparm.Java_VM then
+ if VM_Target = No_VM then
+ Target_Undefer := RE_Abort_Undefer;
+ else
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 (
-- exception
Exception_Handlers => New_List (
- Make_Exception_Handler (Loc,
+ Make_Implicit_Exception_Handler (Loc,
-- when Abort_Signal =>
-- Abort_Undefer.all;
-- Create the inner block to protect the abortable part
Hdle := New_List (
- Make_Exception_Handler (Loc,
+ Make_Implicit_Exception_Handler (Loc,
Exception_Choices =>
New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
Statements => New_List (
Loc : constant Source_Ptr := Sloc (N);
Pid : constant Entity_Id := Corresponding_Spec (N);
Has_Entries : Boolean := False;
- Op_Decl : Node_Id;
Op_Body : Node_Id;
+ Op_Decl : Node_Id;
Op_Id : Entity_Id;
Disp_Op_Body : Node_Id;
New_Op_Body : Node_Id;
New_Op_Body :=
Build_Unprotected_Subprogram_Body (Op_Body, Pid);
+ -- Propagate the finalization chain to the new body.
+ -- In the unlikely event that the subprogram contains a
+ -- declaration or allocator for an object that requires
+ -- finalization, the corresponding chain is created when
+ -- analyzing the body, and attached to its entity. This
+ -- entity is not further elaborated, and so the chain
+ -- properly belongs to the newly created subprogram body.
+
+ if Present
+ (Finalization_Chain_Entity (Defining_Entity (Op_Body)))
+ then
+ Set_Finalization_Chain_Entity
+ (Protected_Body_Subprogram
+ (Corresponding_Spec (Op_Body)),
+ Finalization_Chain_Entity (Defining_Entity (Op_Body)));
+ Set_Analyzed
+ (Handled_Statement_Sequence (New_Op_Body), False);
+ end if;
+
Insert_After (Current_Node, New_Op_Body);
Current_Node := New_Op_Body;
Analyze (New_Op_Body);
Update_Prival_Subtypes (New_Op_Body);
- -- Build the corresponding protected operation only if
- -- this is a visible operation of the type, or if it is
- -- an interrupt handler. Otherwise it is only callable
- -- from within the object, and the unprotected version
- -- is sufficient.
+ -- Build the corresponding protected operation. It may
+ -- appear that this is needed only this is a visible
+ -- operation of the type, or if it is an interrupt handler,
+ -- and this was the strategy used previously in GNAT.
+ -- However, the operation may be exported through a
+ -- 'Access to an external caller. This is the common idiom
+ -- in code that uses the Ada 2005 Timing_Events package
+ -- As a result we need to produce the protected body for
+ -- both visible and private operations.
if Present (Corresponding_Spec (Op_Body)) then
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)))
+ Unit_Declaration_Node (Corresponding_Spec (Op_Body));
+
+ if
+ Nkind (Parent (Op_Decl)) = N_Protected_Definition
then
New_Op_Body :=
Build_Protected_Subprogram_Body (
-- Generate an overriding primitive operation body for
-- this subprogram if the protected type implements
- -- an inerface.
+ -- an interface.
if Ada_Version >= Ada_05
and then Present (Abstract_Interfaces (
return;
else
Rec_Decl := Build_Corresponding_Record (N, Prottyp, Loc);
- Cdecls := Component_Items
- (Component_List (Type_Definition (Rec_Decl)));
end if;
+ Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl)));
+
-- Ada 2005 (AI-345): Propagate the attribute that contains the list
-- of implemented interfaces.
Current_Node := Sub;
+ Sub :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Build_Protected_Sub_Specification
+ (Priv, Prottyp, Protected_Mode));
+
+ Insert_After (Current_Node, Sub);
+ Analyze (Sub);
+ Current_Node := Sub;
+
if Is_Interrupt_Handler
(Defining_Unit_Name (Specification (Priv)))
then
- Sub :=
- Make_Subprogram_Declaration (Loc,
- Specification =>
- Build_Protected_Sub_Specification
- (Priv, Prottyp, Protected_Mode));
-
- Insert_After (Current_Node, Sub);
- Analyze (Sub);
- Current_Node := Sub;
-
if not Restricted_Profile then
Register_Handler;
end if;
-- and the parameter references have already been expanded to be direct
-- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
-- any embedded tasking statements (which would normally be illegal in
- -- procedures, have been converted to calls to the tasking runtime so
+ -- procedures), have been converted to calls to the tasking runtime so
-- there is no problem in putting them into procedures.
-- The original accept statement has been expanded into a block in
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)))));
+ declare
+ Expr_N : constant Node_Id :=
+ Expression (First (
+ Pragma_Argument_Associations (
+ Find_Task_Or_Protected_Pragma
+ (Taskdef, Name_Storage_Size))));
+ Etyp : constant Entity_Id := Etype (Expr_N);
+ P : constant Node_Id := Parent (Expr_N);
+
+ begin
+ -- The stack is defined inside the corresponding record.
+ -- Therefore if the size of the stack is set by means of
+ -- a discriminant, we must reference the discriminant of the
+ -- corresponding record type.
+
+ if Nkind (Expr_N) in N_Has_Entity
+ and then Present (Discriminal_Link (Entity (Expr_N)))
+ then
+ Task_Size :=
+ New_Reference_To
+ (CR_Discriminant (Discriminal_Link (Entity (Expr_N))),
+ Loc);
+ Set_Parent (Task_Size, P);
+ Set_Etype (Task_Size, Etyp);
+ Set_Analyzed (Task_Size);
+
+ else
+ Task_Size := Relocate_Node (Expr_N);
+ end if;
+ end;
+
else
Task_Size :=
New_Reference_To (RTE (RE_Default_Stack_Size), Loc);
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 the protected operation is defined in the visible part of the
- -- protected type, or if it is an interrupt handler, the internal and
- -- external subprograms follow each other on the entity chain. If the
- -- operation is defined in the private part of the type, there is no
- -- need for a separate locking version of the operation, and internal
- -- calls use the protected_body_subprogram directly.
-
- if List_Containing (Decl) = Visible_Declarations (Parent (Decl))
- or else Is_Interrupt_Handler (E)
- then
- return Next_Entity (Subp);
+ -- The internal and external subprograms follow each other on the entity
+ -- chain. Note that previously private operations had no separate
+ -- external subprogram. We now create one in all cases, because a
+ -- private operation may actually appear in an external call, through
+ -- a 'Access reference used for a callback.
+
+ -- If the operation is a function that returns an anonymous access type,
+ -- the corresponding itype appears before the operation, and must be
+ -- skipped.
+
+ -- This mechanism is fragile, there should be a real link between the
+ -- two versions of the operation, but there is no place to put it ???
+
+ if Is_Access_Type (Next_Entity (Subp)) then
+ return Next_Entity (Next_Entity (Subp));
else
- return (Subp);
+ return Next_Entity (Subp);
end if;
end External_Subprogram;
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
- Ttyp : Entity_Id) return Node_Id
+ Ttyp : Entity_Id;
+ Cap : Boolean) return Node_Id
is
+ Ityp : Entity_Id;
+ Real_Hi : Node_Id;
+ Real_Lo : Node_Id;
+
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-- If one of the bounds is a reference to a discriminant, replace with
-- corresponding discriminal of type. Within the body of a task retrieve
-- the renamed discriminant by simple visibility, using its generated
- -- name. Within a protected object, find the original dis- criminant and
- -- replace it with the discriminal of the current prot- ected operation.
+ -- name. Within a protected object, find the original discriminant and
+ -- replace it with the discriminal of the current protected operation.
------------------------------
-- Convert_Discriminant_Ref --
-- Start of processing for Family_Offset
begin
- return
- Make_Op_Subtract (Loc,
- Left_Opnd => Convert_Discriminant_Ref (Hi),
- Right_Opnd => Convert_Discriminant_Ref (Lo));
+ Real_Hi := Convert_Discriminant_Ref (Hi);
+ Real_Lo := Convert_Discriminant_Ref (Lo);
+
+ if Cap then
+ if Is_Task_Type (Ttyp) then
+ Ityp := RTE (RE_Task_Entry_Index);
+ else
+ Ityp := RTE (RE_Protected_Entry_Index);
+ end if;
+
+ Real_Hi :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Ityp, Loc),
+ Attribute_Name => Name_Min,
+ Expressions => New_List (
+ Real_Hi,
+ Make_Integer_Literal (Loc, Entry_Family_Bound - 1)));
+
+ Real_Lo :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Ityp, Loc),
+ Attribute_Name => Name_Max,
+ Expressions => New_List (
+ Real_Lo,
+ Make_Integer_Literal (Loc, -Entry_Family_Bound)));
+ end if;
+
+ return Make_Op_Subtract (Loc, Real_Hi, Real_Lo);
end Family_Offset;
-----------------
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
- Ttyp : Entity_Id) return Node_Id
+ Ttyp : Entity_Id;
+ Cap : Boolean) return Node_Id
is
Ityp : Entity_Id;
Expressions => New_List (
Make_Op_Add (Loc,
Left_Opnd =>
- Family_Offset (Loc, Hi, Lo, Ttyp),
+ Family_Offset (Loc, Hi, Lo, Ttyp, Cap),
Right_Opnd =>
Make_Integer_Literal (Loc, 1)),
Make_Integer_Literal (Loc, 0)));
return First_Op;
end First_Protected_Operation;
+ ---------------------------------
+ -- Is_Potentially_Large_Family --
+ ---------------------------------
+
+ function Is_Potentially_Large_Family
+ (Base_Index : Entity_Id;
+ Conctyp : Entity_Id;
+ Lo : Node_Id;
+ Hi : Node_Id) return Boolean
+ is
+ begin
+ return Scope (Base_Index) = Standard_Standard
+ and then Base_Index = Base_Type (Standard_Integer)
+ and then Has_Discriminants (Conctyp)
+ and then Present
+ (Discriminant_Default_Value (First_Discriminant (Conctyp)))
+ and then
+ (Denotes_Discriminant (Lo, True)
+ or else Denotes_Discriminant (Hi, True));
+ end Is_Potentially_Large_Family;
+
--------------------------------
-- Index_Constant_Declaration --
--------------------------------
-- new itype for the corresponding prival in each protected
-- operation, to avoid scoping problems. We create new itypes
-- by copying the tree for the component definition.
-
- if Is_Itype (Etype (P_Id)) then
+ -- (Ada 2005) If the itype is an anonymous access type created
+ -- for an access definition for a component, it is declared in
+ -- the enclosing scope, and we do no create a local version of
+ -- it, to prevent scoping anomalies in gigi.
+
+ if Is_Itype (Etype (P_Id))
+ and then not
+ (Is_Access_Type (Etype (P_Id))
+ and then Is_Local_Anonymous_Access (Etype (P_Id)))
+ then
Append_Elmt (P_Id, Assoc_L);
Append_Elmt (Priv, Assoc_L);
OSDN Git Service
