[我之前问过question关于Ada进行的可访问性检查，@ Brian Drummond对遮阳篷很友善。可访问性检查在一个函数中，现在我在一个程序中有一个类似的问题；任何关于为什么这样做的指导将不胜感激。
我正在处理的代码已从此处获取：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;
对于为什么发生这种情况的任何帮助，将不胜感激。
谢谢
您在这里看到的是使用匿名访问类型的结果（在ARM 3.10.2中进行了讨论，在Ada的维护者中非正式地称为“黑暗之心”。]]
我不认为有一种简单的解决方法（除了使用我们之前发现的-gnatp来抑制所有检查；尽管也许您很幸运）>
pragma Suppress (Accessibility_Check);以有问题的单位为准。
[我设法获得了一个没有
Program_Error的版本，但遭到了相当残酷的黑客攻击，整个过程都将匿名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;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;理想情况下，我还考虑过让
Create_Simple_Command也返回命名访问类型。您可以在Github看到我去的地方。