From 9e42b1920b40e5f1f2dd5443f48d28b38dd32af6 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 13 Aug 2019 08:07:56 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 6 ++++++ gcc/ada/sem_ch8.adb | 11 ++++++++++- 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d9b75725257..bd3450fffd1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2019-08-13 Ed Schonberg + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Do no suppress mode + conformance checks on child unit instance that is a compilation + unit. + 2019-08-13 Gary Dismukes * exp_dbug.adb (Fully_Qualify_Name): Add full name qualification diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 8795dc07f95..38c3980278d 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -3368,7 +3368,16 @@ package body Sem_Ch8 is if CW_Actual then null; - elsif not Is_Actual or else No (Enclosing_Instance) then + + -- No need for a redundant error message if this is a nested + -- instance, unless the current instantiation (of a child unit) + -- is a compilation unit, which is not analyzed when the parent + -- generic is analyzed. + + elsif not Is_Actual + or else No (Enclosing_Instance) + or else Is_Compilation_Unit (Current_Scope) + then Check_Mode_Conformant (New_S, Old_S); end if;