使用过程 class-wide out 参数作为函数 return 值

Question

   type T is abstract tagged null record;
   type T1 is new T with null record;
   
   procedure Get_Value (Value : out T'Class) is
      T1_Value : T1 := (null record);
   begin
      Value := T'Class (T1_Value);
   end;
   
   function Result return T'Class is
      T_Class_Value : T'Class; -- Initialization required
   begin
      Get_Value (T_Class_Value);
      return T_Class_Value;
   end Result;

在此代码中 T_Class_Value 需要初始化。如何从 Get_Value 参数初始化 T_Class_Value？

Answer 1

with Ada.Text_Io; use ADa.Text_IO;

procedure Main is
   type T is abstract tagged null record;
   type T1 is new T with null record;
   
   function Result return T1'Class is
      T1_Value : t1 := (Null record);
   begin
      return T1'Class(T1_Value);
   end Result;
   
   T1_Class : T1'Class := Result;
   
begin
   Put_Line("It works");
end Main;

Answer 2

这很丑陋，但可以编译：

subtype T_Class is T'Class;
type T_Class_Access is access T_Class;

procedure Get_Value (Value_P : out T_Class_Access) is
   T1_Value : T1 := (null record);
   T_Class_Value : T_Class := T'Class (T1_Value);
begin
   Value_P := new T_Class'(T_Class_Value);
end;

function Result return T'Class is
   T_Class_P : T_Class_Access;
begin
   Get_Value (T_Class_P);
   return Result : T'Class := T_Class_P.all do
      Free (T_Class_P);
   end return;
end Result;

Answer 3

我不知道这个想法有多好，但到目前为止我已经确定了这个解决方案：

   type T is abstract tagged null record;
   type T1 is new T with null record;
   
   type T_Null_Stub is new T with null record;   
   T_Null : constant T_Null_Stub := (null record);
   
   procedure Get_Value (Value : out T'Class) is
      T1_Value : T1 := (null record);
   begin
      Value := T'Class (T1_Value);
   end;
   
   function Result return T'Class is
      T_Class_Value : T'Class := T_Null;
   begin
      Get_Value (T_Class_Value);
      return T_Class_Value;
   end Result;

希望有更优雅的解决方案。

Answer 4

这里我们使用Indefinite_Holders:

package T_Class_Holders is new Ada.Containers.Indefinite_Holders (T'Class);

procedure Get_Value (Value : out T_Class_Holders.Holder) is
   T1_Value : constant T1 := (Z => 42);
begin
   Value.Replace_Element (T'Class (T1_Value));
end;

function Result return T'Class is
   T_Class_H : T_Class_Holders.Holder;
begin
   Get_Value (T_Class_H);
   return T_Class_H.Element;
end Result;

（我用了

type T1 is new T with record
   Z : Integer;
end record;

所以我可以检查是否返回了正确的值）

使用过程 class-wide out 参数作为函数 return 值

Using procedure class-wide out argument as function return value

arguments

return

ada

out