Re: Tagged type more type safe than access to subprogram ?

[Georg Bauhaus <rm.dash-bauhaus@futureapps.de>]

Dmitry A. Kazakov schrieb:
> On Thu, 29 Oct 2009 04:00:29 -0700 (PDT), Hibou57 (Yannick Duchêne) wrote:
> 
>> On 28 oct, 09:55, "Dmitry A. Kazakov" <mail...@dmitry-kazakov.de>
>> wrote:
>>> An access to subprogram is a poor-man's closure. Let's ignore "access" part
>>> and consider a pure downward closure (as it should have been in Ada).
> 
>> “ As this should have been in Ada ” ? What were you to mean ? I've
>> always though real closures are not possible with such structures as
>> Ada provides, except at package level — which is especially the case
>> when a package can have multiple instances... but only at package
>> level. Isn't it ?
> 
> I meant downward closures. [...]

> BTW, in Ada 83, there waa no access to subprogram, so we used tasks instead
> (where a subprogram had to be a non-generic parameter).

Tagged types may come close to a solution sometimes.
You make "function objects", like the ones found in Eiffel
and, I think, some other languages.  Make it have an Item
primitive operation that returns the functions value at
that point:


package F is

   type Nums is range 1 .. 3_333;


   type Func_Of_1_Nums is abstract tagged private;

   function Item (F : Func_Of_1_Nums; X1 : Nums) return Nums is
      abstract;
   --  value of function at X1


   type Func_Of_2_Nums is abstract tagged private;

   function Curry
     (F : Func_Of_2_Nums; First_Argument: Nums) return Func_Of_1_Nums'Class is
      abstract;

   function Item (F : Func_Of_2_Nums; X1, X2 : Nums) return Nums is
      abstract;
   --  value of function at (X1, X2)

private

   type Func_Of_1_Nums is abstract tagged
      record
         null;
         -- ... others, e.g. a memoizing cache



      end record;

   type Func_Of_2_Nums is Abstract tagged
      record
         null;
      end record;
end F;

package F.Addition is

   type Adding_Function is new Func_Of_2_Nums with null record;

   overriding
   function Curry
     (F: Adding_Function; First_Argument: Nums) return Func_Of_1_Nums'Class;

   overriding
   function Item (F : Adding_Function; X1, X2: Nums) return Nums;

end F.Addition;



with F.Addition;   use F;

procedure Test_F is
   Sum   : Addition.Adding_Function;
   Add_2 : constant Func_Of_1_Nums'Class :=
     Addition.Curry (Sum, First_Argument => 2);
   Result : Nums;

   type List_Of_Nums is array (Positive range <>) of Nums;

   ----------------------------------------------
   --  This is the important bit: can pass
   --  a "function object", To_Be_Applied,
   --  to Update_All
   ----------------------------------------------
   procedure Update_All
     (To_Be_Applied : Func_Of_1_Nums'Class;
      Some_Numbers: in out List_Of_Nums) is separate;

   Three_Numbers : List_Of_Nums (1 .. 3) := (40, 664, 1064);
begin
   Result := Sum.Item (X1 => 3, X2 => 2);
   pragma Assert (Result = 5);

   Result := Add_2.Item (X1 => 3);
   pragma Assert (Result = 5);

   Update_All (To_Be_Applied => Add_2,
               Some_Numbers => Three_Numbers);
   pragma Assert (Three_Numbers = (42, 666, 1066));

end Test_F;

package body F.Addition is

   type Curried_Of_2 is new Func_Of_1_Nums with
      record
         X1 : Nums;
      end record;
   type Func_Of_1_Nums_Ref is access Func_Of_1_Nums'Class;

   overriding function  Item (F:  Curried_Of_2; X2 : Nums) return Nums is
     -- add F.X1 (which is bound after Curry-ing)



   begin
      return F.X1 + X2;
   end Item;

   function Curry
     (F: Adding_Function; First_Argument: Nums) return Func_Of_1_Nums'Class
   is
      Result : constant Func_Of_1_Nums_Ref :=
        new Curried_Of_2'(X1 => First_Argument);
   begin
      return Result.all;
   end Curry;

   overriding
   function Item (F: Adding_Function; X1, X2: Nums) return Nums is
      -- sum



   begin
      return X1 + X2;
   end Item;

end F.Addition;

separate (Test_F)
procedure Update_All
  (To_Be_Applied : Func_Of_1_Nums'Class;
   Some_Numbers: in out List_Of_Nums) is
begin
   for K in Some_Numbers'Range loop
      Some_Numbers (K) := To_Be_Applied.Item (Some_Numbers (K));
   end loop;
end Update_All;