===================================================================
@@ -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.
===================================================================
@@ -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
===================================================================
@@ -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;
===================================================================
@@ -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;
===================================================================
@@ -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,
===================================================================
@@ -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 --
-----------------------
===================================================================
@@ -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;
===================================================================
@@ -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;
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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,