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