Finalizer

Кто писал на Borland Delphy и C++ иногда ощущает необходимость секции finally в обработчиках исключения. Предложенный способ позволяет определить локальную процедуру которая будет вызвана в любом случае при выходе из блока.

Пример использования:

declare
   procedure Finalize is
   begin
      Put_Line ("Finalize-2");
   end Finalize;

   F : Finalizers.Handler (Finalize'Access);
begin
   Put_Line ("block-2");
   raise Constraint_Error;
exception
   when others => Put_Line ("exception handler");
end;

Спецификация:

-- Author: Dmitriy Anisimkov <anisimkov@ada-ru.org>, (C) 2007
--
-- Distributed under the GNU General Public License
--

with Ada.Finalization;

package Finalizers is

   type Handler (Action : access procedure) is
     new Ada.Finalization.Limited_Controlled with null record;

   procedure Finalize (Object : in out Handler);

end Finalizers;

Реализация:

--
-- Ada body: Finalizers
--
-- Author: Dmitriy Anisimkov <anisimkov@ada-ru.org>, (C) 2007
--
-- Distributed under the GNU General Public License
--

with Ada.Finalization;

package body Finalizers is

   procedure Finalize (Object : in out Handler) is
   begin
      Object.Action.all;
   end Finalize;

end Finalizers;

Тестовый пример:

with Ada.Text_IO;
with Finalizers;

procedure Main is
   use Ada.Text_IO;

begin
   Put_Line ("Start");

   declare
      procedure Finalize is
      begin
         Put_Line ("Finalize-1");
      end Finalize;

      F : Finalizers.Handler (Finalize'Access);
   begin
      Put_Line ("block-1");
   end;

   Put_Line ("done-1");

   declare
      procedure Finalize is
      begin
         Put_Line ("Finalize-2");
      end Finalize;

      F : Finalizers.Handler (Finalize'Access);
   begin
      Put_Line ("block-2");
      raise Constraint_Error;
   exception
      when others => Put_Line ("exception handler");
   end;

   Put_Line ("done-2");

   declare
      procedure Finalize is
      begin
         Put_Line ("Finalize-3");
      end Finalize;

      F : Finalizers.Handler (Finalize'Access);
   begin
      Put_Line ("block-3");
      raise Constraint_Error;
   end;

end Main;

Архив с текстом