diff mbox series

[Ada] Spurious error on formal package with Inline_Always

Message ID 20170908133133.GA87389@adacore.com
State New
Headers show
Series [Ada] Spurious error on formal package with Inline_Always | expand

Commit Message

Arnaud Charlet Sept. 8, 2017, 1:31 p.m. UTC
This patch removes spurious errors appearing on a formal package of
an instantiation nestled within an enclosing instance body. when
the inner instance is a package that includes a subprogram with an
Inline_Always aspect.

The following must compile quietly:

gnstmske -q -gnatws main

---
with Def_Volume_Act_Conf;
with Env_Volume_Act_Conf;
with Iterate_On_Weekly_Values_General_G;

package body Airspace_Utilities is

  procedure Iteration_On_Active_Configurations_G (Airspace_Uid  : Env_Volume.T;
                                                  During_Period : Period.T) is
      pragma Unreferenced (Airspace_Uid);

      procedure Local_Action  (Activation_Info : Env_Volume_Act_Conf.T;
                               The_Period      : Period.T) is
         pragma Unreferenced (Activation_Info);

         procedure Config_Action (Subperiod : Period.T;
                                  Config    : Env_Configuration.T) is
         begin
            Action (Subperiod, Config);
         end Config_Action;

         use Def_Volume_Act_Conf;
         procedure Iterate_On_Periods is
           new Iterate_On_Weekly_Values_General_G (Value_T
                              => Env_Configuration.T,
                 Interval_T   => Def_Volume_Act_Conf.Base_Interval.T,
                 Value_Weekly => Def_Volume_Act_Conf.Weekly,
                 Action       => Config_Action);
      begin
         Iterate_On_Periods (Activity => Def_Volume_Act_Conf.Weekly.None,
                             Validity => The_Period);
      end Local_Action;
      procedure Iterate_On_Weekly_Activities is
        new Env_Volume_Act_Conf.Iteration_During_Period_G (Local_Action);

   begin
      Iterate_On_Weekly_Activities
        (Env_Volume.None,
         During_Period);
   end Iteration_On_Active_Configurations_G;

   procedure Set_Active (The_Airspace : Env_Volume.T)
   is
      procedure One_Configuration (Subperiod         : Period.T;
                        The_Configuration : Env_Configuration.T) is null;
      procedure Examine is
        new Iteration_On_Active_Configurations_G (Action => One_Configuration);
      pragma Compile_Time_Warning (True,
         "Instantiation fails with rather bogus error message.");
   begin
      Examine (The_Airspace, Period.None);
   end Set_Active;

end Airspace_Utilities;
---
with Env_Volume;
with Env_Configuration;
with Period;

package Airspace_Utilities is

   generic
      with procedure Action (Subperiod        : Period.T;
                             Configurable_Uid : Env_Configuration.T);
  procedure Iteration_On_Active_Configurations_G (Airspace_Uid  : Env_Volume.T;
                                                  During_Period : Period.T);

   procedure Set_Active (The_Airspace : Env_Volume.T);

end Airspace_Utilities;
---
with Ada.Strings;

generic

   type Bound_T is private;

package Base_Interval_G is

   type T is private;

private

   type T is array (Ada.Strings.Alignment) of Bound_T;
   pragma Compile_Time_Warning (True, "Indexed(?) type triggers the bug.");

   --     type T is null record;
   -- This version does not trigger the bug.

end Base_Interval_G;
---
with Base_Interval_G;
with Env_Configuration;
with General_Interval_Partition_G;
with Time;

package Def_Volume_Act_Conf is

   package Base_Interval is new Base_Interval_G (Bound_T => Time.Duration_T);

   package Weekly is new General_Interval_Partition_G
     (Item_T     => Time.Duration_T,
      Interval_T => Base_Interval.T,
      Value_T    => Env_Configuration.T);

end Def_Volume_Act_Conf;
---
with Env_Versioned_Value_Set_G;
with Interfaces;

package Env_Configuration is
  new Env_Versioned_Value_Set_G (Base_Uid_T => Interfaces.Integer_16);
generic

   type Base_Uid_T is range <>;

package Env_Versioned_Value_Set_G is

   type Base_T is new Base_Uid_T range Base_Uid_T'First .. Base_Uid_T'Last - 1;

   subtype T is Base_T range 0 .. Base_T'Last;

   subtype Uid_T is T;

   None : constant Uid_T := 0;

end Env_Versioned_Value_Set_G;
---
with Env_Versioned_Value_Set_G;
with Interfaces;

package Env_Volume is
  new Env_Versioned_Value_Set_G (Base_Uid_T => Interfaces.Integer_16);
package body Env_Volume_Act_Conf is

   procedure Iteration_During_Period_G (Vol           : Env_Volume.T;
                                        During_Period : Period.T) is
      pragma Unreferenced (Vol, During_Period);
   begin
      null;
   end Iteration_During_Period_G;

end Env_Volume_Act_Conf;
---
with Env_Volume;
with Period;

package Env_Volume_Act_Conf is

   type T is private;

   generic
      with procedure Action (Info     : T;
                             Validity : Period.T);
      pragma Unreferenced (Action);
   procedure Iteration_During_Period_G (Vol           : Env_Volume.T;
                                        During_Period : Period.T);

private

   type T is new Natural;

end Env_Volume_Act_Conf;
package body General_Interval_Partition_G is

   function Get (Partition : T; Key : Item_T) return Value_T is
      pragma Unreferenced (Partition, Key);
   begin
      return Result : Value_T
      do
         pragma Warnings (Off, Result);
         null;
      end return;
   end Get;

end General_Interval_Partition_G;
---
generic
   type Item_T is private;

   type Interval_T is private;
   pragma Unreferenced (Interval_T);
   pragma Compile_Time_Warning (True, "Type is required to trigger the bug.");

   type Value_T is private;

package General_Interval_Partition_G is

   type T is private;

   None : constant T;

   -- BUG: If Inline_Always is specified, the instantiation fails!
--   function Get (Partition : T; Key : Item_T) return Value_T;
  function Get (Partition : T; Key : Item_T) return Value_T with Inline_Always;
   pragma Compile_Time_Warning (True,
       "function declaration with Inline_Always triggers the bug.");

private

   type T is new Natural;

   None : constant T := T'First;

end General_Interval_Partition_G;
---
procedure Iterate_On_Weekly_Values_General_G (Activity : Value_Weekly.T;
                                              Validity : Period.T) is
   pragma Unreferenced (Activity, Validity);
begin
  null;
end Iterate_On_Weekly_Values_General_G;
---
with General_Interval_Partition_G;
with Period;
with Time;

generic

   type Value_T is private;

   type Interval_T is private;

   with package Value_Weekly is new General_Interval_Partition_G
     (Item_T     => Time.Duration_T,
      Interval_T => Interval_T,
      Value_T    => Value_T);

   with procedure Action (Subperiod : Period.T;
                          Value     : Value_T);
   pragma Unreferenced (Action);

procedure Iterate_On_Weekly_Values_General_G (Activity : Value_Weekly.T;
                                              Validity : Period.T);
---
with Airspace_Utilities;
with Env_Configuration;
with Period;

procedure Main is
   procedure Action (Subperiod        : Period.T;
                     Configurable_Uid : Env_Configuration.T) is null;
   procedure Iter is new
    Airspace_Utilities.Iteration_On_Active_Configurations_G (Action => Action);
   pragma Unreferenced (Iter);
begin
   null;
end Main;
---
generic

package Open_Interval_G is

   type T is private;

   None : constant T;

private

   type T is null record;

   None : constant T := (others => <>);

end Open_Interval_G;
---
with Open_Interval_G;

package Period is new Open_Interval_G;
package Time is

   type Duration_T is private;

   Zero           : constant Duration_T;
   One_Week   : constant Duration_T;

   None_Duration : constant Duration_T;

private

   type Duration_T is null record;

   None_Duration  : constant Duration_T := (others => <>);
   Zero           : constant Duration_T := (others => <>);
   One_Week       : constant Duration_T := (others => <>);

end Time;

Tested on x86_64-pc-linux-gnu, committed on trunk

2017-09-08  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Check_Formal_Packages): Do not apply conformance
	check if the instance is within an enclosing instance body. The
	formal package was legal in the enclosing generic, and is
	legal in the enclosing instantiation.  This optimisation may be
	applicable elsewhere, and it also removes spurious errors that
	may arise with on-the-fly processing  of instantiations that
	contain Inline_Always subprograms.
diff mbox series

Patch

Index: sem_ch12.adb
===================================================================
--- sem_ch12.adb	(revision 251892)
+++ sem_ch12.adb	(working copy)
@@ -6419,8 +6419,19 @@ 
 
                else
                   Formal_P := Next_Entity (E);
-                  Check_Formal_Package_Instance (Formal_P, E);
 
+                  --  If the instance is within an enclosing instance body
+                  --  there is no need to vertify the legqlity of current
+                  --  formsl psckages because they were legal in the generic
+                  --  body. This optimixation may be applicable elsewhere,
+                  --  and it also removes spurious errors that may arise with
+                  --  on-the-fly inlining and confusion between private and
+                  --  full views.
+
+                  if not In_Instance_Body then
+                     Check_Formal_Package_Instance (Formal_P, E);
+                  end if;
+
                   --  After checking, remove the internal validating package.
                   --  It is only needed for semantic checks, and as it may
                   --  contain generic formal declarations it should not reach