[Ada] Add conformance check on actual subp. in instance of child unit

[Ada] Add conformance check on actual subp. in instance of child unit

This patch properly diagnoses a conformance error between a formal
subprogram and the corresponding actual, when the instance is that of a
child unit that is instantiated as a compilation unit. The error is
normally suppressed on an instantiation nested within another generic,
given that analysis of the enclosing generic will have performed the
conformance check on the nested instance already.  In the case of a
child unit, its instantiation requires an explicit check if it is a
compilation unit, because it has not been analyzed in the context of the
parent generic.

Compiling test.adb must yield:

  container-list.ads:3:01: instantiation error at new_container_g-list_g.ads:12
  container-list.ads:3:01: not mode conformant with declaration at types.ads:5
  container-list.ads:3:01: mode of "Self" does not match

----
with New_Container_G.List_G;
pragma Elaborate_All (New_Container_G.List_G);
package Container.List is new Container.List_G (Init => Types.Init_Object);
with Types;
with Erreur;
with New_Container_G;

pragma Elaborate_All (New_Container_G);

package Container is new New_Container_G (
  Element_T      => Types.Integer_T,
  Pos_Range_T    => Types.Integer_Idx_T,
  Container_Name => Erreur.None);
package Erreur is
   type Container_Name_T is (None, Everything);
end;
----
package body New_Container_G.List_G is

  function Get_Element_At_Pos
   (Self : access List_T;
    Pos  : in     Index_Range_T)
    return Element_Ptr is
  begin
    if not Self.T_Status (Pos) then
      Erreur.Treat_Container_Error
       (Error_Name     => Erreur.Element_Not_Valid,
        Container_Name => Container_Name,
        Procedure_Name => Erreur.Get_Element_Ptr_At_Pos,
        Context        => Erreur.Null_Context_C);
    end if;
    return Pos;

  end Get_Element_At_Pos;

  function Get_Element_At_Pos
   (Self : in List_T;
    Pos  : in Index_Range_T)
    return Element_T is
  begin
    if not Self.T_Status (Pos) then
      Erreur.Treat_Container_Error
       (Error_Name     => Erreur.Element_Not_Valid,
        Container_Name => Container_Name,
        Procedure_Name => Erreur.Get_Element_At_Pos,
        Context        => Erreur.Null_Context_C);
    end if;
    return Self.Data (Pos);
  end Get_Element_At_Pos;

  procedure Add_New
   (Self : in out List_T;
    Pos  :    out Pos_Range_T) is

    Free_Found : Boolean := False;
  begin
    if Self.First_Free = Rbc_Constants.Null_Pos then
      Pos := Rbc_Constants.Null_Pos;
    else
      Self.Size                       := Self.Size + 1;
      Self.T_Status (Self.First_Free) := True;
      Pos                             := Self.First_Free;
      Init (Self.Data (Pos));
      if Self.First_Relevant not in
         Rbc_Constants.Null_Pos + 1 .. Self.First_Free
      then
        Self.First_Relevant := Self.First_Free;
      end if;

      while not (Free_Found or Self.First_Free = Rbc_Constants.Null_Pos) loop
        if Self.First_Free = Pos_Range_T'Last then
          Self.First_Free := Rbc_Constants.Null_Pos;
        else
          Self.First_Free := Self.First_Free + 1;
          if not Self.T_Status (Self.First_Free) then
            Free_Found := True;
          end if;
        end if;
      end loop;
    end if;
  end Add_New;

  procedure Add_New_At_Pos
   (Self : in out List_T;
    Pos  : in out Index_Range_T) is

    Free_Found : Boolean := False;
  begin
    if Self.T_Status (Pos) then
      Erreur.Treat_Container_Error
       (Error_Name     => Erreur.Element_Not_Valid,
        Container_Name => Container_Name,
        Procedure_Name => Erreur.Add_New_At_Pos,
        Context        => Erreur.Null_Context_C);
    else
      Self.Size           := Self.Size + 1;
      Self.T_Status (Pos) := True;
      Init (Self.Data (Pos));
      if Self.First_Relevant = Rbc_Constants.Null_Pos
        or Pos < Self.First_Relevant
      then
        Self.First_Relevant := Pos;
      end if;
      if Self.First_Free = Pos
      then
        -- Look for a new First_Free
        while not (Free_Found or Self.First_Free = Rbc_Constants.Null_Pos) loop
          if Self.First_Free = Pos_Range_T'Last then
            Self.First_Free := Rbc_Constants.Null_Pos;
          else
            Self.First_Free := Self.First_Free + 1;
            if not Self.T_Status (Self.First_Free) then
              Free_Found := True;
            end if;
          end if;
        end loop;
      end if;
      -------------------------------------------------------------------------
    end if;
  end Add_New_At_Pos;

  procedure Clear (Self : out List_T) is
  begin
    Self.T_Status       := (others => False);
    Self.First_Free     := Init_First_Free;
    Self.First_Relevant := Rbc_Constants.Null_Pos;
    Self.Size           := Empty;
  end Clear;

  procedure Remove_Element_At_Pos
   (Self : in out List_T;
    Pos  : in     Index_Range_T) is

    Relevant_Found : Boolean := False;
  begin
    -- REMOVE ITEM IF VALID ---------------------------------------------
    if not Self.T_Status (Pos) then
      Erreur.Treat_Container_Error
       (Error_Name     => Erreur.Element_Not_Valid,
        Container_Name => Container_Name,
        Procedure_Name => Erreur.Remove_Element_At_Pos,
        Context        => Erreur.Null_Context_C);
    end if;

    Self.Size := Self.Size - 1;

    Self.T_Status (Pos) := False;
    if Self.First_Free not in Rbc_Constants.Null_Pos + 1 .. Pos then
      Self.First_Free := Pos;
    end if;

    -- UPDATE FIRST_RELEVANT IF NECESSARY -----------------------------------
    if Self.First_Relevant = Pos then
      while
        not (Relevant_Found or Self.First_Relevant = Rbc_Constants.Null_Pos)
      loop
        if Self.First_Relevant = Pos_Range_T'Last then
          Self.First_Relevant := Rbc_Constants.Null_Pos;
        else
          Self.First_Relevant := Self.First_Relevant + 1;
          if Self.T_Status (Self.First_Relevant) then
            Relevant_Found := True;
          end if;
        end if;
      end loop;
    end if;
    -------------------------------------------------------------------------
  end Remove_Element_At_Pos;

  procedure Next
   (It   : in out Iterator_T;
    Self : in     List_T) is

    Relevant_Found : Boolean := False;
  begin
    if It = Rbc_Constants.Null_Pos then
      Erreur.Treat_Container_Error
       (Error_Name     => Erreur.Iterator_Not_Valid,
        Container_Name => Container_Name,
        Procedure_Name => Erreur.Next,
        Context        => Erreur.Null_Context_C);
    end if;
    while not (Relevant_Found or It = Rbc_Constants.Null_Pos) loop
      if It = Pos_Range_T'Last then
        It := Rbc_Constants.Null_Pos;
      else
        It := It + 1;
        if Self.T_Status (It) then
          Relevant_Found := True;
        end if;
      end if;
    end loop;
  end Next;

  function New_Iterator
   (Self : in List_T)
    return Iterator_T is
  begin
    return Self.First_Relevant;
  end New_Iterator;

  function Get
   (It   : in     Iterator_T;
    Self : in     List_T)
    return Element_Ptr is
  begin
    if It = Rbc_Constants.Null_Pos or else not Self.T_Status (It) then
      Erreur.Treat_Container_Error
       (Error_Name     => Erreur.Iterator_Not_Valid,
        Container_Name => Container_Name,
        Procedure_Name => Erreur.Get_Ptr,
        Context        => Erreur.Null_Context_C);
    end if;
    return It;
  end Get;

  function Get
   (It   : in Iterator_T;
    Self : in List_T)
    return Element_T is
  begin
    if It = Rbc_Constants.Null_Pos or else not Self.T_Status (It) then
      Erreur.Treat_Container_Error
       (Error_Name     => Erreur.Iterator_Not_Valid,
        Container_Name => Container_Name,
        Procedure_Name => Erreur.Get,
        Context        => Erreur.Null_Context_C);
    end if;
    return Self.Data (It);
  end Get;

  function Getstatus
   (Self : in List_T;
    Pos  : in Index_Range_T)
    return Boolean is
  begin
    return Self.T_Status (Pos);
  end Getstatus;

  function Init_First_Free return Pos_Range_T is
    First_Free_Value : Pos_Range_T;
  begin
    if Full = Rbc_Constants.Null_Pos then
      -- size is 0
      First_Free_Value := Rbc_Constants.Null_Pos;
    else
      -- first free cell index is 1
      First_Free_Value := Index_Range_T'First;
    end if;
    return First_Free_Value;
  end Init_First_Free;

end New_Container_G.List_G;

with Rbc_Constants;

generic

  with procedure Init (Self : out Element_T);

package New_Container_G.List_G is

  type List_T is new Container_T with private;

  function Get_Element_At_Pos
   (Self : access List_T;
    Pos  : in     Index_Range_T)
    return Element_Ptr;

  function Get_Element_At_Pos
   (Self : in List_T;
    Pos  : in Index_Range_T)
    return Element_T;

  procedure Add_New
   (Self : in out List_T;
    Pos  :    out Pos_Range_T);

  procedure Add_New_At_Pos
   (Self : in out List_T;
    Pos  : in out Index_Range_T);

  procedure Clear (Self : out List_T);

  procedure Remove_Element_At_Pos
   (Self : in out List_T;
    Pos  : in     Index_Range_T);

  procedure Next
   (It   : in out Iterator_T;
    Self : in     List_T);

  function New_Iterator
   (Self : in List_T)
    return Iterator_T;

  function Get
   (It   : in     Iterator_T;
    Self : in     List_T)
    return Element_Ptr;

  function Get
   (It   : in Iterator_T;
    Self : in List_T)
    return Element_T;

  function Getstatus
   (Self : in List_T;
    Pos  : in Index_Range_T)
    return Boolean;

private

  function Init_First_Free return Pos_Range_T;

  type Status_Array_T is array (Index_Range_T) of Boolean;

  type List_T is new Container_T with
    record
      T_Status       : Status_Array_T := (others => False);
      First_Free     : Pos_Range_T    := Init_First_Free;
      First_Relevant : Pos_Range_T    := Rbc_Constants.Null_Pos;
    end record;

end New_Container_G.List_G;

with Types_Alstom; use Types_Alstom;
with Rbc_Constants;

package body New_Container_G is

  function Done
   (It   : in Iterator_T;
    Self : in Container_T)
    return Boolean is
    pragma Unreferenced (Self);
    Report : Boolean;
  begin
    if It = Rbc_Constants.Null_Pos then
      Report := True;
    else
      Report := False;
    end if;
    return Report;
  end Done;

  procedure Execute (Self      : in out Container_T'class;
                     This_Proc : in Proc_Access_T) is
  begin
    for I in Self.Data'First .. Self.Size loop
      This_Proc (Self.Data (I));
    end loop;
  end Execute;

  procedure Execute (Self      : in out Container_T'class;
                     This_Proc : in Proc_Idx_Access_T) is
  begin
    for I in Self.Data'First .. Self.Size loop
      This_Proc (Self.Data (I), I);
    end loop;
  end Execute;

  function Selected_Subset
   (Self : in Container_T'Class;
    Ref  : in Reference_T)
    return Element_Set_T is
    Set     : Element_Set_T := (others => Rbc_Constants.Null_Pos);
    Current : Pos_Range_T   := 0;

  begin
    for I in Self.Data'Range loop
      if Getstatus (Self, I) and then Is_Selected
                                           (Elem => Self.Data (I),
                                            Ref  => Ref)
      then
        Current       := Current + 1;
        Set (Current) := I;
      end if;
    end loop;
    return Set;
  end Selected_Subset;

  function Selected_Element
   (Self : in Container_T'Class;
    Ref  : in Reference_T)
    return Element_Ptr is
  begin
    for I in Self.Data'Range loop
      if Getstatus (Self, I) and then Is_Selected
                                           (Elem => Self.Data (I),
                                            Ref  => Ref)
      then
        return I;
      end if;
    end loop;
    return Rbc_Constants.Null_Pos;
  end Selected_Element;

  function Getsize
   (Self : in Container_T)
    return Pos_Range_T is
  begin
    return Self.Size;
  end Getsize;

end New_Container_G;

with Types;
with Erreur;

generic

  -- Type of element to be stored
  type Element_T is private;
  type Pos_Range_T is range <>;
  Container_Name : in Erreur.Container_Name_T;

package New_Container_G is
  pragma Unreferenced (Container_Name);

  subtype Element_Acc_T is Pos_Range_T;

  subtype Element_Ptr is Element_Acc_T;   -- for compatibility

  subtype Iterator_T is Pos_Range_T;

  subtype Index_Range_T is Pos_Range_T range 1 .. Pos_Range_T'Last;

  type Element_Set_T is array (Index_Range_T) of Element_Ptr;

  Full  : constant Pos_Range_T := Pos_Range_T'Last;
  Empty : constant Pos_Range_T := Pos_Range_T'First;
  type Element_Array_T is array (Index_Range_T) of Element_T;
  type Container_T is abstract tagged
    record
      Data : Element_Array_T;
      Size : Pos_Range_T := Empty;
    end record;

  function Get
   (It   : in Iterator_T;
    Self : in Container_T)
    return Element_Ptr is abstract;

  function Get
   (It   : in Iterator_T;
    Self : in Container_T)
    return Element_T is abstract;

  procedure Next
   (It   : in out Iterator_T;
    Self : in Container_T) is abstract;

  function Done
   (It   : in Iterator_T;
    Self : in Container_T)
    return Boolean;

  type Proc_Access_T is access procedure (Elem  : in out Element_T);
  type Proc_Idx_Access_T is access procedure (Elem  : in out Element_T;
                                              Idx   : in Index_Range_T);
  procedure Execute (Self      : in out Container_T'class;
                     This_Proc : in Proc_Access_T);
  procedure Execute (Self      : in out Container_T'class;
                     This_Proc : in Proc_Idx_Access_T);

  function Getstatus
   (Self : in Container_T;
    Pos  : in Index_Range_T)
    return Boolean is abstract;

  generic
    -- Type of the parameter of the is_selected () function.
    type Reference_T is private;
    with function Is_Selected
     (Elem : in Element_T;
      Ref  : in Reference_T)
      return Boolean;
  function Selected_Subset
   (Self : in Container_T'Class;
    Ref  : in Reference_T)
    return Element_Set_T;

  generic
    -- Type of the parameter of the is_selected () function.
    type Reference_T is private;
    with function Is_Selected
     (Elem : in Element_T;
      Ref  : in Reference_T)
      return Boolean;
  function Selected_Element
   (Self : in Container_T'Class;
    Ref  : in Reference_T)
    return Element_Ptr;

  function Getsize
   (Self : in Container_T)
    return Pos_Range_T;

end New_Container_G;
----
package Rbc_Constants is
  Null_Pos      : constant := 0;
  Irrelevant_Id : constant String := "                ";
  Nmax_Mc_Bits  : constant := 32;
end Rbc_Constants;
with Ada.Text_IO;
with Types;
with Container.List;

procedure Test is

  List : Container.List.List_T;
  Pos  : Types.Integer_Idx_T;
begin
  Container.List.Add_New (Self => List,
                          Pos  => Pos);

  Ada.Text_IO.Put_Line ("no exception raised");
end Test;
package Types is
  type Integer_T     is range -1000 .. 1000;
  type Integer_Idx_T is range     0 .. 100;

  procedure Init_Object (Elem : in Integer_T);

end Types;

2019-08-13  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch8.adb (Analyze_Subprogram_Renaming): Do no suppress mode
	conformance checks on child unit instance that is a compilation
	unit.

From-SVN: r274350