How to save an Access type of a Discriminant record for later use

user_439274 0
Viewed 113

Issue:

How do I save an Access Pointer to a discriminant record for use later on in the program? In main.adb (1) I demonstrate how I was able to get it to compile, but I get a runtime error: raised PROGRAM_ERROR : main.adb:14 accessibility check failed

Note:

This is small example program based on a much larger/complex codebase.

Constraints:

i. The solution is required to be Ada95 Compatible.

ii. The solution must not change the package specification of Foo.ads as this is existing code that must be used as-is.

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;

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

main.adb

-------------------------------------------------------------------------------
--
-- 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;
ada
4 Answers

Quick answer:

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

Checked as far as I can with

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$
user_408510

In the line

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

replace 'Access with 'Unchecked_Access.

PS. It could cause a dangling references if you destroy the object before Foo_Ptr gone.

user_22084720

The types Base_Class_Ref and Foo_Class_Ref are named access types and variables of this type can only refer to objects either on the heap or on package level, NOT objects on the stack. Since Storage_Size is set to zero it means the heap is out of the question.

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;

I hope this solution applicable to your use-case since it avoids usage of Unchecked_Access.

user_34633380

Ok what you're dealing with here is an anonymous access type, from the signature procedure TEST (This_Ptr : access Foo.Foo_Class). The error is telling you that this particular subprogram is in a deeper nesting than the thing it's pointing to: IOW, it could give you a dangling reference.

The proper solution, staying strictly in Ada95 would be to (A) put the TEST subprogram in the library unit [IIRC; 95 and 2005 are so similar they blur together]; or (B) put use a generic.

For a generic, IIRC, you can do this:

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

This might require a little fiddling for your application, but if you put the generic inside Foo.ads/Foo.adb`, it should work. [IIRC] Aside from this, your best bet is to move your aliased object outside your main subprogram's declaration area, then it should work.

user_6089630
Related