[Ada] Add conformance check on actual subp. in instance of child unit
Pierre-Marie de Rodat
derodat@adacore.com
Tue Aug 13 08:32:00 GMT 2019
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;
Tested on x86_64-pc-linux-gnu, committed on trunk
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.
-------------- next part --------------
A non-text attachment was scrubbed...
Name: patch.diff
Type: text/x-diff
Size: 730 bytes
Desc: not available
URL: <http://gcc.gnu.org/pipermail/gcc-patches/attachments/20190813/a3eb7693/attachment.bin>
More information about the Gcc-patches
mailing list