From d1eb8a82b2851aba9cc35cc698be7dbf4f80ec9a Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 11:22:43 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Arnaud Charlet * a-cfinve.ads, a-cofove.ads (Empty_Vector): add Global contract. 2017-04-25 Justin Squirek * sem_ch3.adb (Analyze_Declarations): Minor correction to comments, move out large conditional and scope traversal into a predicate. (Uses_Unseen_Lib_Unit_Priv): Predicate function made from extracted logic. 2017-04-25 Ed Schonberg * sem_ch4.adb (Analyze_Selected_Component): Refine analysis of prefix whose type is a current instance of a synchronized type. If the prefix is an object this is an external call (or requeue) that can only access public operations of the object. The previous predicate was too restrictive, and did not allow public protected operations, only task entries. 2017-04-25 Hristian Kirtchev * sem_ch5.adb, fname.adb: Minor reformatting. 2017-04-25 Hristian Kirtchev * einfo.adb (Is_Anonymous_Access_Type): New routine. * einfo.ads Update the placement of E_Anonymous_Access_Subprogram_Type along with all subtypes that mention the ekind. (Is_Anonymous_Access_Type): New routine. * exp_ch7.adb (Allows_Finalization_Master): Do not generate a master for an access type subject to pragma No_Heap_Finalization. * exp_util.adb (Build_Allocate_Deallocate_Proc): An object being allocated or deallocated does not finalization actions if the associated access type is subject to pragma No_Heap_Finalization. * opt.ads Add new global variable No_Heap_Finalization_Pragma. * par-prag.adb Pragma No_Heap_Finalization does not need special processing from the parser. * sem_ch6.adb (Check_Return_Subtype_Indication): Remove ancient ??? comments. Use the new predicate Is_Anonymous_Access_Type. * sem_prag.adb Add an entry in table Sig_Flags for pragma No_Heap_Finalization. (Analyze_Pragma): Add processing for pragma No_Heap_Finalization. Update various error messages to use Duplication_Error. * sem_util.ads, sem_util.adb (No_Heap_Finalization): New routine. * snames.ads-tmpl: Add new predefined name No_Heap_Finalization and corresponding pragma id. From-SVN: r247156 --- gcc/ada/ChangeLog | 51 +++++++++++++ gcc/ada/a-cfinve.ads | 5 +- gcc/ada/a-cofove.ads | 5 +- gcc/ada/einfo.adb | 5 ++ gcc/ada/einfo.ads | 28 ++++--- gcc/ada/exp_ch7.adb | 23 ++++-- gcc/ada/exp_util.adb | 49 +++++++----- gcc/ada/fname.adb | 4 +- gcc/ada/opt.ads | 5 ++ gcc/ada/par-prag.adb | 1 + gcc/ada/sem_ch3.adb | 162 ++++++++++++++++++++-------------------- gcc/ada/sem_ch4.adb | 13 +++- gcc/ada/sem_ch5.adb | 3 +- gcc/ada/sem_ch6.adb | 47 ++++-------- gcc/ada/sem_prag.adb | 154 +++++++++++++++++++++++++++++++++++--- gcc/ada/sem_util.adb | 27 +++++++ gcc/ada/sem_util.ads | 3 + gcc/ada/snames.ads-tmpl | 2 + 18 files changed, 418 insertions(+), 169 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a9de5f0f9e5..50e45b69d33 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,54 @@ +2017-04-25 Arnaud Charlet + + * a-cfinve.ads, a-cofove.ads (Empty_Vector): add Global contract. + +2017-04-25 Justin Squirek + + * sem_ch3.adb (Analyze_Declarations): Minor + correction to comments, move out large conditional and scope + traversal into a predicate. + (Uses_Unseen_Lib_Unit_Priv): Predicate function made from extracted + logic. + +2017-04-25 Ed Schonberg + + * sem_ch4.adb (Analyze_Selected_Component): Refine analysis + of prefix whose type is a current instance of a synchronized + type. If the prefix is an object this is an external call (or + requeue) that can only access public operations of the object. The + previous predicate was too restrictive, and did not allow public + protected operations, only task entries. + +2017-04-25 Hristian Kirtchev + + * sem_ch5.adb, fname.adb: Minor reformatting. + +2017-04-25 Hristian Kirtchev + + * einfo.adb (Is_Anonymous_Access_Type): New routine. + * einfo.ads Update the placement of + E_Anonymous_Access_Subprogram_Type along with all subtypes that + mention the ekind. + (Is_Anonymous_Access_Type): New routine. + * exp_ch7.adb (Allows_Finalization_Master): Do not generate a + master for an access type subject to pragma No_Heap_Finalization. + * exp_util.adb (Build_Allocate_Deallocate_Proc): An object being + allocated or deallocated does not finalization actions if the + associated access type is subject to pragma No_Heap_Finalization. + * opt.ads Add new global variable No_Heap_Finalization_Pragma. + * par-prag.adb Pragma No_Heap_Finalization does not need special + processing from the parser. + * sem_ch6.adb (Check_Return_Subtype_Indication): Remove ancient + ??? comments. Use the new predicate Is_Anonymous_Access_Type. + * sem_prag.adb Add an entry in table Sig_Flags for pragma + No_Heap_Finalization. + (Analyze_Pragma): Add processing for + pragma No_Heap_Finalization. Update various error messages to + use Duplication_Error. + * sem_util.ads, sem_util.adb (No_Heap_Finalization): New routine. + * snames.ads-tmpl: Add new predefined name No_Heap_Finalization + and corresponding pragma id. + 2017-04-25 Bob Duff * freeze.adb (Freeze_Record_Type): Use the diff --git a/gcc/ada/a-cfinve.ads b/gcc/ada/a-cfinve.ads index e76ae8d8926..34abfbbbcff 100644 --- a/gcc/ada/a-cfinve.ads +++ b/gcc/ada/a-cfinve.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2014-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2014-2016, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -73,7 +73,8 @@ is type Vector (Capacity : Capacity_Range) is limited private with Default_Initial_Condition; - function Empty_Vector return Vector; + function Empty_Vector return Vector with + Global => null; function "=" (Left, Right : Vector) return Boolean with Global => null; diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads index e8a3c946318..a97d2d8c10b 100644 --- a/gcc/ada/a-cofove.ads +++ b/gcc/ada/a-cofove.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2016, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -73,7 +73,8 @@ is -- unbounded case; you can't assign from one object to another if the -- Capacity is different. - function Empty_Vector return Vector; + function Empty_Vector return Vector with + Global => null; function "=" (Left, Right : Vector) return Boolean with Global => null; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 9f9a0a617bf..441d3096264 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -3533,6 +3533,11 @@ package body Einfo is return Ekind (Id) in Aggregate_Kind; end Is_Aggregate_Type; + function Is_Anonymous_Access_Type (Id : E) return B is + begin + return Ekind (Id) in Anonymous_Access_Kind; + end Is_Anonymous_Access_Type; + function Is_Array_Type (Id : E) return B is begin return Ekind (Id) in Array_Kind; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index f0080d550d3..9a0530d8da7 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4845,12 +4845,6 @@ package Einfo is -- An access to subprogram type, created by an access to subprogram -- declaration. - E_Anonymous_Access_Subprogram_Type, - -- An anonymous access to subprogram type, created by an access to - -- subprogram declaration, or generated for a current instance of - -- a type name appearing within a component definition that has an - -- anonymous access to subprogram type. - E_Access_Protected_Subprogram_Type, -- An access to a protected subprogram, created by the corresponding -- declaration. Values of such a type denote both a protected object @@ -4861,6 +4855,12 @@ package Einfo is -- An anonymous access to protected subprogram type, created by an -- access to subprogram declaration. + E_Anonymous_Access_Subprogram_Type, + -- An anonymous access to subprogram type, created by an access to + -- subprogram declaration, or generated for a current instance of + -- a type name appearing within a component definition that has an + -- anonymous access to subprogram type. + E_Anonymous_Access_Type, -- An anonymous access type created by an access parameter or access -- discriminant. @@ -5090,16 +5090,16 @@ package Einfo is -- E_Allocator_Type -- E_General_Access_Type -- E_Access_Subprogram_Type - -- E_Anonymous_Access_Subprogram_Type -- E_Access_Protected_Subprogram_Type -- E_Anonymous_Access_Protected_Subprogram_Type + -- E_Anonymous_Access_Subprogram_Type E_Anonymous_Access_Type; subtype Access_Subprogram_Kind is Entity_Kind range E_Access_Subprogram_Type .. - -- E_Anonymous_Access_Subprogram_Type -- E_Access_Protected_Subprogram_Type - E_Anonymous_Access_Protected_Subprogram_Type; + -- E_Anonymous_Access_Protected_Subprogram_Type + E_Anonymous_Access_Subprogram_Type; subtype Access_Protected_Kind is Entity_Kind range E_Access_Protected_Subprogram_Type .. @@ -5114,6 +5114,11 @@ package Einfo is -- E_Record_Type E_Record_Subtype; + subtype Anonymous_Access_Kind is Entity_Kind range + E_Anonymous_Access_Protected_Subprogram_Type .. + -- E_Anonymous_Subprogram_Type + E_Anonymous_Access_Type; + subtype Array_Kind is Entity_Kind range E_Array_Type .. -- E_Array_Subtype @@ -5209,8 +5214,8 @@ package Einfo is -- E_General_Access_Type -- E_Access_Subprogram_Type -- E_Access_Protected_Subprogram_Type - -- E_Anonymous_Access_Subprogram_Type -- E_Anonymous_Access_Protected_Subprogram_Type + -- E_Anonymous_Access_Subprogram_Type E_Anonymous_Access_Type; subtype Enumeration_Kind is Entity_Kind range @@ -5388,8 +5393,8 @@ package Einfo is -- E_General_Access_Type -- E_Access_Subprogram_Type, -- E_Access_Protected_Subprogram_Type - -- E_Anonymous_Access_Subprogram_Type -- E_Anonymous_Access_Protected_Subprogram_Type + -- E_Anonymous_Access_Subprogram_Type -- E_Anonymous_Access_Type -- E_Array_Type -- E_Array_Subtype @@ -7359,6 +7364,7 @@ package Einfo is function Is_Access_Protected_Subprogram_Type (Id : E) return B; function Is_Access_Subprogram_Type (Id : E) return B; function Is_Aggregate_Type (Id : E) return B; + function Is_Anonymous_Access_Type (Id : E) return B; function Is_Array_Type (Id : E) return B; function Is_Assignable (Id : E) return B; function Is_Class_Wide_Type (Id : E) return B; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 5d981608e63..852ae444033 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -486,34 +486,41 @@ package body Exp_Ch7 is then return False; - -- Do not consider types that return on the secondary stack + -- Do not consider an access type which return on the secondary stack elsif Present (Associated_Storage_Pool (Ptr_Typ)) and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool) then return False; - -- Do not consider types which may never allocate an object + -- Do not consider an access type which may never allocate an object elsif No_Pool_Assigned (Ptr_Typ) then return False; - -- Do not consider access types coming from Ada.Unchecked_Deallocation - -- instances. Even though the designated type may be controlled, the - -- access type will never participate in allocation. + -- Do not consider an access type coming from an Unchecked_Deallocation + -- instance. Even though the designated type may be controlled, the + -- access type will never participate in any allocations. elsif In_Deallocation_Instance (Ptr_Typ) then return False; - -- Do not consider non-library access types when restriction - -- No_Nested_Finalization is in effect since masters are controlled - -- objects. + -- Do not consider a non-library access type when No_Nested_Finalization + -- is in effect since finalization masters are controlled objects and if + -- created will violate the restriction. elsif Restriction_Active (No_Nested_Finalization) and then not Is_Library_Level_Entity (Ptr_Typ) then return False; + -- Do not consider an access type subject to pragma No_Heap_Finalization + -- because objects allocated through such a type are not to be finalized + -- when the access type goes out of scope. + + elsif No_Heap_Finalization (Ptr_Typ) then + return False; + -- Do not create finalization masters in GNATprove mode because this -- causes unwanted extra expansion. A compilation in this mode must -- keep the tree as close as possible to the original sources. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 4bfd8b9e5ab..034df56907f 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -481,12 +481,6 @@ package body Exp_Util is (N : Node_Id; Is_Allocate : Boolean) is - Desig_Typ : Entity_Id; - Expr : Node_Id; - Pool_Id : Entity_Id; - Proc_To_Call : Node_Id := Empty; - Ptr_Typ : Entity_Id; - function Find_Object (E : Node_Id) return Node_Id; -- Given an arbitrary expression of an allocator, try to find an object -- reference in it, otherwise return the original expression. @@ -576,6 +570,15 @@ package body Exp_Util is return False; end Is_Allocate_Deallocate_Proc; + -- Local variables + + Desig_Typ : Entity_Id; + Expr : Node_Id; + Needs_Fin : Boolean; + Pool_Id : Entity_Id; + Proc_To_Call : Node_Id := Empty; + Ptr_Typ : Entity_Id; + -- Start of processing for Build_Allocate_Deallocate_Proc begin @@ -667,7 +670,15 @@ package body Exp_Util is return; end if; - if Needs_Finalization (Desig_Typ) then + -- Finalization actions are required when the object to be allocated or + -- deallocated needs these actions and the associated access type is not + -- subject to pragma No_Heap_Finalization. + + Needs_Fin := + Needs_Finalization (Desig_Typ) + and then not No_Heap_Finalization (Ptr_Typ); + + if Needs_Fin then -- Certain run-time configurations and targets do not provide support -- for controlled types. @@ -737,7 +748,7 @@ package body Exp_Util is -- c) Finalization master - if Needs_Finalization (Desig_Typ) then + if Needs_Fin then Fin_Mas_Id := Finalization_Master (Ptr_Typ); Fin_Mas_Act := New_Occurrence_Of (Fin_Mas_Id, Loc); @@ -761,7 +772,7 @@ package body Exp_Util is -- Primitive Finalize_Address is never generated in CodePeer mode -- since it contains an Unchecked_Conversion. - if Needs_Finalization (Desig_Typ) and then not CodePeer_Mode then + if Needs_Fin and then not CodePeer_Mode then Fin_Addr_Id := Finalize_Address (Desig_Typ); pragma Assert (Present (Fin_Addr_Id)); @@ -807,8 +818,8 @@ package body Exp_Util is -- h) Is_Controlled - if Needs_Finalization (Desig_Typ) then - declare + if Needs_Fin then + Is_Controlled : declare Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F'); Flag_Expr : Node_Id; Param : Node_Id; @@ -904,7 +915,7 @@ package body Exp_Util is Expression => Flag_Expr)); Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc)); - end; + end Is_Controlled; -- The object is not controlled @@ -935,19 +946,19 @@ package body Exp_Util is Insert_Action (N, Make_Subprogram_Body (Loc, - Specification => + Specification => -- procedure Pnn Make_Procedure_Specification (Loc, - Defining_Unit_Name => Proc_Id, + Defining_Unit_Name => Proc_Id, Parameter_Specifications => New_List ( -- P : Root_Storage_Pool Make_Parameter_Specification (Loc, Defining_Identifier => Make_Temporary (Loc, 'P'), - Parameter_Type => + Parameter_Type => New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)), -- A : [out] Address @@ -972,13 +983,14 @@ package body Exp_Util is Parameter_Type => New_Occurrence_Of (RTE (RE_Storage_Count), Loc)))), - Declarations => No_List, + Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Proc_To_Call, Loc), + Name => + New_Occurrence_Of (Proc_To_Call, Loc), Parameter_Associations => Actuals))))); -- The newly generated Allocate / Deallocate becomes the default @@ -10252,7 +10264,8 @@ package body Exp_Util is -- Class-wide types are treated as controlled because derivations -- from the root type can introduce controlled components. - return Is_Class_Wide_Type (T) + return + Is_Class_Wide_Type (T) or else Is_Controlled (T) or else Has_Some_Controlled_Component (T) or else diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb index 6db82910641..0024eec4e2d 100644 --- a/gcc/ada/fname.adb +++ b/gcc/ada/fname.adb @@ -230,8 +230,8 @@ package body Fname is Renamings_Included : Boolean := True) return Boolean is Result : constant Boolean := - Is_Predefined_File_Name - (Get_Name_String (Fname), Renamings_Included); + Is_Predefined_File_Name + (Get_Name_String (Fname), Renamings_Included); begin return Result; end Is_Predefined_File_Name; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 9ef851d841f..94fdd8a065c 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1115,6 +1115,11 @@ package Opt is -- in the spec of the extended main unit. Used to determine if we need to -- do special tests for violation of this aspect. + No_Heap_Finalization_Pragma : Node_Id := Empty; + -- GNAT + -- Set to point to a No_Heap_Finalization pragma defined in a configuration + -- file. + No_Main_Subprogram : Boolean := False; -- GNATMAKE, GNATBIND -- Set to True if compilation/binding of a program without main diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 85cd8998549..02223c8c686 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1410,6 +1410,7 @@ begin | Pragma_Memory_Size | Pragma_No_Body | Pragma_No_Elaboration_Code_All + | Pragma_No_Heap_Finalization | Pragma_No_Inline | Pragma_No_Return | Pragma_No_Run_Time diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index cbae00f158f..6b8a4535313 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2195,6 +2195,10 @@ package body Sem_Ch3 is -- Utility to resolve the expressions of aspects at the end of a list of -- declarations. + function Uses_Unseen_Lib_Unit_Priv (Pkg : Entity_Id) return Boolean; + -- Check if an inner package has entities within it that rely on library + -- level private types where the full view has not been seen. + ----------------- -- Adjust_Decl -- ----------------- @@ -2480,6 +2484,40 @@ package body Sem_Ch3 is end loop; end Resolve_Aspects; + ------------------------------- + -- Uses_Unseen_Lib_Unit_Priv -- + ------------------------------- + + function Uses_Unseen_Lib_Unit_Priv (Pkg : Entity_Id) return Boolean is + Curr : Entity_Id; + + begin + -- Avoid looking through scopes that do not meet the precondition of + -- Pkg not being within a library unit spec. + + if not Is_Compilation_Unit (Pkg) + and then not Is_Generic_Instance (Pkg) + and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg)) + then + -- Loop through all entities in the current scope to identify + -- an entity that depends on a private type. + + Curr := First_Entity (Pkg); + loop + if Nkind (Curr) in N_Entity + and then Depends_On_Private (Curr) + then + return True; + end if; + + exit when Last_Entity (Current_Scope) = Curr; + Curr := Next_Entity (Curr); + end loop; + end if; + + return False; + end Uses_Unseen_Lib_Unit_Priv; + -- Local variables Context : Node_Id := Empty; @@ -2489,10 +2527,6 @@ package body Sem_Ch3 is Body_Seen : Boolean := False; -- Flag set when the first body [stub] is encountered - Ignore_Freezing : Boolean; - -- Flag set when deciding to freeze an expression function in the - -- current scope. - -- Start of processing for Analyze_Declarations begin @@ -2631,89 +2665,57 @@ package body Sem_Ch3 is -- care to attach the bodies at a proper place in the tree so as to -- not cause unwanted freezing at that point. - elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) then - - -- Check for an edge case that may cause premature freezing of - -- a private type. If there is a type which depends on another - -- private type from an enclosing package that is in the same - -- scope as a non-completing expression function then we cannot - -- freeze here. + -- It is also necessary to check for a case where both an expression + -- function is used and the current scope depends on an unseen + -- private type from a library unit, otherwise premature freezing of + -- the private type will occur. - Ignore_Freezing := False; - - if Nkind (Next_Decl) = N_Subprogram_Body - and then Was_Expression_Function (Next_Decl) - and then not Is_Compilation_Unit (Current_Scope) - and then not Is_Generic_Instance (Current_Scope) - and then not In_Package_Body - (Enclosing_Lib_Unit_Entity (Current_Scope)) + elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) + and then ((Nkind (Next_Decl) /= N_Subprogram_Body + or else not Was_Expression_Function (Next_Decl)) + or else not Uses_Unseen_Lib_Unit_Priv (Current_Scope)) + then + -- When a controlled type is frozen, the expander generates stream + -- and controlled-type support routines. If the freeze is caused + -- by the stand-alone body of Initialize, Adjust, or Finalize, the + -- expander will end up using the wrong version of these routines, + -- as the body has not been processed yet. To remedy this, detect + -- a late controlled primitive and create a proper spec for it. + -- This ensures that the primitive will override its inherited + -- counterpart before the freeze takes place. + + -- If the declaration we just processed is a body, do not attempt + -- to examine Next_Decl as the late primitive idiom can only apply + -- to the first encountered body. + + -- The spec of the late primitive is not generated in ASIS mode to + -- ensure a consistent list of primitives that indicates the true + -- semantic structure of the program (which is not relevant when + -- generating executable code). + + -- ??? A cleaner approach may be possible and/or this solution + -- could be extended to general-purpose late primitives, TBD. + + if not ASIS_Mode + and then not Body_Seen + and then not Is_Body (Decl) then - -- Loop through all entities in the current scope to identify - -- an instance of the edge case outlined above and ignore - -- freezing if it is detected. - - declare - Curr : Entity_Id := First_Entity (Current_Scope); - begin - loop - if Nkind (Curr) in N_Entity - and then Depends_On_Private (Curr) - then - Ignore_Freezing := True; - exit; - end if; - - exit when Last_Entity (Current_Scope) = Curr; - Curr := Next_Entity (Curr); - end loop; - end; - end if; - - if not Ignore_Freezing then - - -- When a controlled type is frozen, the expander generates - -- stream and controlled-type support routines. If the freeze - -- is caused by the stand-alone body of Initialize, Adjust, or - -- Finalize, the expander will end up using the wrong version - -- of these routines, as the body has not been processed yet. - -- To remedy this, detect a late controlled primitive and - -- create a proper spec for it. This ensures that the primitive - -- will override its inherited counterpart before the freeze - -- takes place. - - -- If the declaration we just processed is a body, do not - -- attempt to examine Next_Decl as the late primitive idiom can - -- only apply to the first encountered body. - - -- The spec of the late primitive is not generated in ASIS mode - -- to ensure a consistent list of primitives that indicates the - -- true semantic structure of the program (which is not - -- relevant when generating executable code). - - -- ??? A cleaner approach may be possible and/or this solution - -- could be extended to general-purpose late primitives, TBD. - - if not ASIS_Mode - and then not Body_Seen - and then not Is_Body (Decl) - then - Body_Seen := True; + Body_Seen := True; - if Nkind (Next_Decl) = N_Subprogram_Body then - Handle_Late_Controlled_Primitive (Next_Decl); - end if; + if Nkind (Next_Decl) = N_Subprogram_Body then + Handle_Late_Controlled_Primitive (Next_Decl); end if; + end if; - Adjust_Decl; + Adjust_Decl; - -- The generated body of an expression function does not - -- freeze, unless it is a completion, in which case only the - -- expression itself freezes. This is handled when the body - -- itself is analyzed (see Freeze_Expr_Types, sem_ch6.adb). + -- The generated body of an expression function does not freeze, + -- unless it is a completion, in which case only the expression + -- itself freezes. This is handled when the body itself is + -- analyzed (see Freeze_Expr_Types, sem_ch6.adb). - Freeze_All (Freeze_From, Decl); - Freeze_From := Last_Entity (Current_Scope); - end if; + Freeze_All (Freeze_From, Decl); + Freeze_From := Last_Entity (Current_Scope); end if; Decl := Next_Decl; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 1cdb7a03288..ddb70384394 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4295,6 +4295,7 @@ package body Sem_Ch4 is Comp : Entity_Id; Has_Candidate : Boolean := False; In_Scope : Boolean; + Is_Private_Op : Boolean; Parent_N : Node_Id; Pent : Entity_Id := Empty; Prefix_Type : Entity_Id; @@ -4825,7 +4826,7 @@ package body Sem_Ch4 is -- Find visible operation with given name. For a protected type, -- the possible candidates are discriminants, entries or protected - -- procedures. For a task type, the set can only include entries or + -- subprograms. For a task type, the set can only include entries or -- discriminants if the task type is not an enclosing scope. If it -- is an enclosing scope (e.g. in an inner task) then all entities -- are visible, but the prefix must denote the enclosing scope, i.e. @@ -4833,6 +4834,7 @@ package body Sem_Ch4 is Set_Etype (Sel, Any_Type); In_Scope := In_Open_Scopes (Prefix_Type); + Is_Private_Op := False; while Present (Comp) loop @@ -4845,6 +4847,9 @@ package body Sem_Ch4 is or else Comp /= First_Private_Entity (Type_To_Use)) then Add_One_Interp (Sel, Comp, Etype (Comp)); + if Comp = First_Private_Entity (Type_To_Use) then + Is_Private_Op := True; + end if; -- If the prefix is tagged, the correct interpretation may -- lie in the primitive or class-wide operations of the @@ -4924,6 +4929,12 @@ package body Sem_Ch4 is then null; + elsif Is_Protected_Type (Prefix_Type) + and then Is_Overloadable (Entity (Sel)) + and then not Is_Private_Op + then + null; + else Error_Msg_NE ("invalid reference to internal operation of some object of " diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index fd630afaec7..33282a0a698 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -3857,8 +3857,7 @@ package body Sem_Ch5 is Set_Etype (R_Copy, It.Typ); else - Error_Msg_N - ("ambiguous domain of iteration", R_Copy); + Error_Msg_N ("ambiguous domain of iteration", R_Copy); end if; end if; end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index b8eb6ad4267..41f1e530f95 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -734,21 +734,6 @@ package body Sem_Ch6 is Subtype_Ind : constant Node_Id := Object_Definition (Original_Node (Obj_Decl)); - R_Type_Is_Anon_Access : constant Boolean := - Ekind_In (R_Type, - E_Anonymous_Access_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type, - E_Anonymous_Access_Type); - -- True if return type of the function is an anonymous access type - -- Can't we make Is_Anonymous_Access_Type in einfo ??? - - R_Stm_Type_Is_Anon_Access : constant Boolean := - Ekind_In (R_Stm_Type, - E_Anonymous_Access_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type, - E_Anonymous_Access_Type); - -- True if type of the return object is an anonymous access type - procedure Error_No_Match (N : Node_Id); -- Output error messages for case where types do not statically -- match. N is the location for the messages. @@ -783,10 +768,9 @@ package body Sem_Ch6 is -- "access T", and that the subtypes statically match: -- if this is an access to subprogram the signatures must match. - if R_Type_Is_Anon_Access then - if R_Stm_Type_Is_Anon_Access then - if - Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type + if Is_Anonymous_Access_Type (R_Type) then + if Is_Anonymous_Access_Type (R_Stm_Type) then + if Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type then if Base_Type (Designated_Type (R_Stm_Type)) /= Base_Type (Designated_Type (R_Type)) @@ -796,11 +780,11 @@ package body Sem_Ch6 is end if; else - -- For two anonymous access to subprogram types, the - -- types themselves must be type conformant. + -- For two anonymous access to subprogram types, the types + -- themselves must be type conformant. if not Conforming_Types - (R_Stm_Type, R_Type, Fully_Conformant) + (R_Stm_Type, R_Type, Fully_Conformant) then Error_No_Match (Subtype_Ind); end if; @@ -813,10 +797,11 @@ package body Sem_Ch6 is -- If the return object is of an anonymous access type, then report -- an error if the function's result type is not also anonymous. - elsif R_Stm_Type_Is_Anon_Access then - pragma Assert (not R_Type_Is_Anon_Access); - Error_Msg_N ("anonymous access not allowed for function with " - & "named access result", Subtype_Ind); + elsif Is_Anonymous_Access_Type (R_Stm_Type) then + pragma Assert (not Is_Anonymous_Access_Type (R_Type)); + Error_Msg_N + ("anonymous access not allowed for function with named access " + & "result", Subtype_Ind); -- Subtype indication case: check that the return object's type is -- covered by the result type, and that the subtypes statically match @@ -838,18 +823,16 @@ package body Sem_Ch6 is if Is_Access_Type (R_Type) and then - (Can_Never_Be_Null (R_Type) - or else Null_Exclusion_Present (Parent (Scope_Id))) /= - Can_Never_Be_Null (R_Stm_Type) + (Can_Never_Be_Null (R_Type) + or else Null_Exclusion_Present (Parent (Scope_Id))) /= + Can_Never_Be_Null (R_Stm_Type) then Error_No_Match (Subtype_Ind); end if; -- AI05-103: for elementary types, subtypes must statically match - if Is_Constrained (R_Type) - or else Is_Access_Type (R_Type) - then + if Is_Constrained (R_Type) or else Is_Access_Type (R_Type) then if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then Error_No_Match (Subtype_Ind); end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 2638b37d5cc..0029c6a80a8 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -13815,9 +13815,10 @@ package body Sem_Prag is if Nkind (Stmt) = N_Pragma then if Pragma_Name (Stmt) = Pname then - Error_Msg_Name_1 := Pname; - Error_Msg_Sloc := Sloc (Stmt); - Error_Msg_N ("pragma % duplicates pragma declared#", N); + Duplication_Error + (Prag => N, + Prev => Stmt); + raise Pragma_Exit; end if; -- Skip internally generated code. Note that derived type @@ -15321,9 +15322,10 @@ package body Sem_Prag is if Nkind (Stmt) = N_Pragma then if Pragma_Name (Stmt) = Pname then - Error_Msg_Name_1 := Pname; - Error_Msg_Sloc := Sloc (Stmt); - Error_Msg_N ("pragma % duplicates pragma declared#", N); + Duplication_Error + (Prag => N, + Prev => Stmt); + raise Pragma_Exit; end if; -- Task unit declared without a definition cannot be subject to @@ -17828,6 +17830,134 @@ package body Sem_Prag is Opt.No_Elab_Code_All_Pragma := N; end if; + -------------------------- + -- No_Heap_Finalization -- + -------------------------- + + -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ]; + + when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare + Context : constant Node_Id := Parent (N); + Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1); + Prev : Node_Id; + Typ : Entity_Id; + + begin + GNAT_Pragma; + Check_No_Identifiers; + + -- The pragma appears in a configuration file + + if No (Context) then + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + + -- Detect a duplicate pragma + + if Present (No_Heap_Finalization_Pragma) then + Duplication_Error + (Prag => N, + Prev => No_Heap_Finalization_Pragma); + raise Pragma_Exit; + end if; + + No_Heap_Finalization_Pragma := N; + + -- Otherwise the pragma should be associated with a library-level + -- named access-to-object type. + + else + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + + Find_Type (Typ_Arg); + Typ := Entity (Typ_Arg); + + -- The type being subjected to the pragma is erroneous + + if Typ = Any_Type then + Error_Pragma ("cannot find type referenced by pragma %"); + + -- The pragma is applied to an incomplete or generic formal + -- type way too early. + + elsif Rep_Item_Too_Early (Typ, N) then + return; + + else + Typ := Underlying_Type (Typ); + end if; + + -- The pragma must apply to an access-to-object type + + if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then + null; + + -- Give a detailed error message on all other access type kinds + + elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then + Error_Pragma + ("pragma % cannot apply to access protected subprogram " + & "type"); + + elsif Ekind (Typ) = E_Access_Subprogram_Type then + Error_Pragma + ("pragma % cannot apply to access subprogram type"); + + elsif Is_Anonymous_Access_Type (Typ) then + Error_Pragma + ("pragma % cannot apply to anonymous access type"); + + -- Give a general error message in case the pragma applies to a + -- non-access type. + + else + Error_Pragma + ("pragma % must apply to library level access type"); + end if; + + -- At this point the argument denotes an access-to-object type. + -- Ensure that the type is declared at the library level. + + if Is_Library_Level_Entity (Typ) then + null; + + -- Qietly ignore an access-to-object type originally declared + -- at the library level within a generic, but instantiated at + -- a non-library level. As a result the access-to-object type + -- "loses" its No_Heap_Finalization property. + + elsif In_Instance then + raise Pragma_Exit; + + else + Error_Pragma + ("pragma % must apply to library level access type"); + end if; + + -- Detect a duplicate pragma + + if Present (No_Heap_Finalization_Pragma) then + Duplication_Error + (Prag => N, + Prev => No_Heap_Finalization_Pragma); + raise Pragma_Exit; + + else + Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization); + + if Present (Prev) then + Duplication_Error + (Prag => N, + Prev => Prev); + raise Pragma_Exit; + end if; + end if; + + Record_Rep_Item (Typ, N); + end if; + end No_Heap_Finalization; + --------------- -- No_Inline -- --------------- @@ -21402,8 +21532,9 @@ package body Sem_Prag is Check_Valid_Configuration_Pragma; if Present (SPARK_Mode_Pragma) then - Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma); - Error_Msg_N ("pragma% duplicates pragma declared#", N); + Duplication_Error + (Prag => N, + Prev => SPARK_Mode_Pragma); raise Pragma_Exit; end if; @@ -21433,9 +21564,9 @@ package body Sem_Prag is if Nkind (Stmt) = N_Pragma then if Pragma_Name (Stmt) = Pname then - Error_Msg_Name_1 := Pname; - Error_Msg_Sloc := Sloc (Stmt); - Error_Msg_N ("pragma% duplicates pragma declared#", N); + Duplication_Error + (Prag => N, + Prev => Stmt); raise Pragma_Exit; end if; @@ -28867,6 +28998,7 @@ package body Sem_Prag is Pragma_No_Return => 0, Pragma_No_Body => 0, Pragma_No_Elaboration_Code_All => 0, + Pragma_No_Heap_Finalization => 0, Pragma_No_Inline => 0, Pragma_No_Run_Time => -1, Pragma_No_Strict_Aliasing => -1, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 144fd7d92fc..8b78008c573 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12846,6 +12846,7 @@ package body Sem_Util is S : constant Ureal := Small_Value (T); M : Urealp.Save_Mark; R : Boolean; + begin M := Urealp.Mark; R := (U = UR_Trunc (U / S) * S); @@ -17491,6 +17492,32 @@ package body Sem_Util is end if; end New_Requires_Transient_Scope; + -------------------------- + -- No_Heap_Finalization -- + -------------------------- + + function No_Heap_Finalization (Typ : Entity_Id) return Boolean is + begin + if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) + and then Is_Library_Level_Entity (Typ) + then + -- A global No_Heap_Finalization pragma applies to all library-level + -- named access-to-object types. + + if Present (No_Heap_Finalization_Pragma) then + return True; + + -- The library-level named access-to-object type itself is subject to + -- pragma No_Heap_Finalization. + + elsif Present (Get_Pragma (Typ, Pragma_No_Heap_Finalization)) then + return True; + end if; + end if; + + return False; + end No_Heap_Finalization; + ----------------------- -- Normalize_Actuals -- ----------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 06be2f87fd2..7c0affc9ba8 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1983,6 +1983,9 @@ package Sem_Util is -- Note that the result produced is always an expression, not a parameter -- association node, even if named notation was used. + function No_Heap_Finalization (Typ : Entity_Id) return Boolean; + -- Determine whether type Typ is subject to pragma No_Heap_Finalization + procedure Normalize_Actuals (N : Node_Id; S : Entity_Id; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 5941beb3317..33ba6a57c41 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -433,6 +433,7 @@ package Snames is Name_License : constant Name_Id := N + $; -- GNAT Name_Locking_Policy : constant Name_Id := N + $; Name_Loop_Optimize : constant Name_Id := N + $; -- GNAT + Name_No_Heap_Finalization : constant Name_Id := N + $; -- GNAT Name_No_Run_Time : constant Name_Id := N + $; -- GNAT Name_No_Strict_Aliasing : constant Name_Id := N + $; -- GNAT Name_No_Tagged_Streams : constant Name_Id := N + $; -- GNAT @@ -1797,6 +1798,7 @@ package Snames is Pragma_License, Pragma_Locking_Policy, Pragma_Loop_Optimize, + Pragma_No_Heap_Finalization, Pragma_No_Run_Time, Pragma_No_Strict_Aliasing, Pragma_No_Tagged_Streams, -- 2.30.2