Controlled Types
Overview
In this section, we introduce the concept of controlled types. We start with a review of lifetime of objects and discuss how controlled types allow us to control the initialization, post-copy (e.g. assignment) adjustment and finalization of objects.
Relevant topics
Lifetime of objects
We already talked about the lifetime of objects previously in the context of access types. Again, we assume you understand the concept. In any case, let's quickly review the typical lifetime of an object:
In simple terms, an object A is first created before we can make use of
it. When object A is about to get out of scope, it is finalized.
Note that finalization might not entail any actual code execution — but
it often does.
Let's analyze the lifetime of object A in a procedure P:
procedure P is
A : T;
begin
P2 (A);
end P;
We could visualize the lifetime as follows:
In other words, object A is created in the declarative part of P
and then it's used in P's sequence of statements. Finally, A is
finalized when P ends.
Initialization of objects
Typically, right after an object A is created, it is still uninitialized.
Therefore, we have to explicitly initialize it with a meaningful initial value
— or with the value returned by a function call, for example. Similarly,
when an object A is about to get out of scope, it is going to be
finalized (i.e. destroyed) and its contents are then lost forever.
As we know, for some standard Ada types, objects are initialized by default.
For example, objects of access types are initialized by default to null.
Likewise, we can declare
types with default initial value:
pragma Ada_2022;
with Ada.Text_IO; use Ada.Text_IO;
procedure Main is
type Int is new Integer
with Default_Value => 42;
I : Int;
AI : access Int;
begin
Put_Line ("I : "
& I'Image);
Put_Line ("AI : "
& AI'Image);
end Main;
In this case, we can visualize the lifetime of those objects as follows:
Even though these default initialization methods provide some control over the objects, they might not be enough in certain situations. Also, we don't have any means to perform useful operations right before an object gets out of scope.
For further reading...
In general, record types have a very good default initialization capability. They're the most common completion for private types, so the facility is often used. In this sense, default initialization is the first choice, as it's guaranteed and requires nothing of the client. In addition, it's cheap at run-time compared to controlled types.
Controlled objects
Controlled objects allow us to better control the initialization and
finalization of an object. For any controlled object A, an
Initialize (A) procedure is called right after the object is created,
and a Finalize (A) procedure is called right before the object is
actually finalized.
We can visualize the lifetime of controlled objects as follows:
In the context of a block statement, the lifetime becomes:
Let's look at a simple example:
with Ada.Finalization;
package Simple_Controlled_Types is
type T is tagged private;
procedure Dummy (E : T);
private
type T is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Initialize (E : in out T);
overriding
procedure Finalize (E : in out T);
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
package body Simple_Controlled_Types is
procedure Dummy (E : T) is
begin
Put_Line ("(Dummy...)");
end Dummy;
procedure Initialize (E : in out T) is
begin
Put_Line ("Initialize...");
end Initialize;
procedure Finalize (E : in out T) is
begin
Put_Line ("Finalize...");
end Finalize;
end Simple_Controlled_Types;
with Simple_Controlled_Types;
use Simple_Controlled_Types;
procedure Show_Controlled_Types is
A : T;
--
-- This declaration roughly
-- corresponds to:
--
-- A : T;
-- begin
-- Initialize (A);
--
begin
Dummy (A);
-- When A is about to get out of
-- scope:
--
-- Finalize (A);
--
end Show_Controlled_Types;
When we run this application, we see the user messages indicating the calls to
Initialize and Finalize.
For further reading...
Note that if a controlled object isn't used in the application, the compiler
might optimize it out. In this case, procedures Initialize and
Finalize won't be called for this object, as it doesn't actually
exist. You can see this effect by replacing the call to Dummy (A) in
the Show_Controlled_Types procedure by a null statement (null).
Adjustment of controlled objects
An assignment is a full bit-wise copy of the entire right-hand side to the
entire left-hand side. When copying controlled objects, however, we might
need to adjust the target object. This is made possible by overriding the
Adjust procedure, which is called
right after the copy to an object has been performed. (As we'll see later on,
limited controlled types
do not offer an Adjust procedure.)
The deep copy of objects is a typical
example where adjustments are necessary. When we assign an object B to
an object A, we're essentially doing a shallow copy. If we have
references to other objects in the source object B, those references
will be copied as well, so both target A and source B will be
referring to the same objects. When performing a deep copy, however, we want
the information from the dereferenced objects to be copied, not the references
themselves. Therefore, we have to first allocate new objects for the target
object A and copy the information from the original references —
the ones we copied from the source object B — to the new objects.
This kind of processing can be performed in the Adjust procedure.
As an example, let's extend the previous code example and override the
Adjust procedure:
with Ada.Finalization;
package Simple_Controlled_Types is
type T is tagged private;
procedure Dummy (E : T);
private
type T is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Initialize (E : in out T);
overriding
procedure Adjust (E : in out T);
overriding
procedure Finalize (E : in out T);
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
package body Simple_Controlled_Types is
procedure Dummy (E : T) is
begin
Put_Line ("(Dummy...)");
end Dummy;
procedure Initialize (E : in out T) is
begin
Put_Line ("Initialize...");
end Initialize;
procedure Adjust (E : in out T) is
begin
Put_Line ("Adjust...");
end Adjust;
procedure Finalize (E : in out T) is
begin
Put_Line ("Finalize...");
end Finalize;
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
with Simple_Controlled_Types;
use Simple_Controlled_Types;
procedure Show_Controlled_Types is
A, B : T;
begin
Put_Line ("A := B");
A := B;
Dummy (A);
Dummy (B);
end Show_Controlled_Types;
When running this application, we see that the Adjust procedure is called
for object A — right after B is copied to A as part
of the A := B assignment. We discuss more
about this procedure later on.
Limited controlled types
Ada offers controlled types in two flavors: nonlimited controlled types —
such as the ones we've seen so far — and limited controlled types. Both
types are declared in the Ada.Finalization package.
The only difference between these types is that limited controlled types don't
have an Adjust procedure that could be overridden, as limited types
do not permit direct copies of objects to be made via assignments.
(Obviously, both controlled and limited controlled types provide
Initialize and Finalize procedures.)
The following table summarizes the information:
Type |
Name |
Initialize |
Finalize |
Adjust |
|---|---|---|---|---|
Nonlimited Controlled |
|
Yes |
Yes |
Yes |
Limited controlled |
|
Yes |
Yes |
Not available |
Simple Example with ID
Although the previous code examples indicated that Initialize,
Finalize and Adjust are called as we expect for controlled
objects, they didn't show us exactly how those objects are actually handled. In
this section, we discuss this by analyzing a code example that assigns a unique
ID to each controlled object.
Let's start with the complete code example:
with Ada.Finalization;
package Simple_Controlled_Types is
type T is tagged private;
procedure Show (E : T;
Name : String);
private
protected Id_Gen is
procedure New_Id (Id_Out : out Positive);
private
Id : Natural := 0;
end Id_Gen;
type T is new
Ada.Finalization.Controlled with
record
Id : Positive;
end record;
overriding
procedure Initialize (E : in out T);
overriding
procedure Adjust (E : in out T);
overriding
procedure Finalize (E : in out T);
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
package body Simple_Controlled_Types is
protected body Id_Gen is
procedure New_Id (Id_Out : out Positive) is
begin
Id := Id + 1;
Id_Out := Id;
end New_Id;
end Id_Gen;
procedure Initialize (E : in out T) is
begin
Id_Gen.New_Id (E.Id);
Put_Line ("Initialize: ID => "
& E.Id'Image);
end Initialize;
procedure Adjust (E : in out T) is
Prev_Id : constant Positive := E.Id;
begin
Id_Gen.New_Id (E.Id);
Put_Line ("Adjust: ID => "
& E.Id'Image);
Put_Line (" (Previous ID => "
& Prev_Id'Image
& ")");
end Adjust;
procedure Finalize (E : in out T) is
begin
Put_Line ("Finalize: ID => "
& E.Id'Image);
end Finalize;
procedure Show (E : T;
Name : String) is
begin
Put_Line ("Obj. " & Name
& ": ID => "
& E.Id'Image);
end Show;
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
with Simple_Controlled_Types;
use Simple_Controlled_Types;
procedure Show_Controlled_Types is
A, B : T;
--
-- Declaration corresponds to:
--
-- declare
-- A, B : T;
-- begin
-- Initialize (A);
-- Initialize (B);
-- end;
begin
Put_Line ("--------");
Show (A, "A");
Show (B, "B");
Put_Line ("--------");
Put_Line ("A := B;");
A := B;
-- Statement corresponds to:
--
-- Finalize (A);
-- A := B;
-- Adjust (A);
Put_Line ("--------");
Show (A, "A");
Show (B, "B");
Put_Line ("--------");
-- When A and B get out of scope::
--
-- Finalize (A);
-- Finalize (B);
--
end Show_Controlled_Types;
In contrast to the previous versions of the Simple_Controlled_Types
package, type T now has an Id component. Moreover, we use a
protected object Id_Gen that provides us with a unique ID to keep track
of each controlled object. Basically, we assign an ID to each controlled object
(right after it is created) via the call to Initialize. Similarly, this
ID is updated via the calls to Adjust. Besides, we now have a Show
procedure that displays the ID of a controlled object.
When running the application, we see that the calls to Initialize,
Adjust and Finalize happen as expected. In addition, we see the
objects' ID, which we will now analyze in order to understand how each object is
actually handled.
First, we see the two calls to Initialize for objects A and
B. Object A's ID is 1, and object B's ID is 2. This is
later confirmed by the calls to Show.
The A := B assignment triggers two procedure calls: a call to
Finalize (A) and a call to Adjust (A). In fact, this assignment
can be described as follows:
Finalize (A)is called before the actual copy;B's data is copied to objectA;Adjust (A)is called after that copy.
We can confirm this via the object
ID: the object we handle in the call to Finalize (A) has an ID of 1, and
the object we handle in the call to Adjust (A) has an ID of 2 (which
originates from the copy of B to A) and is later changed
(adjusted) to 3. Again, we can verify the correct IDs by looking at the output
of the calls to Show.
Note that the call to Finalize (A) (before the copy of B's
data) indicates that the previous version of object A is being finalized,
i.e. it's as though the original object A is going to be destroyed and
its contents are going to be lost. Actually, the object's contents are just
overwritten, but the call to Finalize allows us to make proper
adjustments to the object before the previous information is lost.
Finally, the new version of object A (the one whose ID is 3) and object
B are finalized via the calls to Finalize (A) and
Finalize (B) before the Show_Controlled_Types procedure ends.
Initialization
In this section, we cover some details about the initialization of controlled
types. Most of those details are related to the initialization order. In
principle, as stated in the Ada Reference Manual, "Initialize and other
initialization operations are done in an arbitrary order," except in the
situations that we describe later on.
Relevant topics
Subcomponents
We've seen before that default initialization is a way of controlling the
initialization of arbitrary types. In the case of controlled types, the default
initialization of its subcomponents always takes places before the call to
Initialize.
Similarly, a controlled type might have subcomponents of controlled types.
These subcomponents are initialized by a call to the Initialize
procedure of each of those controlled types.
We can visualize the lifetime as follows:
In order to see this effect, let's start by implementing two controlled types:
Sub_1 and Sub_2:
with Ada.Finalization;
package Subs is
type Sub_1 is tagged private;
type Sub_2 is tagged private;
private
type Sub_1 is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Initialize (E : in out Sub_1);
type Sub_2 is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Initialize (E : in out Sub_2);
end Subs;
with Ada.Text_IO; use Ada.Text_IO;
package body Subs is
procedure Initialize (E : in out Sub_1) is
begin
Put_Line ("Initialize: Sub_1...");
end Initialize;
procedure Initialize (E : in out Sub_2) is
begin
Put_Line ("Initialize: Sub_2...");
end Initialize;
end Subs;
Now, let's use those controlled types as components of a type T. In
addition, let's declare an integer component I with default
initialization. This is how the complete code looks like:
with Ada.Finalization;
with Subs; use Subs;
package Simple_Controlled_Types is
type T is tagged private;
procedure Dummy (E : T);
private
function Default_Init return Integer;
type T is new
Ada.Finalization.Controlled with
record
S1 : Sub_1;
S2 : Sub_2;
I : Integer := Default_Init;
end record;
overriding
procedure Initialize (E : in out T);
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
package body Simple_Controlled_Types is
function Default_Init return Integer is
begin
Put_Line ("Default_Init: Integer...");
return 42;
end Default_Init;
procedure Dummy (E : T) is
begin
Put_Line ("(Dummy: T...)");
end Dummy;
procedure Initialize (E : in out T) is
begin
Put_Line ("Initialize: T...");
end Initialize;
end Simple_Controlled_Types;
with Simple_Controlled_Types;
use Simple_Controlled_Types;
procedure Show_Controlled_Types is
A : T;
begin
Dummy (A);
end Show_Controlled_Types;
When we run this application, we see that the Sub_1 and Sub_2
components are initialized by calls to their respective Initialize
procedures, and the I component is initialized with its default value
(via a call to the Default_Init function). Finally, after all
subcomponents of type T have been initialized, the Initialize
procedure is called for the type T itself.
This diagram shows the initialization sequence:
Components with access discriminants
Record types with access discriminants are a special case. In fact, according
to the Ada Reference Manual, "if an object has a component with an access
discriminant constrained by a
per-object expression,
Initialize is applied to this component after any components that do not
have such discriminants. For an object with several components with such a
discriminant, Initialize is applied to them in order of their component
declarations."
Let's see a code example. First, we implement another package with controlled types:
with Ada.Finalization;
package Selections is
type Selection is private;
type Selection_1 (S : access Selection) is
tagged private;
type Selection_2 (S : access Selection) is
tagged private;
private
type Selection is null record;
type Selection_1 (S : access Selection) is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Initialize
(E : in out Selection_1);
type Selection_2 (S : access Selection) is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Initialize
(E : in out Selection_2);
end Selections;
with Ada.Text_IO; use Ada.Text_IO;
package body Selections is
procedure Initialize
(E : in out Selection_1) is
begin
Put_Line ("Initialize: Selection_1...");
end Initialize;
procedure Initialize
(E : in out Selection_2) is
begin
Put_Line ("Initialize: Selection_2...");
end Initialize;
end Selections;
In this example, we see the declaration of the Selection_1 and
Selection_2 types, which are controlled types with an access
discriminant of Selection type. Now, let's use these types in the
declaration of the T type from the
previous example
and add two new components (Sel_1 and Sel_2):
with Ada.Finalization;
with Subs; use Subs;
with Selections; use Selections;
package Simple_Controlled_Types is
type T (S1 : access Selection;
S2 : access Selection) is
tagged private;
procedure Dummy (E : T);
private
function Default_Init return Integer;
type T (S1 : access Selection;
S2 : access Selection) is new
Ada.Finalization.Controlled with
record
Sel_1 : Selection_1 (S1);
Sel_2 : Selection_2 (S2);
S_1 : Sub_1;
I : Integer := Default_Init;
end record;
overriding
procedure Initialize (E : in out T);
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
package body Simple_Controlled_Types is
function Default_Init return Integer is
begin
Put_Line ("Default_Init: Integer...");
return 42;
end Default_Init;
procedure Dummy (E : T) is
begin
Put_Line ("(Dummy: T...)");
end Dummy;
procedure Initialize (E : in out T) is
begin
Put_Line ("Initialize: T...");
end Initialize;
end Simple_Controlled_Types;
with Simple_Controlled_Types;
use Simple_Controlled_Types;
with Selections;
use Selections;
procedure Show_Controlled_Types is
S1, S2 : aliased Selection;
A : T (S1'Access, S2'Access);
begin
Dummy (A);
end Show_Controlled_Types;
When running this example, we see that all other subcomponents — to be
more precise, those subcomponents that require initialization — are
initialized before the Sub_1 and Sub_2 components are initialized
via calls to their corresponding Initialize procedure. Note that,
although Sub_1 and Sub_2 are the last components to be
initialized, they are still initialized before the call to the
Initialize procedure of type T.
This diagram shows the initialization sequence:
Task activation
Components of task types also require special treatment. According to the Ada
Reference Manual, "for an allocator, any task activations follow all calls on
Initialize."
As always, let's analyze an example that illustrates this. First, we implement
another package called Workers with a simple task type:
package Workers is
task type Worker is
entry Start;
entry Stop;
end Worker;
end Workers;
with Ada.Text_IO; use Ada.Text_IO;
package body Workers is
task body Worker is
function Init return Integer is
begin
Put_Line ("Activating Worker task...");
return 0;
end Init;
I : Integer := Init;
begin
accept Start do
Put_Line ("Worker.Start accepted...");
I := I + 1;
end Start;
accept Stop do
Put_Line ("Worker.Stop accepted...");
I := I - 1;
end Stop;
end Worker;
end Workers;
Let's extend the declaration of the T type from the
previous example
and declare a new component of Worker type. Note that we have to change
T to a limited controlled type because of this new component of task
type. This is the updated code:
with Ada.Finalization;
with Subs; use Subs;
with Selections; use Selections;
with Workers; use Workers;
package Simple_Controlled_Types is
type T (S : access Selection) is
tagged limited private;
procedure Start_Work (E : T);
procedure Stop_Work (E : T);
private
function Default_Init return Integer;
type T (S : access Selection) is new
Ada.Finalization.Limited_Controlled with
record
W : Worker;
Sel_1 : Selection_1 (S);
S1 : Sub_1;
I : Integer := Default_Init;
end record;
overriding
procedure Initialize (E : in out T);
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
package body Simple_Controlled_Types is
function Default_Init return Integer is
begin
Put_Line ("Default_Init: Integer...");
return 42;
end Default_Init;
procedure Start_Work (E : T) is
begin
-- Starting Worker task:
E.W.Start;
end Start_Work;
procedure Stop_Work (E : T) is
begin
-- Stopping Worker task:
E.W.Stop;
end Stop_Work;
procedure Initialize (E : in out T) is
begin
Put_Line ("Initialize: T...");
end Initialize;
end Simple_Controlled_Types;
with Simple_Controlled_Types;
use Simple_Controlled_Types;
with Selections; use Selections;
procedure Show_Controlled_Types is
type T_Access is access T;
S : aliased Selection;
A : constant T_Access := new T (S'Access);
begin
Start_Work (A.all);
Stop_Work (A.all);
end Show_Controlled_Types;
When we run this application, we see that the W component is activated
only after all other subcomponents of type T have been initialized.
This diagram shows the initialization sequence:
Assignment
We already talked about
adjustments previously.
As we already mentioned, an actual assignment is a full bit-wise copy of the
entire right-hand side to the entire left-hand side, so the adjustment (via a
call to Adjust) is a way to "work around" that, when necessary. In this
section, we'll look into some details about the adjustment of controlled types.
Relevant topics
Assignment using anonymous object
The Ada Reference Manual mentions that an anonymous object is
created during the assignment of objects of controlled type. A simple
A := B operation for nonlimited controlled types can be expanded to the
following illustrative code:
procedure P is
A, B: Some_Controlled_Type;
begin
--
-- A := B;
--
B_To_A_Assignment : declare
Anon_Obj : Some_Controlled_Type;
begin
Anon_Obj := B;
Adjust (Anon_Obj);
Finalize (A);
A := Anon_Obj;
Finalize (Anon_Obj);
end B_To_A_Assignment;
end P;
The first assignment happens to the anonymous object Anon_Obj. After the
adjustment of Anon_Obj and the finalization of the original version of
A, the actual assignment to A can take place — and
Anon_Obj can be discarded after it has been properly finalized. With
this strategy, we have a chance to finalize the original version of A
before the assignment overwrites the object.
Of course, this expanded code isn't really efficient, and the compiler has some freedom to improve the performance of the generated machine code. Whenever possible, it'll typically optimize the anonymous object out and build the object in place. (The Ada Reference Manual describes the rules when this is possible or not.)
Also, the A := Anon_Obj statement in the code above doesn't necessarily
translate to an actual assignment in the generated machine code. Typically, a
compiler may treat Anon_Obj as the new A and destroy the original
version of A (i.e. the object that used to be A). In this case,
the code becomes something like this:
procedure P is
A, B: Some_Controlled_Type;
begin
--
-- A := B;
--
B_To_A_Assignment : declare
Anon_Obj : Some_Controlled_Type;
begin
Anon_Obj := B;
Finalize (A);
Adjust (Anon_Obj);
declare
A : Some_Controlled_Type renames Anon_Obj;
begin
-- Now, we treat Anon_Obj as the new A.
-- Further processing continues here...
end;
end B_To_A_Assignment;
end P;
In some cases, the compiler is required to build the object in place. A typical example is when an object of controlled type is initialized by assigning an aggregate to it:
C: constant Some_Controlled_Type :=
(Ada.Finalization.Controlled with ...);
-- C is built in place,
-- no anonymous object is used here.
Also, it's possible that Adjust and Finalize aren't called at
all. Consider an assignment like this: A := A;. In this case, since the
object on both sides is the same, the compiler is allowed to simply skip the
assignment and not do anything.
For more details about possible optimizations and compiler behavior, please refer to the Ada Reference Manual .
In general, the advice is simply: use Adjust and Finalize solely
for their intended purposes. In other words, don't implement extraneous
side-effects into those procedures, as they might not be called at run-time.
Adjustment of subcomponents
In principle, the order in which components are adjusted is arbitrary. However, adjustments of subcomponents will happen before the adjustment of the component itself. The subcomponents must be adjusted before the enclosing object because the semantics of the adjustment of the whole might depend on the states of the parts (the subcomponents), so those states must already be in place.
Let's revisit a
previous code example.
First, we override the Adjust procedure of the Sub_1 and
Sub_2 types from the Subs package.
with Ada.Finalization;
package Subs is
type Sub_1 is tagged private;
type Sub_2 is tagged private;
private
type Sub_1 is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Initialize (E : in out Sub_1);
overriding
procedure Adjust (E : in out Sub_1);
overriding
procedure Finalize (E : in out Sub_1);
type Sub_2 is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Initialize (E : in out Sub_2);
overriding
procedure Adjust (E : in out Sub_2);
overriding
procedure Finalize (E : in out Sub_2);
end Subs;
with Ada.Text_IO; use Ada.Text_IO;
package body Subs is
procedure Initialize (E : in out Sub_1) is
begin
Put_Line ("Initialize: Sub_1...");
end Initialize;
procedure Adjust (E : in out Sub_1) is
begin
Put_Line ("Adjust: Sub_1...");
end Adjust;
procedure Finalize (E : in out Sub_1) is
begin
Put_Line ("Finalize: Sub_1...");
end Finalize;
procedure Initialize (E : in out Sub_2) is
begin
Put_Line ("Initialize: Sub_2...");
end Initialize;
procedure Adjust (E : in out Sub_2) is
begin
Put_Line ("Adjust: Sub_2...");
end Adjust;
procedure Finalize (E : in out Sub_2) is
begin
Put_Line ("Finalize: Sub_2...");
end Finalize;
end Subs;
Next, we override the Adjust procedure of the T type from the
Simple_Controlled_Types package:
with Ada.Finalization;
with Subs; use Subs;
package Simple_Controlled_Types is
type T is tagged private;
procedure Dummy (E : T);
private
function Default_Init return Integer;
type T is new
Ada.Finalization.Controlled with
record
S1 : Sub_1;
S2 : Sub_2;
I : Integer := Default_Init;
end record;
overriding
procedure Initialize (E : in out T);
overriding
procedure Adjust (E : in out T);
overriding
procedure Finalize (E : in out T);
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
package body Simple_Controlled_Types is
function Default_Init return Integer is
begin
Put_Line ("Default_Init: Integer...");
return 42;
end Default_Init;
procedure Dummy (E : T) is
begin
Put_Line ("(Dummy: T...)");
end Dummy;
procedure Initialize (E : in out T) is
begin
Put_Line ("Initialize: T...");
end Initialize;
procedure Adjust (E : in out T) is
begin
Put_Line ("Adjust: T...");
end Adjust;
procedure Finalize (E : in out T) is
begin
Put_Line ("Finalize: T...");
end Finalize;
end Simple_Controlled_Types;
Finally, this is the main application:
with Ada.Text_IO; use Ada.Text_IO;
with Simple_Controlled_Types;
use Simple_Controlled_Types;
procedure Show_Controlled_Types is
A, B : T;
begin
Dummy (A);
Put_Line ("----------");
Put_Line ("A := B");
A := B;
Put_Line ("----------");
end Show_Controlled_Types;
When running this code, we see that the S1 and S2 components are
adjusted before the adjustment of the parent type T takes place.
This diagram shows the adjustment sequence:
Finalization
We mentioned finalization — and the Finalize procedure — at
the
beginning of the chapter.
In this section, we discuss the topic in more detail.
Relevant topics
Normal and abnormal completion
When a subprogram has just executed its last statement, normal completion of
this subprogram has been reached. At this point, finalization starts. In the
case of controlled objects, this means that the Finalize procedure is
called for those objects. (As we've already seen
an example of normal completion
at the beginning of the chapter, we won't repeat it here, as we assume you are
already familiar with the concept.)
When an exception is raised or due to an abort, however, a subprogram has an abnormal completion. We discuss more about exception handling and finalization later on.
Finalization via unchecked deallocation
When performing unchecked deallocation of a controlled type, the
Finalize procedure is called right before the actual memory for the
controlled object is deallocated.
Let's see a simple example:
with Ada.Finalization;
with Ada.Unchecked_Deallocation;
package Simple_Controlled_Types is
type T is tagged private;
procedure Dummy (E : T);
type T_Access is access T;
procedure Free (A : in out T_Access);
private
type T is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Finalize (E : in out T);
procedure Free_T_Access is
new Ada.Unchecked_Deallocation
(Object => T,
Name => T_Access);
procedure Free (A : in out T_Access)
renames Free_T_Access;
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
package body Simple_Controlled_Types is
procedure Dummy (E : T) is
begin
Put_Line ("(Dummy T...)");
end Dummy;
procedure Finalize (E : in out T) is
begin
Put_Line ("Finalize T...");
end Finalize;
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
with Simple_Controlled_Types;
use Simple_Controlled_Types;
procedure Show_Controlled_Types is
A : T_Access := new T;
begin
Dummy (A.all);
Free (A);
-- At this point, Finalize (A.all)
-- will be called before the actual
-- deallocation.
Put_Line ("We've just freed A.");
end Show_Controlled_Types;
In this example, we see that a call to Finalize (for type T) is
triggered by the call to Free for the A object — at this
point, we haven't reached the end of the main procedure
(Show_Controlled_Types) yet. After the call to Free, the object
originally referenced by A has been completely finalized — and
deallocated.
When the main procedure completes (after the call to Put_Line in that
procedure), we would normally see the calls to Finalize for controlled
objects. However, at this point, we obviously don't have a second call to the
Finalize procedure for type T, as the object referenced by
A has already been finalized and freed.
Subcomponents
As we've seen in the section about
initialization of subcomponents,
subcomponents of a controlled type are initialized by a call to their
corresponding Initialize procedure before the call to Initialize
for the parent controlled type. In the case of finalization, the reverse order
is applied: first, finalization of the parent type takes place, and then the
finalization of the subcomponents.
We can visualize the lifetime as follows:
Let's show a code example by revisiting the previous implementation of the
controlled types Sub_1 and Sub_2, and adapting it:
with Ada.Finalization;
package Subs is
type Sub_1 is tagged private;
type Sub_2 is tagged private;
private
type Sub_1 is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Finalize (E : in out Sub_1);
type Sub_2 is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Finalize (E : in out Sub_2);
end Subs;
with Ada.Text_IO; use Ada.Text_IO;
package body Subs is
procedure Finalize (E : in out Sub_1) is
begin
Put_Line ("Finalize: Sub_1...");
end Finalize;
procedure Finalize (E : in out Sub_2) is
begin
Put_Line ("Finalize: Sub_2...");
end Finalize;
end Subs;
Now, let's use those controlled types as components of a type T:
with Ada.Finalization;
with Subs; use Subs;
package Simple_Controlled_Types is
type T is tagged private;
procedure Dummy (E : T);
private
type T is new
Ada.Finalization.Controlled with
record
S1 : Sub_1;
S2 : Sub_2;
end record;
overriding
procedure Finalize (E : in out T);
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
package body Simple_Controlled_Types is
procedure Dummy (E : T) is
begin
Put_Line ("(Dummy: T...)");
end Dummy;
procedure Finalize (E : in out T) is
begin
Put_Line ("Finalize: T...");
end Finalize;
end Simple_Controlled_Types;
with Simple_Controlled_Types;
use Simple_Controlled_Types;
procedure Show_Controlled_Types is
A : T;
begin
Dummy (A);
end Show_Controlled_Types;
When we run this application, we see that the Finalize procedure is
called for the type T itself — as the first step of the
finalization of type T. Then, the Sub_2 and Sub_1
components are finalized by calls to their respective Finalize
procedures.
This diagram shows the finalization sequence:
Components with access discriminants
We already discussed the initialization of components with access discriminants constrained by a per-object expression. In the case of the finalization of such components, they are finalized before any components that do not fall into this category — in the reverse order of their component declarations — but after the finalization of the parent type.
Let's revisit a previous code example and adapt it to demonstrate the finalization of components with access discriminants. First, we implement another package with controlled types:
with Ada.Finalization;
package Selections is
type Selection is private;
type Selection_1 (S : access Selection) is
tagged private;
type Selection_2 (S : access Selection) is
tagged private;
private
type Selection is null record;
type Selection_1 (S : access Selection) is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Finalize
(E : in out Selection_1);
type Selection_2 (S : access Selection) is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Finalize
(E : in out Selection_2);
end Selections;
with Ada.Text_IO; use Ada.Text_IO;
package body Selections is
procedure Finalize
(E : in out Selection_1) is
begin
Put_Line ("Finalize: Selection_1...");
end Finalize;
procedure Finalize
(E : in out Selection_2) is
begin
Put_Line ("Finalize: Selection_2...");
end Finalize;
end Selections;
In this example, we see the declaration of the Selection_1 and
Selection_2 types, which are controlled types with an access
discriminant of Selection type. Now, let's use these types in the
declaration of a type T and add two new components — Sel_1
and Sel_2:
with Ada.Finalization;
with Subs; use Subs;
with Selections; use Selections;
package Simple_Controlled_Types is
type T (S1 : access Selection;
S2 : access Selection) is
tagged private;
procedure Dummy (E : T);
private
type T (S1 : access Selection;
S2 : access Selection) is new
Ada.Finalization.Controlled with
record
Sel_1 : Selection_1 (S1);
Sel_2 : Selection_2 (S2);
S_1 : Sub_1;
end record;
overriding
procedure Finalize (E : in out T);
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
package body Simple_Controlled_Types is
procedure Dummy (E : T) is
begin
Put_Line ("(Dummy: T...)");
end Dummy;
procedure Finalize (E : in out T) is
begin
Put_Line ("Finalize: T...");
end Finalize;
end Simple_Controlled_Types;
with Simple_Controlled_Types;
use Simple_Controlled_Types;
with Selections;
use Selections;
procedure Show_Controlled_Types is
S1, S2 : aliased Selection;
A : T (S1'Access, S2'Access);
begin
Dummy (A);
end Show_Controlled_Types;
When we run this example, we see that the Finalize procedure of type
T is called as the first step. Then, the Finalize procedure is
called for the components with an access discriminant constrained by a
per-object expression — in this
case, Sel_2 and Sel_1 (of Selection_2 and
Selection_1 types, respectively). Finally, the Sub_1 component
is finalized.
This diagram shows the finalization sequence:
Controlled Types and Exception Handling
In the previous section, we mainly focused on the normal completion of controlled types. However, when control is transferred out of the normal execution path due to an abort or an exception being raised, we speak of abnormal completion. In this section, we focus on those cases.
Let's start with a simple example:
with Ada.Finalization;
package Simple_Controlled_Types is
type T is tagged private;
procedure Dummy (E : T);
private
type T is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Initialize (E : in out T);
overriding
procedure Finalize (E : in out T);
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
package body Simple_Controlled_Types is
procedure Dummy (E : T) is
begin
Put_Line ("(Dummy...)");
end Dummy;
procedure Initialize (E : in out T) is
begin
Put_Line ("Initialize...");
end Initialize;
procedure Finalize (E : in out T) is
begin
Put_Line ("Finalize...");
end Finalize;
end Simple_Controlled_Types;
with Ada.Text_IO; use Ada.Text_IO;
with Simple_Controlled_Types;
use Simple_Controlled_Types;
procedure Show_Simple_Exception is
A : T;
function Int_Last return Integer is
(Integer'Last);
Cnt : Positive := Int_Last;
begin
Cnt := Cnt + 1;
Dummy (A);
Put_Line (Cnt'Image);
-- When A is about to get out of
-- scope:
--
-- Finalize (A);
--
end Show_Simple_Exception;
In this example, we're forcing an overflow to happen in the
Show_Simple_Exception by adding one to the integer variable Cnt,
which already has the value Integer'Last. The corresponding
overflow check raises the
Constraint_Error.
However, before this exception is raised, the finalization of the controlled
object A is performed. In this sense, we have normal completion of the
controlled type — even though an exception is being raised.
For further reading...
We already talked about the
allocation check, which may raise a
Program_Error exception. In the code example for that section, we
used controlled types. Feel free to revisit the example.
Relevant topics
Exception raising in Initialize
If an exception is raised in the Initialize procedure, we have abnormal
completion. Let's see an example:
with Ada.Finalization;
package CT_Initialize_Exception is
type T is tagged private;
procedure Dummy (E : T);
private
type T is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Initialize (E : in out T);
overriding
procedure Finalize (E : in out T);
end CT_Initialize_Exception;
with Ada.Text_IO; use Ada.Text_IO;
package body CT_Initialize_Exception is
function Int_Last return Integer is
(Integer'Last);
Cnt : Positive := Int_Last;
procedure Dummy (E : T) is
begin
Put_Line ("(Dummy...)");
end Dummy;
procedure Initialize (E : in out T) is
begin
Put_Line ("Initialize...");
Cnt := Cnt + 1;
end Initialize;
procedure Finalize (E : in out T) is
begin
Put_Line ("Finalize...");
end Finalize;
end CT_Initialize_Exception;
with CT_Initialize_Exception;
use CT_Initialize_Exception;
procedure Show_Initialize_Exception is
A : T;
begin
Dummy (A);
end Show_Initialize_Exception;
In the Show_Initialize_Exception procedure, we declare an object
A of controlled type T. As we know, this declaration triggers a
call to the Initialize procedure that we've implemented in the body of
the CT_Initialize_Exception package. In the Initialize procedure,
we're forcing an overflow to happen — by adding one to the Cnt
variable, which already has the Integer'Last value.
This is an example of abnormal completion, as the control is transferred out of
the Initialize procedure, and the corresponding Finalize
procedure is never called for object A.
Bounded errors of controlled types
Bounded errors are an important topic when talking about exception and
controlled types. In general, if an exception is raised in the Adjust or
Finalize procedure, this is considered a bounded error. If the bounded
error is detected, the Program_Error exception is raised.
Note that the original exception raised in the Adjust or Finalize
procedures could be any possible exception. For example, one of those
procedures could raise a Constraint_Error exception. However, the actual
exception that is raised at runtime is the Program_Error exception. This
is because the bounded error, which raises the Program_Error exception,
is more severe than the original exception coming from those procedures.
(The behavior is different when the Adjust or Finalize procedure
is called explicitly, as we'll see later.)
Not every exception raised during an operation on controlled types is considered a bounded error. In fact, the case we've seen before, an exception raised in the Initialize procedure is not a bounded error.
Here's a code example of a Constraint_Error exception being raised in
the Finalize procedure:
with Ada.Finalization;
package CT_Finalize_Exception is
type T is tagged private;
procedure Dummy (E : T);
procedure Reset_Counter;
private
type T is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Initialize (E : in out T);
overriding
procedure Adjust (E : in out T);
overriding
procedure Finalize (E : in out T);
end CT_Finalize_Exception;
with Ada.Text_IO; use Ada.Text_IO;
package body CT_Finalize_Exception is
Cnt : Integer := Integer'Last;
procedure Dummy (E : T) is
begin
Put_Line ("(Dummy...)");
end Dummy;
procedure Initialize (E : in out T) is
begin
Put_Line ("Initialize...");
end Initialize;
overriding
procedure Adjust (E : in out T) is
begin
Put_Line ("Adjust...");
end Adjust;
procedure Finalize (E : in out T) is
begin
Put_Line ("Finalize...");
Cnt := Cnt + 1;
end Finalize;
procedure Reset_Counter is
begin
Cnt := 0;
end Reset_Counter;
end CT_Finalize_Exception;
with Ada.Text_IO; use Ada.Text_IO;
with CT_Finalize_Exception;
use CT_Finalize_Exception;
procedure Show_Finalize_Exception is
A, B : T;
begin
Dummy (A);
-- When A is about to get out of
-- scope:
--
-- Finalize (A);
--
end Show_Finalize_Exception;
In this example, we're again forcing an overflow to happen (by adding one to
the integer variable Cnt), this time in the Finalize procedure.
When this procedure is implicitly called — when object A is about
to get out of scope in the Show_Finalize_Exception procedure —
the Constraint_Error exception is raised.
As we've just seen, having an exception be raised during an implicit call to
the Finalize procedure is a bounded error. Therefore, we see that the
Program_Error exception is raised at runtime instead of the original
Constraint_Error exception.
As we hinted in the beginning, when the Adjust or the Finalize
procedure is called explicitly, the exception raised in that procedure is
not considered a bounded error. In this case, the original exception is
raised.
To show an example of such an explicit call, let's first move the overriden
procedures for type T (Initialize, Adjust and
Finalize) out of the private part of the package
CT_Finalize_Exception, so they are now visible to clients. This allows
us to call the Finalize procedure explicitly:
with Ada.Finalization;
package CT_Finalize_Exception is
type T is new
Ada.Finalization.Controlled
with null record;
overriding
procedure Initialize (E : in out T);
overriding
procedure Adjust (E : in out T);
overriding
procedure Finalize (E : in out T);
procedure Dummy (E : T);
procedure Reset_Counter;
end CT_Finalize_Exception;
with Ada.Text_IO; use Ada.Text_IO;
with CT_Finalize_Exception;
use CT_Finalize_Exception;
procedure Show_Finalize_Exception is
A : T;
begin
Dummy (A);
Finalize (A);
Put_Line ("After Finalize");
exception
when Constraint_Error =>
Put_Line
("Constraint_Error is being handled...");
Reset_Counter;
end Show_Finalize_Exception;
Now, we're calling the Finalize procedure explicitly in the
Show_Finalize_Exception procedure. As we know, due to the operation on
I in the Finalize procedure, the Constraint_Error
exception is raised in the procedure. Because we're handling this exception in
the Show_Finalize_Exception procedure, we see the corresponding user
message ("Constraint_Error is being handled...") at runtime.
(Note that in the exception handling block, we're calling the
Reset_Counter procedure. This prevents Constraint_Error from
being raised in the next call to Finalize.)
Memory allocation and exceptions
When a memory block is allocated for controlled types and a bounded error
occurs, there is no guarantee that this memory block will be deallocated.
Roughly speaking, the compiler has the freedom — but not the obligation
— to generate appropriate calls to Finalize, which may deallocate
memory blocks.
For example, we've seen that
subcomponents of controlled type
of a controlled object A are initialized before the initialization of
object A takes place. Because memory might have been allocated for the
subcomponents, the compiler can insert code that attempts to finalize those
subcomponents, which in turn deallocates the memory blocks (if they were
allocated in the first place).
We can visualize this strategy in the following diagram:
This strategy (of finalizing subcomponents that haven't raised exceptions) prevents memory leaks. However, this behavior very much depends on the compiler implementation. The Ada Reference Manual delineates (in the "Implementation Permissions" section) the cases where the compiler is allowed — but not required — to finalize objects when exceptions are raised.
Because the actual behavior isn't defined, custom implementation of
Adjust and Finalize procedures for controlled types should be
designed very carefully in order to avoid exceptions, especially when memory
is allocated in the Initialize procedure.
Applications of Controlled Types
In this section, we discuss applications of controlled types. In this context, it's important to remember that controlled types have an associated overhead, which can become non-negligible depending in which context the controlled objects are used. However, there are applications where utilizing controlled types is the best approach.
(Note that this overhead we've just mentioned is not specific to Ada. In fact, types similar to controlled types will be relatively expensive in any programming language. As an example, destructors in C++ may require a similar maintenance of state at run-time.)
Encapsulating access type handling
Previously, when discussing design strategies for access types, we saw an example on using limited controlled types to encapsulate access types.
A more generalized example is the one of an unbounded stack. Because it's unbounded, it allows for increasing the stack's size on demand. We can implement this kind of stack by using access types. Let's look at a simple (unoptimized) implementation:
with Ada.Finalization;
generic
Default_Chunk_Size : Positive := 5;
type Element is private;
package Unbounded_Stacks is
Stack_Underflow : exception;
type Unbounded_Stack is private;
procedure Push (S : in out Unbounded_Stack;
E : Element);
function Pop (S : in out Unbounded_Stack)
return Element;
function Is_Empty (S : Unbounded_Stack)
return Boolean;
private
type Element_Array is
array (Positive range <>) of
Element;
type Element_Array_Access is
access Element_Array;
type Unbounded_Stack is new
Ada.Finalization.Controlled with
record
Chunk_Size : Positive
:= Default_Chunk_Size;
Data : Element_Array_Access;
Top : Natural := 0;
end record;
procedure Initialize
(S : in out Unbounded_Stack);
procedure Adjust
(S : in out Unbounded_Stack);
procedure Finalize
(S : in out Unbounded_Stack);
end Unbounded_Stacks;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocation;
package body Unbounded_Stacks is
--
-- LOCAL SUBPROGRAMS
--
procedure Free is
new Ada.Unchecked_Deallocation
(Object => Element_Array,
Name => Element_Array_Access);
function Is_Full (S : Unbounded_Stack)
return Boolean is
begin
return S.Top = S.Data'Last;
end Is_Full;
procedure Reallocate_Data
(To : in out Element_Array_Access;
From : Element_Array_Access;
Max_Last : Positive;
Valid_Last : Positive) is
begin
To := new Element_Array (1 .. Max_Last);
for I in 1 .. Valid_Last loop
To (I) := From (I);
end loop;
end Reallocate_Data;
procedure Increase_Size
(S : in out Unbounded_Stack)
is
Old_Data : Element_Array_Access := S.Data;
Old_Last : constant Positive
:= Old_Data'Last;
New_Last : constant Positive
:= Old_Data'Last + S.Chunk_Size;
begin
Put_Line ("Increasing Unbounded_Stack "
& "(1 .. "
& Old_Last'Image
& ") to (1 .. "
& New_Last'Image
& ")");
Reallocate_Data
(To => S.Data,
From => Old_Data,
Max_Last => New_Last,
Valid_Last => S.Top);
Free (Old_Data);
end Increase_Size;
--
-- SUBPROGRAMS
--
procedure Push (S : in out Unbounded_Stack;
E : Element) is
begin
if Is_Full (S) then
Increase_Size (S);
end if;
S.Top := S.Top + 1;
S.Data (S.Top) := E;
end Push;
function Pop (S : in out Unbounded_Stack)
return Element is
begin
return E : Element do
if Is_Empty (S) then
raise Stack_Underflow;
end if;
E := S.Data (S.Top);
S.Top := S.Top - 1;
end return;
end Pop;
function Is_Empty (S : Unbounded_Stack)
return Boolean is
begin
return S.Top = 0;
end Is_Empty;
--
-- PRIVATE SUBPROGRAMS
--
procedure Initialize
(S : in out Unbounded_Stack)
is
Last : constant Positive
:= S.Chunk_Size;
begin
Put_Line ("Initializing Unbounded_Stack "
& "(1 .. "
& Last'Image
& ")");
S.Data := new Element_Array
(1 .. S.Chunk_Size);
end Initialize;
procedure Allocate_Duplicate_Data
(S : in out Unbounded_Stack)
is
Last : constant Positive
:= S.Data'Last;
begin
Put_Line ("Duplicating data for new "
& "Unbounded_Stack (1 .. "
& Last'Image
& ")");
Reallocate_Data
(To => S.Data,
From => S.Data,
Max_Last => Last,
Valid_Last => S.Top);
end Allocate_Duplicate_Data;
procedure Adjust
(S : in out Unbounded_Stack)
is
begin
Put_Line ("Adjusting Unbounded_Stack...");
Allocate_Duplicate_Data (S);
end Adjust;
procedure Finalize
(S : in out Unbounded_Stack)
is
Last : constant Positive
:= S.Data'Last;
begin
Put_Line ("Finalizing Unbounded_Stack "
& "(1 .. "
& Last'Image
& ")");
if S.Data /= null then
Free (S.Data);
end if;
end Finalize;
end Unbounded_Stacks;
with Ada.Text_IO; use Ada.Text_IO;
with Unbounded_Stacks;
procedure Show_Unbounded_Stack is
package Unbounded_Integer_Stacks is new
Unbounded_Stacks (Element => Integer);
use Unbounded_Integer_Stacks;
procedure Print_Pop_Stack
(S : in out Unbounded_Stack;
Name : String)
is
V : Integer;
begin
Put_Line ("STACK: " & Name);
Put ("= ");
while not Is_Empty (S) loop
V := Pop (S);
Put (V'Image & " ");
end loop;
New_Line;
end Print_Pop_Stack;
Stack : Unbounded_Stack;
Stack_2 : Unbounded_Stack;
begin
for I in 1 .. 10 loop
Push (Stack, I);
end loop;
Stack_2 := Stack;
for I in 11 .. 20 loop
Push (Stack, I);
end loop;
Print_Pop_Stack (Stack, "Stack");
Print_Pop_Stack (Stack_2, "Stack_2");
end Show_Unbounded_Stack;
Let's first focus on the Unbounded_Stack type from the
Unbounded_Stacks package. The actual stack is implemented via the array
that we allocate for the Data component. The initial allocation takes
place in the Initialize procedure, which is called when an object of
Unbounded_Stack type is created. The corresponding deallocation of the
stack happens in the Finalize procedure.
In the Push procedure, we check whether the stack is full or not before
storing a new element into the stack. If the stack is full, we call the
Increase_Size procedure to increase the size of the array. This is
actually done by calling the Reallocate_Data procedure, which allocates
a new array for the stack and copies the original data to the new array.
Also, when copying an unbounded stack object to another object of this type, a
call to the Adjust procedure is triggered — we do this by the
assignment Stack_2 := Stack in the Show_Unbounded_Stack
procedure. In the Adjust procedure, we call the
Allocate_Duplicate_Data procedure to allocate a new array for the stack
data and copy the data from the original stack. (Internally, the
Allocate_Duplicate_Data procedure calls the Reallocate_Data
procedure, which we already mentioned.)
By encapsulating the access type handling in controlled types, we can ensure that the access objects are handled correctly: no incorrect pointer usage or memory leak can happen when we use this strategy.
Encapsulating file handling
Controlled types can be used to encapsulate file handling, so that files are automatically created and closed. A common use-case is when a new file is expected to be created or opened when we declare the controlled object, and closed when the controlled object gets out of scope.
A simple example is the one of a logger, which we can use to write to a
logfile by simple calls to Put_Line:
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Finalization;
package Loggers is
type Logger (<>) is
limited private;
function Init (Filename : String)
return Logger;
procedure Put_Line (L : Logger;
S : String);
private
type Logger is new
Ada.Finalization.Limited_Controlled with
record
Logfile : File_Type;
end record;
procedure Finalize
(L : in out Logger);
end Loggers;
package body Loggers is
--
-- SUBPROGRAMS
--
function Init (Filename : String)
return Logger is
begin
return L : Logger do
Create (L.Logfile, Out_File, Filename);
end return;
end Init;
procedure Put_Line (L : Logger;
S : String) is
begin
Put_Line ("Logger: Put_Line");
Put_Line (L.Logfile, S);
end Put_Line;
--
-- PRIVATE SUBPROGRAMS
--
procedure Finalize
(L : in out Logger) is
begin
Put_Line ("Finalizing Logger...");
if Is_Open (L.Logfile) then
Close (L.Logfile);
end if;
end Finalize;
end Loggers;
with Loggers; use Loggers;
procedure Some_Processing (Log : Logger) is
begin
Put_Line (Log, "Some processing...");
end Some_Processing;
with Loggers; use Loggers;
with Some_Processing;
procedure Show_Logger is
Log : constant Logger := Init ("report.log");
begin
Put_Line (Log, "Some info...");
Some_Processing (Log);
end Show_Logger;
The Logger type from the Loggers package has two subprograms:
Init, which creates a logger object and creates a logfile in the background, andPut_Line, which writes a message to the logfile.
Note that we use the (<>) in the declaration of the Logger type
to ensure that clients call the Init function. This allows us to specify
the location of the logfile (as the Filename parameter).
Also, we can pass the logger to other subprograms and use it there. In this
example, we pass the logger to the Some_Processing procedure and there,
we the call Put_Line using the logger object.
Finally, as soon as the logger goes out of scope, the log is automatically
closed via the call to Finalize.
For further reading...
Instead of enforcing a call to Init, we could have overridden the
Initialize procedure and opened the logfile there. This approach,
however, would have prevented the client from specifying the location of
the logfile in a simple way. Specifying the filename as a type discriminant
wouldn't work because we cannot use a string as a discriminant — as
we mentioned
in a previous chapter,
we cannot use indefinite subtypes as discriminants.
If we had preferred this approach, we could generate a random name for the
file in the Initialize procedure and store the file itself in a
temporary directory indicated by the operating system. Alternatively, we
could use the access to a string as a discriminant:
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Finalization;
package Loggers is
type Logger (Filename : access String) is
limited private;
procedure Put_Line (L : Logger;
S : String);
private
type Logger (Filename : access String) is new
Ada.Finalization.Limited_Controlled with
record
Logfile : File_Type;
end record;
procedure Initialize
(L : in out Logger);
procedure Finalize
(L : in out Logger);
end Loggers;
package body Loggers is
--
-- SUBPROGRAMS
--
procedure Put_Line (L : Logger;
S : String) is
begin
Put_Line ("Logger: Put_Line");
Put_Line (L.Logfile, S);
end Put_Line;
--
-- PRIVATE SUBPROGRAMS
--
procedure Initialize
(L : in out Logger) is
begin
Create (L.Logfile,
Out_File,
L.Filename.all);
end Initialize;
procedure Finalize
(L : in out Logger) is
begin
Put_Line ("Finalizing Logger...");
if Is_Open (L.Logfile) then
Close (L.Logfile);
end if;
end Finalize;
end Loggers;
with Loggers; use Loggers;
with Some_Processing;
procedure Show_Logger is
Name : aliased String := "report.log";
Log : Logger (Name'Access);
begin
Put_Line (Log, "Some info...");
Some_Processing (Log);
end Show_Logger;
This approach works, but requires us to declare an aliased string
(Name), which we can give access to in the declaration of the
Log object.
By encapsulating the file handling in controlled types, we ensure that files are properly opened when we want to use them, and that the files are closed when they're not going to be used anymore.