Chapter 3 Examples

 

-- ***************************************************************************
-- *                         Access_Tests.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Examples of pool-specific access types using the linked list
-- *    example (3.2) from the text.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
procedure Access_Tests1 is
   type Element_Type is new Integer;
   type Element_Holder;
   type List_Ptr is access Element_Holder;
   type Element_Holder is
      record
         Actual : Element_Type;
         Next   : List_Ptr := null;
      end record;
   type List is
      record
         Head : List_Ptr := null;
         Tail : List_Ptr := null;
      end record;
   Actual_1 : Element_Type := 1;
   Actual_2 : Element_Type := 3;
   Actual_3 : Element_Type := 5;
   Temp_Ptr : List_Ptr;
   My_List  : List;
begin
   Temp_Ptr := new Element_Holder'(Actual => Actual_1, Next => null);
   My_List.Tail := Temp_Ptr;
   My_List.Head := My_List.Tail;
   Temp_Ptr := new Element_Holder'(Actual => Actual_2, Next => null);
   My_List.Tail.Next := Temp_Ptr;
   My_List.Tail := My_List.Tail.Next;
   Temp_Ptr := new Element_Holder'(Actual => Actual_3, Next => null);
   My_List.Tail.Next := Temp_Ptr;
   My_List.Tail := My_List.Tail.Next;
end Access_Tests1;

 

-- ***************************************************************************
-- *                         Access_Tests2.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Examples of Ada95 general access types.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
procedure Access_Tests2 is
   type Integer_Ptr       is access all      Integer;
   type Const_Integer_Ptr is access constant Integer;
   Ptr_1 : Integer_Ptr;
   Const_Ptr_1 : Const_Integer_Ptr;
   Variable_1 : Integer;
   Constant_1 : constant Integer := 1;
   Variable_2 : aliased Integer;
   Constant_2 : aliased constant Integer := 1;
begin
   Ptr_1 := Variable_1'Access;       -- illegal
   Const_Ptr_1 := Constant_1'Access; -- illegal
   Ptr_1       := Variable_2'Access; -- legal
   Const_Ptr_1 := Constant_2'Access; -- legal
   Ptr_1       := Constant_2'Access; -- illegal
   Const_Ptr_1 := Variable_2'Access; -- legal
end Access_Tests2;

 

-- ***************************************************************************
-- *                         Access_Tests3.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Examples of Ada95 general access types and access levels. The
-- *    examples are designed not to compile, they follow the order of section
-- *    3.5.2.1.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
procedure Access_Tests3 is
begin
   First_Test:
      declare
         type Data_Ptr is access all Integer;
         procedure Test1(Data : Data_Ptr) is
         begin
            null;
         end Test1;
         procedure Test2 is
            Data : aliased Integer;
         begin
            Test1(Data'Access); -- illegal
            -- Test1(Data'Unchecked_Access); -- would be legal
         end Test2;
      begin
         Test2;
      end First_Test;
   Second_Test:
      declare
         type Data_Ptr is access all Integer;
         function Get_Data return Data_Ptr is
            Data : aliased Integer;
         begin
            return Data'Access; -- illegal
         end Get_Data;
      begin
         null;
      end Second_Test;
   Third_Test:
      declare
         type Data_Ptr is access all Integer;
         procedure Test1(Data : Data_Ptr) is
         begin
            null;
         end Test1;
         Data : aliased Integer;
         procedure Test2 is
         begin
            Test1(Data'Access); -- now legal
         end Test2;
      begin
         Test2;
      end Third_Test;
   Fourth_Test:
      declare
         type Data_Ptr is access all Integer;
         procedure Test0(Data : Data_Ptr) is
         begin
            null;
         end Test0;
         procedure Test1(Data : access Integer) is
         begin
            Test0(Data_Ptr(Data));
         end Test1;
         procedure Test2 is
            Data : aliased Integer;
         begin
            Test1(Data'Access);
         end Test2;
      begin
         Test2;
      end Fourth_Test;
end Access_Tests3;

 

-- ***************************************************************************
-- *                         Access_Tests4.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This example shows the use of access discriminants and takes
-- *    examples from section 3.5.2.3.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
procedure Access_Tests4 is
   type Element_Type is new Integer;
   type Element_Holder;
   type List_Ptr is access Element_Holder;
   type Element_Holder(Actual : access Element_Type) is limited
      record
         Next : List_Ptr := null;
      end record;
   type List is
      record
         Head : List_Ptr := null;
         Tail : List_Ptr := null;
      end record;
   A_Value : aliased Element_Type;
   List_Node : Element_Holder(A_Value'Access);
begin
   null;
end Access_Tests4;

 

-- ***************************************************************************
-- *                         Access_Tests5.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This example shows how Ada95 subprogram access types can be
-- *    used to implement callback functions.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
procedure Access_Tests5 is
   type Device_ID is new Integer;
   -- lots of things missing.
   type Read_Callback is access procedure 
     (Device   : in  Device_ID;
      Read_ID  : in  Integer);
   procedure Async_Read
     (Device   : in  Device_ID; 
      Callback : in  Read_Callback;
      Read_ID  : out Integer);
   procedure Async_Read
     (Device   : in  Device_ID;
      Callback : in  Read_Callback;
      Read_ID  : out Integer) is
   begin
      -- do something ...
      Callback.all(Device, Read_ID);
   end Async_Read;
   -- ************************************************************************
   procedure My_Callback(Device : in Device_ID; Read_ID : Integer) is
   begin
      null;
   end My_Callback;
   Device  : Device_ID;
   Read_ID : Integer;
begin
   Async_Read(Device, My_Callback'Access, Read_ID);
end Access_Tests5;

 

-- ***************************************************************************
-- *                             Angles.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This shows the use of fixed point types.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
procedure Angles is
   type CoOrdinate_Base is digits 3;
   subtype CoOrdinate is Float range 0.0 .. 360.0;
begin
   null;
end Angles;

 

-- ***************************************************************************
-- *                        Array_Tests.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Some very simple examples of arrays, single and mutliple
-- *    dimensions.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
procedure Array_Tests is
   Name  : array (0 .. 30) of Character;
   Track : array (0 .. 2) of Integer;
   DblA  : array (0 .. 2, 0 .. 9) of Integer;
   Init  : array (0 .. 2) of Integer := (0, 1, 2);
   type Name_Type is array (Integer range 0 .. 30) of Character;
   Another_Name : Name_Type;
   type DblA_1 is array (0 .. 2, 0 .. 9) of Integer;
   type DblA_2 is array (0 .. 9) of Integer;
   type DblA_3 is array (0 .. 2) of DblA_2;
   Array_1 : DblA_1;
   Array_2 : DblA_3;
begin
   Array_1(1, 1) := 0;
   Array_2(1)(1) := 0;
end Array_Tests;

 

-- ***************************************************************************
-- *                         Date_Time.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This example builds upon the smaller examples in section
-- *    3.3.1 on discrete types. It also demonstrates some uses of scalar
-- *    attributes,
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
procedure Date_Time is
   type All_Years is new Integer;
   subtype Before_Christ is All_Years range All_Years'First .. 0;
   subtype Ano_Domini is All_Years range 0 .. All_Years'First;
   type All_Months is (January, February, March,
		       April, May, June,
		       July, August, September,
		       October, November, December);
   type Days_In_Month is new Integer range 1 .. 31;
   for Days_In_Month'Size use 8;
   type All_Days is (Monday, Tuesday, Wednesday,
		     Thursday, Friday, Saturday,
		     Sunday);
   subtype Week_Days is All_Days range Monday .. Friday;
   subtype Week_Ends is All_Days range Saturday .. Sunday;
   type A_Complete_Date is 
      record
	 Year  : All_Years  := 0;
	 Month : All_Months := January;
	 Day   : Days_In_Month;
      end record;
   Today : A_Complete_Date := (1970, April, 16);
   A_Day : All_Days := Wednesday;
   Yesterday, Tomorrow : All_Days;
begin
   if A_Day in Week_Days then
      null; -- go to work.
   else
      null; -- something else instead.
   end if;
   if A_Day = Monday then
      Yesterday := Sunday;
   else
      Yesterday := All_Days'Pred(A_Day);
   end if;
   if A_Day = Sunday then
      Tomorrow := Monday;
   else
      Tomorrow := All_Days'Succ(A_Day);
   end if;
   declare
      Days_Name : String := All_Days'Image(A_Day);
   begin
      null;
   end ;
end Date_Time;

 

-- ***************************************************************************
-- *                         Enum_Tests.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This file contains examples on declaring and using some
-- *    enumeration types.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
with Ada.Text_IO;
procedure Enum_Tests is
   type Day is (Monday,   Tuesday, Wednesday, Thursday, Friday,
                Saturday, Sunday);
   subtype Week_Day is Day range Monday .. Friday;
   subtype Weekend  is Day range Saturday .. Sunday;
   Today     : Day     := Tuesday;
   Day_Off   : Integer := Sunday;  -- type mismatch error.
   Tomorrow  : Day     := 2;       -- type mismatch error.
   Day_Off2  : Integer := Day'Pos(Sunday);
   Tomorrow2 : Day     := Day'Val(2);
   Day_Off   : Day     := Day'Val(20);  -- raise Constraint_Error.
begin
   if Today in Week_Day then
      Ada.Text_IO.Put_Line("Go to work");
   else
      Ada.Text_IO.Put_Line("Stay in bed");
   end if;
end Enum_Tests;

 

-- ***************************************************************************
-- *                       Primitive_Ops.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This example shows the inheritance of primitive operations
-- *    with "normal" types.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
with Ada.Text_IO; use Ada.Text_IO;
procedure Primitive_Ops is
   function "+"(L, R : Integer) return Integer;
   function "+"(L, R : Integer) return Integer is
   begin
      Put_Line("Overridden addition operator");
      return 0;
   end "+";
   type Transaction_ID is new Integer;
   A, B, C : Transaction_ID;
begin
   A := 1 + 1;
   A := B + 1;
   A := B + C;
end Primitive_Ops;

 

-- ***************************************************************************
-- *                        Print_Array.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Examples based around the example 3.1 in the text, printing
-- *    the contents of arrays.
-- * Inputs:  None.
-- * Outputs: Prints the contents of a simple array.
-- ***************************************************************************
with Ada.Text_IO; use Ada.Text_IO;
procedure Print_Array is
   type Vector is array (Integer range <>) of Float;
   subtype Small_Vector is Vector(0 .. 2);
   procedure Print_Vector(Print_This : in Vector);
   procedure Print_Vector(Print_This : in Vector) is
   begin
      for Item in Print_This'Range loop
         Put("Item ");
         Put(Integer'Image(Item));
         Put(" = ");
         Put(Float'Image(Print_This(Item)));
         New_Line;
      end loop;
   end Print_Vector;
   Results : Small_Vector;
begin
   Print_Vector(Results);
end Print_Array;

 

-- ***************************************************************************
-- *                          Real_Types.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Although simple, this example demonstrates the declaration
-- *    of some real types for mathematical applications.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
procedure Real_Types is
   type Floating_Point_Type is digits 10;
   A : Floating_Point_Type := 1.0;
   A_Digits : Integer := Floating_Point_Type'Digits;
   type Fixed_Point_Type is delta 0.1 range 0.0 .. 100.0;
   B : Fixed_Point_Type := 1.0;
   B_Delta : Float   := Fixed_Point_Type'Delta;
   B_Fore  : Integer := Fixed_Point_Type'Fore;
   B_Aft   : Integer := Fixed_Point_Type'Aft;
   type Decimal_Type is delta 0.01 digits 10;
   C : Decimal_Type := 1.0;
   C_Delta : Float   := Decimal_Type'Delta;
   C_Fore  : Integer := Decimal_Type'Fore;
   C_Aft   : Integer := Decimal_Type'Aft;
   C_Scale : Integer := Decimal_Type'Scale;
begin
   null;
end Real_Types;

 

-- ***************************************************************************
-- *                         Record_Tests.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This shows some simple record types, starting with a record
-- *    containing simple types, then some compound types. It also shows use
-- *    of discriminants to declare enclosed types and to declare variant
-- *    records.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
procedure Record_Tests is
begin
   pragma Page;
   Simple_Records:
      declare
         type Device is
            record
               Major_Number : Integer;
               Minor_Number : Integer;
               Name         : String(1 .. 20);
            end record;
         Device_1 : Device;
         Device_2 : Device := (1, 1, "lp1                 ");
         type Initialized_Device is
            record
               Major_Number : Integer         := 0;
               Minor_Number : Integer         := 0;
               Name         : String(1 .. 21) := (others => Character'Val(0));
            end record;
      begin
   
         Device_1 := Device_2;
      end Simple_Records;
   pragma Page;
   Nested_Records:
      declare
         type Device is
            record
               Major_Number : Integer;
               Minor_Number : Integer;
               Name         : String(1 .. 20);
            end record;
         type Device_Command is (Open, Close, Flush_Input, Flush_Output, Test);
         type Device_Command_Packet is
            record
               To_Device    : Device;
               The_Command  : Device_Command := Test;
            end record;
         Printer : Device := (1, 1, "lp1                 ");
         Printer_Flush_Command : Device_Command_Packet;
      begin
         Printer_Flush_Command := (To_Device   => Printer, 
                                   The_Command => Flush_Output);
      end Nested_Records;
   pragma Page;
   Discriminant_Records:
      declare
         type Event_Item is
            record
               Event_ID     : Integer;
               Event_Info   : String(1 .. 80);
            end record;
         type Event_Array is array (Positive range <>) of Event_Item;
         type Cyclic_Event_Log(Max_Size : Positive) is
            record
               First_Event  : Positive := 1;
               Events       : Event_Array(1 .. Max_Size);
            end record;
         My_Event_Log : Cyclic_Event_Log(Max_Size => 100);
      begin
         null;
      end Discriminant_Records;
   pragma Page;
   Variant_Records:
      declare
         type Payment_Type is (Cash, Cheque, Credit);
         type Payment(The_Type : Payment_Type) is
            record
               Transaction_ID  : Integer;
               Amount          : Float;
               case The_Type is
               when Cash =>
                  null;
               when Cheque =>
                  Cheque_Number      : Integer;
                  Cheque_Card_Number : String(1 .. 16);
               when Credit =>
                  Credit_Card_Number : String(1 .. 16);
                  Expiry_Date        : Integer;
               end case;
            end record;
         Sale_1 : Payment(Cash);
         subtype Cash_Payment is Payment(Cash);
         subtype Cheque_Payment is Payment(Cheque);
         subtype Credit_Payment is Payment(Cheque);
         Sale_2 : Cheque_Payment;
 
      begin
         Sale_1.Transaction_ID := 1;
         Sale_1.Amount := 15.99;
         Sale_1.Cheque_Number := 1; -- FAILS !!!
         if Sale_2.The_Type = Cheque then
            Sale_2.Cheque_Number := 1; -- OK
         end if;
      end Variant_Records;
end Record_Tests;

 

-- ***************************************************************************
-- *                       Simple_Tests.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This simple example shows how to declare object, constants
-- *    and new types.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
procedure Simple_Tests is
begin
   Simple_Objects:
      declare
	 Test_1 : Integer;
	 Test_2 : Integer := 1;
	 Test_3 : Integer := Test_2'Size;
	 Test_4 : Integer := Integer'Max(Test_2, Test_3);
      begin
	 null;
      end Simple_Objects;
   Constant_Objects:
      declare
	 Test_1 : constant := 1;
	 Test_2 : constant Integer := 1;
	 Test_3 : constant Integer := Test_2'Size;
	 Test_4 : constant Integer := Integer'Max(Test_2, Test_3);
      begin
	 null;
      end Constant_Objects;
   Declaring_Types:
      declare
	 type Transaction_Id is new Integer;
	 Current_Transaction : Transaction_Id;
      begin
	 null;
      end Declaring_Types;
end Simple_Tests;

 

-- ***************************************************************************
-- *                        String_Tests.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Some simple tests of the Ada fixed string type.
-- * Inputs:  .
-- * Outputs: None - This test will fail to compile.
-- ***************************************************************************
procedure String_Tests is
   Legal     : String(1 .. 30);
   Illegal   : String;
   Name_1    : String := "Simon";
   Name_2    : String := ('J', 'o', 'h', 'n', 's', 't', 'o', 'n');
  
   Full_Name : String := Name_1 & " " & Name_2;
 
   Blank     : String(1 .. 30) := (others => ' ');
begin
   Legal := Blank;
   Legal(1 .. 5) := Name_1;
   Legal(Name_1'First .. Name_1'Last) := Name_1;
end String_Tests;

 

-- ***************************************************************************
-- *                      System_Representation.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This example comprises examples of system representation
-- *    attributes and contains code from section 3.7.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
with System;
with System.Storage_Elements;
procedure System_Representation is
   -- * Size representation.
   type BYTE is mod 256;
   for  BYTE'Size use 8;
   -- * Some useful system values.
   BYTE_Size         : constant Integer := BYTE'Size;
   Word_Size         : constant Integer := System.Word_Size;
   Storage_Unit_Size : constant Integer := System.Storage_Unit;
   -- * Specifying enumeration values.
   type Activity is  (Reading, Writing, Idle);
   Read_Active_Bit  : constant BYTE := 2#0000_0001#;
   Write_Active_Bit : constant BYTE := 2#0000_0010#;
   Idle_Bit         : constant BYTE := 2#0000_0100#;
   for  Activity use (Reading => Read_Active_Bit, 
                      Writing => Write_Active_Bit, 
                      Idle    => Idle_Bit);
   -- * Specifying storage locations.
   Status_Address : constant System.Address :=
      System.Storage_Elements.To_Address(16#0340#);
   Device_Status : Activity;
   for Device_Status'Address use Status_Address;
   -- * Specifying record layouts.
   type Bit_Flag is mod 2**1;
   type Device_Status_Word is
      record
         Status : Activity;
         Unused : Integer range 0 .. 7;
         Parity : Bit_Flag;
      end record;
   for  Device_Status_Word use
      record
         Status at 0 range 0 .. 3;
         Unused at 0 range 4 .. 6;
         Parity at 0 range 7 .. 7;
      end record;
   -- * Packed boolean arrays.
   type Error_Locus_Word is array(Natural range 0 .. Word_Size) of Boolean;
   pragma Pack(Error_Locus_Word);
   Error_Register : Error_Locus_Word := (others => false);
begin
   null;
end System_Representation;

 

-- ***************************************************************************
-- *                       Type_Subtype.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This simple example shows the difference between types and
-- *    subtypes.
-- * Inputs:  None.
-- * Outputs: None - this example fails to compile.
-- ***************************************************************************
procedure Type_Subtype is
   type Transaction_ID_1 is new Integer;
   subtype Transaction_ID_2 is Integer;
   An_Integer         : Integer := 0;
   First_Transaction  : Transaction_ID_1;
   Second_Transaction : Transaction_ID_2;
begin
   First_Transaction := An_Integer; -- illegal
   Second_Transaction := An_Integer;
   An_Integer := First_Transaction; -- illegal
   An_Integer := Second_Transaction;
   An_Integer := Integer(First_Transaction);
   An_Integer := Integer(Second_Transaction);
end Type_Subtype;

 

-- ***************************************************************************
-- *                         Variant_Tests.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This file contains three simple blocks demonstrating the
-- *    declaration and use of variant types.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************
with Ada.Text_IO;
use  Ada.Text_IO;
procedure Variant_Tests is
   type Transaction_ID is new Integer;
   type Currency       is delta 0.01 digits 10;
   type Card_ID        is new Integer;
   type Date           is new Positive;
   type Payment_Type is (Cash, Cheque, Credit);
   type Transaction(The_Type : Payment_Type) is
      record
         Transaction       : Transaction_ID;
         Amount            : Currency;
         case The_Type is
         when Cash =>
            null;
         when Cheque =>
            Cheque_Number      : Integer;
            Cheque_Card_Number : Card_ID; 
         when Credit =>
            Credit_Card_Number : Card_ID; 
            Expiry             : Date;
         end case;
      end record;
   subtype Cash_Transaction   is Transaction(Cash);
   subtype Cheque_Transaction is Transaction(The_Type => Cheque);
   subtype Credit_Transaction is Transaction(The_Type => Credit);
begin
   First_Test:
      declare
         A_Trans : Transaction(Cash);
      begin
         A_Trans.The_Type      := Cheque; -- illegal
         A_Trans.Transaction   := 0000;
         A_Trans.Amount        := 10.99;
         A_Trans.Cheque_Number := 10099;
      end First_Test;
   Second_Test:
      declare
         A_Trans : Transaction(Cash);
      begin
         case A_Trans.The_Type is
            when Cash =>
               Put_Line("Cash");
            when Cheque =>
               Put_Line("Cheque");
            when Credit =>
               Put_Line("Credit Card");
         end case;
      end Second_Test;
   Third_Test:
      declare
         A_Trans : Transaction(Cash);
      begin
         A_Trans := (The_Type      => Cheque,
                     Transaction   => 0000,
                     Amount        => 10.99,
                     Cheque_Number => 10099,
                     Cheque_Card_Number => 0);
         -- illegal
      end Third_Test;
end Variant_Tests;

Contents Page

Copyright © 1996 Simon Johnston &
Addison Wesley Longman