使用过程类范围的输出参数作为函数返回值答案

【问题标题】：Using procedure class-wide out argument as function return value使用过程类范围的输出参数作为函数返回值
【发布时间】：2021-06-22 15:24:54
【问题描述】：

   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？

【问题讨论】：

致任何想回答这个问题的人：Get_Value 实际上是一个条目。

标签： return arguments ada out

【解决方案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;

【讨论】：

【解决方案2】：

这里我们使用 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;

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

【讨论】：

我使用 Indefinite_Vectors 来存储元素，因此将其替换为 Holders 的常规向量可能不会损失太多性能。

【解决方案3】：

这很难看，但可以编译：

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;

【讨论】：

【解决方案4】：

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

   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;

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

【讨论】：