Ada

Question

我之前问过关于 Ada 中提出的可访问性检查的问题，@Brian Drummond 非常友好地提出了 awnser。可访问性检查在一个函数中，现在我在一个过程中遇到了类似的问题；任何关于为什么会这样的指导将不胜感激。

我正在处理的代码取自这里：https://github.com/raph-amiard/ada-synth-lib

下面主文件中的代码来自 Simple_Sine 示例，可在此处找到： https://github.com/raph-amiard/ada-synth-lib/blob/master/examples/simple_sine.adb

我的主文件如下所示：

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;

引发的错误是这样的： raised PROGRAM_ERROR : sound_gen_interfaces.adb:20 accessibility check failed

在调用此过程期间引发：

   -- 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;

这是下面代码的第 20 行：

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;

如能提供任何有关发生这种情况的帮助，我们将不胜感激。

谢谢

Answer 1

您在这里看到的是（过度）使用匿名访问类型的结果（在 ARM 3.10.2 中讨论过，在 Ada 的维护者中被非正式地称为“黑暗之心”）。

我不认为有解决这个问题的简单方法（除了使用 -gnatp，正如我们之前发现的那样，禁止所有检查；尽管您可能运气好

pragma Suppress (Accessibility_Check);

在有问题的单元中。

我设法获得了一个没有 Program_Errors 的构建，使用了相当残酷的黑客攻击，将匿名的 access I_Simulation_Listener'Class 更改为命名的 Simulation_Listener_Access，例如，

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;

至

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;

理想情况下，我会考虑让 Create_Simple_Command 也返回命名访问类型。

你可以在 Github 查看我到达的位置。

Ada - 在过程中引发的可访问性检查

Ada - Accessibility check raised within a procedure

gnat

gnat-gps

ada2012