LA AdaTEC Ada Fair `84 Programs (2 of 2)
adatrain at trwspp.UUCP
adatrain at trwspp.UUCP
Mon Oct 1 03:39:12 AEST 1984
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)floatvec.ada 1.2 Date: 9/21/84
--
-- Author: Edward Colbert
-- Ada Technology Group
-- Information Software Systems Lab
-- Defense Systems Group
-- TRW
-- Redondo Beach, CA
--
-- This program measures the time required for the adding of the
-- elements of a large floating point vector
--
-- Note: In order for the measurement to be meaningful, it must be the
-- only program executing while the test is run.
--
-- Please set Vector_Size large enough to provide at least two significant
-- digits in the average times, i.e., the difference between
-- the elapsed time and the loop time must be at least 100 times
-- Duration'Small & at least 100 times System.Tick.
--
with Text_IO; use Text_IO;
with Calendar; use Calendar;
with System; use System;
procedure Float_Vector_Add_Test is
Vector_Size : constant Positive := 1000;
type Real_Time is digits Max_Digits;
Start_Time : Time;
Loop_Time : Duration;
Elapsed_Time : Duration;
Average_Time : Real_Time;
package Duration_IO is new Fixed_IO (Duration);
use Duration_IO;
package Real_Time_IO is new Float_IO (Real_Time);
use Real_Time_IO;
package Int_IO is new Integer_IO (Integer);
use Int_IO;
type vector is array (1..Vector_Size) of Float;
v1, v2, vector_result: vector;
count: integer := integer'first; -- used in timing loop
begin
-- Initialize Vectors
for N in vector'range loop
v1(N) := float (N);
v2(N) := float (vector'last - N + 1);
end loop;
-- Measure the timing loop overhead.
Start_Time := Clock;
for N in vector'range loop
count := count + 1; -- prevent optimization
end loop;
Loop_Time := Clock - Start_Time;
-- Measure the time including the adding of vector elements
Start_Time := Clock;
for N in vector'range loop
count := count + 1; -- prevent optimization
vector_result (n) := v1(n) + v2(n);
end loop;
Elapsed_Time := Clock - Start_Time;
Put("Loop time = ");
Put(Loop_Time, Fore => 0);
Put(" seconds for ");
Put(Vector_Size, Width => 0);
Put_Line(" iterations");
Put("Elapsed time = ");
Put(Elapsed_Time, Fore => 0);
Put(" seconds for ");
Put(Vector_Size, Width => 0);
Put_Line(" iterations (1 iteration/element)");
Average_Time := Real_Time(Elapsed_Time - Loop_Time)/Real_Time(Vector_Size);
Put("Average time for adding each element = ");
Put(Average_Time, Fore => 0);
Put_Line(" seconds");
New_Line;
if (Elapsed_Time - Loop_Time < 100 * Duration'Small or
Elapsed_Time - Loop_Time < 100 * System.Tick) then
Put_Line("** TEST FAILED (due to insufficient precision)! **");
else
Put_Line("** TEST PASSED **");
end if;
end Float_Vector_Add_Test;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)friend.ada 1.1 Date: 5/30/84
--
-- Author: Bryce Bardin
-- Ada Projects Section
-- Software Engineering Division
-- Ground Systems Group
-- Hughes Aircraft Company
-- Fullerton, CA
--
-- The purpose of this program is to determine how "friendly" the Ada
-- compiler is with regard to warning about the use of uninitialized
-- objects, exceptions which will always be raised, and both warning
-- about and removal of code that will never be executed.
-- Compilers may be graded by the number of instances they catch in each
-- of the three categories: set/use errors, 'hard' exceptions, and
-- 'dead' code removal. A perfect score is: 12, 3, and 4, respectively.
-- Detection of set/use errors encountered during execution will not be
-- counted in the score even though it may be a useful feature to have.
-- Appropriate supporting evidence, such as an assembly listing, must be
-- supplied if dead code removal is claimed.
-- N.B.: It is not expected that any compiler will get a perfect score!
--
package Global is
G : Integer; -- uninitialized
end Global;
with Global;
package Renamed is
R : Integer renames Global.G; -- "A rose by any other name ..."
end Renamed;
with Text_IO; use Text_IO;
procedure Do_It is
begin
Put_Line("Should do it.");
end Do_It;
with Text_IO; use Text_IO;
procedure Dont_Do_It is
begin
Put_Line("Shouldn't have done it.");
end Dont_Do_It;
procedure Raise_It is
begin
raise Program_Error;
end Raise_It;
with Global; use Global;
with Renamed; use Renamed;
with Do_It;
with Dont_Do_It;
with Raise_It;
procedure Friendly is
L : Integer; -- uninitialized
Use_1 : Integer := L; -- use before set 1
Use_2 : Integer := G; -- use before set 2
Use_3 : Integer := R; -- use before set 3
Use_4 : Integer;
Use_5 : Integer;
Use_6 : Integer;
Static : constant Integer := 8;
Named : constant := 8;
procedure Embedded (Data : Integer) is separate;
begin
Use_4 := L; -- use before set 4
Use_5 := G; -- use before set 5
Use_6 := R; -- use before set 6
Embedded(L); -- use before set 7
Embedded(G); -- use before set 8
Embedded(R); -- use before set 9
if Static = 8 then
Do_It;
else
Dont_Do_It; -- never executed 1
end if;
if Static - 4 /= 2**2 then
Dont_Do_It; -- never executed 2
else
Do_It;
end if;
if Named mod 4 = 0 then
Do_It;
else
Dont_Do_It; -- never executed 3
end if;
if Named/2 + 2 /= 6 then
Dont_Do_It; -- never executed 4
else
Do_It;
end if;
Raise_It; -- always raised 1
end Friendly;
separate (Friendly)
procedure Embedded (Data : Integer) is
Use_1 : Integer := L; -- use before set 10
Use_2 : Integer := G; -- use before set 11
Use_3 : Integer := R; -- use before set 12
begin
Use_4 := Data; -- (if Data is uninitialized, causes a use before set)
raise Program_Error; -- always raised 2
Raise_It; -- always raised 3
end Embedded;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)int_dir.ada 1.2 Date: 9/21/84
--
-- Author: Edward Colbert
-- Ada Technology Group
-- Information Software Systems Lab
-- Defense Systems Group
-- TRW
-- Redondo Beach, CA
--
-- This program measures the time required for doing various file
-- operations using the Direct_IO package with Integer.
--
-- Note: In order for the measurement to be meaningful, it must be the
-- only program executing while the test is run.
--
-- Please set Times large enough to provide at least two significant
-- digits in the average times, i.e., the difference between
-- the elapsed time and the loop time must be at least 100 times
-- Duration'Small & at least 100 times System.Tick.
--
with Text_IO; use Text_IO;
with Direct_IO;
with Calendar; use Calendar;
with System; use System;
procedure Integer_Direct_IO_Test is
Times : constant Positive := 1000;
type Real_Time is digits Max_Digits;
Start_Time : Time;
Loop_Time : Duration;
Average_Time : Real_Time;
Create_Time : Duration;
Close_Time : Duration;
Open_Time : Duration;
Delete_Time : Duration;
Read_Time : Duration;
Write_Time : Duration;
package Duration_IO is new Fixed_IO (Duration);
use Duration_IO;
package Real_Time_IO is new Float_IO (Real_Time);
use Real_Time_IO;
package Int_IO is new Integer_IO (Integer);
use Int_IO;
package Int_Direct_IO is new Direct_IO (Integer);
use Int_Direct_IO;
file: Int_Direct_IO.file_type;
value: Integer := 5;
count: Integer := Integer'first; -- used in timing loop
begin
-- Measure the timing loop overhead.
Start_Time := Clock;
for N in 1 .. Times loop
count := count + 1; -- prevent optimization
end loop;
Loop_Time := Clock - Start_Time;
-- Create a file
Start_Time := Clock;
Int_Direct_IO.Create (file, mode => out_file, name => "test_file");
Create_Time := Clock - Start_Time;
-- Measure the time of Writing of value
Start_Time := Clock;
for N in 1 .. Times loop
count := count + 1;
Int_Direct_IO.write (file, value);
end loop;
Write_Time := Clock - Start_Time;
-- Close a file
Start_Time := Clock;
Int_Direct_IO.Close (file);
Close_Time := Clock - Start_Time;
-- Open a file
Start_Time := Clock;
Int_Direct_IO.Open (file, mode => in_file, name => "test_file");
Open_Time := Clock - Start_Time;
-- Measure the time of Reading of value
Start_Time := Clock;
for N in 1 .. Times loop
count := count + 1;
Int_Direct_IO.read (file, value);
end loop;
Read_Time := Clock - Start_Time;
-- Delete a file
Start_Time := Clock;
Int_Direct_IO.Delete (file);
Delete_Time := Clock - Start_Time;
Put ("Create File Time = ");
Put (Create_Time, Fore => 0);
put_line (" seconds ");
Put ("Close File Time = ");
Put (Close_Time, Fore => 0);
put_line (" seconds ");
Put ("Open File Time = ");
Put (Open_Time, Fore => 0);
put_line (" seconds ");
Put ("Delete File Time = ");
Put (Delete_Time, Fore => 0);
put_line (" seconds ");
Put("Loop time = ");
Put(Loop_Time, Fore => 0);
Put(" seconds for ");
Put(Times, Width => 0);
Put_Line(" iterations");
Put("Elapsed time = ");
Put(Write_Time, Fore => 0);
Put(" seconds for ");
Put(Times, Width => 0);
Put_Line(" Writes");
Average_Time := Real_Time(Write_Time - Loop_Time)/Real_Time(Times);
Put("Average time for a Write = ");
Put(Average_Time, Fore => 0);
Put_Line(" seconds");
New_Line;
Put("Elapsed time = ");
Put(Read_Time, Fore => 0);
Put(" seconds for ");
Put(Times, Width => 0);
Put_Line(" Reads");
Average_Time := Real_Time(Read_Time - Loop_Time)/Real_Time(Times);
Put("Average time for a Read = ");
Put(Average_Time, Fore => 0);
Put_Line(" seconds");
New_Line;
if (Read_Time - Loop_Time < 100 * Duration'Small) or
(Read_Time - Loop_Time < 100 * System.Tick) or
(Write_Time - Loop_Time < 100 * Duration'Small) or
(Write_Time - Loop_Time < 100 * System.Tick) then
Put_Line("** TEST FAILED (due to insufficient precision)! **");
else
Put_Line("** TEST PASSED **");
end if;
end Integer_Direct_IO_Test;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)int_text.ada 1.2 Date: 9/21/84
--
-- Author: Edward Colbert
-- Ada Technology Group
-- Information Software Systems Lab
-- Defense Systems Group
-- TRW
-- Redondo Beach, CA
--
-- This program measures the time required for doing various file
-- operations using the Text_IO package with Integers.
--
-- Note: In order for the measurement to be meaningful, it must be the
-- only program executing while the test is run.
--
-- Please set Times large enough to provide at least two significant
-- digits in the average times, i.e., the difference between
-- the elapsed time and the loop time must be at least 100 times
-- Duration'Small & at least 100 times System.Tick.
--
with Text_IO; use Text_IO;
with Calendar; use Calendar;
with System; use System;
procedure Integer_Text_IO_Test is
Times : constant Positive := 1000;
type Real_Time is digits Max_Digits;
Start_Time : Time;
Loop_Time : Duration;
Average_Time : Real_Time;
Create_Time : Duration;
Close_Time : Duration;
Open_Time : Duration;
Delete_Time : Duration;
Read_Time : Duration;
Write_Time : Duration;
package Duration_IO is new Fixed_IO (Duration);
use Duration_IO;
package Real_Time_IO is new Float_IO (Real_Time);
use Real_Time_IO;
package Int_IO is new Integer_IO (Integer);
use Int_IO;
file: Text_IO.file_type;
value: Integer := 5;
count: Integer := Integer'first; -- used in timing loop
begin
-- Measure the timing loop overhead.
Start_Time := Clock;
for N in 1 .. Times loop
count := count + 1; -- prevent optimization
end loop;
Loop_Time := Clock - Start_Time;
-- Create a file
Start_Time := Clock;
Text_IO.Create (file, mode => out_file, name => "test_file");
Create_Time := Clock - Start_Time;
-- Measure the time of Writing of value
Start_Time := Clock;
for N in 1 .. Times loop
count := count + 1;
Int_IO.put (file, value);
end loop;
Write_Time := Clock - Start_Time;
-- Close a file
Start_Time := Clock;
Text_IO.Close (file);
Close_Time := Clock - Start_Time;
-- Open a file
Start_Time := Clock;
Text_IO.Open (file, mode => in_file, name => "test_file");
Open_Time := Clock - Start_Time;
-- Measure the time of Reading of value
Start_Time := Clock;
for N in 1 .. Times loop
count := count + 1;
Int_IO.get (file, value);
end loop;
Read_Time := Clock - Start_Time;
-- Delete a file
Start_Time := Clock;
Text_IO.Delete (file);
Delete_Time := Clock - Start_Time;
Put ("Create File Time = ");
Put (Create_Time, Fore => 0);
put_line (" seconds ");
Put ("Close File Time = ");
Put (Close_Time, Fore => 0);
put_line (" seconds ");
Put ("Open File Time = ");
Put (Open_Time, Fore => 0);
put_line (" seconds ");
Put ("Delete File Time = ");
Put (Delete_Time, Fore => 0);
put_line (" seconds ");
Put("Loop time = ");
Put(Loop_Time, Fore => 0);
Put(" seconds for ");
Put(Times, Width => 0);
Put_Line(" iterations");
Put("Elapsed time = ");
Put(Write_Time, Fore => 0);
Put(" seconds for ");
Put(Times, Width => 0);
Put_Line(" Writes");
Average_Time := Real_Time(Write_Time - Loop_Time)/Real_Time(Times);
Put("Average time for a Write = ");
Put(Average_Time, Fore => 0);
Put_Line(" seconds");
New_Line;
Put("Elapsed time = ");
Put(Read_Time, Fore => 0);
Put(" seconds for ");
Put(Times, Width => 0);
Put_Line(" Reads");
Average_Time := Real_Time(Read_Time - Loop_Time)/Real_Time(Times);
Put("Average time for a Read = ");
Put(Average_Time, Fore => 0);
Put_Line(" seconds");
New_Line;
if (Read_Time - Loop_Time < 100 * Duration'Small) or
(Read_Time - Loop_Time < 100 * System.Tick) or
(Write_Time - Loop_Time < 100 * Duration'Small) or
(Write_Time - Loop_Time < 100 * System.Tick) then
Put_Line("** TEST FAILED (due to insufficient precision)! **");
else
Put_Line("** TEST PASSED **");
end if;
end Integer_Text_IO_Test;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)intvec.ada 1.2 Date: 9/21/84
--
-- Author: Edward Colbert
-- Ada Technology Group
-- Information Software Systems Lab
-- Defense Systems Group
-- TRW
-- Redondo Beach, CA
--
-- This program measures the time required for the adding of the
-- elements of a large integer vector
--
-- Note: In order for the measurement to be meaningful, it must be the
-- only program executing while the test is run.
--
-- Please set Vector_Size large enough to provide at least two significant
-- digits in the average times, i.e., the difference between
-- the elapsed time and the loop time must be at least 100 times
-- Duration'Small & at least 100 times System.Tick.
--
with Text_IO; use Text_IO;
with Calendar; use Calendar;
with System; use System;
procedure Integer_Vector_Add_Test is
Vector_Size : constant Positive := 1000;
type Real_Time is digits Max_Digits;
Start_Time : Time;
Loop_Time : Duration;
Elapsed_Time : Duration;
Average_Time : Real_Time;
package Duration_IO is new Fixed_IO (Duration);
use Duration_IO;
package Real_Time_IO is new Float_IO (Real_Time);
use Real_Time_IO;
package Int_IO is new Integer_IO (Integer);
use Int_IO;
type vector is array (1..Vector_Size) of integer;
v1, v2, vector_result: vector;
count: integer := integer'first; -- used in timing loop
begin
-- Initialize Vectors
for N in vector'range loop
v1(N) := N;
v2(N) := vector'last - N + 1;
end loop;
-- Measure the timing loop overhead.
Start_Time := Clock;
for N in vector'range loop
count := count + 1; -- prevent optimization
end loop;
Loop_Time := Clock - Start_Time;
-- Measure the time including the adding of vector elements
Start_Time := Clock;
for N in vector'range loop
count := count + 1; -- prevent optimization
vector_result (n) := v1(n) + v2(n);
end loop;
Elapsed_Time := Clock - Start_Time;
Put("Loop time = ");
Put(Loop_Time, Fore => 0);
Put(" seconds for ");
Put(Vector_Size, Width => 0);
Put_Line(" iterations");
Put("Elapsed time = ");
Put(Elapsed_Time, Fore => 0);
Put(" seconds for ");
Put(Vector_Size, Width => 0);
Put_Line(" Elements");
Average_Time := Real_Time(Elapsed_Time - Loop_Time)/Real_Time(Vector_Size);
Put("Average time for adding each element = ");
Put(Average_Time, Fore => 0);
Put_Line(" seconds");
New_Line;
if (Elapsed_Time - Loop_Time < 100 * Duration'Small or
Elapsed_Time - Loop_Time < 100 * System.Tick) then
Put_Line("** TEST FAILED (due to insufficient precision)! **");
else
Put_Line("** TEST PASSED **");
end if;
end Integer_Vector_Add_Test;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)lowlev.ada 1.1 Date: 5/30/84
--
-- Author: Bryce Bardin
-- Ada Projects Section
-- Software Engineering Division
-- Ground Systems Group
-- Hughes Aircraft Company
-- Fullerton, CA
--
-- The following program tests length clauses in conjunction with
-- unchecked conversion.
--
-- Before running the test, No_Of_Bits must be set to the base 2 logarithm
-- of the successor of System.Max_Int, i.e., the total number of bits in
-- the largest integer type supported.
-- Note: The place where this change is to be made is flagged by a
-- comment prefixed by "--!".
--
-- For a compiler to pass this test, it must obey the length clauses
-- and instantiate and use the unchecked conversions correctly.
-- The output will consist of Cases sets of three identical values.
-- If a conversion fails, the line will be flagged as an error. A summary
-- error count and a "pass/fail" message will be output.
-- Ideally, an assembly listing should be provided which demonstrates
-- the efficiency of the compiled code.
--
with Text_IO; use Text_IO;
with Unchecked_Conversion;
with System;
procedure Change_Types is
--! Change this to Log2 (System.Max_Int + 1):
No_Of_Bits : constant := 32;
Cases : constant := 100;
type Int is range 0 .. 2**No_Of_Bits - 1;
for Int'Size use No_Of_Bits;
--! Change this to System.Max_Int/(Cases - 1):
Increment : constant Int := System.Max_Int/(Cases - 1);
type Bit is (Off, On);
for Bit use (Off => 0, On => 1);
for Bit'Size use 1;
subtype Bits is Positive range 1 .. No_Of_Bits;
type Bit_String is array (Bits) of Bit;
for Bit_String'Size use No_Of_Bits;
I : Int;
J : Int;
B : Bit_String;
Errors : Natural := 0;
Column : constant := 16;
package Int_IO is new Integer_IO(Int);
use Int_IO;
package Nat_IO is new Integer_IO(Natural);
use Nat_IO;
procedure Put (B : Bit_String) is
begin
Put("2#");
for N in Bits loop
if B(N) = On then
Put("1");
else
Put("0");
end if;
end loop;
Put("#");
end Put;
function To_Bit_String is new Unchecked_Conversion (Int, Bit_String);
function To_Int is new Unchecked_Conversion (Bit_String, Int);
begin
for N in 1 .. Cases loop
I := Int(N-1) * Increment;
B := To_Bit_String(I);
J := To_Int(B);
if J /= I then
Errors := Errors + 1;
Put("*** ERROR ***");
end if;
Set_Col(To => Column);
Put("I = ");
Put(I, Base => 2);
Put_Line(",");
Set_Col(To => Column);
Put("B = ");
Put(B);
Put_Line(",");
Set_Col(To => Column);
Put("J = ");
Put(J, Base => 2);
Put(".");
New_Line(2);
end loop;
New_Line(2);
if Errors > 0 then
Put_Line("*** TEST FAILED! ***");
if Errors = 1 then
Put_Line("There was 1 error.");
else
Put("There were ");
Put(Errors, Width => 0);
Put_Line(" errors.");
end if;
else
Put_Line("TEST PASSED!");
Put_Line("There were no errors.");
end if;
end Change_Types;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)proccal.ada 1.2 Date: 9/21/84
--
--
-- Author: Bryce Bardin
-- Ada Projects Section
-- Software Engineering Division
-- Ground Systems Group
-- Hughes Aircraft Company
-- Fullerton, CA
--
-- This program measures the time required for simple procedure calls
-- with scalar parameters.
--
-- Note: In order for the measurement to be meaningful, it must be the
-- only program executing while the test is run.
--
-- Please set Times large enough to provide at least two significant
-- digits in the average calling times, i.e., the differences between
-- the elapsed times and the corresponding loop times for each form of
-- call should be greater than 100 times Duration'Small & greater than
-- 100 times System.Tick.
with Text_IO; use Text_IO;
with Calendar; use Calendar;
with System; use System;
procedure Procedure_Call is
Times : constant Positive := 1000;
type Real_Time is digits Max_Digits;
Start_Time : Time;
Loop_Time : Duration;
Elapsed_Time : Duration;
Average_Time : Real_Time;
Insufficient_Precision : Boolean := False;
package Duration_IO is new Fixed_IO (Duration);
use Duration_IO;
package Real_Time_IO is new Float_IO (Real_Time);
use Real_Time_IO;
package Int_IO is new Integer_IO (Integer);
use Int_IO;
type Cases is range 1 .. 4;
Kind : array (Cases) of String (1 .. 22) :=
("No parameter call: ",
"In parameter call: ",
"Out parameter call: ",
"In Out parameter call:");
-- This package is used to prevent elimination of a "null" call
-- by a smart compiler.
package Prevent is
Counter : Natural := 0;
procedure Prevent_Optimization;
end Prevent;
use Prevent;
procedure Call is
begin
Prevent_Optimization;
end Call;
procedure Call_In (N : in Natural) is
begin
Counter := N;
end Call_In;
procedure Call_Out (N : out Natural) is
begin
N := Counter;
end Call_Out;
procedure Call_In_Out (N : in out Natural) is
begin
N := Counter;
end Call_In_Out;
-- This procedure determines if Times is large enough to assure adequate
-- precision in the timings.
procedure Check_Precision is
begin
if (Elapsed_Time - Loop_Time < 100 * Duration'Small or
Elapsed_Time - Loop_Time < 100 * System.Tick) then
Insufficient_Precision := True;
end if;
end Check_Precision;
package body Prevent is
procedure Prevent_Optimization is
begin
Counter := Counter + 1;
end Prevent_Optimization;
end Prevent;
begin
for Case_Number in Cases loop
-- Measure the timing loop overhead.
Start_Time := Clock;
for N in 1 .. Times loop
case Case_Number is
when 1 =>
Prevent_Optimization;
when 2 =>
Counter := N;
when 3 =>
Counter := N;
when 4 =>
Counter := N;
end case;
end loop;
Loop_Time := Clock - Start_Time;
-- Measure the time including the procedure call.
Start_Time := Clock;
for N in 1 .. Times loop
case Case_Number is
when 1 =>
Call;
when 2 =>
Call_In(Counter);
when 3 =>
Call_Out(Counter);
when 4 =>
Call_In_Out(Counter);
end case;
end loop;
Elapsed_Time := Clock - Start_Time;
Check_Precision;
-- Calculate timing and output the result
Put(Kind(Case_Number));
New_Line(2);
Put("Loop time = ");
Put(Loop_Time, Fore => 0);
Put(" seconds for ");
Put(Times, Width => 0);
Put_Line(" iterations");
Put("Elapsed time = ");
Put(Elapsed_Time, Fore => 0);
Put(" seconds for ");
Put(Times, Width => 0);
Put_Line(" iterations");
Average_Time := Real_Time(Elapsed_Time - Loop_Time)/Real_Time(Times);
New_Line;
Put("Average time for a call = ");
Put(Average_Time);
Put_Line(" seconds");
New_Line(3);
end loop;
if Insufficient_Precision then
Put_Line("** TEST FAILED (due to insufficient precision)! **");
else
Put_Line("TEST PASSED");
end if;
end Procedure_Call;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
----------------------------------------------------------------------
--
-- QUICK SORT BENCHMARK
--
-- Version: @(#)qsortpar.ada 1.1 Date: 6/5/84
--
-- Gerry Fisher
-- Computer Sciences Corporation
--
-- May 26, 1984
--
-- This benchmark consists of two versions of the familiar quick
-- sort algorithm: a parallel version and a sequential version.
-- A relatively small vector (length 100) is sorted into ascending
-- sequence. The number of comparisons and exchanges is counted.
-- In the parallel version separate tasks are created to sort the
-- two subvectors created by partitioning the vector. Each task
-- invokes the quicksort procedure. The parallel version is
-- functionally equivalent to the sequential version and should
-- require the same number of comparisions and exchanges. A check
-- is made to verify that this is so. Also, the sorted vector is
-- checked to verify that the sort has been performed correctly.
-- Control is exercised so that no more than fourteen tasks are
-- created when sorting the vector.
--
-- The sorting is repeated a number of times to obtain a measurable
-- amount of execution time.
--
-- The important measure for this benchmark is the ratio of the
-- execution time of the parallel version to that of the sequential
-- version. This will give some indication of task activation and
-- scheduling overhead.
--
-- One file is used for both versions. The boolean constant "p"
-- indicates whether the parallel or serial version of the algorithm
-- is to be used. Simply set this constant TRUE for the parallel
-- test and FALSE for the sequential test. A difference in code
-- size between the two tests may indicate that conditional
-- compilation is supported by the compiler.
--
------------------------------------------------------------------------
with text_io; use text_io;
procedure main is
failed : exception;
type vector is array(integer range <>) of integer;
type stats is record c, e : integer := 0; end record;
p : constant boolean := true; -- true for parallel algorithm
n : constant integer := 100; -- size of vector to be sorted
m : constant integer := 100; -- number of times to sort vector
x : vector(1 .. n);
y : stats;
procedure Quick_sort(A : in out vector; w : out stats) is
lb : constant integer := A'first;
ub : constant integer := A'last;
k : integer;
c, e : integer := 0;
u, v : stats;
function partition(L, U : integer) return integer is
q, r, i, j : integer;
begin
r := A((U + L)/2);
i := L;
j := U;
while i < j loop
while A(i) < r loop
c := c + 1;
i := i + 1;
end loop;
while A(j) > r loop
c := c + 1;
j := j - 1;
end loop;
c := c + 2;
if i <= j then
e := e + 1;
q := A(i);
A(i) := A(j);
A(j) := q;
i := i + 1;
j := j - 1;
end if;
end loop;
if j > L then
return j;
else
return L;
end if;
end partition;
begin
if lb < ub then
k := partition(lb, ub);
if ub > lb + 15 then
if p then
declare
task S1;
task body S1 is
begin
Quick_sort(A(lb .. k), u);
end S1;
task S2;
task body S2 is
begin
Quick_sort(A(k + 1 .. ub), v);
end S2;
begin
null;
end;
else
Quick_sort(A(lb .. k), u);
Quick_sort(A(k + 1 .. ub), v);
end if;
elsif ub > lb + 1 then
Quick_sort(A(lb .. k), u);
Quick_sort(A(k + 1 .. ub), v);
end if;
e := e + u.e + v.e;
c := c + u.c + v.c;
end if;
w := (c, e);
end Quick_sort;
begin
set_line_length(count(50));
if p then
put_line("*** Starting Parallel Quick Sort Benchmark");
else
put_line("*** Starting Sequential Quick Sort Benchmark");
end if;
for k in 1 .. m loop
for i in x'range loop
x(i) := x'last - i + 1;
end loop;
Quick_sort(x, y);
for i in x'first .. x'last - 1 loop
if x(i) > x(i + 1) then
raise failed;
end if;
end loop;
put(".");
end loop;
new_line;
if y.c /= 782 or else y.e /= 148 then
put_line("*** FAILED Wrong number of comparisons or exchanges");
else
put_line("*** PASSED Sorting test");
end if;
exception
when failed => put_line("*** FAILED Vector not sorted");
end main;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
----------------------------------------------------------------------
--
-- QUICK SORT BENCHMARK
--
-- Version: @(#)qsortseq.ada 1.1 Date: 6/5/84
--
-- Gerry Fisher
-- Computer Sciences Corporation
-- May 27, 1984
--
--
-- This benchmark consists of two versions of the familiar quick
-- sort algorithm: a parallel version and a sequential version.
-- A relatively small vector (length 100) is sorted into ascending
-- sequence. The number of comparisons and exchanges is counted.
-- In the parallel version separate tasks are created to sort the
-- two subvectors created by partitioning the vector. Each task
-- invokes the quicksort procedure. The parallel version is
-- functionally equivalent to the sequential version and should
-- require the same number of comparisions and exchanges. A check
-- is made to verify that this is so. Also, the sorted vector is
-- checked to verify that the sort has been performed correctly.
-- Control is exercised so that no more than fourteen tasks are
-- created when sorting the vector.
--
-- The sorting is repeated a number of times to obtain a measurable
-- amount of execution time.
--
-- The important measure for this benchmark is the ratio of the
-- execution time of the parallel version to that of the sequential
-- version. This will give some indication of task activation and
-- scheduling overhead.
--
-- One file is used for both versions. The boolean constant "p"
-- indicates whether the parallel or serial version of the algorithm
-- is to be used. Simply set this constant TRUE for the parallel
-- test and FALSE for the sequential test. A difference in code
-- size between the two tests may indicate that conditional
-- compilation is supported by the compiler.
--
--------------------------------------------------------------------
with text_io; use text_io;
procedure main is
failed : exception;
type vector is array(integer range <>) of integer;
type stats is record c, e : integer := 0; end record;
p : constant boolean := false; -- true for parallel algorithm
n : constant integer := 100; -- size of vector to be sorted
m : constant integer := 100; -- number of times to sort vector
x : vector(1 .. n);
y : stats;
procedure Quick_sort(A : in out vector; w : out stats) is
lb : constant integer := A'first;
ub : constant integer := A'last;
k : integer;
c, e : integer := 0;
u, v : stats;
function partition(L, U : integer) return integer is
q, r, i, j : integer;
begin
r := A((U + L)/2);
i := L;
j := U;
while i < j loop
while A(i) < r loop
c := c + 1;
i := i + 1;
end loop;
while A(j) > r loop
c := c + 1;
j := j - 1;
end loop;
c := c + 2;
if i <= j then
e := e + 1;
q := A(i);
A(i) := A(j);
A(j) := q;
i := i + 1;
j := j - 1;
end if;
end loop;
if j > L then
return j;
else
return L;
end if;
end partition;
begin
if lb < ub then
k := partition(lb, ub);
if ub > lb + 15 then
if p then
declare
task S1;
task body S1 is
begin
Quick_sort(A(lb .. k), u);
end S1;
task S2;
task body S2 is
begin
Quick_sort(A(k + 1 .. ub), v);
end S2;
begin
null;
end;
else
Quick_sort(A(lb .. k), u);
Quick_sort(A(k + 1 .. ub), v);
end if;
elsif ub > lb + 1 then
Quick_sort(A(lb .. k), u);
Quick_sort(A(k + 1 .. ub), v);
end if;
e := e + u.e + v.e;
c := c + u.c + v.c;
end if;
w := (c, e);
end Quick_sort;
begin
set_line_length(count(50));
if p then
put_line("*** Starting Parallel Quick Sort Benchmark");
else
put_line("*** Starting Sequential Quick Sort Benchmark");
end if;
for k in 1 .. m loop
for i in x'range loop
x(i) := x'last - i + 1;
end loop;
Quick_sort(x, y);
for i in x'first .. x'last - 1 loop
if x(i) > x(i + 1) then
raise failed;
end if;
end loop;
put(".");
end loop;
new_line;
if y.c /= 782 or else y.e /= 148 then
put_line("*** FAILED Wrong number of comparisons or exchanges");
else
put_line("*** PASSED Sorting test");
end if;
exception
when failed => put_line("*** FAILED Vector not sorted");
end main;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)rendez.ada 1.2 Date: 9/21/84
--
-- Author: Bryce Bardin
-- Ada Projects Section
-- Software Engineering Division
-- Ground Systems Group
-- Hughes Aircraft Company
-- Fullerton, CA
--
-- This program measures the time required for a simple rendezvous.
--
-- Note: In order for the measurement to be meaningful, it must be the
-- only program executing while the test is run.
--
-- Please set Times large enough to provide at least two significant
-- digits in the average rendezvous times, i.e., the difference between
-- the elapsed time and the loop time must be at least 100 times
-- Duration'Small & at least 100 times System.Tick.
with Text_IO; use Text_IO;
with Calendar; use Calendar;
with System; use System;
procedure Rendezvous is
Times : constant Positive := 1000;
type Real_Time is digits Max_Digits;
Start_Time : Time;
Loop_Time : Duration;
Elapsed_Time : Duration;
Average_Time : Real_Time;
package Duration_IO is new Fixed_IO (Duration);
use Duration_IO;
package Real_Time_IO is new Float_IO (Real_Time);
use Real_Time_IO;
package Int_IO is new Integer_IO (Integer);
use Int_IO;
task T is
entry Call;
end T;
-- This package is used to prevent elimination of the "null" timing loop
-- by a smart compiler.
package Prevent is
Count : Natural := 0;
procedure Prevent_Optimization;
end Prevent;
use Prevent;
task body T is
begin
loop
select
accept Call;
or
terminate;
end select;
end loop;
end T;
package body Prevent is
procedure Prevent_Optimization is
begin
Count := Count + 1;
end Prevent_Optimization;
end Prevent;
begin
-- Measure the timing loop overhead.
Start_Time := Clock;
for N in 1 .. Times loop
Prevent_Optimization;
end loop;
Loop_Time := Clock - Start_Time;
-- Measure the time including rendezvous.
Start_Time := Clock;
for N in 1 .. Times loop
Prevent_Optimization;
T.Call;
end loop;
Put("Loop time = ");
Put(Loop_Time, Fore => 0);
Put(" seconds for ");
Put(Times, Width => 0);
Put_Line(" iterations");
Elapsed_Time := Clock - Start_Time;
Put("Elapsed time = ");
Put(Elapsed_Time, Fore => 0);
Put(" seconds for ");
Put(Times, Width => 0);
Put_Line(" iterations");
Average_Time := Real_Time(Elapsed_Time - Loop_Time)/Real_Time(Times);
Put("Average time for no-parameter rendezvous = ");
Put(Average_Time, Fore => 0);
Put_Line(" seconds");
New_Line;
if (Elapsed_Time - Loop_Time < 100 * Duration'Small or
Elapsed_Time - Loop_Time < 100 * System.Tick) then
Put_Line("** TEST FAILED (due to insufficient precision)! **");
else
Put_Line("** TEST PASSED **");
end if;
end Rendezvous;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)sets.ada 1.2 Date: 9/20/84
--
--
-- Author: Bryce Bardin
-- Ada Projects Section
-- Software Engineering Division
-- Ground Systems Group
-- Hughes Aircraft Company
-- Fullerton, CA
--
-- This is a highly portable implementation of sets in Ada.
--
-- N. B.: Vendors are invited to supply listings which demonstrate
-- the quality of the code generated.
--
generic
type Element is (<>);
with function Image (E : Element) return String is Element'Image;
package Sets is
type Set is private;
-- A set of elements.
Empty_Set : constant Set;
-- The set of no elements.
Full_Set : constant Set;
-- The set of all elements.
function "and" (Left, Right : Set) return Set;
-- Returns the conjunction (intersection) of two sets.
-- Usage: S1 and S2
function "or" (Left, Right : Set) return Set;
-- Returns the inclusive disjunction (union) of two sets.
-- Usage: S1 or S2
function "xor" (Left, Right : Set) return Set;
-- Returns the exclusive disjunction of two sets.
-- Usage: S1 xor S2
function "not" (Right : Set) return Set;
-- Returns the negation (complement) of a set, i.e., the set of
-- all elements not in Right.
-- Usage: not S
function "-" (Left, Right : Set) return Set;
-- Returns the difference of two sets, i.e., the set of elements
-- in Left which are not in Right.
-- Usage: S1 - S2
function "+" (Left : Element; Right : Set) return Set;
-- Adds an element to a set.
-- Returns the union (or) of an element with a set.
-- Usage: E + S
function "+" (Left : Set; Right : Element) return Set;
-- Adds an element to a set.
-- Returns the union (or) of an element with a set.
-- Usage: S + E
function "+" (Right : Element) return Set;
-- Makes an element into a Set.
-- Returns the union of the element with the Empty_Set.
-- Usage: + E
function "+" (Left, Right : Element) return Set;
-- Combines two elements into a Set.
-- Returns the union (or) of two elements with the Empty_Set.
-- Usage: E1 + E2
function "-" (Left : Set; Right : Element) return Set;
-- Deletes an element from a set, i.e., removes it from the set
-- if it is currently a member of the set, otherwise it returns
-- the original set.
-- Usage: S - E
-- This function is predefined:
-- function "=" (Left, Right : Set) return Boolean;
-- Tests whether Left is identical to Right.
-- Usage: S1 = S2
function "<=" (Left, Right : Set) return Boolean;
-- Tests whether Left is contained in Right, i.e., whether Left
-- is a subset of Right.
-- Usage: S1 <= S2
function Is_Member (S : Set; E : Element) return Boolean;
-- Tests an element for membership in a set.
-- Returns true if an element is in a set.
-- Usage: Is_Member (S, E)
procedure Put (S : Set);
-- Prints a set.
-- Usage: Put (S)
private
type Set is array (Element) of Boolean;
-- A set of elements.
Empty_Set : constant Set := (Element => False);
-- The set of no elements.
Full_Set : constant Set := (Element => True);
-- The set of all elements.
pragma Inline ("and");
pragma Inline ("or");
pragma Inline ("xor");
pragma Inline ("not");
pragma Inline ("-");
pragma Inline ("+");
pragma Inline ("<=");
pragma Inline ("Is_Member");
end Sets;
with Text_IO; use Text_IO;
package body Sets is
type Bool is array (Element) of Boolean;
function "and" (Left, Right : Set) return Set is
begin
return Set(Bool(Left) and Bool(Right));
end "and";
function "or" (Left, Right : Set) return Set is
begin
return Set(Bool(Left) or Bool(Right));
end "or";
function "xor" (Left, Right : Set) return Set is
begin
return Set(Bool(Left) xor Bool(Right));
end "xor";
function "not" (Right : Set) return Set is
begin
return Set(not Bool(Right));
end "not";
function "-" (Left, Right : Set) return Set is
begin
return (Left and not Right);
end "-";
function "+" (Left : Element; Right : Set) return Set is
Temp : Set := Right;
begin
Temp(Left) := True;
return Temp;
end "+";
function "+" (Left : Set; Right : Element) return Set is
Temp : Set := Left;
begin
Temp(Right) := True;
return Temp;
end "+";
function "+" (Right : Element) return Set is
begin
return Empty_Set + Right;
end "+";
function "+" (Left, Right : Element) return Set is
begin
return Empty_Set + Left + Right;
end "+";
function "-" (Left : Set; Right : Element) return Set is
Temp : Set := Left;
begin
Temp(Right) := False;
return Temp;
end "-";
function "<=" (Left, Right : Set) return Boolean is
begin
return ((Left and not Right) = Empty_Set);
end "<=";
function Is_Member (S : Set; E : Element) return Boolean is
begin
return (S(E) = True);
end Is_Member;
procedure Put (S : Set) is
Comma_Needed : Boolean := False;
begin
Text_IO.Put ("{");
for E in Element loop
if S(E) then
if Comma_Needed then
Text_IO.Put (",");
end if;
Text_IO.Put (Image(E));
Comma_Needed := True;
end if;
end loop;
Text_IO.Put ("}");
New_Line;
end Put;
end Sets;
-- This procedure tests the set package.
-- Its output is self-explanatory.
with Text_IO; use Text_IO;
with Sets;
procedure Main is
type Color is (Red, Yellow, Green, Blue);
package Color_Set is new Sets(Color);
use Color_Set;
X, Y, Z : Set;
procedure Put_Set (Name : String; S : Set) is
begin
Put (Name);
Put (" = ");
Put (S);
end Put_Set;
procedure Compare_Set (S_String : String; S : Set;
T_String : String; T : Set) is
begin
if S = T then
Put (S_String);
Put (" is identical to ");
Put (T_String);
New_Line;
end if;
if S /= T then
Put (S_String);
Put (" is not identical to ");
Put (T_String);
New_Line;
end if;
if S <= T then
Put (S_String);
Put (" is a subset of ");
Put (T_String);
New_Line;
end if;
if T <= S then
Put (T_String);
Put (" is a subset of ");
Put (S_String);
New_Line;
end if;
end Compare_Set;
procedure Test_Membership (C : Color; S_String : String; S : Set) is
begin
Put (Color'Image(C));
if Is_Member(S,C) then
Put (" is a member of ");
else
Put (" is not a member of ");
end if;
Put (S_String);
New_Line;
end Test_Membership;
begin
X := Empty_Set;
Put_Line ("X := Empty_Set");
Put_Set ("X",X);
Y := Empty_Set;
Put_Line ("Y := Empty_Set");
Put_Set ("Y",Y);
Compare_Set ("X",X,"Y",Y);
Y := Full_Set;
Put_Line ("Y := Full_Set");
Put_Set ("Y",Y);
Compare_Set ("X",X,"Y",Y);
X := not X;
Put_Line ("X := not X");
Put_Set ("X",X);
Compare_Set ("X",X,"Y",Y);
Y := Empty_Set + Blue;
Put_Line ("Y := Empty_Set + Blue");
Put_Set ("Y",Y);
Y := + Yellow;
Put_Line ("Y := + Yellow");
Put_Set ("Y",Y);
Y := Blue + Y;
Put_Line ("Y := Blue + Y");
Put_Set ("Y",Y);
X := Full_Set - Red;
Put_Line ("X := Full_Set - Red");
Put_Set ("X",X);
Test_Membership (Red,"X",X);
Test_Membership (Yellow,"X",X);
Compare_Set ("X",X,"Y",Y);
Z := X - Y;
Put_Line ("Z := X - Y");
Put_Set ("Z",Z);
Z := Y - X;
Put_Line ("Z := Y - X");
Put_Set ("Z",Z);
X := Green + Blue + Yellow + Red;
Put_Line ("X := Green + Blue + Yellow + Red");
Put_Set ("X",X);
X := Green + Blue;
Put_Line ("X := Green + Blue");
Put_Set ("X",X);
Z := X or Y;
Put_Line ("Z := X or Y");
Put_Set ("Z",Z);
Z := X and Y;
Put_Line ("Z := X and Y");
Put_Set ("Z",Z);
Z := X xor Y;
Put_Line ("Z := X xor Y");
Put_Set ("Z",Z);
end Main;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)shared.ada 1.1 Date: 5/30/84
--
--
-- Author: Bryce Bardin
-- Ada Projects Section
-- Software Engineering Division
-- Ground Systems Group
-- Hughes Aircraft Company
-- Fullerton, CA
--
-- This program illustrates the use of tasking to provide shared access
-- to global variables. N.B.: The values it outputs may vary from run
-- to run depending on how tasking is implemented.
-- A "FIFO" solution to the READERS/WRITERS problem.
-- Authors: Gerald Fisher and Robert Dewar.
-- (Modified by Bryce Bardin to terminate gracefully.)
-- May be used to provide shared access to objects by an arbitrary number of
-- readers and writers which are serviced in order from a single queue.
-- Writers are given uninterrupted access for updates and readers are assured
-- that updates are indivisible and therefore complete when read access is
-- granted.
--
-- If C is a task object of type Control and O is an object which is to be
-- shared between readers and writers using C, then:
--
-- readers should do:
--
-- C.Start(Read);
-- <read all or part of O>
-- C.Stop;
--
-- and writers should do:
--
-- C.Start(Write);
-- <update all or part of O>
-- C.Stop;
package Readers_Writers is
type Service is (Read, Write);
task type Control is
entry Start (Mode : Service); -- start readers or writers
entry Stop; -- stop readers or writers
end Control;
end Readers_Writers;
package body Readers_Writers is
task body Control is
Read_Count : Natural := 0;
begin
loop
select
-- remove the first reader or writer from the queue
accept Start (Mode : Service) do
if Mode = Read then
Read_Count := Read_Count + 1;
else
-- when writer, wait for readers which have already
-- started to finish before allowing the writer to
-- perform the update
while Read_Count > 0 loop
-- when a write is pending, readers stop here
accept Stop;
Read_Count := Read_Count - 1;
end loop;
end if;
end Start;
if Read_Count = 0 then
-- when writer, wait for writer to stop before allowing
-- other readers or writers to start
accept Stop;
end if;
or
-- when no write is pending, readers stop here
accept Stop;
Read_Count := Read_Count -1;
or
-- quit when everyone agrees to do so
terminate;
end select;
end loop;
end Control;
end Readers_Writers;
-- This package allows any number of concurrent programs to read and/or
-- indivisibly write a particular (possibly composite) variable object
-- without interference and in FIFO order. Similar packages can be
-- constructed to perform partial reads and writes of composite objects.
-- If service cannot be started before the appropriate time limit expires,
-- the exception Timed_Out will be raised. (By default, service must be
-- started within Duration'Last (24+) hours. Setting the time limits to
-- 0.0 will require immediate service.)
--
generic
type Object_Type is private;
Object : in out Object_Type;
Read_Time_Limit : in Duration := Duration'Last;
Write_Time_Limit : in Duration := Duration'Last;
-- for testing only
with procedure Read_Put (Item : in Object_Type) is <>;
-- for testing only
with procedure Write_Put (Item : in Object_Type) is <>;
-- for testing only
with procedure Copy (From : in Object_Type; To : in out Object_Type);
package Shared_Variable is
-- for testing only: Item made "in out" instead of "out"
procedure Read (Item : in out Object_Type);
procedure Write (Item : in Object_Type);
Timed_Out : exception;
end Shared_Variable;
with Readers_Writers; use Readers_Writers;
package body Shared_Variable is
C : Control;
-- for testing only: Item made "in out" instead of "out"
procedure Read (Item : in out Object_Type) is
begin
select
C.Start(Read);
or
delay Read_Time_Limit;
raise Timed_Out;
end select;
-- for testing only; this allows the scheduler to screw up!
Copy(From => Object, To => Item);
-- temporarily replaces
-- Item := Object;
-- for testing only
Read_Put(Item);
C.Stop;
end Read;
procedure Write (Item : in Object_Type) is
begin
select
C.Start(Write);
or
delay Write_Time_Limit;
raise Timed_Out;
end select;
-- for testing only; this allows the scheduler to screw up!
Copy(From => Item, To => Object);
-- temporarily replaces
Object := Item;
-- for testing only
Write_Put(Item);
C.Stop;
end Write;
end Shared_Variable;
with Shared_Variable;
package Encapsulate is
Max : constant := 2;
subtype Index is Positive range 1 .. Max;
type Composite is array (Index) of Integer;
procedure Read (C : out Composite);
procedure Write (C : in Composite);
-- This is a help function for testing
function Set_To (I : Integer) return Composite;
-- This is a help function for testing
function Value_Of (C : Composite) return Integer;
-- This entry is used to serialize debug output to Standard_Output
task Msg is
entry Put (S : String);
end Msg;
end Encapsulate;
with Text_IO;
package body Encapsulate is
Shared : Composite;
function Set_To (I : Integer) return Composite is
Temp : Composite;
begin
for N in Index loop
Temp(N) := I;
end loop;
return Temp;
end Set_To;
function Value_Of (C : Composite) return Integer is
begin
return C(Index'First);
end Value_Of;
-- for testing only; this allows the scheduler to overlap readers and
-- writers and thus screw up if Readers_Writers doesn't do its job.
-- it also checks that the copy is consistent.
procedure Copy (From : in Composite; To : in out Composite) is
begin
for I in Index loop
To(I) := From(I);
-- delay so that another access could be made:
delay 0.5;
end loop;
-- test for consistency:
for I in Index range Index'Succ(Index'First) .. Index'Last loop
if To(I) /= To(Index'First) then
raise Program_Error;
end if;
end loop;
end Copy;
procedure Read_Put (Item : Composite) is
begin
Msg.Put(Integer'Image(Value_Of(Item)) & " read");
end Read_Put;
procedure Write_Put (Item : Composite) is
begin
Msg.Put(Integer'Image(Value_Of(Item)) & " written");
end Write_Put;
task body Msg is
begin
loop
select
accept Put (S : String) do
Text_IO.Put (S);
Text_IO.New_Line;
end Put;
or
terminate;
end select;
end loop;
end Msg;
package Share is new Shared_Variable
(Object_Type => Composite, Object => Shared, Read_Put => Read_Put,
Write_Put => Write_Put, Copy => Copy);
use Share;
procedure Read (C : out Composite) is
Temp : Composite;
begin
Share.Read(Temp);
C := Temp;
end Read;
procedure Write (C : in Composite) is
begin
Share.Write(C);
end Write;
begin
Shared := Set_To (0);
end Encapsulate;
with Encapsulate; use Encapsulate;
with Text_IO; use Text_IO;
procedure Test_Shared is
Local : Composite := Set_To (-1);
task A;
task B;
task C;
procedure Put(C : Character; I : Integer);
task body A is
begin
Read(Local);
Put('A',Value_Of(Local));
Write(Set_To(1));
Read(Local);
Put('A',Value_Of(Local));
Write(Set_To(2));
Read(Local);
Put('A',Value_Of(Local));
end A;
task body B is
begin
Read(Local);
Put('B',Value_Of(Local));
Write(Set_To(3));
Read(Local);
Put('B',Value_Of(Local));
end B;
task body C is
begin
Write(Set_To(4));
Read(Local);
Put('C',Value_Of(Local));
Write(Set_To(5));
Read(Local);
Put('C',Value_Of(Local));
end C;
procedure Put(C : Character; I : Integer) is
begin
Msg.Put("Task " & C & " read the value " & Integer'Image(I));
end Put;
begin
null;
end Test_Shared;
More information about the Comp.sources.unix
mailing list