ADA程序实例（面向对象特性之多态）

多态是面向对象的核心特性。一说ADA即使95也没有很好地支持多态性。这可能并不是其一个显著缺陷，而是设计者认为多态性不一定能在ADA语言的通常应用模式中能很好地发挥。但毕竟多态性是很重要的一种属性。好在2005版本做了一些改进，其关键是引入了class-wide类型，即在基类上调'Class记号（Attribute）产生的类型。由于ADA主张常用静态的对象，所以这种情形下的多态看上去有点奇怪；另一方面多态往往和指针引用有很大关系，ADA的指针对对象和指针的声明和类型指定都很严格，所以用起来不像其他语言那么方便灵活。

以下示例基本演示这个特性，并一些其他的语言特性和编程要点：

1. 首先是定义基类的包的声明（person.ads），注意：

- ADA的语言特征是以包作为标识对象（数据+操作）封装的单位，因此以下的这个基类person.object，不应将person像在其他面向对象语言中那样看成名空间，而应当看作这种封装概念的一部分；

- ADA一个数据封装单位即record或者是完全可见的（相当于在public）或是定义在private区域中成为完全不可见的。

package person is

  type gender_type is (female, male);
  type object is tagged private;
  
  procedure set_name (o : in out object; name : string);
  procedure set_gender (o : in out object; gender : gender_type);

  procedure put(o : in object);

private
  -- private region

  -- encapsulated object data (tagged as it's object oriented)
    type object is tagged
    record
      name   : string(1..10);
      gender : gender_type;
    end record;

end person;

2. 其次是其实现（person.adb），这其中定义了3个方法（数据单位以首参数出现），分别负责设置名字，性别和打印，最新ADA支持这些方法以数据单位的成员形式调用。这里的打印方法将要被用来测试多态性。

with Ada.Text_IO;

package body person is

  procedure set_name (o : in out object; name : string) is
  begin
    o.name := name;
  end;

  procedure set_gender (o : in out object; gender : gender_type) is
  begin
    o.gender := gender;
  end;

  procedure put(o : in object) is
  begin
    Ada.Text_IO.Put(o.name);
    Ada.Text_IO.Put(" is a ");
    Ada.Text_IO.Put_Line(Gender_Type'Image(o.gender));
  end put;

end person;

3. 再是子类的声明（programmer.ads），可见其中的object（同名无妨，而用package名区分，再次说明package是表征对象的标识）指明继承person.object。这里还显示了一个嵌套定义特性（ADA类似PASCAL语言，可以在任意可定义的位置嵌套定义各种程序内容）；枚举（enumeration）和C/C++一样，语法上类似不将类型名作为限定符的常量，所以要避免污染，比如这里的第一个元素adabyron，如果定义成ada，就会影响其后的ada.containers...的编译。

with person;
with Ada.Containers.Ordered_Sets;

package programmer is

  -- extends object in original package to what it is as a programmer
  type object is new person.object with private;

  -- nested package for putting languages and related functions together
  package languages is
    type name is (adabyron, algol, basic, c, cobol, cplusplus, csharp,
                  delphi, fortran, java, javascript, lisp, pascal,
                  perl, prolog, python, ruby);
    package sets is new Ada.Containers.Ordered_Sets(languages.name);
  end languages;


  procedure set_skills (o : in out object; langs : languages.sets.set);
  procedure add_skill (o : in out object; lang : languages.name);

  overriding    -- optional, new in Ada 2005; the same when omitted in this case
  procedure put (o : in object);

private

  type object is new person.object with
    record
      skilled_in : languages.sets.set;
    end record;

end programmer;

4. 子类实现（programmer.adb），这里的put事实上重载了基类的对应方法（在上述声明中可用overriding标识，ADA 2005特性）。由于ADA是将对象数据作为第一参数的，所以不存在this指针，只需要对这个第一参数进行操作即可。而如果要调用基类方法，则只要显示地到基类的包里去找那个方法即可，而当前类型的对象数据要转换成基类对象数据（被称作视图转换，view conversion，没有额外开销）填入到其第一参数中去。这里也演示了Ada库中的Set的用法，这里的Cursor只能显式使用了。具体的原理目前还不很清楚。

with Ada.Text_IO;

package body programmer is

  procedure set_skills (o : in out object; langs : languages.sets.set) is
  begin
    o.skilled_in := langs;
  end set_skills;

  procedure add_skill (o : in out object; lang : languages.name) is
  begin
    o.skilled_in.Insert(lang);
  end add_skill;

  procedure put (o : in object) is
    lang : languages.name;
    lang_cur : languages.sets.Cursor;
  begin
    -- make a view conversion to base type and put it
    person.put(person.object(o));
    Ada.Text_IO.Put(" who is skilled in ");

    lang_cur := languages.sets.First(o.skilled_in);

    while languages.sets.Has_Element(lang_cur) loop
      lang := languages.sets.element(lang_cur);
      Ada.Text_IO.Put(languages.name'Image(lang));
      Ada.Text_IO.Put(" ");
      lang_cur := languages.sets.Next(lang_cur);
    end loop;
    Ada.Text_IO.Put_Line("");
  end put;

end programmer;

5. 最后是主程序，这里静态做了两个对象分别是基类和派生类的，为它们填写数据，再通过各种方式调用其put方法，有直接调用，也有用class-wide体现多态调用，也有用class-wide的指针进行多态调用，以及class-wide作为函数参数的多态调用。

with person;
with programmer;

procedure Main is
  -- these two objects need to be declared aliased to be able to be
  -- referenced by local access objects (ADA pointers)
  someone : aliased person.object;
  me : aliased programmer.object;
  langs :  programmer.languages.sets.Set;
begin
  someone.set_name("Minnie    ");
  someone.set_gender(person.female);
  someone.put;

  me.set_name("Lincoln   ");
  me.set_gender(person.male);

  declare	-- for language loading
    use programmer.languages;
  begin
    langs.Insert(adabyron);
    langs.Insert(basic);
    langs.Insert(cobol);
    langs.Insert(c);
    langs.Insert(cplusplus);
    langs.Insert(csharp);

    me.set_skills(langs);

    me.add_skill(pascal);
    me.add_skill(javascript);
    me.add_skill(delphi);
    me.add_skill(java);

  end;

  me.put;

  declare
    -- access type to class-wide type for person family
    -- it has to be declared locally to be able to reference local variabless
    type person_access is access all person.object'Class;

    perclass : person.object'Class := me;
    peracc : person_access;

    procedure display(o : person.object'Class) is
    begin
      o.put;
    end display;

  begin
    perclass.put; -- use pre-assigned class-wide-type object
    peracc := me'Access;
    peracc.put;   -- set a class-wide-type pointer to an object of child type
    peracc := someone'Access;
    peracc.put;   -- set the point to an object of base type

    display(me);  -- pass an object to a method with class-wide-type parameter
  end;

end Main;

输出结果

Minnie     is a FEMALE
Lincoln    is a MALE
 who is skilled in ADABYRON BASIC C COBOL CPLUSPLUS CSHARP DELPHI JAVA JAVASCRIPT PASCAL
Lincoln    is a MALE
 who is skilled in ADABYRON BASIC C COBOL CPLUSPLUS CSHARP DELPHI JAVA JAVASCRIPT PASCAL
Lincoln    is a MALE
 who is skilled in ADABYRON BASIC C COBOL CPLUSPLUS CSHARP DELPHI JAVA JAVASCRIPT PASCAL
Minnie     is a FEMALE
Lincoln    is a MALE
 who is skilled in ADABYRON BASIC C COBOL CPLUSPLUS CSHARP DELPHI JAVA JAVASCRIPT PASCAL