Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 247152) +++ exp_ch7.adb (working copy) @@ -486,34 +486,41 @@ 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. Index: exp_util.adb =================================================================== --- exp_util.adb (revision 247154) +++ exp_util.adb (working copy) @@ -481,12 +481,6 @@ (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 @@ 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,8 +670,16 @@ 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 @@ -- 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 @@ -- 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 @@ -- 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 @@ 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 @@ 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 @@ 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 @@ -- 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 Index: einfo.adb =================================================================== --- einfo.adb (revision 247147) +++ einfo.adb (working copy) @@ -3533,6 +3533,11 @@ 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; Index: einfo.ads =================================================================== --- einfo.ads (revision 247147) +++ einfo.ads (working copy) @@ -4845,12 +4845,6 @@ -- 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 @@ -- 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 @@ -- 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 @@ -- 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 @@ -- E_General_Access_Type -- E_Access_Subprogram_Type -- E_Access_Protected_Subprogram_Type + -- E_Anonymous_Access_Protected_Subprogram_Type -- E_Anonymous_Access_Subprogram_Type - -- E_Anonymous_Access_Protected_Subprogram_Type E_Anonymous_Access_Type; subtype Enumeration_Kind is Entity_Kind range @@ -5388,8 +5393,8 @@ -- E_General_Access_Type -- E_Access_Subprogram_Type, -- E_Access_Protected_Subprogram_Type + -- E_Anonymous_Access_Protected_Subprogram_Type -- E_Anonymous_Access_Subprogram_Type - -- E_Anonymous_Access_Protected_Subprogram_Type -- E_Anonymous_Access_Type -- E_Array_Type -- E_Array_Subtype @@ -7359,6 +7364,7 @@ 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; Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 247152) +++ sem_prag.adb (working copy) @@ -13815,9 +13815,10 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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, Index: sem_util.adb =================================================================== --- sem_util.adb (revision 247153) +++ sem_util.adb (working copy) @@ -12846,6 +12846,7 @@ 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 @@ 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 -- ----------------------- Index: sem_util.ads =================================================================== --- sem_util.ads (revision 247151) +++ sem_util.ads (working copy) @@ -1983,6 +1983,9 @@ -- 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; Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 247151) +++ sem_ch6.adb (working copy) @@ -734,21 +734,6 @@ 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 @@ -- "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 @@ 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 @@ -- 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 @@ 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; Index: par-prag.adb =================================================================== --- par-prag.adb (revision 247151) +++ par-prag.adb (working copy) @@ -1410,6 +1410,7 @@ | 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 Index: opt.ads =================================================================== --- opt.ads (revision 247135) +++ opt.ads (working copy) @@ -1115,6 +1115,11 @@ -- 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 Index: snames.ads-tmpl =================================================================== --- snames.ads-tmpl (revision 247135) +++ snames.ads-tmpl (working copy) @@ -433,6 +433,7 @@ 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 @@ Pragma_License, Pragma_Locking_Policy, Pragma_Loop_Optimize, + Pragma_No_Heap_Finalization, Pragma_No_Run_Time, Pragma_No_Strict_Aliasing, Pragma_No_Tagged_Streams,