We already had Subprogram_[Body|Spec|Specification] family of routines;
now we also have a symmetrical Package_[Body|Spec|Specification] family.
The added Package_Body routine is essentially moved from GNATprove, but
for simplicity it doesn't support package body entities.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* sem_aux.adb, sem_aux.ads (Package_Body): Moved from GNATprove.
* sem_elab.adb (Spec_And_Body_From_Entity): Refine type of parameter.diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb
--- a/gcc/ada/sem_aux.adb
+++ b/gcc/ada/sem_aux.adb
@@ -1401,6 +1401,31 @@ package body Sem_Aux is
and then Has_Discriminants (Typ));
end Object_Type_Has_Constrained_Partial_View;
+ ------------------
+ -- Package_Body --
+ ------------------
+
+ function Package_Body (E : Entity_Id) return Node_Id is
+ Body_Decl : Node_Id;
+ Body_Id : constant Opt_E_Package_Body_Id :=
+ Corresponding_Body (Package_Spec (E));
+
+ begin
+ if Present (Body_Id) then
+ Body_Decl := Parent (Body_Id);
+
+ if Nkind (Body_Decl) = N_Defining_Program_Unit_Name then
+ Body_Decl := Parent (Body_Decl);
+ end if;
+
+ pragma Assert (Nkind (Body_Decl) = N_Package_Body);
+
+ return Body_Decl;
+ else
+ return Empty;
+ end if;
+ end Package_Body;
+
------------------
-- Package_Spec --
------------------
diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads
--- a/gcc/ada/sem_aux.ads
+++ b/gcc/ada/sem_aux.ads
@@ -377,6 +377,10 @@ package Sem_Aux is
-- derived type, and the subtype is not an unconstrained array subtype
-- (RM 3.3(23.10/3)).
+ function Package_Body (E : Entity_Id) return Node_Id;
+ -- Given an entity for a package, return the corresponding package body, if
+ -- any, or else Empty.
+
function Package_Spec (E : Entity_Id) return Node_Id;
-- Given an entity for a package spec, return the corresponding package
-- spec if any, or else Empty.
diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -2070,7 +2070,7 @@ package body Sem_Elab is
-- Change the status of the elaboration phase of the compiler to Status
procedure Spec_And_Body_From_Entity
- (Id : Node_Id;
+ (Id : Entity_Id;
Spec_Decl : out Node_Id;
Body_Decl : out Node_Id);
pragma Inline (Spec_And_Body_From_Entity);
@@ -15835,7 +15835,7 @@ package body Sem_Elab is
-------------------------------
procedure Spec_And_Body_From_Entity
- (Id : Node_Id;
+ (Id : Entity_Id;
Spec_Decl : out Node_Id;
Body_Decl : out Node_Id)
is
