This is a minor internal cleanup, to introduce a new primitive
Is_Subprogram_Or_Generic_Subprogram with the obvious meaning.
No external effect, no test required.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-10-10 Robert Dewar <de...@adacore.com>
* sem_ch7.adb, einfo.adb, einfo.ads, sem_prag.adb, sem_ch12.adb,
freeze.adb, sem_util.adb, sem_res.adb, exp_ch6.adb, exp_ch13.adb,
sem_ch6.adb, sem_cat.adb, sem_disp.adb
(Is_Subprogram_Or_Generic_Subprogram): New primitive. Use this primitive
throughout where appropriate.
Index: sem_ch7.adb
===================================================================
--- sem_ch7.adb (revision 216063)
+++ sem_ch7.adb (working copy)
@@ -2808,7 +2808,7 @@
-- Body required if subprogram
- elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then
+ elsif Is_Subprogram_Or_Generic_Subprogram (P) then
return True;
-- Treat a block as requiring a body
@@ -2937,7 +2937,7 @@
-- Body required if subprogram
- elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then
+ elsif Is_Subprogram_Or_Generic_Subprogram (P) then
Error_Msg_N ("info: & requires body (subprogram case)?Y?", P);
-- Body required if generic parent has Elaborate_Body
Index: einfo.adb
===================================================================
--- einfo.adb (revision 216063)
+++ einfo.adb (working copy)
@@ -1129,8 +1129,7 @@
E_Package_Body,
E_Subprogram_Body,
E_Variable)
- or else Is_Generic_Subprogram (Id)
- or else Is_Subprogram (Id));
+ or else Is_Subprogram_Or_Generic_Subprogram (Id));
return Node34 (Id);
end Contract;
@@ -3405,6 +3404,13 @@
return Ekind (Id) in Subprogram_Kind;
end Is_Subprogram;
+ function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B is
+ begin
+ return Ekind (Id) in Subprogram_Kind
+ or else
+ Ekind (Id) in Generic_Subprogram_Kind;
+ end Is_Subprogram_Or_Generic_Subprogram;
+
function Is_Task_Type (Id : E) return B is
begin
return Ekind (Id) in Task_Kind;
@@ -3593,15 +3599,14 @@
begin
pragma Assert
(Ekind_In (Id, E_Entry,
- E_Entry_Family,
- E_Generic_Package,
- E_Package,
- E_Package_Body,
- E_Subprogram_Body,
- E_Variable,
- E_Void)
- or else Is_Generic_Subprogram (Id)
- or else Is_Subprogram (Id));
+ E_Entry_Family,
+ E_Generic_Package,
+ E_Package,
+ E_Package_Body,
+ E_Subprogram_Body,
+ E_Variable,
+ E_Void)
+ or else Is_Subprogram_Or_Generic_Subprogram (Id));
Set_Node34 (Id, V);
end Set_Contract;
Index: einfo.ads
===================================================================
--- einfo.ads (revision 216063)
+++ einfo.ads (working copy)
@@ -2974,6 +2974,10 @@
-- Applies to all entities, true for function, procedure and operator
-- entities.
+-- Is_Subprogram_Or_Generic_Subprogram
+-- Applies to all entities, true for function procedure and operator
+-- entities, and also for the corresponding generic entities.
+
-- Is_Synchronized_Interface (synthesized)
-- Defined in types that are interfaces. True if interface is declared
-- synchronized, task, or protected, or is derived from a synchronized
@@ -6964,6 +6968,7 @@
function Is_Scalar_Type (Id : E) return B;
function Is_Signed_Integer_Type (Id : E) return B;
function Is_Subprogram (Id : E) return B;
+ function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B;
function Is_Task_Type (Id : E) return B;
function Is_Type (Id : E) return B;
@@ -8800,6 +8805,7 @@
pragma Inline (Is_Base_Type);
pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Packed_Array);
+ pragma Inline (Is_Subprogram_Or_Generic_Subprogram);
pragma Inline (Is_Volatile);
pragma Inline (Is_Wrapper_Package);
pragma Inline (Known_RM_Size);
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 216063)
+++ sem_prag.adb (working copy)
@@ -6736,10 +6736,9 @@
("dispatching subprogram# cannot use Stdcall convention!",
Arg1);
- -- Subprogram is allowed, but not a generic subprogram
+ -- Subprograms are not allowed
- elsif not Is_Subprogram (E)
- and then not Is_Generic_Subprogram (E)
+ elsif not Is_Subprogram_Or_Generic_Subprogram (E)
-- A variable is OK
@@ -7016,8 +7015,7 @@
-- For Intrinsic, a subprogram is required
if C = Convention_Intrinsic
- and then not Is_Subprogram (E)
- and then not Is_Generic_Subprogram (E)
+ and then not Is_Subprogram_Or_Generic_Subprogram (E)
then
Error_Pragma_Arg
("second argument of pragma% must be a subprogram", Arg2);
@@ -7025,9 +7023,7 @@
-- Deal with non-subprogram cases
- if not Is_Subprogram (E)
- and then not Is_Generic_Subprogram (E)
- then
+ if not Is_Subprogram_Or_Generic_Subprogram (E) then
Set_Convention_From_Pragma (E);
if Is_Type (E) then
@@ -7885,9 +7881,8 @@
end if;
end if;
- elsif Is_Subprogram (Def_Id)
- or else Is_Generic_Subprogram (Def_Id)
- then
+ elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
+
-- If the name is overloaded, pragma applies to all of the denoted
-- entities in the same declarative part, unless the pragma comes
-- from an aspect specification or was generated by the compiler
@@ -7909,9 +7904,7 @@
-- If it is not a subprogram, it must be in an outer scope and
-- pragma does not apply.
- elsif not Is_Subprogram (Def_Id)
- and then not Is_Generic_Subprogram (Def_Id)
- then
+ elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
null;
-- The pragma does not apply to primitives of interfaces
Index: sem_ch12.adb
===================================================================
--- sem_ch12.adb (revision 216073)
+++ sem_ch12.adb (working copy)
@@ -3543,9 +3543,7 @@
else
E := First_Entity (Gen_Unit);
while Present (E) loop
- if Is_Subprogram (E)
- and then Is_Inlined (E)
- then
+ if Is_Subprogram (E) and then Is_Inlined (E) then
return True;
end if;
@@ -6558,7 +6556,7 @@
if Ekind (Scop) = E_Generic_Package
or else (Is_Subprogram (Scop)
- and then Nkind (Unit_Declaration_Node (Scop)) =
+ and then Nkind (Unit_Declaration_Node (Scop)) =
N_Generic_Subprogram_Declaration)
then
Elmt := First_Elmt (Inner_Instances (Inner));
Index: freeze.adb
===================================================================
--- freeze.adb (revision 216063)
+++ freeze.adb (working copy)
@@ -1703,7 +1703,6 @@
E := From;
while Present (E) loop
if Is_Subprogram (E) then
-
if not Default_Expressions_Processed (E) then
Process_Default_Expressions (E, After);
end if;
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 216063)
+++ sem_util.adb (working copy)
@@ -4321,7 +4321,7 @@
function Current_Subprogram return Entity_Id is
Scop : constant Entity_Id := Current_Scope;
begin
- if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
+ if Is_Subprogram_Or_Generic_Subprogram (Scop) then
return Scop;
else
return Enclosing_Subprogram (Scop);
@@ -16491,8 +16491,7 @@
while not Comes_From_Source (Val_Actual)
and then Nkind (Val_Actual) in N_Entity
and then (Ekind (Val_Actual) = E_Enumeration_Literal
- or else Is_Subprogram (Val_Actual)
- or else Is_Generic_Subprogram (Val_Actual))
+ or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual))
and then Present (Alias (Val_Actual))
loop
Val_Actual := Alias (Val_Actual);
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 216063)
+++ sem_res.adb (working copy)
@@ -4289,9 +4289,7 @@
then
Error_Msg_N ("class-wide argument not allowed here!", A);
- if Is_Subprogram (Nam)
- and then Comes_From_Source (Nam)
- then
+ if Is_Subprogram (Nam) and then Comes_From_Source (Nam) then
Error_Msg_Node_2 := F_Typ;
Error_Msg_NE
("& is not a dispatching operation of &!", A, Nam);
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 216063)
+++ exp_ch6.adb (working copy)
@@ -5825,9 +5825,8 @@
Defining_Identifier
(First (Parameter_Specifications (Parent (Corr))));
- if Is_Subprogram (Proc)
- and then Proc /= Corr
- then
+ if Is_Subprogram (Proc) and then Proc /= Corr then
+
-- Protected function or procedure
Set_Entity (Rec, Param);
Index: exp_ch13.adb
===================================================================
--- exp_ch13.adb (revision 216063)
+++ exp_ch13.adb (working copy)
@@ -528,7 +528,7 @@
and then
(Is_Entry (E_Scope)
or else (Is_Subprogram (E_Scope)
- and then Is_Protected_Type (Scope (E_Scope)))
+ and then Is_Protected_Type (Scope (E_Scope)))
or else Is_Task_Type (E_Scope))
then
null;
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb (revision 216063)
+++ sem_ch6.adb (working copy)
@@ -8406,7 +8406,7 @@
procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id) is
begin
if Opt.List_Inherited_Aspects
- and then (Is_Subprogram (E) or else Is_Generic_Subprogram (E))
+ and then Is_Subprogram_Or_Generic_Subprogram (E)
then
declare
Inherited : constant Subprogram_List := Inherited_Subprograms (E);
Index: sem_cat.adb
===================================================================
--- sem_cat.adb (revision 216063)
+++ sem_cat.adb (working copy)
@@ -615,10 +615,8 @@
E := Current_Scope;
loop
- if Is_Subprogram (E)
+ if Is_Subprogram_Or_Generic_Subprogram (E)
or else
- Is_Generic_Subprogram (E)
- or else
Is_Concurrent_Type (E)
then
return True;
Index: sem_disp.adb
===================================================================
--- sem_disp.adb (revision 216063)
+++ sem_disp.adb (working copy)
@@ -2098,10 +2098,7 @@
and then
Is_Interface (Find_Dispatching_Type (Parent_Op)));
- if Is_Subprogram (Parent_Op)
- or else
- Is_Generic_Subprogram (Parent_Op)
- then
+ if Is_Subprogram_Or_Generic_Subprogram (Parent_Op) then
Store_IS (Parent_Op);
end if;
end loop;
@@ -2134,10 +2131,7 @@
-- The following test eliminates some odd cases in which
-- Ekind (Prim) is Void, to be investigated further ???
- if not (Is_Subprogram (Prim)
- or else
- Is_Generic_Subprogram (Prim))
- then
+ if not Is_Subprogram_Or_Generic_Subprogram (Prim) then
null;
-- For [generic] subprogram, look at interface alias
