-- *************************************************************************** -- * 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;
Copyright ©
1996 Simon Johnston &
Addison Wesley Longman