Chapter 8 Examples

-- ***************************************************************************
-- *                         Card_Pack.ads
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This is a specification for a package which can represent a
-- *    pack of cards. It demonstrates the use of the standard library random 
-- *    number generator.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

with Ada.Numerics.Discrete_Random;

package Card_Pack is

   type Suits is ( Diamonds, Clubs, Hearts, Spades );
   type Cards is new Positive range 1 .. 13;

   Jack  : constant Cards := 11;
   Queen : constant Cards := 12;
   King  : constant Cards := 13;

   type Pack is limited private;

   procedure Shuffle(The_Pack : in out Pack);

   procedure Draw(The_Pack : in out Pack;
                  The_Suit : out Suits;
                  The_Card : out Cards);

private
   type Index is new Positive range 1 .. 52;
   type Card_Array is array (Index) of Boolean;
   pragma Pack(Card_Array);

   package Random_Card is new Ada.Numerics.Discrete_Random(Index);

   type Pack is limited
      record
         All_Cards : Card_Array := (others => false);
         Gen       : Random_Card.Generator;
      end record;

end Card_Pack;

 

-- ***************************************************************************
-- *                         Card_Pack.abs
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This is the body for a package which can represent a
-- *    pack of cards. It demonstrates the use of the standard library random 
-- *    number generator.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

package body Card_Pack is

   procedure Shuffle(The_Pack : in out Pack) is
   begin
      The_Pack.All_Cards := (others => False);
      The_Pack.Drawn     := 0;
      Random_Card.Reset(The_Pack.Gen);
   end Shuffle;

   procedure Draw(The_Pack : in out Pack;
                  The_Suit :    out Suits;
                  The_Card :    out Cards) is
      The_Index : Index;
   begin
     if The_Pack.Drawn = 52 then
        raise Pack_Empty;
     end if;

     loop
	    The_Index := Random_Card.Random(The_Pack.Gen);

	    if The_Pack.All_Cards(The_Index) = False then

	       The_Pack.All_Cards(The_Index) := True;
	       The_Suit := Suits'Val(The_Index mod 13 + 1);
	       The_Card := Cards(The_Index / 13);

            The_Pack.Drawn := The_Pack.Drawn + 1;
            exit;
	    end if;
      end loop;
   end Draw;

end Card_Pack;

 

-- ***************************************************************************
-- *                         Direct_Test.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Simple test of the standard library direct IO package.
-- * Inputs:  None.
-- * Outputs: This file does NOT compile.
-- ***************************************************************************

with Ada.Direct_IO;

procedure Direct_Test is

   type File_Header is
      record
         Magic_Number     : Special_Stamp;
         Number_Of_Records: Record_Number;
         First_Deleted	   : Record_Number;
      end record;

   type Row is
      record
         Key  : String(1 .. 80);
         Data : String(1 .. 255);
      end record;

   package Header_IO is new Direct_IO (File_Header); 

   package Row_IO    is new Direct_IO (Row);    
   
begin
   null;
end Direct_Test;

 

-- ***************************************************************************
-- *                         Echo_Args.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This simple, though useful program simply writes the
-- *    arguments provided to it.
-- * Inputs:  None.
-- * Outputs: whatever else you put on the command line.
-- ***************************************************************************

with Ada.Text_IO;
with Ada.Command_Line;
 
procedure Echo_Args is
begin
   Ada.Text_IO.Put_Line("Program " & 
    		        Ada.Command_Line.Command_Name & 
		        " called with " &
			Natural'Image(Ada.Command_Line.Argument_Count) &
			" arguments:");

   for I in 1 .. Ada.Command_Line.Argument_Count loop

      Ada.Text_IO.Put_Line("    " & Ada.Command_Line.Argument(I));
   end loop;

   Ada.Command_Line.Set_Exit_Status(Ada.Command_Line.Success);
end Echo_Args;

 

-- ***************************************************************************
-- *                         Final.ads
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: How to specify a controlled type.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

with Ada.Finalization;

package Final is

   type Example is new Ada.Finalization.Controlled with 
      record
         Int_Data : Integer;
      end record;

private
   procedure Initialize (Object : in out Example);
   procedure Adjust     (Object : in out Example);
   procedure Finalize   (Object : in out Example);

end Final;

 

-- ***************************************************************************
-- *                         Final.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: How to specify a controlled type.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

with Ada.Text_IO;
use  Ada;

package body Final is

   procedure Initialize (Object : in out Example) is
   begin
      Text_IO.Put_Line("Initialize");
   end Initialize;

   procedure Adjust     (Object : in out Example) is
   begin
      Text_IO.Put_Line("Adjust");
   end Adjust;

   procedure Finalize   (Object : in out Example) is
   begin
      Text_IO.Put_Line("Finalize");
   end Finalize;

end Final;

 

-- ***************************************************************************
-- *                         Final_Test.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This uses the controlled type introduced in Final.ads and
-- *    demonstrates the use of the three subprograms defined.
-- * Inputs:  None.
-- * Outputs: See book text.
-- ***************************************************************************

with Final;

procedure Final_Test is

   type P_Example is access Final.Example;

   Ex_1 : Final.Example;
   Ex_2 : Final.Example;
   
   Ex_3 : P_Example;
begin 
   Ex_1 := Ex_2;

   Ex_3 := new Final.Example;

   Ex_3.all := Ex_2;

   declare 
      Ex_4 : Final.Example := Ex_2;
   begin
      Ex_4.Int_Data := 1;
   end ;
end Final_Test;

 

-- ***************************************************************************
-- *                         IO_Test1.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Simple test of the library text IO packages.
-- * Inputs:  None.
-- * Outputs: Some boring text messages.
-- ***************************************************************************

with Ada.Text_IO; 
use  Ada.Text_IO;

procedure IO_Test1 is

   package My_Integer_IO is new Integer_IO(Integer);
   use My_Integer_IO;

   package My_Float_IO is new Float_IO(Float);
   use My_Float_IO;
begin
   Put_Line("Test Starts Here >");
   Put("Integer is ");
   Put(2); 
   New_Line;
   Put("Float is   ");
   Put(2.0);
   New_Line;
   Put_Line("Test Ends Here");
end IO_Test1;

 

-- ***************************************************************************
-- *                         IO_Test2.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: Another test for the library text IO packages.
-- * Inputs:  None.
-- * Outputs: A simpler version of the previous IO tests using attributes.
-- ***************************************************************************

with Ada.Text_IO; 
use  Ada.Text_IO;

procedure IO_Test2 is
begin
   Put_Line("Test Starts Here >");
   Put_Line("Integer is " & Integer'Image(2));
   Put_Line("Float is   " & Float'Image(2.0));
   Put_Line("Test Ends Here");
end IO_Test2;

 

-- ***************************************************************************
-- *                         Network_IO.ads 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: A specification for a stream oriented network IO package.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

with Ada.Streams;

package Network_IO is

   type Stream_Access is access all
      Ada.Streams.Root_Stream_Type'Class;

   type Connection_Type is private;

   -- This will be extended in time to include
   -- other protocols as support becomes 
   -- available.
   type Connection_Protocol is ( Tcp, Udp );

   -- Create_Connection initialises a server port.
   -- A server port can only be created on this 
   -- host so no host parameter is required.
   function Create_Connection
     (Service	  : in String;
      Protocol	  : in Connection_Protocol;
      Max_Clients  : in Positive := 4)
      return Connection_Type;

   -- This call is used by a server after
   -- calling the Create_Connection above, it 
   -- waits for a connection and returns the client.
   function Wait_For_Client
     (Server_Connection : in Connection_Type)
      return Connection_Type;

   -- Connect_To initialises a client port, and 
   -- as such requires the host on which the server 
   -- port resides.
   function Connect_To
     (Service  : in String;
      Protocol : in Connection_Protocol;
      Host     : in String := "localhost")
      return Connection_Type;

   -- close a connection and all associated streams 
   -- completely.
   procedure Close  
     (Connection       : in out Connection_Type);

   -- This returns a stream type which can be used
   -- with the Read, Write, Input and Output
   -- attributes.
   function Stream(Connection : in Connection_Type) 
      return Stream_Access;

   -- exceptions.
   Connection_Creation_Error : exception;
   Connection_Invalid        : exception;
   Connection_Closed         : exception;
   Operating_System_Error    : exception;
   Parameter_In_Error        : exception;

private
   use  Ada.Streams;

   type Network_Stream_Type is new Root_Stream_Type with
      record
	    Connection : Connection_Type;
      end record;

   type Network_Stream_Access is access all Network_Stream_Type;

   type Connection_Type is new Integer;

   procedure Read
     (Stream : in out Network_Stream_Type;
      Item   : out    Stream_Element_Array;
      Last   : out    Stream_Element_Offset);

   procedure Write
     (Stream : in out Network_Stream_Type;
      Item   : in     Stream_Element_Array);

end Network_IO;

 

-- ***************************************************************************
-- *                         Network_IO.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: The body for the network IO package, incomplete.
-- * Inputs:  None.
-- * Outputs: this file does NOT compile.
-- ***************************************************************************

with Ada.Text_IO;
 
package body Network_IO is

   -- lots and lots missing !

   function Stream
     (Connection : in Connection_Type)
      return Stream_Access is

      The_Stream : Network_Stream_Access;
   begin
      The_Stream := new Network_Stream_Type;

      The_Stream.Connection := Connection;

      return Stream_Access(The_Stream);
   end Stream;

   procedure Read
     (Stream : in out Network_Stream_Type;
      Item   : out    Stream_Element_Array;
      Last   : out    Stream_Element_Offset) is
   begin
      Ada.Text_IO.Put_Line("Socket'Read ( 1 .. " &
			          Stream_Element_Offset'Image(Last) &
			          " )");
   end Read;

   procedure Write
     (Stream : in out Network_Stream_Type;
      Item   : in    Stream_Element_Array) is
   begin
      Ada.Text_IO.Put_Line("Socket'Write (" & 
			        Stream_Element_Offset'Image(Item'First) &
			        " .. " &
			        Stream_Element_Offset'Image(Item'Last) &
			        " ) :=");
      for I in Item'Range loop
	    Ada.Text_IO.Put(Stream_Element'Image(Item(I)));
      end loop;
      Ada.Text_IO.New_Line;
   end Write;

end Network_IO;

 

-- ***************************************************************************
-- *                         Pool_Test.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This tests the pool specified in Shared_Pool.ads. It also
-- *    demonstrates how to assign a type to a specific pool.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

with Shared_Pool;

procedure Pool_Test is

   Pool_Name       : aliased constant String := "stats";
   Statistics_Pool : Shared_Pool.Pool(1024, Pool_Name'Unchecked_Access);

    type App_Statistics is
      record
         Ex : Integer;
      end record;
    type App_Statistics_Ptr is access all App_Statistics;

   for App_Statistics_Ptr'Storage_Pool use Statistics_Pool;

   Shared_Statistics : App_Statistics_Ptr;
begin
   Shared_Statistics := new App_Statistics;
end Pool_Test;

 

-- ***************************************************************************
-- *                         Shared_Pool.ads 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: The specification for a package which implements a storage
-- *    pool. It is expected that pool specific objects are actually allocated
-- *    in some form of shared memory.
-- * Inputs:  None.
-- * Outputs: None.
-- ***************************************************************************

with System.Storage_Pools;
with System.Storage_Elements;
use  System;

package Shared_Pool is

   type Pool_Name is access constant String;

   type Pool(Size : Storage_Elements.Storage_Count;
             Name : Pool_Name) is
      new Storage_Pools.Root_Storage_Pool with private;

   procedure Allocate
     (The_Pool                : in out Pool;
      Storage_Address         : out Address;
      Size_In_Storage_Elements: in Storage_Elements.Storage_Count;
      Alignment               : in Storage_Elements.Storage_Count);

   procedure Deallocate
     (The_Pool                : in out Pool;
      Storage_Address         : in Address;
      Size_In_Storage_Elements: in Storage_Elements.Storage_Count;
      Alignment               : in Storage_Elements.Storage_Count);

   function Storage_Size
     (The_Pool : in Pool)
      return Storage_Elements.Storage_Count;

private

   procedure Initialize (Object : in out Pool);
   procedure Finalize   (Object : in out Pool);

   type Pool(Size : Storage_Elements.Storage_Count;
             Name : Pool_Name) is 
      new Storage_Pools.Root_Storage_Pool with 
      record
         Ex : Integer;
      end record;

end Shared_Pool;

 

-- ***************************************************************************
-- *                         String_Test.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This tests the standard library string functions for fixed
-- *    length strings (ie the builtin type String).
-- * Inputs:  None.
-- * Outputs: See book text.
-- ***************************************************************************

with Ada.Strings; use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Text_IO; use Ada.Text_IO;

procedure String_Test is

   String_1 : String := "Hello";
   String_2 : String(1 .. 20);
   String_3 : String := "1234567890ABCDEFGHIJ";
   Result   : Natural;
begin

   Move(Source => String_1, 
	Target => String_2, 
	Justify => Left);
   Put_Line(" 1: " & String_2 & ".");

   Move(Source => String_1, 
	Target => String_2, 
	Justify => Right);
   Put_Line(" 2: " & String_2 & ".");

   Move(Source => String_1, 
	Target => String_2, 
	Justify => Left,
	Pad => '*');
   Put_Line(" 3: " & String_2 & ".");

   Replace_Slice(Source => String_2, 
		 Low => String_1'First,
		 High => String_1'Last,
		 By => "HELLO");
   Put_Line(" 4: " & String_2 & ".");

   begin
      Insert(Source => String_2, 
	     Before => 3,
	     New_Item => "mum");
   exception
      when Length_Error =>
	 Put_Line(" 5: String is now too long!");
   end ;

   
   Delete(Source => String_2, 
	  From => String_1'Last,
	  Through => String_2'Last);
   Put_Line(" 6: " & String_2 & ".");

   New_Line;

   Put_Line(" 7: " & Head(Source => String_3, Count => 5) & ".");

   Put_Line(" 8: " & Tail(Source => String_3, Count => 5) & ".");

   Put_Line(" 9: " & (20 * '+') & ".");

   Put_Line("10: " & (5 * "Ada ") & ".");

   String_3(11 .. 20) := String_3(1 .. 10);
   New_Line;

   Result := Index(Source => String_3,
		   Pattern => "8");
   Put_Line("11: First '8' in String_3 is " & Natural'Image(Result));
				
   Result := Index(Source => String_3,
		   Pattern => "8",
		   Going=> Backward);
   Put_Line("12: Last '8' in String_3 is " & Natural'Image(Result));
				
   Result := Ada.Strings.Fixed.Count(Source => String_3,
				     Pattern => "8");
   Put_Line("13: Number of '8' in String_3 is " & Natural'Image(Result));
   -- full qualification due to a Count specified in
   -- the package Ada.Text_IO.
end String_Test;

 

-- ***************************************************************************
-- *                         Time_Test.adb 
-- * Copyright (c) Simon Johnston & Addison Wesley Longman 1996.
-- *
-- * Description: This example shows some simple use of the time facilities
-- *    provided by the package Ada.Calendar.
-- * Inputs:  None.
-- * Outputs: The date.
-- ***************************************************************************

with Ada.Calendar;
with Ada.Text_IO;
use  Ada;

procedure Time_Test is

   function Image(A_Time : Calendar.Time) return String is
      A_String : String(1 .. 80);
      Year     : Calendar.Year_Number;
      Month    : Calendar.Month_Number;
      Day      : Calendar.Day_Number;
      Seconds  : Calendar.Day_Duration;
   begin
      Calendar.Split(A_Time, Year, Month, Day, Seconds);

      declare
	 Year_String : String := Calendar.Year_Number'Image(Year);
	 Month_String : String := Calendar.Month_Number'Image(Month);
	 Day_String : String := Calendar.Day_Number'Image(Day);
	 Seconds_String : String := Calendar.Day_Duration'Image(Seconds);
      begin
	 declare
	    R_String : String := Year_String & Month_String;
	 begin
	    return R_String;
	 end ;
      end ;
   end Image;

begin
   Text_IO.Put_Line(Image(Calendar.Clock));
end Time_Test;

Contents Page

Copyright © 1996 Simon Johnston &
Addison Wesley Longman