Controlled Type Example

A controlled type is a special kind of tagged type that gives the programmer extra control over what happens at certain times -- such as when an object of the type is created, or when the object is about to go out of existence. A controlled type is created by deriving it from one of two predefined types exported by the package Ada.Finalization. For example, one can write:

My_Type_1 inherits three operations called Initialize, Adjust and Finalize. My_Type_2 inherits two operations called Initialize and Finalize. Initialize is automatically called when a controlled object is created. Adjust is automatically called as the last step of an assignment to a controlled object. Finalize is automatically called when a controlled object is about to go out of existence. The default (inherited) versions of these procedures do nothing, but the programmer can override any of them to perform some desired action. (A common motivation for the use of Finalize is to prevent "memory leak" in real-time systems. This involves the use of a predefined procedure called Ada.Unchecked_Deallocation. We will not illustrate such techniques in this introductory volume.)

Careful study of the code and sample output given below reveals the following order of events. Bomber 1 and Bomber 2 are created and initialized first, but finalized last (in reverse order), because they are associated with the global access-to-bomber type and don't go out of existence until the outer procedure is ready to quit. Bomber 3 is created and finalized before Bomber 4 is created and finalized. These two are associated with the local access-to-bomber type and each ceases to exist at the end of each call to the inner procedure.

-------------------------------------------------------------------
------  Bombers  --------------------------------------------------
-------------------------------------------------------------------
--  This package exports a controlled type, Bomber, that has two 
--  visible operations and two private operations. Initialize and 
--  Finalize (the private operations) are used to keep track of how 
--  many bombers have been created so far and how many are still 
--  "in play". Initialize also assigns a number to each bomber. 
-------------------------------------------------------------------
with Ada.Finalization;
package Bombers is  
  type Lat_Type is range -90..90;           
  type Lon_Type is range -180..180;
  type Hdg_Type is mod 360;
  type Alt_Type is range 0..100000;   
  type Bomber is new Ada.Finalization.Controlled with private;
    
  procedure Reset_State(B   : in out Bomber; -- primitive operation 
                        Lat : in Lat_Type;
                        Lon : in Lon_Type;
                        Hdg : in Hdg_Type;
                        Alt : in Alt_Type);
  procedure Deploy_Weapon(B  : in Bomber);   -- primitive operation
private  
  type Bomber is new Ada.Finalization.Controlled with 
    record
      Number    : Natural  := 0;
      Latitude  : Lat_Type := 0;
      Longitude : Lon_Type := 0;
      Heading   : Hdg_Type := 0;
      Altitude  : Alt_Type := 30000;
    end record; 
    procedure Initialize(B : in out Bomber);  -- override operation
    procedure Finalize  (B : in out Bomber);  -- override operation
end Bombers;
-------------------------------------------------------------------
with Ada.Text_IO; use Ada.Text_IO;
package body Bombers is
  Next_Number     : Natural := 0;        -- increment in Initialize
  Number_In_Play  : Natural := 0;        -- increment in Initialize,
                                           --  decrement in Finalize
  --------------------------------------------  
  procedure Reset_State(B   : in out Bomber; 
                        Lat : in Lat_Type;
                        Lon : in Lon_Type;
                        Hdg : in Hdg_Type;
                        Alt : in Alt_Type) is
  begin                     
    B.Latitude  := Lat;
    B.Longitude := Lon;
    B.Heading   := Hdg;
    B.Altitude  := Alt;  
  end Reset_State;      
  ------------------------------------------
  procedure Deploy_Weapon(B  : in Bomber) is
  begin
    Put_line("Bomber " & Integer'Image(B.Number) &
             " releases bomb at" & 
             " Lat = " & Integer'Image(Integer(B.Latitude)) &
             ", Lon = " & Integer'Image(Integer(B.Longitude)) &
             ", Hdg = " & Integer'Image(Integer(B.Heading)) &
             ", Alt = " & Integer'Image(Integer(B.Altitude)));    
  end Deploy_Weapon;
  --------------------------------------------------
  procedure Initialize(B : in out Bomber) is
  begin
    Next_Number    := Next_Number + 1;
    Number_In_Play := Number_In_Play + 1;
    B.Number       := Next_Number;
    Put_Line("Bomber " & Integer'Image(B.Number) &
             " initialized");    
  end Initialize;    
  --------------------------------------------------
  procedure Finalize(B : in out Bomber) is
  begin
    Number_In_Play := Number_In_Play - 1;   
    Put_Line("Bomber " & Integer'Image(B.Number) &
             " finalized" & ", Number_In_Play = " &
             Integer'Image(Number_In_Play));       
  end Finalize;
end Bombers;
-------------------------------------------------------------------
-------- Test_Controlled ------------------------------------------
-------------------------------------------------------------------
--  This procedure tests the controlled type, Bomber, using two 
--  loops. One uses a local access type and the other uses a global 
--  access type. 
-------------------------------------------------------------------
with Bombers, Ada.Text_IO, Ada.Integer_Text_IO; 
use  Bombers, Ada.Text_IO, Ada.Integer_Text_IO;
procedure Test_Controlled is  
  Ch    : Character; Data  : Integer;
  B_Lat : Lat_Type;  B_Lon : Lon_Type; 
  B_Hdg : Hdg_Type;  B_Alt : Alt_Type;
  type Bptr1_Type is access all Bomber;      -- global access type
  Bptr1 : array (1..20) of Bptr1_Type;
  ---------------------------------------
  procedure Bomb_With_Local_Objects is
    type Bptr2_Type is access all Bomber;    -- local access type
    Bptr2 : Bptr2_Type;  
  begin
    Bptr2 := new Bomber;                     -- auto initialization
    Reset_State(Bptr2.all, B_Lat, B_Lon, B_Hdg, B_Alt);
    Deploy_Weapon(Bptr2.all); 
  end Bomb_With_Local_Objects;               -- auto finalization
  ---------------------------------------
begin
  Put("Enter bombing latitude (-90..90) > ");
  Get(Data); B_Lat := Lat_Type(Data);  
  Put("Enter bombing longitude (-90..90) > ");
  Get(Data); B_Lon := Lon_Type(Data);
  Put("Enter bombing heading (0..359) > ");
  Get(Data); B_Hdg := Hdg_Type(Data);
  Put("Enter bombing altitude (5000..40000) > ");
  Get(Data); B_Alt := Alt_Type(Data); 
  New_Line;
  
  for I in 1..2 loop                         -- first bombing loop
    Bptr1(I) := new Bomber;                  -- auto initialization
    Reset_State(Bptr1(I).all, B_Lat, B_Lon, B_Hdg, B_Alt);
    Deploy_Weapon(Bptr1(I).all); 
  end loop;                                  -- no finalization
  
  Put("Enter bombing heading (0..359) > ");
  Get(Data); B_Hdg := Hdg_Type(Data);
  
  loop                                       -- second bombing loop
    Put("Enter b or q (Bomb or Quit) > ");
    Get(Ch);
    exit when Ch = 'q';
    if Ch = 'b' then
      Bomb_With_Local_Objects;
    else
      Put_Line("Invalid input");
    end if;
  end loop;                      
end Test_Controlled;      -- finalization for bombers in first loop
-------------------------------------------------------------------

5.7 Controlled Type Example