From b9696ffb6e8e8fbb59b0cc925e218e92c2d71be0 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 10 Oct 2014 14:21:19 +0200 Subject: [PATCH] [multiple changes] 2014-10-10 Robert Dewar * 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. 2014-10-10 Bob Duff * a-coinho-shared.ads: Minor reformatting. * s-traceb.adb: Minor clean up. 2014-10-10 Robert Dewar * ali.adb (Scan_ALI): Read and process new GP flag on ALI P line. * ali.ads (GNATprove_Mode): New component in ALI table. (GNATprove_Mode_Specified): New global. * gnatbind.adb (Gnatbind): Give fatal error if any file compiled in GNATProve mode. * lib-writ.ads, lib-writ.adb (GP): New flag on P line for GNATProve_Mode. 2014-10-10 Javier Miranda * exp_ch3.adb (Build_Init_Procedure): Adding assertion. (Build_Init_Statement): Ensure that statements associated with the parent components are located at the beginning of the returned list of statements. 2014-10-10 Ed Schonberg * sem_ch13.adb (Inherit_Aspects_At_Freeze_Node): If the full view of a private type T that has a type invariant is a scalar or constrained array type, the base type created for the full view has the same type invariant. From-SVN: r216074 --- gcc/ada/ChangeLog | 37 +++++++++++++++++++++ gcc/ada/a-coinho-shared.ads | 6 ++-- gcc/ada/ali.adb | 9 ++++++ gcc/ada/ali.ads | 8 +++++ gcc/ada/einfo.adb | 27 +++++++++------- gcc/ada/einfo.ads | 6 ++++ gcc/ada/exp_ch13.adb | 2 +- gcc/ada/exp_ch3.adb | 64 +++++++++++++++++++++++++------------ gcc/ada/exp_ch6.adb | 5 ++- gcc/ada/freeze.adb | 1 - gcc/ada/gnatbind.adb | 7 ++++ gcc/ada/lib-writ.adb | 4 +++ gcc/ada/lib-writ.ads | 7 +++- gcc/ada/s-traceb.adb | 10 ------ gcc/ada/sem_cat.adb | 4 +-- gcc/ada/sem_ch12.adb | 6 ++-- gcc/ada/sem_ch13.adb | 9 ++++++ gcc/ada/sem_ch6.adb | 2 +- gcc/ada/sem_ch7.adb | 4 +-- gcc/ada/sem_disp.adb | 10 ++---- gcc/ada/sem_prag.adb | 21 ++++-------- gcc/ada/sem_res.adb | 4 +-- gcc/ada/sem_util.adb | 5 ++- 23 files changed, 170 insertions(+), 88 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5d50356a7f4..e835483dca7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,40 @@ +2014-10-10 Robert Dewar + + * 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. + +2014-10-10 Bob Duff + + * a-coinho-shared.ads: Minor reformatting. + * s-traceb.adb: Minor clean up. + +2014-10-10 Robert Dewar + + * ali.adb (Scan_ALI): Read and process new GP flag on ALI P line. + * ali.ads (GNATprove_Mode): New component in ALI table. + (GNATprove_Mode_Specified): New global. + * gnatbind.adb (Gnatbind): Give fatal error if any file compiled + in GNATProve mode. + * lib-writ.ads, lib-writ.adb (GP): New flag on P line for + GNATProve_Mode. + +2014-10-10 Javier Miranda + + * exp_ch3.adb (Build_Init_Procedure): Adding assertion. + (Build_Init_Statement): Ensure that statements + associated with the parent components are located at the beginning + of the returned list of statements. + +2014-10-10 Ed Schonberg + + * sem_ch13.adb (Inherit_Aspects_At_Freeze_Node): If the full + view of a private type T that has a type invariant is a scalar + or constrained array type, the base type created for the full + view has the same type invariant. + 2014-10-10 Robert Dewar * exp_util.ads, sem_ch12.adb, exp_util.adb, i-fortra.ads: Minor code diff --git a/gcc/ada/a-coinho-shared.ads b/gcc/ada/a-coinho-shared.ads index b040e666141..2ec30f88aef 100644 --- a/gcc/ada/a-coinho-shared.ads +++ b/gcc/ada/a-coinho-shared.ads @@ -29,12 +29,12 @@ -- . -- ------------------------------------------------------------------------------ --- Missing documentation: what is this unit all about??? From its name it --- is some variation of a-coinho.ads/adb, but documentation needs to be --- HERE explaining that ??? +-- This is an optimized version of Indefinite_Holders using copy-on-write. +-- It is used on platforms that support atomic built-ins. private with Ada.Finalization; private with Ada.Streams; + private with System.Atomic_Counters; generic diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 2fe95525926..3a3431878aa 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -111,6 +111,7 @@ package body ALI is Locking_Policy_Specified := ' '; No_Normalize_Scalars_Specified := False; No_Object_Specified := False; + GNATprove_Mode_Specified := False; Normalize_Scalars_Specified := False; Partition_Elaboration_Policy_Specified := ' '; Queuing_Policy_Specified := ' '; @@ -875,6 +876,7 @@ package body ALI is First_Sdep => No_Sdep_Id, First_Specific_Dispatching => Specific_Dispatching.Last + 1, First_Unit => No_Unit_Id, + GNATprove_Mode => False, Last_Interrupt_State => Interrupt_States.Last, Last_Sdep => No_Sdep_Id, Last_Specific_Dispatching => Specific_Dispatching.Last, @@ -1089,6 +1091,13 @@ package body ALI is ALIs.Table (Id).Partition_Elaboration_Policy := Partition_Elaboration_Policy_Specified; + -- Processing for GP + + elsif C = 'G' then + Checkc ('P'); + GNATprove_Mode_Specified := True; + ALIs.Table (Id).GNATprove_Mode := True; + -- Processing for Lx elsif C = 'L' then diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index f896e7d0088..c48d913d8a3 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -176,6 +176,11 @@ package ALI is -- always be set as well in this case. Not set if 'P' appears in -- Ignore_Lines. + GNATprove_Mode : Boolean; + -- Set to True if ALI and object file produced in GNATprove_Mode as + -- signalled by GP appearing on the P line. Not set if 'P' appears in + -- Ignore_Lines. + No_Object : Boolean; -- Set to True if no object file generated. Not set if 'P' appears in -- Ignore_Lines. @@ -465,6 +470,9 @@ package ALI is -- Set to False by Initialize_ALI. Set to True if Scan_ALI reads -- a unit for which dynamic elaboration checking is enabled. + GNATprove_Mode_Specified : Boolean := False; + -- Set to True if an ali file was produced in GNATprove mode. + Initialize_Scalars_Used : Boolean := False; -- Set True if an ali file contains the Initialize_Scalars flag diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index c3b0f991966..e4e03601996 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -1129,8 +1129,7 @@ package body Einfo is 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 @@ package body Einfo is 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 @@ package body Einfo is 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; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index d75beccb0ee..da63627748c 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2974,6 +2974,10 @@ package Einfo is -- 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 @@ package Einfo is 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 @@ package Einfo is 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); diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 096365ccb40..ff73d94522b 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -528,7 +528,7 @@ package body Exp_Ch13 is 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; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index bd4886da512..9541ad096c1 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2372,7 +2372,15 @@ package body Exp_Ch3 is -- generated. if not Is_Interface (Etype (Rec_Ent)) then - Prepend_To (Body_Stmts, Remove_Head (Stmts)); + declare + First_Stmt : constant Node_Id := Remove_Head (Stmts); + begin + pragma Assert + (Nkind (First_Stmt) = N_Procedure_Call_Statement + and then + Is_Init_Proc (Name (First_Stmt))); + Prepend_To (Body_Stmts, First_Stmt); + end; end if; Append_List_To (Body_Stmts, Stmts); @@ -2655,15 +2663,16 @@ package body Exp_Ch3 is --------------------------- function Build_Init_Statements (Comp_List : Node_Id) return List_Id is - Checks : constant List_Id := New_List; - Actions : List_Id := No_List; - Comp_Loc : Source_Ptr; - Counter_Id : Entity_Id := Empty; - Decl : Node_Id; - Has_POC : Boolean; - Id : Entity_Id; - Stmts : List_Id; - Typ : Entity_Id; + Checks : constant List_Id := New_List; + Actions : List_Id := No_List; + Comp_Loc : Source_Ptr; + Counter_Id : Entity_Id := Empty; + Decl : Node_Id; + Has_POC : Boolean; + Id : Entity_Id; + Parent_Stmts : List_Id; + Stmts : List_Id; + Typ : Entity_Id; procedure Increment_Counter (Loc : Source_Ptr); -- Generate an "increment by one" statement for the current counter @@ -2727,6 +2736,7 @@ package body Exp_Ch3 is return New_List (Make_Null_Statement (Loc)); end if; + Parent_Stmts := New_List; Stmts := New_List; -- Loop through visible declarations of task types and protected @@ -2956,22 +2966,30 @@ package body Exp_Ch3 is end if; if Present (Checks) then - Append_List_To (Stmts, Checks); + if Chars (Id) = Name_uParent then + Append_List_To (Parent_Stmts, Checks); + else + Append_List_To (Stmts, Checks); + end if; end if; if Present (Actions) then - Append_List_To (Stmts, Actions); + if Chars (Id) = Name_uParent then + Append_List_To (Parent_Stmts, Actions); - -- Preserve the initialization state in the current counter + else + Append_List_To (Stmts, Actions); - if Chars (Id) /= Name_uParent - and then Needs_Finalization (Typ) - then - if No (Counter_Id) then - Make_Counter (Comp_Loc); - end if; + -- Preserve the initialization state in the current + -- counter - Increment_Counter (Comp_Loc); + if Needs_Finalization (Typ) then + if No (Counter_Id) then + Make_Counter (Comp_Loc); + end if; + + Increment_Counter (Comp_Loc); + end if; end if; end if; end if; @@ -2979,6 +2997,12 @@ package body Exp_Ch3 is Next_Non_Pragma (Decl); end loop; + -- The parent field must be initialized first because variable + -- size components of the parent affect the location of all the + -- new components. + + Prepend_List_To (Stmts, Parent_Stmts); + -- Set up tasks and protected object support. This needs to be done -- before any component with a per-object access discriminant -- constraint, or any variant part (which may contain such diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 97464167129..25a3972e758 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5825,9 +5825,8 @@ package body Exp_Ch6 is 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); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 17f96491c38..d5dbb440fbb 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1703,7 +1703,6 @@ package body Freeze is 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; diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 7cba0c684f2..0d99ccf155c 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -776,6 +776,13 @@ begin raise Unrecoverable_Error; end if; + -- Quit with message if we had a GNATprove file + + if GNATprove_Mode_Specified then + Error_Msg ("one or more files compiled in GNATprove mode"); + raise Unrecoverable_Error; + end if; + -- Output list of ALI files in closure if Output_ALI_List then diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 1492852468b..67a4859a81f 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -1153,6 +1153,10 @@ package body Lib.Writ is end if; end if; + if GNATprove_Mode then + Write_Info_Str (" GP"); + end if; + if Partition_Elaboration_Policy /= ' ' then Write_Info_Str (" E"); Write_Info_Char (Partition_Elaboration_Policy); diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index 5a061e49e4d..91c16c0f081 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -192,6 +192,9 @@ package Lib.Writ is -- the units in this file, where x is the first character -- (upper case) of the policy name (e.g. 'C' for Concurrent). + -- GP Set if this compilation was done in GNATprove mode, either + -- from direct use of GNATprove, or from use of -gnatdF. + -- Lx A valid Locking_Policy pragma applies to all the units in -- this file, where x is the first character (upper case) of -- the policy name (e.g. 'C' for Ceiling_Locking). @@ -200,7 +203,9 @@ package Lib.Writ is -- were not compiled to produce an object. This can occur as a -- result of the use of -gnatc, or if no object can be produced -- (e.g. when a package spec is compiled instead of the body, - -- or a subunit on its own). + -- or a subunit on its own). Note that in GNATprove mode, we + -- do produce an object. The object is not suitable for binding + -- and linking, but we do not set NO, instead we set GP. -- NR No_Run_Time. Indicates that a pragma No_Run_Time applies -- to all units in the file. diff --git a/gcc/ada/s-traceb.adb b/gcc/ada/s-traceb.adb index 0a8726c6596..4855644434e 100644 --- a/gcc/ada/s-traceb.adb +++ b/gcc/ada/s-traceb.adb @@ -38,16 +38,6 @@ pragma Compiler_Unit_Warning; package body System.Traceback is --- procedure Call_Chain --- (Traceback : System.Address; --- Max_Len : Natural; --- Len : out Natural; --- Exclude_Min : System.Address := System.Null_Address; --- Exclude_Max : System.Address := System.Null_Address; --- Skip_Frames : Natural := 1); --- -- Same as the exported version, but takes Traceback as an Address --- ???See declaration in the spec for why this is temporarily commented out. - ------------------ -- C_Call_Chain -- ------------------ diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 9a65a05bb4f..04638aaa8d0 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -615,9 +615,7 @@ package body Sem_Cat is E := Current_Scope; loop - if Is_Subprogram (E) - or else - Is_Generic_Subprogram (E) + if Is_Subprogram_Or_Generic_Subprogram (E) or else Is_Concurrent_Type (E) then diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index ed96e8929f4..595a3b0a8b4 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3543,9 +3543,7 @@ package body Sem_Ch12 is 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 @@ package body Sem_Ch12 is 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)); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index a73712bfb5f..10f4a7480b6 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -10705,6 +10705,15 @@ package body Sem_Ch13 is if Class_Present (Get_Rep_Item (Typ, Name_Invariant)) then Set_Has_Inheritable_Invariants (Typ); end if; + + -- If the full view of the type is a scalar type or array type, the + -- implicit base type created for it has the same invariant. + + elsif Has_Invariants (Typ) and then Base_Type (Typ) /= Typ + and then not Has_Invariants (Base_Type (Typ)) + then + Set_Has_Invariants (Base_Type (Typ)); + Set_Invariant_Procedure (Base_Type (Typ), Invariant_Procedure (Typ)); end if; -- Volatile diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 01c6e26b50c..41c7fd8dae7 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -8406,7 +8406,7 @@ package body Sem_Ch6 is 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); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 4821db529c8..2d96314fc35 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -2808,7 +2808,7 @@ package body Sem_Ch7 is -- 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 @@ package body Sem_Ch7 is -- 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 diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 6d6078dc9f5..a915ab05e77 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -2098,10 +2098,7 @@ package body Sem_Disp is 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 @@ package body Sem_Disp is -- 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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index dc084f9e13e..436b9b12a29 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6736,10 +6736,9 @@ package body Sem_Prag is ("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 @@ package body Sem_Prag is -- 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 @@ package body Sem_Prag is -- 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 @@ package body Sem_Prag is 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 @@ package body Sem_Prag is -- 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 diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f45e07e06cc..b35ffbd8626 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4289,9 +4289,7 @@ package body Sem_Res is 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); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 01c16244621..85105e538e0 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4321,7 +4321,7 @@ package body Sem_Util is 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 @@ package body Sem_Util is 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); -- 2.30.2