From: Javier Miranda <miranda@adacore.com>
Date: Fri, 18 Mar 2022 19:28:52 +0000 (+0000)
Subject: [Ada] Spurious error on subprogram with class-wide preconditions
X-Git-Tag: basepoints/gcc-14~6682
X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=c30e5ab027a59a2ffcf7fb2d093ce2b64de712eb;p=thirdparty%2Fgcc.git

[Ada] Spurious error on subprogram with class-wide preconditions

gcc/ada/

	* freeze.adb (Build_DTW_Spec): Do not inherit the not-overriding
	indicator because the DTW wrapper overrides its wrapped
	subprogram.
	* contracts.ads (Make_Class_Precondition_Subps): Adding
	documentation.
---

diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads
index adbb0e6eb67..5178373bff3 100644
--- a/gcc/ada/contracts.ads
+++ b/gcc/ada/contracts.ads
@@ -226,6 +226,39 @@ package Contracts is
    --  overrides an inherited class-wide precondition (see AI12-0195-1).
    --  Late_Overriding enables special handling required for late-overriding
    --  subprograms.
+   --
+   --  For example, if we have a subprogram with the following profile:
+   --
+   --     procedure Prim (Obj : TagTyp; <additional formals>)
+   --       with Pre'Class => F1 (Obj) and F2(Obj)
+   --
+   --  We build the following helper that evaluates statically the class-wide
+   --  precondition:
+   --
+   --    function PrimSP (Obj : TagTyp) return Boolean is
+   --    begin
+   --       return F1 (Obj) and F2(Obj);
+   --    end PrimSP;
+   --
+   --   ... and the following helper that evaluates dynamically the class-wide
+   --   precondition:
+   --
+   --    function PrimDP (Obj : TagTyp'Class; ...) return Boolean is
+   --    begin
+   --       return F1 (Obj) and F2(Obj);
+   --    end PrimSP;
+   --
+   --   ... and the following indirect-call wrapper (ICW) that is used by the
+   --   code generated by the compiler for indirect calls:
+   --
+   --    procedure PrimICW (Obj : TagTyp; <additional formals> is
+   --    begin
+   --       if not PrimSP (Obj) then
+   --          $raise_assert_failure ("failed precondition in call at ...");
+   --       end if;
+   --
+   --       Prim (Obj, ...);
+   --    end Prim;
 
    procedure Merge_Class_Conditions (Spec_Id : Entity_Id);
    --  Merge and preanalyze all class-wide conditions of Spec_Id (class-wide
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 7d90f512245..ca0ffe39c25 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -1619,6 +1619,13 @@ package body Freeze is
          DTW_Spec := Build_Overriding_Spec (Par_Prim, R);
          DTW_Id   := Defining_Entity (DTW_Spec);
 
+         --  Clear the not-overriding indicator since the DTW wrapper overrides
+         --  its wrapped subprogram; required because if present in the parent
+         --  primitive, given that Build_Overriding_Spec inherits it, we report
+         --  spurious errors.
+
+         Set_Must_Not_Override (DTW_Spec, False);
+
          --  Add minimal decoration of fields
 
          Mutate_Ekind (DTW_Id, Ekind (Par_Prim));