Aspect_Exceptional_Cases, -- GNAT
Aspect_External_Name,
Aspect_External_Tag,
+ Aspect_Finalizable, -- GNAT
Aspect_Ghost_Predicate, -- GNAT
Aspect_Global, -- GNAT
Aspect_GNAT_Annotate, -- GNAT
Aspect_Exceptional_Cases => True,
Aspect_Extensions_Visible => True,
Aspect_Favor_Top_Level => True,
+ Aspect_Finalizable => True,
Aspect_Ghost => True,
Aspect_Ghost_Predicate => True,
Aspect_Global => True,
Aspect_Subprogram_Variant => True,
Aspect_Suppress_Debug_Info => True,
Aspect_Suppress_Initialization => True,
- Aspect_Thread_Local_Storage => True,
Aspect_Test_Case => True,
+ Aspect_Thread_Local_Storage => True,
Aspect_Unimplemented => True,
Aspect_Universal_Aliasing => True,
Aspect_Unmodified => True,
(Aspect_Aggregate => True,
Aspect_Constant_Indexing => True,
Aspect_Default_Iterator => True,
+ Aspect_Finalizable => True,
Aspect_Iterable => True,
Aspect_Iterator_Element => True,
Aspect_Variable_Indexing => True,
Aspect_Exceptional_Cases => Expression,
Aspect_External_Name => Expression,
Aspect_External_Tag => Expression,
+ Aspect_Finalizable => Expression,
Aspect_Ghost_Predicate => Expression,
Aspect_Global => Expression,
Aspect_GNAT_Annotate => Expression,
Aspect_Exclusive_Functions => False,
Aspect_External_Name => False,
Aspect_External_Tag => False,
+ Aspect_Finalizable => False,
Aspect_Ghost_Predicate => False,
Aspect_Global => False,
Aspect_GNAT_Annotate => False,
Aspect_External_Name => Name_External_Name,
Aspect_External_Tag => Name_External_Tag,
Aspect_Favor_Top_Level => Name_Favor_Top_Level,
+ Aspect_Finalizable => Name_Finalizable,
Aspect_Full_Access_Only => Name_Full_Access_Only,
Aspect_Ghost => Name_Ghost,
Aspect_Ghost_Predicate => Name_Ghost_Predicate,
Aspect_External_Name => Always_Delay,
Aspect_External_Tag => Always_Delay,
Aspect_Favor_Top_Level => Always_Delay,
+ Aspect_Finalizable => Always_Delay,
Aspect_Ghost_Predicate => Always_Delay,
Aspect_Implicit_Dereference => Always_Delay,
Aspect_Independent => Always_Delay,
with Sem_Ch8; use Sem_Ch8;
with Sem_Cat; use Sem_Cat;
with Sem_Disp; use Sem_Disp;
+with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
-- need to be called while elaboration is taking place.
elsif Is_Controlled (Tag_Typ)
- and then
- Chars (Subp_Id) in Name_Adjust | Name_Finalize | Name_Initialize
+ and then (Is_Controlled_Procedure (Subp_Id, Name_Adjust)
+ or else Is_Controlled_Procedure (Subp_Id, Name_Finalize)
+ or else Is_Controlled_Procedure (Subp_Id, Name_Initialize))
then
return;
end if;
Link to the original RFC:
https://github.com/AdaCore/ada-spark-rfcs/blob/topic/rfc-finally/considered/rfc-class-size.md
+
+Generalized Finalization
+------------------------
+
+The `Finalizable` aspect can be applied to any record type, tagged or not,
+to specify that it provides the same level of control on the operations of initialization, finalization, and assignment of objects as the controlled
+types (see RM 7.6(2) for a high-level overview). The only restriction is
+that the record type must be a root type, in other words not a derived type.
+
+The aspect additionally makes it possible to specify relaxed semantics for
+the finalization operations by means of the `Relaxed_Finalization` setting.
+
+Example:
+
+.. code-block:: ada
+
+ type Ctrl is record
+ Id : Natural := 0;
+ end record
+ with Finalizable => (Initialize => Initialize,
+ Adjust => Adjust,
+ Finalize => Finalize,
+ Relaxed_Finalization => True);
+
+ procedure Adjust (Obj : in out Ctrl);
+ procedure Finalize (Obj : in out Ctrl);
+ procedure Initialize (Obj : in out Ctrl);
+
+As of this writing, the relaxed semantics for finalization operations are
+only implemented for dynamically allocated objects.
+
+Link to the original RFC:
+https://github.com/AdaCore/ada-spark-rfcs/blob/topic/finalization-rehaul/considered/rfc-generalized-finalization.md
-- is detected while analyzing the body. Used to activate some error
-- checks for infinite recursion.
+-- Has_Relaxed_Finalization [base type only]
+-- Defined in all type entities. Indicates that the type is subject to
+-- relaxed semantics for the finalization operations.
+
-- Has_Shift_Operator [base type only]
-- Defined in integer types. Set in the base type of an integer type for
-- which at least one of the shift operators is defined.
-- Is_Controlled_Active [base type only]
-- Defined in all type entities. Indicates that the type is controlled,
--- i.e. is either a descendant of Ada.Finalization.Controlled or of
--- Ada.Finalization.Limited_Controlled.
+-- i.e. has been declared with the Finalizable aspect or has inherited
+-- the Finalizable aspect from an ancestor. Can only be set for record
+-- types, tagged or untagged. System.Finalization_Root.Root_Controlled
+-- is an example of the former case while Ada.Finalization.Controlled
+-- and Ada.Finalization.Limited_Controlled are examples of the latter.
-- Is_Controlled (synth) [base type only]
-- Defined in all type entities. Set if Is_Controlled_Active is set for
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
- (Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
+ (Find_Controlled_Prim_Op (Init_Typ, Name_Initialize), Loc),
Parameter_Associations => New_List (New_Copy_Tree (Ref))));
end if;
end Generate_Finalization_Actions;
Rewrite (N, New_Occurrence_Of (Size, Loc));
- -- The prefix is known to be controlled at compile time. Calculate
- -- Finalization_Size by calling function Header_Size_With_Padding.
+ -- The prefix is known to be controlled at compile time and to
+ -- require strict finalization. Calculate Finalization_Size by
+ -- calling function Header_Size_With_Padding.
- elsif Needs_Finalization (Ptyp) then
+ elsif Needs_Finalization (Ptyp)
+ and then not Has_Relaxed_Finalization (Ptyp)
+ then
Rewrite (N, Calculate_Header_Size);
-- The prefix is not an object with controlled parts, so its
or else Has_Discriminants (T)
or else Is_Limited_Type (T)
or else Has_Non_Standard_Rep (T)
+ or else Needs_Finalization (T)
then
Initialization_Warning (T);
return Empty;
-- Make sure that the primitives Initialize, Adjust and Finalize
-- are Frozen before other TSS subprograms. We don't want them
- -- Frozen inside.
+ -- frozen inside.
if Is_Controlled (Typ) then
+ Append_Freeze_Actions (Typ,
+ Freeze_Entity
+ (Find_Controlled_Prim_Op (Typ, Name_Initialize), Typ));
+
if not Is_Limited_Type (Typ) then
Append_Freeze_Actions (Typ,
- Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ));
+ Freeze_Entity
+ (Find_Controlled_Prim_Op (Typ, Name_Adjust), Typ));
end if;
Append_Freeze_Actions (Typ,
- Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ));
-
- Append_Freeze_Actions (Typ,
- Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ));
+ Freeze_Entity
+ (Find_Controlled_Prim_Op (Typ, Name_Finalize), Typ));
end if;
-- Freeze rest of primitive operations. There is no need to handle
Build_Record_Init_Proc (Typ_Decl, Typ);
end if;
+ -- Create the body of TSS primitive Finalize_Address. This must be done
+ -- before the bodies of all predefined primitives are created. If Typ
+ -- is limited, Stream_Input and Stream_Read may produce build-in-place
+ -- allocations and for those the expander needs Finalize_Address.
+
+ if Is_Controlled (Typ) then
+ Make_Finalize_Address_Body (Typ);
+ end if;
+
-- For tagged type that are not interfaces, build bodies of primitive
-- operations. Note: do this after building the record initialization
-- procedure, since the primitive operations may need the initialization
then
null;
- else
- -- Create the body of TSS primitive Finalize_Address. This must
- -- be done before the bodies of all predefined primitives are
- -- created. If Typ is limited, Stream_Input and Stream_Read may
- -- produce build-in-place allocations and for those the expander
- -- needs Finalize_Address.
+ -- Do not add the body of the predefined primitives if we are
+ -- compiling under restriction No_Dispatching_Calls.
- Make_Finalize_Address_Body (Typ);
+ elsif not Restriction_Active (No_Dispatching_Calls) then
+ -- Create the body of the class-wide type's TSS primitive
+ -- Finalize_Address. This must be done before any class-wide
+ -- precondition functions are created.
- -- Do not add the body of the predefined primitives if we are
- -- compiling under restriction No_Dispatching_Calls.
+ Make_Finalize_Address_Body (Class_Wide_Type (Typ));
- if not Restriction_Active (No_Dispatching_Calls) then
- -- Create the body of the class-wide type's TSS primitive
- -- Finalize_Address. This must be done before any class-wide
- -- precondition functions are created.
-
- Make_Finalize_Address_Body (Class_Wide_Type (Typ));
-
- Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq);
- Append_Freeze_Actions (Typ, Predef_List);
- end if;
+ Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq);
+ Append_Freeze_Actions (Typ, Predef_List);
end if;
-- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
-- The address manipulation is not performed for access types that are
-- subject to pragma No_Heap_Finalization because the two pointers do
- -- not exist in the first place.
+ -- not exist in the first place. Likewise for designated types that are
+ -- subject to relaxed finalization.
if No_Heap_Finalization (Ptr_Typ) then
null;
- elsif Needs_Finalization (Desig_Typ) then
-
+ elsif Needs_Finalization (Desig_Typ)
+ and then not Has_Relaxed_Finalization (Desig_Typ)
+ then
-- Adjust the address and size of the dereferenced object. Generate:
-- Adjust_Controlled_Dereference (Addr, Size, Alig);
-- such build-in-place functions, primitive or not.
return not Restriction_Active (No_Finalization)
- and then (Needs_Finalization (Typ) or else Is_Tagged_Type (Typ))
+ and then ((Needs_Finalization (Typ)
+ and then not Has_Relaxed_Finalization (Typ))
+ or else Is_Tagged_Type (Typ))
and then not Has_Foreign_Convention (Typ);
end Needs_BIP_Collection;
then
return False;
+ -- Do not consider controlled types with relaxed finalization
+
+ elsif Has_Relaxed_Finalization (Desig_Typ) then
+ return False;
+
-- Do not consider an access type that returns on the secondary stack
elsif Present (Associated_Storage_Pool (Ptr_Typ))
-- is from a private type that is not visibly controlled.
Parent_Type := Etype (Typ);
- Op := Find_Optional_Prim_Op (Parent_Type, Name_Of (Prim));
+ Op := Find_Controlled_Prim_Op (Parent_Type, Name_Of (Prim));
if Present (Op) then
E := Op;
-- Derivations from [Limited_]Controlled
elsif Is_Controlled (Utyp) then
- Adj_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Adjust_Case));
+ Adj_Id := Find_Controlled_Prim_Op (Utyp, Name_Adjust);
-- Tagged types
Typ : Entity_Id;
Is_Local : Boolean := False) return List_Id
is
+ Loc : constant Source_Ptr := Sloc (Typ);
+
function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
-- Build the statements necessary to adjust a record type. The type may
-- have discriminants and contain variant parts. Generate:
-----------------------------
function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (Typ);
Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
Finalizer_Data : Finalization_Exception_Data;
Proc : Entity_Id;
begin
- Proc := Find_Optional_Prim_Op (Typ, Name_Adjust);
+ Proc := Find_Controlled_Prim_Op (Typ, Name_Adjust);
-- Generate:
-- if F then
-------------------------------
function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (Typ);
- Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
+ Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
Counter : Nat := 0;
Finalizer_Data : Finalization_Exception_Data;
Proc : Entity_Id;
begin
- Proc := Find_Optional_Prim_Op (Typ, Name_Finalize);
+ Proc := Find_Controlled_Prim_Op (Typ, Name_Finalize);
-- Generate:
-- if F then
return Build_Finalize_Statements (Typ);
when Initialize_Case =>
- declare
- Loc : constant Source_Ptr := Sloc (Typ);
-
- begin
- if Is_Controlled (Typ) then
- return New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
- Parameter_Associations => New_List (
- Make_Identifier (Loc, Name_V))));
- else
- return Empty_List;
- end if;
- end;
+ if Is_Controlled (Typ) then
+ return New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Find_Controlled_Prim_Op (Typ, Name_Initialize), Loc),
+ Parameter_Associations => New_List (
+ Make_Identifier (Loc, Name_V))));
+ else
+ return Empty_List;
+ end if;
end case;
end Make_Deep_Record_Body;
-- Derivations from [Limited_]Controlled
elsif Is_Controlled (Utyp) then
- Fin_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Finalize_Case));
+ Fin_Id := Find_Controlled_Prim_Op (Utyp, Name_Finalize);
-- Tagged types
if Is_Task then
null;
- -- Nothing to do if the type is not controlled or it already has a
- -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
- -- come from source. These are usually generated for completeness and
- -- do not need the Finalize_Address primitive.
+ -- Nothing to do if the type does not need finalization or already has
+ -- a TSS entry for Finalize_Address. Skip class-wide subtypes that do
+ -- not come from source, as they are usually generated for completeness
+ -- and need no Finalize_Address.
elsif not Needs_Finalization (Typ)
or else Present (TSS (Typ, TSS_Finalize_Address))
-- Select the appropriate version of initialize
if Has_Controlled_Component (Utyp) then
- Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
+ Proc := TSS (Utyp, TSS_Deep_Initialize);
elsif Is_Mutably_Tagged_Type (Utyp) then
- Proc := Find_Prim_Op (Etype (Utyp), Name_Of (Initialize_Case));
+ Proc := Find_Controlled_Prim_Op (Etype (Utyp), Name_Initialize);
Check_Visibly_Controlled (Initialize_Case, Etype (Typ), Proc, Ref);
else
- Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
+ Proc := Find_Controlled_Prim_Op (Utyp, Name_Initialize);
Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
end if;
First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
The_Tag : constant Entity_Id := First_Tag_Component (Typ);
- Adjusted : Boolean := False;
- Finalized : Boolean := False;
-
Count_Prim : Nat;
DT_Length : Nat;
Nb_Prim : Nat;
Validate_Position (Prim);
end if;
- if Chars (Prim) = Name_Finalize then
- Finalized := True;
- end if;
-
- if Chars (Prim) = Name_Adjust then
- Adjusted := True;
- end if;
-
-- An abstract operation cannot be declared in the private part for a
-- visible abstract type, because it can't be overridden outside this
-- package hierarchy. For explicit declarations this is checked at
Next_Elmt (Prim_Elmt);
end loop;
- -- Additional check
-
- if Is_Controlled (Typ) then
- if not Finalized then
- Error_Msg_N
- ("controlled type has no explicit Finalize method??", Typ);
-
- elsif not Adjusted then
- Error_Msg_N
- ("controlled type has no explicit Adjust method??", Typ);
- end if;
- end if;
-
-- Set the final size of the Dispatch Table
Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo.Utils; use Sinfo.Utils;
-with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
Needs_Fin :=
Needs_Finalization (Desig_Typ)
+ and then not Has_Relaxed_Finalization (Desig_Typ)
and then not No_Heap_Finalization (Ptr_Typ);
-- The allocation/deallocation of a controlled object must be associated
return TSS (Utyp, TSS_Finalize_Address);
end Finalize_Address;
+ -----------------------------
+ -- Find_Controlled_Prim_Op --
+ -----------------------------
+
+ function Find_Controlled_Prim_Op
+ (T : Entity_Id; Name : Name_Id) return Entity_Id
+ is
+ Op_Name : constant Name_Id := Name_Of_Controlled_Prim_Op (T, Name);
+
+ begin
+ if Op_Name = No_Name then
+ return Empty;
+ end if;
+
+ return Find_Optional_Prim_Op (T, Op_Name);
+ end Find_Controlled_Prim_Op;
+
------------------------
-- Find_Interface_ADT --
------------------------
-- Primitive Initialize
if Is_Controlled (Typ) then
- Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize);
+ Prim_Init := Find_Controlled_Prim_Op (Typ, Name_Initialize);
if Present (Prim_Init) then
Prim_Init := Ultimate_Alias (Prim_Init);
return True;
end May_Generate_Large_Temp;
+ --------------------------------
+ -- Name_Of_Controlled_Prim_Op --
+ --------------------------------
+
+ function Name_Of_Controlled_Prim_Op
+ (Typ : Entity_Id;
+ Nam : Name_Id) return Name_Id
+ is
+ begin
+ pragma Assert (Is_Controlled (Typ));
+
+ -- The aspect Finalizable may change the name of the primitives when
+ -- present, but it's a GNAT extension.
+
+ if All_Extensions_Allowed then
+ declare
+ Rep : constant Node_Id
+ := Get_Rep_Item (Typ, Name_Finalizable, Check_Parents => True);
+
+ Assoc : Node_Id;
+
+ begin
+ if Present (Rep) then
+ Assoc := First (Component_Associations (Expression (Rep)));
+ while Present (Assoc) loop
+ if Chars (First (Choices (Assoc))) = Nam then
+ return Chars (Expression (Assoc));
+ end if;
+
+ Next (Assoc);
+ end loop;
+
+ return No_Name;
+ end if;
+ end;
+ end if;
+
+ return Nam;
+ end Name_Of_Controlled_Prim_Op;
+
--------------------------------------------
-- Needs_Conditional_Null_Excluding_Check --
--------------------------------------------
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
+with Snames; use Snames;
with Types; use Types;
with Uintp; use Uintp;
function Find_Last_Init (Decl : Node_Id) return Node_Id;
-- Find the last initialization call related to object declaration Decl
- function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id;
+ function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id
+ with Pre => Name not in Name_Adjust | Name_Finalize | Name_Initialize;
-- Find the first primitive operation of type T with the specified Name,
-- disregarding any visibility considerations. If T is a class-wide type,
-- then examine the primitive operations of its corresponding root type.
- -- Raise Program_Error if no primitive operation with the specified Name
- -- is found.
+ -- This function should not be called for the three controlled primitive
+ -- operations, and, instead, Find_Controlled_Prim_Op must be called for
+ -- those. Raise Program_Error if no primitive operation with the given
+ -- Name is found.
function Find_Prim_Op
(T : Entity_Id;
-- the form indicated by Name (i.e. is a type support subprogram with the
-- indicated suffix).
+ function Find_Controlled_Prim_Op
+ (T : Entity_Id; Name : Name_Id) return Entity_Id
+ with Pre => Name in Name_Adjust | Name_Finalize | Name_Initialize;
+ -- Same as Find_Prim_Op but for the three controlled primitive operations,
+ -- and returns Empty if not found.
+
function Find_Optional_Prim_Op
(T : Entity_Id; Name : Name_Id) return Entity_Id;
function Find_Optional_Prim_Op
-- caller has to check whether stack checking is actually enabled in order
-- to guide the expansion (typically of a function call).
+ function Name_Of_Controlled_Prim_Op
+ (Typ : Entity_Id;
+ Nam : Name_Id) return Name_Id
+ with Pre => Nam in Name_Adjust | Name_Finalize | Name_Initialize;
+ -- Return the name of the Adjust, Finalize, or Initialize primitive of
+ -- controlled type Typ, if it exists, and No_Name if it does not.
+
function Needs_Conditional_Null_Excluding_Check
(Typ : Entity_Id) return Boolean;
-- Check if a type meets certain properties that require it to have a
private
pragma Inline (Duplicate_Subexpr);
+ pragma Inline (Find_Controlled_Prim_Op);
+ pragma Inline (Find_Prim_Op);
pragma Inline (Force_Evaluation);
pragma Inline (Get_Mapped_Entity);
pragma Inline (Is_Library_Level_Tagged_Type);
-- clause (used to warn about useless Bit_Order pragmas, and also
-- to detect cases where Implicit_Packing may have an effect).
+ Relaxed_Finalization : Boolean := True;
+ -- Used to compute the Has_Relaxed_Finalization flag
+
Sized_Component_Total_RM_Size : Uint := Uint_0;
-- Accumulates total RM_Size values of all sized components. Used
-- for processing of Implicit_Packing.
Final_Storage_Only :=
Final_Storage_Only
and then Finalize_Storage_Only (Etype (Comp));
+ Relaxed_Finalization :=
+ Relaxed_Finalization
+ and then Has_Relaxed_Finalization (Etype (Comp));
end if;
if Has_Unchecked_Union (Etype (Comp)) then
-- For a type that is not directly controlled but has controlled
-- components, Finalize_Storage_Only is set if all the controlled
- -- components are Finalize_Storage_Only.
+ -- components are Finalize_Storage_Only. The same processing is
+ -- appled to Has_Relaxed_Finalization.
if not Is_Controlled (Rec) and then Has_Controlled_Component (Rec)
then
- Set_Finalize_Storage_Only (Rec, Final_Storage_Only);
+ Set_Finalize_Storage_Only (Rec, Final_Storage_Only);
+ Set_Has_Relaxed_Finalization (Rec, Relaxed_Finalization);
end if;
end if;
Has_RACW,
Has_Record_Rep_Clause,
Has_Recursive_Call,
+ Has_Relaxed_Finalization,
Has_Shift_Operator,
Has_Size_Clause,
Has_Small_Clause,
Sm (Has_Private_Declaration, Flag),
Sm (Has_Protected, Flag, Base_Type_Only),
Sm (Has_Qualified_Name, Flag),
+ Sm (Has_Relaxed_Finalization, Flag, Base_Type_Only),
Sm (Has_Size_Clause, Flag),
Sm (Has_Stream_Size_Clause, Flag),
Sm (Has_Task, Flag, Base_Type_Only),
@copying
@quotation
-GNAT Reference Manual , Jun 14, 2024
+GNAT Reference Manual , Jun 24, 2024
AdaCore
* Simpler accessibility model::
* Case pattern matching::
* Mutably Tagged Types with Size’Class Aspect::
+* Generalized Finalization::
Security Hardening Features
* Simpler accessibility model::
* Case pattern matching::
* Mutably Tagged Types with Size’Class Aspect::
+* Generalized Finalization::
@end menu
Link to the original RFC:
@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-pattern-matching.rst}
-@node Mutably Tagged Types with Size’Class Aspect,,Case pattern matching,Experimental Language Extensions
+@node Mutably Tagged Types with Size’Class Aspect,Generalized Finalization,Case pattern matching,Experimental Language Extensions
@anchor{gnat_rm/gnat_language_extensions mutably-tagged-types-with-size-class-aspect}@anchor{44f}
@subsection Mutably Tagged Types with Size’Class Aspect
Link to the original RFC:
@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/topic/rfc-finally/considered/rfc-class-size.md}
+@node Generalized Finalization,,Mutably Tagged Types with Size’Class Aspect,Experimental Language Extensions
+@anchor{gnat_rm/gnat_language_extensions generalized-finalization}@anchor{450}
+@subsection Generalized Finalization
+
+
+The @cite{Finalizable} aspect can be applied to any record type, tagged or not,
+to specify that it provides the same level of control on the operations of initialization, finalization, and assignment of objects as the controlled
+types (see RM 7.6(2) for a high-level overview). The only restriction is
+that the record type must be a root type, in other words not a derived type.
+
+The aspect additionally makes it possible to specify relaxed semantics for
+the finalization operations by means of the @cite{Relaxed_Finalization} setting.
+
+Example:
+
+@example
+type Ctrl is record
+ Id : Natural := 0;
+end record
+ with Finalizable => (Initialize => Initialize,
+ Adjust => Adjust,
+ Finalize => Finalize,
+ Relaxed_Finalization => True);
+
+procedure Adjust (Obj : in out Ctrl);
+procedure Finalize (Obj : in out Ctrl);
+procedure Initialize (Obj : in out Ctrl);
+@end example
+
+As of this writing, the relaxed semantics for finalization operations are
+only implemented for dynamically allocated objects.
+
+Link to the original RFC:
+@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/topic/finalization-rehaul/considered/rfc-generalized-finalization.md}
+
@node Security Hardening Features,Obsolescent Features,GNAT language extensions,Top
-@anchor{gnat_rm/security_hardening_features doc}@anchor{450}@anchor{gnat_rm/security_hardening_features id1}@anchor{451}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15}
+@anchor{gnat_rm/security_hardening_features doc}@anchor{451}@anchor{gnat_rm/security_hardening_features id1}@anchor{452}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15}
@chapter Security Hardening Features
@end menu
@node Register Scrubbing,Stack Scrubbing,,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{452}
+@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{453}
@section Register Scrubbing
@c Stack Scrubbing:
@node Stack Scrubbing,Hardened Conditionals,Register Scrubbing,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{453}
+@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{454}
@section Stack Scrubbing
@c Hardened Conditionals:
@node Hardened Conditionals,Hardened Booleans,Stack Scrubbing,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{454}
+@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{455}
@section Hardened Conditionals
@c Hardened Booleans:
@node Hardened Booleans,Control Flow Redundancy,Hardened Conditionals,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{455}
+@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{456}
@section Hardened Booleans
@c Control Flow Redundancy:
@node Control Flow Redundancy,,Hardened Booleans,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{456}
+@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{457}
@section Control Flow Redundancy
can be used with other programming languages supported by GCC.
@node Obsolescent Features,Compatibility and Porting Guide,Security Hardening Features,Top
-@anchor{gnat_rm/obsolescent_features doc}@anchor{457}@anchor{gnat_rm/obsolescent_features id1}@anchor{458}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16}
+@anchor{gnat_rm/obsolescent_features doc}@anchor{458}@anchor{gnat_rm/obsolescent_features id1}@anchor{459}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16}
@chapter Obsolescent Features
@end menu
@node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id2}@anchor{459}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{45a}
+@anchor{gnat_rm/obsolescent_features id2}@anchor{45a}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{45b}
@section pragma No_Run_Time
includes just those features that are to be made accessible.
@node pragma Ravenscar,pragma Restricted_Run_Time,pragma No_Run_Time,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id3}@anchor{45b}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{45c}
+@anchor{gnat_rm/obsolescent_features id3}@anchor{45c}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{45d}
@section pragma Ravenscar
is part of the new Ada 2005 standard.
@node pragma Restricted_Run_Time,pragma Task_Info,pragma Ravenscar,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id4}@anchor{45d}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{45e}
+@anchor{gnat_rm/obsolescent_features id4}@anchor{45e}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{45f}
@section pragma Restricted_Run_Time
this kind of implementation dependent addition.
@node pragma Task_Info,package System Task_Info s-tasinf ads,pragma Restricted_Run_Time,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id5}@anchor{45f}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{460}
+@anchor{gnat_rm/obsolescent_features id5}@anchor{460}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{461}
@section pragma Task_Info
library.
@node package System Task_Info s-tasinf ads,,pragma Task_Info,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{461}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{462}
+@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{462}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{463}
@section package System.Task_Info (@code{s-tasinf.ads})
standard replacement for GNAT’s @code{Task_Info} functionality.
@node Compatibility and Porting Guide,GNU Free Documentation License,Obsolescent Features,Top
-@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{463}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{464}
+@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{464}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{465}
@chapter Compatibility and Porting Guide
@end menu
@node Writing Portable Fixed-Point Declarations,Compatibility with Ada 83,,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{465}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{466}
+@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{466}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{467}
@section Writing Portable Fixed-Point Declarations
types will be portable.
@node Compatibility with Ada 83,Compatibility between Ada 95 and Ada 2005,Writing Portable Fixed-Point Declarations,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{467}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{468}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{468}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{469}
@section Compatibility with Ada 83
@end menu
@node Legal Ada 83 programs that are illegal in Ada 95,More deterministic semantics,,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{469}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{46a}
+@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{46a}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{46b}
@subsection Legal Ada 83 programs that are illegal in Ada 95
@end itemize
@node More deterministic semantics,Changed semantics,Legal Ada 83 programs that are illegal in Ada 95,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{46b}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{46c}
+@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{46c}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{46d}
@subsection More deterministic semantics
@end itemize
@node Changed semantics,Other language compatibility issues,More deterministic semantics,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{46d}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{46e}
+@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{46e}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{46f}
@subsection Changed semantics
@end itemize
@node Other language compatibility issues,,Changed semantics,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{46f}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{470}
+@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{470}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{471}
@subsection Other language compatibility issues
@end itemize
@node Compatibility between Ada 95 and Ada 2005,Implementation-dependent characteristics,Compatibility with Ada 83,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{471}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{472}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{472}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{473}
@section Compatibility between Ada 95 and Ada 2005
@end itemize
@node Implementation-dependent characteristics,Compatibility with Other Ada Systems,Compatibility between Ada 95 and Ada 2005,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{473}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{474}
+@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{474}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{475}
@section Implementation-dependent characteristics
@end menu
@node Implementation-defined pragmas,Implementation-defined attributes,,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{475}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{476}
+@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{476}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{477}
@subsection Implementation-defined pragmas
relevant in a GNAT context and hence are not otherwise implemented.
@node Implementation-defined attributes,Libraries,Implementation-defined pragmas,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{477}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{478}
+@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{478}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{479}
@subsection Implementation-defined attributes
@code{Type_Class}.
@node Libraries,Elaboration order,Implementation-defined attributes,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{479}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{47a}
+@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{47a}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{47b}
@subsection Libraries
@end itemize
@node Elaboration order,Target-specific aspects,Libraries,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{47b}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{47c}
+@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{47c}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{47d}
@subsection Elaboration order
@end itemize
@node Target-specific aspects,,Elaboration order,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{47d}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{47e}
+@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{47e}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{47f}
@subsection Target-specific aspects
Ada 2005 and Ada 2012) are sometimes
incompatible with typical Ada 83 compiler practices regarding implicit
packing, the meaning of the Size attribute, and the size of access values.
-GNAT’s approach to these issues is described in @ref{47f,,Representation Clauses}.
+GNAT’s approach to these issues is described in @ref{480,,Representation Clauses}.
@node Compatibility with Other Ada Systems,Representation Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{480}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{481}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{481}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{482}
@section Compatibility with Other Ada Systems
@end itemize
@node Representation Clauses,Compatibility with HP Ada 83,Compatibility with Other Ada Systems,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{482}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{47f}
+@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{483}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{480}
@section Representation Clauses
@end itemize
@node Compatibility with HP Ada 83,,Representation Clauses,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{483}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{484}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{484}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{485}
@section Compatibility with HP Ada 83
@end itemize
@node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top
-@anchor{share/gnu_free_documentation_license doc}@anchor{485}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{486}
+@anchor{share/gnu_free_documentation_license doc}@anchor{486}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{487}
@chapter GNU Free Documentation License
@copying
@quotation
-GNAT User's Guide for Native Platforms , Jun 14, 2024
+GNAT User's Guide for Native Platforms , Jun 24, 2024
AdaCore
@printindex ge
-@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ }
@anchor{d1}@w{ }
+@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ }
@c %**end of body
@bye
package System.Finalization_Root is
pragma Preelaborate;
- -- The base for types Controlled and Limited_Controlled declared in Ada.
- -- Finalization.
+ -- The root type for types Controlled and Limited_Controlled declared in
+ -- Ada.Finalization (False needs to be qualified due to RTSfind quirks).
- type Root_Controlled is abstract tagged null record;
+ type Root_Controlled is abstract tagged null record
+ with Finalizable => (Initialize => Initialize,
+ Adjust => Adjust,
+ Finalize => Finalize,
+ Relaxed_Finalization => Standard.False);
procedure Adjust (Object : in out Root_Controlled);
procedure Finalize (Object : in out Root_Controlled);
return True;
elsif Is_Record_Type (Btype) then
- if Is_Limited_Record (Btype)
+ if Is_Controlled (Btype)
+ or else Is_Limited_Record (Btype)
or else Is_Tagged_Type (Btype)
or else Is_Volatile (Btype)
then
-- Check legality and completeness of the aggregate associations given in
-- the Storage_Model_Type aspect associated with Typ.
+ procedure Validate_Finalizable_Aspect (Typ : Entity_Id; ASN : Node_Id);
+ -- Check legality and completeness of the aggregate associations given in
+ -- the Finalizable aspect associated with Typ.
+
procedure Resolve_Storage_Model_Type_Argument
(N : Node_Id;
Typ : Entity_Id;
-- Resolve each one of the functions specified in the specification of
-- aspect Stable_Properties (or Stable_Properties'Class).
+ procedure Resolve_Finalizable_Argument
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Nam : Name_Id);
+ -- Resolve each one of the arguments specified in the specification of
+ -- aspect Finalizable.
+
procedure Resolve_Iterable_Operation
(N : Node_Id;
Cursor : Entity_Id;
ASN);
end if;
+ when Aspect_Finalizable =>
+ Validate_Finalizable_Aspect (E, ASN);
+
when others =>
null;
end case;
-- Otherwise the expression is not static
else
- Error_Msg_N
- ("expression of aspect % must be static", Aspect);
+ Flag_Non_Static_Expr
+ ("expression of aspect % must be static!", Aspect);
end if;
-- Otherwise the aspect appears without an expression and
(Expression (Assoc))
then
Error_Msg_Name_1 := Nam;
- Error_Msg_N
+ Flag_Non_Static_Expr
("expression of aspect % " &
- "must be static", Aspect);
+ "must be static!", Aspect);
end if;
else
-- Error if the boolean expression is not static
if not Is_OK_Static_Expression (Expr) then
- Error_Msg_N
- ("expression of aspect % must be static", Aspect);
+ Flag_Non_Static_Expr
+ ("expression of aspect % must be static!", Aspect);
end if;
end if;
end if;
Expr_Value := True;
end if;
else
- Error_Msg_N
- ("expression of aspect % must be static", Aspect);
+ Flag_Non_Static_Expr
+ ("expression of aspect % must be static!", Aspect);
end if;
end if;
else
Error_Msg_Name_1 := Nam;
Flag_Non_Static_Expr
- ("entity for aspect% must be a static expression",
+ ("entity for aspect% must be a static expression!",
Expr);
raise Aspect_Exit;
end if;
when Aspect_Storage_Model_Type =>
if not All_Extensions_Allowed then
+ Error_Msg_Name_1 := Nam;
Error_Msg_GNAT_Extension ("aspect %", Loc);
goto Continue;
goto Continue;
end if;
+ when Aspect_Finalizable =>
+ if not All_Extensions_Allowed then
+ Error_Msg_Name_1 := Nam;
+ Error_Msg_GNAT_Extension ("aspect %", Loc);
+ goto Continue;
+
+ elsif not Is_Type (E) then
+ Error_Msg_N ("can only be specified for a type", Aspect);
+ goto Continue;
+ end if;
+
when Aspect_Integer_Literal
| Aspect_Real_Literal
| Aspect_String_Literal
Analyze (Expression (ASN));
return;
- -- Ditto for Iterable, legality checks in Validate_Iterable_Aspect.
+ -- Finalizable, legality checks in Validate_Finalizable_Aspect
+
+ when Aspect_Finalizable =>
+ T := Entity (ASN);
+
+ if Nkind (Expression (ASN)) /= N_Aggregate then
+ pragma Assert (Serious_Errors_Detected > 0);
+ return;
+ end if;
+
+ declare
+ Assoc : Node_Id;
+ Exp : Node_Id;
+ Nam : Node_Id;
+
+ begin
+ Assoc := First (Component_Associations (Expression (ASN)));
+ while Present (Assoc) loop
+ Nam := First (Choices (Assoc));
+ Exp := Expression (Assoc);
+
+ if Chars (Nam) = Name_Relaxed_Finalization
+ and then Inside_A_Generic
+ then
+ Preanalyze_And_Resolve (Exp, Any_Boolean);
+
+ else
+ Analyze (Exp);
+ Resolve_Finalizable_Argument (Exp, T, Chars (Nam));
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end;
+
+ return;
+
+ -- Iterable, legality checks in Validate_Iterable_Aspect
when Aspect_Iterable =>
T := Entity (ASN);
+ if Nkind (Expression (ASN)) /= N_Aggregate then
+ pragma Assert (Serious_Errors_Detected > 0);
+ return;
+ end if;
+
declare
Cursor : constant Entity_Id := Get_Cursor_Type (ASN, T);
Assoc : Node_Id;
Set_SSO_Set_High_By_Default (Bas_Typ, False);
end if;
end if;
+
+ -- Finalizable
+
+ if Is_Record_Type (Typ) and then Typ = Bas_Typ then
+ Rep := Get_Inherited_Rep_Item (Typ, Name_Finalizable);
+ if Present (Rep) then
+ Propagate_Controlled_Flags (Typ, Etype (Bas_Typ));
+ end if;
+ end if;
end;
end if;
end Inherit_Aspects_At_Freeze_Point;
when Pre_Post_Aspects =>
null;
- when Aspect_Iterable =>
+ when Aspect_Finalizable | Aspect_Iterable =>
if Nkind (Expr) = N_Aggregate then
declare
Assoc : Node_Id;
end if;
end Validate_Aspect_Stable_Properties;
+ ----------------------------------
+ -- Resolve_Finalizable_Argument --
+ ----------------------------------
+
+ procedure Resolve_Finalizable_Argument
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Nam : Name_Id)
+ is
+ function Is_Finalizable_Primitive (E : Entity_Id) return Boolean;
+ -- Check whether E is a finalizable primitive for Typ
+
+ ------------------------------
+ -- Is_Finalizable_Primitive --
+ ------------------------------
+
+ function Is_Finalizable_Primitive (E : Entity_Id) return Boolean is
+ begin
+ return Ekind (E) = E_Procedure
+ and then Scope (E) = Scope (Typ)
+ and then Present (First_Formal (E))
+ and then Ekind (First_Formal (E)) = E_In_Out_Parameter
+ and then Etype (First_Formal (E)) = Typ
+ and then No (Next_Formal (First_Formal (E)));
+ end Is_Finalizable_Primitive;
+
+ -- Start of processing for Resolve_Finalizable_Argument
+
+ begin
+ if Nam = Name_Relaxed_Finalization then
+ Resolve (N, Any_Boolean);
+
+ if Is_OK_Static_Expression (N) then
+ Set_Has_Relaxed_Finalization (Typ, Is_True (Static_Boolean (N)));
+
+ else
+ Flag_Non_Static_Expr
+ ("expression of aspect Finalizable must be static!", N);
+ end if;
+
+ return;
+ end if;
+
+ if not Is_Entity_Name (N) then
+ null;
+
+ elsif not Is_Overloaded (N) then
+ if Is_Finalizable_Primitive (Entity (N)) then
+ return;
+ end if;
+
+ else
+ -- Overloaded case: find subprogram with proper signature
+
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (N, I, It);
+
+ while Present (It.Typ) loop
+ if Is_Finalizable_Primitive (It.Nam) then
+ Set_Entity (N, It.Nam);
+ return;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ Error_Msg_N
+ ("finalizable primitive must be local procedure whose only formal " &
+ "parameter has mode `IN OUT` and is of the finalizable type", N);
+ end Resolve_Finalizable_Argument;
+
--------------------------------
-- Resolve_Iterable_Operation --
--------------------------------
end loop;
end Validate_Address_Clauses;
+ ---------------------------------
+ -- Validate_Finalizable_Aspect --
+ ---------------------------------
+
+ procedure Validate_Finalizable_Aspect (Typ : Entity_Id; ASN : Node_Id) is
+ Aggr : constant Node_Id := Expression (ASN);
+
+ Assoc : Node_Id;
+ Exp : Node_Id;
+ Nam : Node_Id;
+
+ begin
+ if not Is_Record_Type (Typ) then
+ Error_Msg_N
+ ("aspect Finalizable can only be specified for a record type", ASN);
+ return;
+
+ elsif Is_Derived_Type (Typ) then
+ Error_Msg_N
+ ("aspect Finalizable cannot be specified for a derived type", ASN);
+ return;
+
+ elsif Nkind (Aggr) /= N_Aggregate then
+ Error_Msg_N ("aspect Finalizable must be an aggregate", Aggr);
+ return;
+
+ elsif not Is_Empty_List (Expressions (Aggr)) then
+ Error_Msg_N
+ ("illegal positional association", First (Expressions (Aggr)));
+ return;
+ end if;
+
+ Set_Is_Controlled_Active (Typ);
+
+ -- Relaxed_Finalization is optional and set True if not specified
+
+ Set_Has_Relaxed_Finalization (Typ);
+
+ Assoc := First (Component_Associations (Aggr));
+ while Present (Assoc) loop
+ Nam := First (Choices (Assoc));
+ Exp := Expression (Assoc);
+
+ if Nkind (Nam) /= N_Identifier or else Present (Next (Nam)) then
+ Error_Msg_N ("illegal name in association", Nam);
+
+ elsif Chars (Nam) in Name_Initialize | Name_Adjust | Name_Finalize
+ then
+ Analyze (Exp);
+ Resolve_Finalizable_Argument (Exp, Typ, Chars (Nam));
+
+ elsif Chars (Nam) = Name_Relaxed_Finalization then
+ if Inside_A_Generic then
+ Preanalyze_And_Resolve (Exp, Any_Boolean);
+ else
+ Analyze (Exp);
+ Resolve_Finalizable_Argument (Exp, Typ, Chars (Nam));
+ end if;
+
+ else
+ Error_Msg_N ("invalid argument for Finalizable aspect", Nam);
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end Validate_Finalizable_Aspect;
+
------------------------------
-- Validate_Iterable_Aspect --
------------------------------
-- Set fields for tagged types
if Is_Tagged then
- -- All tagged types defined in Ada.Finalization are controlled
-
- if Chars (Scope (Derived_Type)) = Name_Finalization
- and then Chars (Scope (Scope (Derived_Type))) = Name_Ada
- and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard
- then
- Set_Is_Controlled_Active (Derived_Type);
- end if;
-
-- Minor optimization: there is no need to generate the class-wide
-- entity associated with an underlying record view.
----------------------------
procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id) is
- Component : Entity_Id;
- Final_Storage_Only : Boolean := True;
- T : Entity_Id;
+ Component : Entity_Id;
+ Final_Storage_Only : Boolean := True;
+ Relaxed_Finalization : Boolean := True;
+ T : Entity_Id;
begin
if Ekind (Prev_T) = E_Incomplete_Type then
Final_Storage_Only :=
Final_Storage_Only
and then Finalize_Storage_Only (Etype (Component));
+ Relaxed_Finalization :=
+ Relaxed_Finalization
+ and then Has_Relaxed_Finalization (Etype (Component));
end if;
Next_Entity (Component);
-- For a type that is not directly controlled but has controlled
-- components, Finalize_Storage_Only is set if all the controlled
- -- components are Finalize_Storage_Only.
+ -- components are Finalize_Storage_Only. The same processing is
+ -- appled to Has_Relaxed_Finalization.
if not Is_Controlled (T) and then Has_Controlled_Component (T) then
- Set_Finalize_Storage_Only (T, Final_Storage_Only);
+ Set_Finalize_Storage_Only (T, Final_Storage_Only);
+ Set_Has_Relaxed_Finalization (T, Relaxed_Finalization);
end if;
-- Place reference to end record on the proper entity, which may
with Expander; use Expander;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
-with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
pragma Inline (Is_Bridge_Target);
-- Determine whether arbitrary entity Id denotes a bridge target
- function Is_Controlled_Proc
- (Subp_Id : Entity_Id;
- Subp_Nam : Name_Id) return Boolean;
- pragma Inline (Is_Controlled_Proc);
- -- Determine whether subprogram Subp_Id denotes controlled type
- -- primitives Adjust, Finalize, or Initialize as denoted by name
- -- Subp_Nam.
-
function Is_Default_Initial_Condition_Proc
(Id : Entity_Id) return Boolean;
pragma Inline (Is_Default_Initial_Condition_Proc);
-- primitive [Deep_]Initialize.
if Is_Init_Proc (Spec_Id)
- or else Is_Controlled_Proc (Spec_Id, Name_Initialize)
+ or else Is_Controlled_Procedure (Spec_Id, Name_Initialize)
or else Is_TSS (Spec_Id, TSS_Deep_Initialize)
then
return True;
-- an initialization context.
return
- (Is_Controlled_Proc (Subp_Id, Name_Finalize)
+ (Is_Controlled_Procedure (Subp_Id, Name_Finalize)
or else Is_Finalizer_Proc (Subp_Id)
or else Is_TSS (Subp_Id, TSS_Deep_Finalize))
and then In_Initialization_Context (Call);
-- Controlled adjustment actions
- elsif Is_Controlled_Proc (Targ_Id, Name_Adjust) then
+ elsif Is_Controlled_Procedure (Targ_Id, Name_Adjust) then
Extra := First_Formal_Type (Targ_Id);
Kind := Controlled_Adjustment;
-- Controlled finalization actions
- elsif Is_Controlled_Proc (Targ_Id, Name_Finalize)
+ elsif Is_Controlled_Procedure (Targ_Id, Name_Finalize)
or else Is_Finalizer_Proc (Targ_Id)
then
Extra := First_Formal_Type (Targ_Id);
-- Controlled initialization actions
- elsif Is_Controlled_Proc (Targ_Id, Name_Initialize) then
+ elsif Is_Controlled_Procedure (Targ_Id, Name_Initialize) then
Extra := First_Formal_Type (Targ_Id);
Kind := Controlled_Initialization;
begin
return
Is_Activation_Proc (Id)
- or else Is_Controlled_Proc (Id, Name_Adjust)
- or else Is_Controlled_Proc (Id, Name_Finalize)
- or else Is_Controlled_Proc (Id, Name_Initialize)
+ or else Is_Controlled_Procedure (Id, Name_Adjust)
+ or else Is_Controlled_Procedure (Id, Name_Finalize)
+ or else Is_Controlled_Procedure (Id, Name_Initialize)
or else Is_Init_Proc (Id)
or else Is_Invariant_Proc (Id)
or else Is_Protected_Entry (Id)
or else Is_TSS (Id, TSS_Deep_Initialize);
end Is_Bridge_Target;
- ------------------------
- -- Is_Controlled_Proc --
- ------------------------
-
- function Is_Controlled_Proc
- (Subp_Id : Entity_Id;
- Subp_Nam : Name_Id) return Boolean
- is
- Formal_Id : Entity_Id;
-
- begin
- pragma Assert
- (Subp_Nam in Name_Adjust | Name_Finalize | Name_Initialize);
-
- -- To qualify, the subprogram must denote a source procedure with
- -- name Adjust, Finalize, or Initialize where the sole formal is
- -- controlled.
-
- if Comes_From_Source (Subp_Id)
- and then Ekind (Subp_Id) = E_Procedure
- and then Chars (Subp_Id) = Subp_Nam
- then
- Formal_Id := First_Formal (Subp_Id);
-
- return
- Present (Formal_Id)
- and then Is_Controlled (Etype (Formal_Id))
- and then No (Next_Formal (Formal_Id));
- end if;
-
- return False;
- end Is_Controlled_Proc;
-
---------------------------------------
-- Is_Default_Initial_Condition_Proc --
---------------------------------------
if not Is_Controlled (Typ) then
return;
else
- Init := Find_Prim_Op (Typ, Name_Initialize);
+ Init := Find_Controlled_Prim_Op (Typ, Name_Initialize);
if Comes_From_Source (Init) then
Ent := Init;
("instantiation of& may occur before body is seen<l<",
N, Orig_Ent);
else
- -- A rather specific check. For Finalize/Adjust/Initialize, if
+ -- A rather specific check: for Adjust/Finalize/Initialize, if
-- the type has Warnings_Off set, suppress the warning.
- if Chars (E) in Name_Adjust
- | Name_Finalize
- | Name_Initialize
- and then Present (First_Formal (E))
+ if Is_Controlled_Procedure (E, Name_Adjust)
+ or else Is_Controlled_Procedure (E, Name_Finalize)
+ or else Is_Controlled_Procedure (E, Name_Initialize)
then
declare
T : constant Entity_Id := Etype (First_Formal (E));
+
begin
- if Is_Controlled (T) then
- if Has_Warnings_Off (T)
- or else (Ekind (T) = E_Private_Type
- and then Has_Warnings_Off (Full_View (T)))
- then
- goto Output;
- end if;
+ if Has_Warnings_Off (T)
+ or else (Ekind (T) = E_Private_Type
+ and then Has_Warnings_Off (Full_View (T)))
+ then
+ goto Output;
end if;
end;
end if;
and then Chars (Name (N)) /= Chars (Entity (Name (N)));
end Is_Call_Of_Generic_Formal;
+ -----------------------------
+ -- Is_Controlled_Procedure --
+ -----------------------------
+
+ function Is_Controlled_Procedure
+ (Id : Entity_Id;
+ Nam : Name_Id) return Boolean
+ is
+ begin
+ -- To qualify, the subprogram must denote a source procedure with
+ -- name Adjust, Finalize, or Initialize where the sole formal is
+ -- in out and controlled.
+
+ if Comes_From_Source (Id) and then Ekind (Id) = E_Procedure then
+ declare
+ Formal_Id : constant Entity_Id := First_Formal (Id);
+
+ begin
+ return
+ Present (Formal_Id)
+ and then Ekind (Formal_Id) = E_In_Out_Parameter
+ and then Is_Controlled (Etype (Formal_Id))
+ and then No (Next_Formal (Formal_Id))
+ and then Chars (Id) =
+ Name_Of_Controlled_Prim_Op (Etype (Formal_Id), Nam);
+ end;
+ end if;
+
+ return False;
+ end Is_Controlled_Procedure;
+
-------------------------------
-- Is_Finalization_Procedure --
-------------------------------
Deep_Fin := TSS (Typ, TSS_Deep_Finalize);
if Is_Controlled (Typ) then
- Fin := Find_Prim_Op (Typ, Name_Finalize);
+ Fin := Find_Controlled_Prim_Op (Typ, Name_Finalize);
end if;
return (Present (Deep_Fin) and then Id = Deep_Fin)
Init_Call : constant Boolean :=
Nkind (Call) = N_Procedure_Call_Statement
- and then Chars (Subp) = Name_Initialize
- and then Comes_From_Source (Subp)
- and then Present (Parameter_Associations (Call))
- and then Is_Controlled (Etype (First_Actual (Call)));
+ and then Is_Controlled_Procedure (Subp, Name_Initialize);
begin
-- If the unit is mentioned in a with_clause of the current unit, it is
-- This package contains routines which handle access-before-elaboration
-- run-time checks and compile-time diagnostics. See the body for details.
+with Namet; use Namet;
with Types; use Types;
package Sem_Elab is
pragma Inline (Initialize);
-- Initialize the internal structures of this unit
+ function Is_Controlled_Procedure
+ (Id : Entity_Id;
+ Nam : Name_Id) return Boolean;
+ -- Determine whether subprogram Id denotes controlled primitive operation
+ -- Adjust, Finalize, or Initialize as specified by Nam.
+
procedure Kill_Elaboration_Scenario (N : Node_Id);
-- Determine whether arbitrary node N denotes a scenario which requires
-- ABE diagnostics or runtime checks and eliminate it from a region with
if Present (Utyp) then
declare
Init : constant Entity_Id :=
- (Find_Optional_Prim_Op
- (Utyp, Name_Initialize));
+ Find_Controlled_Prim_Op (Utyp, Name_Initialize);
begin
if Present (Init)
then
return True;
- elsif Has_Null_Extension (Typ)
- and then
- Is_Fully_Initialized_Type
- (Etype (Base_Type (Typ)))
+ elsif Is_Tagged_Type (Typ)
+ and then Is_Derived_Type (Typ)
+ and then Has_Null_Extension (Typ)
+ and then
+ Is_Fully_Initialized_Type (Etype (Base_Type (Typ)))
then
return True;
end if;
then
Set_Has_Controlled_Component (Typ);
end if;
+
+ if Has_Relaxed_Finalization (From_Typ) then
+ Set_Has_Relaxed_Finalization (Typ);
+ end if;
end Propagate_Controlled_Flags;
------------------------------
Comp : Boolean := False;
Deriv : Boolean := False);
-- Set Disable_Controlled, Finalize_Storage_Only, Has_Controlled_Component,
- -- and Is_Controlled_Active on Typ when the flags are set on From_Typ. If
- -- Comp is True, From_Typ is the type of a component of Typ while, if Deriv
- -- is True, From_Typ is the parent type of Typ. This procedure can only set
- -- flags for Typ, and never clear them.
+ -- Has_Relaxed_Finalization, and Is_Controlled_Active on Typ when the flags
+ -- are set on From_Typ. If Comp is True, From_Typ is assumed to be the type
+ -- of a component of Typ while, if Deriv is True, From_Typ is assumed to be
+ -- the parent type of Typ. This procedure can only set flags for Typ, and
+ -- never clear them.
procedure Propagate_DIC_Attributes
(Typ : Entity_Id;
Name_Disable_Controlled : constant Name_Id := N + $;
Name_Dynamic_Predicate : constant Name_Id := N + $;
Name_Exclusive_Functions : constant Name_Id := N + $;
+ Name_Finalizable : constant Name_Id := N + $;
Name_Full_Access_Only : constant Name_Id := N + $;
Name_Ghost_Predicate : constant Name_Id := N + $;
Name_Integer_Literal : constant Name_Id := N + $;
Name_Proof_In : constant Name_Id := N + $;
Name_Reason : constant Name_Id := N + $;
Name_Reference : constant Name_Id := N + $;
+ Name_Relaxed_Finalization : constant Name_Id := N + $;
Name_Renamed : constant Name_Id := N + $;
Name_Requires : constant Name_Id := N + $;
Name_Restricted : constant Name_Id := N + $;
projects / thirdparty / gcc.git / commitdiff
