From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: 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 B90A43845148 for ; Tue, 14 May 2024 08:23:23 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org B90A43845148 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 B90A43845148 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=1715675016; cv=none; b=SpgWfpoNwOei3UBtp+O5q79haG5YfocXZfAg61L/jc9KgWepGJJWwyjUObZKxJxBco3LE8+WtKO9D4+cgzNZw/KfkaPWRHBXt7yFHQQeAxYMuPYEdB9AxRa7t0Fspzo5teiDgZ0YqX28B+MEVxmbVUGvVgEBq078ldwPtu2MNl8= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1715675016; c=relaxed/simple; bh=aAW+FIybt6erHLZ89Y4+BmmwaeMS8vjMI5TvbMsH8yM=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=C1D5wpbEvXel4sW/8G/+VLfAwavXEXPpz11Xkxq4Sx9jFfmhLHBImUzPcawxmkX2IgE7H+rcYgdalyNfzF7ncKSo3tb44Il3fZSVKbjTHoqLHPzDBqO385QEbRdMubC0+OrGRidG7sBKn4hdSXHV+ccE+bL/IFBuW260qr2OCtg= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x42f.google.com with SMTP id ffacd0b85a97d-34ddc9fe497so3338053f8f.3 for ; Tue, 14 May 2024 01:23:23 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1715675002; x=1716279802; 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=o89y2dLcCb0NHWiCt1K+wYQKOVK5IO9Hr/XuX3ShLMA=; b=CDJWrvpEbREsQo85Cms7G9tcdLGBrPuubchApOMyIdyc5BMfENmozPnj2tLzCIvPaK ljv8eE5wnIv7hnGP9p5FJb58Lvqlh9w/cPgo/RcFa+73HGh38pv0ITgpVhM01Ze3sTL/ DktpKWOfkuJ4IbbrQrToZXROn60dia4AG0tnnZCZWhkmu8JxK2dQlN2x2+YGxVuTeYTW ZYQai13CuC4BQ6AFoXa1MatYWHaXC4FwaxN2cEGgKsSW8bawAo4xksjOSHPCsJY+ul5z c3ZCv9Q925CHm7+1eO7NF2pmigmuW4x9vnDnJgBD7rIppZF9ASDq1wZtf3Ig6Y9PJY5t rh7w== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1715675002; x=1716279802; 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=o89y2dLcCb0NHWiCt1K+wYQKOVK5IO9Hr/XuX3ShLMA=; b=dbU3HzoYX0Ma1VQKSI6XIGJ6jprixdCGbZ1SHX3RohNDdj/HlePmF/jEmOFnZzO1TY sK1TM2L9imi40IX/BQsJ0IcoEPWS8Lt0JZ8R6nJ/JLEm261TfylAdzG78/L9E7xpTrpA xm0a4bXFwVZDB0PQ5R2IvVBeXcE2YSUUrnqWW2f6w+rnLHIC9AYTIK0hJao1LwpemDxO MhX0MeU74zXg8acnQFEgpvs6lb8Zwf7uJibIXAlpSbcetDuRJAqcNizYxiyjz4fZytmP JiavQ4cWuF/EMDaCYTKnbnV2gnDqedAFskM0HP5JEF0LBHSEZr/33Oc5uGpaew3luy4d tO8Q== X-Gm-Message-State: AOJu0YxKLQizdX//eK5CAiVcWuIW3sd9Pxqs8bvnEbZlBsn1IQDA9+xk 14hi/7RA5YrMZjSIAaeh49+qsItjUoiZOcN/Uliv4nSCEkvqkKm9vondo/oIeVH9nkladSkRWEc = X-Google-Smtp-Source: AGHT+IFDrM/usVgN392r1WcmHeDNI0nC0qeIDsvcE30cpDjwKOoyvJ465xLRdaTlnUWgP2IUUOfNaw== X-Received: by 2002:adf:ed8d:0:b0:34d:9161:2253 with SMTP id ffacd0b85a97d-3504a61c6d3mr10496503f8f.12.1715675002298; Tue, 14 May 2024 01:23:22 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-3502b8a791esm13038755f8f.64.2024.05.14.01.23.21 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 14 May 2024 01:23:21 -0700 (PDT) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [COMMITTED] ada: Missing support for consistent assertion policy Date: Tue, 14 May 2024 10:23:21 +0200 Message-ID: <20240514082321.832999-1-poulhies@adacore.com> X-Mailer: git-send-email 2.43.2 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit 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 List-Id: From: Javier Miranda Add missing support for RM 10.2/5: the region for a pragma Assertion_Policy given as a configuration pragma is the declarative region for the entire compilation unit (or units) to which it applies. gcc/ada/ * sem_ch10.adb (Install_Inherited_Policy_Pragmas): New subprogram. (Remove_Inherited_Policy_Pragmas): New subprogram. (Analyze_Compilation_Unit): Call the new subprograms to install and remove inherited assertion policy pragmas. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_ch10.adb | 212 ++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 208 insertions(+), 4 deletions(-) diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 7fc623b6278..73e5388affd 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -292,6 +292,18 @@ package body Sem_Ch10 is -- Spec_Context_Items to that of the spec. Parent packages are not -- examined for documentation purposes. + function Install_Inherited_Policy_Pragmas + (Comp_Unit : Node_Id) return Node_Id; + -- Install assertion_policy pragmas placed at the start of the spec of + -- the given compilation unit (and the spec of its parent units). Return + -- the last pragma found in the check policy list before installing + -- these pragmas; used to remove the installed pragmas. + + procedure Remove_Inherited_Policy_Pragmas (Last_Pragma : Node_Id); + -- Remove assertion_policy pragmas installed after the given pragma. If + -- Last_Pragma is empty then remove all the pragmas installed in the + -- check policy list (if any). + --------------------------- -- Check_Redundant_Withs -- --------------------------- @@ -631,6 +643,186 @@ package body Sem_Ch10 is end loop; end Check_Redundant_Withs; + -------------------------------------- + -- Install_Inherited_Policy_Pragmas -- + -------------------------------------- + + -- Opt.Check_Policy_List is handled as a stack; assertion policy + -- pragmas defined at inner scopes are placed at the beginning of + -- the list. Therefore, policy pragmas defined at the start of + -- parent units must be appended to the end of this list. + + -- When the compilation unit is a package body (or a subprogram body + -- that does not act as its spec) we recursively traverse to its spec + -- (and from there to its ultimate parent); when the compilation unit + -- is a child package (or subprogram) spec we recursively climb until + -- its ultimate parent. In both cases policy pragmas defined at the + -- beginning of all these traversed units are appended to the check + -- policy list in the way back to the current compilation unit (and + -- they are left installed in reverse order). For example: + -- + -- pragma Assertion_Policy (...) -- [policy-1] + -- package Pkg is ... + -- + -- pragma Assertion_Policy (...) -- [policy-2] + -- package Pkg.Child is ... + -- + -- pragma Assertion_Policy (...) -- [policy-3] + -- package body Pkg.Child is ... + -- + -- When the compilation unit Pkg.Child is analyzed, and its context + -- clauses are analyzed, these are the contents of Check_Policy_List: + -- + -- Opt.Check_Policy_List -> [policy-3] + -- ^ + -- last_policy_pragma + -- + -- After climbing to the ultimate parent spec, these are the contents + -- of Check_Policy_List: + -- + -- Opt.Check_Policy_List -> [policy-3] -> [policy-2] -> [policy-1] + -- ^ + -- last_policy_pragma + -- + -- The reference to the last policy pragma in the initial contents of + -- the list is used later to remove installed inherited pragmas. + + function Install_Inherited_Policy_Pragmas + (Comp_Unit : Node_Id) return Node_Id + is + Last_Policy_Pragma : Node_Id; + + procedure Install_Parent_Policy_Pragmas (N : Node_Id); + -- Recursively climb to the ultimate parent and install their policy + -- pragmas after Last_Policy_Pragma. + + ----------------------------------- + -- Install_Parent_Policy_Pragmas -- + ----------------------------------- + + procedure Install_Parent_Policy_Pragmas (N : Node_Id) is + Lib_Unit : constant Node_Id := Unit (N); + Item : Node_Id; + + begin + if Is_Child_Spec (Lib_Unit) then + Install_Parent_Policy_Pragmas (Parent_Spec (Lib_Unit)); + + elsif Nkind (Lib_Unit) = N_Package_Body then + Install_Parent_Policy_Pragmas (Library_Unit (N)); + + elsif Nkind (Lib_Unit) = N_Subprogram_Body + and then not Acts_As_Spec (N) + then + Install_Parent_Policy_Pragmas (Library_Unit (N)); + end if; + + -- Search for check policy pragmas defined at the start of the + -- context items. They are not part of the context clause, but + -- that is where the parser places them. + + Item := First (Context_Items (N)); + while Present (Item) + and then Nkind (Item) = N_Pragma + and then Pragma_Name (Item) in Configuration_Pragma_Names + loop + if Pragma_Name (Item) = Name_Check_Policy then + if No (Last_Policy_Pragma) then + Set_Next_Pragma (Item, Opt.Check_Policy_List); + Opt.Check_Policy_List := Item; + + else + Set_Next_Pragma (Item, Next_Pragma (Last_Policy_Pragma)); + Set_Next_Pragma (Last_Policy_Pragma, Item); + end if; + end if; + + Next (Item); + end loop; + end Install_Parent_Policy_Pragmas; + + -- Local variables + + Lib_Unit : constant Node_Id := Unit (Comp_Unit); + + -- Start of processing for Install_Inherited_Policy_Pragmas + + begin + -- Search for the last configuration pragma of the current + -- compilation unit in the check policy list. These pragmas were + -- added to the ckeck policy list as part of the analysis of the + -- context of the current compilation unit (because, although + -- configuration pragmas are not part of the context clauses, + -- they are placed there by the parser). + + Last_Policy_Pragma := Opt.Check_Policy_List; + + if Present (Last_Policy_Pragma) then + while Present (Next_Pragma (Last_Policy_Pragma)) loop + Last_Policy_Pragma := Next_Pragma (Last_Policy_Pragma); + end loop; + end if; + + -- We must not install configuration pragmas of the current unit + -- because they have been installed by Analyze_Context (see previous + -- comment). + + if Is_Child_Spec (Lib_Unit) then + Install_Parent_Policy_Pragmas (Parent_Spec (Lib_Unit)); + + elsif Nkind (Lib_Unit) = N_Package_Body then + Install_Parent_Policy_Pragmas (Library_Unit (Comp_Unit)); + + elsif Nkind (Lib_Unit) = N_Subprogram_Body + and then not Acts_As_Spec (Comp_Unit) + then + Install_Parent_Policy_Pragmas (Library_Unit (Comp_Unit)); + end if; + + return Last_Policy_Pragma; + end Install_Inherited_Policy_Pragmas; + + ------------------------------------- + -- Remove_Inherited_Policy_Pragmas -- + ------------------------------------- + + procedure Remove_Inherited_Policy_Pragmas (Last_Pragma : Node_Id) is + Curr_Prag : Node_Id; + Next_Prag : Node_Id; + + begin + if No (Opt.Check_Policy_List) then + return; + end if; + + -- If this unit does not have assertion_policy pragmas, then all the + -- pragmas installed in the check policy list were inherited and must + -- be removed from the list. + + if No (Last_Pragma) then + Curr_Prag := Opt.Check_Policy_List; + + -- Otherwise, pragmas installed after Last_Pragma must be removed. + + else + Curr_Prag := Last_Pragma; + end if; + + -- Remove pragmas from the list + + Next_Prag := Next_Pragma (Curr_Prag); + while Present (Next_Prag) loop + Set_Next_Pragma (Curr_Prag, Empty); + + Curr_Prag := Next_Prag; + Next_Prag := Next_Pragma (Curr_Prag); + end loop; + + if No (Last_Pragma) then + Opt.Check_Policy_List := Empty; + end if; + end Remove_Inherited_Policy_Pragmas; + -- Local variables Main_Cunit : constant Node_Id := Cunit (Main_Unit); @@ -640,6 +832,12 @@ package body Sem_Ch10 is Unum : Unit_Number_Type; Options : Style_Check_Options; + Last_Policy_Pragma : Node_Id; + -- Last policy pragma of this compilation unit installed in the check + -- policy list when its context is analyzed (see Analyze_Context); this + -- node is used as a reference to remove from this list policy pragmas + -- inherited from parent units. + -- Start of processing for Analyze_Compilation_Unit begin @@ -910,11 +1108,16 @@ package body Sem_Ch10 is end; end if; - -- With the analysis done, install the context. Note that we can't - -- install the context from the with clauses as we analyze them, because - -- each with clause must be analyzed in a clean visibility context, so - -- we have to wait and install them all at once. + -- With the analysis done, install assertion_policy pragmas defined at + -- the start of the specification of this unit (and recursively the + -- assertion policy pragmas defined at the start of the specification + -- of its parent units); install also the context of this compilation + -- unit. Note that we can't install the context from the with clauses + -- as we analyze them, because each with clause must be analyzed in a + -- clean visibility context, so we have to wait and install them all + -- at once. + Last_Policy_Pragma := Install_Inherited_Policy_Pragmas (N); Install_Context (N); if Is_Child_Spec (Unit_Node) then @@ -1077,6 +1280,7 @@ package body Sem_Ch10 is -- the unit just compiled. Remove_Context (N); + Remove_Inherited_Policy_Pragmas (Last_Policy_Pragma); -- When generating code for a non-generic main unit, check that withed -- generic units have a body if they need it, even if the units have not -- 2.43.2