在 Ada 95 中实现具有类范围操作的接口

Question

我正在使用 Ada 95 创建一个程序，但遇到了问题。具体来说，我正在尝试实现一个执行作为参数给出的函子的类。

我想要实现的行为是：

• 用过程Execute声明一个接口IF。
• 从IF 派生类C 并实现Execute。
• 创建一个类D，它的字段是IF 的数组。由于IF无法实例化，我使用access IF的数组。
• 实例化一个 D 类的对象，为其提供多个 C 实例作为参数。
• 对 D 数组中包含的每个 C 实例调用 Execute。

我已经能够实现上述并编译它，但是当我执行它时，当我尝试将类C 的对象分配给D 中的数组组件时，我得到错误可访问性检查失败。

我知道我得到的错误是因为我正在做的分配可能会导致根据 Ada 策略的危险指针错误，所以我的问题是 在 Ada 95 中实现此功能的正确方法是什么？

源代码如下。错误在文件elevators.adb 中出现，在过程Add_Event_Handler 中，我已经注释了导致它的语句。

Functors.ads

package Functors is

    type IFunctor is abstract tagged null record;

    procedure Execute(Self : in out IFunctor) is abstract;

end Functors;

Elevators.ads

with Functors; use Functors;

package Elevators is

    NOT_A_FLOOR : constant := -1;
    MAX_EVENT_HANDLERS : constant := 255;

    type Floor is new Integer range NOT_A_FLOOR .. 4; 

    type Elevator is private;

    subtype Event_Handler is IFunctor'Class; --'
    type Event_Handler_Index is new Integer range 0 .. MAX_EVENT_HANDLERS;
    type Event_Handers is array(Event_Handler_Index) of access Event_Handler;


    function Create_Elevator return Elevator;

    procedure Add_Stop_Handler(Self : in out Elevator; Handler : access Event_Handler);
    procedure Add_Moving_Handler(Self : in out Elevator; Handler : access Event_Handler);
    procedure Add_Called_Handler(Self : in out Elevator; Handler : access Event_Handler);
    procedure Add_Button_Pressed_Handler(Self : in out Elevator; Handler : access Event_Handler);

    procedure Run_Simulation(Self : in out Elevator);

    private
        type Elevator is
        record
            Current_Floor : Floor := 0;
            Is_Moving : Boolean := False;
            Next_Floor : Floor := NOT_A_FLOOR;

            Stop : Event_Handers := (others => null);
            Moving : Event_Handers := (others => null);
            Called : Event_Handers := (others => null);
            Button_Pressed : Event_Handers := (others => null);
        end record;

        procedure On_Stop(Self : in out Elevator);
        procedure On_Moving(Self : in out Elevator);
        procedure On_Called(Self : in out Elevator);
        procedure On_Button_Pressed(Self : in out Elevator);

        procedure Add_Event_Handler(Self : out Event_Handers; Handler : access Event_Handler);
        procedure Exec_All_Events(Self : in out Elevator; EH : in Event_Handers);

end Elevators;

电梯.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Elevators is

    function Create_Elevator return Elevator is
        elev : Elevator;
    begin
        return elev;
    end;

    procedure Add_Stop_Handler(self : in out Elevator; Handler : access Event_Handler) is
    begin
        Add_Event_Handler(self.Stop, Handler);
    end;

    procedure Add_Moving_Handler(self : in out Elevator; Handler : access Event_Handler) is
    begin
        Add_Event_Handler(self.Moving, Handler);
    end;

    procedure Add_Called_Handler(self : in out Elevator; Handler : access Event_Handler) is
    begin
        Add_Event_Handler(self.Called, Handler);
    end;

    procedure Add_Button_Pressed_Handler(self : in out Elevator; Handler : access Event_Handler) is
    begin
        Add_Event_Handler(self.Button_Pressed, Handler);
    end;

    procedure Run_Simulation(self : in out Elevator) is
    begin
        Put_Line("Floor: " & Floor'Image(self.Current_Floor)); --'
        self.Next_Floor := 3;

        On_Called(self);
        On_Moving(self);
        On_Stop(self);
    end;

    procedure On_Stop(self : in out Elevator) is
    begin
        self.Current_Floor := self.Next_Floor;
        self.Is_Moving := False;
        self.Next_Floor := NOT_A_FLOOR;

        Put_Line("Stopped. Current floor = " & Floor'Image(self.Current_Floor)); --'

        Exec_All_Events(self, self.Stop);
    end;

    procedure On_Moving(self : in out Elevator) is
    begin
        self.Is_Moving := True;
        self.Current_Floor := NOT_A_FLOOR;
        Put_Line("Moving to floor " & Floor'Image(self.Next_Floor)); --'

        Exec_All_Events(self, self.Moving);
    end;

    procedure On_Called(self : in out Elevator) is
    begin
        Put_Line("Calling button pressed (" & Floor'Image(self.Next_Floor) & ")..."); --'

        Exec_All_Events(self, self.Moving);
    end;

    procedure On_Button_Pressed(self : in out Elevator) is
    begin
        null;
    end;

    procedure Add_Event_Handler(Self : out Event_Handers; Handler : access Event_Handler) is
        I : Event_Handler_Index := Event_Handler_Index'First; --'
    begin
        while I < Event_Handler_Index'Last loop --'
            if Self(I) = null then
                Self(I) := Handler; -- ======> The error is raised here <======
                exit;
            end if;
            I := I + 1;
        end loop;
    end;

    procedure Exec_All_Events(self : in out Elevator; EH : in Event_Handers) is
        I : Event_Handler_Index := Event_Handler_Index'First; --'
    begin
         while I < Event_Handler_Index'Last loop --'
            if EH(I) /= null then
                EH(I).Execute;
            end if;
            I := I + 1;
        end loop;
    end;

end Elevators;

main.adb

with Ada.Text_IO; use Ada.Text_IO;
with Functors; use Functors;
with Elevators; use Elevators;

procedure Main is

    type My_Functor is new IFunctor with
    record
        I : Integer := 0;
    end record;

    overriding
    procedure Execute(Self : in out My_Functor) is
    begin
        Put_Line("Executing functor, I is " & Integer'Image(Self.I)); --'
        Self.I := Self.I + 1;
    end;

    Generic_Functor : aliased My_Functor;
    Elev : Elevator := Create_Elevator;
begin
    Add_Stop_Handler(elev, Generic_Functor'Access); --'
    Add_Moving_Handler(elev, Generic_Functor'Access); --'
    Add_Called_Handler(elev, Generic_Functor'Access); --'

    Run_Simulation(Elev);
end;

编辑

我已进行以下更改以修复上述运行时错误，但我仍然获得accessibility check failed。

elevators.ads

...
type Event_Handler_Generic_Ptr is access all Event_Handler;
type Event_Handers is array(Event_Handler_Index) of Event_Handler_Generic_Ptr;
...

电梯.adb

procedure Add_Event_Handler(Self : out Event_Handers; Handler : access Event_Handler) is
        I : Event_Handler_Index := Event_Handler_Index'First; --'
    begin
        while I < Event_Handler_Index'Last loop --'
            if Self(I) = null then
                -- Notice the casting here
                Self(I) := Event_Handler_Generic_Ptr(Handler); -- ======> The error is raised here <======
                exit;
            end if;
            I := I + 1;
        end loop;
    end;

Answer 1

由于您将使用'Access 生成的指针存储在Event_Handlers 中，因此必须使用access all 声明它，使其成为通用访问类型：

type Event_Handers is array(Event_Handler_Index) of access all Event_Handler;

如果您错过 all，则它是一种特定于池的访问类型。请参阅Ada 95 RM, 3.10 Access Types、(8) 和 (10)。 pool-specific 访问类型可能只包含指向在存储池中分配的对象的指针，而您的对象不是。