A class is a set of types that is closed under derivation, which means that if a given type is in the class, then all types derived from that type are also in the class. The set of types of a class share common properties, such as their primitive operations. The semantics of a class include expected behavior and exceptions.

An object is either a constant or variable defined from a type (class). An object contains a value. A subcomponent of an object is itself an object.

Guidelines in this chapter are frequently worded "consider . . ." because hard and fast rules cannot apply in all situations. The specific choice you make in a given situation involves design tradeoffs. The rationale for these guidelines is intended to give you insight into some of these tradeoffs.

type Object is tagged

   record

      X_Coord : Float;

      Y_Coord : Float;

   end record;



type Circle is new Object with

   record

      Radius : Float;

   end record;



type Point is new Object with null record;



type Shape is new Object with

   record

      -- other components

      ...

   end record;

The following is an example of general access type to the corresponding class-wide type:

package Employee is

   type Object is tagged limited private;

   type Reference is access all Object'class;

   ...

private

   ...

end Employee;

In deriving from a tagged type, you can extend the type with new components. Each descendant can extend a common interface (the parent's). The union of a tagged type and its descendants form a class, and a class offers some unique features not available to untagged derivations. You can write class-wide operations that can be applied to any object that is a member of the class. You can also provide new implementations for the descendants of tagged types, either by overriding inherited primitive operations or by creating new primitive operations. Finally, tagged types can be used as the basis for multiple inheritance building blocks (see Guideline 9.5.1).

Reference semantics are very commonly used in object-oriented programming. In particular, heterogeneous polymorphic data structures based on tagged types require the use of access types. It is convenient to have a common definition for such a type provided to any client of the package defining the tagged type. A heterogeneous polymorphic data structure is a composite data structure (such as an array) whose elements have a homogeneous interface (i.e., an access to class-wide type) and whose elements' implementations are heterogeneous (i.e., the implementation of the elements uses different specific types). See also Guidelines 9.3.5 on polymorphism and 9.4.1 on managing visibility of tagged type hierarchies.

In Ada, the primitive operations of a type are implicitly associated with the type through scoping rules. The definition of a tagged type and a set of operations corresponds together to the "traditional" object-oriented programming concept of a "class." Putting these into a package provides a clean encapsulation mechanism.

If a descendant needs to remove one of the components or primitive operations of its ancestor, it may not be appropriate to extend the tagged type.

An exception to using reference semantics is when a type is exported that would not be used in a data structure or made part of a collection.

If the implementation of two tagged types requires mutual visibility and the two types are generally used together, then it may be best to define them together in one package, though thought should be given to using child packages instead (see Guideline 9.4.1). Also, it can be convenient to define a small hierarchy of (completely) abstract types (or a small part of a larger hierarchy) all in one package specification; however, the negative impact on maintainability may outweigh the convenience. You do not provide a package body in this situation unless you have declared nonabstract operations on members of the hierarchy.

with Database;

package Transaction is



   type Object (Data : access Database.Object'Class) is abstract tagged limited

      record

         Has_Executed : Boolean := False;

      end record;



   function Is_Valid (T : Object) return Boolean;

   -- checks that Has_Executed is False



   procedure Execute (T : in out Object);

   -- sets Has_Executed to True



   Is_Not_Valid : exception;



end Transaction;

The precondition of Execute(T) for all T in Transaction.Object'Class is that Is_Valid(T) is True. The postcondition is the T.Has_Executed = True. This model is trivially satisfied by the root type Transaction.Object.

Consider the following derived type:

with Transaction;

with Personnel;

package Pay_Transaction is

   type Object is new Transaction.Object with

      record

         Employee     : Personnel.Name;

         Hours_Worked : Personnel.Time;

      end record;

   function Is_Valid (T : Object) return Boolean;

   -- checks that Employee is a valid name, Hours_Worked is a valid

   -- amount of work time and Has_Executed = False

   procedure Has_Executed (T : in out Object);

   -- computes the pay earned by the Employee for the given Hours_Worked

   -- and updates this in the database T.Data, then sets Has_Executed to True

end Pay_Transaction;

The precondition for the specific operation Pay_Transaction.Execute(T) is that Pay_Transaction.Is_Valid(T) is True, which is the same precondition as for the dispatching operation Execute on the class-wide type. (The actual validity check is different, but the statement of the "precondition" is the same.) The postcondition for Pay_Transaction.Execute(T) includes T.Has_Executed = True but also includes the appropriate condition on T.Data for computation of pay.

The class-wide transaction type can then be properly used as follows:

type Transaction_Reference is access all Transaction.Object'Class;

type Transaction_List is array (Positive range <>) of Transaction_Reference;

procedure Process (Action : in Transaction_List) is

begin

   for I in Action'Range loop

   -- Note that calls to Is_Valid and Execute are dispatching

      if Transaction.Is_Valid(Action(I).all) then

         -- the precondition for Execute is satisfied

         Transaction.Execute(Action(I).all);

         -- the postcondition Action(I).Has_Executed = True is

         -- guaranteed to be satisfied (as well as any stronger conditions

         -- depending on the specific value of Action(I))

      else

         -- deal with the error

         ...

      end if;

   end loop;

end Process;

If you had not defined the operation Is_Valid on transactions, then the validity condition for pay computation (valid name and hours worked) would have to directly become the precondition for Pay_Transaction.Execute. But this would be a "stronger" precondition than that on the class-wide dispatching operation, violating the guideline. As a result of this violation, there would be no way to guarantee the precondition of a dispatching call to Execute, leading to unexpected failures.

An alternative resolution to this problem is to define an exception to be raised by an Execute operation when the transaction is not valid. This behavior becomes part of the semantic model for the class-wide type: the precondition for Execute(T) becomes simply True (i.e., always valid), but the postcondition becomes "either" the exception is not raised and Has_Executed = True "or" the exception is raised and Has_Executed = False. The implementations of Execute in all derived transaction types would then need to satisfy the new postcondition. It is important that the "same" exception be raised by "all" implementations because this is part of the expected semantic model of the class-wide type.

With the alternative approach, the above processing loop becomes:

procedure Process (Action : in Transaction_List) is

begin



   for I in Action'Range loop



    Process_A_Transaction:

      begin



         -- there is no precondition for Execute

         Transaction.Execute (Action(I).all);

         -- since no exception was raised, the postcondition

         -- Action(I).Has_Executed = True is guaranteed (as well as

         -- any stronger condition depending on the specific value of

         -- Action(I))



      exception

         when Transaction.Is_Not_Valid =>

            -- the exception was raised, so Action(I).Has_Executed = False



            -- deal with the error

            ...



      end Process_A_Transaction;



   end loop;



end Process;

When a dispatching operation is used on a variable of a class-wide type T'Class, the actual implementation executed will depend dynamically on the actual tag of the value in the variable. In order to rationally use T'Class, it must be possible to understand the semantics of the operations on T'Class without having to study the implementation of the operations for each of the types in the derivation class rooted in T. Further, a new type added to this derivation class should not invalidate this overall understanding of T'Class because this could invalidate existing uses of the class-wide type. Thus, there needs to be an overall set of semantic properties of the operations of T'Class that is preserved by the implementations of the corresponding dispatching operations of all the types in the derivation class.

One way to capture the semantic properties of an operation is to define a "precondition" that must be true before the operation is invoked and a "postcondition" that must be true (given the precondition) after the operation has executed. You can (formally or informally) define pre- and postconditions for each operation of T'Class without reference to the implementations of dispatching operations of specific types. These semantic properties define the "minimum" set of properties common to all types in the derivation class. To preserve this minimum set of properties, the implementation of the dispatching operations of all the types in the derivation class rooted in T (including the root type T) should have (the same or) weaker preconditions than the corresponding operations of T'Class and (the same or) stronger postconditions than the T'Class operations. This means that any invocation of a dispatching operation on T'Class will result in the execution of an implementation that requires no more than what is expected of the dispatching operation in general (though it could require less) and delivers a result that is no less than what is expected (though it could do more).

with Ada.Finalization;

package Linked_List_Package is

   type Iterator is private;

   type Data_Type is ...

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

   function Head (List : Linked_List) return Iterator;

   procedure Get_Next (Element  : in out Iterator;

                       Data     :    out Data_Type);

   procedure Add (List     : in out Linked_List;

                  New_Data : in     Data_Type);

   procedure Finalize (List : in out Linked_List); -- reset Linked_List structure

   -- Initialize and Adjust are left to the default implementation.

private

   type Node;

   type Node_Ptr is access Node;

   type Node is

      record

         Data : Data_Type;

         Next : Node_Ptr;

      end record;

   type Iterator is new Node_Ptr;

   type Linked_List is new Ada.Finalization.Controlled with

      record

         Number_Of_Items : Natural := 0;

         Root            : Node_Ptr;

      end record;

end Linked_List_Package;

--------------------------------------------------------------------------

package body Linked_List_Package is



   function Head (List : Linked_List) return Iterator is

      Head_Node_Ptr : Iterator;

   begin

      Head_Node_Ptr := Iterator (List.Root);

      return Head_Node_Ptr;  -- Return the head element of the list

   end Head;



   procedure Get_Next (Element : in out Iterator;

                       Data    :    out Data_Type) is

   begin

      --

      -- Given an element, return the next element (or null)

      --

   end Get_Next;



   procedure Add (List     : in out Linked_List;

                  New_Data : in     Data_Type) is

   begin

      --

      -- Add a new element to the head of the list

      --

   end Add;



   procedure Finalize (List : in out Linked_List) is

   begin

      -- Release all storage used by the linked list

      --   and reinitialize.

   end Finalize;



end Linked_List_Package;

You can ensure that the derived type's initialization is consistent with that of the parent by calling the parent type's initialization from the derived type's initialization.

You can ensure that the derived type's finalization is consistent with that of the parent by calling the parent type's finalization from the derived type's finalization.

In general, you should call parent initialization before descendant-specific initialization. Similarly, you should call parent finalization after descendant-specific finalization. (You may position the parent initialization and/or finalization at the beginning or end of the procedure.)

--------------------------------------------------------------------------

package Bank_Account_Package is



   type Bank_Account_Type is abstract tagged limited private;

   type Money is delta 0.01 digits 15;



   -- The following abstract operations must be overridden for

   --   each derivation, thus ensuring that any restrictions

   --   for specialized accounts will be implemented.



   procedure Open (Account : in out Bank_Account_Type) is abstract;



   procedure Close (Account : in out Bank_Account_Type) is abstract;



   procedure Deposit (Account : in out Bank_Account_Type;

                      Amount  : in     Money) is abstract;



   procedure Withdraw (Account : in out Bank_Account_Type;

                       Amount  : in     Money) is abstract;



   function Balance (Account : Bank_Account_Type)

     return Money is abstract;



private

   type Account_Number_Type is ...

   type Account_Owner_Type  is ...

   type Tax_ID_Number_Type  is ...



   type Bank_Account_Type is abstract tagged limited

      record

         Account_Number : Account_Number_Type;

         Account_Owner  : Account_Owner_Type;

         Tax_ID_Number  : Tax_ID_Number_Type;

      end record;

end Bank_Account_Package;

--------------------------------------------------------------------------

-- Now, other specialized accounts such as a savings account can

-- be derived from Bank_Account_Type as in the following example.

-- Note that abstract types are still used to ensure that only

-- account objects corresponding to specific products will be

-- created.with Bank_Account_Package;

with Bank_Account_Package;

package Savings_Account_Package is

   type Savings_Account_Type is abstract

      new Bank_Account_Package.Bank_Account_Type with private;

   -- We must override the abstract operations provided

   --   by Bank_Account_Package.  Since we are still declaring

   --   these operations to be abstract, they must also be

   --   overridden by the specializations of Savings_Account_Type.

   procedure Open (Account : in out Savings_Account_Type) is abstract;

   procedure Close (Account : in out Savings_Account_Type) is abstract;



   procedure Deposit (Account : in out Savings_Account_Type;

                      Amount  : in     Bank_Account_Package.Money) is abstract;





   procedure Withdraw (Account : in out Savings_Account_Type;

                       Amount  : in     Bank_Account_Package.Money) is abstract;



   function Balance (Account : Savings_Account_Type)

     return Bank_Account_Package.Money is abstract;



private

   type Savings_Account_Type is abstract

      new Bank_Account_Package.Bank_Account_Type with

         record

            Minimum_Balance : Bank_Account_Package.Money;

         end record;

end Savings_Account_Package;



--------------------------------------------------------------------------

See the abstract set package in Guideline 9.5.1 for an example of creating an abstraction with a single interface and the potential for multiple implementations. The example only shows one possible implementation; however, you could provide an alternate implementation of the Hashed_Set abstraction using other data structures.

You can only declare abstract subprograms when the root type is also abstract. This is useful as you build an abstraction that forms the basis for a family of abstractions. By declaring the primitive subprograms to be abstract, you can write the "common class-wide parts of a system . . . without being dependent on the properties of any specific type at all" (Rationale 1995, §4.2).

Abstract types and operations can help you resolve problems when your tagged type hierarchy violates the expected semantics of the class-wide type dispatching operations. The Rationale (1995, §4.2) explains:

When building an abstraction that is to form the basis of a class of types, it is often convenient not to provide actual subprograms for the root type but just abstract subprograms which can be replaced when inherited. This is only allowed if the root type is declared as abstract; objects of an abstract type cannot exist. This technique enables common class-wide parts of a system to be written without being dependent on the properties of any specific type at all. Dispatching always works because it is known that there can never be any objects of the abstract type and so the abstract subprograms could never be called.

See Guidelines 8.3.8 and 9.2.1.

The multiple inheritance techniques discussed in Guideline 9.5.1 make use of abstract tagged types. The basic abstraction is defined using an abstract tagged (limited) private type (whose full type declaration is a null record) with a small set of abstract primitive operations. While abstract operations have no bodies and thus cannot be called, they are inherited. Derivatives of the abstraction then extend the root type with components that provide the data representation and override the abstract operations to provide callable implementations (Rationale 1995, §4.4.3). This technique allows you to build multiple implementations of a single abstraction. You declare a single interface and vary the specifics of the data representation and operation implementation.

Any_Rectangle:

type Figure is abstract tagged

   record

      ...

   end record;

type Any_Rectangle is abstract new Figure with private;

-- No Make function for this; it's abstract.

function Area (R: Any_Rectangle) return Float;

  -- Overrides abstract Area function inherited from Figure.

  -- Computes area as Width(R) * Height(R), which it will

  -- invoke via dispatching calls.

function Width (R: Any_Rectangle) return Float is abstract;

function Height (R: Any_Rectangle) return Float is abstract;

type Rectangle is new Any_Rectangle with private;

function Make_Rectangle (Width, Height: Float) return Rectangle;

function Width (R: Rectangle) return Float;

function Height (R: Rectangle) return Float;

-- Area for Rectangle inherited from Any_Rectangle

type Square is new Any_Rectangle with private;

function Make_Square (Side_Length: Float) return Square;

function Side_Length (S: Square) return Float;

function Width (S: Square) return Float;

function Height (S: Square) return Float;

-- Area for Square inherited from Any_Rectangle

...

-- In the body, you could just implement Width and Height for

-- Square as renamings of Side_Length:

function Width (S: Square) return Float renames Side_Length;

function Height (S: Square) return Float renames Side_Length;

function Area (R: Any_Rectangle) return Float is

begin

  return Width(Any_Rectangle'Class(R)) * Height(Any_Rectangle'Class(R));

  -- Casting [sic, i.e., converting] to the class-wide type causes the function calls to

  -- dynamically dispatch on the 'Tag of R.

  -- [sic, i.e., redispatch on the tag of R.]

end Area;

Alternatively, you could just wait until defining types Rectangle and Square to provide actual Area functions:

type Any_Rectangle is abstract new Figure with private;

-- Inherits abstract Area function from Figure,

-- but that's okay, Any_Rectangle is abstract too.

function Width (R: Any_Rectangle) return Float is abstract;

function Height (R: Any_Rectangle) return Float is abstract;

type Rectangle is new Any_Rectangle with private;

function Make_Rectangle (Width, Height: Float) return Rectangle;

function Width (R: Rectangle) return Float;

function Height (R: Rectangle) return Float;

function Area (R: Rectangle) return Float; -- Overrides Area from Figure

type Square is new Any_Rectangle with private;

function Make_Square (Side_Length: Float) return Square;

function Side_Length (S: Square) return Float;

function Width (S: Square) return Float;

function Height (S: Square) return Float;

function Area (S: Square) return Float;  -- Overrides Area from Figure

...

function Area (R: Rectangle) return Float is

begin

  return Width(R) * Height(R); -- Non-dispatching calls

end Area;

function Area (S: Square) return Float is

begin

  return Side_Length(S) ** 2;

end Area;

All operations declared in the same package as the tagged type and following the tagged type's declaration but before the next type declaration are considered its primitive operations. Therefore, when a new type is derived from the tagged type, it inherits the primitive operations. If there are any operations that you do not want to be inherited, you must choose whether to declare them as class-wide operations (see Guideline 9.3.2) or to declare them in a separate package (e.g., a child package).

Exceptions are part of the semantics of the class. By modifying the exceptions, you are violating the semantic properties of the class-wide type (see Guideline 9.2.1).

There are (at least) two distinct users of a tagged type and its primitives. The "ordinary" user uses the type and its primitives without enhancement. The "extending" user extends the type by deriving a type based on the existing (tagged) type. Extending users and maintainers must determine the ramifications of a possibly incorrect extension. The guidelines here try to strike a balance between too much documentation (that can then easily get out of synch with the actual code) and an appropriate level of documentation to enhance the maintainability of the code.

One of the major maintenance headaches associated with inheritance and dynamic binding relates to undocumented interdependencies among primitive (dispatching) operations of tagged types (the equivalent of "methods" in typical object-oriented terminology). If a derived type inherits some and overrides other primitive operations, there is the question of what indirect effects on the inherited primitives are produced. If no redispatching is used, the primitives may be inherited as "black boxes." If redispatching is used internally, then when inherited, the externally visible behavior of an operation may change, depending on what other primitives are overridden. Maintenance problems (here, finding and fixing bugs) occur when someone overrides incorrectly (on purpose or by accident) an operation used in redispatching. Because this overriding can invalidate the functioning of another operation defined perhaps several levels of inheritance up from the incorrect operation, it can be extremely difficult to track down.

In the object-oriented paradigm, redispatching is often used to parameterize abstractions. In other words, certain primitives are intended to be overridden precisely because they are redispatching. These primitives may even be declared as abstract, requiring that they be overridden. Because they are redispatching, they act as "parameters" for the other operations. Although in Ada much of this parameterization can be done using generics, there are cases where the redispatching approach leads to a clearer object-oriented design. When you document the redispatching connection between the operations that are to be overridden and the operations that use them, you make the intended use of the type much clearer.

Hence, any use of redispatching within a primitive should be considered part of the "interface" of the primitive, at least as far as any inheritor, and requires documentation at the specification level. The alternative (i.e., not providing such documentation in the specification) is to have to delve deep into the code of all the classes in the derivation hierarchy in order to map out the redispatching calls. Such detective work compromises the black-box nature of object-oriented class definitions. Note that if you follow Guideline 9.2.1 on preserving the semantics of the class-wide dispatching operations in the extensions of derived types, you will minimize or avoid the problems discussed here about redispatching.

function Area (O : in Object) return Float;



function Area (C : in Circle) return Float;



function Area (S : in Shape) return Float;

A function for computing the moment of a force about a fulcrum can now be created using a class-wide type as follows:

function Moment (OC : Object'Class) return Float is

begin

   return OC.X_Coord*Area(OC);

end Moment;

Because Moment accepts the class-wide formal parameter of Object'Class, it can be called with an actual parameter that is any derivation of type Object. Assuming that all derivations of type object have defined a function for Area, Moment will dispatch to the appropriate function when called. For example:

C : Circle;

M : Float;



...



-- Moment will dispatch to the Area function for the Circle type.

M := Moment(C);

See also Guideline 8.4.3 for a discussion of class-wide pointers in an object-oriented programming framework registry.

--------------------------------------------------------------------------

package Game is

   type Game_Piece is tagged ...

   ...



end Game;

--------------------------------------------------------------------------

package Game.Constructors is

   function Make_Piece return Game_Piece;

   ...

end Game.Constructors;

--------------------------------------------------------------------------

The following example shows how to split the initialization and construction of an object:

type Vehicle is tagged ...



procedure Initialize (Self : in out Vehicle;

                      Make : in     String);



...



type Car is new Vehicle with ... ;

type Car_Ptr is access all Car'Class;



...



procedure Initialize (Self  : in out Car_Ptr;

                      Make  : in     String;

                      Model : in     String) is

begin -- Initialize

   Initialize (Vehicle (Self.all), Make);

   ...

   -- initialization of Car

end Initialize;



function Create (Make  : in String;

                 Model : in String) return Car_Ptr is

   Temp_Ptr : Car_Ptr;

begin -- Create

   Temp_Ptr := new Car;

   Initialize (Temp_Ptr, Make, Model);

   return Temp_Ptr;

end Create;

You cannot initialize a limited type at its declaration, so you may need to use an access discriminant and rely on default initialization. For a tagged type, however, you should not assume that any default initialization is sufficient, and you should declare constructors. For limited types, the constructors must be separate procedures or functions that return an access to the limited type.

The example shows using a constructor in a child package. By declaring constructor operations in either a child package or a nested package, you avoid the problems associated with making them primitive operations. Because they are no longer primitive operations, they cannot be inherited. By declaring them in a child package (see also Guidelines 4.1.6 and 4.2.2 on using child packages versus nested packages), you gain the ability to change them without affecting the clients of the parent package (Taft 1995b).

You should put the construction logic and initialization logic in distinct subprograms so that you are able to call the initialization routine for the parent tagged type.

----------------------------------------------------------------------------

package Object_Package is



   Epsilon : constant Float := 0.01;



   type Object is tagged

      record

         X_Coordinate : Float;

         Y_Coordinate : Float;

      end record;



   function "=" (A, B : Object) return Boolean;



end Object_Package;

----------------------------------------------------------------------------

package body Object_Package is



   -- redefine equality to be when two objects are located within a delta

   -- of the same point

   function "=" (A, B : Object) return Boolean is

   begin

      return (A.X_Coordinate - B.X_Coordinate) ** 2

           + (A.Y_Coordinate - B.Y_Coordinate) ** 2 < Epsilon**2;

   end "=";



end Object_Package;



----------------------------------------------------------------------------

with Object_Package;  use Object_Package;

package Circle_Package_1 is

   type Circle is new Object with

      record

         Radius : Float;

      end record;

  function "=" (A, B : Circle) return Boolean;

end Circle_Package_1;

----------------------------------------------------------------------------

package body Circle_Package_1 is



   -- Equality is overridden, otherwise two circles must have exactly

   -- equal radii to be considered equal.

   function "=" (A, B : Circle) return Boolean is

   begin

      return (Object(A) = Object(B)) and

             (abs (A.Radius - B.Radius) < Epsilon);

   end "=";



end Circle_Package_1;

----------------------------------------------------------------------------

with Object_Package;  use Object_Package;

package Circle_Package_2 is



   type Circle is new Object with

      record

         Radius : Float;

      end record;



   -- don't override equality in this package



end Circle_Package_2;

----------------------------------------------------------------------------

with Object_Package;

with Circle_Package_1;

with Circle_Package_2;

with Ada.Text_IO;

procedure Equality_Test is

   use type Object_Package.Object;

   use type Circle_Package_1.Circle;

   use type Circle_Package_2.Circle;

   Object_1 : Object_Package.Object;

   Object_2 : Object_Package.Object;

   Circle_1 : Circle_Package_1.Circle;

   Circle_2 : Circle_Package_1.Circle;

   Circle_3 : Circle_Package_2.Circle;

   Circle_4 : Circle_Package_2.Circle;

begin

   Object_1 := (X_Coordinate => 1.000, Y_Coordinate => 2.000);

   Object_2 := (X_Coordinate => 1.005, Y_Coordinate => 2.000);

   -- These Objects are considered equal.  Equality has been redefined to be

   -- when two objects are located within a delta of the same point.

   if Object_1 = Object_2 then

      Ada.Text_IO.Put_Line ("Objects equal.");

   else

      Ada.Text_IO.Put_Line ("Objects not equal.");

   end if;

   Circle_1 := (X_Coordinate => 1.000, Y_Coordinate => 2.000, Radius => 5.000);

   Circle_2 := (X_Coordinate => 1.005, Y_Coordinate => 2.000, Radius => 5.005);

   -- These Circles are considered equal.  Equality has been redefined to be

   -- when the X-Y locations of the circles and their radii are both within

   -- the delta.

   if Circle_1 = Circle_2 then

      Ada.Text_IO.Put_Line ("Circles equal.");

   else

      Ada.Text_IO.Put_Line ("Circles not equal.");

   end if;

   Circle_3 := (X_Coordinate => 1.000, Y_Coordinate => 2.000, Radius => 5.000);

   Circle_4 := (X_Coordinate => 1.005, Y_Coordinate => 2.000, Radius => 5.005);

   -- These Circles are not considered equal because predefined equality of

   -- the extension component Radius will evaluate to False.

   if Circle_3 = Circle_4 then

      Ada.Text_IO.Put_Line ("Circles equal.");

   else

      Ada.Text_IO.Put_Line ("Circles not equal.");

   end if;

end Equality_Test;

  generic

     type Element is private;

  package Stack is

     ...

  end Stack;

is preferable to:

  package Stack is

     type Element is tagged null record;

     -- Elements to be put on the stack must be of a descendant type

     -- of this type.

     ...

  end Stack;

Class-wide programming enables you to take a set of heterogeneous data structures and provide a homogeneous-looking interface across the whole set. See also Guideline 9.2.1 on using tagged types to describe heterogeneous polymorphic data.

In object-oriented programming languages without generic capabilities, it was common to use inheritance to achieve much the same effect. However, this technique is generally less clear and more cumbersome to use than the equivalent explicit generic definition. The nongeneric, inheritance approach can always be recovered using a specific instantiation of the generic. Also see Guidelines 5.3.2 and 5.4.7 for a discussion of
self-referential data structures.

generic

   type Item_Type is private;

package Generic_Stack is

   type Abstract_Stack_Type is abstract tagged limited private;

   procedure Push (Stack : in out Abstract_Stack_Type;

                   Item  : in     Item_Type) is abstract;

   procedure Pop (Stack : in out Abstract_Stack_Type;

                  Item  :    out Item_Type) is abstract;

   function Size (Stack : Abstract_Stack_Type) return Natural;

   Full_Error  : exception; -- May be raised by Push

   Empty_Error : exception; -- May be raised by Pop

private

   type Abstract_Stack_Type is abstract tagged limited

      record

         Size : Natural := 0;

      end record;

end Generic_Stack;

package body Generic_Stack is

   function Size (Stack : Abstract_Stack_Type)

      return Natural is

   begin

      return Stack.Size;

   end Size;

end Generic_Stack;

--

-- Now, a bounded stack can be derived in a child package as follows:

--

----------------------------------------------------------------------

generic

package Generic_Stack.Generic_Bounded_Stack is

   type Stack_Type (Max : Positive) is

      new Abstract_Stack_Type with private;

   -- override all abstract subprograms

   procedure Push (Stack : in out Stack_Type;

                   Item  : in     Item_Type);

   procedure Pop (Stack : in out Stack_Type;

                  Item  :    out Item_Type);

private

   type Table_Type is array (Positive range <>) of Item_Type;

   type Stack_Type (Max : Positive) is new Abstract_Stack_Type with

      record

         Table : Table_Type (1 .. Max); 

      end record;

end Generic_Stack.Generic_Bounded_Stack;

----------------------------------------------------------------------

package body Generic_Stack.Generic_Bounded_Stack is



   procedure Push (Stack : in out Stack_Type;

                   Item  : in     Item_Type) is

   begin



      -- The new bounded stack needs visibility into the base type

      --   in order to update the Size element of the stack type

      --   when adding or removing items.



      if (Stack.Size = Stack.Max) then

         raise Full_Error;

      else

         Stack.Size := Stack.Size + 1;

         Stack.Table(Stack.Size) := Item;

      end if;

   end Push;



   procedure Pop (Stack : in out Stack_Type;

                  Item  :    out Item_Type) is

   begin

      ...

   end Pop;



end Generic_Stack.Generic_Bounded_Stack;

When the implementation of a derived tagged type requires visibility of the implementation of the base type, use a child package to define the derived type. Rather than providing additional public operations for this information, it is better to place the definition of the derived type in a child package. This gives the derived type the necessary visibility without risking misuse by other clients.

This situation is likely to arise when you build a data structure with a homogeneous interface but whose data elements have a heterogeneous implementation. See also Guidelines 8.4.8, 9.2.1, and 9.3.5.

The abstract type Set_Of_Strings provides the interface to inherit:

type Set_Of_Strings is abstract tagged limited private;

type Element_Index is new Natural;  -- Index within set.

No_Element : constant Element_Index := 0;

Invalid_Index : exception;

procedure Enter(

  -- Enter an element into the set, return the index

  Set : in out Set_Of_Strings;

  S : String;

  Index : out Element_Index) is abstract;

procedure Remove(

  -- Remove an element from the set; ignore if not there

  Set : in out Set_Of_Strings;

  S : String) is abstract;

procedure Combine(

  -- Combine Additional_Set into Union_Set

  Union_Set : in out Set_Of_Strings;

  Additional_Set : Set_Of_Strings) is abstract;

procedure Intersect(

  -- Remove all elements of Removal_Set from Intersection_Set

  Intersection_Set : in out Set_Of_Strings;

  Removal_Set : Set_Of_Strings) is abstract;

function Size(Set : Set_Of_Strings) return Element_Index 

  is abstract;

  -- Return a count of the number of elements in the set

function Index(

  -- Return the index of a given element;

  -- return No_Element if not there.

  Set : Set_Of_Strings;

  S : String) return Element_Index is abstract;

function Element(Index : Element_Index) return String is abstract;

  -- Return element at given index position

  -- raise Invalid_Index if no element there.

private

  type Set_Of_Strings is abstract tagged limited ...

The type Hashed_Set derives its interface from Set_of_Strings and its implementation from an existing (concrete) type Hash_Table:

type Hashed_Set(Table_Size : Positive) is

  new Set_Of_Strings with private;

-- Now we give the specs of the operations being implemented

procedure Enter(

  -- Enter an element into the set, return the index

  Set : in out Hashed_Set;

  S : String;

  Index : out Element_Index);

procedure Remove(

  -- Remove an element from the set; ignore if not there

  Set : in out Hashed_Set;

  S : String);

  -- . . . etc.

private

  type Hashed_Set(Table_Size : Positive) is

    new Set_Of_Strings with record

      Table : Hash_Table(1..Table_Size);

    end record;

In the package body, you define the bodies of the operations (i.e., Enter, Remove,Combine, Size, etc.) using the operations available on Hash_Table. You must also provide any necessary "glue" code.

In this second example, the type Basic_Window responds to various events and calls:

type Basic_Window is tagged limited private;

procedure Display(W : Basic_Window);

procedure Mouse_Click(W     : in out Basic_Window;

                      Where :        Mouse_Coords);

          . . .

You use mixins to add features such as labels, borders, menu bar, etc:

generic

  type Some_Window is new Window with private;

  -- take in any descendant of Window

package Label_Mixin is

  type Window_With_Label is new Some_Window with private;

    -- Jazz it up somehow.

  -- Overridden operations:

  procedure Display(W : Window_With_Label);

  -- New operations:

  procedure Set_Label(W : in out Window_With_Label; S : String);

    -- Set the label

  function Label(W : Window_With_Label) return String;

    -- Fetch the label

private

  type Window_With_Label is

    new Some_Window with record

      Label : String_Quark := Null_Quark;

        -- An XWindows-Like unique ID for a string

    end record;

In the generic body, you implement any overridden operations as well as the new operations. For example, you could implement the overridden Display operation using some of the inherited operations:

procedure Display(W : Window_With_Label) is

begin

    Display(Some_Window(W));

      -- First display the window normally,

      -- by passing the buck to the parent type.

    if W.Label /= Null_Quark then

      -- Now display the label if it is not null

        Display_On_Screen(XCoord(W), YCoord(W)-5, Value(W.Label));

          -- Use two inherited functions on Basic_Window

          -- to get the coordinates where to display the label.

    end if;

end Display;

Assuming you have defined several generics with these additional features, to create the desired window, you use a combination of generic instantiations and private type extension, as shown in the following code:

  type My_Window is new Basic_Window with private;

  . . .

private

  package Add_Label is new Label_Mixin(Basic_Window);

  package Add_Border is

    new Border_Mixin(Add_Label.Window_With_Label);

  package Add_Menu_Bar is

    new Menu_Bar_Mixin(Add_Border.Window_With_Border);

  type My_Window is

    new Add_Menu_Bar.Window_With_Menu_Bar with null record;

      -- Final window is a null extension of Window_With_Menu_Bar.

      -- We could instead make a record extension and

      -- add components for My_Window over and above those

      -- needed by the mixins.

The following example shows "full" multiple inheritance.

Assume previous definition of packages for Savings_Account and Checking_Account. The following example shows the definition of an interest-bearing checking account (NOW account):

with Savings_Account;

with Checking_Account;

package NOW_Account is



   type Object is tagged limited private;



   type Savings (Self : access Object'Class) is

      new Savings_Account.Object with null record;



   -- These need to be overridden to call through to "Self"

   procedure Deposit (Into_Account : in out Savings; ...);

   procedure Withdraw (...);

   procedure Earn_Interest (...);

   function Interest (...) return Float;

   function Balance (...) return Float;

   type Checking (Self : access Object'Class) is

      new Checking_Account.Object with null record;



   procedure Deposit (Into_Account : in out Checking; ...);

   ...

   function Balance (...) return Float;



   -- These operations will call-through to Savings_Account or

   -- Checking_Account operations. "Inherits" in this way all savings and

   -- checking operations



   procedure Deposit (Into_Account : in out Object; ...);

   ...

   procedure Earn_Interest (...);

   ...

   function Balance (...) return Float;



private



   -- Could alternatively have Object be derived from either

   -- Savings_Account.Object or Checking_Account.Object

   type Object is tagged

      record

         As_Savings  : Savings (Object'Access);

         As_Checking : Checking (Object'Access);

      end record;



end NOW_Account;

Another possibility is that the savings and checking accounts are both implemented based on a common Account abstraction, resulting in inheriting a Balance state twice for NOW_Account.Object. To resolve this ambiguity, you need to use an abstract type hierarchy for the multiple inheritance of interface and separate mixins for the multiple inheritance of implementation.

A library of mixins allows the client to mix and match in order to develop an implementation. Also see Guideline 8.3.8 about implementing mixins.

You should not use multiple inheritance to derive an abstraction that is essentially unrelated to its parent(s). Thus, you should not try to derive a menu abstraction by inheriting from a command line type and a window type. However, if you have a basic abstraction such as a window, you can use multiple inheritance mixins to create a more sophisticated abstraction, where a mixin is the package containing the type(s) and operations that will extend the parent abstraction.

Use self-referential data structures to implement types with "full" multiple inheritance ("multiple polymorphism").

A common mistake is to use multiple inheritance for parts-of relations. When a type is composed of several others types, you should use heterogeneous data structuring techniques, discussed in Guideline 5.4.2.