ADA 95教程 高级特性 更多的例子程序
随机数
Example program ------> e_c33_p1.ada
-- Chapter 33 - Program 1
-- This is a generic package to generate random numbers in the
-- range of 0.00000 to just less than 1.00000 with as many
-- significant digits as the type FLOAT_ITEM. This package uses
-- the Linear Congruential Method of random number generation as
-- discussed in "The Art of Computer Programming" volume 2 by
-- Donald Knuth. The method used follows;
--
-- X(n + 1) = (A * X(n) + C) mod M
--
-- X(n + 1) is the new random number
-- X(n) is the previous random number or the seed
-- M is 1.0 for the floating point system
-- A is 7.0 for the floating point system
-- C is 13.0 / 31.0 for the floating point system
-- X(0) is zero by default
-- X(0) is the number provided if forced with Force_Seed
-- X(0) is generated as follows when Set_Seed is called;
-- 1. The real time clock is read from the system
-- 2. The hours and minutes are stripped off
-- 3. The resulting number of seconds are divided by
-- 60.0 to get the fraction of a minute that has
-- elapsed since midnight
generic
type FLOAT_ITEM is digits <>;
package Random is
-- This procedure uses the system clock to set the seed.
procedure Set_Seed;
-- This procedure sets the seed to the input value.
procedure Force_Seed(Start_Seed : FLOAT_ITEM);
-- This Function returns the current seed which is also
-- the value of the previous random number returned.
function Get_Seed return FLOAT_ITEM;
-- This function returns a random number from 0.0 to 1.0
function Random_Number return FLOAT_ITEM;
end Random;
with Ada.Text_IO, Calendar;
use Ada.Text_IO, Calendar;
package body Random is
X_initial : FLOAT_ITEM := 0.0;
M : FLOAT_ITEM := 1.0;
A : FLOAT_ITEM := 7.0;
C : FLOAT_ITEM := 13.0 / 31.0;
procedure Set_Seed is
Time_And_Date : TIME;
All_Day : DAY_DURATION;
Minutes : FLOAT_ITEM;
Int_Minutes : INTEGER;
Part_Of_A_Minute : FLOAT_ITEM;
begin
Time_And_Date := Clock; -- Get the time and date
All_Day := Seconds(Time_And_Date); -- Seconds since midnight
Minutes := FLOAT_ITEM(All_Day) / 60.0; -- Floating type Minutes
Int_Minutes := INTEGER(Minutes - 0.5); -- Integer type minutes
Part_Of_A_Minute := FLOAT_ITEM(All_Day)
- 60.0 * FLOAT_ITEM(Int_Minutes);
X_Initial := Part_Of_A_Minute / 60.0;
end Set_Seed;
procedure Force_Seed(Start_Seed : FLOAT_ITEM) is
Temp : FLOAT_ITEM;
Natural_Temp : NATURAL;
begin
Natural_Temp := NATURAL(Start_Seed - 0.5); -- Subtract 0.5 because
-- the type conversion
-- rounds the result.
Temp := Start_Seed - FLOAT_ITEM(Natural_Temp);
X_Initial := Start_Seed;
exception
when Constraint_Error =>
Put_Line("Seed out of range, ignored");
end Force_Seed;
function Get_Seed return FLOAT_ITEM is
begin
return X_Initial;
end Get_Seed;
function Random_Number return FLOAT_ITEM is
Temp : FLOAT_ITEM;
Natural_Temp : NATURAL; -- Cannot exceed (7 + 13/31)
begin
Temp := A * X_Initial + C;
Natural_Temp := NATURAL(Temp - 0.5); -- Subtract 0.5 because
-- the type conversion
-- rounds the result.
Temp := Temp - FLOAT_ITEM(Natural_Temp);
X_Initial := Temp;
return Temp;
end Random_Number;
end Random;
在编写计算机程序时，有时需要使用随机数生成器。很少有编译器将随机数生成器作为系统的一部分，因此您必须自己编写随机数生成器，或者找到由别人编写和调试过的随机数生成器。示例包名为e_c33_p1.ada的出现有几个原因。第一个原因是为您提供一个完整的通用包的有用示例，以说明如何编写通用包。其次，它是一个有用的软件包，当您需要使用随机数生成器时，可以将其用作自己程序的一部分。最后，它说明了良好的格式风格，并说明了包规范中包含足够的注释来完全定义所使用的方法，以及如何将这个包作为另一个程序的一部分。
当Ada 83升级到Ada 95时，一个随机数生成器被定义为标准库的一部分，使其成为每个Ada 95编译系统的必需组件。e_c33_p1中的随机数生成器。ada没有从教程中删除，因为它是注释良好的ada实用程序包的一个很好的例子。没有人试图证明它能产生真正的随机数，所以也没有人敢说它是随机的。研究它，然后使用编译器提供的随机数生成器来进行任何生产工作，对您是有好处的，
不需要给出关于这个包的操作的其他注释，因此您将自行研究清单，然后编译这个包，为使用下一个示例程序做准备。
测试随机数
Example program ------> e_c33_p2.ada
-- Chapter 33 - Program 2
with Ada.Text_IO, Random;
use Ada.Text_IO;
procedure TestRan is
package My_Random is new Random(FLOAT);
use My_Random;
package Int_IO is new Ada.Text_IO.Integer_IO(INTEGER);
use Int_IO;
package Flt_IO is new Ada.Text_IO.Float_IO(FLOAT);
use Flt_IO;
SIZE : constant := 100;
type MY_ARRAY is array(1..SIZE) of INTEGER;
Events : MY_ARRAY;
Int_Rand : INTEGER;
begin
Set_Seed;
Put("The starting value of the seed is ");
Put(Get_Seed, 3, 6, 0);
New_Line;
for Index in 1..12 loop
Put("The random number is ");
Put(Random_Number, 3, 6, 0);
New_Line;
end loop;
for Index in 1..SIZE loop
Events(Index) := 0;
end loop;
for Index in 1..10000 loop
Int_Rand := INTEGER(0.5 + (FLOAT(SIZE) * Random_Number));
Events(Int_Rand) := Events(Int_Rand) + 1;
end loop;
New_Line(2);
for Index in 1..Size loop
Put(Events(Index), 4);
end loop;
end TestRan;
-- Result of execution
-- The starting value of the seed is 0.195333
-- The random number is 0.786685
-- The random number is 0.926148
-- The random number is 0.902392
-- The random number is 0.736096
-- The random number is 0.572030
-- The random number is 0.423565
-- The random number is 0.384310
-- The random number is 0.109521
-- The random number is 0.186004
-- The random number is 0.721385
-- The random number is 0.469050
-- The random number is 0.702704
-- 109 97 102 96 107 98 85 87 104 111 113 115 108 99 112 ...
-- 97 93 107 91 101 85 91 103 95 101 102 98 95 118 110 ...
-- 87 106 103 102 93 129 112 94 102 89 95 104 98 94 98 ...
-- 93 106 96 104 119 95 82 97 112 82 104 103 97 107 112 ...
-- 93 96 101 98 109 95 94 99 80 74 99 85 76 117 124 ...
-- (Note; only fifteen are listed in each row to stay within
-- 70 columns.)
检查名为 e_c33_p2.ada，它只是为了测试包random中的随机数生成器而编写的。它在第7行中使用FLOAT类型实例化泛型包的一个副本，然后声明一些对象和一个数组类型。在程序的可执行部分中，使用第21行中的Set_Seed过程初始化随机数生成器，并读取并打印12个随机数，以确定它们是否覆盖了包头random中定义的0.0到1.0的范围。
随机数生成器的真正测试是在第35行开始的循环中，其中生成了10,000个随机数，并通过乘以100将其转换为整型值。因此，整数值将涵盖1到100的范围，并在名为Events的数组中计数。数组中每个元素的计数应该在100左右，因为有一万种情况分布在100个元素之上。程序的执行将显示每个数组元素中的计数约为预期的100，因此我们声明随机数生成器至少是合理的随机的。数学家可能会认为这种方法太粗糙，不能称为好的随机数生成器，但对于我们的目的来说，它已经足够好了。
编译并执行这个程序，您将发现每次运行它都会得到不同的结果，因为它使用系统时钟来设置种子，从而为每次执行产生一个新的开始种子。
一个新的动态字符串包
Example program ------> e_c33_p3.ada
-- Chapter 33 - Program 3
-- This is a dynamic string package which can be used as an aid
-- in writing string intensive programs. Ada only has a static
-- string capability, so this package was written as an example of
-- how the Ada programming language can be expanded.
-- A dynamic string is defined as an array of characters of maximum
-- length of 255. The dynamic length of the dynamic string is
-- stored in the Max_Length field of the record. So the string
-- must be defined with a lower limit of 1 and an upper limit of
-- whatever the desired maximum length of the string is to be. The
-- subtype STRING_SIZE limits the string length when it is defined.
-- Put Outputs a dynamic string to the monitor
-- ConCat Concatenates two dynamic strings and puts the result
-- into a third dynamic string
-- Copy Copies a dynamic string to another dynamic string
-- Copy Copies a static string to a dynamic string
-- Delete Deletes a group of characters from a dynamic string
-- Insert Inserts a group of characters into a dynamic string
-- Length Returns the dynamic length of a dynamic string
-- Size_Of Returns the static length of a dynamic string
-- Pos Returns the first location of a dynamic string within
-- another dynamic string
with Ada.Text_IO; use Ada.Text_IO;
package DynStrng is
subtype STRING_SIZE is INTEGER range 0..255;
type STRING_ARRAY is array(STRING_SIZE range <>) of CHARACTER;
type DYNAMIC_STRING(Maximum_Length : STRING_SIZE) is
record
Dynamic_Length : INTEGER range 0..255;
String_Data : STRING_ARRAY(1..Maximum_Length);
end record;
-- Put : Display a dynamic string on the monitor.
procedure Put(Input_String : in DYNAMIC_STRING);
-- ConCat : Concatenation - The First_String is copied into the
-- Result_String, then the Second_String is copied
-- into the Result_String following the First_String.
-- If all characters fit, Result is set to TRUE.
-- If Result_String will not hold all characters,
-- only as many as will fit are copied and Result
-- is set to FALSE.
-- Result = TRUE, complete copy done.
-- Result = FALSE, some or all not copied
procedure ConCat(First_String : in DYNAMIC_STRING;
Second_String : in DYNAMIC_STRING;
Result_String : in out DYNAMIC_STRING;
Result : out BOOLEAN);
-- Copy : The String contained in Input_String is copied into
-- the string Output_String. This procedure is
-- overloaded to include copying from either dynamic
-- strings or static strings.
-- Result = TRUE, complete copy done
-- Result = FALSE, some or all not copied
procedure Copy(Input_String : in DYNAMIC_STRING;
Output_String : in out DYNAMIC_STRING;
Result : out BOOLEAN);
procedure Copy(Input_String : in STRING;
Output_String : out DYNAMIC_STRING;
Result : out BOOLEAN);
-- Delete : Beginning at First_Position, as many characters as are
-- indicated by Number_Of_Characters are deleted from
-- String_To_Modify. If there are not that many, only
-- as many as are left are deleted.
-- Result = TRUE, deletion was complete
-- Result = FALSE, only a partial deletion was done
procedure Delete(String_To_Modify : in out DYNAMIC_STRING;
First_Position : in STRING_SIZE;
Number_Of_Characters : in STRING_SIZE;
Result : out BOOLEAN);
-- Insert : The string String_To_Insert is inserted into the string
-- String_To_Modify begining at location Place_To_Insert
-- if there is enough room.
-- Result = TRUE, insert completed in full
-- Result = FALSE, not enough room for full insert
procedure Insert(String_To_Modify : in out DYNAMIC_STRING;
String_To_Insert : in DYNAMIC_STRING;
Place_To_Insert : in STRING_SIZE;
Result : out BOOLEAN);
-- Length : Returns the dynamic length of the string defined by
-- String_To_Measure.
function Length(String_To_Measure : in DYNAMIC_STRING)
return STRING_SIZE;
-- Size_Of : Returns the static length of the string, the actual
-- upper limit of the string definition.
function Size_Of(String_To_Measure : in DYNAMIC_STRING)
return STRING_SIZE;
-- Pos : Position of substring - The string String_To_Search is
-- searched for the string Required_String beginning
-- at Place_To_Start.
-- Result = TRUE, a search was possible
-- Result = FALSE, no search could be made
-- Location_Found = 0, no string found
-- Location_Found = N, start of matching string
procedure Pos(String_To_Search : in DYNAMIC_STRING;
Required_String : in DYNAMIC_STRING;
Place_To_Start : in STRING_SIZE;
Location_Found : out STRING_SIZE;
Result : out BOOLEAN);
end DynStrng;
package body DynStrng is
-- The display procedure overloads the existing
-- Put procedures to output a dynamic string. Note
-- that the existing Put is used in this new Put.
procedure Put(Input_String : in DYNAMIC_STRING) is
begin
for Index in 1..Input_String.Dynamic_Length loop
Put(Input_String.String_Data(Index));
end loop;
end Put;
procedure ConCat(First_String : in DYNAMIC_STRING;
Second_String : in DYNAMIC_STRING;
Result_String : in out DYNAMIC_STRING;
Result : out BOOLEAN) is
Intermediate_Result : BOOLEAN;
Character_Count : STRING_SIZE;
Room_Left : STRING_SIZE;
begin
-- Copy the first into the result string
Copy(First_String,Result_String,Intermediate_Result);
if Intermediate_Result then
Character_Count := Second_String.Dynamic_Length;
Room_Left := Result_String.String_Data'LAST
- Result_String.Dynamic_Length;
Result := TRUE;
if Character_Count > Room_Left then
Character_Count := Room_Left;
Result := FALSE;
end if;
for Index in 1..Character_Count loop
Result_String.String_Data
(Index + Result_String.Dynamic_Length) :=
Second_String.String_Data(Index);
end loop;
Result_String.Dynamic_Length :=
Result_String.Dynamic_Length + Character_Count;
else
Result := FALSE;
end if;
end ConCat;
-- This procedure overloads the name Copy to
-- copy from one dynamic string to another.
procedure Copy(Input_String : in DYNAMIC_STRING;
Output_String : in out DYNAMIC_STRING;
Result : out BOOLEAN) is
Character_Count : STRING_SIZE;
begin
-- First pick the smallest string size
Character_Count := Input_String.Dynamic_Length;
if Character_Count > Output_String.String_Data'LAST then
Character_Count := Output_String.String_Data'LAST;
Result := FALSE; -- The entire string didn't fit
else
Result := TRUE; -- The entire string fit
end if;
for Index in 1..Character_Count loop
Output_String.String_Data(Index) :=
Input_String.String_Data(Index);
end loop;
Output_String.Dynamic_Length := Character_Count;
end Copy;
-- This routine overloads the copy procedure name
-- to copy a static string into a dynamic string.
procedure Copy(Input_String : in STRING;
Output_String : out DYNAMIC_STRING;
Result : out BOOLEAN) is
Character_Count : STRING_SIZE;
begin
-- First pick the smallest string size
Character_Count := Input_String'LAST;
if Character_Count > Output_String.String_Data'LAST then
Character_Count := Output_String.String_Data'LAST;
Result := FALSE; -- The entire string didn't fit
else
Result := TRUE; -- The entire string fit
end if;
for Index in 1..Character_Count loop
Output_String.String_Data(Index) :=
Input_String(Index);
end loop;
Output_String.Dynamic_Length := Character_Count;
end Copy;
procedure Delete(String_To_Modify : in out DYNAMIC_STRING;
First_Position : in STRING_SIZE;
Number_Of_Characters : in STRING_SIZE;
Result : out BOOLEAN) is
Number_To_Delete : STRING_SIZE;
Number_To_Move : STRING_SIZE;
Last_Dynamic_Character : STRING_SIZE :=
String_To_Modify.Dynamic_Length;
begin
-- can we delete any at all?
if First_Position > Last_Dynamic_Character then
Result := FALSE;
return;
end if;
-- Decide how many to delete
if (First_Position + Number_Of_Characters)
> Last_Dynamic_Character then
Number_To_Delete := Last_Dynamic_Character
- First_Position + 1;
Result := FALSE;
else
Number_To_Delete := Number_Of_Characters;
Result := TRUE;
end if;
-- find out how many to move back
if (Last_Dynamic_Character - (First_Position + Number_To_Delete))
>= 0 then
Number_To_Move := 1 + Last_Dynamic_Character
- (First_Position + Number_To_Delete);
else
Number_To_Move := 0;
end if;
-- now delete the characters by moving them back
for Index in First_Position..
(First_Position + Number_To_Move - 1) loop
String_To_Modify.String_Data(Index) :=
String_To_Modify.String_Data(Index + Number_To_Delete);
end loop;
String_To_Modify.Dynamic_Length :=
String_To_Modify.Dynamic_Length - Number_To_Delete;
end Delete;
procedure Insert(String_To_Modify : in out DYNAMIC_STRING;
String_To_Insert : in DYNAMIC_STRING;
Place_To_Insert : in STRING_SIZE;
Result : out BOOLEAN) is
Number_To_Add : STRING_SIZE;
Number_To_Move : STRING_SIZE;
Room_Left : STRING_SIZE;
begin
-- Can we add any at all?
if (Place_To_Insert > String_To_Modify.String_Data'LAST) or
(Place_To_Insert > String_To_Modify.Dynamic_Length + 1) then
Result := FALSE;
return;
end if;
Result := TRUE;
-- How many can we add?
Number_To_Add := String_To_Modify.String_Data'LAST
- Place_To_Insert + 1;
if Number_To_Add > String_To_Insert.Dynamic_Length then
Number_To_Add := String_To_Insert.Dynamic_Length;
end if;
-- Find how many to move forward
Number_To_Move := String_To_Modify.Dynamic_Length
- Place_To_Insert + 1;
Room_Left := String_To_Modify.String_Data'LAST
- Place_To_Insert + 1;
if Room_Left < Number_To_Move then
Number_To_Move := Room_Left;
end if;
-- Move them forward
for Index in reverse Place_To_Insert..Place_To_Insert
+ Number_To_Move - 1 loop
String_To_Modify.String_Data(Index + Number_To_Add) :=
String_To_Modify.String_Data(Index);
end loop;
for Index in 1..Number_To_Add loop
String_To_Modify.String_Data(Index + Place_To_Insert - 1) :=
String_To_Insert.String_Data(Index);
end loop;
-- Increase the length of the string
String_To_Modify.Dynamic_Length :=
String_To_Modify.Dynamic_Length + Number_To_Add;
if String_To_Modify.Dynamic_Length >
String_To_Modify.String_Data'LAST then
String_To_Modify.Dynamic_Length := String_To_Modify.String_Data'LAST;
end if;
end Insert;
-- This returns the dynamic length of a string
function Length(String_To_Measure : in DYNAMIC_STRING)
return STRING_SIZE is
begin
return String_To_Measure.Dynamic_Length;
end Length;
-- This returns the static length of a string
function Size_Of(String_To_Measure : in DYNAMIC_STRING)
return STRING_SIZE is
begin
return String_To_Measure.String_Data'LAST;
end Size_Of;
procedure Pos(String_To_Search : in DYNAMIC_STRING;
Required_String : in DYNAMIC_STRING;
Place_To_Start : in STRING_SIZE;
Location_Found : out STRING_SIZE;
Result : out BOOLEAN) is
End_Search : STRING_SIZE;
Characters_All_Compare : BOOLEAN;
begin
Location_Found := 0;
-- can we search the string at all?
if (Place_To_Start < String_To_Search.Dynamic_Length) and
(Place_To_Start < String_To_Search.String_Data'LAST) then
Result := TRUE;
else
Result := FALSE;
return;
end if;
-- search the loop for the string now
End_Search := String_To_Search.Dynamic_Length -
Required_String.Dynamic_Length + 1;
for Index in Place_To_Start..End_Search loop -- search loop
Characters_All_Compare := TRUE;
for Count in 1..Required_String.Dynamic_Length loop
if Required_String.String_Data(Count) /=
String_To_Search.String_Data(Count + Index - 1) then
Characters_All_Compare := FALSE;
exit; -- exit loop, a character did not match
end if;
end loop;
if Characters_All_Compare then
Location_Found := Index;
return; -- string match found, return location
end if;
end loop; -- end search loop
end Pos;
end DynStrng;
检查名为e_c16_p3.ada,的程序，它包含在本教程的第2部分中，以获得更好的动态字符串包。您应该还记得，当我们在本教程第1部分的第16章学习动态字符串包时，我们在Copy过程调用中使用字符串常量时发现了一个问题。这是因为系统发现了模棱两可的程序。它不能分辨字符串常量是string类型还是我们自己声明的DYNAMIC_STRING类型。因为当时没有研究歧视记录，所以无法妥善解决这个问题。新的DynStrng包使用了一个有区别的记录，是解决动态字符串使用问题的更好的包。
DYNAMIC_STRING类型在第33行到第37行中声明，这次声明为记录，这样就不会混淆它是字符串还是记录，重载歧义问题也就解决了。包规范与上一个动态字符串包本质上没有变化，当然除了类型之外，但是包体发生了很大的变化，以反映新的数据结构。如果您愿意，可以自行比较这两个包的主体。
字符常数问题是固定的
Example program ------> e_c33_p4.ada
-- Chapter 33 - Program 4
with Ada.Text_IO; use Ada.Text_IO;
with DynStrng; use DynStrng;
procedure TestStrn is
package Int_IO is new Ada.Text_IO.Integer_IO(INTEGER);
use Int_IO;
Stuff : DYNAMIC_STRING(35);
Result : BOOLEAN;
begin
Copy("ABCDEFGHIJKL$", Stuff, Result);
Put(Size_Of(Stuff), 4);
Put(Length(Stuff), 4);
Put(Stuff);
New_Line;
Copy("ABCD$", Stuff, Result);
Put(Size_Of(Stuff), 4);
Put(Length(Stuff), 4);
Put(Stuff);
New_Line;
Copy("", Stuff, Result);
Put(Size_Of(Stuff), 4);
Put(Length(Stuff), 4);
Put(Stuff);
New_Line;
end TestStrn;
程序名为e_c33_p4。Ada的设计目的是用一些字符串常量来测试新包，以证明它确实能像广告中说的那样工作。您可以编译并执行这个文件，以查看它是否真的可以在Copy过程调用中使用字符串常量。
示例程序—— e_c16_p4.ada
您可以返回到名为e_c16_p4的程序。Ada从第16章证明了新包仍然与旧程序一起工作。您将发现必须进行一些更改以反映不同的数据类型。必须修改第11行和第12行，以仅反映动态字符串变量的静态长度的上限。他们将阅读如下内容;
Name : DYNAMIC_STRING(15); Stuff : DYNAMIC_STRING(35);
此外，由于类型被更改，第21行和第22行也必须修改如下;
Name.Dynamic_Length := 3; Stuff.Dynamic_Length := 7;
在做了这两个更改之后，这个程序执行起来应该和它使用旧的动态字符串包时完全一样。
你几岁了
Example program ------> e_c33_p5.ada
-- Chapter 33 - Program 5
-- This program will calculate the number of days old you are.
-- It is a rather dumb program, but illustrates some interesting
-- programming techniques. It checks all input to see that they
-- are in the correct range before continuing. Since the number
-- of days can easily exceed the limits of type INTEGER, and we
-- cannot count on LONG_INTEGER being available, a fixed point
-- variable is used for the total number of days since Jan 1, 1880.
-- This program also passes a record to a procedure, where it is
-- modified and returned.
-- This is a repeat of the program named AGE.ADA from chapter 16
-- of this tutorial. This program uses the CALENDAR package for
-- the current date so the user does not have to enter today's
-- date. It also uses some of the subtypes from the CALENDAR
-- package, but not the YEAR_NUMBER, because it does not follow
-- our desired range.
with Ada.Text_IO, Calendar;
use Ada.Text_IO, Calendar;
procedure Age2 is
LOW_YEAR : constant := 1880;
MAX : constant := 365.0 * (2100 - LOW_YEAR);
type AGES is delta 1.0 range -MAX..MAX;
Days_Since_1880 : AGES;
Present_Age : AGES;
Today : TIME; -- Present date and time
This_Month : MONTH_NUMBER;
This_Day : DAY_NUMBER;
This_Year : INTEGER range LOW_YEAR..2100;
Seconds : DAY_DURATION;
type DATE is
record
Month : MONTH_NUMBER;
Day : DAY_NUMBER;
Year : INTEGER range LOW_YEAR..2100;
Days : AGES;
end record;
Birth_Day : DATE;
package Int_IO is new Ada.Text_IO.Integer_IO(INTEGER);
use Int_IO;
package Fix_IO is new Ada.Text_IO.Fixed_IO(AGES);
use Fix_IO;
procedure Get_Date(Date_To_Get : in out DATE) is
Temp : INTEGER;
begin
Put(" month --> ");
loop
Get(Temp);
if Temp in 1..12 then
Date_To_Get.Month := Temp;
exit; -- month OK
else
Put_Line(" Month must be in the range of 1 to 12");
Put(" ");
Put(" month --> ");
end if;
end loop;
Put(" ");
Put(" day ----> ");
loop
Get(Temp);
if Temp in 1..31 then
Date_To_Get.Day := Temp;
exit; -- day OK
else
Put_Line(" Day must be in the range of 1 to 31");
Put(" ");
Put(" day ----> ");
end if;
end loop;
Put(" ");
Put(" year ---> ");
loop
Get(Temp);
if Temp in LOW_YEAR..2100 then
Date_To_Get.Year := Temp;
exit; -- year OK
else
Put_Line(" Year must be in the range of 1880 to 2100");
Put(" ");
Put(" year ---> ");
end if;
end loop;
Date_To_Get.Days := 365 * AGES(Date_To_Get.Year - LOW_YEAR)
+ AGES(31 * Date_To_Get.Month + Date_To_Get.Day);
end Get_Date;
begin
-- Get todays date
Today := Clock;
Split(Today, This_Year, This_Month, This_Day, Seconds);
Days_Since_1880 := 365 * AGES(This_Year - LOW_YEAR)
+ AGES(31 * This_Month + This_Day);
Put("Enter your birthday;");
Get_Date(Birth_Day);
New_Line(2);
Present_Age := Days_since_1880 - Birth_Day.Days;
if Present_Age < 0.0 then
Put("You will be born in ");
Present_Age := abs(Present_Age);
Put(Present_Age,6,0,0);
Put_Line(" days.");
elsif Present_Age = 0.0 then
Put_Line("Happy birthday, you were just born today.");
else
Put("You are now ");
Put(Present_Age,6,0,0);
Put_Line(" days old.");
end if;
end Age2;
这个程序是第16章中给出的程序的重复，但是在这里有所改进。既然我们现在知道了如何使用Calendar包，那么我们可以使用它来获取今天的日期，我们可以在名为e_c33_p5.ada的新程序中这样做。请特别注意在继续之前读入数据并检查其有效性的方式。如果数据被读入到相应的变量中，无效的条目将导致异常，但是由于数据被读入到一个范围很宽的INTEGER类型变量中，因此可以在将其赋给范围小得多的正确变量之前检查其有效性。对您来说，这个程序应该非常容易理解，但是在编译和执行它之前花一点时间研究它是有好处的。
餐厅的哲学家
Example program ------> e_c33_p6.ada
-- Chapter 33 - Program 6
package One_Man is
type AVAILABILITY is (AVAILABLE, IN_USE);
Fork_Usage : array(1..5) of AVAILABILITY;
type ACTIVITY is (THINKING, HAS_LEFT_FORK, HAS_BOTH_FORKS);
Philosopher_Activity : array(1..5) of ACTIVITY;
task type EATING_OR_THINKING is
entry Start(Left_Fork, Right_Fork : INTEGER);
end EATING_OR_THINKING;
end One_Man;
with Ada.Text_IO, Ada.Integer_Text_IO, Ada.Calendar, Random;
use Ada.Text_IO, Ada.Integer_Text_IO;
package body One_Man is
package My_Random is new Random(FLOAT);
use My_Random;
procedure Get_Fork(Identifier : INTEGER;
Left_Or_Right : INTEGER) is
begin
Fork_Usage(Identifier) := IN_USE;
end Get_Fork;
procedure Return_Fork(Identifier : INTEGER) is
begin
Fork_Usage(Identifier) := AVAILABLE;
end Return_Fork;
task body EATING_OR_THINKING is
Left, Right : INTEGER;
Ident : INTEGER renames Left;
begin
accept Start(Left_Fork, Right_Fork : INTEGER) do
Left := Left_Fork;
Right := Right_Fork;
Philosopher_Activity(Ident) := THINKING;
end Start;
loop
Put("Philosopher");
Put(Ident, 2);
Put_Line(" is thinking.");
delay Calendar.DAY_DURATION(Random_Number);
loop
delay 0.10;
exit when Fork_Usage(Left) = AVAILABLE;
end loop;
Get_Fork(Ident, Left);
Philosopher_Activity(Ident) := HAS_LEFT_FORK;
Put("Philosopher");
Put(Ident, 2);
Put_Line(" has his left fork");
delay Calendar.DAY_DURATION(Random_Number);
loop
delay 0.10;
exit when Fork_Usage(Right) = AVAILABLE;
end loop;
Get_Fork(Ident,Right);
Philosopher_Activity(Ident) := HAS_BOTH_FORKS;
Put("Philosopher");
Put(Ident, 2);
Put_Line(" has his right fork and is eating");
delay Calendar.DAY_DURATION(Random_Number);
Return_Fork(Left);
Return_Fork(Right);
Philosopher_Activity(Ident) := THINKING;
end loop;
end EATING_OR_THINKING;
begin
Set_Seed; -- Initialize the random number generator
for Index in 1.. 5 loop
Fork_Usage(Index) := AVAILABLE;
Philosopher_Activity(Index) := THINKING;
end loop;
end One_Man;
with Ada.Text_IO, One_Man;
use Ada.Text_IO, One_Man;
procedure Philos is
-- Declare all 5 tasks
Philosopher_1 : One_Man.EATING_OR_THINKING;
Philosopher_2 : One_Man.EATING_OR_THINKING;
Philosopher_3 : One_Man.EATING_OR_THINKING;
Philosopher_4 : One_Man.EATING_OR_THINKING;
Philosopher_5 : One_Man.EATING_OR_THINKING;
begin
-- Assign forks to Philosophers & start
Philosopher_1.Start(Left_Fork => 1, Right_Fork => 2);
Philosopher_2.Start(Left_Fork => 2, Right_Fork => 3);
Philosopher_3.Start(Left_Fork => 3, Right_Fork => 4);
Philosopher_4.Start(Left_Fork => 4, Right_Fork => 5);
Philosopher_5.Start(Left_Fork => 5, Right_Fork => 1);
loop -- Watch for deadlock to occur
delay 0.01;
if Philosopher_Activity(1) = HAS_LEFT_FORK and
Philosopher_Activity(2) = HAS_LEFT_FORK and
Philosopher_Activity(3) = HAS_LEFT_FORK and
Philosopher_Activity(4) = HAS_LEFT_FORK and
Philosopher_Activity(5) = HAS_LEFT_FORK then exit;
end if;
end loop;
Put_Line("Deadlock detected, program operation aborted.");
abort Philosopher_1, Philosopher_2, Philosopher_3,
Philosopher_4, Philosopher_5;
end Philos;
大多数关于任务或并发的书籍和文章都至少提到了进餐哲学家的问题，所以在本教程中不讨论这个问题是不好的。实际上，这个程序名为e_c33_p6。Ada是一个您可以研究和执行的程序，以查看这个问题的说明。
问题是，五个哲学家坐下来吃饭。它们喜欢吃一会儿，然后思考一会儿，然后永远重复这个模式。为了吃东西，他们的左右两手都需要一把叉子，而且桌子的两边盘子上都摆好了一把叉子。当我们声明每个相邻的哲学家之间只有一个叉子时，问题就出现了，因此他被要求与他相邻的同事共享每个叉子。
每个哲学家坐下来，随机等待一段时间，然后拿起自己左边的叉子，再随机等待一段时间，然后拿起自己右边的叉子。然后他继续随机进食一段时间，然后把两把叉子都放回桌上，随机思考一段时间。一旦他拿起左边的叉子，他固执地抓住它，直到他得到右边的叉子。如果我们达到每个哲学家都有他的左叉的状态，那么没有人会归还它，因此也没有人能拿起他的右叉。整个系统都陷入了僵局，因为其他的事情都无法完成。这五个不合作的哲学家最终都会饿死，因为他们都不能吃东西。
该程序演示了死锁
该程序使用一个包来为一个哲学家定义一个任务类型，该任务类型具有所需的延迟和获取每个fork、吃，然后将fork返回到表的逻辑。根据我们关于任务分配的研究，你应该能够很好地理解本文的逻辑。
名为Philos的主程序在文件的第93行开始，它简单地声明了这5个哲学家，在第108行到第112行开始他们的循环，然后在观察死锁时进行循环。当检测到死锁时，将向监视器输出一条消息，整个系统将被中止。
编译并执行这个程序，这样您就可以观察死锁的发生和系统中止操作。如果您多次运行它，您将看到死锁经常立即发生，但在其他时候，它会在检测到死锁之前运行几秒钟。
这是一个有趣的问题，但更有趣的一点是，这个从第93行开始的程序使用Ada.Text_IO and One_Man, and One_Man in turn uses Ada.Text_IO, Ada.Calendar, and Random. 。这个程序使用了Ada中相当多的可用资源，并使用了几个包来完成它的预期任务。因为我们使用的是为早期项目开发的Random，所以我们实际上是在说明Ada软件的可重用性。
通用的堆栈
Example program ------> e_c33_p7.ada
-- Chapter 33 - Program 7
generic
type ITEM is private;
package GenStack is
procedure Push(In_Item : in ITEM); -- In_Item is added to the
-- stack if there is room.
procedure Pop(Out_Item : out ITEM); -- Out_Item is removed from
-- stack and returned if a
-- character is on stack.
-- else a blank is returned
function Is_Empty return BOOLEAN; -- TRUE if stack is empty
function Is_Full return BOOLEAN; -- TRUE if stack is full
function Current_Stack_Size return INTEGER;
procedure Clear_Stack; -- Reset the stack to empty
end GenStack;
package body GenStack is
Maximum_Size : constant := 25;
type ITEM_ARRAY is array(1..Maximum_Size) of ITEM;
Stack_List : ITEM_ARRAY; -- The stack itself, purposely
-- defined very small.
Top_Of_Stack : INTEGER := 0; -- This will always point to
-- the top entry on the stack.
procedure Push(In_Item : in ITEM) is
begin
if not Is_Full then
Top_Of_Stack := Top_Of_Stack + 1;
Stack_List(Top_Of_Stack) := In_Item;
end if;
end Push;
procedure Pop(Out_Item : out ITEM) is
begin
if Is_Empty then
null; -- Nothing to return
else
Out_Item := Stack_List(Top_Of_Stack);
Top_Of_Stack := Top_Of_Stack - 1;
end if;
end Pop;
function Is_Empty return BOOLEAN is
begin
return Top_Of_Stack = 0;
end Is_Empty;
function Is_Full return BOOLEAN is
begin
return Top_Of_Stack = Maximum_Size;
end Is_Full;
function Current_Stack_Size return INTEGER is
begin
return Top_Of_Stack;
end Current_Stack_Size;
procedure Clear_Stack is
begin
Top_Of_Stack := 0;
end Clear_Stack;
end GenStack;
我们在第16章学习字符堆栈时承诺过要包含一个泛型堆栈和e_c33_p7。Ada是实现这一承诺的通用堆栈。它实际上只是e_c16_p1的副本。根据本教程中研究的规则将第16章中的Ada做成一个通用包。
Example program ------> e_c33_p8.ada
-- Chapter 33 - Program 8
with Ada.Text_IO, Ada.Integer_Text_IO;
use Ada.Text_IO, Ada.Integer_Text_IO;
with GenStack;
procedure TryStak is
package Char_Stack is new GenStack(CHARACTER);
use Char_Stack;
Example : constant STRING := "This is the first test.";
Another : constant STRING :=
"This is another test and this should not fit.";
procedure Fill_The_Stack(Input_Line : STRING) is
begin
Clear_Stack;
for Index in 1..Input_Line'LAST loop
if Is_Full then
Put_Line("The stack is full, no more added.");
exit;
else
Push(Input_Line(Index));
end if;
end loop;
end Fill_The_Stack;
procedure Empty_The_Stack is
Char : CHARACTER;
begin
loop
if Is_Empty then
New_Line;
Put_Line("The stack is empty.");
exit;
else
Pop(Char);
Put(Char);
end if;
end loop;
end Empty_The_Stack;
begin
Put_Line(Example);
Fill_The_Stack(Example);
Empty_The_Stack;
New_Line;
Put_Line(Another);
Fill_The_Stack(Another);
Empty_The_Stack;
end TryStak;
-- Result of execution
-- This is the first test.
-- .tset tsrif eht si sihT
-- The stack is empty.
--
-- This is another test and this should not fit.
-- The stack is full, no more added.
-- dna tset rehtona si sihT
-- The stack is empty.
程序e_c16_p2。Ada与第16章中同名的程序几乎完全相同，唯一的区别是通用包的实例化，因此它可以在主程序中使用。
---------------------------------------------------------------------------------------------------------------------------
原英文版出处：https://perso.telecom-paristech.fr/pautet/Ada95/a95list.htm
翻译（百度）：博客园 一个默默的 *** 的人
