Re: How to get generic formal parameter type into base class

[Adam Beneschan <adam@irvine.com>]

On Friday, October 5, 2012 3:23:01 PM UTC-7, (unknown) wrote:
> Is there a way to get a generic formal parameter type into base class so that I can dispatch to a function with that type in the function signature? Below is what I am trying to achieve, and of course the main procedure will not compile.
> 
> Thanks,
> 
> 
> 
> package Classes is
> 
>    type Value_Type is range -2 ** 31 .. 2 ** 31 - 1;
> 
>    generic
>       type Data_Type is (<>);
>    package Translate_Base is
> 
>       type Xlate_Base_Type is abstract tagged record
>          Value : Data_Type := Data_Type'first;
>       end record; 
> 
>       procedure Decode   (Xlate_Class : in out Xlate_Base_Type; 
>                           Value : in Value_Type) is abstract;
>       function  Encode   (Xlate_Class : in     Xlate_Base_Type) 
>                           return Value_Type is abstract;
>       function  Get_Value(Xlate_Class : in     Xlate_Base_Type) 
>                           return Data_Type is abstract;
>       procedure Set_Value(Xlate_Class : in out Xlate_Base_Type; 
>                           Value : in Data_Type) is abstract;
>
>    end Translate_Base;
> 
> 
>    generic
>       type Data_Type is (<>);
>    package Translate_Integer is 
> 
>       package base is new Translate_Base(Data_Type);
>       type Xlate_Type is new base.Xlate_Base_Type with record
>          Signed     : Boolean   := False;
>       end record;
> 
>       procedure Decode   (Xlate_Class : in out Xlate_Type; 
>                           Value : in Value_Type);
>       function  Encode   (Xlate_Class : in     Xlate_Type) return Value_Type;
>       function  Get_Value(Xlate_Class : in     Xlate_Type) return Data_Type;
>       procedure Set_Value(Xlate_Class : in out Xlate_Type; 
>                           Value : in Data_Type);
> 
>    end Translate_Integer;
> 
>    -- define Translate_Enumuration
>    -- define Translate_Float
>    -- ...
> 
> end Classes;
> 
> package body Classes is
> 
>    package body Translate_Integer is
> 
>       procedure Decode   (Xlate_Class : in out Xlate_Type; 
>                           Value : in Value_Type) is
>       begin
>          Xlate_Class.Value := Data_Type'val(Value);
>       end Decode;
> 
>       function  Encode   (Xlate_Class : in     Xlate_Type) return Value_Type is
>       begin
>          return Data_Type'pos(Xlate_Class.Value);
>       end Encode;
> 
>       function  Get_Value(Xlate_Class : in     Xlate_Type) return Data_Type is
>       begin
>          return Xlate_Class.Value;
>       end Get_Value;
> 
>       procedure Set_Value(Xlate_Class : in out Xlate_Type; 
>                           Value : in Data_Type) is
>       begin
>           Xlate_Class.Value := Value;
>       end Set_Value;
>    end Translate_Integer;
> 
> end Classes;
> 
> with Classes;
> 
> package Objects is
> 
>    type Int_100_Type is range -100 .. 100;
> 
>    package Int_100 is new Classes.Translate_Integer(Int_100_Type);
> 
> end Objects; 
> 
> with Classes;
> with Objects;
> with Ada.Text_IO;
> 
> procedure main is

>    procedure PrintLn(Item : String) renames Ada.Text_IO.Put_Line;
> 
>    type Message_ID_Type is (type1);
> 
>    function Factory_Get (Message_ID : in Message_ID_Type)  
>                          return Classes.Xlate_Base_Type'class is
>    begin
>
>       case Message_ID is
>       when type1 =>
>          declare
>             This : Objects.Int_100.Xlate_Type;
>          begin
>             return This;
>          end;
>       end case;
> 
>    end Factory_Get;
> 
>    This : Classes.Xlate_Base_Type'class := Factory_Get(type1);
>    Value : Classes.Value_Type;
>    My_Value : Objects.Int_100_Type;
> begin
> 
>    Value := 255;  -- get FF from input stream.
>    Classes.Translate_Base.Decode(This, Value);
>    My_Value := Classes.Translate_Base.Get_Value(This);
> 
>    -- do something
> 
>    Classes.Translate_Base.Set_Value(This, My_Value);
>    Value := Classes.Translate_Base.Encode(This);
> end main;

Since you're trying to use Xlate_Type'Class, it looks like you're thinking that the types involved are all related.  They're not.  A generic package isn't useful until you instantiate it, and instantiating the package has pretty much the same effect as writing it all over again, substituting something different for the formal parameters.  It's something like a macro substitution.  And if you had two types with the same name in different packages, e.g.

   package Instantiation_1 is
      type Xlate_Type is tagged record ...
   end Instantiation_1;

   package Instantiation_2 is
      type Xlate_Type is tagged record ...
   end Instantiation_2;

you wouldn't expect the two Xlate_Type types to be related at all, and you wouldn't expect a 'Class type to be able to represent both.  Well, that's pretty much what you're getting when you define the type in the instantiation.

What I think you want to do is declare an abstract root type *outside* any generic, and declare abstract procedures/functions Decode, Encode, etc., in the same package outside the generic.  Then, in Translate_Base (which could still be generic), make your Xlate_Type a type extension of that root type.  Now you can declare something as Your_Root_Type'Class and this object could represent any type derived from Your_Root_Type, including those in generic instantiations, and it could dispatch to those procedures and functions.

Hope this helps,

                               -- Adam