Program code for Ada, 4th Edition

Chapter 2 Ada Concepts
2.2 Overall structure
with Sqrt, Simple_IO;
procedure Print_Root is
use Simple_IO;
begin
Put(Sqrt(2.5));
end Print_Root;
----
with Sqrt, Simple_IO;
procedure Print_Root is
use Simple_IO;
X: Float;
begin
Get(X);
Put(Sqrt(X));
end Print_Root;
----
with Sqrt, Simple_IO;
procedure Print_Roots is
use Simple_IO;
X: Float;
begin
Put("Roots of various numbers");
New_Line(2);
loop
Get(X);
exit when X = 0.0;
Put(" Root of ");
Put(X);
Put(" is ");
if X < 0.0 then
Put("not calculable");
else
Put(Sqrt(X));
end if;
New_Line;
end loop;
New_Line;
Put("Program finished");
New_Line;
end Print_Roots;
----
function Sqrt(F: Float) return Float is
R: Float;
begin
-- compute value of Sqrt(F) in R
return R;
end Sqrt;
----
package Simple_IO is
procedure Get(F: out Float);
procedure Put(F: in Float);
procedure Put(S: in String);
procedure New_Line(N: in Integer := 1);
end Simple_IO;
----
with Text_IO;
package body Simple_IO is
...
procedure Get(F: out Float) is
...
begin
...
end Get;
-- other procedures similarly
end Simple_IO;
2.3 Errors and exceptions
if X < 0.0 then
Put("not calculable");
else
Put(Sqrt(X));
end if;
----
begin
Put(Sqrt(X));
exception
when Constraint_Error =>
Put("not calculable");
end;
2.4 The type model
declare
type Colour is (Red, Amber, Green);
type Fish is (Cod, Hake, Plaice);
X, Y: Colour;
A, B: Fish;
begin
X := Red; -- ok
A := Hake; -- ok
B := X; -- illegal
...
end;
----
declare
type Light is new Colour;
C: Colour;
L: Light;
begin
L := Amber; -- the light amber, not the colour
C := Colour(L); -- explicit conversion
...
end;
2.5 Generics
generic
type Num is digits <>;
package Float_IO is
...
procedure Get(Item: out Num; ... );
procedure Put(Item: in Num; ... );
...
end Float_IO;
----
with Elementary_Functions_Exceptions;
generic
type Float_Type is digits <>;
package Generic_Elementary_Functions is
function Sqrt(X: Float_Type) return Float_Type;
... -- and so on
end;
2.6 Input-output
with IO_Exceptions;
package Text_IO is
type Count is ... -- an integer type
...
procedure New_Line(Spacing: in Count := 1);
procedure Set_Col(To: in Count);
function Col return Count;
...
procedure Get(Item: out Character);
procedure Put(Item: in Character);
procedure Put(Item: in String);
...
-- the package Float_IO outlined in the previous section
-- plus a similar package Integer_IO
...
end Text_IO;
----
C: Character;
...
Put("Do you want to stop? Answer Y if so. ");
Get(C);
if C = 'Y' then
...
2.7 Running a program
with Text_IO, Generic_Elementary_Functions;
procedure Print_Roots is
type Real is digits 7;
X: Real;
use Text_IO;
package Real_IO is new Float_IO(Real);
use Real_IO;
package Real_Maths is
new Generic_Elementary_Functions(Real);
use Real_Maths;
begin
Put("Roots of various numbers");
...
... -- and so on as before
...
end Print_Roots;
----
with Text_IO, Generic_Elementary_Functions;
package Etc is
type Real is digits 7;
package Real_IO is new Text_IO.Float_IO(Real);
package Int_IO is new Text_IO.Integer_IO(Integer);
package Real_Maths is
new Generic_Elementary_Functions(Real);
end Etc;
----
with Text_IO, Etc;
use Text_IO, Etc;
procedure Program is
use Real_IO, Int_IO, Real_Maths; -- as required
...
...
end Program;
Chapter 4 Scalar Types
4.2 Blocks and scopes
declare
I: Integer := 0; -- declarations here
begin
I := I+1; -- statements here
end;
----
declare
I, J: Integer;
begin
... -- here I is the outer one
declare
I: Integer;
begin
... -- here I is the inner one
end;
... -- here I is the outer one
end;
----
declare
I: Integer := 0;
begin
...
declare
K: Integer := I;
I: Integer := 0;
begin
...
end;
...
end;
Exercise 4.2
declare
I: Integer := 7;
J, K: Integer
begin
J := I+K;
declare
P: Integer=I;
I, J: Integer;
begin
I := P+Q;
J := P-Q;
K := I*J;
end;
Put(K); -- output value of K
end;
4.6 Enumeration types
type Colour is (Red, Amber, Green);
type Day is (Mon, Tue, Wed, Thu, Fri, Sat, Sun);
type Stone is (Amber, Beryl, Quartz);
type Groom is (Tinker, Tailor, Soldier, Sailor,
Rich_Man, Poor_Man, Beggar_Man, Thief);
type Solo is (Alone);
Chapter 5 Control Structures
5.1 If statements
if Hungry then
Cook;
Eat;
Wash_Up;
end if;
----
if Today = Sun then
Tomorrow := Mon;
else
Tomorrow := Day'Succ(Today);
end if;
----
if A = 0.0 then
-- linear case
else
if B**2 - 4.0*A*C >= 0.0 then
-- real roots
else
-- complex roots
end if;
end if;
----
if A = 0.0 then
-- linear case
elsif B**2 - 4.0*A*C >= 0.0 then
-- real roots
else
-- complex roots
end if;
----
if Order = Left then
Turn_Left;
else
if Order = Right then
Turn_Right;
else
if Order = Back then
Turn_Back;
end if;
end if;
end if;
----
if Order = Left then
Turn_Left;
elsif Order = Right then
Turn_Right;
elsif Order = Back then
Turn_Back;
end if;
5.2 Case statements
case Order is
when Left => Turn_Left;
when Right => Turn_Right;
when Back => Turn_Back;
when On => null;
end case;
----
case Today is
when Mon Tues Wed Thu => Work;
when Fri => Work; Party;
when Sat Sun => null;
end case;
----
case Today is
when Mon .. Thu => Work;
when Fri => Work; Party;
when others => null;
end case;
----
case Today is
when Weekday => Work;
if Today = Fri then
Party;
end if;
when others => null;
end case;
----
case Weekday'(Today) is
when Mon .. Thu => Work;
when Fri => Work; Party;
end case;
5.3 Loop statements
loop
Work;
Eat;
Sleep;
end loop;
----
declare
E: Real := 1.0;
I: Integer := 0;
Term: Real := 1.0;
begin
loop
I := I + 1;
Term := Term / Real(I);
E := E + Term;
end loop;
...
----
loop
if I = N then exit; end if;
I := I + 1;
Term := Term / Real(I);
E := E + Term;
end loop;
----
loop
exit when I = N;
I := I + 1;
Term := Term / Real(I);
E := E + Term;
end loop;
----
while I /= N loop
I := I + 1;
Term := Term / Real(I);
E := E + Term;
end loop;
----
for I in 1 .. N loop
Term := Term / Real(I);
E := E + Term;
end loop;
----
for I in 1 .. N loop
for J in 1 .. M loop
-- if values of I and J satisfy
-- some condition then leave nested loop
end loop;
end loop;
----
Search:
for I in 1 .. N loop
for J in 1 .. M loop
if condition_OK then
I_Value := I;
J_Value := J;
exit Search;
end if;
end loop;
end loop Search;
-- control passes here
Chapter 6 Composite Types
6.1 Arrays
for I in A'Range loop
A(I) := 0.0;
end loop;
for I in AA'Range(1) loop
for J in AA'Range(2) loop
AA(I, J) := 0.0;
end loop;
end loop;
6.3 Array aggregates
type Event is (Birth, Accession, Death);
type Monarch is (William_I, William_II, Henry_I, ... ,
Victoria, Edward_VII, George_V, ... );
...
Royal_Events: constant array (Monarch, Event) of Integer
:= (William_I => (1027, 1066, 1087),
William_II => (1056, 1087, 1100),
Henry_I => (1068, 1100, 1135),
...
Victoria => (1819, 1837, 1901),
Edward_VII => (1841, 1901, 1910),
George_V => (1865, 1910, 1936),
... );
6.5 Arrays of arrays and slices
Zoo: constant String_Array := ("aardvark",
"baboon ",
"camel ",
"dolphin ",
"elephant",
...
"zebra ");
6.6 One-dimensional array operations
White: constant Colour := (F, F, F);
Red: constant Colour := (T, F, F);
Yellow: constant Colour := (F, T, F);
Blue: constant Colour := (F, F, T);
Green: constant Colour := (F, T, T);
Purple: constant Colour := (T, F, T);
Orange: constant Colour := (T, T, F);
Black: constant Colour := (T, T, T);
6.7 Records
type Month_Name is (Jan, Feb, Mar, Apr, May, Jun, Jul,
Aug, Sep, Oct, Nov, Dec);
type Date is
record
Day: Integer range 1 .. 31;
Month: Month_Name;
Year: Integer;
end record;
Chapter 7 Subprograms
7.1 Functions
function Sqrt(X: Real) return Real is
R: Real;
begin
-- compute value of Sqrt(X) in R
return R;
end Sqrt;
----
function Sign(X: Integer) return Integer is
begin
if X > 0 then
return +1;
elsif X < 0 then
return -1;
else
return 0;
end if;
end Sign;
----
function Factorial(N: Positive) return Positive is
begin
if N = 1 then
return 1;
else
return N * Factorial(N-1);
end if;
end Factorial;
----
function Sum(A: Vector) return Real is
Result: Real := 0.0;
begin
for I in A'Range loop
Result := Result + A(I);
end loop;
return Result;
end Sum;
----
function Inner(A, B: Vector) return Real is
Result: Real := 0.0;
begin
for I in A'Range loop
Result := Result + A(I)*B(I);
end loop;
return Result;
end Inner;
----
function Rev(X: Vector) return Vector is
R: Vector(X'Range);
begin
for I in X'Range loop
R(I) := X(X'First+X'Last-I);
end loop;
return R;
end Rev;
7.2 Operators
function "*" (A, B: Vector) return Real is
Result: Real := 0.0;
begin
for I in A'Range loop
Result := Result + A(I)*B(I);
end loop;
return Result;
end "*";
----
function "+" (A: Vector) return Real is
Result: Real := 0.0;
begin
for I in A'Range loop
Result := Result + A(I);
end loop;
return Result;
end "+";
7.3 Procedures
declare
A: constant Integer := 2+P; -- in
B: constant Integer := 37; -- in
C: Integer; -- out
begin
C := A+B; -- body
Q := C; -- out
end;
----
declare
X: Integer := I;
begin
X := X+1;
I := X;
end;
----
I: Integer;
A: array (1 .. 10) of Integer;
procedure Silly(X: in out Integer) is
begin
I := I+1;
X := X+1;
end;
----
procedure Quadratic(A, B, C: in Real; Root_1, Root_2:
out Real; OK: out Boolean) is
D: constant Real := B**2 - 4.0*A*C;
begin
if D < 0.0 or A = 0.0 then
OK := False;
return;
end if;
Root_1 := (-B+Sqrt(D)) / (2.0*A);
Root_2 := (-B-Sqrt(D)) / (2.0*A);
OK := True;
end Quadratic;
----
declare
L, M, N: Real;
P, Q: Real;
Status: Boolean;
begin
-- sets values into L, M and N
Quadratic(L, M, N, P, Q, Status);
if Status then
-- roots are in P and Q
else
-- fails
end if;
end;
----
begin
OK := D >= 0.0 and A /= 0.0;
if not OK then
return;
end if;
Root_1 := ... ;
Root_2 := ... ;
end Quadratic;
Exercise 7.3
A: Vector(1 .. 1);
procedure P(V: Vector) is
begin
A(1) := V(1)+V(1);
A(1) := V(1)+V(1);
end;
...
A(1) := 1.0;
P(A);
7.6 Declarations, scopes and visibility
procedure F( ... ); -- declaration of F
procedure G( ... ) is -- body of G
begin
F( ... );
end G;
procedure F( ... ) is -- body of F repeats
begin -- its specification
G( ... );
end F;
----
procedure P is
I: Integer := 0;
procedure Q is
K: Integer := I;
I: Integer;
J: Integer;
begin
...
end Q;
begin
...
end P;
----
Outer:
declare
I: Integer := 0;
begin
...
declare
K: Integer := I;
I: Integer;
J: Integer := Outer.I;
begin
...
end;
end Outer;
----
L:
for I in AA'Range(1) loop
for I in AA'Range(2) loop
AA(L.I, I) := 0.0;
end loop;
end loop L;
Chapter 8 Overall Structure
8.1 Packages
procedure Push(X: Integer) is
begin
Top := Top+1;
S(Top) := X;
end Push;
function Pop return Integer is
begin
Top := Top-1;
return S(Top+1);
end Pop;
----
package Stack is -- specification
procedure Push(X: Integer);
function Pop return Integer;
end Stack;
package body Stack is -- body
Max: constant := 100;
S: array (1 .. Max) of Integer;
Top: Integer range 0 .. Max;
procedure Push(X: Integer) is
begin
Top := Top+1;
S(Top) := X;
end Push;
function Pop return Integer is
begin
Top := Top-1;
return S(Top+1);
end Pop;
begin -- initialization
Top := 0;
end Stack;
----
declare
package Stack is -- specification
... -- and
... -- body
end Stack;
begin
...
Stack.Push(M);
...
N := Stack.Pop;
...
end;
----
declare
use Stack;
begin
...
Push(M);
...
N := Pop;
...
end;
----
package Diurnal is
type Day is (Mon, Tue, Wed, Thu, Fri, Sat, Sun);
subtype Weekday is Day range Mon .. Fri;
Tomorrow: constant array (Day) of Day
:= (Tue, Wed, Thu, Fri, Sat, Sun, Mon);
Next_Work_Day: constant array (Weekday) of Weekday
:= (Tue, Wed, Thu, Fri, Mon);
end Diurnal;
8.2 Library units
package Stack is
...
end Stack;
package body Stack is
...
end Stack;
----
with Stack;
procedure Main is
use Stack;
M, N: Integer;
begin
...
Push(M);
...
N := Pop;
...
end Main;
8.3 Subunits
package body Stack is
Max: constant := 100;
S: array (1 .. Max) of Integer;
Top: Integer range 0 .. Max;
procedure Push(X: Integer) is separate; -- stub
function Pop return Integer is separate; -- stub
begin
Top := 0;
end Stack;
----
separate (Stack)
procedure Push(X: Integer) is
begin
Top := Top+1;
S(Top) := X;
end Push;
8.4 Scope and visibility
declare
type R is
record
I: Integer;
end record;
type S is
record
I: Integer;
end record;
AR: R;
AS: S;
I: Integer;
begin
...
I := AR.I+AS.I; -- legal
...
end;
----
package P1 is
package P2 is
...
end P2;
...
end P1;
8.5 Renaming
declare
procedure S_Push(X: Integer) renames Stack.Push;
function S_Pop return Integer renames Stack.Pop;
begin
...
S_Push(M);
...
N := S_Pop;
...
end;
----
for I in People'Range loop
Put(People(I).Birth.Day); Put(":");
Put(Month_Name'Pos(People(I).Birth.Month)+1);
Put(":");
Put(People(I).Birth.Year);
end loop;
----
for I in People'Range loop
declare
D: Date renames People(I).Birth;
begin
Put(D.Day); Put(":");
Put(Month_Name'Pos(D.Month)+1);
Put(":");
Put(D.Year);
end;
end loop;
Chapter 9 Private Types
9.1 Normal private types
package Complex_Numbers is
type Complex is
record
Rl, Im: Real;
end record;
I: constant Complex := (0.0, 1.0);
function "+" (X: Complex) return Complex; -- unary +
function "-" (X: Complex) return Complex; -- unary -
function "+" (X, Y: Complex) return Complex;
function "-" (X, Y: Complex) return Complex;
function "*" (X, Y: Complex) return Complex;
function "/" (X, Y: Complex) return Complex;
end;
----
package Complex_Numbers is
type Complex is private;
I: constant Complex;
function "+" (X: Complex) return Complex;
function "-" (X: Complex) return Complex;
function "+" (X, Y: Complex) return Complex;
function "-" (X, Y: Complex) return Complex;
function "*" (X, Y: Complex) return Complex;
function "/" (X, Y: Complex) return Complex;
function Cons(R, I: Real) return Complex;
function Rl_Part(X: Complex) return Real;
function Im_Part(X: Complex) return Real;
private
type Complex is
record
Rl, Im: Real;
end record;
I: constant Complex := (0.0, 1.0);
end;
----
package body Complex_Numbers is
-- unary + -
function "+" (X, Y: Complex) return Complex is
begin
return (X.Rl + Y.Rl, X.Im + Y.Im);
end "+";
-- plus - * / similarly
function Cons(R, I: Real) return Complex is
begin
return (R, I);
end Cons;
function Rl_Part(X: Complex) return Real is
begin
return X.Rl;
end Rl_Part;
-- Im_Part similarly
end Complex_Numbers;
----
declare
use Complex_Numbers;
C, D: Complex;
R, S: Real;
begin
C := Cons(1.5, -6.0);
D := C + I; -- Complex +
R := Rl_Part(D) + 6.0; -- Real +
...
end;
----
private
Pi: constant := 3.14159_26536;
type Complex is
record
R: Real;
Theta: Real range 0.0 .. 2.0*Pi;
end record;
I: constant Complex := (1.0, 0.5*Pi);
end;
Exercise 9.1
package Rational_Numbers is
type Rational is private;
function "+" (X: Rational) return Rational; -- unary +
function "-" (X: Rational) return Rational; -- unary -
function "+" (X, Y: Rational) return Rational;
function "-" (X, Y: Rational) return Rational;
function "*" (X, Y: Rational) return Rational;
function "/" (X, Y: Rational) return Rational;
function "/" (X: Integer; Y: Positive) return Rational;
function Numerator(R: Rational) return Integer;
function Denominator(R: Rational) return Positive;
private
...
end;
9.2 Limited private types
package Stacks is
type Stack is limited private;
procedure Push(S: in out Stack; X: in Integer);
procedure Pop(S: in out Stack; X: out Integer);
function "=" (S, T: Stack) return Boolean;
private
Max: constant := 100;
type Integer_Vector is array (Integer range <>) of Integer;
type Stack is
record
S: Integer_Vector(1 .. Max);
Top: Integer range 0 .. Max := 0;
end record;
end;
----
package body Stacks is
procedure Push(S: in out Stack; X: in Integer) is
begin
S.Top := S.Top+1;
S.S(S.Top) := X;
end Push;
procedure Pop(S: in out Stack; X: out Integer) is
begin
X := S.S(S.Top);
S.Top := S.Top-1;
end Pop;
function "=" (S, T: Stack) return Boolean is
begin
if S.Top /= T.Top then
return False;
end if;
for I in 1 .. S.Top loop
if S.S(I) /= T.S(I) then
return False;
end if;
end loop;
return True;
end "=";
end Stacks;
----
declare
use Stacks;
St: Stack;
Empty: Stack;
...
begin
Push(St, N);
...
Pop(St, M);
...
if St = Empty then
...
end if;
...
end;
9.3 Resource management
package Key_Manager is
type Key is limited private;
procedure Get_Key(K: in out Key);
procedure Return_Key(K: in out Key);
function Valid(K: Key) return Boolean;
...
procedure Action(K: in Key; ... );
...
private
Max: constant := 100; -- number of keys
subtype Key_Code is Integer range 0 .. Max;
type Key is
record
Code: Key_Code := 0;
end record;
end;
package body Key_Manager is
Free: array (Key_Code range 1 .. Key_Code'Last) of
Boolean := (others => True);
function Valid(K: Key) return Boolean is
begin
return K.Code /= 0;
end Valid;
procedure Get_Key(K: in out Key) is
begin
if K.Code = 0 then
for I in Free'Range loop
if Free(I) then
Free(I) := False;
K.Code := I;
return;
end if;
end loop;
-- all keys in use
end if;
end Get_Key;
procedure Return_Key(K: in out Key) is
begin
if K.Code /= 0 then
Free(K.Code) := True;
K.Code := 0;
end if;
end Return_Key;
...
procedure Action(K: in Key; ... ) is
begin
if Valid(K) then
...
end Action;
end Key_Manager;
----
declare
use Key_Manager;
My_Key: Key;
begin
...
Get_Key(My_Key);
...
Action(My_Key, ... );
...
Return_Key(My_Key);
...
end;
Exercise 9.3
package Bank is
subtype Money is Natural;
type Key is limited private;
procedure Open_Account(K: in out Key; M: in Money);
-- open account with initial deposit M
procedure Close_Account(K: in out Key; M: out Money);
-- close account and return balance
procedure Deposit(K: in Key; M: in Money);
-- deposit amount M
procedure Withdraw(K: in out Key; M in out Money);
-- withdraw amount M; if account does not contain M
-- then return what is there and close account
function Statement(K: Key) return Money;
-- returns a statement of current balance
function Valid(K: Key) return Boolean;
-- checks the key is valid
private
...
----
declare
use Key_Manager;
My_Key: Key;
procedure Cheat(Copy: in out Key) is
begin
Return_Key(My_Key);
Action(Copy, ... );
...
end;
begin
Get_Key(My_Key);
Cheat(My_Key);
...
end;
----
declare
use Key_Manager;
My_Key: Key;
procedure Destroy(K: out Key) is
begin
null;
end;
begin
Get_Key(My_Key);
Destroy(My_Key);
...
end;
Chapter 10 Exceptions
10.1 Handling exceptions
begin
-- sequence of statements
exception
when Constraint_Error =>
-- do something
end;
----
begin
Tomorrow := Day'Succ(Today);
exception
when Constraint_Error =>
Tomorrow := Day'First;
end;
----
begin
-- sequence of statements
exception
when Numeric_Error Constraint_Error =>
Put("Numeric or Constraint Error occurred");
...
when Storage_Error =>
Put("Ran out of space");
...
when others =>
Put("Something else went wrong");
...
end;
----
function Tomorrow(Today: Day) return Day is
begin
return Day'Succ(Today);
exception
when Constraint_Error =>
return Day'First;
end Tomorrow;
10.2 Declaring and raising exceptions
declare
use Stack;
begin
...
Push(M);
...
N := Pop;
...
exception
when Constraint_Error =>
-- stack manipulation incorrect?
end;
----
package Stack is
Error: exception;
procedure Push(X: Integer);
function Pop return Integer;
end Stack;
package body Stack is
Max: constant := 100;
S: array (1 .. Max) of Integer;
Top: Integer range 0 .. Max;
procedure Push(X: Integer) is
begin
if Top = Max then
raise Error;
end if;
Top := Top+1;
S(Top) := X;
end Push;
function Pop return Integer is
begin
if Top = 0 then
raise Error;
end if;
Top := Top-1;
return S(Top+1);
end Pop;
begin
Top := 0;
end Stack;
----
declare
use Stack;
begin
...
Push(M);
...
N := Pop;
...
exception
when Error =>
-- stack manipulation incorrect
when others =>
-- something else went wrong
end;
----
declare
use Stack, Key_Manager;
My_Key: Key;
procedure Clean_Up is
begin
Reset;
Return_Key(My_Key);
end;
begin
Get_Key(My_Key);
...
Push(M);
...
Action(My_Key, ... );
...
N := Pop;
...
Return_Key(My_Key);
exception
when Error =>
Put("Stack used incorrectly");
Clean_Up;
when others =>
Put("Something else went wrong");
Clean_Up;
end;
----
procedure Reset is
Junk: Integer;
use Stack;
begin
loop
Junk := Pop;
end loop;
exception
when Error =>
null;
end Reset;
----
exception
when Error =>
Put("Stack used incorrectly");
Clean_Up;
raise Another_Error;
when others =>
...
end;
----
declare
use Stack;
OK: Boolean;
begin
...
Push(M, OK);
if not OK then ... end if;
...
Pop(N, OK);
if not OK then ... end if;
end;
10.3 Checking and exceptions
...
S: array (1 .. Max) of Integer;
Top: Integer range 0 .. Max;
procedure Push(X: Integer) is
begin
Top := Top+1;
S(Top) := X;
end Push;
----
procedure Push(X: Integer) is
begin
if Top = Max then
raise Error;
end if;
Top := Top+1;
S(Top) := X;
end Push;
10.4 Scope of exceptions
declare
procedure P is
X: exception;
begin
raise X;
end P;
begin
P;
exception
when others =>
-- X handled here
end;
----
declare
package P is
procedure F;
procedure H;
end P;
procedure G is
begin
P.H;
exception
when others =>
raise;
end G;
package body P is
X: exception;
procedure F is
begin
G;
exception
when X =>
Put("Got it!");
end F;
procedure H is
begin
raise X;
end H;
end P;
begin
P.F;
end;
----
procedure F(N: Integer) is
X: exception;
begin
if N = 0 then
raise X;
else
F(N-1);
end if;
exception
when X =>
Put("Got it!");
raise;
when others =>
null;
end F;
----
procedure Withdraw (K: in out Key; M: in out Money) is
begin
if Valid (K) then
if M > amount remaining then
M := amount remaining;
Free(K.Code) := True;
K.Code := 0;
raise Alarm;
else
...
end if;
end if;
end Withdraw;
Exercise 10.4
procedure P is
begin
P;
exception
when Storage_Error =>
P;
end P;
Chapter 11 Advanced Types
11.1 Discriminated record types
function Trace(M: Matrix) return Real is
Sum: Real := 0.0;
begin
if M'First(1) /= M'First(2) or M'Last(1) /= M'Last(2) then
raise Non_Square;
end if;
for I in M'Range loop
Sum := Sum + M(I, I);
end loop;
return Sum;
end Trace;
----
function Trace(M: Square) return Real is
Sum: Real := 0.0;
begin
for I in M.Mat'Range loop
Sum := Sum + M.Mat(I, I);
end loop;
return Sum;
end Trace;
----
function Transpose(M: Square) return Square is
R: Square(M.Order);
begin
for I in 1 .. M.Order loop
for J in 1 .. M.Order loop
R.Mat(I, J) := M.Mat(J, I);
end loop;
end loop;
return R;
end Transpose;
----
package Stacks is
type Stack(Max: Natural) is limited private;
procedure Push(S: in out Stack; X: in Integer);
procedure Pop(S: in out Stack; X out Integer);
function "=" (S, T: Stack) return Boolean;
private
type Integer_Vector is array (Integer range <>) of Integer;
type Stack(Max: Natural) is
record
S: Integer_Vector(1 .. Max);
Top: Integer := 0;
end record;
end;
11.2 Default discriminants
function Normal(P: Polynomial) return Polynomial is
Size: Integer := P.N;
begin
while Size > 0 and P.A(Size) = 0 loop
Size := Size-1;
end loop;
return (Size, P.A(0 .. Size));
end Normal;
----
subtype String_Size is Integer range 0 .. 80;
type V_String(N: String_Size := 0) is
record
S: String(1 .. N);
end record;
11.3 Variant parts
type Gender is (Male, Female);
type Person(Sex: Gender) is
record
Birth: Date;
case Sex is
when Male =>
Bearded: Boolean;
when Female =>
Children: Integer;
end case;
end record;
----
type Gender is (Male, Female, Neuter);
type Mutant(Sex: Gender := Neuter) is
record
Birth: Date;
case Sex is
when Male =>
Bearded: Boolean;
when Female =>
Children: Integer;
when Neuter =>
null;
end case;
end record;
11.4 Access Types
type Cell;
type Link is access Cell;
type Cell is
record
Value: Integer;
Next: Link;
end record;
L: Link;
----
function Sum(List: Link) return Integer is
L: Link := List;
S: Integer := 0;
begin
while L /= null loop
S := S+L.Value;
L := L.Next;
end loop;
return S;
end Sum;
----
type Node;
type Tree is access Node;
type Node is
record
Value: Real;
Left, Right: Tree;
end record;
----
procedure Sort(A: in out Vector) is
I: Integer;
Base: Tree := null;
procedure Insert(T: in out Tree; V: Real) is
begin
if T = null then
T := new Node'(V, null, null);
else
if V < T.Value then
Insert(T.Left, V);
else
Insert(T.Right, V);
end if;
end if;
end Insert;
procedure Output(T: Tree) is
begin
if T /= null then
Output(T.Left);
A(I) := T.Value;
I := I+1;
Output(T.Right);
end if;
end Output;
begin -- body of Sort
for J in A'Range loop
Insert(Base, A(J));
end loop;
I := A'First;
Output(Base);
end Sort;
11.5 Access types and private types
package Stacks is
type Stack is limited private;
procedure Push(S: in out Stack; X: in Integer);
procedure Pop(S: in out Stack; X: out Integer);
private
type Cell;
type Stack is access Cell;
type Cell is
record
Value: Integer;
Next: Stack;
end record;
end;
package body Stacks is
procedure Push(S: in out Stack; X: in Integer) is
begin
S := new Cell'(X, S);
end;
procedure Pop(S: in out Stack; X: out Integer) is
begin
X := S.Value;
S := S.Next;
end;
end Stacks;
----
function "=" (S, T: Stack) return Boolean is
SS: Stack := S;
TT: Stack := T;
begin
while SS /= null and TT /= null loop
SS := SS.Next;
TT := TT.Next;
if SS.Value /= TT.Value then
return False;
end if;
end loop;
return SS = TT; -- True if both null
end;
----
type Cell;
type Link is access Cell;
type Cell is
record
Value: Integer;
Next: Link;
end record;
type Stack is
record
List: Link;
end record;
Exercise 11.5
package Queues is
Empty: exception;
type Queue is limited private;
procedure Join(Q: in out Queue; X: in Item);
procedure Remove(Q: in out Queue; X: out Item);
function Length(Q: Queue) return Integer;
private
11.6 Access types and constraints
type Person;
type Person_Name is access Person;
type Person is
record
Sex: Gender;
Birth: Date;
Spouse: Person_Name;
Father: Person_Name;
First_Child: Person_Name;
Next_Sibling: Person_Name;
end record;
----
type Person(Sex: Gender);
type Person_Name is access Person;
type Person(Sex: Gender) is
record
Birth: Date;
Father: Person_Name(Male);
Next_Sibling: Person_Name;
case Sex is
when Male =>
Wife: Person_Name(Female);
when Female =>
Husband: Person_Name(Male);
First_Child: Person_Name;
end case;
end record;
----
procedure Marry(Bride: Womans_Name;
Groom: Mans_Name) is
begin
if Bride.Husband /= null or Groom.Wife /= null then
raise Bigamy;
end if;
Bride.Husband := Groom;
Groom.Wife := Bride;
end Marry;
----
function Spouse(P: Person_Name) return Person_Name is
begin
case P.Sex is
when Male =>
return P.Wife;
when Female =>
return P.Husband;
end case;
end Spouse;
----
function New_Child(Mother: Womans_Name;
Boy_Or_Girl: Gender; Birthday: Date)
return Person_Name is
Child: Person_Name;
begin
if Mother.Husband = null then
raise Illegitimate;
end if;
Child := new Person(Boy_Or_Girl);
Child.Birth := Birthday;
Child.Father := Mother.Husband;
declare
Last: Person_Name := Mother.First_Child;
begin
if Last = null then
Mother.First_Child := Child;
else
while Last.Next_Sibling /= null loop
Last := Last.Next_Sibling;
end loop;
Last.Next_Sibling := Child;
end if;
end;
return Child;
end New_Child;
11.7 Derived types
type Cell;
type Link is access Cell;
type Cell is
record
Value: Integer;
Next: Link;
end record;
type Stack is new Link;
----
function "=" (S, T: Stack) return Boolean is
SL: Link := Link(S);
TL: Link := Link(T);
begin
-- as the answer to Exercise 11.5(2)
end "=";
Chapter 12 Numeric Types
12.4 Fixed point types
private
Pi: constant := 3.14159_26536;
type Angle is delta 0.1 range -4*Pi .. 4*Pi;
for Angle'Small use Pi*2**(-13);
type Complex is
record
R: Real;
Theta: Angle range -Pi .. Pi;
end record;
I: constant Complex := (1.0, 0.5*Pi);
end;
----
function Normal(A: Angle) return Angle is
begin
if A >= Pi then
return A - Angle(2*Pi);
elsif A < -Pi then
return A + Angle(2*Pi);
else
return A;
end if;
end Normal;
----
package body Complex_Numbers is
function Normal ... -- as above
...
function "*" (X, Y: Complex) return Complex is
begin
return (X.R * Y.R, Normal(X.Theta + Y.Theta));
end "*";
...
function Rl_Part(X: Complex) return Real is
begin
return X.R * Cos(X.Theta);
end Rl_Part;
...
end Complex_Numbers;
Chapter 13 Generics
13.1 Declarations and instantiations
procedure Swap(X, Y: in out Real) is
T: Real;
begin
T := X; X := Y; Y := T;
end;
----
generic
type Item is private;
procedure Exchange(X, Y: in out Item);
procedure Exchange(X, Y: in out Item) is
T: Item;
begin
T := X; X := Y; Y := T;
end;
----
generic
Max: Positive;
type Item is private;
package Stack is
procedure Push(X: Item);
function Pop return Item;
end Stack;
package body Stack is
S: array (1 .. Max) of Item;
Top: Integer range 0 .. Max;
-- etc. as before but with Integer
-- replaced by Item
end Stack;
----
declare
package My_Stack is new Stack(100, Real);
use My_Stack;
begin
...
Push(X);
...
Y := Pop;
...
end;
----
generic
Max: Positive;
type Item is private;
package Stack is
Error: exception;
procedure Push(X: Item);
function Pop return Item;
end Stack;
----
package All_Stacks is
Error: exception;
generic
Max: Positive;
type Item is private;
package Stack is
procedure Push(X: Item);
function Pop return Item;
end Stack;
end All_Stacks;
package body All_Stacks is
package body Stack is
...
end Stack;
end All_Stacks;
----
generic
type Thing is private;
procedure Cab(A, B, C: in out Thing);
procedure Cab(A, B, C: in out Thing) is
procedure Swap is new Exchange(Item => Thing);
begin
Swap(A, B);
Swap(A, C);
end Cab;
13.2 Type parameters
generic
type T is (<>);
function Next(X: T) return T;
function Next(X: T) return T is
begin
if X=T'Last then
return T'First;
else
return T'Succ(X);
end if;
end Next;
----
generic
type Real is digits <>;
package Generic_Complex_Numbers is
type Complex is private;
-- as before
I: constant Complex := (0.0, 1.0);
end;
----
generic
type Index is (<>);
type Floating is digits <>;
type Vec is array (Index range <>) of Floating;
function Sum(A: Vec) return Floating;
function Sum(A: Vec) return Floating is
Result: Floating := 0.0;
begin
for I in A'Range loop
Result := Result+A(I);
end loop;
return Result;
end Sum;
----
generic
type Base is (<>);
package Set_Of is
type Set is private;
type List is array (Positive range <>) of Base;
Empty, Full: constant Set;
function Make_Set(X: List) return Set;
function Make_Set(X: Base) return Set;
function Decompose(X: Set) return List;
function "+" (X, Y: Set) return Set; -- union
function "*" (X, Y: Set) return Set; -- intersection
function "-" (X, Y: Set) return Set; -- symmetric difference
function "<" (X: Base; Y: Set) return Boolean; -- inclusion
function "<=" (X, Y: Set) return Boolean; -- contains
function Size(X: Set) return Natural; -- no of elements
private
type Set is array (Base) of Boolean;
Empty: constant Set := (Set'Range => False);
Full: constant Set := (Set'Range => True);
end;
----
generic
type Base is (<>);
type Index is (<>);
type List is array (Index range <>) of Base;
package Nice_Set_Of is
type Set is private;
function Empty return Set;
function Full return Set;
...
private
----
type Primary_List is array (Positive range <>) of Primary;
package Primary_Sets is new Nice_Set_Of(Base => Primary,
Index => Positive,
List => Primary_List);
type Colour is new Primary_Sets.Set;
13.3 Subprogram parameters
generic
type Index is (<>);
type Item is (<>);
type Collection is array (Index range <>) of Item;
procedure Sort(C: in out Collection);
----
procedure Sort(C: in out Collection) is
Min: Index;
Temp: Item;
begin
for I in C'First .. Index'Pred(C'Last) loop
Min := I;
for J in Index'Succ(I) .. C'Last loop
if C(J) < C(Min) then Min := J; end if; -- use of <
end loop;
Temp := C(I); C(I) := C(Min); C(Min) := Temp;
end loop;
end Sort;
----
generic
type Index is (<>);
type Item is private;
type Collection is array (Index range <>) of Item;
with function "<" (X, Y: Item) return Boolean;
procedure Sort(C: in out Collection);
----
procedure Reverse_Sort_Vector is
new Sort(Index => Integer,
Item => Real,
Collection => Vector,
"<" => ">");
----
subtype String_3 is String(1 .. 3);
procedure Sort_String_3_Array is
new Sort(Positive, String_3, String_3_Array, "<");
...
Sort_String_3_Array(Farmyard);
----
type Date_Array is array (Positive range <>) of Date;
function "<" (X, Y: Date) return Boolean is
begin
if X.Year /= Y.Year then
return X.Year < Y.Year;
elsif X.Month /= Y.Month then
return X.Month < Y.Month;
else
return X.Day < Y.Day;
end if;
end "<";
procedure Sort_Date_Array is
new Sort(Positive, Date, Date_Array);
----
generic
type Index is (<>);
type Item is private;
type Vec is array (Index range <>) of Item;
with function "+" (X, Y: Item) return Item;
function Apply(A: Vec) return Item;
function Apply(A: Vec) return Item is
Result: Item := A(A'First);
begin
for I in Index'Succ(A'First) .. A'Last loop
Result := Result+A(I);
end loop;
return Result;
end Apply;
----
function G(T: Real) return Real is
begin
return Exp(T)*Sin(T);
end;
function Integrate_G is new Integrate(G);
13.4 The mathematical library
with Elementary_Functions_Exceptions;
generic
type Float_Type is digits <>;
package Generic_Elementary_Functions is
function Sqrt (X: Float_Type) return Float_Type;
function Log (X: Float_Type) return Float_Type;
function Log (X, Base: Float_Type) return Float_Type;
function Exp (X: Float_Type) return Float_Type;
function "**" (Left, Right: Float_Type) return Float_Type;
function Sin (X: Float_Type) return Float_Type;
function Sin (X, Cycle: Float_Type) return Float_Type;
function Cos (X: Float_Type) return Float_Type;
function Cos (X, Cycle: Float_Type) return Float_Type;
function Tan (X: Float_Type) return Float_Type;
function Tan (X, Cycle: Float_Type) return Float_Type;
function Cot (X: Float_Type) return Float_Type;
function Cot (X, Cycle: Float_Type) return Float_Type;
function Arcsin (X: Float_Type) return Float_Type;
function Arcsin (X, Cycle: Float_Type) return Float_Type;
function Arccos (X: Float_Type) return Float_Type;
function Arccos (X, Cycle: Float_Type) return Float_Type;
function Arctan (Y: Float_Type; X: Float_Type := 1.0)
return Float_Type;
function Arctan (Y: Float_Type; X: Float_Type := 1.0;
Cycle: Float_Type) return Float_Type;
function Arccot (X: Float_Type; Y: Float_Type := 1.0)
return Float_Type;
function Arccot (X: Float_Type; Y: Float_Type := 1.0;
Cycle: Float_Type) return Float_Type;
function Sinh (X: Float_Type) return Float_Type;
function Cosh (X: Float_Type) return Float_Type;
function Tanh (X: Float_Type) return Float_Type;
function Coth (X: Float_Type) return Float_Type;
function Arcsinh (X: Float_Type) return Float_Type;
function Arccosh (X: Float_Type) return Float_Type;
function Arctanh (X: Float_Type) return Float_Type;
function Arccoth (X: Float_Type) return Float_Type;
Argument_Error: exception
renames Elementary_Functions_Exceptions.Argument_Error;
end Generic_Elementary_Functions;
----
generic
type Real_Type is digits <>;
type Complex_Type is private;
with function Cons(R, I: Real_Type) return Complex_Type is <>;
with function Cons_Polar(R, Theta: Real_Type) return
Complex_Type is <>;
with function Rl_Part(X: Complex_Type) return Real_Type is <>;
with function Im_Part(X: Complex_Type) return Real_Type is <>;
with function "abs" (X: Complex_Type) return Real_Type is <>;
with function Arg (X: Complex_Type) return Real_Type is <>;
with function Sqrt (X: Real_Type) return Real_Type is <>;
with function Log (X: Real_Type) return Real_Type is <>;
with function Exp (X: Real_Type) return Real_Type is <>;
with function Sin (X: Real_Type) return Real_Type is <>;
with function Cos (X: Real_Type) return Real_Type is <>;
with function Sinh (X: Real_Type) return Real_Type is <>;
with function Cosh (X: Real_Type) return Real_Type is <>;
package Generic_Complex_Functions is
function Sqrt(X: Complex_Type) return Complex_Type;
function Log (X: Complex_Type) return Complex_Type;
function Exp (X: Complex_Type) return Complex_Type;
function Sin (X: Complex_Type) return Complex_Type;
function Cos (X: Complex_Type) return Complex_Type;
end Generic_Complex_Functions;
----
type My_Real is digits 9;
package My_Elementary_Functions is
new Generic_Elementary_Functions(Float_Type => My_Real);
package My_Complex_Numbers is
new Generic_Complex_Numbers(Real => My_Real);
use My_Elementary_Functions, My_Complex_Numbers;
package My_Complex_Functions is
new Generic_Complex_Functions(My_Real, Complex);
use My_Complex_Functions;
Chapter 14 Tasking
14.1 Parallelism
task T is -- specification
...
end T;
task body T is -- body
...
end T;
----
procedure Shopping is
begin
Buy_Meat;
Buy_Salad;
Buy_Wine;
end;
----
procedure Shopping is
task Get_Salad;
task body Get_Salad is
begin
Buy_Salad;
end Get_Salad;
task Get_Wine;
task body Get_Wine is
begin
Buy_Wine;
end Get_Wine;
begin
Buy_Meat;
end Shopping;
14.2 The rendezvous
procedure Shopping is
task Get_Salad is
entry Pay(M: in Money);
entry Collect(S: out Salad);
end Get_Salad;
task body Get_Salad is
Cash: Money;
Food: Salad;
begin
accept Pay(M: in Money) do
Cash := M;
end Pay;
Food := Buy_Salad(Cash);
accept Collect(S: out Salad) do
S := Food;
end Collect;
end Get_Salad;
-- Get_Wine similarly
begin
Get_Salad.Pay(50);
Get_Wine.Pay(100);
MM := Buy_Meat(200);
Get_Salad.Collect(SS);
Get_Wine.Collect(WW);
end Shopping;
----
task Buffering is
entry Put(X: in Item);
entry Get(X: out Item);
end;
task body Buffering is
V: Item;
begin
loop
accept Put(X: in Item) do
V := X;
end Put;
accept Get(X: out Item) do
X := V;
end Get;
end loop;
end Buffering;
Exercise 14.2
task Build_Complex is
entry Put_Rl(X: in Real);
entry Put_Im(X: in Real);
entry Get_Comp(X: out Complex);
end;
14.3 Timing and scheduling
task Buffering is
pragma Priority(7);
entry Put ...
...
end;
----
package Calendar is
type Time is private;
subtype Year_Number is Integer range 1901 .. 2099;
subtype Month_Number is Integer range 1 .. 12;
subtype Day_Number is Integer range 1 .. 31;
subtype Day_Duration is Duration range 0.0 .. 86_400.0;
function Clock return Time;
function Year(Date: Time) return Year_Number;
function Month(Date: Time) return Month_Number;
function Day(Date: Time) return Day_Number;
function Seconds(Date: Time) return Day_Duration;
procedure Split(Date: in Time;
Year: out Year_Number;
Month: out Month_Number;
Day: out Day_Number;
Seconds: out Day_Duration);
function Time_Of(Year: Year_Number;
Month: Month_Number;
Day: Day_Number;
Seconds: Day_Duration := 0.0) return Time;
function "+" (Left: Time; Right: Duration) return Time;
function "+" (Left: Duration; Right: Time) return Time;
function "-" (Left: Time; Right: Duration) return Time;
function "-" (Left: Time; Right: Time) return Duration;
function "<" (Left, Right: Time) return Boolean;
function "<=" (Left, Right: Time) return Boolean;
function ">" (Left, Right: Time) return Boolean;
function ">=" (Left, Right: Time) return Boolean;
Time_Error: exception;
-- can be raised by Time_Of, +, and -
private
-- implementation dependent
end Calendar;
----
declare
use Calendar;
Interval: constant Duration := 5*Minutes;
Next_Time: Time := First_Time;
begin
loop
delay Next_Time - Clock;
Action;
Next_Time := Next_Time + Interval;
end loop;
end;
14.4 Simple select statements
package Protected_Variable is
procedure Read(X: out Item);
procedure Write(X: in Item);
end;
package body Protected_Variable is
V: Item;
procedure Read(X: out Item) is
begin
X := V;
end;
procedure Write(X: in Item) is
begin
V := X;
end;
begin
V := initial value;
end Protected_Variable;
----
type Item is
record
X_Coord: Real;
Y_Coord: Real;
end record;
----
task Protected_Variable is
entry Read(X: out Item);
entry Write(X: in Item);
end;
task body Protected_Variable is
V: Item;
begin
accept Write(X: in Item) do
V := X;
end;
loop
select
accept Read(X: out Item) do
X := V;
end;
or
accept Write(X: in Item) do
V := X;
end;
end select;
end loop;
end Protected_Variable;
----
task Buffering is
entry Put(X: in Item);
entry Get(X: out Item);
end;
task body Buffering is
N: constant := 8; -- for instance
A: array (1 .. N) of Item;
I, J: Integer range 1 .. N := 1;
Count: Integer range 0 .. N := 0;
begin
loop
select
when Count < n ="">
accept Put(X: in Item) do
A(I) := X;
end;
I := I mod N+1; Count := Count+1;
or
when Count > 0 =>
accept Get(X: out Item) do
X := A(J);
end;
J := J mod N+1; Count := Count-1;
end select;
end loop;
end Buffering;
----
package Reader_Writer is
procedure Read(X: out Item);
procedure Write(X: in Item);
end;
package body Reader_Writer is
V: Item;
task Control is
entry Start;
entry Stop;
entry Write(X: in Item);
end;
task body Control is
Readers: Integer := 0;
begin
accept Write(X: in Item) do
V := X;
end;
loop
select
accept Start;
Readers := Readers+1;
or
accept Stop;
Readers := Readers-1;
or
when Readers = 0 =>
accept Write(X: in Item) do
V := X;
end;
end select;
end loop;
end Control;
procedure Read(X: out Item) is
begin
Control.Start;
X := V;
Control.Stop;
end Read;
procedure Write(X: in Item) is
begin
Control.Write(X);
end Write;
end Reader_Writer;
----
select
when Write'Count = 0 =>
accept Start;
Readers := Readers+1;
or
accept Stop;
Readers := Readers-1;
or
when Readers = 0 =>
accept Write(X: in Item) do
V := X;
end;
end select;
14.5 Timed and conditional rendezvous
select
accept Read( ... ) do
...
end;
or
accept Write( ... ) do
...
end;
or
delay 10*Minutes;
-- time out statements
end select;
----
Operator.Call("Put out fire");
select
accept Acknowledge;
or
delay 1*Minutes;
Fire_Brigade.Call;
end select;
----
select
accept Read( ... ) do
...
end;
or
accept Write( ... ) do
...
end;
else
-- alternative statements
end select;
----
select
accept Acknowledge;
else
delay 1*Minutes;
Fire_Brigade.Call;
end select;
----
select
Operator.Call("Put out fire");
or
delay 1*Minutes;
Fire_Brigade.Call;
end select;
----
select
Operator.Call("Put out fire");
else
Fire_Brigade.Call;
end select;
----
procedure Write(X: in Item; T: Duration; OK: out Boolean) is
begin
select
Control.Write(X);
OK := True;
or
delay T;
OK := False;
end select;
end Write;
----
package body Reader_Writer is
V: Item;
type Service is (Read, Write);
task Control is
entry Start(S: Service);
entry Stop_Read;
entry Write;
entry Stop_Write;
end Control;
task body Control is
Readers: Integer := 0;
Writers: Integer := 0;
begin
loop
select
when Writers = 0 =>
accept Start(S: Service) do
case S is
when Read =>
Readers := Readers+1;
when Write =>
Writers := 1;
end case;
end Start;
or
accept Stop_Read;
Readers := Readers-1;
or
when Readers = 0 =>
accept Write;
or
accept Stop_Write;
Writers := 0;
end select;
end loop;
end Control;
procedure Read(X: out Item) is
begin
Control.Start(Read);
X := V;
Control.Stop_Read;
end Read;
procedure Write(X: in Item) is
begin
Control.Start(Write);
Control.Write;
V := X;
Control.Stop_Write;
end Write;
end Reader_Writer;
----
task Control is
entry Start(S: Service);
entry Stop;
end Control;
task body Control is
Readers: Integer := 0;
begin
loop
select
accept Start(S: Service) do
case S is
when Read =>
Readers := Readers+1;
when Write =>
while Readers > 0 loop
accept Stop; -- from readers
Readers := Readers-1
end loop;
end case;
end Start;
if Readers = 0 then
accept Stop; -- from the writer
end if;
or
accept Stop; -- from a reader
Readers := Readers-1;
end select;
end loop;
end Control;
procedure Read(X: out Item) is
begin
Control.Start(Read);
X := V;
Control.Stop;
end Read;
procedure Write(X: in Item) is
begin
Control.Start(Write);
V := X;
Control.Stop;
end Write;
14.6 Task types and activation
task type T is
entry E( ... );
end T;
task body T is
...
end T;
----
type Rec is
record
CT: T;
...
end record;
R: Rec;
----
declare
...
A: T;
B: T;
...
begin
...
end;
----
type R is
record
A: T;
I: Integer := E;
B: T;
end record;
----
declare
XA: T;
XI: Integer := E;
XB: T;
begin
----
task type Mailbox is
entry Deposit(X: in Item);
entry Collect(X: out Item);
end;
task body Mailbox is
Local: Item;
begin
accept Deposit(X: in Item) do
Local := X;
end;
accept Collect(X: out Item) do
X := Local;
end;
end Mailbox;
----
task Server is
entry Request(A: Address; X: Item);
end;
task body Server is
Reply: Address;
Job: Item;
begin
loop
accept Request(A: Address; X: Item) do
Reply := A;
Job := X;
end;
-- work on job
Reply.Deposit(Job);
end loop;
end Server;
task User;
task body User is
My_Box: Address := new Mailbox;
My_Item: Item;
begin
Server.Request(My_Box, My_Item);
-- do something while waiting
My_Box.Collect(My_Item);
end User;
----
select
My_Box.Collect(My_Item);
-- item collected successfully
else
-- not ready yet
end select;
----
task body Mailbox is
begin
accept Deposit(X: in Item) do
accept Collect(X: out Item) do
Collect.X := Deposit.X;
end;
end;
end Mailbox;
14.7 Termination and exceptions
task body Protected_Variable is
V: Item;
begin
accept Write(X: in Item) do
V := X;
end;
loop
select
accept Read(X: out Item) do
X := V;
end;
or
accept Write(X: in Item) do
V := X;
end;
or
terminate;
end select;
end loop;
end Protected_Variable;
----
select
T.Closedown;
or
delay 60*Seconds;
abort T;
end select;
----
select
accept Closedown;
-- tidy up and die
else
-- carry on normally
end select;
----
select
T.Closedown;
delay 10*Seconds;
or
delay 60*Seconds;
end select;
abort T;
----
accept Closedown do
loop
Put("Can't catch me");
end loop;
end;
----
task body Control is
Readers: Integer := 0;
begin
loop
select
accept Start(S: Service) do
case S is
when Read =>
Readers := Readers+1;
when Write =>
while Readers > 0 loop
accept Stop; -- from readers
Readers := Readers-1;
end loop;
end case;
end Start;
if Readers = 0 then
accept Stop; -- from the writer
end if;
or
accept Stop; -- from a reader
Readers := Readers-1;
end select;
end loop;
end Control;
----
package body Reader_Writer is
V: Item;
type Service is (Read, Write);
task type Read_Agent is
entry Read(X: out Item);
end;
type RRA is access Read_Agent;
task Control is
entry Start(S: Service);
entry Stop;
end;
task body Control is
-- as before
end Control;
task body Read_Agent is
begin
select
accept Read(X: out Item) do
Control.Start(Read);
X := V;
Control.Stop;
end;
or
terminate;
end select;
end Read_Agent;
procedure Read