-- *************************************************************************** -- * 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;
Copyright ©
1996 Simon Johnston &
Addison Wesley Longman