Ada - Accessibility check raised within a procedure

Question

I previously asked a question regarding accessibility checks being raised in Ada, which @Brian Drummond was kind enough to awnser. The accessibility check was in a function, now I have a similair problem within a procedure; any guidance as to why this is would be greatly appreciated.

The code I am working on has been taken from here: https://github.com/raph-amiard/ada-synth-lib

The code in main file below is from the the Simple_Sine example which can be found here: https://github.com/raph-amiard/ada-synth-lib/blob/master/examples/simple_sine.adb

My main file looks like this:

with Write_To_Stdout;
with Command; use Command;
with Effects; use Effects;
with Sound_Gen_Interfaces; use Sound_Gen_Interfaces;
with Utils; use Utils;

procedure main is
   pragma Suppress (Accessibility_Check);
   BPM   : Natural := 15;
   Notes : Notes_Array :=
     To_Seq_Notes ((C, G, F, G, C, G, F, A, C, G, F, G, C, G, F, G), 400, 4);

   function Simple_Synth
     (S    : access Simple_Sequencer; Tune : Integer := 0; Decay : Integer)
      return access Mixer
   is
     (Create_Mixer
        ((0 => (Create_Sine (Create_Pitch_Gen (Tune, S)), 0.5)),
         Env => Create_ADSR (5, 50, Decay, 0.5, S)));

   Volume     : Float   := 0.9;
   Decay      : Integer := 800;
   Seq        : access Simple_Sequencer;
   Sine_Gen   : access Mixer;
   Main       : constant access Mixer := Create_Mixer (No_Generators);
begin
   for I in -3 .. 1 loop
      Seq      := Create_Sequencer (16, BPM, 1, Notes);
      Sine_Gen := Simple_Synth (Seq, I * 12, Decay);
      Main.Add_Generator (Sine_Gen, Volume);
      BPM    := BPM * 2;
      Volume := Volume / 1.8;
      Decay  := Decay / 2;
   end loop;

   Write_To_Stdout (Main);
end main;

The error that's raised is this: raised PROGRAM_ERROR : sound_gen_interfaces.adb:20 accessibility check failed

It is raised during a call to this procedure:

   -- Register_Note_Generator --
   -----------------------------

   procedure Register_Simulation_Listener
     (N : access I_Simulation_Listener'Class) is
   begin
      Simulation_Listeners (Simulation_Listeners_Nb) := N;
      Simulation_Listeners_Nb := Simulation_Listeners_Nb + 1;
   end Register_Simulation_Listener;

Which is line 20 of the code below:

with Ada.Containers.Vectors;

package body Sound_Gen_Interfaces is

   package PA_Vectors
   is new Ada.Containers.Vectors (Natural, Params_Scope);

   Params_Aggregators : PA_Vectors.Vector;

   function Current_FPA return Params_Scope is
     (Params_Aggregators.Last_Element);

   -----------------------------
   -- Register_Note_Generator --
   -----------------------------

   procedure Register_Simulation_Listener
     (N : access I_Simulation_Listener'Class) is
   begin
      Simulation_Listeners (Simulation_Listeners_Nb) := N;
      Simulation_Listeners_Nb := Simulation_Listeners_Nb + 1;
   end Register_Simulation_Listener;

   ---------------
   -- Next_Step --
   ---------------

   procedure Next_Steps is
   begin
      for I in 0 .. Simulation_Listeners_Nb - 1 loop
         Simulation_Listeners (I).Next_Step;
      end loop;
   end Next_Steps;

   ----------------
   -- Base_Reset --
   ----------------

   procedure Base_Reset (Self : in out Generator) is
   begin
      null;
   end Base_Reset;

   --------------------
   -- Reset_Not_Null --
   --------------------

   procedure Reset_Not_Null (Self : Generator_Access) is
   begin
      if Self /= null then
         Self.Reset;
      end if;
   end Reset_Not_Null;

   --------------------
   -- Reset_Not_Null --
   --------------------

   procedure Reset_Not_Null (Self : Note_Generator_Access) is
   begin
      if Self /= null then
         Self.Reset;
      end if;
   end Reset_Not_Null;

   --------------------------
   -- Compute_Fixed_Params --
   --------------------------

   procedure Compute_Params (Self : in out Generator) is

      procedure Internal (Self : in out Generator'Class);
      procedure Internal (Self : in out Generator'Class) is
      begin
         for C of Self.Children loop
            if C /= null then
               if C.Is_Param then
                  Add_To_Current (C);
               end if;
               Internal (C.all);
            end if;
         end loop;
      end Internal;

   begin
      Self.Parameters := new Params_Scope_Type;
      Enter (Self.Parameters);
      Internal (Self);
      Leave (Self.Parameters);
   end Compute_Params;

   -----------
   -- Enter --
   -----------

   procedure Enter (F : Params_Scope) is
   begin
      Params_Aggregators.Append (F);
   end Enter;

   -----------
   -- Leave --
   -----------

   procedure Leave (F : Params_Scope) is
   begin
      pragma Assert (F = Current_FPA);
      Params_Aggregators.Delete_Last;
   end Leave;

   --------------------
   -- Add_To_Current --
   --------------------

   procedure Add_To_Current (G : Generator_Access) is
      use Ada.Containers;
   begin
      if Params_Aggregators.Length > 0 then
         Current_FPA.Generators.Append (G);
      end if;
   end Add_To_Current;

   ------------------
   -- All_Children --
   ------------------

   function All_Children
     (Self : in out Generator) return Generator_Array
   is
      function All_Children_Internal
        (G : Generator_Access) return Generator_Array
      is
        (G.All_Children) with Inline_Always;

      function Is_Null (G : Generator_Access) return Boolean
      is (G /= null) with Inline_Always;

      function Cat_Arrays
      is new Generator_Arrays.Id_Flat_Map_Gen (All_Children_Internal);

      function Filter_Null is new Generator_Arrays.Filter_Gen (Is_Null);

      S : Generator'Class := Self;
      use Generator_Arrays;
   begin
      return Filter_Null (S.Children & Cat_Arrays (Filter_Null (S.Children)));
   end All_Children;

   ----------------
   -- Get_Params --
   ----------------

   function Get_Params
     (Self : in out Generator) return Generator_Arrays.Array_Type
   is
      use Generator_Arrays;

      function Internal
        (G : Generator_Access) return Generator_Arrays.Array_Type
      is
        (if G.Parameters /= null
         then Generator_Arrays.To_Array (G.Parameters.Generators)
         else Generator_Arrays.Empty_Array) with Inline_Always;

      function Cat_Arrays
      is new Generator_Arrays.Id_Flat_Map_Gen (Internal);

   begin
      return Internal (Self'Unrestricted_Access)
        & Cat_Arrays (Self.All_Children);
   end Get_Params;

   ----------------------
   -- Set_Scaled_Value --
   ----------------------

   procedure Set_Scaled_Value
     (Self : in out Generator'Class; I : Natural; Val : Scaled_Value_T)
   is
      V : Float :=
        (if Self.Get_Scale (I) = Exp
         then Exp8_Transfer (Float (Val)) else Float (Val));
      Max : constant Float := Self.Get_Max_Value (I);
      Min : constant Float := Self.Get_Min_Value (I);
   begin
      V := V * (Max - Min) + Min;
      Self.Set_Value (I, V);
   end Set_Scaled_Value;

end Sound_Gen_Interfaces;

Any help as to why this is happening would be greatly appreciated.

Thank you

Answer 1

What you're seeing here is the result of (over-)using anonymous access types (discussed in ARM 3.10.2, informally known as the “Heart of Darkness” amongst the maintainers of Ada).

I don't think there's a simple way around this (aside from using -gnatp, as we found earlier, to suppress all checks; though perhaps you might have luck with

pragma Suppress (Accessibility_Check);

in the units where there's a problem).

I managed to get a build without Program_Errors with a fairly brutal hack, changing the anonymous access I_Simulation_Listener'Class to the named Simulation_Listener_Access throughout and, for example,

function Create_Simple_Command
  (On_Period, Off_Period : Sample_Period;
   Note : Note_T) return access Simple_Command'Class
is
begin
   return N : constant access Simple_Command'Class
     := new Simple_Command'(Note       => Note,
                            Buffer     => <>,
                            On_Period  => On_Period,
                            Off_Period => Off_Period,
                            Current_P  => 0)
   do
      Register_Simulation_Listener (N);
   end return;
end Create_Simple_Command;

to

function Create_Simple_Command
  (On_Period, Off_Period : Sample_Period;
   Note : Note_T) return access Simple_Command'Class
is
   Command : constant Simulation_Listener_Access
     := new Simple_Command'(Note       => Note,
                            Buffer     => <>,
                            On_Period  => On_Period,
                            Off_Period => Off_Period,
                            Current_P  => 0);
begin
   Register_Simulation_Listener (Command);
   return Simple_Command (Command.all)'Access;
end Create_Simple_Command;

Ideally I'd have thought about having Create_Simple_Command returning a named access type too.

You can see where I got to at Github.