[Ada] Simplify making of null procedure wrappers
Commit Message
Yet another cleanup related to expansion of dispatching primitives for
GNATprove. To keep this change semantically neutral, one parameter is
added to the Copy_Subprogram_Spec utility routine.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* exp_ch3.adb (Make_Null_Procedure_Specs): Simplify by reusing
Copy_Subprogram_Spec.
* sem_util.ads (Copy_Subprogram_Spec): Add New_Sloc parameter.
* sem_util.adb (Copy_Subprogram_Spec): Pass New_Sloc to
New_Copy_Tree.
@@ -10265,8 +10265,8 @@ package body Exp_Ch3 is
Decl_List : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Tag_Typ);
Formal : Entity_Id;
- Formal_List : List_Id;
New_Param_Spec : Node_Id;
+ New_Spec : Node_Id;
Parent_Subp : Entity_Id;
Prim_Elmt : Elmt_Id;
Subp : Entity_Id;
@@ -10285,59 +10285,47 @@ package body Exp_Ch3 is
if Present (Parent_Subp)
and then Is_Null_Interface_Primitive (Parent_Subp)
then
- Formal := First_Formal (Subp);
-
- if Present (Formal) then
- Formal_List := New_List;
-
- while Present (Formal) loop
+ -- The null procedure spec is copied from the inherited procedure,
+ -- except for the IS NULL (which must be added) and the overriding
+ -- indicators (which must be removed, if present).
- -- Copy the parameter spec including default expressions
+ New_Spec :=
+ Copy_Subprogram_Spec (Subprogram_Specification (Subp), Loc);
- New_Param_Spec :=
- New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
+ Set_Null_Present (New_Spec, True);
+ Set_Must_Override (New_Spec, False);
+ Set_Must_Not_Override (New_Spec, False);
- -- Generate a new defining identifier for the new formal.
- -- Required because New_Copy_Tree does not duplicate
- -- semantic fields (except itypes).
+ Formal := First_Formal (Subp);
+ New_Param_Spec := First (Parameter_Specifications (New_Spec));
- Set_Defining_Identifier (New_Param_Spec,
- Make_Defining_Identifier (Sloc (Formal),
- Chars => Chars (Formal)));
+ while Present (Formal) loop
- -- For controlling arguments we must change their parameter
- -- type to reference the tagged type (instead of the
- -- interface type).
+ -- For controlling arguments we must change their parameter
+ -- type to reference the tagged type (instead of the interface
+ -- type).
- if Is_Controlling_Formal (Formal) then
- if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier
- then
- Set_Parameter_Type (New_Param_Spec,
- New_Occurrence_Of (Tag_Typ, Loc));
-
- else pragma Assert
- (Nkind (Parameter_Type (Parent (Formal))) =
- N_Access_Definition);
- Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
- New_Occurrence_Of (Tag_Typ, Loc));
- end if;
+ if Is_Controlling_Formal (Formal) then
+ if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier
+ then
+ Set_Parameter_Type (New_Param_Spec,
+ New_Occurrence_Of (Tag_Typ, Loc));
+
+ else pragma Assert
+ (Nkind (Parameter_Type (Parent (Formal))) =
+ N_Access_Definition);
+ Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
+ New_Occurrence_Of (Tag_Typ, Loc));
end if;
+ end if;
- Append (New_Param_Spec, Formal_List);
-
- Next_Formal (Formal);
- end loop;
- else
- Formal_List := No_List;
- end if;
+ Next_Formal (Formal);
+ Next (New_Param_Spec);
+ end loop;
Append_To (Decl_List,
Make_Subprogram_Declaration (Loc,
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Chars (Subp)),
- Parameter_Specifications => Formal_List,
- Null_Present => True)));
+ Specification => New_Spec));
end if;
Next_Elmt (Prim_Elmt);
@@ -6871,7 +6871,10 @@ package body Sem_Util is
-- Copy_Subprogram_Spec --
--------------------------
- function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is
+ function Copy_Subprogram_Spec
+ (Spec : Node_Id;
+ New_Sloc : Source_Ptr := No_Location) return Node_Id
+ is
Def_Id : Node_Id;
Formal_Spec : Node_Id;
Result : Node_Id;
@@ -6880,7 +6883,7 @@ package body Sem_Util is
-- The structure of the original tree must be replicated without any
-- alterations. Use New_Copy_Tree for this purpose.
- Result := New_Copy_Tree (Spec);
+ Result := New_Copy_Tree (Spec, New_Sloc => New_Sloc);
-- However, the spec of a null procedure carries the corresponding null
-- statement of the body (created by the parser), and this cannot be
@@ -623,10 +623,13 @@ package Sem_Util is
-- aspect specifications. If From has no aspects, the routine has no
-- effect.
- function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id;
+ function Copy_Subprogram_Spec
+ (Spec : Node_Id;
+ New_Sloc : Source_Ptr := No_Location) return Node_Id;
-- Replicate a function or a procedure specification denoted by Spec. The
-- resulting tree is an exact duplicate of the original tree. New entities
- -- are created for the unit name and the formal parameters.
+ -- are created for the unit name and the formal parameters. For definition
+ -- of New_Sloc, see the comment for New_Copy_Tree.
function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id;
-- If a type is a generic actual type, return the corresponding formal in