 Previous |
 Contents |
 Next |
Previous |
Contents |
Next |
Every kind of thinking, without exception,
is stamped with the brand of a class.
— Mao Tse-tung, On Practice
The last chapter showed how new types of appointment for an appointments diary can be created by inheritance from the original appointment type. However, it assumed that the diary would only need to deal with a single type of appointment. It would be more realistic to produce a diary capable of holding different types of appointments at the same time: some meetings, some social appointments, and so on. The diary can be listed by displaying each appointment in turn using Put. Here are the declarations of some appointment types and the associated versions of Put:
type Appointment_Type is
tagged record
... -- properties common to all appointments
end record;
procedure Put (Appt : in Appointment_Type); -- primitive operation
type Meeting_Type is new Appointment_Type with
record
... -- extra properties of meetings
end record;
procedure Put (Appt : in Meeting_Type); -- override inherited Put
type Deadline_Type is new Appointment_Type with
record
... -- extra properties of deadlines
end record;
procedure Put (Appt : in Deadline_Type); -- override inherited Put
Notice that you can guarantee that you’ll be able to use Put to display any appointment, since any type derived directly or indirectly from Appointment_Type either inherits a version of Put from its parent type or overrides the inherited version. In either case there will be a procedure called Put with a single parameter which can be used to display the appointment.
We could create a linked list of Appointment_Types or a linked list of Meeting_Types using the linked list package from chapter 12, but what we want is a list that can contain a mixture of appointments. It wouldn’t be any good creating a list of Appointment_Types since this would mean converting meetings and deadlines to normal appointments before they could be stored in the list, and this would mean stripping off the extra components that they have in addition to any components that Appointment_Type provides.
Tagged types provide an attribute called 'Class which gives a type describing an entire family of types (a class-wide type) which can be used to solve this problem. For example, Appointment_Type'Class consists of Appointment_Type itself, together with any types derived from Appointment_Type (in this case Meeting_Type and Deadline_Type). Any other types that we derive from Appointment_Type or Meeting_Type or Deadline_Type will also be members of Appointment_Type'Class. This means that a linked list of Appointment_Type'Class objects could be used to hold appointments, meetings, deadlines, or any other type of appointment that we decide to add later:
However, Appointment_Type'Class is an unconstrained type. Different appointments will occupy different amounts of memory, so you can’t declare an Appointment_Type'Class variable since the compiler won’t know how much memory to allocate for it (unless you specify an initial value for it, in which case it is permanently constrained to be the same type of appointment as the initial value). What you can do is to create an access type for Appointment_Type'Class:
type Appointment_Access is access Appointment_Type'Class;
Since Appointment_Access is a pointer to the class-wide type Appointment_Type'Class, an Appointment_Access variable can be used to point to any kind of appointment at all:
M : Appointment_Access := new Meeting_Type;
D : Appointment_Access := new Deadline_Type;
This means that we can have a linked list of Appointment_Access objects and have each list element point to any kind of appointment we feel like:
package Appointment_Lists is
new JE.Lists (Appointment_Access);
M and D above can point to any type of appointment at all. This means that if you get at the appointments that M and D point to using ‘M.all’ and ‘D.all’, the only thing the compiler knows is that they’re some sort of appointment. It doesn’t know whether they’re going to be meetings or deadlines (and they could be different at different times), so you can’t apply any meeting-specific or deadline-specific operations. The only things you can do with M.all and D.all are operations common to all appointments, namely the primitive operations of Appointment_Type. If you want to do something to M.all which is unique to Meeting_Type, you have to use a type conversion to convert M.all to a Meeting_Type:
Meeting_Specific_Operation( Meeting_Type(M.all) );
If you do this, it’s your responsibility to make sure that M does actually point to a meeting. If it doesn’t you’ll get a Constraint_Error when you try to do the type conversion. How you check what M really points to is discussed below.
A consequence of class-wide types is that you aren’t allowed to declare derived types at a deeper level than the parent type. Library units are at library level, and each time you enter a subprogram (or go into a declare block) you are going one level deeper, so that inside the main program you are one level deeper than the library level. Basically, entering any block which can have a declaration section increases the depth, and exiting from the block decreases it again. Packages do not affect the level. The reason for the restriction is similar to the reason for the accessibility limitations on general access types described in chapter 11; for example, if you declared a derived type in a procedure called from the main program and the main program had a pointer to a class-wide type, the procedure would be able to set the pointer to point to an object of the derived type. On exit from the procedure, the pointer would be pointing to an object of a type that no longer exists, and any attempt to use this pointer in the main program would probably be disastrous.
Since Appointment_Type'Class is an unconstrained type, one of the few things you can use it for is as the type for a procedure parameter:
procedure Display (A : in Appointment_Type'Class) is
begin
... -- display an appointment using Put
end Display;
This lets you pass a meeting or a deadline or any other type of appointment to Display as its parameter. You could use this procedure to process individual appointments from a list of appointments like this:
procedure List_Diary (A : in Appointment_Lists.List_Type) is
I : Appointment_Lists.List_Iterator := Appointment_Lists.First(A);
begin
while I /= Appointment_Lists.Last(A) loop
Display( Appointment_Lists.Value(I).all );
I := Succ(I);
end loop;
end List_Diary;
This uses an iterator I to go through each item in the list. Appointment_Lists.Value(I) extracts the current Appointment_Access value from the list, and then ‘.all’ is used to get the Appointment_Type'Class value it points to for use by Display.
Display will need to deal with each appointment in an appropriate way. The parameter might be a meeting or a deadline or any other type of appointment, so we need to ensure that the correct version of Put is called according to the actual type of the parameter. Tagged types contain a tag (hence the name ‘tagged type’) which identifies their actual type, so that we can inspect the parameter’s tag to find out if it’s actually a meeting or a deadline or whatever. One way to do this is to use the in operator to check for membership of a particular class:
procedure Display (A : in Appointment_Type'Class) is
begin
if A in Meeting_Type'Class then
Put( Meeting_Type(A) );
elsif A in Deadline_Type'Class then
Put( Deadline_Type(A) );
else
Put( Appointment_Type(A) );
end if;
end Display;
The test ‘A in Meeting_Type'Class’ tests if the actual type of A belongs to Meeting_Type'Class, i.e. Meeting_Type itself or any types derived from Meeting_Type. If so, A is converted to a Meeting_Type so that the version of Put which takes a Meeting_Type parameter will be called to display the meeting. The same is done for deadlines, and if all else fails the version of Put for the parent type Appointment_Type will be called.
This is not particularly satisfactory since the version of Put for meetings will be called for any type derived from Meeting_Type. If you want to add a derived type called Urgent_Meeting_Type, the version of Put for Meeting_Type will be called instead of the version for Urgent_Meeting_Type. One way to solve this is to get at the parameter’s tag directly using the 'Tag attribute:
if A'Tag = Meeting_Type'Tag then ...
This will check whether A is actually a Meeting_Type rather than a member of Meeting_Type’s family of derived types. The tag belongs to the private type Ada.Tags.Tag; you can also get a printable form of the tag using the attribute 'External_Tag (e.g. A'External_Tag) whose value is a String.
Using the tag to identify the type is still not a particularly satisfactory solution. Regardless of whether you decide to identify an object using ‘A in Meeting_Type'Class’ or ‘A'Tag = Meeting_Type'Tag’, you’ll still run into problems whenever a new type of appointment is added to the program. Any class-wide operations like Display will need modifying whenever a new appointment is derived from Appointment_Type, with resultant costs in recompiling and testing.
Fortunately you don’t actually need to go to all this trouble. When you have a class-wide type like Appointment_Type'Class and you call a primitive operation like Put, the tag is used to identify the correct version of the primitive operation automatically. This automatic selection of primitive operations is known in Ada as dispatching. It only applies to class-wide values where the actual type isn’t known until run time; if the compiler can identify the actual type at compile time it knows which version of the operation to use so no dispatching is necessary. It also only applies to primitive operations, since these are the only ones that are guaranteed to be available for all types derived from the parent type. So for Appointment_Type'Class, a call to any primitive operation of Appointment_Type will be a dispatching operation. This means that Display can be written like this:
procedure Display (A : in Appointment_Type'Class) is
begin
Put( A ); -- A is class-wide and Put is primitive, so
-- dispatching happens; the version of Put that
-- gets called depends on the actual type of A
end Display;
If A is actually a meeting, the version of Put for Meeting_Type will be called; if it’s a deadline, the version of Put for Deadline_Type will be called. In fact, you can eliminate Display altogether:
procedure List_Diary (A : in Appointment_Lists.List_Type) is
I : Appointment_Lists.List_Iterator := Appointment_Lists.First(A);
begin
while I /= Appointment_Lists.Last(A) loop
Put( Appointment_Lists.Value(I).all );
-- Appointment_Lists.Value(I).all is class-wide and Put
-- is primitive, so dispatching happens; the version
-- of Put that gets called depends on the actual type
-- of Appointment_Lists.Value(I).all
I := Succ(I);
end loop;
end List_Diary;
In effect, you can think of calls to primitive operations of a class-wide object as asking the object to perform the primitive operation on itself. How each object satisfies this request will depend on what type of object it really is. You’re asking each appointment to display itself, and how this is done depends on the actual type of appointment involved. Primitive operations of tagged types are polymorphic (literally ‘many shaped’); what the ‘shape’ of the operation will be depends on the type of object being operated on.
One possible complication arises if two tagged types are declared within the same package specification. What will happen if you declare a subprogram which takes two parameters, one of each type? The subprogram would end up being a primitive operation of both types, and the compiler would need some way of deciding which parameter to use for dispatching. For example, consider the following (illegal) example:
type Appointment_Type is
tagged record
...
end record;
type Output_Device is
tagged record
...
end record;
procedure Put (A : in Appointment_Type; D : in Output_Device);
-- write A to output device D (ILLEGAL!)
The idea is to be able to have various types of output device and to have a procedure to output a given appointment to a given device (e.g. a display, or a speech synthesiser, or whatever). Each appointment can override Put to output itself appropriately; also each Output_Device can override Put to use the operations appropriate to a particular output device. If Put is called the compiler won’t know whether to call the overridden version for the derived Appointment_Type or the overridden version for the derived Output_Device.
Ada adopts a brutally simple approach to resolving this problem. Subprograms which are primitive operations of two tagged types (like Put above) are not allowed. Either you could move the operation itself out of the package specification so that it is no longer a primitive operation of either type or you could move one of the type declarations out of the package so that the operation is a primitive operation of only one of the two types. Alternatively, you could change the procedure specification so that it only uses one of the two types. Here’s how you could modify Put to eliminate the Output_Device parameter:
procedure Put (A : in Appointment_Type;
D : in Output_Device'Class);
The parameter D isn’t an Output_Device any more so the procedure is no longer a primitive operation of Output_Device. However, inside Put an Output_Device'Class value will cause dispatching to occur if there is a call to a primitive operation of Output_Device. This technique is known as double dispatching or redispatching. For example, imagine that Output_Device has a primitive operation called Write_Output that looks like this:
procedure Write_Output (D : in Output_Device; S : in String);
Meeting_Type might override Put to output a meeting like this:
procedure Put (A : in Meeting_Type;
D : in Output_Device'Class) is
begin
Put (Appointment_Type(A), D); -- parent's version of Put
Write_Output (D, "Room: "); -- display the meeting's room
Write_Output (D, Room_Type'Image(A.Room));
end Put;
A call to Put involving class-wide parameters corresponding to a meeting and a particular type of output device will result in the call being dispatched to the version of Put above. This will output the meeting’s details using calls to Write_Output, each of which will be dispatched to the correct version of Write_Output for the particular type of device.
You are still allowed to have two parameters of the same tagged type. For example, imagine a primitive operation to determine the time between two appointments. The declaration might look like this:
function Interval (A,B : Appointment_Type) return Time_Type;
This means that the inherited operations for Meeting_Type and Deadline_Type will look like this:
function Interval (A,B : Meeting_Type) return Time_Type;
function Interval (A,B : Deadline_Type) return Time_Type;
The reason that declarations like this are allowed is that the parameters in situations like this will always be the same type as each other so there will never be a choice of types to dispatch the operation to. This means that if you call Interval with two class-wide parameters, the actual types of the class-wide parameters must match. The compiler will insert a run-time check in your program to make sure that the types do in fact match, and a Constraint_Error will be raised if you ever try to call Interval with parameters whose actual types don’t match.
In many cases it can be difficult to define the contents of a parent type or the implementation of its primitive operations. Consider the Shape type mentioned at the end of the previous chapter. The components of Shape will be those that are common to all shapes we could ever imagine: not just squares and rectangles, but triangles, circles, ellipses, parallelograms and so on as well. Quite often in these situations there are no components at all that will be common to everything, so Shape needs to be a null record:
type Shape is
tagged record
null; -- no components!
end record;
This happens often enough that there is a special abbreviated form of this declaration:
type Shape is tagged null record;
You can also use null records as type extensions if you don’t want to add any extra components when you derive from a tagged type:
type Deadline_Type is new Appointment_Type with null record;
For example, the only difference between Deadline_Type and Appointment_Type might be in the way they’re displayed; you might want a Deadline_Type to be displayed in a way that makes it stand out on the screen (e.g. in bright red or boldface characters).
We might want all shapes to have a primitive operation called Draw to guarantee that there’ll always be a way of drawing any derived shape. Now, how can we implement Draw when Shape is a null record? The answer is that we can’t; each shape will have its own requirements, but there’s no way to draw a generalised Shape without knowing what sort of shape it is. One solution is to define Draw so that it does nothing:
procedure Draw (S : in Shape) is
begin
null; -- do nothing
end Draw;
An alternative would be to raise a Program_Error exception, since there’s surely something wrong if we ever get into the situation of drawing an amorphous shape.
However, there’s an easy way to overcome this problem: Ada allows us to declare Shape as an abstract type (which is not the same thing as an abstract data type!) by adding the word abstract to the declaration:
type Shape is abstract tagged null record;
You can’t create objects of an abstract type; the only reason for its existence is to act as a parent type for a family of related types. Its main purpose is to provide a set of primitive operations such as Draw which will be inherited by all types derived from it. Since you can’t declare a Shape once it’s made abstract, you don’t run the risk of calling Draw for an indeterminate Shape. You have to derive concrete (non-abstract) types such as Square and Rectangle so that objects of these types can be created. These can override Draw in an appropriate way, and the version of Draw that will be called from a class-wide (Shape'Class) reference will then be the overridden versions defined for Square or Rectangle.
There is still one risk to be guarded against, and that is that when you derive a new type from Shape you might forget to override Draw. As it is, you will simply end up with an invisible shape (or an exception, depending on how the Shape version of Draw was implemented), but it would be far better to identify this sort of problem at compile time rather than leaving it until run time. The way to do this is to declare Draw as an abstract operation:
procedure Draw (S : in Shape) is abstract;
This is used as the specification of Draw in the package specification, and it indicates to the compiler that this version of Draw will not actually be implemented (i.e. there will be no definition of Draw in the package body). Only abstract types can have abstract operations. When you derive a concrete type from an abstract type, the compiler requires you to override all the abstract primitive operations, so that it’s impossible to forget to provide them. If you want to you can derive another abstract type from a parent abstract type, in which case the derived type will just inherit the abstract operations from its parent:
type Coloured_Shape is abstract new Shape with record ... end record;
Coloured_Shape inherits Draw as an abstract primitive procedure, just as if you’d written this:
procedure Draw (S : in Coloured_Shape) is abstract;
Since you’re not allowed to create objects belonging to an abstract type, functions which return a result of an abstract type must be declared to be abstract, since you can't provide an implementation; there’s no way to create an object to return as the function’s result.
Let’s reconsider the appointment diary design using the tagged types for appointments and meetings from the previous chapter. If we want a diary which holds a mixture of appointments and meetings and any other derivations we may care to add at some future date, we’ll need to have a list of pointers to Appointment_Type'Class objects rather than a list of Appointment_Types. The main difficulty is in preserving the separation of model and view. Different types of appointment will need to be displayed in different ways, so we’ll need to provide a primitive operation of Appointment_Type (which we can call Put, as usual) to do this:
procedure Put (Appt : in Appointment_Type);
Since the appointment list contains class-wide pointers, the availability of Put as a primitive operation will mean that Put can just be called for each appointment in the list and dispatching will ensure that the correct version for the actual appointment type will be used. However, this will mean that the model (Appointment_Type) is once again entangled with a particular view.
Derivation provides a simple solution to this difficulty. If the user interface needs to be redesigned you can just derive a new type from Appointment_Type which overrides Put. In fact, by making Appointment_Type an abstract type and Put an abstract operation, you can preserve the independence of the model from the view; each program which uses the Appointment_Type abstraction will need to derive a concrete type from it to be able to use it and will be forced to provide an appropriate implementation of Put. Since functions returning abstract types have to be abstract, the constructor has to be made into a procedure so that an implementation can be given for it; it also has to be inherited by derived classes (with all the potentially nasty consequences described in the previous chapter) since derived classes will need to use it to set up the Date and Details components that they inherit from Appointment_Type. The appointment package from the previous chapter will need some minor modifications as a result:
with JE.Times;
use JE.Times;
package JE.Appointments is
type Appointment_Type is abstract tagged private;
function Date (Appt : Appointment_Type) return Time_Type;
function Details (Appt : Appointment_Type) return String;
procedure Appointment (Date : in Time_Type;
Details : in String;
Result : out Appointment_Type);
procedure Put (Appt : in Appointment_Type) is abstract;
private
type Appointment_Type is
abstract tagged record
Time : Time_Type;
Details : String (1..50);
Length : Natural := 0;
end record;
end JE.Appointments;
The diary will need changing to be a linked list of class-wide pointers. Add will need to take a class-wide pointer as its parameter and Choose will need to return a class-wide result.
with JE.Appointments, JE.Lists;
use JE.Appointments;
package JE.Diaries is
type Diary_Type is limited private;
procedure Add (Diary : in out Diary_Type;
Appt : in Appointment_Type'Class);
function Choose (Diary : Diary_Type;
Appt : Positive) return Appointment_Type'Class;
... -- other declarations as before
private
type Appointment_Access is access Appointment_Type'Class;
package Lists is new JE.Lists (Item_Type => Appointment_Access);
type Diary_Type is
limited record
List : Lists.List_Type;
end record;
end JE.Diaries;
Meetings can be derived from Appointment_Type as in the previous chapter, but Meeting_Type will need to be an abstract type which inherits an abstract Put procedure:
package JE.Appointments.Meetings is
subtype Room_Type is Integer range 100 .. 999;
type Meeting_Type is abstract new Appointment_Type with private;
procedure Meeting (Date : in Time_Type;
Details : in String;
Room : in Room_Type;
Result : out Meeting_Type);
function Room (Appt : Meeting_Type) return Room_Type;
-- Date, Details and Put inherited unchanged from
-- Appointment_Type; so is Appointment, but don't use it!
private
type Meeting_Type is abstract new Appointment_Type with
record
Room : Room_Type;
end record;
end JE.Appointments.Meetings;
Meeting_Type inherits the constructor procedure Appointment from Appointment_Type and also provides its own constructor called Meeting. Meeting can be implemented using the inherited version of Appointment:
procedure Meeting (Date : in Time_Type;
Details : in String;
Room : in Room_Type;
Result : out Meeting_Type) is
begin
Appointment (Date, Details, Result); -- set up Result's date & details
Result.Room := Room; -- and its room component
end Meeting;
The main program will need to derive concrete appointment types from the abstract types Appointment_Type and Meeting_Type as part of the view package. Because of the restrictions about where derived types can be declared (as described at the beginning of this chapter), it’s no longer possible to declare the view package inside the main program; it’ll have to be declared at library level. To do this, I’ll create another empty parent package called JE.Views:
package JE.Views is
-- another empty package!
end JE.Views;
and then I’ll make a child package of JE.Views called JE.Views.Diary:
with JE.Diaries, JE.Appointments.Meetings;
package JE.Views.Diary is
type Appointment_Type is
new JE.Appointments.Appointment_Type with null record;
procedure Put (Appt : in Appointment_Type);
type Meeting_Type is
new JE.Appointments.Meetings.Meeting_Type with null record;
procedure Put (Appt : in Meeting_Type);
type Command_Type is (Add, List, Delete, Save, Quit);
function Next_Command return Command_Type;
procedure Load_Diary (Diary : in out JE.Diaries.Diary_Type);
procedure Save_Diary (Diary : in JE.Diaries.Diary_Type);
procedure Add_Appointment (Diary : in out JE.Diaries.Diary_Type);
procedure List_Appointments (Diary : in JE.Diaries.Diary_Type);
procedure Delete_Appointment (Diary : in out JE.Diaries.Diary_Type);
end JE.Views.Diary;
One problem that arises from using a linked list of class-wide pointers is that Load and Save will need modifying because they won’t be able to use Ada.Sequential_IO. After all, it’s a bit difficult to read a value into a variable when you don’t know the exact type of value that you’re about to read until you’ve already read it! However, all tagged types like Appointment_Type have attributes called Input and Output which are subprograms for reading and writing values; these use streams rather than files, but there is a package called Ada.Streams.Stream_IO (see Appendix B) which lets you associate a stream with a file. Input and Output are also defined for class-wide types; if you use the procedure Appointment_Type'Class'Output, the tag of the appointment will be written to the stream followed by the actual appointment, whatever type within Appointment_Type'Class it might be. Appointment_Type'Class'Input reads the tag, and then it reads the appropriate type of object from the stream. The specifications for these two subprograms look like this (see Appendix C):
procedure Appointment'Class'Output (Stream : access Ada.Streams.Root_Stream_Type'Class;
Item : in Appointment_Type'Class);
function Appointment'Class'Input (Stream : access Ada.Streams.Root_Stream_Type'Class)
return Appointment_Type'Class;
The package Ada.Streams.Stream_IO provides similar facilities to Text_IO and Sequential_IO. It also contains a function Stream which takes a file as a parameter and returns a value suitable for use as the Stream parameter of the Input and Output subprograms above:
type Stream_Access is access all Ada.Streams.Root_Stream_Type'Class;
function Stream (File : in Ada.Streams.Stream_IO.File_Type) return Stream_Access;
The with clause at the start of the package body will need changing to refer to Ada.Streams.Stream_IO instead of Ada.Sequential_IO. Here’s what Save will look like:
procedure Save (Diary : in Diary_Type;
To : in String) is
File : Ada.Streams.Stream_IO.File_Type;
Stream : Ada.Streams.Stream_IO.Stream_Access;
I : List_Iterator := First(Diary.List);
begin
Ada.Streams.Stream_IO.Create (File, Name => To);
Stream := Ada.Streams.Stream_IO.Stream(File);
while I /= Last(Diary.List) loop
Appointment_Type'Class'Output (Stream, Value(I).all);
I := Succ(I);
end loop;
Ada.Streams.Stream_IO.Close (File);
end Save;
Load just has to use Appointment_Type'Class'Input to read successive appointments of whatever type from the file:
procedure Load (Diary : in out JE.Diaries.Diary_Type;
From : in String) is
File : Ada.Streams.Stream_IO.File_Type;
Stream : Ada.Streams.Stream_IO.Stream_Access;
begin
while Size(Diary) > 0 loop
Delete (First(Diary.List));
end loop;
Ada.Streams.Stream_IO.Open (File, Name => From,
Mode => Ada.Streams.Stream_IO.In_File);
Stream := Ada.Streams.Stream_IO.Stream(File);
while not Ada.Streams.Stream_IO.End_Of_File(File) loop
Add (Diary, Appointment_Type'Class'Input (Stream));
end loop;
Ada.Streams.Stream_IO.Close (File);
exception
when Ada.Streams.Stream_IO.Name_Error =>
raise Diary_Error;
end Load;
First of all the diary is emptied by repeatedly deleting the first appointment until there are none left. Then the file is opened and the main loop reads appointments one by one, adding them to the diary using Add.
Apart from these changes, the other changes to the diary are fairly minor. References to ‘Value(I)’ need to be changed to ‘Value(I).all’, as for example in Choose:
function Choose (Diary : Diary_Type;
Appt : Positive) return Appointment_Type'Class is
Iterator : List_Iterator;
begin
if Appt not in 1 .. Size(Diary) then
raise Diary_Error;
else
Iterator := First(Diary.List);
for I in 2 .. Appt loop
Iterator := Succ(Iterator);
end loop;
return Value(Iterator).all;
end if;
end Choose;
Delete needs to deallocate the appointments when the pointers to them are removed from the list:
procedure Delete (Diary : in out Diary_Type;
Appt : in Positive) is
Iterator : List_Iterator;
procedure Delete_Appt is new Ada.Unchecked_Deallocation
(Appointment_Type'Class, Appointment_Access);
begin
if Appt not in 1 .. Size(Diary) then
raise Diary_Error;
else
Iterator := First(Diary.List);
for I in 2 .. Appt loop
Iterator := Succ(Iterator);
end loop;
Delete_Appt (Value(Iterator));
Delete (Iterator);
end if;
end Delete;
The only changes to Add are the change to the type of its parameter and the use of new to create a class-wide object initialised to hold a copy of the parameter:
procedure Add (Diary : in out Diary_Type;
Appt : in Appointment_Type'Class) is
use type JE.Times.Time_Type; -- to allow use of ">"
Iterator : List_Iterator;
begin
Iterator := First(Diary.List);
while Iterator /= Last(Diary.List) loop
exit when Value(Iterator).Time > Appt.Time;
Iterator := Succ(Iterator);
end loop;
Insert (Iterator, new Appointment_Type'Class'(Appt));
exception
when Storage_Error =>
raise Diary_Error;
end Add;
Adding a new appointment will involve asking the user if it’s an ordinary appointment or a meeting. The date, time and details are then read in. Finally, the appointment is created and added to the diary depending on the appointment type; if it’s a meeting, the extra meeting-specific information (the room number) is read in first:
procedure Add_Appointment (Diary : in out Diary_Type) is
Day : JE.Times.Day_Type;
Month : JE.Times.Month_Type;
Year : JE.Times.Year_Type;
Hour : JE.Times.Hour_Type;
Minute : JE.Times.Minute_Type;
Details : String (1..50);
Length : Natural;
Separator : Character;
Appt_Kind : Character;
begin
-- Get appointment type
Put ("Appointment (A) or meeting (M)? ");
Get (Appt_Kind);
if Appt_Kind /= 'A' and Appt_Kind /= 'a' and
Appt_Kind /= 'M' and Appt_Kind /= 'm' then
raise Data_Error;
end if;
-- Get date
Put ("Enter date: ");
Get (Day);
Get (Separator);
Get (Month);
Get (Separator);
Get (Year);
Skip_Line;
-- Get time
Put ("Enter time: ");
Get (Hour);
Get (Separator);
Get (Minute);
Skip_Line;
-- Get description
Put ("Description: ");
Get_Line (Details, Length);
if Appt_Kind = 'M' or Appt_Kind = 'm' then
-- Get meeting-specific details and construct a meeting
declare
Room : JE.Diaries.Meetings.Room_Type;
Appt : Meeting_Type;
begin
Put ("Room number: ");
Get (Room);
Skip_Line;
Meeting (JE.Times.Time(Year,Month,Day,Hour,Minute),
Details(1..Length), Room, Appt);
JE.Diaries.Add (Diary, Appt);
end;
else
-- Construct a normal appointment
declare
Appt : Appointment_Type;
begin
Appointment (JE.Times.Time(Year,Month,Day,Hour,Minute),
Details(1..Length), Appt);
JE.Diaries.Add (Diary, Appt);
end;
end if;
exception
when Data_Error | Constraint_Error | JE.Diaries.Diary_Error =>
Put_Line ("Invalid input.");
end Add_Appointment;
If at some point in the future you decide to add another appointment type (e.g. Deadline_Type) all you’ll need to do is to create a new child package which derives Deadline_Type from Appointment_Type and provides any overridden operations as well as any extra operations (of which there are none in this case):
package JE.Appointments.Deadlines is
type Deadline_Type is abstract new Appointment_Type with null record;
-- Date, Details, Put and Appointment inherited unchanged
-- from Appointment_Type
end JE.Appointments.Deadlines;
The view package will need modifying to provide a new concrete type with a suitable implementation of Put:
type Deadline_Type is new JE.Appointments.Deadlines.Deadline_Type with null record;
procedure Put (Appt : in Deadline_Type);
Put will also need to be defined in the package body. It might simply display the message ‘URGENT’ at the end; the rest of the appointment can be displayed by converting the urgent appointment to an ordinary appointment so that the Appointment_Type version of Put can be called, although it’s a bit fiddly since it involves converting to the abstract parent type Appointment_Type and then using an aggregate extension to convert this to the derived concrete Appointment_Type:
procedure Put (Appt : in Deadline_Type) is
begin
Put(Appointment_Type'(JE.Appointments.Appointment_Type(Appt) with null record));
Ada.Text_IO.Put (" (URGENT)");
end Put;
Note that even when a derived type adds no extra data components to its parent type, an extension aggregate must still be used to convert from the parent type to the derived type, but the extension to the parent type is specified as ‘with null record’. We need to use a qualified expression to tell the compiler which type we expect the extension aggregate to be, since there might be any number of derived types like Deadline_Type which have a null extension and an inherited version of Put, and it would otherwise be ambiguous.
Add_Appointment will need modifying to ask if the appointment is a deadline or not and to create and initialise deadlines when necessary:
procedure Add_Appointment (Diary : in out JE.Diaries.Diary_Type) is
... -- as before
begin
Put ("Appointment (A), meeting (M) or deadline (D)? ");
if Appt_Kind /= 'A' and Appt_Kind /= 'a' and
Appt_Kind /= 'M' and Appt_Kind /= 'm' and
Appt_Kind /= 'D' and Appt_Kind /= 'd' then
raise Data_Error;
end if;
... -- as before
if Appt_Kind = 'M' or Appt_Kind = 'm' then
... -- as before
elsif Appt_Kind = 'D' or Appt_Kind = 'd' then
declare
Appt : Deadline_Type;
begin
Appointment (JE.Times.Time(Year,Month,Day,Hour,Minute),
Details(1..Length), Appt);
JE.Diaries.Add (Diary, Appt);
end;
else
... -- as before
end if;
exception
when Data_Error | Constraint_Error | JE.Diaries.Diary_Error =>
Put_Line ("Invalid input.");
end Add_Appointment;
The diary package will not need changing; a Deadline_Type will be a member of Appointment_Type'Class so it will be able to be stored in the diary along with the other appointments. Calls to Put will be dispatched to the overridden version of Put defined for Deadline_Type, so no modifications will be needed to the operations in the diary package itself. The only changes will be the introduction of the new child package JE.Appointments.Deadlines and the modifications to the view package described above. None of the existing code in the other packages will need changing; these packages won’t even need to be recompiled. You’ll need to compile the new child package and the modified view package, recompile the main program (because JE.Views.Diary’s specification has been changed) and then test the changes that you’ve made. This is an enormous maintenance saving compared with any non-object-oriented solution.
| 15.1 | Write a program which allows you to create any of the bank accounts from exercise 14.3 and then lets you deposit and withdraw money and inspect the balance, regardless of which account type you created. |
| 15.2 | Modify the diary program to incorporate an appointment type which records the duration of an appointment in minutes, as in exercise 14.4. |
| 15.3 | Define a tagged type to represent the details of a publication (title, author and year of publication) which could be used to display an entry in a bibliography. Derive specialised publication types to represent journal articles (with journal name and volume and issue numbers), books (with publisher’s name) and articles in collections (with the details of the book containing the article: title, editor, publisher and so on). Write a program similar to the appointments diary example in this chapter which uses this to implement a bibliographic database. You should be able to add the details of a publication to the database, display the contents of the database in alphabetical order of author, delete publications, and save the database to a file. |
| 15.4 | A chessboard consists of an 8×8 grid of squares, each of which can be empty or can hold a piece. Each piece is coloured white or black. Different pieces can move in different ways: for example, a rook can move along either the row or the column it is on, whereas a bishop can move along either of the two diagonals through the square it is on. Rooks and bishops cannot move through other pieces; they must stop on the square before a piece of the same colour or on the same square as a piece of the opposite colour (in which case the opposing piece is captured and removed from the board). Define a tagged type to represent a chess piece with a primitive operation which takes a chessboard and a position on the board as its parameters and returns a linked list of board positions that the piece can move to, then derive types from this to represent rooks and bishops. Write a program which will read the positions of a set of rooks and bishops on a chessboard and generate a list of all legal moves for each piece. |
Previous |
Contents |
Next |
This file is part of
Ada 95: The Craft of Object-Oriented Programming
by John English.
Copyright © John
English 2000. All rights reserved.
Permission is given to redistribute this work for non-profit educational
use only, provided that all the constituent files are distributed without
change.