is
Def : Node_Id;
Rec_Typ : Entity_Id;
+ procedure Scan_Declarations (L : List_Id);
+ -- Common processing for visible and private declarations
+ -- of a protected type.
+
+ procedure Scan_Declarations (L : List_Id) is
+ Decl : Node_Id;
+ Wrap_Decl : Node_Id;
+ Wrap_Spec : Node_Id;
+
+ begin
+ if No (L) then
+ return;
+ end if;
+
+ Decl := First (L);
+ while Present (Decl) loop
+ Wrap_Spec := Empty;
+
+ if Nkind (Decl) = N_Entry_Declaration
+ and then Ekind (Defining_Identifier (Decl)) = E_Entry
+ then
+ Wrap_Spec :=
+ Build_Wrapper_Spec
+ (Subp_Id => Defining_Identifier (Decl),
+ Obj_Typ => Rec_Typ,
+ Formals => Parameter_Specifications (Decl));
+
+ elsif Nkind (Decl) = N_Subprogram_Declaration then
+ Wrap_Spec :=
+ Build_Wrapper_Spec
+ (Subp_Id => Defining_Unit_Name (Specification (Decl)),
+ Obj_Typ => Rec_Typ,
+ Formals =>
+ Parameter_Specifications (Specification (Decl)));
+ end if;
+
+ if Present (Wrap_Spec) then
+ Wrap_Decl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification => Wrap_Spec);
+
+ Insert_After (N, Wrap_Decl);
+ N := Wrap_Decl;
+
+ Analyze (Wrap_Decl);
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Scan_Declarations;
+
+ -- start of processing for Build_Wrapper_Specs
begin
if Is_Protected_Type (Typ) then
Rec_Typ := Corresponding_Record_Type (Typ);
-- Generate wrapper specs for a concurrent type which implements an
- -- interface and has visible entries and/or protected procedures.
+ -- interface. Operations in both the visible and private parts may
+ -- implement progenitor operations.
if Present (Interfaces (Rec_Typ))
and then Present (Def)
- and then Present (Visible_Declarations (Def))
then
- declare
- Decl : Node_Id;
- Wrap_Decl : Node_Id;
- Wrap_Spec : Node_Id;
-
- begin
- Decl := First (Visible_Declarations (Def));
- while Present (Decl) loop
- Wrap_Spec := Empty;
-
- if Nkind (Decl) = N_Entry_Declaration
- and then Ekind (Defining_Identifier (Decl)) = E_Entry
- then
- Wrap_Spec :=
- Build_Wrapper_Spec
- (Subp_Id => Defining_Identifier (Decl),
- Obj_Typ => Rec_Typ,
- Formals => Parameter_Specifications (Decl));
-
- elsif Nkind (Decl) = N_Subprogram_Declaration then
- Wrap_Spec :=
- Build_Wrapper_Spec
- (Subp_Id => Defining_Unit_Name (Specification (Decl)),
- Obj_Typ => Rec_Typ,
- Formals =>
- Parameter_Specifications (Specification (Decl)));
- end if;
-
- if Present (Wrap_Spec) then
- Wrap_Decl :=
- Make_Subprogram_Declaration (Loc,
- Specification => Wrap_Spec);
-
- Insert_After (N, Wrap_Decl);
- N := Wrap_Decl;
-
- Analyze (Wrap_Decl);
- end if;
-
- Next (Decl);
- end loop;
- end;
+ Scan_Declarations (Visible_Declarations (Def));
+ Scan_Declarations (Private_Declarations (Def));
end if;
end Build_Wrapper_Specs;
-- Build_Private_Protected_Declaration --
-----------------------------------------
- function Build_Private_Protected_Declaration (N : Node_Id)
- return Entity_Id
+ function Build_Private_Protected_Declaration
+ (N : Node_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (N);
Body_Id : constant Entity_Id := Defining_Entity (N);
begin
Formal := First_Formal (Body_Id);
- -- The protected operation always has at least one formal, namely
- -- the object itself, but it is only placed in the parameter list
- -- if expansion is enabled.
+ -- The protected operation always has at least one formal, namely the
+ -- object itself, but it is only placed in the parameter list if
+ -- expansion is enabled.
- if Present (Formal)
- or else Expander_Active
- then
+ if Present (Formal) or else Expander_Active then
Plist := Copy_Parameter_List (Body_Id);
else
Plist := No_List;
if Nkind (Specification (N)) = N_Procedure_Specification then
New_Spec :=
Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
+ Defining_Unit_Name =>
Make_Defining_Identifier (Sloc (Body_Id),
Chars => Chars (Body_Id)),
- Parameter_Specifications => Plist);
+ Parameter_Specifications =>
+ Plist);
else
New_Spec :=
Make_Function_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Sloc (Body_Id),
- Chars => Chars (Body_Id)),
- Parameter_Specifications => Plist,
- Result_Definition =>
- New_Occurrence_Of (Etype (Body_Id), Loc));
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Sloc (Body_Id),
+ Chars => Chars (Body_Id)),
+ Parameter_Specifications => Plist,
+ Result_Definition =>
+ New_Occurrence_Of (Etype (Body_Id), Loc));
end if;
- Decl :=
- Make_Subprogram_Declaration (Loc,
- Specification => New_Spec);
+ Decl := Make_Subprogram_Declaration (Loc, Specification => New_Spec);
Insert_Before (N, Decl);
Spec_Id := Defining_Unit_Name (New_Spec);
- -- Indicate that the entity comes from source, to ensure that
- -- cross-reference information is properly generated. The body
- -- itself is rewritten during expansion, and the body entity will
- -- not appear in calls to the operation.
+ -- Indicate that the entity comes from source, to ensure that cross-
+ -- reference information is properly generated. The body itself is
+ -- rewritten during expansion, and the body entity will not appear in
+ -- calls to the operation.
Set_Comes_From_Source (Spec_Id, True);
Analyze (Decl);
Current_Node := New_Op_Body;
-- Generate an overriding primitive operation body for
- -- this subprogram if the protected type implements
- -- an interface.
+ -- this subprogram if the protected type implements an
+ -- interface.
if Ada_Version >= Ada_05
- and then Present (Interfaces (
- Corresponding_Record_Type (Pid)))
+ and then
+ Present (Interfaces (Corresponding_Record_Type (Pid)))
then
Disp_Op_Body :=
- Build_Dispatching_Subprogram_Body (
- Op_Body, Pid, New_Op_Body);
+ Build_Dispatching_Subprogram_Body
+ (Op_Body, Pid, New_Op_Body);
Insert_After (Current_Node, Disp_Op_Body);
Analyze (Disp_Op_Body);
end loop;
-- Finally, create the body of the function that maps an entry index
- -- into the corresponding body index, except when there is no entry,
- -- or in a ravenscar-like profile.
+ -- into the corresponding body index, except when there is no entry, or
+ -- in a Ravenscar-like profile.
if Corresponding_Runtime_Package (Pid) =
System_Tasking_Protected_Objects_Entries
OSDN Git Service
