Chapter 6 Examples

 

-- ***************************************************************************
-- *                         Animal.ads
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This is the first example of a tagged type, and represents
-- *    the C++ class animal.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
package Animal is
   type Instance is abstract tagged private;
   procedure Make_A_Sound
     (Animal : in Instance'Class)
      is abstract;
   function  Name
     (Animal : in Instance)
      return String;
   function  Class_Name return String;
private
   type Instance is abstract tagged 
      record
         Name  : String(1 .. 30);
      end record;
   Private_Class_Name : constant String := "Animal";
end Animal;

 

-- ***************************************************************************
-- *                         Animal.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: The package body for the Animal example.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
package body Animal is
   function  Name
     (Animal : in Instance) return String is
   begin
      return Animal.Name;
   end Name;
   function  Class_Name return String is
   begin
      return Private_Class_Name;
   end Class_Name;
end Animal;

 

-- ***************************************************************************
-- *                         Animal-Cat.ads 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This type is derived from the Animal type introduced in 
-- *    example 6.2
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

package Animal.Cat is
   type Instance is new Animal.Instance with private;
   procedure Make_A_Sound(Cat : in Animal.Instance'Class);
   function  Class_Name return String;
private
   type Instance is new Animal.Instance with
      record
         Likes_Water : Boolean := False;
      end record;
   Private_Class_Name : constant String := "Cat";
end Animal.Cat;

 

-- ***************************************************************************
-- *                         Animal-Dog.ads 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This type is derived from the Animal type introduced in 
-- *    example 6.2
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

package Animal.Dog is
   type Instance is new Animal.Instance with private;
   procedure Make_A_Sound(Dog : in Animal.Instance'Class);
   function  Class_Name return String;
private
   type Instance is new Animal.Instance with
      record
         Has_Fleas : Boolean := False;
      end record;
   Private_Class_Name : constant String := "Dog";
end Animal.Dog;

 

-- ***************************************************************************
-- *                         Domesticated.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: How to achieve a measure of multiple inheritance support in
-- *    a programming language which does not support it.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
with Animal;
generic
   type Wild_Animal is new Animal.Instance with private;
package Domesticated is
   type Instance is new Wild_Animal with private;
   procedure Set_Purpose
     (Domesticated_Animal : in out Instance;
      Purpose             : in     String);
   function  Get_Purpose
     (Domesticated_Animal : in     Instance)
      return String;
private
   type Instance is new Wild_Animal with
      record
         Purpose : String(1 .. 30);
      end record;
end Domesticated;

 

-- ***************************************************************************
-- *                         List_Test.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This demonstrates the use of 'Class with dynamic instances.
-- * Inputs:  None.
-- * Outputs: This test will only compile if used with the list example from
-- *    the case study Ada_Store.
-- ***************************************************************************
with Ada_Store.Support.List;
procedure List_Test is
   type    Object  is tagged null record;
   subtype O_Class is Object'Class;
   package Object_List is new Ada_Store.Support.List(O_Class);
   type List_Ptr is access Object_List.Instance;
   List : List_Ptr := new Object_List.Instance;
begin
   -- put items into list.
   loop
      declare
         An_Object : O_Class := Get(List);
      begin
         -- Process An_Object.
         null;
      end ;
   end loop;
end List_Test;

 

-- ***************************************************************************
-- *                         Nice_And_Safe.ads
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This is a safe package, the data is held in the private
-- *    part and so cannot be altered, or can it?
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
package Nice_And_Safe is
   type Instance is tagged private;
   function Access_My_Data
     (Object : in Instance)
      return Integer;
private
   type Instance is tagged
      record
         Private_Data : Integer;
      end record;
end Nice_And_Safe;

 

-- ***************************************************************************
-- *                    Nice_And_Safe.Not_So_Safe.ads
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This example shows how the safety of data in the private
-- *    part of a package can be violated using child packages.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
procedure Nice_And_Safe.Not_So_Safe
  (Object : access Nice_And_Safe.Instance'Class);

 

-- ***************************************************************************
-- *                   Nice_And_Safe.Not_So_Safe.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This shows how the data in the private part of a package
-- *    can be violated using child packages.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
procedure Nice_And_Safe.Not_So_Safe
  (Object : access Nice_And_Safe.Instance'Class) is
begin
   Object.Private_Data := 0;
end Nice_And_Safe.Not_So_Safe;

 

-- ***************************************************************************
-- *                         Test1.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This example tests the animal types introduced so far.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
with Animal;
with Animal.Cat;
with Animal.Dog;
procedure Test1 is
   type Animal_Ptr is access all Animal.Instance;
   Ptr       : Animal_Ptr;
   An_Animal : Animal.Instance;
   A_Cat     : Animal.Cat.Instance;
   A_Dog     : Animal.Dog.Instance;
begin
   Ptr := An_Animal'Access;              -- perfectly legal.
   Ptr := Animal.Instance(A_Cat)'Access; -- illegal.
   Ptr := Animal.Instance(A_Dog)'Access; -- legal.
end Test1;

 

-- ***************************************************************************
-- *                         Test2.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: An enhanced version of example 06
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
with Animal;
with Animal;
with Animal.Cat;
with Animal.Dog;
procedure Test2 is
   type Animal_Ptr is access all Animal.Instance'Class;
   Ptr       : Animal_Ptr;
   An_Animal : Animal.Instance;
   A_Cat     : Animal.Cat.Instance;
   A_Dog     : Animal.Dog.Instance;
begin
   Ptr := An_Animal'Access; 
   Ptr := A_Cat'Access; 
   Ptr := A_Dog'Access; 
end Test2;

 

-- ***************************************************************************
-- *                         Test3.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Another enhancement to the test 06
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
with Ada.Text_IO;
with Animal;
use  Animal;
with Animal.Cat;
with Animal.Dog;
procedure Test3 is
   type Animal_Ptr is access all Animal.Instance'Class;
   procedure What_Is(Animal : Animal_Ptr) is
   begin
      if Animal.all in Animal.Cat.Instance'Class then
         Ada.Text_IO.Put_Line("Animal is a cat");
      elsif Animal.all in Animal.Dog.Instance'Class then
         Ada.Text_IO.Put_Line("Animal is a dog");
      else
         Ada.Text_IO.Put_Line("Animal is an unknown animal");
      end if;
   end What_Is;
   An_Other : Animal.Instance;
   A_Cat    : Animal.Cat.Instance;
   A_Dog    : Animal.Dog.Instance;
begin
   What_Is(A_Cat);
   What_Is(A_Dog);
   What_Is(An_Other);
end Test3;

 

-- ***************************************************************************
-- *                         Test4.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Another enhancement of test 06
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
with Ada.Text_IO;
with Animal;
use  Animal;
with Animal.Cat;
with Animal.Dog;
procedure Test4 is
   subtype Animal_Class is Animal.Instance'Class;
   type    Animal_Ptr   is access all Animal.Instance'Class;
   Some_Animal : Animal_Class;                   -- illegal.
   A_Cat       : aliased Animal.Cat.Instance;    -- legal.
   An_Animal   : Animal_Class := A_Cat;          -- now legal.
   Animal      : Animal_Ptr;
begin
   Ada.Text_IO.Put_Line(Name(A_Cat));        -- normal call.
   Ada.Text_IO.Put_Line(Name(An_Animal));    -- normal call.
   Animal := A_Cat'Access;
   Ada.Text_IO.Put_Line(Name(An_Animal));    -- dispatched.
end Test4;

 

-- ***************************************************************************
-- *                         Test5.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Test the multiple inheritance support using the package 
-- *    Domesticated.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
with Animal;
use  Animal;
with Animal.Dog;
with Domesticated;
procedure Test5 is
   package Domesticated_Dog is new Domesticated(Dog.Instance);
   A_Wild_Wolf   : Dog.Instance;
   My_Pet_Collie : Domesticated_Dog.Instance;
begin
   Domesticated_Dog.Set_Purpose("Herd Sheep and tear slippers");
end Test5;

 

-- ***************************************************************************
-- *                         Test6.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This creates a new type which uses multiple inheritance 
-- *    twice. 
-- * Inputs:  You will need to create a package Coloured as this is not done
-- *    in the text.
-- * Outputs: None.
-- ***************************************************************************
with Animal;
use  Animal;
with Animal.Dog;
with Domesticated;
with Coloured;
 
procedure Test6 is
   package Domesticated_Dog is new Domesticated(Dog.Instance);
   package Pet_Dog is new Coloured(Domesticated_Dog.Instance);
   A_Wild_Wolf   : Dog.Instance;
   My_Pet_Collie : Pet_Dog.Instance;
begin
   Domesticated_Dog.Set_Purpose("Herd Sheep and tear slippers");
   Pet_Dog.Set_Colour(Pet_Dog.Black & Pet_Dog.White);
end Test6;

Contents Page

Copyright © 1996 Simon Johnston &
Addison Wesley Longman