* [COMMITTED 1/7] ada: Implement first half of Generalized Finalization
@ 2024-06-27 8:52 Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 2/7] ada: Overridden operation field not correctly set for controlling result wrappers Marc Poulhiès
` (5 more replies)
0 siblings, 6 replies; 7+ messages in thread
From: Marc Poulhiès @ 2024-06-27 8:52 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
This implements the first half of the Generalized Finalization proposal,
namely the Finalizable aspect as well as its optional relaxed semantics
for the finalization operations, but the latter part is only implemented
for dynamically allocated objects.
In accordance with the spirit, if not the letter, of the proposal, this
implements the finalizable types declared with strict semantics for the
finalization operations as a direct generalization of controlled types,
which in turn makes it possible to reimplement the latter types in terms
of the former types and ensures full interoperability between them.
The relaxed semantics for the finalization operations is also a direct
generalization of the GNAT pragma No_Heap_Finalization for dynamically
allocated objects, in that it extends the effects of the pragma to all
access types designating the finalizable type, instead of just applying
them to library-level named access types.
gcc/ada/
* aspects.ads (Aspect_Id): Add Aspect_Finalizable.
(Implementation_Defined_Aspect): Add True for Aspect_Finalizable.
(Operational_Aspect): Add True for Aspect_Finalizable.
(Aspect_Argument): Add Expression for Aspect_Finalizable.
(Is_Representation_Aspect): Add False for Aspect_Finalizable.
(Aspect_Names): Add Name_Finalizable for Aspect_Finalizable.
(Aspect_Delay): Add Always_Delay for Aspect_Finalizable.
* checks.adb: Add with and use clauses for Sem_Elab.
(Install_Primitive_Elaboration_Check): Call Is_Controlled_Procedure.
* einfo.ads (Has_Relaxed_Finalization): Document new flag.
(Is_Controlled_Active): Update documentation.
* exp_aggr.adb (Generate_Finalization_Actions): Replace Find_Prim_Op
with Find_Controlled_Prim_Op for Name_Finalize.
* exp_attr.adb (Expand_N_Attribute_Reference) <Finalization_Size>:
Return 0 if the prefix type has relaxed finalization.
* exp_ch3.adb (Build_Equivalent_Record_Aggregate): Return Empty if
the type needs finalization.
(Expand_Freeze_Record_Type): Call Find_Controlled_Prim_Op instead of
Find_Prim_Op for Name_{Adjust,Initialize,Finalize}.
Call Make_Finalize_Address_Body for all controlled types.
* exp_ch4.adb (Insert_Dereference_Action): Do not generate a call to
Adjust_Controlled_Dereference if the designated type has relaxed
finalization.
* exp_ch6.adb (Needs_BIP_Collection): Return false for an untagged
type that has relaxed finalization.
* exp_ch7.adb (Allows_Finalization_Collection): Return false if the
designated type has relaxed finalization.
(Check_Visibly_Controlled): Call Find_Controlled_Prim_Op instead of
Find_Prim_Op.
(Make_Adjust_Call): Likewise.
(Make_Deep_Record_Body): Likewise.
(Make_Final_Call): Likewise.
(Make_Init_Call): Likewise.
* exp_disp.adb (Set_All_DT_Position): Remove obsolete warning.
* exp_util.ads: Add with and use clauses for Snames.
(Find_Prim_Op): Add precondition.
(Find_Controlled_Prim_Op): New function declaration.
(Name_Of_Controlled_Prim_Op): Likewise.
* exp_util.adb: Remove with and use clauses for Snames.
(Build_Allocate_Deallocate_Proc): Do not build finalization actions
if the designated type has relaxed finalization.
(Find_Controlled_Prim_Op): New function.
(Find_Last_Init): Call Find_Controlled_Prim_Op instead of
Find_Prim_Op.
(Name_Of_Controlled_Prim_Op): New function.
* freeze.adb (Freeze_Entity.Freeze_Record_Type): Propagate the
Has_Relaxed_Finalization flag from components.
* gen_il-fields.ads (Opt_Field_Enum): Add Has_Relaxed_Finalization.
* gen_il-gen-gen_entities.adb (Entity_Kind): Likewise.
* sem_aux.adb (Is_By_Reference_Type): Return true for all controlled
types.
* sem_ch3.adb (Build_Derived_Record_Type): Do not special case types
declared in Ada.Finalization.
(Record_Type_Definition): Propagate the Has_Relaxed_Finalization
flag from components.
* sem_ch13.adb (Analyze_Aspects_At_Freeze_Point): Also process the
Finalizable aspect.
(Analyze_Aspect_Specifications): Likewise. Call Flag_Non_Static_Expr
in more cases.
(Check_Aspect_At_Freeze_Point): Likewise.
(Inherit_Aspects_At_Freeze_Point): Likewise.
(Resolve_Aspect_Expressions): Likewise.
(Resolve_Finalizable_Argument): New procedure.
(Validate_Finalizable_Aspect): Likewise.
* sem_elab.ads: Add with and use clauses for Snames.
(Is_Controlled_Procedure): New function declaration.
* sem_elab.adb: Remove with and use clauses for Snames.
(Is_Controlled_Proc): Move to...
(Is_Controlled_Procedure): ...here and rename.
(Check_A_Call): Call Find_Controlled_Prim_Op instead of
Find_Prim_Op.
(Is_Finalization_Procedure): Likewise.
* sem_util.ads (Propagate_Controlled_Flags): Update documentation.
* sem_util.adb (Is_Fully_Initialized_Type): Replace call to
Find_Optional_Prim_Op with Find_Controlled_Prim_Op.
Call Has_Null_Extension only for derived tagged types.
(Propagate_Controlled_Flags): Propagate Has_Relaxed_Finalization.
* snames.ads-tmpl (Name_Finalizable): New name.
(Name_Relaxed_Finalization): Likewise.
* libgnat/s-finroo.ads (Root_Controlled): Add Finalizable aspect.
* doc/gnat_rm/gnat_language_extensions.rst: Document implementation
of Generalized Finalization.
* gnat_rm.texi: Regenerate.
* gnat_ugn.texi: Regenerate.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/aspects.ads | 9 +-
gcc/ada/checks.adb | 6 +-
.../doc/gnat_rm/gnat_language_extensions.rst | 33 +++
gcc/ada/einfo.ads | 11 +-
gcc/ada/exp_aggr.adb | 2 +-
gcc/ada/exp_attr.adb | 9 +-
gcc/ada/exp_ch3.adb | 53 ++--
gcc/ada/exp_ch4.adb | 8 +-
gcc/ada/exp_ch6.adb | 4 +-
gcc/ada/exp_ch7.adb | 62 ++---
gcc/ada/exp_disp.adb | 24 --
gcc/ada/exp_util.adb | 61 ++++-
gcc/ada/exp_util.ads | 25 +-
gcc/ada/freeze.adb | 12 +-
gcc/ada/gen_il-fields.ads | 1 +
gcc/ada/gen_il-gen-gen_entities.adb | 1 +
gcc/ada/gnat_rm.texi | 103 +++++---
gcc/ada/gnat_ugn.texi | 4 +-
gcc/ada/libgnat/s-finroo.ads | 10 +-
gcc/ada/sem_aux.adb | 3 +-
gcc/ada/sem_ch13.adb | 243 +++++++++++++++++-
gcc/ada/sem_ch3.adb | 25 +-
gcc/ada/sem_elab.adb | 120 ++++-----
gcc/ada/sem_elab.ads | 7 +
gcc/ada/sem_util.adb | 16 +-
gcc/ada/sem_util.ads | 9 +-
gcc/ada/snames.ads-tmpl | 2 +
27 files changed, 621 insertions(+), 242 deletions(-)
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index cf992a89038..3157e5cdd9a 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -98,6 +98,7 @@ package Aspects is
Aspect_Exceptional_Cases, -- GNAT
Aspect_External_Name,
Aspect_External_Tag,
+ Aspect_Finalizable, -- GNAT
Aspect_Ghost_Predicate, -- GNAT
Aspect_Global, -- GNAT
Aspect_GNAT_Annotate, -- GNAT
@@ -291,6 +292,7 @@ package Aspects is
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,
@@ -331,8 +333,8 @@ package Aspects is
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,
@@ -355,6 +357,7 @@ package Aspects is
(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,
@@ -432,6 +435,7 @@ package Aspects is
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,
@@ -530,6 +534,7 @@ package Aspects is
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,
@@ -703,6 +708,7 @@ package Aspects is
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,
@@ -953,6 +959,7 @@ package Aspects is
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,
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index c8a0696be67..504cba0b942 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -50,6 +50,7 @@ with Sem_Ch3; use Sem_Ch3;
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;
@@ -8622,8 +8623,9 @@ package body Checks is
-- 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;
diff --git a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
index d06ac4cc98d..fc3ca5f7adf 100644
--- a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
+++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
@@ -562,3 +562,36 @@ subcomponents, among others detailed in the RFC.
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
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index de175310ee9..fbe6c8566ec 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -2036,6 +2036,10 @@ package Einfo is
-- 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.
@@ -2505,8 +2509,11 @@ package Einfo is
-- 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
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index d564fd4f755..01ad1dcd437 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -2477,7 +2477,7 @@ package body Exp_Aggr is
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;
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 5c85b4912d2..627cd7f3392 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -3757,10 +3757,13 @@ package body Exp_Attr is
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
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 548fbede4f1..70048e68331 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -1893,6 +1893,7 @@ package body Exp_Ch3 is
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;
@@ -6328,19 +6329,22 @@ package body Exp_Ch3 is
-- 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
@@ -6424,6 +6428,15 @@ package body Exp_Ch3 is
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
@@ -6440,28 +6453,18 @@ package body Exp_Ch3 is
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
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 1674d6c8132..6a33734c443 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -13598,13 +13598,15 @@ package body Exp_Ch4 is
-- 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);
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 6d3d05fcf20..5d808a3402d 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -9640,7 +9640,9 @@ package body Exp_Ch6 is
-- 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;
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index e3e9bac2b34..149715f94da 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -972,6 +972,11 @@ package body Exp_Ch7 is
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))
@@ -3944,7 +3949,7 @@ package body Exp_Ch7 is
-- 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;
@@ -5435,7 +5440,7 @@ package body Exp_Ch7 is
-- 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
@@ -6369,6 +6374,8 @@ package body Exp_Ch7 is
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:
@@ -6518,7 +6525,6 @@ package body Exp_Ch7 is
-----------------------------
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;
@@ -6846,7 +6852,7 @@ package body Exp_Ch7 is
Proc : Entity_Id;
begin
- Proc := Find_Optional_Prim_Op (Typ, Name_Adjust);
+ Proc := Find_Controlled_Prim_Op (Typ, Name_Adjust);
-- Generate:
-- if F then
@@ -6934,8 +6940,7 @@ package body Exp_Ch7 is
-------------------------------
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;
@@ -7472,7 +7477,7 @@ package body Exp_Ch7 is
Proc : Entity_Id;
begin
- Proc := Find_Optional_Prim_Op (Typ, Name_Finalize);
+ Proc := Find_Controlled_Prim_Op (Typ, Name_Finalize);
-- Generate:
-- if F then
@@ -7629,22 +7634,17 @@ package body Exp_Ch7 is
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;
@@ -7784,7 +7784,7 @@ package body Exp_Ch7 is
-- 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
@@ -7895,10 +7895,10 @@ package body Exp_Ch7 is
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))
@@ -8287,12 +8287,12 @@ package body Exp_Ch7 is
-- 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;
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 77256ac5af1..c3671810d64 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -7878,9 +7878,6 @@ package body Exp_Disp is
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;
@@ -8208,14 +8205,6 @@ package body Exp_Disp is
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
@@ -8262,19 +8251,6 @@ package body Exp_Disp is
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));
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index e86e7037d1f..fcb62a64e70 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -60,7 +60,6 @@ with Sem_Res; use Sem_Res;
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;
@@ -929,6 +928,7 @@ package body Exp_Util is
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
@@ -6056,6 +6056,23 @@ package body Exp_Util is
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 --
------------------------
@@ -6323,7 +6340,7 @@ package body Exp_Util is
-- 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);
@@ -11603,6 +11620,46 @@ package body Exp_Util is
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 --
--------------------------------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 6460bf02c1b..96d896a0b98 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -31,6 +31,7 @@ with Namet; use Namet;
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;
@@ -577,12 +578,15 @@ package Exp_Util is
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;
@@ -591,6 +595,12 @@ package Exp_Util is
-- 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
@@ -1001,6 +1011,13 @@ package Exp_Util is
-- 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
@@ -1269,6 +1286,8 @@ package Exp_Util is
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);
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 29733a17a56..757c16e6839 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -5084,6 +5084,9 @@ package body Freeze is
-- 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.
@@ -5707,6 +5710,9 @@ package body Freeze is
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
@@ -5741,11 +5747,13 @@ package body Freeze is
-- 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;
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 5aa246d1fb6..ef37bb20f53 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -625,6 +625,7 @@ package Gen_IL.Fields is
Has_RACW,
Has_Record_Rep_Clause,
Has_Recursive_Call,
+ Has_Relaxed_Finalization,
Has_Shift_Operator,
Has_Size_Clause,
Has_Small_Clause,
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb
index c3595bb3dd6..bdc81202645 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -103,6 +103,7 @@ begin -- Gen_IL.Gen.Gen_Entities
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),
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index b80d77eeb02..dc5721689cb 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -19,7 +19,7 @@
@copying
@quotation
-GNAT Reference Manual , Jun 14, 2024
+GNAT Reference Manual , Jun 24, 2024
AdaCore
@@ -908,6 +908,7 @@ Experimental Language Extensions
* Simpler accessibility model::
* Case pattern matching::
* Mutably Tagged Types with Size’Class Aspect::
+* Generalized Finalization::
Security Hardening Features
@@ -29265,6 +29266,7 @@ particular the @code{Shift_Left} and @code{Shift_Right} intrinsics.
* Simpler accessibility model::
* Case pattern matching::
* Mutably Tagged Types with Size’Class Aspect::
+* Generalized Finalization::
@end menu
@@ -29458,7 +29460,7 @@ case statement with composite selector type”.
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
@@ -29498,8 +29500,43 @@ subcomponents, among others detailed in the RFC.
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
@@ -29521,7 +29558,7 @@ change.
@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
@@ -29557,7 +29594,7 @@ programming languages, see @cite{Using the GNU Compiler Collection (GCC)}.
@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
@@ -29701,7 +29738,7 @@ Bar_Callable_Ptr.
@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
@@ -29791,7 +29828,7 @@ be used with other programming languages supported by GCC.
@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
@@ -29852,7 +29889,7 @@ and more details on that attribute, see @cite{Using the GNU Compiler Collection
@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
@@ -30020,7 +30057,7 @@ see @cite{Using the GNU Compiler Collection (GCC)}. These options
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
@@ -30039,7 +30076,7 @@ compatibility purposes.
@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
@@ -30052,7 +30089,7 @@ preferred usage is to use an appropriately configured run-time that
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
@@ -30061,7 +30098,7 @@ The pragma @code{Ravenscar} has exactly the same effect as pragma
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
@@ -30071,7 +30108,7 @@ preferred since the Ada 2005 pragma @code{Profile} is intended for
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
@@ -30097,7 +30134,7 @@ in the spec of package System.Task_Info in the runtime
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})
@@ -30107,7 +30144,7 @@ to support the @code{Task_Info} pragma. The predefined Ada package
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
@@ -30129,7 +30166,7 @@ applications developed in other Ada environments.
@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
@@ -30251,7 +30288,7 @@ If you follow this scheme you will be guaranteed that your fixed-point
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
@@ -30279,7 +30316,7 @@ following subsections treat the most likely issues to be encountered.
@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
@@ -30379,7 +30416,7 @@ the fix is usually simply to add the @code{(<>)} to the generic declaration.
@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
@@ -30407,7 +30444,7 @@ which open select branches are executed.
@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
@@ -30449,7 +30486,7 @@ covers only the restricted range.
@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
@@ -30482,7 +30519,7 @@ include @code{pragma Interface} and the floating point type attributes
@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
@@ -30554,7 +30591,7 @@ can declare a function returning a value from an anonymous access type.
@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
@@ -30577,7 +30614,7 @@ transition from certain Ada 83 compilers.
@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
@@ -30599,7 +30636,7 @@ avoiding compiler rejection of units that contain such pragmas; they are not
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
@@ -30613,7 +30650,7 @@ Ada 83, GNAT supplies the attributes @code{Bit}, @code{Machine_Size} and
@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
@@ -30642,7 +30679,7 @@ be preferable to retrofit the application using modular types.
@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
@@ -30678,7 +30715,7 @@ pragmas either globally (as an effect of the `-gnatE' switch) or locally
@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
@@ -30691,10 +30728,10 @@ on the robustness of the original design. Moreover, Ada 95 (and thus
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
@@ -30737,7 +30774,7 @@ far beyond this minimal set, as described in the next section.
@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
@@ -30830,7 +30867,7 @@ with thin pointers.
@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
@@ -30860,7 +30897,7 @@ extension of package System.
@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
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 135a4e13e78..80cfb41b983 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -19,7 +19,7 @@
@copying
@quotation
-GNAT User's Guide for Native Platforms , Jun 14, 2024
+GNAT User's Guide for Native Platforms , Jun 24, 2024
AdaCore
@@ -29670,8 +29670,8 @@ to permit their use in free software.
@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
diff --git a/gcc/ada/libgnat/s-finroo.ads b/gcc/ada/libgnat/s-finroo.ads
index 2f34007d37a..3b6c2a1c444 100644
--- a/gcc/ada/libgnat/s-finroo.ads
+++ b/gcc/ada/libgnat/s-finroo.ads
@@ -34,10 +34,14 @@
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);
diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb
index ac0acb7b0d0..0639a2e4d86 100644
--- a/gcc/ada/sem_aux.adb
+++ b/gcc/ada/sem_aux.adb
@@ -882,7 +882,8 @@ package body Sem_Aux is
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
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 90376f818a3..957c43d689b 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -291,6 +291,10 @@ package body Sem_Ch13 is
-- 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;
@@ -306,6 +310,13 @@ package body Sem_Ch13 is
-- 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;
@@ -1382,6 +1393,9 @@ package body Sem_Ch13 is
ASN);
end if;
+ when Aspect_Finalizable =>
+ Validate_Finalizable_Aspect (E, ASN);
+
when others =>
null;
end case;
@@ -1913,8 +1927,8 @@ package body Sem_Ch13 is
-- 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
@@ -2353,9 +2367,9 @@ package body Sem_Ch13 is
(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
@@ -2572,8 +2586,8 @@ package body Sem_Ch13 is
-- 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;
@@ -2628,8 +2642,8 @@ package body Sem_Ch13 is
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;
@@ -2682,7 +2696,7 @@ package body Sem_Ch13 is
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;
@@ -4139,6 +4153,7 @@ package body Sem_Ch13 is
when Aspect_Storage_Model_Type =>
if not All_Extensions_Allowed then
+ Error_Msg_Name_1 := Nam;
Error_Msg_GNAT_Extension ("aspect %", Loc);
goto Continue;
@@ -4151,6 +4166,17 @@ package body Sem_Ch13 is
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
@@ -11439,11 +11465,53 @@ package body Sem_Ch13 is
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;
@@ -14159,6 +14227,15 @@ package body Sem_Ch13 is
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;
@@ -15977,7 +16054,7 @@ package body Sem_Ch13 is
when Pre_Post_Aspects =>
null;
- when Aspect_Iterable =>
+ when Aspect_Finalizable | Aspect_Iterable =>
if Nkind (Expr) = N_Aggregate then
declare
Assoc : Node_Id;
@@ -16449,6 +16526,83 @@ package body Sem_Ch13 is
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 --
--------------------------------
@@ -17693,6 +17847,73 @@ package body Sem_Ch13 is
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 --
------------------------------
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 391727a37f4..c0943f97341 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -9854,15 +9854,6 @@ package body Sem_Ch3 is
-- 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.
@@ -22898,9 +22889,10 @@ package body Sem_Ch3 is
----------------------------
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
@@ -22970,6 +22962,9 @@ package body Sem_Ch3 is
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);
@@ -22977,10 +22972,12 @@ package body Sem_Ch3 is
-- 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
diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index 4d6e14cc49c..cebef2ca44f 100644
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -38,7 +38,6 @@ with Exp_Util; use Exp_Util;
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;
@@ -1773,14 +1772,6 @@ package body Sem_Elab is
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);
@@ -5315,7 +5306,7 @@ package body Sem_Elab is
-- 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;
@@ -5346,7 +5337,7 @@ package body Sem_Elab is
-- 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);
@@ -13113,13 +13104,13 @@ package body Sem_Elab is
-- 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);
@@ -13127,7 +13118,7 @@ package body Sem_Elab is
-- 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;
@@ -14427,9 +14418,9 @@ package body Sem_Elab is
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)
@@ -14496,39 +14487,6 @@ package body Sem_Elab is
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 --
---------------------------------------
@@ -16948,7 +16906,7 @@ package body Sem_Elab is
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;
@@ -18740,24 +18698,22 @@ package body Sem_Elab is
("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;
@@ -19375,6 +19331,37 @@ package body Sem_Elab is
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 --
-------------------------------
@@ -19407,7 +19394,7 @@ package body Sem_Elab is
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)
@@ -19574,10 +19561,7 @@ package body Sem_Elab is
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
diff --git a/gcc/ada/sem_elab.ads b/gcc/ada/sem_elab.ads
index e6410635254..72a46f5654c 100644
--- a/gcc/ada/sem_elab.ads
+++ b/gcc/ada/sem_elab.ads
@@ -26,6 +26,7 @@
-- 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
@@ -119,6 +120,12 @@ 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
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 4dde5f3964e..9d4fd74b98f 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -17201,8 +17201,7 @@ package body Sem_Util is
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)
@@ -17211,10 +17210,11 @@ package body Sem_Util is
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;
@@ -26289,6 +26289,10 @@ package body Sem_Util is
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;
------------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 7363ad96bd8..21e90dcf53b 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -2920,10 +2920,11 @@ package Sem_Util is
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;
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index c624d04a7f7..5be3044158e 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -155,6 +155,7 @@ package Snames is
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 + $;
@@ -868,6 +869,7 @@ package Snames is
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 + $;
--
2.45.2
^ permalink raw reply [flat|nested] 7+ messages in thread
* [COMMITTED 2/7] ada: Overridden operation field not correctly set for controlling result wrappers
2024-06-27 8:52 [COMMITTED 1/7] ada: Implement first half of Generalized Finalization Marc Poulhiès
@ 2024-06-27 8:52 ` Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 3/7] ada: Bug using user defined string literals with interpolated strings Marc Poulhiès
` (4 subsequent siblings)
5 siblings, 0 replies; 7+ messages in thread
From: Marc Poulhiès @ 2024-06-27 8:52 UTC (permalink / raw)
To: gcc-patches; +Cc: Martin Clochard
From: Martin Clochard <clochard@adacore.com>
Implicit wrapper overridings generated for functions with
controlling result when deriving with null extension may
have field Overridden_Operation incorrectly set, when making
several such derivations in succession. This happens because
overridings were assumed to come from source, and entities
generated by Derive_Subprograms were also assumed to be
derived from source subprograms. Overridden_Operation could
be set to the entity generated by Derive_Subprograms for the
same type, resulting in a cycle between Overriden_Operation
and Alias fields, causing non-termination in GNATprove.
gcc/ada/
* sem_ch6.adb (Check_Overriding_Indicator) Remove Comes_From_Source filter.
(New_Overloaded_Entity) Move up special case of LSP_Subprogram,
and remove Comes_From_Source filter.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch6.adb | 82 +++++++++++++++++++--------------------------
1 file changed, 35 insertions(+), 47 deletions(-)
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index e97afdaf12e..43aa2e636fa 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -6916,13 +6916,11 @@ package body Sem_Ch6 is
-- operation is the inherited primitive (which is available
-- through the attribute alias)
- if (Is_Dispatching_Operation (Subp)
- or else Is_Dispatching_Operation (Overridden_Subp))
+ if Is_Dispatching_Operation (Subp)
and then not Comes_From_Source (Overridden_Subp)
and then Find_Dispatching_Type (Overridden_Subp) =
Find_Dispatching_Type (Subp)
and then Present (Alias (Overridden_Subp))
- and then Comes_From_Source (Alias (Overridden_Subp))
then
Set_Overridden_Operation (Subp, Alias (Overridden_Subp));
Inherit_Subprogram_Contract (Subp, Alias (Overridden_Subp));
@@ -12565,16 +12563,25 @@ package body Sem_Ch6 is
Enter_Overloaded_Entity (S);
+ -- LSP wrappers must override the ultimate alias of their
+ -- wrapped dispatching primitive E; required to traverse the
+ -- chain of ancestor primitives (see Map_Primitives). They
+ -- don't inherit contracts.
+
+ if Is_Wrapper (S)
+ and then Present (LSP_Subprogram (S))
+ then
+ Set_Overridden_Operation (S, Ultimate_Alias (E));
+
-- For entities generated by Derive_Subprograms the
-- overridden operation is the inherited primitive
-- (which is available through the attribute alias).
- if not (Comes_From_Source (E))
+ elsif not (Comes_From_Source (E))
and then Is_Dispatching_Operation (E)
and then Find_Dispatching_Type (E) =
Find_Dispatching_Type (S)
and then Present (Alias (E))
- and then Comes_From_Source (Alias (E))
then
Set_Overridden_Operation (S, Alias (E));
Inherit_Subprogram_Contract (S, Alias (E));
@@ -12591,20 +12598,8 @@ package body Sem_Ch6 is
-- must check whether the target is an init_proc.
elsif not Is_Init_Proc (S) then
-
- -- LSP wrappers must override the ultimate alias of their
- -- wrapped dispatching primitive E; required to traverse
- -- the chain of ancestor primitives (c.f. Map_Primitives)
- -- They don't inherit contracts.
-
- if Is_Wrapper (S)
- and then Present (LSP_Subprogram (S))
- then
- Set_Overridden_Operation (S, Ultimate_Alias (E));
- else
- Set_Overridden_Operation (S, E);
- Inherit_Subprogram_Contract (S, E);
- end if;
+ Set_Overridden_Operation (S, E);
+ Inherit_Subprogram_Contract (S, E);
Set_Is_Ada_2022_Only (S, Is_Ada_2022_Only (E));
end if;
@@ -12619,37 +12614,30 @@ package body Sem_Ch6 is
-- If S is a user-defined subprogram or a null procedure
-- expanded to override an inherited null procedure, or a
- -- predefined dispatching primitive then indicate that E
- -- overrides the operation from which S is inherited.
+ -- predefined dispatching primitive, or a function wrapper
+ -- expanded to override an inherited function with
+ -- dispatching result, then indicate that S overrides the
+ -- operation from which E is inherited.
- if Comes_From_Source (S)
- or else
- (Present (Parent (S))
- and then Nkind (Parent (S)) = N_Procedure_Specification
- and then Null_Present (Parent (S)))
- or else
- (Present (Alias (E))
- and then
- Is_Predefined_Dispatching_Operation (Alias (E)))
+ if (not Is_Wrapper (S) or else No (LSP_Subprogram (S)))
+ and then Present (Alias (E))
+ and then
+ (Comes_From_Source (S)
+ or else
+ (Nkind (Parent (S)) = N_Procedure_Specification
+ and then Null_Present (Parent (S)))
+ or else Is_Predefined_Dispatching_Operation (Alias (E))
+ or else
+ (E in E_Function_Id
+ and then Is_Dispatching_Operation (E)
+ and then Has_Controlling_Result (E)
+ and then Is_Wrapper (S)
+ and then not Is_Dispatch_Table_Wrapper (S)))
then
- if Present (Alias (E)) then
-
- -- LSP wrappers must override the ultimate alias of
- -- their wrapped dispatching primitive E; required to
- -- traverse the chain of ancestor primitives (see
- -- Map_Primitives). They don't inherit contracts.
-
- if Is_Wrapper (S)
- and then Present (LSP_Subprogram (S))
- then
- Set_Overridden_Operation (S, Ultimate_Alias (E));
- else
- Set_Overridden_Operation (S, Alias (E));
- Inherit_Subprogram_Contract (S, Alias (E));
- end if;
+ Set_Overridden_Operation (S, Alias (E));
+ Inherit_Subprogram_Contract (S, Alias (E));
- Set_Is_Ada_2022_Only (S, Is_Ada_2022_Only (Alias (E)));
- end if;
+ Set_Is_Ada_2022_Only (S, Is_Ada_2022_Only (Alias (E)));
end if;
if Is_Dispatching_Operation (E) then
--
2.45.2
^ permalink raw reply [flat|nested] 7+ messages in thread
* [COMMITTED 3/7] ada: Bug using user defined string literals with interpolated strings
2024-06-27 8:52 [COMMITTED 1/7] ada: Implement first half of Generalized Finalization Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 2/7] ada: Overridden operation field not correctly set for controlling result wrappers Marc Poulhiès
@ 2024-06-27 8:52 ` Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 4/7] ada: Fix array-manipulating code in Mdll Marc Poulhiès
` (3 subsequent siblings)
5 siblings, 0 replies; 7+ messages in thread
From: Marc Poulhiès @ 2024-06-27 8:52 UTC (permalink / raw)
To: gcc-patches; +Cc: Javier Miranda
From: Javier Miranda <miranda@adacore.com>
The frontend rejects the use of user defined string literals
using interpolated strings.
gcc/ada/
* sem_res.adb (Has_Applicable_User_Defined_Literal): Add missing
support for interpolated strings.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_res.adb | 7 ++++++-
1 file changed, 6 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index a0dd1f7962b..72bba1f97af 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -467,7 +467,7 @@ package body Sem_Res is
Literal_Aspect_Map :
constant array (N_Numeric_Or_String_Literal) of Aspect_Id :=
(N_Integer_Literal => Aspect_Integer_Literal,
- N_Interpolated_String_Literal => No_Aspect,
+ N_Interpolated_String_Literal => Aspect_String_Literal,
N_Real_Literal => Aspect_Real_Literal,
N_String_Literal => Aspect_String_Literal);
@@ -487,6 +487,7 @@ package body Sem_Res is
begin
if (Nkind (N) in N_Numeric_Or_String_Literal
+ | N_Interpolated_String_Literal
and then Present
(Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N)))))
or else
@@ -563,6 +564,10 @@ package body Sem_Res is
Param1 := Make_String_Literal (Loc, Strval (N));
Params := New_List (Param1);
+ elsif Nkind (N) = N_Interpolated_String_Literal then
+ Param1 := New_Copy_Tree (N);
+ Params := New_List (Param1);
+
else
Param1 :=
Make_String_Literal
--
2.45.2
^ permalink raw reply [flat|nested] 7+ messages in thread
* [COMMITTED 4/7] ada: Fix array-manipulating code in Mdll
2024-06-27 8:52 [COMMITTED 1/7] ada: Implement first half of Generalized Finalization Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 2/7] ada: Overridden operation field not correctly set for controlling result wrappers Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 3/7] ada: Bug using user defined string literals with interpolated strings Marc Poulhiès
@ 2024-06-27 8:52 ` Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 5/7] ada: Add missing dimension information for target names Marc Poulhiès
` (2 subsequent siblings)
5 siblings, 0 replies; 7+ messages in thread
From: Marc Poulhiès @ 2024-06-27 8:52 UTC (permalink / raw)
To: gcc-patches; +Cc: Ronan Desplanques
From: Ronan Desplanques <desplanques@adacore.com>
This patch fixes a duo of array assigments in Mdll that were bound
to fail.
gcc/ada/
* mdll.adb (Build_Non_Reloc_DLL): Fix incorrect assignment
to array object.
(Ada_Build_Non_Reloc_DLL): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/mdll.adb | 43 ++++++++++++++++++++++++++-----------------
1 file changed, 26 insertions(+), 17 deletions(-)
diff --git a/gcc/ada/mdll.adb b/gcc/ada/mdll.adb
index 2f946b0a5bb..ac4af8363aa 100644
--- a/gcc/ada/mdll.adb
+++ b/gcc/ada/mdll.adb
@@ -322,17 +322,21 @@ package body MDLL is
-- Build the DLL
declare
- Params : OS_Lib.Argument_List :=
- Adr_Opt'Unchecked_Access & All_Options;
+ Params : constant OS_Lib.Argument_List :=
+ Map_Opt'Unchecked_Access &
+ Adr_Opt'Unchecked_Access & All_Options;
+ First_Param : Positive := Params'First + 1;
+
begin
if Map_File then
- Params := Map_Opt'Unchecked_Access & Params;
+ First_Param := Params'First;
end if;
- Utl.Gcc (Output_File => Dll_File,
- Files => Exp_File'Unchecked_Access & Ofiles,
- Options => Params,
- Build_Lib => True);
+ Utl.Gcc
+ (Output_File => Dll_File,
+ Files => Exp_File'Unchecked_Access & Ofiles,
+ Options => Params (First_Param .. Params'Last),
+ Build_Lib => True);
end;
OS_Lib.Delete_File (Exp_File, Success);
@@ -377,20 +381,25 @@ package body MDLL is
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
declare
- Params : OS_Lib.Argument_List :=
- Out_Opt'Unchecked_Access &
- Dll_File'Unchecked_Access &
- Lib_Opt'Unchecked_Access &
- Exp_File'Unchecked_Access &
- Adr_Opt'Unchecked_Access &
- Ofiles &
- All_Options;
+ Params : constant OS_Lib.Argument_List :=
+ Map_Opt'Unchecked_Access &
+ Out_Opt'Unchecked_Access &
+ Dll_File'Unchecked_Access &
+ Lib_Opt'Unchecked_Access &
+ Exp_File'Unchecked_Access &
+ Adr_Opt'Unchecked_Access &
+ Ofiles &
+ All_Options;
+ First_Param : Positive := Params'First + 1;
+
begin
if Map_File then
- Params := Map_Opt'Unchecked_Access & Params;
+ First_Param := Params'First;
end if;
- Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
+ Utl.Gnatlink
+ (L_Afiles (L_Afiles'Last).all,
+ Params (First_Param .. Params'Last));
end;
OS_Lib.Delete_File (Exp_File, Success);
--
2.45.2
^ permalink raw reply [flat|nested] 7+ messages in thread
* [COMMITTED 5/7] ada: Add missing dimension information for target names
2024-06-27 8:52 [COMMITTED 1/7] ada: Implement first half of Generalized Finalization Marc Poulhiès
` (2 preceding siblings ...)
2024-06-27 8:52 ` [COMMITTED 4/7] ada: Fix array-manipulating code in Mdll Marc Poulhiès
@ 2024-06-27 8:52 ` Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 6/7] ada: Reject ambiguous function calls in interpolated string expressions Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 7/7] ada: Remove last uses of System.Address_Operations in runtime library Marc Poulhiès
5 siblings, 0 replies; 7+ messages in thread
From: Marc Poulhiès @ 2024-06-27 8:52 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
It is computed from the Etype of N_Target_Name nodes.
gcc/ada/
* sem_ch5.adb (Analyze_Target_Name): Call Analyze_Dimension on the
node once the Etype is set.
* sem_dim.adb (OK_For_Dimension): Set to True for N_Target_Name.
(Analyze_Dimension): Call Analyze_Dimension_Has_Etype for it.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch5.adb | 1 +
gcc/ada/sem_dim.adb | 2 ++
2 files changed, 3 insertions(+)
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index b92ceb17b1b..644bd21ce93 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -4201,6 +4201,7 @@ package body Sem_Ch5 is
if Current = Expression (Context) then
pragma Assert (Context = Current_Assignment);
Set_Etype (N, Etype (Name (Current_Assignment)));
+ Analyze_Dimension (N);
else
Report_Error;
end if;
diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb
index 45a0f2ab922..39c36332497 100644
--- a/gcc/ada/sem_dim.adb
+++ b/gcc/ada/sem_dim.adb
@@ -219,6 +219,7 @@ package body Sem_Dim is
N_Real_Literal => True,
N_Selected_Component => True,
N_Slice => True,
+ N_Target_Name => True,
N_Type_Conversion => True,
N_Unchecked_Type_Conversion => True,
@@ -1179,6 +1180,7 @@ package body Sem_Dim is
| N_Qualified_Expression
| N_Selected_Component
| N_Slice
+ | N_Target_Name
| N_Unchecked_Type_Conversion
=>
Analyze_Dimension_Has_Etype (N);
--
2.45.2
^ permalink raw reply [flat|nested] 7+ messages in thread
* [COMMITTED 6/7] ada: Reject ambiguous function calls in interpolated string expressions
2024-06-27 8:52 [COMMITTED 1/7] ada: Implement first half of Generalized Finalization Marc Poulhiès
` (3 preceding siblings ...)
2024-06-27 8:52 ` [COMMITTED 5/7] ada: Add missing dimension information for target names Marc Poulhiès
@ 2024-06-27 8:52 ` Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 7/7] ada: Remove last uses of System.Address_Operations in runtime library Marc Poulhiès
5 siblings, 0 replies; 7+ messages in thread
From: Marc Poulhiès @ 2024-06-27 8:52 UTC (permalink / raw)
To: gcc-patches; +Cc: Javier Miranda
From: Javier Miranda <miranda@adacore.com>
gcc/ada/
* sem_ch2.adb (Analyze_Interpolated_String_Literal): Report
interpretations of ambiguous parameterless function calls.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch2.adb | 80 ++++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 79 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb
index 08cc75c9104..ddbb329d1f8 100644
--- a/gcc/ada/sem_ch2.adb
+++ b/gcc/ada/sem_ch2.adb
@@ -38,6 +38,8 @@ with Rident; use Rident;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
with Sem_Dim; use Sem_Dim;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
@@ -135,20 +137,96 @@ package body Sem_Ch2 is
-----------------------------------------
procedure Analyze_Interpolated_String_Literal (N : Node_Id) is
+
+ procedure Check_Ambiguous_Parameterless_Call (Func_Call : Node_Id);
+ -- Examine the interpretations of the call to the given parameterless
+ -- function call and report the location of each interpretation.
+
+ ----------------------------------------
+ -- Check_Ambiguous_Parameterless_Call --
+ ----------------------------------------
+
+ procedure Check_Ambiguous_Parameterless_Call (Func_Call : Node_Id) is
+
+ procedure Report_Interpretation (E : Entity_Id);
+ -- Report an interpretation of the function call
+
+ ---------------------------
+ -- Report_Interpretation --
+ ---------------------------
+
+ procedure Report_Interpretation (E : Entity_Id) is
+ begin
+ Error_Msg_Sloc := Sloc (E);
+
+ if Nkind (Parent (E)) = N_Full_Type_Declaration then
+ Error_Msg_N ("interpretation (inherited) #!", Func_Call);
+ else
+ Error_Msg_N ("interpretation #!", Func_Call);
+ end if;
+ end Report_Interpretation;
+
+ -- Local variables
+
+ Error_Reported : Boolean;
+ I : Interp_Index;
+ It : Interp;
+
+ -- Start of processing for Check_Ambiguous_Parameterless_Call
+
+ begin
+ Error_Reported := False;
+
+ -- Examine possible interpretations
+
+ Get_First_Interp (Name (Func_Call), I, It);
+ while Present (It.Nam) loop
+ if It.Nam /= Entity (Name (Func_Call))
+ and then Ekind (It.Nam) = E_Function
+ and then No (First_Formal (It.Nam))
+ then
+ if not Error_Reported then
+ Error_Msg_NE
+ ("ambiguous call to&", Func_Call,
+ Entity (Name (Func_Call)));
+ Report_Interpretation (Entity (Name (Func_Call)));
+ Error_Reported := True;
+ end if;
+
+ Report_Interpretation (It.Nam);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end Check_Ambiguous_Parameterless_Call;
+
+ -- Local variables
+
Str_Elem : Node_Id;
+ -- Start of processing for Analyze_Interpolated_String_Literal
+
begin
Set_Etype (N, Any_String);
Str_Elem := First (Expressions (N));
while Present (Str_Elem) loop
+
+ -- Before analyzed, a function call that has parameter is an
+ -- N_Indexed_Component node, and a call to a function that has
+ -- no parameters is an N_Identifier node.
+
Analyze (Str_Elem);
+ -- After analyzed, if it is still an N_Identifier node then we
+ -- found ambiguity and could not rewrite it as N_Function_Call.
+
if Nkind (Str_Elem) = N_Identifier
and then Ekind (Entity (Str_Elem)) = E_Function
and then Is_Overloaded (Str_Elem)
then
- Error_Msg_NE ("ambiguous call to&", Str_Elem, Entity (Str_Elem));
+ Check_Parameterless_Call (Str_Elem);
+ Check_Ambiguous_Parameterless_Call (Str_Elem);
end if;
Next (Str_Elem);
--
2.45.2
^ permalink raw reply [flat|nested] 7+ messages in thread
* [COMMITTED 7/7] ada: Remove last uses of System.Address_Operations in runtime library
2024-06-27 8:52 [COMMITTED 1/7] ada: Implement first half of Generalized Finalization Marc Poulhiès
` (4 preceding siblings ...)
2024-06-27 8:52 ` [COMMITTED 6/7] ada: Reject ambiguous function calls in interpolated string expressions Marc Poulhiès
@ 2024-06-27 8:52 ` Marc Poulhiès
5 siblings, 0 replies; 7+ messages in thread
From: Marc Poulhiès @ 2024-06-27 8:52 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
This completes the switch from using System.Address_Operations to using only
System.Storage_Elements in the runtime library. The remaining uses were for
simple optimizations that can be done by the optimizer alone.
gcc/ada/
* libgnat/s-carsi8.adb: Remove clauses for System.Address_Operations
and use only operations of System.Storage_Elements for addresses.
* libgnat/s-casi16.adb: Likewise.
* libgnat/s-casi32.adb: Likewise.
* libgnat/s-casi64.adb: Likewise.
* libgnat/s-casi128.adb: Likewise.
* libgnat/s-carun8.adb: Likewise.
* libgnat/s-caun16.adb: Likewise.
* libgnat/s-caun32.adb: Likewise.
* libgnat/s-caun64.adb: Likewise.
* libgnat/s-caun128.adb: Likewise.
* libgnat/s-geveop.adb: Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/libgnat/s-carsi8.adb | 8 +++++---
gcc/ada/libgnat/s-carun8.adb | 8 +++++---
gcc/ada/libgnat/s-casi128.adb | 7 ++++---
gcc/ada/libgnat/s-casi16.adb | 11 +++++++----
gcc/ada/libgnat/s-casi32.adb | 7 ++++---
gcc/ada/libgnat/s-casi64.adb | 7 ++++---
gcc/ada/libgnat/s-caun128.adb | 7 ++++---
gcc/ada/libgnat/s-caun16.adb | 11 +++++++----
gcc/ada/libgnat/s-caun32.adb | 7 ++++---
gcc/ada/libgnat/s-caun64.adb | 7 ++++---
gcc/ada/libgnat/s-geveop.adb | 33 ++++++++++++++++-----------------
11 files changed, 64 insertions(+), 49 deletions(-)
diff --git a/gcc/ada/libgnat/s-carsi8.adb b/gcc/ada/libgnat/s-carsi8.adb
index 2a6c532d247..7eb545a2657 100644
--- a/gcc/ada/libgnat/s-carsi8.adb
+++ b/gcc/ada/libgnat/s-carsi8.adb
@@ -29,8 +29,7 @@
-- --
------------------------------------------------------------------------------
-with System.Address_Operations; use System.Address_Operations;
-with System.Storage_Elements; use System.Storage_Elements;
+with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Conversion;
@@ -77,7 +76,10 @@ package body System.Compare_Array_Signed_8 is
begin
-- If operands are non-aligned, or length is too short, go by bytes
- if ModA (OrA (Left, Right), 4) /= 0 or else Compare_Len < 4 then
+ if Left mod Storage_Offset (4) /= 0
+ or else Right mod Storage_Offset (4) /= 0
+ or else Compare_Len < 4
+ then
return Compare_Array_S8_Unaligned (Left, Right, Left_Len, Right_Len);
end if;
diff --git a/gcc/ada/libgnat/s-carun8.adb b/gcc/ada/libgnat/s-carun8.adb
index 27422e5d728..e4cac204769 100644
--- a/gcc/ada/libgnat/s-carun8.adb
+++ b/gcc/ada/libgnat/s-carun8.adb
@@ -29,8 +29,7 @@
-- --
------------------------------------------------------------------------------
-with System.Address_Operations; use System.Address_Operations;
-with System.Storage_Elements; use System.Storage_Elements;
+with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Conversion;
@@ -76,7 +75,10 @@ package body System.Compare_Array_Unsigned_8 is
begin
-- If operands are non-aligned, or length is too short, go by bytes
- if ModA (OrA (Left, Right), 4) /= 0 or else Compare_Len < 4 then
+ if Left mod Storage_Offset (4) /= 0
+ or else Right mod Storage_Offset (4) /= 0
+ or else Compare_Len < 4
+ then
return Compare_Array_U8_Unaligned (Left, Right, Left_Len, Right_Len);
end if;
diff --git a/gcc/ada/libgnat/s-casi128.adb b/gcc/ada/libgnat/s-casi128.adb
index 3d3614136a7..1b65c8c86ef 100644
--- a/gcc/ada/libgnat/s-casi128.adb
+++ b/gcc/ada/libgnat/s-casi128.adb
@@ -29,8 +29,7 @@
-- --
------------------------------------------------------------------------------
-with System.Address_Operations; use System.Address_Operations;
-with System.Storage_Elements; use System.Storage_Elements;
+with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Conversion;
@@ -70,7 +69,9 @@ package body System.Compare_Array_Signed_128 is
begin
-- Case of going by aligned quadruple words
- if ModA (OrA (Left, Right), 16) = 0 then
+ if Left mod Storage_Offset (16) = 0
+ and then Right mod Storage_Offset (16) = 0
+ then
while Clen /= 0 loop
if W (L).all /= W (R).all then
if W (L).all > W (R).all then
diff --git a/gcc/ada/libgnat/s-casi16.adb b/gcc/ada/libgnat/s-casi16.adb
index 01771d1f8ff..e3411c978c5 100644
--- a/gcc/ada/libgnat/s-casi16.adb
+++ b/gcc/ada/libgnat/s-casi16.adb
@@ -29,8 +29,7 @@
-- --
------------------------------------------------------------------------------
-with System.Address_Operations; use System.Address_Operations;
-with System.Storage_Elements; use System.Storage_Elements;
+with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Conversion;
@@ -78,7 +77,9 @@ package body System.Compare_Array_Signed_16 is
begin
-- Go by words if possible
- if ModA (OrA (Left, Right), 4) = 0 then
+ if Left mod Storage_Offset (4) = 0
+ and then Right mod Storage_Offset (4) = 0
+ then
while Clen > 1
and then W (L).all = W (R).all
loop
@@ -90,7 +91,9 @@ package body System.Compare_Array_Signed_16 is
-- Case of going by aligned half words
- if ModA (OrA (Left, Right), 2) = 0 then
+ if Left mod Storage_Offset (2) = 0
+ and then Right mod Storage_Offset (2) = 0
+ then
while Clen /= 0 loop
if H (L).all /= H (R).all then
if H (L).all > H (R).all then
diff --git a/gcc/ada/libgnat/s-casi32.adb b/gcc/ada/libgnat/s-casi32.adb
index 24ad9ef90b9..43e47170606 100644
--- a/gcc/ada/libgnat/s-casi32.adb
+++ b/gcc/ada/libgnat/s-casi32.adb
@@ -29,8 +29,7 @@
-- --
------------------------------------------------------------------------------
-with System.Address_Operations; use System.Address_Operations;
-with System.Storage_Elements; use System.Storage_Elements;
+with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Conversion;
@@ -73,7 +72,9 @@ package body System.Compare_Array_Signed_32 is
begin
-- Case of going by aligned words
- if ModA (OrA (Left, Right), 4) = 0 then
+ if Left mod Storage_Offset (4) = 0
+ and then Right mod Storage_Offset (4) = 0
+ then
while Clen /= 0 loop
if W (L).all /= W (R).all then
if W (L).all > W (R).all then
diff --git a/gcc/ada/libgnat/s-casi64.adb b/gcc/ada/libgnat/s-casi64.adb
index bcadea106c7..0625d1f5d74 100644
--- a/gcc/ada/libgnat/s-casi64.adb
+++ b/gcc/ada/libgnat/s-casi64.adb
@@ -29,8 +29,7 @@
-- --
------------------------------------------------------------------------------
-with System.Address_Operations; use System.Address_Operations;
-with System.Storage_Elements; use System.Storage_Elements;
+with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Conversion;
@@ -73,7 +72,9 @@ package body System.Compare_Array_Signed_64 is
begin
-- Case of going by aligned double words
- if ModA (OrA (Left, Right), 8) = 0 then
+ if Left mod Storage_Offset (8) = 0
+ and then Right mod Storage_Offset (8) = 0
+ then
while Clen /= 0 loop
if W (L).all /= W (R).all then
if W (L).all > W (R).all then
diff --git a/gcc/ada/libgnat/s-caun128.adb b/gcc/ada/libgnat/s-caun128.adb
index 113c4d4237b..f16f1348361 100644
--- a/gcc/ada/libgnat/s-caun128.adb
+++ b/gcc/ada/libgnat/s-caun128.adb
@@ -29,8 +29,7 @@
-- --
------------------------------------------------------------------------------
-with System.Address_Operations; use System.Address_Operations;
-with System.Storage_Elements; use System.Storage_Elements;
+with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Conversion;
@@ -69,7 +68,9 @@ package body System.Compare_Array_Unsigned_128 is
begin
-- Case of going by aligned quadruple words
- if ModA (OrA (Left, Right), 16) = 0 then
+ if Left mod Storage_Offset (16) = 0
+ and then Right mod Storage_Offset (16) = 0
+ then
while Clen /= 0 loop
if W (L).all /= W (R).all then
if W (L).all > W (R).all then
diff --git a/gcc/ada/libgnat/s-caun16.adb b/gcc/ada/libgnat/s-caun16.adb
index 82f9d5b5afe..77a617ebb47 100644
--- a/gcc/ada/libgnat/s-caun16.adb
+++ b/gcc/ada/libgnat/s-caun16.adb
@@ -29,8 +29,7 @@
-- --
------------------------------------------------------------------------------
-with System.Address_Operations; use System.Address_Operations;
-with System.Storage_Elements; use System.Storage_Elements;
+with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Conversion;
@@ -78,7 +77,9 @@ package body System.Compare_Array_Unsigned_16 is
begin
-- Go by words if possible
- if ModA (OrA (Left, Right), 4) = 0 then
+ if Left mod Storage_Offset (4) = 0
+ and then Right mod Storage_Offset (4) = 0
+ then
while Clen > 1
and then W (L).all = W (R).all
loop
@@ -90,7 +91,9 @@ package body System.Compare_Array_Unsigned_16 is
-- Case of going by aligned half words
- if ModA (OrA (Left, Right), 2) = 0 then
+ if Left mod Storage_Offset (2) = 0
+ and then Right mod Storage_Offset (2) = 0
+ then
while Clen /= 0 loop
if H (L).all /= H (R).all then
if H (L).all > H (R).all then
diff --git a/gcc/ada/libgnat/s-caun32.adb b/gcc/ada/libgnat/s-caun32.adb
index 0be3a2ddc73..6bd31f59c98 100644
--- a/gcc/ada/libgnat/s-caun32.adb
+++ b/gcc/ada/libgnat/s-caun32.adb
@@ -29,8 +29,7 @@
-- --
------------------------------------------------------------------------------
-with System.Address_Operations; use System.Address_Operations;
-with System.Storage_Elements; use System.Storage_Elements;
+with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Conversion;
@@ -73,7 +72,9 @@ package body System.Compare_Array_Unsigned_32 is
begin
-- Case of going by aligned words
- if ModA (OrA (Left, Right), 4) = 0 then
+ if Left mod Storage_Offset (4) = 0
+ and then Right mod Storage_Offset (4) = 0
+ then
while Clen /= 0 loop
if W (L).all /= W (R).all then
if W (L).all > W (R).all then
diff --git a/gcc/ada/libgnat/s-caun64.adb b/gcc/ada/libgnat/s-caun64.adb
index 92d7d13b1a8..1018cbe1343 100644
--- a/gcc/ada/libgnat/s-caun64.adb
+++ b/gcc/ada/libgnat/s-caun64.adb
@@ -29,8 +29,7 @@
-- --
------------------------------------------------------------------------------
-with System.Address_Operations; use System.Address_Operations;
-with System.Storage_Elements; use System.Storage_Elements;
+with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Conversion;
@@ -72,7 +71,9 @@ package body System.Compare_Array_Unsigned_64 is
begin
-- Case of going by aligned double words
- if ModA (OrA (Left, Right), 8) = 0 then
+ if Left mod Storage_Offset (8) = 0
+ and then Right mod Storage_Offset (8) = 0
+ then
while Clen /= 0 loop
if W (L).all /= W (R).all then
if W (L).all > W (R).all then
diff --git a/gcc/ada/libgnat/s-geveop.adb b/gcc/ada/libgnat/s-geveop.adb
index 2f679b4d244..ab8ac1e085a 100644
--- a/gcc/ada/libgnat/s-geveop.adb
+++ b/gcc/ada/libgnat/s-geveop.adb
@@ -29,8 +29,7 @@
-- --
------------------------------------------------------------------------------
-with System.Address_Operations; use System.Address_Operations;
-with System.Storage_Elements; use System.Storage_Elements;
+with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Conversion;
@@ -49,15 +48,10 @@ package body System.Generic_Vector_Operations is
(R, X, Y : System.Address;
Length : System.Storage_Elements.Storage_Count)
is
- RA : Address := R;
- XA : Address := X;
- YA : Address := Y;
- -- Address of next element to process in R, X and Y
-
VI : constant Integer_Address := Integer_Address (VU);
Unaligned : constant Integer_Address :=
- Boolean'Pos (OrA (OrA (RA, XA), YA) mod VU /= 0) - 1;
+ (if R mod VU /= 0 or X mod VU /= 0 or Y mod VU /= 0 then 0 else -1);
-- Zero iff one or more argument addresses is not aligned, else all 1's
type Vector_Ptr is access all Vectors.Vector;
@@ -74,10 +68,15 @@ package body System.Generic_Vector_Operations is
-- Vector'Size > Storage_Unit
-- VI > 0
SA : constant Address :=
- XA + Storage_Offset
- ((Integer_Address (Length) / VI * VI) and Unaligned);
+ X + Storage_Offset
+ ((Integer_Address (Length) / VI * VI) and Unaligned);
-- First address of argument X to start serial processing
+ RA : Address := R;
+ XA : Address := X;
+ YA : Address := Y;
+ -- Address of next element to process in R, X and Y
+
begin
while XA < SA loop
VP (RA).all := Vector_Op (VP (XA).all, VP (YA).all);
@@ -102,14 +101,10 @@ package body System.Generic_Vector_Operations is
(R, X : System.Address;
Length : System.Storage_Elements.Storage_Count)
is
- RA : Address := R;
- XA : Address := X;
- -- Address of next element to process in R and X
-
VI : constant Integer_Address := Integer_Address (VU);
Unaligned : constant Integer_Address :=
- Boolean'Pos (OrA (RA, XA) mod VU /= 0) - 1;
+ (if R mod VU /= 0 or X mod VU /= 0 then 0 else -1);
-- Zero iff one or more argument addresses is not aligned, else all 1's
type Vector_Ptr is access all Vectors.Vector;
@@ -126,10 +121,14 @@ package body System.Generic_Vector_Operations is
-- Vector'Size > Storage_Unit
-- VI > 0
SA : constant Address :=
- XA + Storage_Offset
- ((Integer_Address (Length) / VI * VI) and Unaligned);
+ X + Storage_Offset
+ ((Integer_Address (Length) / VI * VI) and Unaligned);
-- First address of argument X to start serial processing
+ RA : Address := R;
+ XA : Address := X;
+ -- Address of next element to process in R and X
+
begin
while XA < SA loop
VP (RA).all := Vector_Op (VP (XA).all);
--
2.45.2
^ permalink raw reply [flat|nested] 7+ messages in thread
end of thread, other threads:[~2024-06-27 8:52 UTC | newest]
Thread overview: 7+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-06-27 8:52 [COMMITTED 1/7] ada: Implement first half of Generalized Finalization Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 2/7] ada: Overridden operation field not correctly set for controlling result wrappers Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 3/7] ada: Bug using user defined string literals with interpolated strings Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 4/7] ada: Fix array-manipulating code in Mdll Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 5/7] ada: Add missing dimension information for target names Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 6/7] ada: Reject ambiguous function calls in interpolated string expressions Marc Poulhiès
2024-06-27 8:52 ` [COMMITTED 7/7] ada: Remove last uses of System.Address_Operations in runtime library Marc Poulhiès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).