Re: Subprogram Pointer in a Generic

[tmoran@acm.org]

> It is the other way around: he wants to call the procedure taking
> the access-to-subprogram formal parameter *from* within the body of
> the generic package.

> (2) Is there a more robust way of working around it?
  You want to be able to save away a pointer to a procedure?  A tagged
type carries a vector of procedure pointers, so an "access T'class"
is effectively a simple pointer to a list of (one or more) pointers.
The following code registers two instantiations of a generic, one
with a "type T is Positive" and the other with "type T is Boolean".
It then calls the saved registerees, printing for T'image(T'first)
 1
FALSE

package Testr is
  type Registerable_Type is abstract tagged null record;
  procedure Proc(Dummy : Registerable_Type) is abstract;

  type Ptr_To_Registerable_Type is access all Registerable_Type'Class;
  procedure Register(Registeree : Ptr_To_Registerable_Type);

  procedure Call(Index : in Integer);
end Testr;

package body Testr is
  P : array (1 .. 3) of Ptr_To_Registerable_Type;
  N : Natural := 0;

  procedure Register(Registeree : Ptr_To_Registerable_Type) is
  begin
    N := N + 1;
    P(N) := Registeree;
  end Register;

  procedure Call(Index : in Integer) is
  begin
    Proc(P(Index).all);
  end Call;
end Testr;

with Testr;
generic
  type T is (<>);
package Testrg is
  procedure Register_It;
private
  type My_Registerable_Type is new Testr.Registerable_Type with null record;
  procedure Proc(Dummy : My_Registerable_Type);
end Testrg;

with Ada.Text_Io;
package body Testrg is
  Jump_Vector: aliased My_Registerable_Type;

  procedure Proc(Dummy : My_Registerable_Type) is
  begin
    Ada.Text_Io.Put_Line(T'Image(T'First));
  end Proc;

  procedure Register_It is
  begin
    Testr.Register(Jump_Vector'unchecked_access);
  end Register_It;
end Testrg;

with Testrg;
package Testr1 is
  package A is new Testrg(Positive);
  package B is new Testrg(Boolean);
end Testr1;

with Testr1, Testr;
with Ada.Text_Io;
procedure Testr2 is
begin
  Testr1.A.Register_It;
  Testr1.B.Register_It;
  Testr.Call(1);  -- first registeree was A, type T was Positive
  Testr.Call(2);  -- second registeree was B, type T was Boolean
end Testr2;