From patchwork Thu Jun 27 08:52:24 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 1953076 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=ETO9xU6j; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4W8srG2rKvz20XB for ; Thu, 27 Jun 2024 18:56:46 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id EA1E13838A24 for ; Thu, 27 Jun 2024 08:56:43 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-lj1-x22a.google.com (mail-lj1-x22a.google.com [IPv6:2a00:1450:4864:20::22a]) by sourceware.org (Postfix) with ESMTPS id 68A313838A24 for ; Thu, 27 Jun 2024 08:52:45 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 68A313838A24 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 68A313838A24 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::22a ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1719478379; cv=none; b=PwtSQgYxEerLXFjwb+EoR6qqbUTjccI+zJ+ffxJop3YZ6WmtdshfmjEAQUhIE1LUceXgAVIgK6cDCFrn9yiK9I1b0P64eejUtAghlVSSq50QgsRawEJhWQuu5lImV6l0ettymSIloPs+B1Udfr09G/pXvj7lMSuFch8rAO5yhsI= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1719478379; c=relaxed/simple; bh=wl0ms/qMemUPsOheTwtKEwA0Q5bXKEA8l54gnzzUcPE=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=eGpifvqrlK57XeDQYmPhbztdb/w/zXBeuHeA2kpX5azMXJbnCqHQ7IsRgnLyQ8B+P/+49a6E1ZsLKrmYvyyN6qVh0xGTCONqAYxQBplkDDLAQUsqR16zmMjmyc1QDYU+ptdUbWp8TInICobgYuVVjJsv6SKPw6yQijOk2xeQElw= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-lj1-x22a.google.com with SMTP id 38308e7fff4ca-2ebeefb9a7fso93879071fa.0 for ; Thu, 27 Jun 2024 01:52:45 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1719478364; x=1720083164; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=O1mk3oUyupH3MqxRGBf/Iz39pUZVL9dFyl7ungzYCkE=; b=ETO9xU6jgMOORApyEXzAlYe8P3q5HrE7qWAI/Qephcix+tFOlz5CoNulEVozM7lbu4 Gq/xHV5b5NDC6g8uEsnbeEL9Ygm4w/R179MRRJgouUkcbmo6enK4u8C+o1AdzfRq3vmb l4WiGzdZce02wNWgPqmjP8kwmMehK6mH86T9WJa0C0tOSRWJdic195SrDoiuy+4r6bUy hVzAm2vxMRmHhOPppE6+73VcnI3pLAMPXc86MiRZGcWQHBVE2Y/kc8hKiGJ2Uh1krsHh E+KJczzt4YwzBNewwBVOv2qSpg4YZL5wcgSa1ClMTRgKK4SBjFXm1jLLVqo71Qy92ZBl pVWg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1719478364; x=1720083164; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=O1mk3oUyupH3MqxRGBf/Iz39pUZVL9dFyl7ungzYCkE=; b=ARSIdrbfrMtFs9gpgP1PUhqlCIFKI8vornJp7amhHbAwsleXcIAdV+iHn38G5zoque pgJrQsrJCBbUt8su4dOk3JLxEeRvlk486mwCAwTaR0P0LswuhrA1z/iJSCCU201DwkEm mDHdg0LwqPYGz9hOkr97NGWf/RWjHvlE30sxwexbrtC8EjATnBP0AMBBAjOykKPTCZwb ifC8XrHNEtal2r/Kb7GOzHHvSG3uL7YJZfJiU/WrTlv+aIjThGbb92IHxE7Q1ZX92YQn oYnBigRidDemEMxtNO85cFu5YOOKuAVwTiilF+Q8XrDruL0xgcSUKB4N+p4/iww1VmAi /idA== X-Gm-Message-State: AOJu0YzBLKCcSas1ND/KRkLNe4dbC/MyM4S71GLEm1Wiq/7c6NaJjtxz 9+hJLyw9ZfA0cID7iEp7hMwQZtXr0bUP8co0089n9qsdfG+P8SlptHhX5Sp0te8Mv0GvJNBGcAc = X-Google-Smtp-Source: AGHT+IGQa3kfH+LpNZDwEYa1S+/JqZy5vSSpNe1YyMpDZvr3e+lQR/BEq+NNH8hfPcbihiZC2DrxXA== X-Received: by 2002:a2e:9b94:0:b0:2ec:c8:2755 with SMTP id 38308e7fff4ca-2ec57983763mr80577581fa.24.1719478362569; Thu, 27 Jun 2024 01:52:42 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:2a5d:d7ee:58d:fee4]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-3674357c14fsm1149133f8f.16.2024.06.27.01.52.41 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 27 Jun 2024 01:52:41 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 1/7] ada: Implement first half of Generalized Finalization Date: Thu, 27 Jun 2024 10:52:24 +0200 Message-ID: <20240627085232.226541-1-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 MIME-Version: 1.0 X-Spam-Status: No, score=-13.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org From: Eric Botcazou 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) : 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 X-Patchwork-Id: 1953069 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=CvrJcem6; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4W8snR2y7Mz20Xg for ; Thu, 27 Jun 2024 18:54:19 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 7D110383640D for ; Thu, 27 Jun 2024 08:54:17 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42f.google.com (mail-wr1-x42f.google.com [IPv6:2a00:1450:4864:20::42f]) by sourceware.org (Postfix) with ESMTPS id 03C323838A09 for ; Thu, 27 Jun 2024 08:52:45 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 03C323838A09 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 03C323838A09 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::42f ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1719478370; cv=none; b=wtlf+RYKPLMit4WIquGihe5A2bECSlG/ntP1RDfJcKQpFiBZF3xoBnuQLjv7K/Y0UGGmKUWFzlF0OVCClzbRau4MWb0PAkNXDyxJfmr8kEZ2FsMxo9LlmeTsnSDQsXyLGrg7DlKjqvJeJ3IjmQVjZfsBWLFMsPKXELzMm5SCEMM= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1719478370; c=relaxed/simple; bh=wYC/fUKLkEVhErD9C1FkT1nQoRIQxRwylgtGgcwPw0k=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=vzsJtIIm/K5iBM2D9EAS/iz+HxNv4pA3ZNkxdt4PRSgudsgo6m2lIjtYoq2QnqbhbJQe3r03cHGJ7ABfy2HfgeJgftQfe2yDv0GWpzhwP+D2nr6IfoAAgvrgUP+ap2QdU2FJNTnj9oOr+OXB6zmpiKhd4JVWnuGwf2bI4nvoZaY= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x42f.google.com with SMTP id ffacd0b85a97d-35f06861ae6so5790100f8f.2 for ; Thu, 27 Jun 2024 01:52:44 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1719478364; x=1720083164; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=/y7QigmNVR+EVerw4xn8tk9cgH6UvGgQxTDIeymf50I=; b=CvrJcem6Rns9gvKI87+Kz47LEbcnwf6+FwBu0TVn1PqPuckp7rXdv49Rjek16/v8HA pjHdzh6Tldsn4XgQejjZa9lbdxHl01YdB7OufcJBp3UcUag91aEQbAaZs3rakT60MU8f v1TiZbxB/9QZ9lz4ssrbGERnbAHbI17Efe3H/uwXoUZgJCWTresBUSGRDre3LbdTGoPW GoOuAbL8V+UgE6UHi4tnI1XW/rjoLT9Vgbnm3bwGoGFq5sunX0KtN0/eR8lMUb2F/Jao dhZ7LquW9pmFDQ/ZhdRKtdgFCIrpeyvnA0V/6WivLIz7Qk4I2t1q6xD7DltyJ5mizlQj ofAQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1719478364; x=1720083164; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=/y7QigmNVR+EVerw4xn8tk9cgH6UvGgQxTDIeymf50I=; b=apcKXH8A94rD72+Q6ojkTO99BbxC/MqnCNSYrKqVpZoZlcpnQ/TvMmPOj8oT2Y01T0 J9qOrYsG99/7RcJqMrlzjUgcUJq83Vcww6GOLziSFXKCnZhGqi5RB+UGOsII6dT2ey+n /Li2Mh0EB67Z9RtK/I2ORWRKjF57AbOyXBl7HjghGEXGbPtlmBz2nK5o3xk6LRlGvIoH +nE4YZR+2CzBMp9Q2cVN5GL5Yugk2Ec/Gr/tOzcYWihXQKNJ3TvbjLfaawbCGOda1izQ 66+GR9NrKEYMYbhqHkCd1aPHXxw6scuiNFBhRFikr4aukDbXx96Gch1cf1Z1SxqAzpwt EAng== X-Gm-Message-State: AOJu0YwTfY/8dBLcJGlKdxxYA9Cn0fL9eApOny33bms5LNAlQckjkuAS NIg3GdrkQULt/hOXLTuSVjfRhjXPkcAi9oQm6Ex9F+/NvVsGOkZV6OeQJnV1xC8ZottJAc27G2E = X-Google-Smtp-Source: AGHT+IFy05U090RPHBUEVNb+rY3E8Pnh9hGqFFzPz0qVSb4n39N4pQDR4pX8KT+yveBSBBLRK8Hujg== X-Received: by 2002:a05:6000:154d:b0:360:89a3:5293 with SMTP id ffacd0b85a97d-366e93b18f9mr10818615f8f.0.1719478363580; Thu, 27 Jun 2024 01:52:43 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:2a5d:d7ee:58d:fee4]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-3674357c14fsm1149133f8f.16.2024.06.27.01.52.42 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 27 Jun 2024 01:52:43 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Martin Clochard Subject: [COMMITTED 2/7] ada: Overridden operation field not correctly set for controlling result wrappers Date: Thu, 27 Jun 2024 10:52:25 +0200 Message-ID: <20240627085232.226541-2-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240627085232.226541-1-poulhies@adacore.com> References: <20240627085232.226541-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org From: Martin Clochard 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 From patchwork Thu Jun 27 08:52:26 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 1953070 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=Hsyq0cxM; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4W8snk51Nzz20Xg for ; Thu, 27 Jun 2024 18:54:34 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id C24213838A2C for ; Thu, 27 Jun 2024 08:54:32 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-lf1-x12f.google.com (mail-lf1-x12f.google.com [IPv6:2a00:1450:4864:20::12f]) by sourceware.org (Postfix) with ESMTPS id E43DE3838A1E for ; Thu, 27 Jun 2024 08:52:45 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org E43DE3838A1E Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org E43DE3838A1E Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::12f ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1719478370; cv=none; b=lVmfIuQB6OBB7JX4sM1iIQo1Rky2SUWupI6e78wq3k71xCji+YZPBSdPkbpnYxen1trk7SW9o6FhBEAOL+6wAlaUDN5mO+H1D/xq1BOAHfx5PSjScuQdew9hlbjcD7XKeZv0l5QScMWsDX5ScUF0TR6rOlsisE+2e3gutK+4Kuw= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1719478370; c=relaxed/simple; bh=1m0T7O5GEQfmazRqsR2by4p5+kqdcSkA6vWs9qD7sT4=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=edGGnLcGL8uewz91KN26q97IIMvlVOrbeVDxBO4slRdiZ8s1MrPBHpg6zFUsOpFCGUKV5mJXh2lHfRMq2owxBBRj9C/d8AFSHQ/TR5p+av2OYNYaWbMN234yutavnEwcvMeCW9zSdsUMRCzYCSQUlTrzgBCDE87ZF453AoRmH/o= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-lf1-x12f.google.com with SMTP id 2adb3069b0e04-52cd8897c73so6715875e87.2 for ; Thu, 27 Jun 2024 01:52:45 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1719478364; x=1720083164; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=zvHGTnXYj0eGFZjCnQftmkdH2dkGVtyaohOpWBl/wII=; b=Hsyq0cxMymrnMgH761E7S/t5h3WBFOV9VCAfJq5JannDEhA5NNMcmqmNPiorsImSYE McFxxh0BGAz4KS6HVJ8cGavwCEiu2t/Q8lIX6/D4RHB0JP9Fh9siFRFUW2qHlf9tbpVC 9V5n3K5sv7xNm52TIPP3kVIbtqXbC6j+6mByjzulcWPiMMHJN2tEMXG+oUA1uXnbzcsX 4MF7Z0uE5bUfYB/TbhRjqHm52ZvDPi+7+iPeERzYuvf631xnOpN4n7bJ9F6VMjNvhsGB gxlfxslTEgQB6raS78dsQB9tVeP0RxsgbAuV3Ck2ISh4CtCs/9VM4V3+kNK++ju+9RzK pNfA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1719478364; x=1720083164; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=zvHGTnXYj0eGFZjCnQftmkdH2dkGVtyaohOpWBl/wII=; b=YblWyOZpkDdFL7xppFwRwcVM/I5St37MgEWqiUXA7nrNmT1vneG1c23z9RTywxxgrl i3TQug+zUDCbPrufLIRj3B0BiE+vYsSFmQagGBlwh/KV1/f+KxKopd/9axTunrZ0wbjc POJvyjJ2sXNc1PKMCXHvx/jzB6lFoeusKSWQYMOZKEN1SkPdpeZ6f27lnBq/MAqxMzeh OKcbsiPITv8XjRDl0ui2a2QunJY7qZoIJFdHbbWVNm0qTgnIhQjIHmcV6us5f3YZrxiX GzIhBeOZqAujF1KPH2d4Mm+NLrG/w2aI0oUuCQkyUYN3u11UhrfDtL2TmtVyqOGQ2nP8 zlVg== X-Gm-Message-State: AOJu0YxlKyH9iCqz8rtPDojr8Zzb/nJrGf3xX88f05om/89ar43v746g ijsK5F+0yXQUa9UjY8yGem6IVDTMV4aE7z0Qvfcf1WTvFNE79AvZ9C34RVFfvEKiCj6bb29x7FA = X-Google-Smtp-Source: AGHT+IFaieFS/Qs3ONMVcxQjE6ius9MqdOkdM4JIzkH0vzYVO0QmXHzu1D1Hwz2hLrVKVQNlIdj3mg== X-Received: by 2002:ac2:544f:0:b0:52c:d626:77aa with SMTP id 2adb3069b0e04-52ce18644a1mr7512194e87.58.1719478364405; Thu, 27 Jun 2024 01:52:44 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:2a5d:d7ee:58d:fee4]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-3674357c14fsm1149133f8f.16.2024.06.27.01.52.43 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 27 Jun 2024 01:52:43 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [COMMITTED 3/7] ada: Bug using user defined string literals with interpolated strings Date: Thu, 27 Jun 2024 10:52:26 +0200 Message-ID: <20240627085232.226541-3-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240627085232.226541-1-poulhies@adacore.com> References: <20240627085232.226541-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org From: Javier Miranda 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 From patchwork Thu Jun 27 08:52:27 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 1953073 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=Dn3GHG36; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4W8spz2fdLz20XB for ; Thu, 27 Jun 2024 18:55:39 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 9778A38346B8 for ; Thu, 27 Jun 2024 08:55:37 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42c.google.com (mail-wr1-x42c.google.com [IPv6:2a00:1450:4864:20::42c]) by sourceware.org (Postfix) with ESMTPS id 7DC0B3836E9D for ; Thu, 27 Jun 2024 08:52:46 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 7DC0B3836E9D Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 7DC0B3836E9D Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::42c ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1719478375; cv=none; b=rUByf7RfKWrOuxPCDO3PvPQYlyRsEIlFETqMPGbvWpplv5CXHlXh1MS3Q6omhO/g4BENxnI8oZSDD9QAMietk0TFw5Fw54vBNwrh3Hto8kHVOZDMtT89nudNZipavyT/wp9VZsYtU4w5CUD5XmMQk8qyC/cqhKNIXhe6qzTz8ig= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1719478375; c=relaxed/simple; bh=vbdcdhvwaUCv9VoFtF9ejmypjXYRFdW5ZniaOyJWUhc=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=J4pKo8C+RSzSDuFNHkFrPhX6StglbqCQ/touo1d016BriPorGT1ZtB8pS9EvU0OY4/6MDQh+ju5z6oVtSpuKqr+OEwUtXAsP0YZezxg/7uSoFHsQwTcBUaWL/SITnArPolN+oFu3K65ffnSYB0AA8CEPsru/WClhLIzm7YBMcmI= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x42c.google.com with SMTP id ffacd0b85a97d-356c4e926a3so6762863f8f.1 for ; Thu, 27 Jun 2024 01:52:46 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1719478365; x=1720083165; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=csdUnTw0wIspiord21xrViilb5ZGuXsb175rwk/7zkE=; b=Dn3GHG36kGCCL4/qRJviZ+gbFI6tmXNytibOwxya+NkF4T25q2ppnyffXXbUef3Z+l WwLcOm0HPF+CmOBBV9GFS+2siq4kHawl1Gu5Xbk6edpARQW7kBpmbiM/PXOk/dxuauNl Hy1RN7oByjiJapY5t3fhi15ZsDTAvmlumFDU/VwZ9NFQjQaVWxugM5Bzjthc+2yNBNMp fUEK4n4Bn/h1ki+YfP0tWll1zIxDhG0pjvt28y6qiZoLzbBck0bJmNt1Ow3aKcI3ahPG Be8eIQ8fbKmkBFREAlRPUtn+Eow9DgA6xn6NKkEO+yVeiFbH4dR7UylcUIru7FXYVfmg EDBw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1719478365; x=1720083165; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=csdUnTw0wIspiord21xrViilb5ZGuXsb175rwk/7zkE=; b=WpBgslI0GTX4637OzDrtjpXMa4E1KE8cSEYGscNdZ53tJq2Fwk6ezavI16w1okFV6L AUnTYRXXE8erd08xkKz2yhKzap2imWyAl6WQ0B2QghEBn2TkmBce9Dc2kGUzuzg4ixAi 8UjsE++5HQkcxH9NTihNWsKK/uJI9LyfdRYF7tRgObuxKI+mfSWcF4sCuuBcgzM+s40d YSDNRAbCC/tUiyP2mU7RaK5ZDMtbedW0gB1T2eQFRy4JBjm0N6WgHnaE7vUYj8w0i+XK CTC5x4Ms+idcaAVpAS62gG1qwxcT+A2efKO1H2atpH6avLytvhXa7pASTWcDyFgYADKp 3H+A== X-Gm-Message-State: AOJu0YwCRsPx6wN7Gpxbrd03twyAPfZYDyFplr6MOm7ORFfdbgycfYXM R+JlL4owMgN8pTjGamuHgSaViqD/unpHqyDX0kAnxNzEci1oKx5vW6pFXcsVjKekla706nFrXJ8 = X-Google-Smtp-Source: AGHT+IGCCIPOAPnX7aoKOk8xqPk4SoZq7Mn/76b4BrfHwSag7ZUEexu7rDL5VBsA3xNStwCUd3EkLA== X-Received: by 2002:a05:6000:184d:b0:366:ebc4:2574 with SMTP id ffacd0b85a97d-366ebc425fdmr9301085f8f.33.1719478365269; Thu, 27 Jun 2024 01:52:45 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:2a5d:d7ee:58d:fee4]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-3674357c14fsm1149133f8f.16.2024.06.27.01.52.44 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 27 Jun 2024 01:52:44 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Ronan Desplanques Subject: [COMMITTED 4/7] ada: Fix array-manipulating code in Mdll Date: Thu, 27 Jun 2024 10:52:27 +0200 Message-ID: <20240627085232.226541-4-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240627085232.226541-1-poulhies@adacore.com> References: <20240627085232.226541-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org From: Ronan Desplanques 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); From patchwork Thu Jun 27 08:52:28 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 1953074 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=RKE9tWkK; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4W8sr44CMQz20XB for ; Thu, 27 Jun 2024 18:56:36 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id B2F90383600F for ; Thu, 27 Jun 2024 08:56:34 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42f.google.com (mail-wr1-x42f.google.com [IPv6:2a00:1450:4864:20::42f]) by sourceware.org (Postfix) with ESMTPS id 3FB703838A1B for ; Thu, 27 Jun 2024 08:52:47 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 3FB703838A1B Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 3FB703838A1B Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::42f ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1719478377; cv=none; b=iUBoRTWXQHcQSAp0pAVvvpoQsP7swk/I4Df92qfU/6KpbXGH/r52cUTkdT5KhyAh7Df/ecJjfbZMoBiM5aDatcS71kSCoJcR9+RMNWiwDucpiZVAOP3FrcEvo5jv0lSWtGPXUnJ7FFuLgRKo25TtPlUluQdStAnoY9pWaWyDjpE= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1719478377; c=relaxed/simple; bh=LNaxmJr5Pbbz1TXazoXqNj3y0VaFNiWWjX5L12tv130=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=sQSthqsCHAFdvnYzUFdP/N6iUbq6j/PHN90haZYEk534vCjub2PuKtODclLJt22sZPZH2y+5kVcWzZ57o3Vz1S/Rqp1TXKsAxzAMXoMJwRU0mKSSJlC7y8otS9Mq7pcMy9pDl3sQw0c3GT3csa+SipWWt5XVIvIYMX8Qn4tbTek= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x42f.google.com with SMTP id ffacd0b85a97d-35f090093d8so5013539f8f.0 for ; Thu, 27 Jun 2024 01:52:47 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1719478366; x=1720083166; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=ooNpRkwCSk9sY5qKaNpX8BWpE+7KCugZ5+T9QKvlvsU=; b=RKE9tWkKLiREt9FJiI8nAeSbUWbn1Sf2OSeRH7u/StH/YZpznra2qcPdGjk3PqkOOc ArFOJAGGje3bOoNS11P1vvwn39IGl84L0/LKuztkZjH3Tq33ypHmm4zCBlIf1fveu4k2 34Fe6aJvRqQ0URoykMxANiUBpHXqP4x+YR5RW4nXskWDm95dlFcAQUVEX13UziQbYYVF ScdUZY03vhK6LS1AxJTNzBj0zkTKlCEMdjsqLBdUcJE+eb+Wc9OiJA0TyhDLZ0IiWue6 RoG0BIHfiW1VhKJbHB2yhPKD+GkIOkQWVMcYoZcHNUFO4ZQyh/7GmAzKoA6noYGSmuwK ru0g== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1719478366; x=1720083166; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=ooNpRkwCSk9sY5qKaNpX8BWpE+7KCugZ5+T9QKvlvsU=; b=oSuaDlT/QWEEEmx40l/G99m+Kkcxd+HEr7WmtfvTRsr+ozNpk7sJ5sh81s8Gz8WSyX 6eEwT+fjk39r9R2U7zbcbu9P/bvkj0X9Kv79ZSAJyjCOaDxTbh7yTTuuuPsidxLg1W3V f3zUK3iU0wsNfggJc6j0qDSD67/yAx7tbZNSiGGy+83ynqHWiTgRR5GVcbdmtGjjqNLy w2XvNjbf/YAIwCEIWGJcaGBpzEWrM4yoGAcILUDZVm8X+EPZpnhU/98/9oeZQ1gyHiq4 kjdlKgirmgXnYVsnX3smKpe9LkC2QhC47I8RUGOWJpGzaiFSUCxXTlHyeQXP/TaEBsbD Yhhg== X-Gm-Message-State: AOJu0YyjTLVYrv4RmIPBlvjF1M+1Wv0i1ZzQCiQurt6I3GrPVhLej9zZ ILSVJ08Lo0C5fFJXWtj7yTpl2KnNKZo6OOwwD/77qG6yfn4AQrVWQc7fmUCJb37/ST0hm+CvvCo = X-Google-Smtp-Source: AGHT+IEqoxQlpfSLB3gjBKjstvWCn6dIWLEqJXeDLxY8sThPsWvRnpr8yBxHxVzdifmxaNl+2t+GJw== X-Received: by 2002:a5d:68d2:0:b0:362:41a4:974d with SMTP id ffacd0b85a97d-366e7a56ecfmr8713784f8f.46.1719478366061; Thu, 27 Jun 2024 01:52:46 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:2a5d:d7ee:58d:fee4]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-3674357c14fsm1149133f8f.16.2024.06.27.01.52.45 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 27 Jun 2024 01:52:45 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 5/7] ada: Add missing dimension information for target names Date: Thu, 27 Jun 2024 10:52:28 +0200 Message-ID: <20240627085232.226541-5-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240627085232.226541-1-poulhies@adacore.com> References: <20240627085232.226541-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org From: Eric Botcazou 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); From patchwork Thu Jun 27 08:52:29 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 1953068 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=SgcCZzUT; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4W8snK65HXz20Xg for ; Thu, 27 Jun 2024 18:54:13 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id EDB3C3835C0B for ; Thu, 27 Jun 2024 08:54:11 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42e.google.com (mail-wr1-x42e.google.com [IPv6:2a00:1450:4864:20::42e]) by sourceware.org (Postfix) with ESMTPS id 872623836E8A for ; Thu, 27 Jun 2024 08:52:48 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 872623836E8A Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 872623836E8A Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::42e ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1719478379; cv=none; b=SjjNVESRcg/XF1QPN4+TJGmv0unoXFRy7vFWXZ5it60rCZPLz8lJqFyR7KA7vZRpQNwNQb7rEdzsZM0o7G5a5wBB/0ghdmhJDYlTYiiMRDk9L7kW6QaXFuLJsSgQ5H5cjIGiG6nGLgkwMy82H4fsF86aos6dLveQJJJbDQ1EpiQ= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1719478379; c=relaxed/simple; bh=l6rDOU8hY73/3P/zGoMwwRoJFlRRs8AadNqCSTC6j24=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=SGkXrmKnUgzQtc4AhFGPNtyTbr1SIWx7D/jhSZiU0j6S36sMKES7JdC3qkRny2BHYOz9igLZZdH+Xv+7cyxZ8W26ngYbld9D0eqiCI+Tte08wr4UBTjX52CEov4CmT/MkByZ5+e7Bu8xqrweXa9INjXALagus1QNo1DqXXu65cU= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x42e.google.com with SMTP id ffacd0b85a97d-36703b0f914so990144f8f.0 for ; Thu, 27 Jun 2024 01:52:48 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1719478367; x=1720083167; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=sM6hWwvmR/nEkOC88BzqS4R3iEfHJEjeBKskJ5nh1NM=; b=SgcCZzUTB4nN0dzUY9zu4GDFIfgu6JH9xInp4nA3jIr/oPPjz742oXUWPmNIgCPlME SQe5mXqTaRzZ+huvwv6i60EmHJF99DPh1AZLUlMEtGg+6WmW2PWp6815/LTxxreH5Blw m1uP5B4SdSmiplz0ZAtTfCHDc4HqxHxTP+VRnVuZmC5Mzo37nL+H8GprXolh6KjdwUVj qwbsTm8KRsE7qZZbGOLnL/+772do08A//pP5vA/6m1+JsKpXBsgQJHJX19nOavAF5Dqu jkv/lJ3WqsIjcv8oVpvmhTDbEXb22U7ySaUzWHeqGNzSxeiH94Ln/6mOC5uSVgN+OYGP H+NQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1719478367; x=1720083167; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=sM6hWwvmR/nEkOC88BzqS4R3iEfHJEjeBKskJ5nh1NM=; b=P4P9gonvuyGdRInC8AL56a3yFhdxTaatwbCFilCj3fJfyRLEG/3ehbp7TrHJk2YeIA zR4oZxMDs8dS5Jqc3+5FwMYFRbsAkhm8TxnQku1XHbKd/wHUdXvHJUm3gJHGvze0fodx jcSlPj/B8I9SP0Yeu9Bx3POkONhFNtjKdBCOI8EjkAzoEeoLvVA2Sxwx857mmLN9pGYC UtnNdI29mC6GXySxSA9kCvhnZpSj1yrbvJ82dJkTTjodnZsxboSjslGVIxdw1dJKKOmx Axm5AAHJ/KS+qFMPRGtmh78pN3VXELNH2zUz+pM7+tZzLtVrBaXRbt+m2Q0yjHRnFGNy NzZQ== X-Gm-Message-State: AOJu0YyeDWtycTCq2Z2Etp2uwH56yZ7fuQzKlQnFI80dvQYxUTejOx/5 /W8M4K+wsZjG9EPs82peiX4mNfNvglrk1wrQK8PoVQ7w9S6gNjzGQ6lt/jo6vAYuyN8PKeRgaNE = X-Google-Smtp-Source: AGHT+IF0F8DdIsRFgX3f7rUOnD27nFTJq8H8zKmPrWYB260LQSIgIM8KMaQLOF+rnLPfB0BVczXofw== X-Received: by 2002:a5d:64ce:0:b0:366:defe:1b3b with SMTP id ffacd0b85a97d-3673cc55d39mr2025077f8f.11.1719478367092; Thu, 27 Jun 2024 01:52:47 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:2a5d:d7ee:58d:fee4]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-3674357c14fsm1149133f8f.16.2024.06.27.01.52.46 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 27 Jun 2024 01:52:46 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [COMMITTED 6/7] ada: Reject ambiguous function calls in interpolated string expressions Date: Thu, 27 Jun 2024 10:52:29 +0200 Message-ID: <20240627085232.226541-6-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240627085232.226541-1-poulhies@adacore.com> References: <20240627085232.226541-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org From: Javier Miranda 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); From patchwork Thu Jun 27 08:52:30 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 1953071 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=GTzeTvNG; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4W8sp75h1rz20Xg for ; Thu, 27 Jun 2024 18:54:55 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id EC7383834682 for ; Thu, 27 Jun 2024 08:54:53 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-lj1-x233.google.com (mail-lj1-x233.google.com [IPv6:2a00:1450:4864:20::233]) by sourceware.org (Postfix) with ESMTPS id B56593838A22 for ; Thu, 27 Jun 2024 08:52:49 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org B56593838A22 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org B56593838A22 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::233 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1719478379; cv=none; b=YOs1NhXRqKiJcjl68xsuiK7J/EKnrSCSKd2PWP090iatJ7DRIQTn7brLbFEgSO5qIFWH4U6oP1V7RuKwq53nESnTCdYUyvHRTK8Qgj7gNevilPpWO8VsidqqIYsibncqXl5dwvApz6XgyOayKTARZnvFFzKi7cLj7B71DJWsNSk= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1719478379; c=relaxed/simple; bh=/AjC2pjKe+/xU5eO/PVAiiYSeW3a/zKtvBs1RUW/g1Q=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=xy34Dz+dAgoh8MTw5Qdq048k7sXTbB+ZDRWv4mjwzOOTnxwBbULYi5JPqHaNxksgEyjfXqijZIAq0PGgIu0yq3PfPkhoPfcIm6IpYClWG9QfbVXuVNbb8OG/hAbCapwSoMqQhwMdRKW9XvHAQI2JTcaiUCIfeEWV9YPLP6TBztQ= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-lj1-x233.google.com with SMTP id 38308e7fff4ca-2ec595d0acbso57875441fa.1 for ; Thu, 27 Jun 2024 01:52:49 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1719478368; x=1720083168; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=ANrc3qa/bvmAxXm2RdcR1dUjgXPQqmTOU4HqxIxtQkk=; b=GTzeTvNGwFDUnmKBDeazO3Rn/VjdffJrLq0hUP13H55/55oKhXNKLz6un2Y5cE+15A 2SJXhffqi74OkKuPHz7IMFGA1dEDiEOytiwul/FsA6ZgWE7ZzPirQgkSHvKj2hEz/tdp AxcSAdPF0HCnEmiQls/jyNDodCRGfruz2hVz6zPks/OTgUJKb8zN+X2CYlxcbV+mlcrT JwCR6py+yTp07q1gP9akwHouz5umSvjD+32IbvMB3xHviMNBCo376qXB+9OdGHmDQ2Xa ajSU6yX5Hhw5SkkDm4QsE5ErGsGvUJ5P82F5xGY8sQxR7/rWZZY05iviWxaucdYtOmx0 SHkw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1719478368; x=1720083168; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=ANrc3qa/bvmAxXm2RdcR1dUjgXPQqmTOU4HqxIxtQkk=; b=fKsZMK4jiY5AG3quYCBNTy4G4B4LV56agR/RixSP2mlMpNACDj3F+RNDhl2L3Wcn8d woG0w5J82AwB5h2yEdCF4G8M4p6I19Fx1IQ30fzOzS1xeCLhPlgMguvQb52syvWNnOZc iZ4BRr/povlM+NSLEiyVo7gIKoO0Xaw3VlrYZ3hAOxLhRWeXRdB0VKvxqPRZDIGo+B/v ASjujh0dvi4ok5YzZlbXIn+hrvFo9sSOJs6WhA3r0hfzd7pA/GJJh43F4/hmHIFcLrXa 87LoFgt/sqpczNZXHBBBJedvYk/dqmDSLo0MtGTHv5EJCFKoLovSPJ67aWN7V2doEYd3 LB4A== X-Gm-Message-State: AOJu0YxkhdOxe4SDKnzoz34X/a2yWwl8MLkUO7tdl7XyVjQyrDlpc9ez Lp4jpGWtcFlD3Y3vx4RXGeMGMEnETtqZs3MNXSBMC32KadY4FlWQ08WZin89fvPv1si0KVNewLM = X-Google-Smtp-Source: AGHT+IE2RiPVKEt4HmHR6sBXzcxZeCuMpjkWQa59cbVr+4uxyTBIS1lTdwxZiK5SPP5ZmHidic/XZQ== X-Received: by 2002:ac2:5607:0:b0:52c:e0e1:9ae3 with SMTP id 2adb3069b0e04-52ce18614d1mr9884909e87.57.1719478368138; Thu, 27 Jun 2024 01:52:48 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:2a5d:d7ee:58d:fee4]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-3674357c14fsm1149133f8f.16.2024.06.27.01.52.47 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 27 Jun 2024 01:52:47 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 7/7] ada: Remove last uses of System.Address_Operations in runtime library Date: Thu, 27 Jun 2024 10:52:30 +0200 Message-ID: <20240627085232.226541-7-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240627085232.226541-1-poulhies@adacore.com> References: <20240627085232.226541-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org From: Eric Botcazou 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);