ADA程序实例（一个简单的智能指针实现）

普通的ADA并不含有垃圾收集等托管程序的特性，除非当ADA的目标运行时建立在Java Virtual Machine或.NET系统上。所以从这个对象内存分配角度，ADA和C++基本上是等价的。

ADA提供的语言特性，基本上足以使得ADA能够实现智能指针。当然，是不是有必要在ADA中使用智能指针（考虑ADA常用的思考建模方式），其完善程度（指针的类型，对于OO的支持和对于一般数据的支持）又是另一会儿事。智能指针再智能也不能达到托管程序所能达到内存管理功能（例如简单的引用计数是无法应对孤立环路结构的释放的）。

当然，纯粹展现一下ADA的语言特性，这不失为一个好的例子。

首先是声明（autoptr.ads）。这里显然是一个泛型模块，而其核心类型是指针要处理的对象的类型（private约束是一个很松的约束，尚需查明是不是最松的）。对这个类型可赋予初始化和终止化方法各一。指针实现是指针对象指向一个含引用计数和对象内容的封装对象（Wrapper）。这里比较重要的是封装对象从ada.finalization.controlled继承，这使得能够对其赋值和跨域的状态进行跟踪。其重载函数initialize相当于C++中的无参构造函数，finalize相当于C++中的析构函数，他们分别在对象数据（变量）进域（begin）和出域（end）调用，伴随着变量的诞生和销毁。Adjust比较特殊，也比较关键，它在对象数据被赋值完毕后调用。另外finalize在对象数据被赋值之前也会调用（这个在运行了这个程序才发现）。因为ADA数据赋值永远是针对其直接内容的深拷贝，所以Adjust可用于对收入数据的处理，基本上起到了拷贝构造函数或赋值重载的作用。

spec中提供了一些主要的功能，如所指对象的获取，指针相等的判断的等号重载（根据指针所指对象的一致性而非指针对象本身相同性），以及一个新建空对象的操作。

with Ada.Finalization;

generic
  -- type of the target the pointer is dealing with
  type target_t is private;

  -- handlers invoked on initialization and finalization respectivelys
  target_initialize : access procedure(target : in out target_t) := null;
  target_finalize : access procedure(target : in out target_t) := null;

package autoptr is

  type Pointer is new Ada.Finalization.Controlled with private;

  -- returns the targeted object pointer 'p' points to
  function target(p : Pointer) return target_t;

  -- override of equal sign that returns if two pointers are considered equal
  -- in which case they are pointing to the same wrapper/target
  function "="(left, right : Pointer) return boolean;

  -- creates an new instance of target and returns a pointer that points to it
  function create return Pointer;

  -- returns the number of pointers referencing the target pointer p points to
  function numrefs(p : Pointer) return integer;

private

  -- wrapper that wraps around an instance of target
  type wrapper_t is tagged
    record
      target : target_t;
      reference_counter : integer;
    end record;

  -- type of access to wrapper for pointer to point to wrapper
  type wrapper_access is access all wrapper_t;

  -- data definition of pointer type
  type Pointer is new Ada.Finalization.Controlled with
    record
      wrapper : wrapper_access;
    end record;

  -- initializer 
  overriding procedure Initialize(p : in out Pointer);
  
  -- adjuster that is called after assignment of 'p'
  overriding procedure Adjust(p : in out Pointer);
 
  -- finalizer (destructor) of the pointer type for dealing with referencing
  overriding procedure Finalize(p : in out Pointer);

end autoptr;

知道spec的这些要点，就能完成实现（autoptr.adb），这其中在关键步骤上进行了打印。注意Finalize函数中一开始的指针判断，这从Finalize的特点看是必须的（这反映在执行结果中）。

with Ada.Unchecked_Deallocation;
with ada.text_io; use Ada.text_io;

package body autoptr is

  -- instantiate a wrapper deallocation procedure
  procedure free_wrapper is new Ada.Unchecked_Deallocation
    (Object=> wrapper_t, Name => wrapper_access);

  -- returns the targeted object poiner 'p' points to
  function target(p : Pointer) return target_t is
  begin
    -- wrapper is guaranteed to be available
    -- if not an exception should be thrown by the system for now
    return p.wrapper.target;
  end target;

  -- creates an new instance of target and returns a pointer that points to it
  function create return Pointer is
    p : Pointer;
  begin
    put_line("creating");

    p.wrapper := new wrapper_t;
    put_line(" step 1");
    
    if target_initialize /= null then
      target_initialize(p.wrapper.target);
    end if;
    put_line(" step 2");

    p.wrapper.reference_counter := 1;
    put_line(" step 3");

    put_line("'create' returning");
    return p;
  end create;

  -- override of equal sign that returns if two pointers are considered equal
  -- in which case they are pointing to the same wrapper/target
  function "="(left, right : Pointer) return boolean is
  begin
    return left.wrapper = right.wrapper;
  end "=";
  
  -- returns the number of pointers referencing the target pointer p points tos
  function numrefs(p : Pointer) return integer is
  begin
    if p.wrapper = null then
      return 0;
    end if;

    return p.wrapper.reference_counter;
  end numrefs;
  
  -- private methods
  
  -- finalizes the target and release the allocation
  procedure finalize_wrapper(p : in out wrapper_access) is
  begin
    if target_finalize /= null then
      target_finalize(p.target);
    end if;

    free_wrapper(p);
  end finalize_wrapper;
  
  -- initializer 
  overriding procedure Initialize(p : in out Pointer) is
  begin
    put_line("initializing");
    null;  -- do nothing; what could be done is instantiate a wrapper
    put_line("initialized");
  end Initialize;
  
  -- adjuster that is called after assignment of 'p'
  overriding procedure Adjust(p : in out Pointer) is
  begin
    put_line("adjusting");
    p.wrapper.reference_counter := p.wrapper.reference_counter + 1;
    put_line("adjusted");
  end Adjust;

  overriding procedure Finalize(p : in out Pointer) is
  begin
    put_line("finalizing");
    if p.wrapper = null then
      put_line(" wrapper is null");
      return;
    end if;
 
    p.wrapper.reference_counter := p.wrapper.reference_counter - 1;
    put(" refcount = "); put_line(integer'Image(p.wrapper.reference_counter));
    -- allowing 'less than' is purely for tolerating erroneous condition
    if p.wrapper.reference_counter <= 0 then
      finalize_wrapper(p.wrapper);
    end if;
    put_line("finalized");
  end Finalize;

begin
  null;
end autoptr;

最后是一个演示程序（autoptr_demo.adb），只覆盖了一个简单的创建和赋值，未充分测试。

with Ada.Strings; use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Text_IO; use Ada.Text_IO;
with autoptr;

procedure autoptr_demo is
  type myrec_t is tagged record
    id    : integer;
    name  : string(1..10);
  end record;
  
  id : integer := 1;
  
  procedure myrecinit(myrec : in out myrec_t) is 
  begin
    myrec.id := id;
    id := id + 1;
    myrec.name := 10 * ' ';
    myrec.name := overwrite(myrec.name, 1, "rec");
    myrec.name := overwrite(myrec.name, 4, trim(integer'Image(id), Both));
    put("record{"); 
    put(integer'Image(myrec.id)); put("; '"); put(myrec.name); 
    put_line("'} created");
  end myrecinit;
  
  package myptr is new autoptr(target_t => myrec_t, 
                               target_initialize => myrecinit'Access);
  
  p1, p2 : myptr.Pointer;
  
begin
  p1 := myptr.create;
  put("reference count of p1 is "); put_line(integer'Image(p1.numrefs));
  
  p2 := p1;
  put("reference count of p2 is "); put_line(integer'Image(p2.numrefs));
  
  put("p2.name = '"); put(p2.target.name); put_line("'");
  
end;

运行结果（其中wrapper is null说明在赋值前的Finalize调用作用在了未赋值指针上了）：

initializing
initialized
initializing
initialized
initializing
initialized
creating
 step 1
record{ 1; 'rec2      '} created
 step 2
 step 3
'create' returning
adjusting
adjusted
finalizing
 refcount =  1
finalized
finalizing
 wrapper is null
adjusting
adjusted
finalizing
 refcount =  1
finalized
reference count of p1 is  1
finalizing
 wrapper is null
adjusting
adjusted
reference count of p2 is  2
p2.name = 'rec2      '
finalizing
 refcount =  1
finalized
finalizing
 refcount =  0
finalized