[Ada] Ada2020: AI12-0195 overriding class-wide pre/post conditions

diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -2610,7 +2610,21 @@  package body Contracts is
 
             for Index in Subps'Range loop
                Subp_Id := Subps (Index);
-               Items   := Contract (Subp_Id);
+
+               if Present (Alias (Subp_Id)) then
+                  Subp_Id := Ultimate_Alias (Subp_Id);
+               end if;
+
+               --  Wrappers of class-wide pre/post conditions reference the
+               --  parent primitive that has the inherited contract.
+
+               if Is_Wrapper (Subp_Id)
+                 and then Present (LSP_Subprogram (Subp_Id))
+               then
+                  Subp_Id := LSP_Subprogram (Subp_Id);
+               end if;
+
+               Items := Contract (Subp_Id);
 
                if Present (Items) then
                   Prag := Pre_Post_Conditions (Items);
@@ -2892,7 +2906,21 @@  package body Contracts is
 
             for Index in Subps'Range loop
                Subp_Id := Subps (Index);
-               Items   := Contract (Subp_Id);
+
+               if Present (Alias (Subp_Id)) then
+                  Subp_Id := Ultimate_Alias (Subp_Id);
+               end if;
+
+               --  Wrappers of class-wide pre/post conditions reference the
+               --  parent primitive that has the inherited contract.
+
+               if Is_Wrapper (Subp_Id)
+                 and then Present (LSP_Subprogram (Subp_Id))
+               then
+                  Subp_Id := LSP_Subprogram (Subp_Id);
+               end if;
+
+               Items := Contract (Subp_Id);
 
                if Present (Items) then
                   Prag := Pre_Post_Conditions (Items);


diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -612,7 +612,7 @@  package Einfo is
 
 --    Class_Wide_Clone
 --       Defined on subprogram entities. Set if the subprogram has a class-wide
---       ore- or postcondition, and the expression contains calls to other
+--       pre- or postcondition, and the expression contains calls to other
 --       primitive funtions of the type. Used to implement properly the
 --       semantics of inherited operations whose class-wide condition may
 --       be different from that of the ancestor (See AI012-0195).
@@ -2385,12 +2385,6 @@  package Einfo is
 --       Defined in all entities. Set only for defining entities of program
 --       units that are child units (but False for subunits).
 
---    Is_Class_Wide_Clone
---       Defined on subprogram entities. Set for subprograms built in order
---       to implement properly the inheritance of class-wide pre- or post-
---       conditions when the condition contains calls to other primitives
---       of the ancestor type. Used to implement AI12-0195.
-
 --    Is_Class_Wide_Equivalent_Type
 --       Defined in record types and subtypes. Set to True, if the type acts
 --       as a class-wide equivalent type, i.e. the Equivalent_Type field of
@@ -3408,6 +3402,11 @@  package Einfo is
 --       Defined in package entities. Indicates that the package has been
 --       created as a wrapper for a subprogram instantiation.
 
+--    Is_Wrapper
+--       Defined in subprogram entities. Indicates that it has been created as
+--       a wrapper to handle inherited class-wide pre/post conditions that call
+--       overridden primitives or as a wrapper of a controlling function.
+
 --    Itype_Printed
 --       Defined in all type and subtype entities. Set in Itypes if the Itype
 --       has been printed by Sprint. This is used to avoid printing an Itype
@@ -4715,6 +4714,12 @@  package Einfo is
 --       Defined in functions and procedures which have been classified as
 --       Is_Primitive_Wrapper. Set to the entity being wrapper.
 
+--    LSP_Subprogram
+--       Defined in subprogram entities. Set on wrappers created to handle
+--       inherited class-wide pre/post conditions that call overridden
+--       primitives. It references the parent primitive that has the
+--       class-wide pre/post conditions.
+
 ---------------------------
 -- Renaming and Aliasing --
 ---------------------------
@@ -5487,6 +5492,7 @@  package Einfo is
    --    Protection_Object                    (for concurrent kind)
    --    Subps_Index                          (non-generic case only)
    --    Interface_Alias
+   --    LSP_Subprogram                       (non-generic case only)
    --    Overridden_Operation
    --    Wrapped_Entity                       (non-generic case only)
    --    Extra_Formals
@@ -5546,6 +5552,7 @@  package Einfo is
    --    Is_Private_Primitive                 (non-generic case only)
    --    Is_Pure
    --    Is_Visible_Lib_Unit
+   --    Is_Wrapper
    --    Needs_No_Actuals
    --    Requires_Overriding                  (non-generic case only)
    --    Return_Present
@@ -5687,6 +5694,7 @@  package Einfo is
    --    Linker_Section_Pragma
    --    Contract
    --    Import_Pragma
+   --    LSP_Subprogram
    --    SPARK_Pragma
    --    Default_Expressions_Processed
    --    Has_Nested_Subprogram
@@ -5697,6 +5705,7 @@  package Einfo is
    --    Is_Machine_Code_Subprogram
    --    Is_Primitive
    --    Is_Pure
+   --    Is_Wrapper
    --    SPARK_Pragma_Inherited
    --    Interface_Name $$$
    --    Renamed_Entity $$$
@@ -5841,6 +5850,7 @@  package Einfo is
    --    Protection_Object                    (for concurrent kind)
    --    Subps_Index                          (non-generic case only)
    --    Interface_Alias
+   --    LSP_Subprogram                       (non-generic case only)
    --    Overridden_Operation                 (never for init proc)
    --    Wrapped_Entity                       (non-generic case only)
    --    Extra_Formals
@@ -5899,6 +5909,7 @@  package Einfo is
    --    Is_Private_Descendant
    --    Is_Private_Primitive                 (non-generic case only)
    --    Is_Pure
+   --    Is_Wrapper
    --    Is_Valued_Procedure
    --    Is_Visible_Lib_Unit
    --    Needs_No_Actuals


diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -9703,10 +9703,10 @@  package body Exp_Ch3 is
             --  to override interface primitives.
 
             Mutate_Ekind (Defining_Unit_Name (Func_Spec), E_Function);
+            Set_Is_Wrapper (Defining_Unit_Name (Func_Spec));
 
             Override_Dispatching_Operation
-              (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec),
-               Is_Wrapper => True);
+              (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec));
          end if;
 
       <<Next_Prim>>


diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -1474,7 +1474,7 @@  package body Freeze is
       --  pragmas force the creation of a wrapper for the inherited operation.
       --  If the ancestor is being overridden, the pragmas are constructed only
       --  to verify their legality, in case they contain calls to other
-      --  primitives that may haven been overridden.
+      --  primitives that may have been overridden.
 
       ---------------------------------------
       -- Build_Inherited_Condition_Pragmas --
@@ -1558,6 +1558,15 @@  package body Freeze is
          then
             Par_Prim := Overridden_Operation (Prim);
 
+            --  When the primitive is an LSP wrapper we climb to the parent
+            --  primitive that has the inherited contract.
+
+            if Is_Wrapper (Par_Prim)
+              and then Present (LSP_Subprogram (Par_Prim))
+            then
+               Par_Prim := LSP_Subprogram (Par_Prim);
+            end if;
+
             --  Analyze the contract items of the overridden operation, before
             --  they are rewritten as pragmas.
 
@@ -1596,6 +1605,15 @@  package body Freeze is
          if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then
             Par_Prim := Alias (Prim);
 
+            --  When the primitive is an LSP wrapper we climb to the parent
+            --  primitive that has the inherited contract.
+
+            if Is_Wrapper (Par_Prim)
+              and then Present (LSP_Subprogram (Par_Prim))
+            then
+               Par_Prim := LSP_Subprogram (Par_Prim);
+            end if;
+
             --  Analyze the contract items of the parent operation, and
             --  determine whether a wrapper is needed. This is determined
             --  when the condition is rewritten in sem_prag, using the
@@ -1629,14 +1647,22 @@  package body Freeze is
             --  statement with a call.
 
             declare
+               Alias_Id : constant Entity_Id  := Ultimate_Alias (Prim);
                Loc      : constant Source_Ptr := Sloc (R);
                Par_R    : constant Node_Id    := Parent (R);
                New_Body : Node_Id;
                New_Decl : Node_Id;
+               New_Id   : Entity_Id;
                New_Spec : Node_Id;
 
             begin
+               --  The wrapper must be analyzed in the scope of its wrapped
+               --  primitive (to ensure its correct decoration).
+
+               Push_Scope (Scope (Prim));
+
                New_Spec := Build_Overriding_Spec (Par_Prim, R);
+               New_Id   := Defining_Entity (New_Spec);
                New_Decl :=
                  Make_Subprogram_Declaration (Loc,
                    Specification => New_Spec);
@@ -1658,9 +1684,26 @@  package body Freeze is
                     Build_Class_Wide_Clone_Call
                       (Loc, Decls, Par_Prim, New_Spec);
 
+                  --  Adding minimum decoration
+
+                  Mutate_Ekind (New_Id, Ekind (Par_Prim));
+                  Set_LSP_Subprogram (New_Id, Par_Prim);
+                  Set_Is_Wrapper (New_Id);
+
                   Insert_List_After_And_Analyze
                     (Par_R, New_List (New_Decl, New_Body));
+
+                  --  Ensure correct decoration
+
+                  pragma Assert (Present (Alias (Prim)));
+                  pragma Assert (Present (Overridden_Operation (New_Id)));
+                  pragma Assert (Overridden_Operation (New_Id) = Alias_Id);
                end if;
+
+               pragma Assert (Is_Dispatching_Operation (Prim));
+               pragma Assert (Is_Dispatching_Operation (New_Id));
+
+               Pop_Scope;
             end;
          end if;
 


diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -677,7 +677,6 @@  package Gen_IL.Fields is
       Is_Character_Type,
       Is_Checked_Ghost_Entity,
       Is_Child_Unit,
-      Is_Class_Wide_Clone,
       Is_Class_Wide_Equivalent_Type,
       Is_Compilation_Unit,
       Is_Completely_Hidden,
@@ -789,6 +788,7 @@  package Gen_IL.Fields is
       Is_Volatile_Type,
       Is_Volatile_Object,
       Is_Volatile_Full_Access,
+      Is_Wrapper,
       Itype_Printed,
       Kill_Elaboration_Checks,
       Kill_Range_Checks,
@@ -802,6 +802,7 @@  package Gen_IL.Fields is
       Lit_Indexes,
       Lit_Strings,
       Low_Bound_Tested,
+      LSP_Subprogram,
       Machine_Radix_10,
       Master_Id,
       Materialize_Entity,


diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -126,7 +126,6 @@  begin -- Gen_IL.Gen.Gen_Entities
         Sm (Is_Character_Type, Flag),
         Sm (Is_Checked_Ghost_Entity, Flag),
         Sm (Is_Child_Unit, Flag),
-        Sm (Is_Class_Wide_Clone, Flag),
         Sm (Is_Class_Wide_Equivalent_Type, Flag),
         Sm (Is_Compilation_Unit, Flag),
         Sm (Is_Concurrent_Record_Type, Flag),
@@ -204,6 +203,7 @@  begin -- Gen_IL.Gen.Gen_Entities
         Sm (Is_Volatile_Type, Flag),
         Sm (Is_Volatile_Object, Flag),
         Sm (Is_Volatile_Full_Access, Flag),
+        Sm (Is_Wrapper, Flag),
         Sm (Kill_Elaboration_Checks, Flag),
         Sm (Kill_Range_Checks, Flag),
         Sm (Low_Bound_Tested, Flag),
@@ -1088,6 +1088,7 @@  begin -- Gen_IL.Gen.Gen_Entities
         Sm (Is_Predicate_Function_M, Flag),
         Sm (Is_Primitive_Wrapper, Flag),
         Sm (Is_Private_Primitive, Flag),
+        Sm (LSP_Subprogram, Node_Id),
         Sm (Mechanism, Mechanism_Type),
         Sm (Next_Inlined_Subprogram, Node_Id),
         Sm (Original_Protected_Subprogram, Node_Id),
@@ -1107,7 +1108,8 @@  begin -- Gen_IL.Gen.Gen_Entities
        --  defined concatenation operator created whenever an array is declared.
        --  We do not make normal derived operators explicit in the tree, but the
        --  concatenation operators are made explicit.
-       (Sm (Extra_Accessibility_Of_Result, Node_Id)));
+       (Sm (Extra_Accessibility_Of_Result, Node_Id),
+        Sm (LSP_Subprogram, Node_Id)));
 
    Cc (E_Procedure, Subprogram_Kind,
        --  A procedure, created by a procedure declaration or a procedure
@@ -1137,6 +1139,7 @@  begin -- Gen_IL.Gen.Gen_Entities
         Sm (Is_Primitive_Wrapper, Flag),
         Sm (Is_Private_Primitive, Flag),
         Sm (Is_Valued_Procedure, Flag),
+        Sm (LSP_Subprogram, Node_Id),
         Sm (Next_Inlined_Subprogram, Node_Id),
         Sm (Original_Protected_Subprogram, Node_Id),
         Sm (Postconditions_Proc, Node_Id),


diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb
--- a/gcc/ada/gen_il-internals.adb
+++ b/gcc/ada/gen_il-internals.adb
@@ -317,6 +317,8 @@  package body Gen_IL.Internals is
             return "Is_SPARK_Mode_On_Node";
          when Local_Raise_Not_OK =>
             return "Local_Raise_Not_OK";
+         when LSP_Subprogram =>
+            return "LSP_Subprogram";
          when OK_To_Rename =>
             return "OK_To_Rename";
          when Referenced_As_LHS =>


diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -12080,9 +12080,22 @@  package body Sem_Ch6 is
                   --  must check whether the target is an init_proc.
 
                   elsif not Is_Init_Proc (S) then
-                     Set_Overridden_Operation    (S, E);
-                     Inherit_Subprogram_Contract (S, E);
-                     Set_Is_Ada_2022_Only        (S, Is_Ada_2022_Only (E));
+
+                     --  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_Is_Ada_2022_Only (S, Is_Ada_2022_Only (E));
                   end if;
 
                   Check_Overriding_Indicator (S, E, Is_Primitive => True);
@@ -12109,10 +12122,22 @@  package body Sem_Ch6 is
                           Is_Predefined_Dispatching_Operation (Alias (E)))
                   then
                      if Present (Alias (E)) then
-                        Set_Overridden_Operation    (S, Alias (E));
-                        Inherit_Subprogram_Contract (S, Alias (E));
-                        Set_Is_Ada_2022_Only        (S,
-                          Is_Ada_2022_Only (Alias (E)));
+
+                        --  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_Is_Ada_2022_Only (S, Is_Ada_2022_Only (Alias (E)));
                      end if;
                   end if;
 


diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -1239,7 +1239,9 @@  package body Sem_Disp is
               or else Get_TSS_Name (Subp) = TSS_Stream_Read
               or else Get_TSS_Name (Subp) = TSS_Stream_Write
 
-              or else Present (Contract (Overridden_Operation (Subp)))
+              or else
+               (Is_Wrapper (Subp)
+                 and then Present (LSP_Subprogram (Subp)))
 
               or else GNATprove_Mode);
 
@@ -2646,8 +2648,7 @@  package body Sem_Disp is
    procedure Override_Dispatching_Operation
      (Tagged_Type : Entity_Id;
       Prev_Op     : Entity_Id;
-      New_Op      : Entity_Id;
-      Is_Wrapper  : Boolean := False)
+      New_Op      : Entity_Id)
    is
       Elmt : Elmt_Id;
       Prim : Node_Id;
@@ -2724,7 +2725,7 @@  package body Sem_Disp is
                --  wrappers of controlling functions since (at this stage)
                --  they are not yet decorated.
 
-               if not Is_Wrapper then
+               if not Is_Wrapper (New_Op) then
                   Check_Subtype_Conformant (New_Op, Prim);
 
                   Set_Is_Abstract_Subprogram (Prim,


diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads
--- a/gcc/ada/sem_disp.ads
+++ b/gcc/ada/sem_disp.ads
@@ -167,13 +167,10 @@  package Sem_Disp is
    procedure Override_Dispatching_Operation
      (Tagged_Type : Entity_Id;
       Prev_Op     : Entity_Id;
-      New_Op      : Entity_Id;
-      Is_Wrapper  : Boolean := False);
+      New_Op      : Entity_Id);
    --  Replace an implicit dispatching operation of the type Tagged_Type
    --  with an explicit one. Prev_Op is an inherited primitive operation which
-   --  is overridden by the explicit declaration of New_Op. Is_Wrapper is
-   --  True when New_Op is an internally generated wrapper of a controlling
-   --  function. The caller checks that Tagged_Type is indeed a tagged type.
+   --  is overridden by the explicit declaration of New_Op.
 
    procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id);
    --  If a function call given by Actual is tag-indeterminate, its controlling


diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb
--- a/gcc/ada/treepr.adb
+++ b/gcc/ada/treepr.adb
@@ -371,6 +371,8 @@  package body Treepr is
             return "Is_Elaboration_Warnings_OK_Id";
          when F_Is_RACW_Stub_Type =>
             return "Is_RACW_Stub_Type";
+         when F_LSP_Subprogram =>
+            return "LSP_Subprogram";
          when F_OK_To_Rename =>
             return "OK_To_Rename";
          when F_Referenced_As_LHS =>