adatrain@trwspp.UUCP (09/30/84)
--------------------------------------------------
-- Rules --
--------------------------------------------------
1. All rules apply equally to all vendors participating. Every effort
will be made to assure fairness in the treatment of the vendors.
2. All vendors must perform the tests in accordance with these rules.
Each vendor is responsible for complying with them and for
accurately reporting the results of all the tests which were
submitted, including any tests not performed.
3. If more than one Ada toolset or host/target environment is used, the
vendor should make a complete, independent report of the test
results for each distinct combination of tools, host, and target.
4. All tests must be performed using the source code in its original,
official format, without alteration of any kind, except as directed.
Where implementation differences may effect the source code,
directions for alteration may be supplied to the vendors in written
form, embedded in the source code as comments, or orally by the
Technical Chair or his authorized representative. Any alterations
made to a test in the absence of such directions or which violate
the clear intent of the directions given are grounds for
disqualification of the vendor on that test.
5. The test source files must be submitted as single compilations,
regardless of the number of compilation units they contain, unless
specific directions to the contrary are given. All pragmas which an
implementation can obey must be obeyed. In particular, range
checking must not be suppressed except where directed by pragmas in
the source code. A compilation listing file must be generated by
each compilation. Unless specifically requested, no linker or
loader outputs are required. Execution outputs must be those
produced by the Ada program and its run-time environment, without
alteration of any kind. The information submitted as official test
results must represent a complete, continuous, and self-consistent
sequence of operations in which the unaltered output of each
operation is the input of the next. The image which is executed
must be precisely that which is directly produced by the sequence
described above. The intent of this rule is to avoid any
inconsistency between the options used in different parts of the
test sequence and to make sure that timing and performance data are
measured for that specific sequence only. Additional information
which was not produced in that sequence may not be included in the
official test results, but may be submitted as a supplement as
described below.
6. All timing information which is requested (other than that obtained
directly by the program using the Calendar package) shall be given
in terms of differences in the actual time of day ("wall clock"
time), accurate to the nearest second (or tenth of a second, if
possible). Compilation, link or binding, and load times must
include the time required to load and initialize the programs which
perform these processes. Compilation times include all intermediate
translations performed (e.g., from assembly code to native object
code), and specifically must include those not performed by the Ada
compiler itself. The sum of the times given for each phase
(compilation, linking, etc.) must be equal to the actual elapsed
time for the entire sequence, starting with initiation of
compilation and ending with completion of execution.
7. Size information shall be given in bytes, accurate to the nearest
byte if possible. Module object code size does not include
predefined packages such as Text_IO and Calendar which were "with"ed
or the run-time support library or the underlying operating system
if any.
8. In the event that a test is found to be defective for any reason,
including (but not restricted to) invalid Ada code, functional
errors, or unclear directions for its execution, it will be dropped
from the test suite and will not be considered further unless it can
be corrected easily and all participating vendors can be given
timely notification of the corrections.
9. Any test may be challenged by any vendor stating their belief that
it is defective and why they feel that it is. (Suggestions for
fixing the defects will be gratefully received.) Such challenges
will be taken under advisement by the Technical Chair and his
appointed representatives and will be considered and accepted or
rejected as expeditiously as possible. Only those challenges made
before the date of the fair will be considered unless there is
unanimous agreement between all vendors and the Technical Chair that
a test is defective, in which case a challenge may be accepted on
the spot. In the case of a rejected challenge, vendors may include
their objections with their results.
10. In case of ambiguities or contradictions in these rules, the
interpretation of the Technical Chair shall prevail. Suggestions
for future changes to these rules which would improve them in any
way, particularly in their fairness, clarity of interpretation, and
usefulness to the Ada community are always welcome.
11. Several copies of these rules will be made available for public
inspection and reference at the Fair.
12. Vendors are requested to present two copies of a written summary of
their results and two copies of the compilation listing of each test
program to the Technical Chair at least 30 minutes prior to the
opening of the demonstration period (scheduled for 10:00am on 30
June, 1984). Additional documentation which may be specifically
required for each test and supplemental information which the vendor
desires to supply for each test should be submitted at the same
time. In particular, cross reference listings, set/use listings,
assembly listings, linkage and load maps, etc., which were not
generated in the official test sequence, may be included. The
summary of results shall categorize the results in accordance with
the program outlined below:
with Text_IO; use Text_IO;
procedure Summarize is
type Vendor_Name is (<List of participating vendors>, None);
Vendor : Vendor_Name := None;
Columns : constant := 80;
subtype Comment is String (1 .. Columns);
Blank_Comment : constant Comment := (1 .. Columns => ' ');
type Note is array (1 .. 5) of String (1 .. Columns);
Blank_Note : constant Note := (1 .. 5 => (1 .. Columns => ' '));
Compilation_Environment : Note := Blank_Note;
Execution_Environment : Note := Blank_Note;
type Test_Result is (Passed,
Failed,
Uncertain,
Unable_To_Run,
Not_Attempted,
Disqualified,
Test_Has_Been_Dropped);
Seconds : constant Integer := 1;
type Size is digits 6;
Kilo_Bytes : constant Size := 1.0; -- represents 1024 bytes
type Result_Record is
record
Class : Test_Result := Not_Attempted;
Class_Comment : Comment := Blank_Comment;
Challenged_By_Vendor : Boolean := False;
Challenge_Comment : Comment := Blank_Comment;
-- Officially requested results go here:
Performance_Data : Note := Blank_Note;
Performance_Comment : Comment := Blank_Comment;
-- Explanations and objections go here:
Explanations : Note := Blank_Note;
-- This includes any intermediate translations by other
-- compilers or assemblers:
Compilation_Time : Duration := 0.0 * Seconds;
Compilation_Comment : Comment := Blank_Comment;
-- A value of zero indicates load- or execution-time binding:
Link_Or_Binding_Time : Duration := 0.0 * Seconds;
Linkage_Comment : Comment := Blank_Comment;
-- A value of zero indicates load time is included in
-- execution time (and cannot be reported separately).
Load_Time : Duration := 0.0 * Seconds;
Loading_Comment : Comment := Blank_Comment;
-- This includes Load_Time if it is not reported above:
Execution_Time : Duration := 0.0 * Seconds;
Execution_Comment : Comment := Blank_Comment;
-- This includes only the units whose source is in the
-- compilation;
-- it excludes predefined packages which they "with":
Object_Code_Size : Size := 0.000 * Kilo_Bytes;
Object_Code_Comment : Comment := Blank_Comment;
-- This includes pure code only; it excludes data and the
-- run-time support library:
Code_Image_Size : Size := 0.000 * Kilo_Bytes;
Code_Image_Comment : Comment := Blank_Comment;
-- This includes it all -- code, data, and run-time support:
Maximum_Memory_Used : Size := 0.000 * Kilo_Bytes;
Memory_Used_Comment : Comment := Blank_Comment;
end record;
Number_Of_Programs : constant
:= <Number actually submitted to vendors>;
type Number is range 1 .. Number_Of_Programs;
type Result_Array is array (Number) of Result_Record;
Results : Result_Array;
procedure Put (N : Note) is ... end Put;
procedure Put (R : Result_Record) is ... end Put;
begin
Set_Line(To => 10);
Set_Column(To => 31);
Put_Line("LA AdaTEC Ada* Fair");
Set_Column(To => 33);
Put_Line("30 June, 1984");
Set_Column(To => 29);
Put_Line("COMPILER TEST RESULTS");
New_Line;
Vendor := <This vendor's name>;
Set_Column(To => <TBD>);
Put(Vendor);
New_Line(2);
Compilation_Environment
:= <Description of the host computer and compiler toolset>;
Put(Compilation_Environment);
New_Line;
Execution_Environment
:= <Description of the target computer and run-time environment>;
Put(Execution_Environment);
Set_Line(To => 55);
Put("* Ada is a registered trademark of the U.S. Government " &
"(Ada Joint Program Office)");
Results := <Vendor's actual results>;
for N in Number loop
New_Page;
Put(Results(N));
end loop;
end Summarize;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)akerman.ada 2.3 Date: 9/21/84
--
-- Author: Brian A. Wichmann
-- National Physical Laboratory
-- Teddington, Middlesex TW11 OLW, UK
--
-- Modified by LA AdaTEC to conform to ANSI Standard Ada & to test
-- for significance of elapsed time.
--
-- [Extracts from: "Latest resuts from the procedure calling test,
-- Ackermann's function", B. A. Wichamann, NPL Report DITC 3/82,
-- ISSN 0143-7348]
--
-- Ackermann's function has been used to measure the procedure calling
-- overhead in languages which support recursion [Algol-like languages,
-- Assembly Languages, & Basic]
--
-- Ackermann's function is a small recursive function .... Although of
-- no particular interest in itself, the function does perform other
-- operations common to much systems programming (testing for zero,
-- incrementing and decrementing integers). The function has two
-- parameters M and N, the test being for (3, N) with N in the range
-- 1 to 6.
--
-- [End of Extract]
--
-- The object code size of the Ackermann function should be reported in
-- 8-bit bytes, as well as, the Average Number of Instructions Executed
-- per Call of the Ackermann function. Also, if the stack space is
-- exceeded, report the parameter values used as input to the initial
-- invocation of the Ackermann function.
--
-- The Average Number of Instructions Executed Per Call should preferably
-- be determined by examining the object code and calculating the number
-- of instructions executed for a significant number of calls of the
-- Ackermann function (see below). If that is not possible,
-- please make an estimate based the average execution time per machine
-- instruction for the target machine and the average time per call for
-- a significant number of calls. Clearly indicate whether the Average
-- Number of Instructions Executed Per Call is an estimate or not.
--
-- Note: In order for the measurement to be meaningful, it must be the
-- only program executing while the test is run. The number of calls is
-- significant if the elapsed time for the initial invocation of the
-- Ackermann's function is 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 Time_Ackermann is
type Real_Time is digits Max_Digits;
Start_Time : Time;
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;
I, J, K, K1, Calls: Integer;
function Ackermann (M, N: Natural) return Natural is
begin
if M = 0 then
return N + 1;
elsif N = 0 then
return Ackermann (M - 1, 1);
else
return Ackermann (M - 1, Ackermann (M, N -1 ));
end if;
end Ackermann;
begin
K := 16;
K1 := 1;
I := 1;
while K1 < Integer'Last / 512 loop
Start_Time := Clock;
J := Ackermann (3, I);
Elapsed_Time := Clock - Start_Time;
if J /= K - 3 then
Put_line (" *** Wrong Value ***");
end if;
Calls := (512*K1 - 15*K + 9*I + 37) / 3;
Put ("Number of Calls = ");
Put (Calls, Width => 0);
new_line;
Put ("Elapsed Time = ");
Put (Elapsed_Time, Fore => 0);
Put (" seconds -- precision is ");
if (Elapsed_Time < 100 * Duration'Small or
Elapsed_Time < 100 * System.Tick) then
Put_line ("Insignificant");
else
Put_line ("Significant");
end if;
Average_Time := Real_Time (Elapsed_Time / Calls);
Put ("Average Time per call = ");
Put (Average_Time, Fore => 0);
Put_Line (" seconds");
new_line;
I := I + 1;
K1 := 4 * K1;
K := 2 * K;
end loop;
Put_Line (" End of Ackermann Test");
exception
when Storage_Error =>
New_line;
Put ("Stack space exceeded for Ackermann ( 3, " );
Put (I);
Put_line ( ")" );
new_line;
Put_Line (" End of Ackermann Test");
end Time_Ackermann;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)boolvec.ada 1.3 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 "and" operation on the
-- elements of a boolean vector
--
-- Note: In order for the measurement to be meaningful, it must be the
-- only program executing while the test is run.
--
-- Please set Iterations 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 Boolean_Vector_AND_Test is
Iterations : 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;
Vector_Size : constant Positive := 25;
type vector is array (1..Vector_Size) of Boolean;
v1, v2, vector_result: vector;
count: integer := integer'first; -- used in timing loop
begin
-- Initialize Vectors
for N in vector'range loop
v1(N) := true;
v2(N) := boolean'val (N mod 2);
end loop;
-- Measure the timing loop overhead.
Start_Time := Clock;
for N in 1 .. Iterations 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 1 .. Iterations loop
count := count + 1; -- prevent optimization
vector_result := v1 and v2;
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");
Average_Time := Real_Time(Elapsed_Time - Loop_Time)/Real_Time(Vector_Size);
Put("Average time for " & '"' & "and" & '"' &
" of 2 arrays (" & Integer'Image (Vector_Size) & " elements) = ");
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 Boolean_Vector_AND_Test;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)bsearch.ada 1.1 Date: 5/30/84
--
-- Authors: Marion Moon and Bryce Bardin
-- Software Engineering Division
-- Ground Systems Group
-- Hughes Aircraft Company
-- Fullerton, CA
--
-- This package implements a generic binary search function.
-- It was designed to allow the use of an enumeration type for the table
-- index (a feature of possibly dubious utility, but included here for
-- uniformity with other generic operations on unconstrained arrays).
--
generic
type Index is (<>);
type Item is limited private;
type Table is array (Index range <>) of Item;
with function "=" (Left, Right : Item) return Boolean is <>;
with function ">" (Left, Right : Item) return Boolean is <>;
package Searching is
function Index_Of (Key : in Item; Within : in Table) return Index;
-- Returns the Index of the Item in Within which matches Key
-- if there is one, otherwise raises Not_Found.
Not_Found : exception;
-- Raised if the search fails.
end Searching;
package body Searching is
function Index_Of (Key : in Item; Within : in Table) return Index is
Low : Index := Within'First;
Mid : Index;
Hi : Index := Within'Last;
begin
loop
if Low > Hi then
raise Not_Found;
end if;
-- Calculate the mean Index value, using an expression
-- which can never overflow:
Mid := Index'Val(Index'Pos(Low)/2 + Index'Pos(Hi)/2 +
(Index'Pos(Low) rem 2 + Index'Pos(Hi) rem 2)/2);
if Within(Mid) = Key then
return Mid;
elsif Within(Mid) > Key then
-- This can raise Constraint_Error, but in that case
-- the search has failed:
Hi := Index'Pred(Mid);
else
-- This can raise Constraint_Error, but in that case
-- the search has failed:
Low := Index'Succ(Mid);
end if;
end loop;
exception
when Constraint_Error =>
raise Not_Found;
end Index_Of;
end Searching;
-- This procedure tests the binary search package at the extreme limits
-- of its index type.
with Searching;
with System; use System;
with Text_IO; use Text_IO;
procedure Main is
type Big_Integer is range Min_Int .. Max_Int;
type Table is array (Big_Integer range <>) of Character;
package Table_Search is
new Searching (Big_Integer, Character, Table);
use Table_Search;
T1 : constant Table (Big_Integer'First .. Big_Integer'First + 2) := "XYZ";
T2 : constant Table (Big_Integer'Last - 3 .. Big_Integer'Last) := "ABCD";
Index : Big_Integer;
Key : Character;
subtype Alpha is Character range 'A' .. 'Z';
package Big_IO is new Integer_IO (Big_Integer);
use Big_IO;
procedure Put_Match (Index : Big_Integer; Key : Character) is
begin
Put("The index for the key value of '" & Key & "' is ");
Put(Index, Width => 0);
Put('.');
New_Line;
end Put_Match;
begin
begin
for C in reverse Alpha loop
Key := C;
Index := Index_Of (Key, Within => T1);
Put_Match(Index, Key);
end loop;
exception
when Not_Found =>
Put("Key '");
Put(Key);
Put_Line("' not found.");
end;
begin
for C in Alpha loop
Key := C;
Index := Index_Of (Key, Within => T2);
Put_Match(Index, Key);
end loop;
exception
when Not_Found =>
Put("Key '");
Put(Key);
Put_Line("' not found.");
end;
end Main;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)cauchfl.ada 1.1 Date: 6/3/84
--
with text_io; use text_io;
procedure cauchy is
--
-- This test of floating point accuracy based on computing the inverses
-- of Cauchy matricies. These are N x N matricies for which the i, jth
-- entry is 1 / (i + j - 1). The inverse is computed using determinants.
-- As N increases, the determinant rapidly approaches zero. The inverse
-- is computed exactly and then checked by multiplying it by the original
-- matrix.
--
-- Gerry Fisher
-- Computer Sciences Corporation
-- May 27, 1984
type REAL is digits 6;
type MATRIX is array(POSITIVE range <>, POSITIVE range <>) of REAL;
trials : constant := 5;
FAILED : Boolean := FALSE;
function cofactor(A : MATRIX; i, j : POSITIVE) return MATRIX is
B : MATRIX(A'FIRST(1) .. A'LAST(1) - 1, A'FIRST(2) .. A'LAST(2) - 1);
x : REAL;
begin
for p in A'RANGE(1) loop
for q in A'RANGE(2) loop
x := A(p, q);
if p < i and then q < j then
B(p, q) := x;
elsif p < i and then q > j then
B(p, q - 1) := x;
elsif p > i and then q < j then
B(p - 1, q) := x;
elsif p > i and then q > j then
B(p - 1, q - 1) := x;
end if;
end loop;
end loop;
return B;
end cofactor;
function det(A : MATRIX) return REAL is
D : REAL;
k : INTEGER;
begin
if A'LENGTH = 1 then
D := A(A'FIRST(1), A'FIRST(2));
else
D := 0.0;
k := 1;
for j in A'RANGE(2) loop
D := D + REAL(k) * A(A'FIRST(1), j) * det(cofactor(A, A'FIRST(1), j));
k := - k;
end loop;
end if;
return D;
end det;
function init(n : positive) return MATRIX is
B : MATRIX(1 .. n, 1 .. n);
begin
for i in B'RANGE(1) loop
for j in B'RANGE(2) loop
B(i, j) := 1.0 / REAL(i + j - 1);
end loop;
end loop;
return B;
end init;
function inverse(A : MATRIX) return MATRIX is
B : MATRIX(A'RANGE(1), A'RANGE(2));
D : REAL := det(A);
E : REAL;
begin
if A'LENGTH = 1 then
return (1 .. 1 => (1 .. 1 => 1.0 / D));
end if;
for i in B'RANGE(1) loop
for j in B'RANGE(2) loop
B(i, j) := REAL((-1) ** (i + j)) * (det(cofactor(A, i, j)) / D);
end loop;
end loop;
-- Now check the inverse
for i in A'RANGE loop
for j in A'RANGE loop
E := 0.0;
for k in A'RANGE loop
E := E + A(i, k) * B(k, j);
end loop;
if (i = j and then E /= 1.0) or else
(i /= j and then E /= 0.0) then
raise PROGRAM_ERROR;
end if;
end loop;
end loop;
return B;
end inverse;
begin
put_line("*** TEST Inversion of Cauchy Matricies.");
for N in 1 .. trials loop
begin
declare
A : constant MATRIX := init(N);
B : constant MATRIX := inverse(A);
begin
put_line("*** REMARK: The Cauchy Matrix of size" & integer'image(N) &
" successfully inverted.");
end;
exception
when PROGRAM_ERROR =>
put_line("*** REMARK: The Cauchy Matrix of size" & integer'image(N) &
" not successfully inverted.");
when NUMERIC_ERROR =>
put_line("*** REMARK: The Cauchy Matrix of size" & integer'image(N) &
" appears singular.");
when others =>
put_line("*** REMARK: Unexpected exception raised.");
raise;
end;
end loop;
put_line("*** FINISHED Matrix Inversion Test.");
end cauchy;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)cauchfx.ada 1.1 Date: 6/3/84
--
with text_io; use text_io;
procedure cauchy is
--
-- This test of fixed point accuracy based on computing the inverses
-- of Cauchy matricies. These are N x N matricies for which the i, jth
-- entry is 1 / (i + j - 1). The inverse is computed using determinants.
-- As N increases, the determinant rapidly approaches zero. The inverse
-- is computed exactly and then checked by multiplying it by the original
-- matrix.
--
-- Gerry Fisher
-- Computer Sciences Corporation
-- May 27, 1984
type FIXED is delta 2.0**(-16) range -1000.0 .. +1000.00;
type MATRIX is array(POSITIVE range <>, POSITIVE range <>) of FIXED;
trials : constant := 5;
FAILED : Boolean := FALSE;
function cofactor(A : MATRIX; i, j : POSITIVE) return MATRIX is
B : MATRIX(A'FIRST(1) .. A'LAST(1) - 1, A'FIRST(2) .. A'LAST(2) - 1);
x : FIXED;
begin
for p in A'RANGE(1) loop
for q in A'RANGE(2) loop
x := A(p, q);
if p < i and then q < j then
B(p, q) := x;
elsif p < i and then q > j then
B(p, q - 1) := x;
elsif p > i and then q < j then
B(p - 1, q) := x;
elsif p > i and then q > j then
B(p - 1, q - 1) := x;
end if;
end loop;
end loop;
return B;
end cofactor;
function det(A : MATRIX) return FIXED is
D : FIXED;
k : INTEGER;
begin
if A'LENGTH = 1 then
D := A(A'FIRST(1), A'FIRST(2));
else
D := 0.0;
k := 1;
for j in A'RANGE(2) loop
D := D + k * FIXED(A(A'FIRST(1), j) * det(cofactor(A, A'FIRST(1), j)));
k := - k;
end loop;
end if;
return D;
end det;
function init(n : positive) return MATRIX is
B : MATRIX(1 .. n, 1 .. n);
begin
for i in B'RANGE(1) loop
for j in B'RANGE(2) loop
B(i, j) := 1.0 / (i + j - 1);
end loop;
end loop;
return B;
end init;
function inverse(A : MATRIX) return MATRIX is
B : MATRIX(A'RANGE(1), A'RANGE(2));
D : FIXED := det(A);
E : FIXED;
begin
if A'LENGTH = 1 then
return (1 .. 1 => (1 .. 1 => FIXED(FIXED(1.0) / D)));
end if;
for i in B'RANGE(1) loop
for j in B'RANGE(2) loop
B(i, j) := ((-1) ** (i + j)) * FIXED(det(cofactor(A, i, j)) / D);
end loop;
end loop;
-- Now check the inverse
for i in A'RANGE loop
for j in A'RANGE loop
E := 0.0;
for k in A'RANGE loop
E := E + FIXED(A(i, k) * B(k, j));
end loop;
if (i = j and then E /= 1.0) or else
(i /= j and then E /= 0.0) then
raise PROGRAM_ERROR;
end if;
end loop;
end loop;
return B;
end inverse;
begin
put_line("*** TEST Inversion of Cauchy Matricies.");
for N in 1 .. trials loop
begin
declare
A : constant MATRIX := init(N);
B : constant MATRIX := inverse(A);
begin
put_line("*** REMARK: The Cauchy Matrix of size" & integer'image(N) &
" successfully inverted.");
end;
exception
when PROGRAM_ERROR =>
put_line("*** REMARK: The Cauchy Matrix of size" & integer'image(N) &
" not successfully inverted.");
when NUMERIC_ERROR =>
put_line("*** REMARK: The Cauchy Matrix of size" & integer'image(N) &
" appears singular.");
when others =>
put_line("*** REMARK: Unexpected exception raised.");
raise;
end;
end loop;
put_line("*** FINISHED Matrix Inversion Test.");
end cauchy;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)cauchun.ada 1.1 Date: 6/3/84
--
with universal_integer_arithmetic; use universal_integer_arithmetic;
with universal_real_arithmetic; use universal_real_arithmetic;
with text_io; use text_io;
procedure cauchy is
--
-- This test of the Universal Arithmetic Packages computes the inverses
-- of Cauchy matricies. These are N x N matricies for which the i, jth
-- entry is 1 / (i + j - 1). The inverse is computed using determinants.
-- As N increases, the determinant rapidly approaches zero. The inverse
-- is computed exactly and then checked by multiplying it by the original
-- matrix.
--
-- Gerry Fisher
-- Computer Sciences Corporation
-- May 27, 1984
type MATRIX is array(POSITIVE range <>, POSITIVE range <>) of Universal_real;
one : Universal_integer := UI(1);
r_one : Universal_real := UR(one, one);
r_zero : Universal_real := UR(UI(0), one);
trials : constant := 10;
FAILED : Boolean := FALSE;
function cofactor(A : MATRIX; i, j : POSITIVE) return MATRIX is
B : MATRIX(A'FIRST(1) .. A'LAST(1) - 1, A'FIRST(2) .. A'LAST(2) - 1);
x : Universal_real;
begin
for p in A'RANGE(1) loop
for q in A'RANGE(2) loop
x := A(p, q);
if p < i and then q < j then
B(p, q) := x;
elsif p < i and then q > j then
B(p, q - 1) := x;
elsif p > i and then q < j then
B(p - 1, q) := x;
elsif p > i and then q > j then
B(p - 1, q - 1) := x;
end if;
end loop;
end loop;
return B;
end cofactor;
function det(A : MATRIX) return Universal_real is
D : Universal_real;
k : INTEGER;
begin
if A'LENGTH = 1 then
D := A(A'FIRST(1), A'FIRST(2));
else
D := r_zero;
k := 1;
for j in A'RANGE(2) loop
D := D + UI(k) * A(A'FIRST(1), j) * det(cofactor(A, A'FIRST(1), j));
k := - k;
end loop;
end if;
return D;
end det;
function init(n : positive) return MATRIX is
B : MATRIX(1 .. n, 1 .. n);
begin
for i in B'RANGE(1) loop
for j in B'RANGE(2) loop
B(i, j) := UR(one, UI(i + j - 1));
end loop;
end loop;
return B;
end init;
function inverse(A : MATRIX) return MATRIX is
B : MATRIX(A'RANGE(1), A'RANGE(2));
D : Universal_real := det(A);
E : Universal_real;
begin
if A'LENGTH = 1 then
return (1 .. 1 => (1 .. 1 => r_one / D));
end if;
for i in B'RANGE(1) loop
for j in B'RANGE(2) loop
B(i, j) := UI((-1) ** (i + j)) * det(cofactor(A, i, j)) / D;
end loop;
end loop;
-- Now check the inverse
for i in A'RANGE loop
for j in A'RANGE loop
E := r_zero;
for k in A'RANGE loop
E := E + A(i, k) * B(k, j);
end loop;
if (i = j and then not eql(E, r_one)) or else
(i /= j and then not eql(E, r_zero)) then
raise PROGRAM_ERROR;
end if;
end loop;
end loop;
return B;
end inverse;
begin
put_line("*** TEST Inversion of Cauchy Matricies.");
for N in 1 .. trials loop
begin
declare
A : constant MATRIX := init(N);
B : constant MATRIX := inverse(A);
begin
put_line("*** REMARK: The Cauchy Matrix of size " & integer'image(N) &
" successfully inverted.");
end;
exception
when PROGRAM_ERROR =>
put_line("*** FAILED: Matrix of size " & integer'image(N) &
" not successfully inverted.");
FAILED := True;
exit;
end;
end loop;
if not FAILED then
put_line("*** PASSED Matrix Inversion Test.");
end if;
end cauchy;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)char_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 Characters.
--
-- 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 Character_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 Char_IO is new Direct_IO (Character);
use Char_IO;
file: Char_IO.file_type;
value: character := 'A';
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;
Char_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;
Char_IO.write (file, value);
end loop;
Write_Time := Clock - Start_Time;
-- Close a file
Start_Time := Clock;
Char_IO.Close (file);
Close_Time := Clock - Start_Time;
-- Open a file
Start_Time := Clock;
Char_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;
Char_IO.read (file, value);
end loop;
Read_Time := Clock - Start_Time;
-- Delete a file
Start_Time := Clock;
Char_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 Character_Direct_IO_Test;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)char_enm.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 & the Enumeration_IO subpackage
-- with Characters.
--
-- 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 Character_Enumeration_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 Char_IO is new Enumeration_IO (Character);
file: Text_IO.file_type;
value: character := 'A';
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;
Char_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;
Char_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 Character_Enumeration_IO_Test;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)char_txt.ada 1.3 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 Characters.
--
-- 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 Character_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: character := 'A';
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;
Text_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;
Text_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 Character_Text_IO_Test;adatrain@trwspp.UUCP (09/30/84)
-------------------------------------------------------------------
--------------------- 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;