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