Ada 如何保存鉴别记录的访问类型以供以后使用

问题：

如何保存鉴别记录的访问指针以供以后在程序中使用？ 在main.adb（1）中，我演示了如何编译它，但我遇到了一个运行时错误：

引发的程序\u错误：main.adb:14辅助功能检查失败

注意：

这是一个基于更大/更复杂代码库的小示例程序

约束条件：

一,。要求该溶液与Ada95兼容

二,。解决方案不得更改Foo.ads的包规范，因为这是必须按原样使用的现有代码

foo.ads

with Interfaces;
package Foo is
   
       type Base_Class is abstract tagged limited private;
    
       type Base_Class_Ref is access all Base_Class'Class;
       for Base_Class_Ref'Storage_Size use 0;
    

        Max_Count : constant := 6;

        type Count_Type is new Interfaces.Unsigned_16 range 1 .. Max_Count;

        type Foo_Class (Max : Count_Type) is new Base_Class with private;

        type Foo_Class_Ref is access all Foo_Class;
        for Foo_Class_Ref'Storage_Size use 0;

        --
        procedure Initialize (This_Ptr : Access Foo_Class);
        
        --
        function Get_Using_Pointer (This_Ptr : in Foo_Class_Ref) return Interfaces.Unsigned_16;

private
   type Base_Class is abstract tagged limited null record;
   
   type My_Data_Type is
        record
           X, Y, Z : Interfaces.Unsigned_16;
        end record;

    type My_Data_Array is
        array (Count_Type range <>) of My_Data_Type;

    type Foo_Class (Max : Count_Type) is new Base_Class with
        record
            Other_Data : Interfaces.Unsigned_16;
            Data       : My_Data_Array(1 .. Max);
        end record;

end Foo;

main.adb

package body Foo is

    -- --------------------------------------------------------------------
    procedure Initialize (This_Ptr : Access Foo_Class) is
    begin
        This_Ptr.Other_Data := 0;
        This_Ptr.Data := (others => (0,0,0));
    end Initialize;

    -- --------------------------------------------------------------------
    function Get_Using_Pointer (This_Ptr : in Foo_Class_Ref)
        return Interfaces.Unsigned_16 is
    begin
        return This_Ptr.Other_Data;
    end Get_Using_Pointer;

end Foo;

-------------------------------------------------------------------------------
--
-- Issue:
-- How do I save an Access Pointer for later use (1) to a discriminent record?
--
-- Constraints:
--  i. The solution is required to be Ada95 Compatible.
-- ii. The solution must not change the package specification of Foo.ads
--
-------------------------------------------------------------------------------
--
with Interfaces;
with Foo;

procedure Main is

    Foo_Count : constant := 3;
    Foo_Obj   : aliased Foo.Foo_Class (Max => Foo_Count);

   procedure TEST (This_Ptr : access Foo.Foo_Class) is      

      -- (1) Save Pointer
      -- **** This Line reports: ****
      -- raised PROGRAM_ERROR : main.adb:14 accessibility check failed
      Foo_Ptr : Foo.Foo_Class_Ref := This_Ptr.all'Access;    -- This Compiles...
      
      -- ^^^ I know that this is not correct.
      --     But it was the only way I could find to get it to compile.      
      
      Data    : Interfaces.Unsigned_16;
      
   begin
      
      -- (2) Get Data
      Data := Foo.Get_Using_Pointer(This_Ptr => Foo_Ptr);    -- This Compiles...

   end;

begin

   Foo.Initialize(This_Ptr => Foo_Obj'Access);
   
   Test(This_Ptr => Foo_Obj'Access);
   
end Main;

快速回答：

Foo\u Ptr:Foo.Foo\u Class\u Ref:=此\u Ptr.all'Unchecked\u访问；

尽我所能与你核实

lockheed:jerunh simon$ gnatmake main.adb -gnat95 -f
gcc -c -gnat95 main.adb
gcc -c -gnat95 foo.adb
gnatbind -x main.ali
gnatlink main.ali
lockheed:jerunh simon$ ./main
lockheed:jerunh simon$ 

排队

Foo_Ptr : Foo.Foo_Class_Ref := This_Ptr.all'Access;

将

'Access

替换为

'Unchecked\u Access

---

PS.如果在

Foo_Ptr

消失之前销毁对象，可能会导致悬空引用。

类型Base_Class_Ref和Foo_Class_Ref是命名访问类型，此类型的变量只能引用堆或包级别的对象，而不能引用堆栈上的对象。由于存储大小设置为零，这意味着堆是不可能的

package Main_App is

   procedure Run;

end Main_App;

package body Main_App is

   procedure TEST (This_Ptr : access Foo.Foo_Class) is      

      -- (1) Save Pointer
      -- **** This Line reports: ****
      -- raised PROGRAM_ERROR : main.adb:14 accessibility check failed
      Foo_Ptr : Foo.Foo_Class_Ref := This_Ptr.all'Access;    -- This Compiles...
      
      -- ^^^ I know that this is not correct.
      --     But it was the only way I could find to get it to compile.      
      
      Data    : Interfaces.Unsigned_16;
      
   begin
      
      -- (2) Get Data
      Data := Foo.Get_Using_Pointer(This_Ptr => Foo_Ptr);    -- This Compiles...

   end TEST;

   Foo_Count : constant := 3;
   Foo_Obj   : aliased Foo.Foo_Class (Max => Foo_Count);

   procedure Run is
   begin
      Foo.Initialize (This_Ptr => Foo_Obj'Access);
   
      TEST (This_Ptr => Foo_Obj'Access);
   end Run;

end Main_App;

with Main_App;
procedure Main is
begin
   Main_App.Run;
end Main;

---

我希望此解决方案适用于您的用例，因为它避免使用未经检查的访问。

好的，您在这里处理的是一种匿名访问类型，来自签名

过程测试（此\u Ptr:Access Foo.Foo\u类）

。这个错误告诉你，这个特殊的子程序的嵌套比它指向的东西更深：瞧，它可能会给你一个悬空的引用

严格遵守Ada95的正确解决方案是：（A）将

测试
子程序放在库单元中[IIRC；95和2005非常相似，它们模糊在一起]；或者（B）使用
通用

对于通用IIRC，您可以执行以下操作：

Generic
   Object : Aliased Foo_Class'Class; -- Might not need 'Class.
   with Function Operation(This_Ptr : in Foo_Class_Ref) return Interfaces.Unsigned_16;
Procedure Execute;
--...
Procedure Execute is
   Result : Interfaces.Unsigned_16;
Begin
   Result:= Operation( Object'Access );
End Execute;
----------------------------------------
O : Aliased Foo.Foo_Class(3);
Procedure TEST is new Foo.Execute( Operation => Foo.Get_Using_Pointer, Object => O );

这可能需要对应用程序进行一些修改，但是如果将泛型放在Foo.ads
/
Foo.adb`中，它应该可以工作。[IIRC]除此之外，最好的办法是将别名对象移到主子程序声明区域之外，然后它就可以工作了