--::::::::::
--adafr85.pro
--::::::::::
-------- SIMTEL20 Ada Software Repository Prologue ------------
--
-- Unit name : ADAFAIR85
-- Version :
-- Author : LA AdaTEC, POC: Ed Colbert
-- : Absolute Software
-- : 220 40th Street
-- : Manhatten Beach, CA 90266
-- DDN Address :
-- Copyright :
-- Date created : 1984-1985
-- Release date : 7/11/87
-- Last update : 7/11/87
-- Machine/System Compiled/Run on : VAX/VMS
--
---------------------------------------------------------------
--
-- Keywords : benchmarks
--
-- Abstract :
-- ADAFAIR85 contains a set of tests/benchmarks
-- used to compare various Ada compilers.
--
------------------ Revision history ---------------------------
--
-- DATE VERSION AUTHOR HISTORY
-- 7/11/87 1 LA AdaTEC First ASR Release
--
------------------ Distribution and Copyright -----------------
--
-- This prologue must be included in all copies of this software.
--
-- This software is released to the Ada community.
-- This software is released to the Public Domain (note:
-- software released to the Public Domain is not subject
-- to copyright protection).
-- Restrictions on use or distribution: NONE
--
------------------ Disclaimer ---------------------------------
--
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered. The user is advised to
-- test the software thoroughly before relying on it. The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--
-------------------END-PROLOGUE--------------------------------
--::::::::::
--adafr85.cmm
--::::::::::
COMMENTS on ADAFAIR85.SRC
by Rick Conn, 5 Jan 87
I successfully compiled all but two modules in the ADAFAIR85.SRC
file. I did not attempt to execute any of the modules.
The compilations were done under VAX/VMS 4.4 with the DEC Ada
compiler on a VAX 11/785.
The module for Universal Arithmetic was required by other modules,
so I compiled it first. The file name is UNIV_AR.ADA. All other files were
compiled in alphabetical order. The full compilation order (as a VAX/VMS
command sequence) is:
$ ada UNIV_AR.ADA
$ ada AKERMAN.ADA
$ ada BOOLVEC.ADA
$ ada BSEARCH.ADA
$ ada CAUCHFL.ADA
$ ada CAUCHFX.ADA
$ ada CAUCHUN.ADA
$ ada CHAR_DIR.ADA
$ ada CHAR_ENM.ADA
$ ada CHAR_TXT.ADA
$ ada CONPROD.ADA
$ ada DERIVED.ADA
$ ada FLOATVEC.ADA
$ ada FRIEND.ADA
$ ada INTVEC.ADA
$ ada INT_DIR.ADA
$ ada INT_TEXT.ADA
$ ada LOWLEV.ADA
$ ada PHYSICS.ADA
$ ada PROCCAL.ADA
$ ada QSORTPAR.ADA
$ ada QSORTSEQ.ADA
$ ada RENDEZ.ADA
$ ada SETS.ADA
$ ada SHARED.ADA
All files compiled quickly except for PHYSICS.ADA. I ended up
compiling PHYSICS.ADA in batch, and the following statistics are offered:
Accounting information:
Buffered I/O count: 510 Peak working set size: 600
Direct I/O count: 1021 Peak page file size: 7512
Page faults: 345843 Mounted volumes: 0
Charged CPU time: 0 00:38:31.51 Elapsed time: 0 01:09:07.16
The files DERIVED.ADA and LOWLEV.ADA did not compile correctly.
The following are the diagnostics generated by these compilation attempts:
DERIVED.ADA
-----------
$ ada derived
82 Second at 0 range 8 .. 23;
.................1
(1) The number of bits to represent record component Second at line 77 (from
Originals at line 36) must be exactly 128
86 for New_Block'Size use 32;
.........1
(1) The number of bits to represent type declaration New_Block at line 77 must
be exactly 160
Error(s) compiling package specification Deriveds in file
DRB2:[CONTR13.ADA2]DERIVED.ADA;1
93 with Deriveds; use Deriveds;
.............1
(1) Unit Deriveds not found in library
...........................2
(2) Deriveds is not declared
101 Derived : New_Block := New_Block(Original);
......................1
(1) New_Block is not declared
...................................2
(2) New_Block is not declared
103 Copy : Block := Block(Derived);
.................................1
(1) Result type is unknown due to prior error related to variable Derived at
line 101
120 Put(Derived);
...............1
(1) Result type is unknown due to prior error related to variable Derived at
line 101
124 Put(Derived'Size);
...............1
(1) Result type is unknown due to prior error related to variable Derived at
line 101
132 if Copy = Original and Derived'Size = 32 then
..................................1
(1) Result type is unknown due to prior error related to variable Derived at
line 101
Error(s) compiling procedure body Change_Representation in file
DRB2:[CONTR13.ADA2]DERIVED.ADA;1
LOWLEV.ADA
----------
Ada compilation completed with 6 diagnostics
$ ada lowlev
44 type Int is range 0 .. 2**No_Of_Bits - 1;
................................................1
(1) Value 4294967295 is outside implemented range -2147483648 .. 2147483647 of
any integer type
57 for Bit_String'Size use No_Of_Bits;
...........1
(1) The number of bits to represent index constraint at line 56 must be exactly
256
Error(s) compiling procedure body Change_Types in file
DRB2:[CONTR13.ADA2]LOWLEV.ADA;1
Ada compilation completed with 2 diagnostics
--::::::::::
--adafr85.src
--::::::::::
::::::::::
adafair85.dis
::::::::::
--
-- The following is introductory documentation
--
ADAFAIR85.DOC
--
-- The following are the benchmarks in compilation order
--
UNIV_AR.ADA
AKERMAN.ADA
BOOLVEC.ADA
BSEARCH.ADA
CAUCHFL.ADA
CAUCHFX.ADA
CAUCHUN.ADA
CHAR_DIR.ADA
CHAR_ENM.ADA
CHAR_TXT.ADA
PHYSICS.ADA
CONPROD.ADA
DERIVED.ADA
FLOATVEC.ADA
FRIEND.ADA
INT_DIR.ADA
INT_TEXT.ADA
INTVEC.ADA
LOWLEV.ADA
PROCCAL.ADA
QSORTPAR.ADA
QSORTSEQ.ADA
RENDEZ.ADA
SETS.ADA
SHARED.ADA
::::::::::
ADAFAIR85.DOC
::::::::::
The messages and programs contained in this file were received from
Ed Colbert in conjunction with Ada Fair '85. If there are any questions
with respect to this file please contact Mr. Colbert at :
trwrb!trwspp!spp1!colbert(ampersand)Berkeley . ( Note: I am unable to
transmit an ampersand over the net without the host saying 'BAD" things
about my computer literacy. ) RAY SZYMANSKI -----------
This is the 1st of 4 messages that you should receive. Included are the
rules for running the programs, a copy of 3 universial arithmatic packages,
and a copy of the 24 programs that were used this year. This years programs
consisted of all of last years programs plus 1 new one, a real world Physics
problem. All of the programs have been tested on a number of validated
compilers and are correct to the best of our knowledge (there was a logic
bug in boolvec.ada, but that has been corrected in the copy I am sending
you).
--------------------------------------------------------------------------
------------------------- 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 (, 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
:= ;
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 := ;
Set_Column(To => );
Put(Vendor);
New_Line(2);
Compilation_Environment
:= ;
Put(Compilation_Environment);
New_Line;
Execution_Environment
:= ;
Put(Execution_Environment);
Set_Line(To => 55);
Put("* Ada is a registered trademark of the U.S. Government " &
"(Ada Joint Program Office)");
Results := ;
for N in Number loop
New_Page;
Put(Results(N));
end loop;
end Summarize;
::::::::::
UNIV_AR.ADA
::::::::::
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
------------------------------------------------------------------------
--
--
--
-- U N I V E R S A L A R I T H M E T I C P A C K A G E S
--
-- Version: @(#)univ_ar.ada 1.1 Date: 5/30/84
--
-- written by
--
-- Gerry Fisher
-- Computer Sciences Corporation
-- 4045 Hancock Street
-- San Diego, CA 92110
--
--
--
-- The packages UNIVERSAL_INTEGER_ARITHMETIC and UNIVERSAL_REAL_ARITHMETIC,
-- implement the arithmetic operations for the Ada* universal_integer and
-- universal_real types. Unlimited precision arithmetic is used for the
-- universal_integer type and rational arithmetic for the universal_real
-- type. The implementation is based on the universal arithmetic package
-- written in SETL by Robert Dewar for the NYU Ada/Ed compiler, and was
-- coded in part while the author worked at TeleSoft.
--
-- The implementation presented here is not the most efficient. It is,
-- however, quite general and requires no low level facilities. With some
-- tuning these packages could be used within an Ada compiler to evaluate
-- static expressions. They also provide an excellent example of the use
-- of Ada packages to support an abstract data type.
--
-- * Ada is a registered trademark of the DoD (Ada Joint Program Office)
--
------------------------------------------------------------------------
package UNIVERSAL_INTEGER_ARITHMETIC is
-- This package implements the Ada type Universal_integer.
-- The operations defined on universal integers are those specified in
-- chapter 4 of the RM. Since the equality and inequality operators can
-- not be overloaded, an equality operation is defined. In addition,
-- conversions between INTEGER, STRING and Universal_integer are defined.
type Universal_integer is private;
function "+" (x, y : Universal_integer) return Universal_integer;
function "-" (x, y : Universal_integer) return Universal_integer;
function "*" (x, y : Universal_integer) return Universal_integer;
function "/" (x, y : Universal_integer) return Universal_integer;
function "mod"(x, y : Universal_integer) return Universal_integer;
function "rem"(x, y : Universal_integer) return Universal_integer;
function "**" (x : Universal_integer; y : INTEGER) return Universal_integer;
function "-" (x : Universal_integer) return Universal_integer;
function "abs"(x : Universal_integer) return Universal_integer;
function ">=" (x, y : Universal_integer) return boolean;
function ">" (x, y : Universal_integer) return boolean;
function "<=" (x, y : Universal_integer) return boolean;
function "<" (x, y : Universal_integer) return boolean;
function eql (x, y : Universal_integer) return boolean;
function Int(x : Universal_integer) return INTEGER;
-- Converts a universal integer to a integer. The exception
-- NUMERIC_ERROR is raised if the universal integer x has a value
-- outside the integer range.
function UI(i : INTEGER) return Universal_integer;
-- Constructs a universal integer from an integer.
function IMAGE(x : Universal_integer) return STRING;
-- Converts the universal integer x into its string image, that is, a
-- sequence of characters representing the value in display form. The
-- image of a universal integer value is the corresponding decimal
-- literal; without underlines, leading zeros, exponent or trailing spaces;
-- but with a single leading minus sign or space. The lower bound of the
-- image string is one.
function VALUE(s : STRING) return Universal_integer;
-- Converts the string s into a universal integer value. The string must have
-- the syntax of an optionally signed decimal integer literal; otherwise, the
-- exception CONSTRAINT_ERROR is raised. The exponent of the decimal literal,
-- if present, must not exceed INTEGER'LAST.
private
type VECTOR;
type Universal_integer is access VECTOR;
end UNIVERSAL_INTEGER_ARITHMETIC;
package body UNIVERSAL_INTEGER_ARITHMETIC is
-- A universal integer consists of a sign and a magnitude. The
-- magnitude is a vector of non-negative integers giving from
-- most significant to least significant the "digits" of the
-- number in some convenient base. There are no leading zero digits,
-- unless the value is zero. Universal integers are always normalized.
-- The lower bound of the universal integer vector is always one.
-- Thus, the magnitude for the vector V(1 .. k) is given by:
--
-- V(1) * BASE**(k - 1) + V(2) * BASE**(k - 2) + ... + V(k)
--
-- The maximum number of digits in a universal integer is limited
-- in this implementation only by the amount of available memory.
--
-- The base is 10 ** ((INTEGER'WIDTH - 2) / 2). The universal digits are
-- integers in the range 0 .. BASE - 1. This choice of BASE means that
-- slightly less than half of the integer range is used. However, the
-- choice does ensure that the product of two universal digits is an integer.
-- Also, the number of universal digits required to represent an integer value
-- as a universal integer is at most four.
--
-- To complete the representation the high order universal digit has the sign
-- of the universal integer.
BASE_D : constant := (INTEGER'WIDTH - 2) / 2;
BASE : constant := 10 ** BASE_D;
BASE_SQ : constant := BASE * BASE;
INT_D : constant := 4;
type VECTOR is array(POSITIVE range <>) of INTEGER;
i_zero : constant Universal_integer := new VECTOR'(1 => 0);
i_one : constant Universal_integer := new VECTOR'(1 => 1);
i_two : constant Universal_integer := new VECTOR'(1 => 2);
i_ten : constant Universal_integer := new VECTOR'(1 => 10);
function UI(v : VECTOR; s : BOOLEAN := FALSE) return Universal_integer is
-- Constructs a universal integer from a vector and a sign; the vector
-- need not be normalized. The boolean s is true if the number is negative.
t : Universal_integer;
begin
-- The representation used in this package requires that all
-- Universal_integer values be normalized. The first digit of any
-- value, except zero, must be non-zero.
for j in v'range loop
if v(j) /= 0 then
t := new VECTOR(1 .. v'last - j + 1); -- ensure lower bound of one
t.all := v(j .. v'last);
if s then t(1) := - t(1); end if;
return t;
end if;
end loop;
return i_zero;
end UI;
function UI(i : INTEGER) return Universal_integer is
y : VECTOR(1 .. INT_D) := (1 .. INT_D => 0);
z : INTEGER;
begin
if i < BASE and then i > - BASE then
return new VECTOR'(1 => i);
end if;
z := i;
for j in reverse y'range
loop
y(j) := abs(z rem BASE);
z := z / BASE;
end loop;
return UI(y, i < 0);
end UI;
function Int(x : Universal_integer) return INTEGER is
y : INTEGER;
begin
if x'length = 1 then
return x(1);
end if;
y := 0;
for i in x'range loop -- convert as a negative integer
y := y * BASE - abs x(i); -- this may raise NUMERIC_ERROR, but
end loop; -- only if the magnitude of x is too large.
if x(1) < 0 then
return y;
else
return - y; -- this may raise NUMERIC_ERROR if x is
end if; -- -(integer'first) and range is not symmetric.
end Int;
function IMAGE(x : Universal_integer) return STRING is
m : integer := x'length * BASE_D + 1;
s : string(1 .. m);
y : Universal_integer;
j, d : integer;
begin
if x(1) = 0 then
return " 0";
end if;
j := m;
y := abs x;
while y(1) /= 0 loop
d := Int(y rem i_ten);
y := y / i_ten;
s(j) := character'val(character'pos('0') + d);
j := j - 1;
end loop;
if x(1) < 0 then
s(j) := '-';
else
s(j) := ' ';
end if;
d := m - j + 1;
s(1 .. d) := s(j .. m);
return s(1 .. d);
end IMAGE;
function VALUE(s : STRING) return Universal_integer is
num : Universal_integer := i_zero;
exp : integer := 0;
signed : boolean := false;
has_exp: boolean := false;
c : character;
j : integer;
begin
if s'length = 0 then
raise CONSTRAINT_ERROR;
end if;
j := s'first;
c := s(j);
if c = '-' or else c = '+' then
j := j + 1;
if s(j) not in '0' .. '9' then -- index out of range may also raise
raise CONSTRAINT_ERROR; -- constraint_error here
end if;
signed := c = '-';
end if;
while j <= s'last loop
c := s(j);
case c is
when '0' .. '9' =>
if has_exp then
exp := exp * 10 + (character'pos(c) - character'pos('0'));
else
num := num * i_ten + UI(character'pos(c) - character'pos('0'));
end if;
when '_' =>
if s(j - 1) not in '0' .. '9' or else s(j + 1) not in '0' .. '9' then
raise CONSTRAINT_ERROR;
end if;
when 'E' | 'e' =>
if has_exp or else s(j - 1) not in '0' .. '9' then
raise CONSTRAINT_ERROR;
end if;
has_exp := true;
if s(j + 1) = '+' then j := j + 1; end if;
if s(j + 1) not in '0' .. '9' then
raise CONSTRAINT_ERROR;
end if;
when others =>
raise CONSTRAINT_ERROR;
end case;
j := j + 1;
end loop;
if has_exp then num := num * i_ten ** exp; end if;
if signed then num := - num; end if;
return num;
end VALUE;
function "-" (x : Universal_integer) return Universal_integer is
begin
return new VECTOR'(- x(1) & x(2 .. x'last));
end "-";
function "abs" (x : Universal_integer) return Universal_integer is
begin
return new VECTOR'(abs x(1) & x(2 .. x'last));
end "abs";
function "+" (x, y : Universal_integer) return Universal_integer is
m : integer;
k, r : integer;
xl, yl : integer;
xs, ys : boolean;
begin
xl := x'length;
yl := y'length;
if xl = 1 and then yl = 1 then -- each has one digit
return UI(x(1) + y(1));
else -- either or both operands have > 1 digits
if xl < yl then
m := yl + 1;
else
m := xl + 1;
end if;
declare
u, v : VECTOR(1 .. m);
begin
xs := x(1) < 0;
ys := y(1) < 0;
u := (1 .. m - xl => 0) & abs x(1) & x(2 .. xl);
v := (1 .. m - yl => 0) & abs y(1) & y(2 .. yl);
if xs = ys then -- signs agree so add
k := 0;
for i in reverse 1 .. m loop
r := u(i) + v(i) + k;
if r >= BASE then
r := r - BASE;
k := 1;
else
k := 0;
end if;
u(i) := r;
end loop;
return UI(u, xs);
else
-- signs different, subtract smaller from larger
k := 0;
for i in reverse 1 .. m loop
r := u(i) - v(i) + k;
if r < 0 then
r := r + BASE;
k := - 1;
else
k := 0;
end if;
u(i) := r;
end loop;
if k = 0 then -- x has the larger magnitude
return UI(u, xs);
else -- y has the larger magnitude, so recomplement
k := 1;
for i in reverse 1 .. m loop
r := BASE - 1 - u(i) + k;
if r = BASE then
r := 0;
k := 1;
else
k := 0;
end if;
u(i) := r;
end loop;
return UI(u, ys);
end if;
end if;
end;
end if;
end "+";
function "-" (x, y : Universal_integer) return Universal_integer is
begin
return x + (- y);
end "-";
function "*" (x, y : Universal_integer) return Universal_integer is
-- This function returns the product of the universal integers x
-- and y using essentially the familiar hand algorithm.
xl, yl : integer;
begin
xl := x'length;
yl := y'length;
if xl = 1 and yl = 1 then -- both have a single digit
return UI(x(1) * y(1));
end if;
declare
w : VECTOR(1 .. xl + yl) := (1 .. xl + yl => 0);
k, r : integer;
begin
for j in reverse y'range loop
-- outer loop through digits of the multiplier, inner loop
-- through digits of multiplicand
k := 0;
for i in reverse x'range loop
r := abs(x(i) * y(j)) + w(i + j) + k;
w(i + j) := r rem BASE;
k := r / BASE;
end loop;
w(j) := k;
end loop;
return UI(w, (x(1) < 0) xor (y(1) < 0));
end;
end "*";
function "/" (x, y : Universal_integer) return Universal_integer is
m : integer;
xl, yl : integer;
e : integer;
d, r, t : integer;
qe : integer; -- quotient digit estimate
v1, v2 : integer;
begin
xl := x'length;
yl := y'length;
if xl = 1 and then yl = 1 then -- can use simple integer division
return UI(x(1) / y(1)); -- integer divide catches zero divisor
elsif xl < yl then -- divisor has more digits
return i_zero;
elsif yl = 1 then -- divisor has single digit
-- dividend has more than one digit,
-- important special case for which
-- an efficient algorithm is used
r := 0;
v1 := abs y(1);
if v1 = 0 then -- divisor is zero
raise NUMERIC_ERROR;
end if;
declare
q : VECTOR(1 .. xl);
begin
for j in x'range loop
t := r * BASE + abs x(j);
q(j) := t / v1;
r := t rem v1;
end loop;
return UI(q, (x(1) < 0) xor (y(1) < 0));
end;
end if;
-- At this point the length of the dividend is at least two and
-- at least as much as the length of the divisor. We must do a
-- full long division. The algorithm used here is from Knuth,
-- "The Art of Programming", Volume 2, Section 4.3.1, Algorithm D.
-- The first step is to multiply both the divisor and dividend
-- by a scale factor to ensure that the first digit of the divisor
-- is at least BASE / 2. This condition is required by the
-- quotient digit estimation algorithm used in the division loop.
-- Note that this may increase the size of the dividend by one digit
-- and thus the scaled dividend is placed in u.
m := xl - yl + 1;
declare
u : VECTOR(1 .. xl + 1); -- the dividend
v : VECTOR(1 .. yl); -- the divisor
q : VECTOR(1 .. m); -- the quotient
begin
u := 0 & abs x(1) & x(2 .. xl);
v := abs y(1) & y(2 .. yl);
v1 := v(1);
d := BASE / (v1 + 1); -- scale factor
if d > 1 then -- scale dividend and divisor
r := 0;
for j in reverse u'range loop
t := u(j) * d + r;
u(j) := t rem BASE;
r := t / BASE;
end loop;
r := 0;
for j in reverse v'range loop
t := v(j) * d + r;
v(j) := t rem BASE;
r := t / BASE;
end loop;
end if;
-- This is the major loop, corresponding to long division steps.
v1 := v(1);
v2 := v(2);
for j in q'range loop
-- Guess the next quotient digit, qe, by dividing the first two
-- remaining dividend digits by the high order divisor digit.
-- This estimate is never low and is at most 2 high.
t := u(j) * BASE + u(j + 1);
if u(j) /= v1 then
qe := t / v1;
else
qe := BASE - 1;
end if;
-- Now refine this guess so that it is almost always correct and
-- is at worst one too high.
while v2 * qe > (t - qe * v1) * BASE + u(j + 2) loop
qe := qe - 1;
end loop;
-- Using qe as the quotient digit, we multiply the divisor by
-- qe and subtract from the remaining dividend.
r := 0;
for k in reverse v'range loop
t := u(j + k) - qe * v(k) + r;
e := t rem BASE;
r := t / BASE;
if e < 0 then
e := e + BASE;
r := r - 1;
end if;
u(j + k) := e;
end loop;
u(j) := u(j) + r;
-- If qe was off by one, then u(j) went negative when the last
-- carry was added. So we correct the error by subtracting one
-- from the quotient digit and adding back the divisor to the
-- relevant portion of the dividend.
if u(j) < 0 then
qe := qe - 1;
r := 0;
for k in reverse v'range loop
t := u(j + k) + v(k) + r;
if t > BASE then
t := t - BASE;
r := 1;
else
r := 0;
end if;
u(j + k) := t;
end loop;
u(j) := u(j) + r;
end if;
-- Store the next quotient digit.
q(j) := qe;
end loop;
return UI(q, (x(1) < 0) xor (y(1) < 0));
end;
end "/";
function "rem"(x, y : Universal_integer) return Universal_integer is
begin
if x'length = 1 and then y'length = 1 then
return UI(x(1) rem y(1));
else
return x - (x / y) * y;
end if;
end "rem";
function "mod"(x, y : Universal_integer) return Universal_integer is
r : constant Universal_integer := x rem y;
begin
if (x(1) < 0) = (y(1) < 0) or else r(1) = 0 then
return r;
else
return y + r;
end if;
end "mod";
function "**"(x : Universal_integer; y : INTEGER) return Universal_integer is
-- Raise a universal integer to an integer power using the binary
-- representation of the exponent.
r : Universal_integer := i_one;
v : integer := y;
t : Universal_integer := abs x;
begin
if y < 0 then
raise CONSTRAINT_ERROR;
elsif y = 0 then
return i_one;
elsif x(1) = 0 then
return i_zero;
end if;
-- Starting the variable r at 1 and t at x loop through the binary
-- digits of v, squaring t each time, and multiplying the result r
-- by the current value of t each time a 1-bit is found.
while v /= 0 loop
if v rem 2 = 1 then -- v is odd
r := r * t;
end if;
t := t * t;
v := v / 2; -- halve v
end loop;
-- Compute the sign of the result: positive if y is even, the sign of
-- x if y is odd.
if x(1) < 0 and then y rem 2 = 1 then r(1) := - r(1); end if;
return r;
end "**";
function ">=" (x, y : Universal_integer) return boolean is
z : Universal_integer := x - y;
begin
return z(1) >= 0;
end ">=";
function "<=" (x, y : Universal_integer) return boolean is
z : Universal_integer := x - y;
begin
return z(1) <= 0;
end "<=";
function "<" (x, y : Universal_integer) return boolean is
z : Universal_integer := x - y;
begin
return z(1) < 0;
end "<";
function ">" (x, y : Universal_integer) return boolean is
z : Universal_integer := x - y;
begin
return z(1) > 0;
end ">";
function eql (x, y : Universal_integer) return boolean is
begin
return x.all = y.all;
end eql;
end UNIVERSAL_INTEGER_ARITHMETIC;
with UNIVERSAL_INTEGER_ARITHMETIC;
use UNIVERSAL_INTEGER_ARITHMETIC;
package UNIVERSAL_REAL_ARITHMETIC is
-- This package implements the Ada type Universal_real.
-- The operations defined on universal numbers are those specified in
-- chapter 4 of the RM. Since the equality and inequality operators can
-- not be overloaded, an equality function is defined. A universal real
-- number corresponds to a unique pair of universal integers that represent
-- it as a rational number. A function, UR, is defined that constructs a
-- universal real number from a pair of universal integers. Also, the inverse
-- of this function is provided by two functions, NUMERATOR and DENOMINATOR,
-- that decompose the rational number representation of their universal real
-- argument into its numerator and denominator, respectively. In addition,
-- conversions between Universal_integer and Universal_real are defined.
type Universal_real is private;
function "+" (x, y : Universal_real) return Universal_real;
function "-" (x, y : Universal_real) return Universal_real;
function "*" (x, y : Universal_real) return Universal_real;
function "/" (x, y : Universal_real) return Universal_real;
function "**" (x : Universal_real; y : INTEGER) return Universal_real;
function "*" (x : Universal_integer; y : Universal_real)
return Universal_real;
function "*" (x : Universal_real; y : Universal_integer)
return Universal_real;
function "/" (x : Universal_real; y : Universal_integer)
return Universal_real;
function "-" (x : Universal_real) return Universal_real;
function "abs"(x : Universal_real) return Universal_real;
function ">=" (x, y : Universal_real) return boolean;
function ">" (x, y : Universal_real) return boolean;
function "<=" (x, y : Universal_real) return boolean;
function "<" (x, y : Universal_real) return boolean;
function eql (x, y : Universal_real) return boolean;
function UI(x : Universal_real) return Universal_integer;
-- Converts a universal real to a universal integer by rounding.
function UR(x : Universal_integer) return Universal_real;
-- Converts a universal integer to a universal real.
function UR(n, d : Universal_integer) return Universal_real;
-- Constructs a universal real as the ratio of two universal integers.
-- The value of d must not be ZERO; if it is, NUMERIC_ERROR is raised.
function NUMERATOR(x : Universal_real) return Universal_integer;
-- Returns the numerator of x viewed as a rational number.
function DENOMINATOR(x : Universal_real) return Universal_integer;
-- Returns the denominator of x viewed as a rational number.
private
-- A universal real is represented as a rational number consisting
-- of a pair of universal integers. The numerator is the first
-- member of the pair and the denominator is the second. The
-- denominator must not be zero. Also, the numerator, denominator
-- pair is always reduced to lowest terms.
type Universal_real is
record
num : Universal_integer;
den : Universal_integer;
end record;
end UNIVERSAL_REAL_ARITHMETIC;
with UNIVERSAL_INTEGER_ARITHMETIC;
use UNIVERSAL_INTEGER_ARITHMETIC;
pragma ELABORATE(UNIVERSAL_INTEGER_ARITHMETIC);
package body UNIVERSAL_REAL_ARITHMETIC is
i_zero : constant Universal_integer := UI(0);
i_one : constant Universal_integer := UI(1);
i_two : constant Universal_integer := UI(2);
i_ten : constant Universal_integer := UI(10);
r_zero : constant Universal_real := (i_zero, i_one);
r_one : constant Universal_real := (i_one, i_one);
function UR(n, d : Universal_integer) return Universal_real is
-- Constructs a universal real as the ratio of two universal integers.
-- The value of d must not be ZERO; if it is, NUMERIC_ERROR is raised.
-- Every real number produced as a result of an operation defined in
-- this package must have a positive denominator and the numerator and
-- denominator must be reduced to lowest terms. This ensures uniqueness
-- of the representation.
r : Universal_integer;
y : Universal_integer;
z : Universal_integer;
begin
if eql(d, i_zero) then
raise NUMERIC_ERROR;
elsif eql(n, i_zero) then
return r_zero;
end if;
-- Now reduce to lowest terms; that is, find the gcd of n and d.
y := abs n;
z := abs d;
loop
r := y rem z;
exit when eql(r, i_zero);
y := z;
z := r;
end loop;
if d >= i_zero then
return (n / z, d / z);
else
return (- n / z, - d / z);
end if;
end UR;
function UI(x : Universal_real) return Universal_integer is
i : Universal_integer := x.num / x.den;
r : Universal_real := (i, i_one);
h : Universal_real := (i_two, i_one);
begin
if eql(x.num, i_zero) then
return i_zero;
elsif x.num < i_zero and then x - r <= - h then
return i - i_one;
elsif x.num > i_zero and then x - r >= h then
return i + i_one;
else
return i;
end if;
end UI;
function UR(x : Universal_integer) return Universal_real is
begin
return (x, i_one);
end UR;
function NUMERATOR(x : Universal_real) return Universal_integer is
begin
return x.num;
end NUMERATOR;
function DENOMINATOR(x : Universal_real) return Universal_integer is
begin
return x.den;
end DENOMINATOR;
function "-" (x : Universal_real) return Universal_real is
begin
return (- x.num, x.den);
end "-";
function "abs" (x : Universal_real) return Universal_real is
begin
return (abs x.num, x.den);
end "abs";
function "*" (x : Universal_integer; y : Universal_real)
return Universal_real is
begin
return UR(y.num * x, y.den);
end "*";
function "*"(x : Universal_real; y : Universal_integer)
return Universal_real is
begin
return UR(x.num * y, x.den);
end "*";
function "/"(x : Universal_real; y : Universal_integer)
return Universal_real is
begin
return UR(x.num, x.den * y);
end "/";
function "+" (x, y : Universal_real) return Universal_real is
begin
return UR(x.num * y.den + y.num * x.den, x.den * y.den);
end "+";
function "-" (x, y : Universal_real) return Universal_real is
begin
return x + (- y);
end "-";
function "*" (x, y : Universal_real) return Universal_real is
begin
return UR(x.num * y.num, x.den * y.den);
end "*";
function "/" (x, y : Universal_real) return Universal_real is
begin
return UR(x.num * y.den, x.den * y.num);
end "/";
function "**"(x : Universal_real; y : INTEGER) return Universal_real is
begin
if y = 0 then
return r_one;
elsif y > 0 then
return UR(x.num ** y, x.den ** y);
else
return UR(x.den ** (- y), x.num ** (- y));
end if;
end "**";
function ">=" (x, y : Universal_real) return boolean is
z : Universal_real := x - y;
begin
return z.num >= i_zero;
end ">=";
function "<=" (x, y : Universal_real) return boolean is
z : Universal_real := x - y;
begin
return z.num <= i_zero;
end "<=";
function "<" (x, y : Universal_real) return boolean is
z : Universal_real := x - y;
begin
return z.num < i_zero;
end "<";
function ">" (x, y : Universal_real) return boolean is
z : Universal_real := x - y;
begin
return z.num > i_zero;
end ">";
function eql (x, y : Universal_real) return boolean is
z : Universal_real := x - y;
begin
return eql(z.num, i_zero);
end eql;
end UNIVERSAL_REAL_ARITHMETIC;
::::::::::
AKERMAN.ADA
::::::::::
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)akerman.ada 2.4 Date: 6/3/85
--
-- 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) / Real_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;
::::::::::
BOOLVEC.ADA
::::::::::
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)boolvec.ada 1.4 Date: 6/17/85
--
-- 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(Iterations);
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;
::::::::::
BSEARCH.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
CAUCHFL.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
CAUCHFX.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
CAUCHUN.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
CHAR_DIR.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
CHAR_ENM.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
CHAR_TXT.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
PHYSICS.ADA
::::::::::
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)physics.ada 1.1 Date: 6/3/85
--
-- Supplied by: John Squires
-- Westinghouse Electric Company
-- (except as noted)
--
-- Edited by: Jim Alstad
-- Software Engineering Laboratories
-- Radar Systems Group
-- Hughes Aircraft Company
-- El Segundo CA USA
--
-- Series of compilation units to test real-world (i.e., heavy) use
-- of packages. Can be compilation & link time benchmark. The main
-- program (PHYSICS_1) should execute quickly.
--
-- Two units were written by Alstad; the rest are taken from
-- the tape distributed by Squires following the San Jose SIGAda meeting
-- (winter 85). Necessary alterations by Alstad
-- are flagged "--Alstad". The compilation units are as follows, where
-- a trailing underscore means a specification unit:
--
-- NthRoot_ Alstad
-- NthRoot Alstad
-- PHYSICAL_REAL Squires
-- LONG_FLT_IO Squires
-- PHYSICAL_UNITS_BASIC Squires
-- PHYSICAL_UNITS_MECHANICAL Squires
-- PHYSICAL_UNITS_ELECTRICAL Squires
-- PHYSICAL_UNITS_OTHER Squires
-- PHYSICAL_UNITS_OUTPUT_BASIC_ Squires
-- PHYSICAL_UNITS_OUTPUT_BASIC Squires
-- PHYSICAL_UNITS_OUTPUT_MECHANICAL_ Squires
-- PHYSICAL_UNITS_OUTPUT_MECHANICAL Squires
-- MKS_PHYSICS_MECHANICAL_ Squires
-- MKS_PHYSICS_MECHANICAL Squires
-- PHYSICS_1 Squires
--
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--
-- Version: NthRoot_.ada 1.0 Date: 5/29/85
--
-- Author: Jim Alstad
-- Software Engineering Laboratories
-- Radar Systems Group
-- Hughes Aircraft Company
-- El Segundo CA USA
--
-- Simple generic package to compute Nth roots.
--
-- Instantiating NthRoot with N, an integer >= 2,
-- and Arith-Type, a floating point type,
-- yields NthRoot.RootOf, a function which computes
-- the Nth root of its argument.
--
-- The result is an approximation, good to (at least) four digits.
-- For simplicity, RootOf (- X) = - RootOf (X), though N may be even.
-- Arith-Type is used for intermediate calculations.
--
generic
N: integer; -- N >= 2
type Arith_Type is digits <>;
package
NthRoot is
function
RootOf (X: Arith_Type) return Arith_Type;
end NthRoot; --spec
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--
-- Version: NthRoot.ada 1.0 Date: 5/29/85
--
--
-- Author: Jim Alstad
-- Software Engineering Laboratories
-- Radar Systems Group
-- Hughes Aircraft Company
-- El Segundo CA USA
--
-- Assisted by Nat Bachman (same affiliation).
--
-- Simple generic package to compute Nth roots.
--
-- The basic approach is to use Newton's method, which computes
-- successive approximations. This may be summarized as follows.
-- Suppose a number X and a function F are given, and it is desired
-- to find a Y such that F(Y) = X. Then Newton's method says that
-- a better approximation YNext may be found via
-- YNext = Y + (X - F(Y)) / F'(Y) .
-- Taking F(Y) to be Y**N, Y to be RootPrev, and YNext to be Root yields
-- Root = ((X/RootPrev**(N-1)) + ((N-1)*RootPrev)) / N ,
-- which is the formula used below. Iteration continues until
-- Root and RootPrev differ by less than Tolerance.
--
-- Convergence is fairly fast once RootPrev gets close to the actual root.
-- To speed this up, X is "normalized" into XNorm, where 1 <= XNorm < 2**N.
-- This means that 1 <= RootOf(XNorm) < 2, so that 2.0 is used as
-- the initial approximation to RootOf(XNorm). A side effect of this is
-- that the approximation to RootOf(XNorm) will never be less than
-- the actual root.
--
-- From a programming point of view, the main point of interest is
-- calculating XNorm (from XG1). This involves dividing XNorm by values
-- Power(C).TwoN, while remembering corresponding values Power(C).Two
-- by which to multiply Root to compensate. This algorithm can be
-- characterized as calculating the integer part of log(X), where
-- the log is base 2**N, by calculating the bits in its binary
-- representation from left to right (!). The initialization of Power
-- is also interesting, as it uses an exception to terminate a loop
-- (no alternative seems as appropriate).
--
-- This routine is used as a vehicle to demonstrate Dijkstra's proof-
-- of-correctness technique, which is based on his "weakest precondition"
-- predicate transformer. (This demonstration has not been carried
-- through 100%.)
--
-- The main consideration in designing this routine has been to achieve
-- reasonable accuracy and efficiency with broad applicability but
-- without an extended effort (i.e., it had to be interesting).
-- Consequently there are some rough edges. Here is a partial list:
-- 1. There is no check for N < 2.
-- 2. Arith-Type'small <= abs (X) < 1 / MaxX causes numeric_error.
--
--
package body
NthRoot is
-- - MaxX <= X <= MaxX
MaxX: constant Arith_Type := Arith_Type'large;
-- (2**N) ** (2**(CBound + 1)) > MaxX
CBound: constant := 10;
subtype
CIndex is integer range 0..CBound;
-- Power assertion (after initialization):
-- for all C in 0..CMax:
-- RootOf(Power(C).TwoN) = Power(C).Two &
-- Power(C+1) = Power(C) ** 2 &
-- Power(CMax+1).TwoN > MaxX &
-- Power(0).TwoN = 2**N
-- (Power(CMax+1) is not actually computed.)
type APower is record
Two, TwoN: Arith_Type;
end record; --APower
Power: array (CIndex) of APower;
CMax: CIndex;
function
RootOf (X: Arith_Type) return Arith_Type is
C: CIndex; -- C <= CMax
-- Sign * (XG1 ** Inverter) = X
Sign: Arith_Type; -- +1 or -1
Inverter: integer range -1..+1; -- +1 or -1
XG1: Arith_Type; -- 1 <= XG1 <= MaxX
-- RootOf (XG1) = RootOf (XNorm) * Unnormalizer
Unnormalizer: Arith_Type;
XNorm: Arith_Type; -- 1 <= XNorm < 2**N
-- Root & RootPrev are approximations to RootOf (XNorm)
Root, RootPrev: Arith_Type;
-- abs (RootOf (XNorm) - Root) <= Tolerance
Tolerance: constant := 1.0E-4;
begin -- body of RootOf
if X = 0.0
then
return (0.0); -- 0 = RootOf (0)
else
--assert: X /= 0
if X > 0.0
then Sign := +1.0; XG1 := +X;
else Sign := -1.0; XG1 := -X;
end if;
--assert: Sign * XG1 = X & XG1 > 0 & Sign = +1 or -1
if XG1 >= 1.0
then Inverter := +1;
else Inverter := -1;
end if;
XG1 := XG1 ** Inverter;
--assert: Sign * (XG1 ** Inverter) = X &
-- XG1 >= 1 &
-- Sign = +1 or -1 &
-- Inverter = +1 or -1
--assert: RootOf (X) = RootOf (Sign * (XG1 ** Inverter))
-- = Sign * (RootOf (XG1) ** Inverter)
--assert: 1 <= XG1 <= MaxX < (2**N) ** (2 ** (CMax + 1))
XNorm := XG1; Unnormalizer := 1.0; C := CMax + 1;
--invariant: RootOf (XG1) = Unnormalizer * RootOf (XNorm) &
-- 1 <= XNorm < (2**N) ** (2**C)
-- (see also Power assertion)
--bound: C
while C /= 0 loop
C := C - 1;
if XNorm >= Power(C).TwoN
then
--assert: RootOf (XNorm)
-- = RootOf ((XNorm / Power(C).TwoN) * Power(C).TwoN)
-- = RootOf (XNorm / Power(C).TwoN) * Power(C).Two
--assert: Power(C).TwoN <= XNorm < Power(C+1).TwoN
-- = Power(C).TwoN ** 2
XNorm := XNorm / Power(C).TwoN;
--assert: 1 <= XNorm < Power(C).TwoN
Unnormalizer := Unnormalizer * Power(C).Two;
end if;
-- invariant has been reestablished
end loop;
--assert: 1 <= XNorm < Power(0).TwoN = 2**N
--assert (incidentally): 1 <= RootOf (XNorm) < 2
--invariant & bound: supplied by Isaac Newton
RootPrev := 2.0;
loop
Root := (XNorm / (RootPrev ** (N - 1))
+ Arith_Type (N - 1) * RootPrev )
/ Arith_Type (N) ;
exit when abs (Root - RootPrev) <= Tolerance;
RootPrev := Root;
end loop;
--assert: abs (Root - RootOf (XNorm) <= Tolerance)
-- i.e., Root ~= RootOf (XNorm)
return (Sign * ((Root * Unnormalizer) ** Inverter));
end if; -- X = 0.0?
end RootOf;
begin -- NthRoot body
-- make Power assertion true (initialize Power)
Power(0).Two := 2.0; Power(0).TwoN := 2.0 ** N;
CMax := 1;
begin -- to catch exceptions
for C in CIndex loop -- escape on exception
--assert: Power(C).TwoN < MaxX
Power(C+1).TwoN := Power(C).TwoN ** 2; --may except
Power(C+1).Two := Power(C).Two ** 2;
CMax := C + 1;
end loop;
-- should never fall out
exception
when numeric_error -- on Power(C).TwoN ** 2 > MaxX
| constraint_error -- on C + 1 > CMax
=>
--assert: Power(CMax).TwoN > MaxX
null; -- just leave block
end; -- exception block
-- Power assertion is true
end NthRoot; -- body
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- The purpose of this package is to define an Ada type that has exactly
-- the operations that are valid for any physical quantity. This package
-- is then used by the packages that define many physical units. These
-- packages are used in turn by packages that define operators on physical
-- units that produce other physical units. Additional packages in this
-- set provide for outputting of physical units, conversions between
-- physical units, and other functions needed when working with physical
-- units.
--
package PHYSICAL_REAL is
type REAL is private ;
-- Operators available for all types derived from REAL
--
-- implicit : := = /=
--
--
-- Physical quantities with the same units can be added
-- preserving their physical units.
function "+" ( LEFT , RIGHT : REAL ) return REAL ;
-- Physical quantities with the same units can be subtracted
-- preserving their physical units.
function "-" ( LEFT , RIGHT : REAL ) return REAL ;
-- Multiplying a physical quantity by itself does not produce
-- the same physical quantity and thus must not be allowed.
-- Multiplying a physical quantity by a non dimensional quantity
-- does preserve the units of the physical quantity.
function "*" ( LEFT : LONG_FLOAT ;
RIGHT : REAL ) return REAL ;
function "*" ( LEFT : REAL ;
RIGHT : LONG_FLOAT ) return REAL ;
-- Dividing a physical quantity by a non dimensional quantity
-- preserves the units of the physical quantity.
function "/" ( LEFT : REAL ;
RIGHT : LONG_FLOAT ) return REAL ;
-- Dividing a physical quantity by itself produces
-- a non dimensional value.
function "/" ( LEFT , RIGHT : REAL ) return LONG_FLOAT ;
-- The absolute value of a physical quantity retains the
-- same physical units.
function "abs" ( LEFT : REAL ) return REAL ;
-- Equality and inequality are implicitly defined. The other
-- relational operators must be explicitly defined.
function "<" ( LEFT , RIGHT : REAL ) return BOOLEAN ;
function ">" ( LEFT , RIGHT : REAL ) return BOOLEAN ;
function "<=" ( LEFT , RIGHT : REAL ) return BOOLEAN ;
function ">=" ( LEFT , RIGHT : REAL ) return BOOLEAN ;
--Alstad start
-- Taking a root of a physical quantity by itself does not produce
-- the same physical quantity and thus must not be allowed.
function SQRT ( LEFT : LONG_FLOAT ) return LONG_FLOAT ;
function CUBE_ROOT ( LEFT : LONG_FLOAT ) return LONG_FLOAT ;
--Alstad end
-- The primary purpose of this function for the user is
-- to make constants into values of a specific physical
-- unit.
-- The use of this function in the set of physics packages
-- is to apply the required Ada type to the result of a
-- non dimensional computation.
function DIMENSION ( LEFT : LONG_FLOAT ) return REAL ;
-- The use of this function in the set of physics packages
-- is to take any physical quantity and get a non dimensional
-- value in the base floating point arithmetic type in order
-- to preform computation. This should not be needed by users
-- of the set of physics packages.
function UNDIMENSION ( LEFT : REAL ) return LONG_FLOAT ;
-- For compilers that can make use of INLINE
pragma INLINE ( "+" , "-" , "*" , "/" , "abs" , "<" , ">" , "<=" , ">=" ,
DIMENSION , UNDIMENSION ) ;
--
private
type REAL is new LONG_FLOAT ;
end PHYSICAL_REAL ;
with NthRoot; --Alstad
package body PHYSICAL_REAL is
--Alstad start
package Square is new NthRoot (N => 2, Arith_Type => LONG_FLOAT);
package Cube is new NthRoot (N => 3, Arith_Type => LONG_FLOAT);
function SQRT (LEFT : LONG_FLOAT) return LONG_FLOAT
is begin
return (Square.RootOf (LEFT));
end; -- SQRT
function CUBE_ROOT (LEFT : LONG_FLOAT) return LONG_FLOAT
is begin
return (Cube.RootOf (LEFT));
end; -- SQRT
pragma INLINE (SQRT, CUBE_ROOT);
--Alstad end
function "+" ( LEFT , RIGHT : REAL ) return REAL is
begin
return REAL ( LONG_FLOAT( LEFT ) + LONG_FLOAT ( RIGHT )) ;
end "+" ;
function "-" ( LEFT , RIGHT : REAL ) return REAL is
begin
return REAL ( LONG_FLOAT( LEFT ) - LONG_FLOAT ( RIGHT )) ;
end "-" ;
function "*" ( LEFT : LONG_FLOAT ;
RIGHT : REAL ) return REAL is
begin
return REAL ( LEFT * LONG_FLOAT( RIGHT )) ;
end "*" ;
function "*" ( LEFT : REAL ;
RIGHT : LONG_FLOAT ) return REAL is
begin
return REAL ( LONG_FLOAT( LEFT ) * RIGHT) ;
end "*" ;
function "/" ( LEFT : REAL ;
RIGHT : LONG_FLOAT ) return REAL is
begin
return REAL ( LONG_FLOAT( LEFT ) / RIGHT) ;
end "/" ;
function "/" ( LEFT , RIGHT : REAL ) return LONG_FLOAT is
begin
return LONG_FLOAT ( LEFT ) / LONG_FLOAT ( RIGHT ) ;
end "/" ;
function "abs" ( LEFT : REAL ) return REAL is
begin
return REAL ( abs( LONG_FLOAT( LEFT ))) ;
end "abs" ;
function "<" ( LEFT , RIGHT : REAL ) return BOOLEAN is
begin
return LONG_FLOAT ( LEFT ) < LONG_FLOAT ( RIGHT ) ;
end "<" ;
function ">" ( LEFT , RIGHT : REAL ) return BOOLEAN is
begin
return LONG_FLOAT ( LEFT ) > LONG_FLOAT ( RIGHT ) ;
end ">" ;
function "<=" ( LEFT , RIGHT : REAL ) return BOOLEAN is
begin
return LONG_FLOAT ( LEFT ) <= LONG_FLOAT ( RIGHT ) ;
end "<=" ;
function ">=" ( LEFT , RIGHT : REAL ) return BOOLEAN is
begin
return LONG_FLOAT ( LEFT ) >= LONG_FLOAT ( RIGHT ) ;
end ">=" ;
function DIMENSION ( LEFT : LONG_FLOAT ) return REAL is
begin
return REAL ( LEFT ) ;
end DIMENSION ;
function UNDIMENSION ( LEFT : REAL ) return LONG_FLOAT is
begin
return LONG_FLOAT ( LEFT ) ;
end UNDIMENSION ;
end PHYSICAL_REAL ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with TEXT_IO ; use TEXT_IO ;
package LONG_FLT_IO is new FLOAT_IO ( LONG_FLOAT ) ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_REAL ; use PHYSICAL_REAL ;
package PHYSICAL_UNITS_BASIC is
-- This package specification defines Ada types for physical
-- quantities. A number of other packages use this package
-- specification in order to provide a comprehensive dimension
-- checking and units conversion system.
--
-- PHYSICAL QUANTITIES AND THEIR ASSOCIATED DIMENSIONS
--
-- Errors can occur in writing equations to solve problems in classical
--physics. Many of these errors can be prevented by performing a dimensionality
--check on the equations. All physical quantities have a fundamental dimension
--that is independent of the units of measurement. The basic physical dimensions
--are: length, mass, time, electrical charge, temperature and luminous intens-
--ity.There are a number of systems of units for measuring physical quantities.
--The MKS system is based on meter, kilogram, second measurement.
--The CGS system is based on centimeter, gram, second measurement.
--The English system is based on feet, pound, second measurement.
--A few physical dimensions and the associated measurement unit in
--these three systems are :
--
--
-- Physical Quantity Unit System
-- Dimension MKS CGS English
--
-- length meter centimeter feet
--
-- mass kilogram gram pound mass
--
-- time second second second
--
-- force newton dyne poundal
--
-- energy joule erg B.t.u.
--
--
-- The checking of a physical equation has two aspects. The first is to check
--the dimensionality. The dimensionality is independent of the unit system. The
--second is to check that a consistent system of units is used in the equation.
-- An example of a dimensionality check is using the basic equation F=ma to
--determine that force has the dimension mass x length / time squared, then
-- 2
--check if F=mv /r is dimensionally correct. The check is performed by
--expanding the dimensions, e.g. mass x (length/time) x (length/time) / length.
--with the dimensions expected for force from the basic equation F=ma. As
--expected, centripetal force has the same dimensionality as the force from
--Newton's second law of motion.
--
-- THE ALGEBRA OF DIMENSIONALITY
--
-- The dimension of any physical quantity can be written as
--
-- a b c d e f
-- L M T Q C K
--
--where a,b,c,d,e and f are integers such as -4, -3, -2 , -1, 0, 1, 2, 3, 4
--and L is length, M is mass, T is time, Q is charge, C is luminous intensity
--and K is temperature. An exponent of zero means the dimension does not apply
--to the physical quantity. The normal rules of algebra for exponents apply
--for combining dimensions.
--
-- In order to add or subtract two physical quantities the quantities must
--have the same dimension. The resulting physical quantity has the same
--dimensions. Physical quantities with the same dimension in different
--systems of units can be added or subtracted by multiplying one of
--the quantities by a units conversion factor to obtain compatible units.
--
-- The multiplication of two physical quantities results in a new physical
--quantity that has the sum of the exponents of the dimensions of the initial
--two quantities.
--
-- The division of one physical quantity by another results in a new physical
--quantity that has the dimension of the exponents of the first quantity minus
--the exponents of the second quantity.
--
-- Taking the square root of a physical quantity results in a new physical
--quantity having a dimension with exponents half of the initial dimension.
--
-- Raising a physical quantity to a power results in a new physical quantity
--having a dimension with the exponents multiplied by the power.
--
-- 2 2 2 2 -2
-- e.g. v has dimension L/T, v has dimension L /T or L T
--
-- The derivative of a physical quantity with respect to another physical
--quantity results in a new physical quantity with the exponents of the
--first dimension minus the exponents of the other dimension.
-- e.g. v has dimension L/T, t has dimension T,
--
-- 2
-- then dv/dt has dimension L/T
--
-- The integral of a physical quantity over the range of another physical
--quantity results in a new physical quantity that has a dimension with the
--sum of the exponents of the two quantities.
--
-- e.g. v has dimension L/T, t has dimension T,
-- then integral v dt has dimension L/T * T or L
--
--
-- The initial thought was to have metric units and English units
-- in separate package specifications. This proved inpractical
-- because time in seconds is both metric and English. Many other
-- units such as watt of power and Farad of capacitance are in
-- both systems. A further impracticallity arose when considering
-- the design of a units system conversion package. e.g. A package
-- that would provide accurate conversion form meters to inches
-- to micrometers to light years. The one package specification became
-- so large that it was inefficient, so, in order to keep the size
-- reasonable, three packages were created. The basic units, the
-- mechanical units and the electrical units. Then a package
-- called other units came into existance for pragmatic reasons.
--
-- Notice that there is not a type called LENGTH because
-- adding length in meters to length in feet is not allowed.
-- Even LENGTH_METRIC and LENGTH_ENGLISH are not acceptable
-- because meters can not be added to centimeters and inches can
-- not be added to feet. Further complication arises because of
-- seconds of time and seconds of arc. There can be ounces of
-- milk ( liquid measure ) and ounces of sugar ( weight measure ).
-- There can be quarts of milk and quarts of strawberries ( dry
-- measure ). Thus the decision was made that every Ada type
-- would be a dimension name followed by a unit name.
--
-- Now, more choices had to be made. Unit names such as
-- DENSITY_KILOGRAM_PER_CUBIC_METER or DENSITY_TONS_PER_CUBIC_YARD
-- start getting long and there are many combinations. The number
-- of combinations for density are all the units of mass times all
-- the units of volume. Thus a subset of all possible units was
-- chosen with the additional short hand notation of _MKS for
-- the meter, kilogram, second system of units and the _ENGLISH for
-- the foot, pound, second system. Additional qualifiers are added
-- to clarify such as VOLUME_QUART_LIQUID and VOLUME_QUART_DRY.
--
-- Some other compromises were made:
-- Only a few units were entered as both singular and plural.
-- The choice of names is the authors. A committee could expand
-- the list. For example a meter can be a length or a distance,
-- length is used as the type and distance is a subtype.
-- A user may provide additional local subtype names for units
-- and thus has the full capability for alternate type names.
--
-- The comments below are organized to present the physical quantity name with
--associated information. The second column is one of the typical symbols used
--for the physical quantity. The third column is the dimension of the physical
--quantity expressed in terms of the fundamental dimensions. The fourth column
--is the name of the unit in the MKS measurement system. The fifth column
--is the typical MKS unit equation. An independent table presents conversion
--factors from the MKS measurement system to other measurement systems.
-- Physics developed over a period of many years by many people from a variety
--of disciplines. Thus, there is ambiguity and duplication of symbols.
--
--
--PHYSICAL QUANTITY SYMBOL DIMENSION MEASUREMENT UNIT UNIT EQUATION
--_________________ ______ _________ ________________ ______________
--
--
-- BASIC UNITS
--
--length s L meter m
--wave length lambda " " "
--
type LENGTH_MKS is new REAL ;
subtype LENGTH_METER is LENGTH_MKS ;
subtype LENGTH_METERS is LENGTH_MKS ; -- This could be done for every type
subtype DISTANCE_METER is LENGTH_MKS ; -- with plurals and alias and
subtype DISTANCE_METERS is LENGTH_MKS ; -- plurals for the alias
subtype WAVE_LENGTH_MKS is LENGTH_MKS ;
subtype WAVE_LENGTH_METER is LENGTH_MKS ;
type LENGTH_ENGLISH is new REAL ;
subtype LENGTH_FOOT is LENGTH_ENGLISH ;
subtype LENGTH_FEET is LENGTH_ENGLISH ;
type LENGTH_PICOMETER is new REAL ;
type LENGTH_NANOMETER is new REAL ;
type LENGTH_MICROMETER is new REAL ;
type LENGTH_MILLIMETER is new REAL ;
type LENGTH_CENTIMETER is new REAL ;
type LENGTH_DECIMETER is new REAL ;
type LENGTH_DECAMETER is new REAL ;
type LENGTH_HECTOMETER is new REAL ;
type LENGTH_KILOMETER is new REAL ;
type LENGTH_MEGAMETER is new REAL ;
type LENGTH_GIGAMETER is new REAL ;
type LENGTH_ANGSTROM is new REAL ;
type LENGTH_MIL is new REAL ;
type LENGTH_INCH is new REAL ;
type LENGTH_YARD is new REAL ;
type LENGTH_FATHOM is new REAL ;
type LENGTH_ROD is new REAL ;
type LENGTH_CHAIN_SURVEYOR is new REAL ;
type LENGTH_CHAIN_ENGINEER is new REAL ;
type LENGTH_FURLONG is new REAL ;
type LENGTH_MILE is new REAL ;
subtype LENGTH_MILE_STATUTE is LENGTH_MILE ;
type LENGTH_MILE_NAUTICAL is new REAL ;
type LENGTH_LEAGUE_LAND is new REAL ;
type LENGTH_LEAGUE_MARINE is new REAL ;
type LENGTH_LIGHT_YEAR is new REAL ;
--
--mass m M kilogram Kg
--
type MASS_MKS is new REAL ;
subtype MASS_KILOGRAM is MASS_MKS ;
type MASS_ENGLISH is new REAL ;
subtype MASS_POUND is MASS_ENGLISH ;
subtype MASS_POUND_AVDP is MASS_ENGLISH ;
type MASS_POUND_TROY is new REAL ;
subtype MASS_POUND_APOTHECARY is MASS_POUND_TROY ;
type MASS_MILLIGRAM is new REAL ;
type MASS_GRAM is new REAL ;
type MASS_GRAIN is new REAL ; -- same inall English systems
type MASS_PENNYWEIGHT_TROY is new REAL ;
type MASS_CARAT_TROY is new REAL ;
type MASS_SCRUPLE is new REAL ;
type MASS_DRAM_AVDP is new REAL ;
type MASS_OUNCE_AVDP is new REAL ;
type MASS_OUNCE_TROY is new REAL ;
type MASS_TON_SHORT is new REAL ;
type MASS_TON_LONG is new REAL ;
type MASS_TON_METRIC is new REAL ;
--
--time t T second sec
--
type TIME_SECOND is new REAL ;
subtype TIME_SECONDS is TIME_SECOND ;
type TIME_PICOSECOND is new REAL ;
type TIME_NANOSECOND is new REAL ;
type TIME_MICROSECOND is new REAL ;
type TIME_MILLISECOND is new REAL ;
type TIME_CENTISECOND is new REAL ;
type TIME_KILOSECOND is new REAL ;
type TIME_MEGASECOND is new REAL ;
type TIME_GIGASECOND is new REAL ;
type TIME_MINUTE is new REAL ;
type TIME_HOUR is new REAL ;
type TIME_DAY is new REAL ;
type TIME_FORTNIGHT is new REAL ;
type TIME_MONTH is new REAL ;
type TIME_YEAR is new REAL ;
type TIME_DECADE is new REAL ;
type TIME_CENTURY is new REAL ;
type TIME_MILLENNIA is new REAL ;
--
--electric charge q Q coulomb c
-- electric flux
--
type CHARGE_COULOMB is new REAL ;
subtype CHARGE_AMPERE_SECOND is CHARGE_COULOMB ;
type CHARGE_AMPERE_HOURS is new REAL ;
type CHARGE_ELECTRON is new REAL ;
type CHARGE_FARADAY is new REAL ;
--
--luminous intensity I C candle cd
--
type LUMINOUS_INTENSITY_CANDLE is new REAL ;
-- o
--temperature T K degree kelvin K
--
type TEMPERATURE_KELVIN is new real ;
type TEMPERATURE_CENTIGRADE is new REAL ;
subtype TEMPERATURE_CELSIUS is TEMPERATURE_CENTIGRADE ;
type TEMPERATURE_FARENHEIT is new REAL ;
--
--angle theta none radian none
--
type ANGLE_RADIAN is new REAL ;
subtype ANGLE_RADIANS is ANGLE_RADIAN ;
subtype PLANE_ANGLE_RADIANS is ANGLE_RADIAN ;
type ANGLE_SECOND is new REAL ;
type ANGLE_MINUTE is new REAL ;
type ANGLE_DEGREE is new REAL ;
type ANGLE_REVOLUTION is new REAL ;
type ANGLE_BAM is new REAL ;
--
--solid angle phi none steradian none
--
type SOLID_ANGLE_STERADIAN is new REAL ;
--
end PHYSICAL_UNITS_BASIC ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_REAL ; use PHYSICAL_REAL ;
package PHYSICAL_UNITS_MECHANICAL is
-- This package specification defines Ada types for physical
-- quantities generally in the mechanical context.
--
-- This package is the logical continuation of PHYSICAL_UNITS_BASIC
--
--
-- DERIVED MECHANICAL UNITS
--
--
-- 2 2
--area A L square meter m
--
type AREA_MKS is new REAL ;
subtype AREA_SQUARE_METER is AREA_MKS ;
subtype AREA_SQUARE_METERS is AREA_MKS ;
type AREA_ENGLISH is new REAL ;
subtype AREA_SQUARE_FEET is AREA_ENGLISH ;
subtype AREA_SQUARE_FOOT is AREA_ENGLISH ;
type AREA_SQUARE_CENTIMETER is new REAL ;
type AREA_SQUARE_KILOMETER is new REAL ;
type AREA_SQUARE_INCH is new REAL ;
type AREA_SQUARE_YARD is new REAL ;
type AREA_SQUARE_MILE is new REAL ;
type AREA_ACRE is new REAL ;
type AREA_CIRCULAR_MIL is new REAL ;
type AREA_HECTARE is new REAL ;
type AREA_TOWNSHIP is new REAL ;
--
-- 3 3
--volume V L stere m
--
type VOLUME_MKS is new REAL ;
subtype VOLUME_STERE is VOLUME_MKS ;
subtype VOLUME_CUBIC_METER is VOLUME_MKS ;
type VOLUME_ENGLISH is new REAL ;
subtype VOLUME_CUBIC_FEET is VOLUME_ENGLISH ;
type VOLUME_MILLILITER is new REAL ;
type VOLUME_LITER is new REAL ;
type VOLUME_KILOLITER is new REAL ;
type VOLUME_CUBIC_CENTIMETER is new REAL ;
type VOLUME_CUBIC_INCH is new REAL ;
type VOLUME_CUBIC_YARD is new REAL ;
type VOLUME_CUBIC_MILE is new REAL ;
type VOLUME_TEASPOON is new REAL ;
type VOLUME_TABLESPOON is new REAL ;
type VOLUME_OUNCE_FLUID is new REAL ;
type VOLUME_JIGGER is new REAL ;
type VOLUME_CUP is new REAL ;
type VOLUME_PINT_LIQUID is new REAL ;
type VOLUME_QUART_LIQUID is new REAL ;
type VOLUME_GALLON is new REAL ;
type VOLUME_KEG is new REAL ;
type VOLUME_BARREL is new REAL ;
type VOLUME_PINT_DRY is new REAL ;
type VOLUME_QUART_DRY is new REAL ;
type VOLUME_PECK is new REAL ;
type VOLUME_BUSHEL is new REAL ;
type VOLUME_CORD is new REAL ;
--
--velocity v L/T meter per second m/sec
--
type VELOCITY_MKS is new REAL ;
subtype VELOCITY_METER_PER_SECOND is VELOCITY_MKS ;
type VELOCITY_ENGLISH is new REAL ;
subtype VELOCITY_FEET_PER_SECOND is VELOCITY_ENGLISH ;
type VELOCITY_CENTIMETER_PER_SECOND is new REAL ;
type VELOCITY_KILOMETER_PER_HOUR is new REAL ;
type VELOCITY_INCHES_PER_SECOND is new REAL ;
type VELOCITY_MILE_PER_HOUR is new REAL ;
type VELOCITY_MILES_PER_SECOND is new REAL ;
type VELOCITY_INCHES_PER_MINUTE is new REAL ;
type VELOCITY_FEET_PER_MINUTE is new REAL ;
type VELOCITY_MILES_PER_HOUR is new REAL ;
type VELOCITY_KNOTS is new REAL ;
type VELOCITY_FURLONG_PER_FORTNIGHT is new REAL ;
--
--angular velocity omega 1/T radians per second 1/sec
--
type ANGULAR_VELOCITY is new REAL ;
subtype ANGULAR_VELOCITY_RADIANS_PER_SECOND is ANGULAR_VELOCITY ;
type ANGULAR_VELOCITY_DEGREES_PER_SECOND is new REAL ;
type ANGULAR_VELOCITY_REVOLUTIONS_PER_MINUTE is new REAL ;
type ANGULAR_VELOCITY_REVOLUTIONS_PER_SECOND is new REAL ;
--
-- 2 2
--acceleration a L/T meter per second m/sec
-- squared
--
type ACCELERATION_MKS is new REAL ;
subtype ACCELERATION_METER_PER_SECOND_SQUARED is ACCELERATION_MKS ;
type ACCELERATION_ENGLISH is new REAL ;
subtype ACCELERATION_FEET_PER_SECOND_SQUARED is ACCELERATION_ENGLISH ;
--
-- 2 2
--angular acceleration alpha 1/T radians per 1/sec
-- square second
--
type ANGULAR_ACCELERATION is new REAL ;
subtype ANGULAR_ACCELERATION_RADIANS_PER_SECOND_SQUARED is
ANGULAR_ACCELERATION ;
type ANGULAR_ACCELERATION_REVOLUTIONS_PER_MINUTE_SQUARED is new REAL ;
--
-- 2 2
--force F ML/T newton Kg m/sec
--
type FORCE_MKS is new REAL ;
subtype FORCE_NEWTON is FORCE_MKS ;
subtype FORCE_KILOGRAM_METER_PER_SECOND_SQUARED is FORCE_MKS ;
type FORCE_DYNE is new REAL ;
type FORCE_ENGLISH is new REAL ;
subtype FORCE_POUNDAL is FORCE_ENGLISH ;
subtype FORCE_POUND_FOOT_PER_PER_SECOND_SQUARED is FORCE_ENGLISH ;
--
-- 2 2 2 2
--energy E ML /T joule Kg m /sec
--work W " " "
--heat Q " " "
--torque (moment) T " newton meter "
--
type ENERGY_MKS is new REAL ;
subtype WORK_MKS is ENERGY_MKS ;
subtype HEAT_MKS is ENERGY_MKS ;
subtype TORQUE_MKS is ENERGY_MKS ;
subtype ENERGY_JOULE is ENERGY_MKS ;
subtype ENERGY_NEWTON_METER is ENERGY_MKS ;
subtype ENERGY_KILOGRAM_METER_SQUARED_PER_SECOND_SQUARED is ENERGY_MKS ;
type ENERGY_ERG is new REAL ;
type ENERGY_GRAM_CALORIE is new REAL ;
type ENERGY_KILOGRAM_CALORIE is new REAL ;
type ENERGY_ENGLISH is new REAL ;
subtype ENERGY_B_T_U is ENERGY_ENGLISH ;
type ENERGY_FOOT_POUND is new REAL ;
type ENERGY_KILOWATT_HOUR is new REAL ;
type ENERGY_HORSEPOWER_HOUR is new REAL ;
--
-- 2 3
--power P ML /T watt joule/sec
--
type POWER_MKS is new REAL ;
subtype POWER_WATT is POWER_MKS ;
subtype POWER_JOULE_PER_SECOND is POWER_MKS ;
subtype POWER_VOLT_AMPERE is POWER_MKS ;
type POWER_KILOGRAM_CALORIE_PER_SECOND is new REAL ;
type POWER_KILOGRAN_CALORIE_PER_MINUTE is new REAL ;
type POWER_HORSEPOWER_MECHANICAL is new REAL ;
type POWER_HORSEPOWER_ELECTRICAL is new REAL ;
type POWER_HORSEPOWER_METRIC is new REAL ;
type POWER_HORSEPOWER_BOILER is new REAL ;
type POWER_B_T_U_PER_MINUTE is new REAL ;
type POWER_B_T_U_PER_HOUR is new REAL ;
type POWER_FOOT_POUND_PER_MINUTE is new REAL ;
type POWER_FOOT_POUND_PER_SECOND is new REAL ;
--
-- 3 3
--density D M/L kilogram per Kg/m
-- cubic meter
--
type DENSITY_MKS is new REAL ;
subtype DENSITY_KILOGRAM_PER_CUBIC_METER is DENSITY_MKS ;
type DENSITY_ENGLISH is new REAL ;
subtype DENSITY_POUND_PER_CUBIC_FOOT is DENSITY_ENGLISH ;
--
-- 3 3
--flow rate f L /T cubic meter per m /sec
-- second
--
type FLOW_RATE_MKS is new REAL ;
subtype FLOW_RATE_CUBIC_METER_PER_SECOND is FLOW_RATE_MKS ;
type FLOW_RATE_ENGLISH is new REAL ;
subtype FLOW_RATE_CUBIC_FEET_PER_SECOND is FLOW_RATE_ENGLISH ;
type FLOW_RATE_GALLON_PER_MINUTE is new REAL ;
type FLOW_RATE_CUBIC_FEET_PER_MINUTE is new REAL ;
--
-- 2 2
--pressure P M/LT pascal Kg/m sec
-- stress newton per
-- energy density square meter
--
type PRESSURE_MKS is new REAL ;
subtype PRESSURE_PASCAL is PRESSURE_MKS ;
subtype PRESSURE_NEWTON_PER_SQUARE_METER is PRESSURE_MKS ;
subtype PRESSURE_FORCE_PER_AREA_MKS is PRESSURE_MKS ;
subtype PRESSURE_JOULE_PER_CUBIC_METER is PRESSURE_MKS ;
subtype PRESSURE_ENERGY_DENSITY_MKS is PRESSURE_MKS ;
type PRESSURE_ENGLISH is new REAL ;
subtype PRESSURE_POUND_PER_SQUARE_FOOT is PRESSURE_ENGLISH ;
type PRESSURE_TON_PER_SQUARE_FOOT is new REAL ;
type PRESSURE_ATMOSPHERE_STANDARD is new REAL ;
type PRESSURE_FEET_OF_WATER is new REAL ;
type PRESSURE_INCHES_OF_MERCURY is new REAL ;
type PRESSURE_MILLIMETER_OF_MERCURY is new REAL ;
type PRESSURE_BAR is new REAL ;
type PRESSURE_MILLIBAR is new REAL ;
type PRESSURE_TORR is new REAL ;
--
--momentum p ML/T newton second Kg m/sec
--
type MOMENTUM_MKS is new REAL ;
subtype MOMENTUM_NEWTON_SECOND is MOMENTUM_MKS ;
subtype MOMENTUM_KILOGRAM_METER_PER_SECOND is MOMENTUM_MKS ;
--
-- 2 2
--inertia I ML /T joule second Kg m /sec
--
type INERTIA_MKS is new REAL ;
subtype INERTIA_JOULE_SECOND is INERTIA_MKS ;
subtype INERTIA_KILOGRAM_METER_SQUARED_PER_SECOND is INERTIA_MKS ;
--
-- 2 2
--moment of inertia M ML kilogram Kg m
-- meter squared
--
type MOMENT_OF_INERTIA_MKS is new REAL ;
subtype MOMENT_OF_INERTIA_KILOGRAM_METER_SQUARED is MOMENT_OF_INERTIA_MKS ;
--
-- 2 2
--kinematic viscosity v M /T kilogram squared Kg /sec
-- per second
--
type KINEMATIC_VISCOSITY_MKS is new REAL ;
subtype KINEMATIC_VISCOSITY_KILOGRAM_SQUARED_PER_SECOND is
KINEMATIC_VISCOSITY_MKS ;
--
--dynamic viscosity d M/LT newton second Kg/m sec
-- per square meter
--
type DYNAMIC_VISCOSITY_MKS is new REAL ;
subtype DYNAMIC_VISCOSITY_NEWTON_PER_SQUARE_METER is DYNAMIC_VISCOSITY_MKS ;
subtype DYNAMIC_VISCOSITY_KILOGRAM_PER_METER_SECOND is DYNAMIC_VISCOSITY_MKS ;
--
--
--luminous flux phi C lumen (4Pi candle cd sr
-- for point source)
--
type LUMINOUS_FLUX_LUMEN is new REAL ;
--
-- 2 2
--illumination E C/L lumen per cd sr/m
-- square meter
--
type ILLUMINATION_MKS is new REAL ;
subtype ILLUMINATION_LUMEN_PER_SQUARE_METER is ILLUMINATION_MKS ;
--
-- 2 2
--luminance l C/L lux cd/m
-- square meter
--
type LUMINANCE_MKS is new REAL ;
subtype LUMINANCE_LUX is LUMINANCE_MKS ;
subtype LUMINANCE_CANDLE_PER_SQUARE_METER is LUMINANCE_MKS ;
--
--
-- 2 2 2
--entropy S ML /T K joule per degree Kg m /
-- 2 o
-- sec K
--
type ENTROPY_MKS is new REAL ;
subtype SPECIFIC_HEAT_MKS is ENTROPY_MKS ;
subtype SPECIFIC_HEAT_JOULE_PER_DEGREE_KELVIN is ENTROPY_MKS ;
type SPECIFIC_HEAT_B_T_U_PER_POUND_DEGREE_FARENHEIT is new REAL ;
--
end PHYSICAL_UNITS_MECHANICAL ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_REAL ; use PHYSICAL_REAL ;
package PHYSICAL_UNITS_ELECTRICAL is
-- This package specification defines Ada types for physical
-- quantities related to electrical units. It ia a logical
-- extension of PHYSICAL_UNITS_MECHANICAL .
--
--
--
-- DERIVED ELECTRICAL
--
--electric current I Q/T ampere c/sec
-- magnetomotive force
type CURRENT_AMPERE is new REAL ;
type CURRENT_MILLIAMPERE is new REAL ;
type CURRENT_MICROAMPERE is new REAL ;
type CURRENT_ABAMPERE is new REAL ;
type CURRENT_STATAMPERE is new REAL ;
--
-- 2 2 2 2
--voltage E ML /T Q volt Kg m /sec c
-- potential difference
-- electromotive force
type VOLTAGE_VOLT is new REAL ;
type VOLTAGE_MILLIVOLT is new REAL ;
type VOLTAGE_MICROVOLT is new REAL ;
type VOLTAGE_KILOVOLT is new REAL ;
--
-- 2 2 2 2
--electric resistance R ML /TQ ohm Kg m /sec c
--
type RESISTANCE_OHM is new REAL ;
type RESISTANCE_MILLIOHM is new REAL ;
type RESISTANCE_KILOHM is new REAL ;
type RESISTANCE_MEGOHM is new REAL ;
--
-- 3 2 3 2
--electric resistivity rho ML /TQ ohm meter Kg m /sec c
--
type RESISTIVITY_OHM_METER is new REAL ;
--
-- 2 2 2 2
--electric conductance G TQ /ML mho sec c /Kg m
--
type CONDUCTANCE_MHO is new REAL ;
--
-- 2 3 2 3
--conductivity sigma TQ /ML mho per meter sec c /Kg m
--
type CONDUCTIVITY_MHO_PER_METER is new REAL ;
--
--
-- 2 2 2 2 2 2
--capacitance C T Q /ML farad sec c /Kg m
--
type CAPACITANCE_FARAD is new REAL ;
type CAPACITANCE_MICROFARAD is new REAL ;
type CAPACITANCE_PICOFARAD is new REAL ;
--
--
-- 2 2 2 2
--inductance L ML /Q henry Kg m /c
-- weber per ampere
-- volt second per ampere
--
type INDUCTANCE_HENRY is new REAL ;
type INDUCTANCE_MILLIHENRY is new REAL ;
type INDUCTANCE_MICROHENRY is new REAL ;
--
-- 2 2
--current density J Q/TL ampere per c/sec m
-- square meter
--
type CURRENT_DENSITY_AMPERE_PER_SQUARE_METER is new REAL ;
--
-- 3 3
--charge density rho Q/L coulomb per c/m
-- cubic meter
--
type CHARGE_DENSITY_COULOMB_PER_CUBIC_METER is new REAL ;
-- 2 2
--magnetic flux F ML /TQ weber Kq m /sec c
-- volt second
--
type MAGNETIC_FLUX_WEBER is new REAL ;
--
--magnetic flux density, B M/TQ tesla Kq/sec c
-- magnetic induction weber per square meter
--
type MAGNETIC_FLUX_DENSITY is new REAL ;
subtype MAGNETIC_FLUX_DENSITY_TESLA is MAGNETIC_FLUX_DENSITY ;
subtype MAGNETIC_FLUX_DENSITY_WEBER_PER_SQUARE_METER is
MAGNETIC_FLUX_DENSITY ;
--
--magnetic intensity H Q/LT ampere per meter c/m sec
-- magnetic field strength
--
type MAGNETIC_INTENSITY is new REAL ;
subtype MAGNETIC_INTENSITY_AMPERE_PER_METER is MAGNETIC_INTENSITY ;
--
--
--magnetic vector potential A ML/TQ weber/meter Kg m/sec c
--
type MAGNETIC_VECTOR_POTENTIAL_WEBER_PER_METER is new REAL ;
--
-- 2 2
--electric field intensity E ML/T Q volt/meter Kg m/sec c
-- electric field strength newton per coulomb
--
type ELECTRIC_FIELD is new REAL ;
subtype ELECTRIC_FIELD_INTENSITY_VOLT_PER_METER is
ELECTRIC_FIELD ;
--
-- 2 2
--electric displacement D Q/L coulomb per c/m
-- square meter
--
type ELECTRIC_DISPLACEMENT is new REAL ;
subtype ELECTRIC_DISPLACEMENT_COULOMB_PER_SQUARE_METER is
ELECTRIC_DISPLACEMENT ;
--
-- 2 2
--permeability mu ML/Q henry per meter Kg m/c
--
type PERMEABILITY is new REAL ;
subtype PERMEABILITY_HENRY_PER_METER is PERMEABILITY ;
--
-- 2 2 3 2 2 3
--permittivity, epsi T Q /ML farad per meter sec c /Kg m
-- dielectric constant
--
type PERMITTIVITY is new REAL ;
subtype PERMITTIVITY_FARAD_PER_METER is PERMITTIVITY ;
subtype DIELECTRIC_CONSTANT is PERMITTIVITY ;
--
-- -1
--frequency f Pi/T hertz sec
--
type FREQUENCY_HERTZ is new REAL ;
type FREQUENCY_KILOHERTZ is new REAL ;
type FREQUENCY_MEGAHERTZ is new REAL ;
type FREQUENCY_GIGAHERTZ is new REAL ;
--
-- -1
--angular frequency omega 1/T radians per second sec
--
type ANGULAR_FREQUENCY_RADIAN_PER_SECOND is new REAL ;
--
end PHYSICAL_UNITS_ELECTRICAL ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_REAL ; use PHYSICAL_REAL ;
package PHYSICAL_UNITS_OTHER is
-- This package specification defines Ada types for physical
-- units that occur as intermediate results.
-- A number of other packages use this package.
--
--
-- The comments below are organized to present the physical quantity unit with
--associated information. The first column is the dimension of the physical
--quantity expressed in terms of the fundamental dimensions. The second column
--is the typical MKS unit equation.
--
-- DIMENSION UNIT EQUATION
-- _________ _____________
--
-- TYPES NEEDED FOR COMPUTATIONS
--
-- 2 2
-- T sec
type TIME_SECOND_SQUARED is new REAL ;
--
-- 2 2 2 2
-- L /T m /sec
type VELOCITY_SQUARED_MKS is new REAL ;
subtype VELOCITY_MKS_SQUARED is VELOCITY_SQUARED_MKS ;
-- 2 2 o
-- ML /T K joule/ K
type JOULE_PER_DEGREE_KELVIN is new REAL ;
--
-- 3 2 2
-- ML /T Q m/farad
type METER_PER_FARAD is new REAL ;
--
-- 2 4 4 2 2
-- M L /T Q volt
type VOLT_SQUARED is new REAL ;
--
-- 2 2 2
-- Q /T ampere
type AMPERE_SQUARED is new REAL ;
--
-- 2
-- Q/T ampere/sec
type AMPERE_PER_SECOND is new REAL ;
--
-- 2 3
-- ML /T Q volt/sec
type VOLT_PER_SECOND is new REAL ;
--
-- 2 2
-- L /MT
type ACCELERATION_PER_KILOGRAM is new REAL ;
--
end PHYSICAL_UNITS_OTHER ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_UNITS_BASIC ; use PHYSICAL_UNITS_BASIC ;
package PHYSICAL_UNITS_OUTPUT_BASIC is
-- This package specification defines a simple PUT for Ada types for physical
-- quantities. The initial thought was to have metric units and English units
-- in separate package specifications. This proved inpractical
-- because time in seconds is both metric and English. Many other
-- units such as watt of power and Farad of capacitance are in
-- both systems. Thus, in order to keep the packages reasonable sizes,
-- the packages are basic units, mechanical units and electrical units.
--
-- Notice that there is not a procedure PUT defined for LENGTH_METER
-- or for that matter, any " subtype " defined in the package PHYSICAL_UNITS.
-- It is unnecessary and happens to be illegal ada.
procedure PUT ( ITEM : LENGTH_MKS ) ;
procedure PUT ( ITEM : LENGTH_ENGLISH ) ;
procedure PUT ( ITEM : LENGTH_PICOMETER ) ;
procedure PUT ( ITEM : LENGTH_NANOMETER ) ;
procedure PUT ( ITEM : LENGTH_MICROMETER ) ;
procedure PUT ( ITEM : LENGTH_MILLIMETER ) ;
procedure PUT ( ITEM : LENGTH_CENTIMETER ) ;
procedure PUT ( ITEM : LENGTH_DECIMETER ) ;
procedure PUT ( ITEM : LENGTH_DECAMETER ) ;
procedure PUT ( ITEM : LENGTH_HECTOMETER ) ;
procedure PUT ( ITEM : LENGTH_KILOMETER ) ;
procedure PUT ( ITEM : LENGTH_MEGAMETER ) ;
procedure PUT ( ITEM : LENGTH_GIGAMETER ) ;
procedure PUT ( ITEM : LENGTH_ANGSTROM ) ;
procedure PUT ( ITEM : LENGTH_MIL ) ;
procedure PUT ( ITEM : LENGTH_INCH ) ;
procedure PUT ( ITEM : LENGTH_YARD ) ;
procedure PUT ( ITEM : LENGTH_FATHOM ) ;
procedure PUT ( ITEM : LENGTH_ROD ) ;
procedure PUT ( ITEM : LENGTH_CHAIN_SURVEYOR ) ;
procedure PUT ( ITEM : LENGTH_CHAIN_ENGINEER ) ;
procedure PUT ( ITEM : LENGTH_FURLONG ) ;
procedure PUT ( ITEM : LENGTH_MILE ) ;
procedure PUT ( ITEM : LENGTH_MILE_NAUTICAL ) ;
procedure PUT ( ITEM : LENGTH_LEAGUE_LAND ) ;
procedure PUT ( ITEM : LENGTH_LEAGUE_MARINE ) ;
procedure PUT ( ITEM : LENGTH_LIGHT_YEAR ) ;
procedure PUT ( ITEM : MASS_MKS ) ;
procedure PUT ( ITEM : MASS_ENGLISH ) ;
procedure PUT ( ITEM : MASS_POUND_TROY ) ;
procedure PUT ( ITEM : MASS_MILLIGRAM ) ;
procedure PUT ( ITEM : MASS_GRAM ) ;
procedure PUT ( ITEM : MASS_GRAIN ) ;
procedure PUT ( ITEM : MASS_PENNYWEIGHT_TROY ) ;
procedure PUT ( ITEM : MASS_CARAT_TROY ) ;
procedure PUT ( ITEM : MASS_SCRUPLE ) ;
procedure PUT ( ITEM : MASS_DRAM_AVDP ) ;
procedure PUT ( ITEM : MASS_OUNCE_AVDP ) ;
procedure PUT ( ITEM : MASS_OUNCE_TROY ) ;
procedure PUT ( ITEM : MASS_TON_SHORT ) ;
procedure PUT ( ITEM : MASS_TON_LONG ) ;
procedure PUT ( ITEM : MASS_TON_METRIC ) ;
procedure PUT ( ITEM : TIME_SECOND ) ;
procedure PUT ( ITEM : TIME_PICOSECOND ) ;
procedure PUT ( ITEM : TIME_NANOSECOND ) ;
procedure PUT ( ITEM : TIME_MICROSECOND ) ;
procedure PUT ( ITEM : TIME_MILLISECOND ) ;
procedure PUT ( ITEM : TIME_CENTISECOND ) ;
procedure PUT ( ITEM : TIME_KILOSECOND ) ;
procedure PUT ( ITEM : TIME_MEGASECOND ) ;
procedure PUT ( ITEM : TIME_GIGASECOND ) ;
procedure PUT ( ITEM : TIME_MINUTE ) ;
procedure PUT ( ITEM : TIME_HOUR ) ;
procedure PUT ( ITEM : TIME_DAY ) ;
procedure PUT ( ITEM : TIME_FORTNIGHT ) ;
procedure PUT ( ITEM : TIME_MONTH ) ;
procedure PUT ( ITEM : TIME_YEAR ) ;
procedure PUT ( ITEM : TIME_DECADE ) ;
procedure PUT ( ITEM : TIME_CENTURY ) ;
procedure PUT ( ITEM : TIME_MILLENNIA ) ;
procedure PUT ( ITEM : CHARGE_COULOMB ) ;
procedure PUT ( ITEM : CHARGE_ELECTRON ) ;
procedure PUT ( ITEM : CHARGE_FARADAY ) ;
procedure PUT ( ITEM : CHARGE_AMPERE_HOURS ) ;
procedure PUT ( ITEM : LUMINOUS_INTENSITY_CANDLE ) ;
procedure PUT ( ITEM : TEMPERATURE_KELVIN ) ;
procedure PUT ( ITEM : TEMPERATURE_CENTIGRADE ) ;
procedure PUT ( ITEM : TEMPERATURE_FARENHEIT ) ;
procedure PUT ( ITEM : ANGLE_RADIAN ) ;
procedure PUT ( ITEM : ANGLE_SECOND ) ;
procedure PUT ( ITEM : ANGLE_MINUTE ) ;
procedure PUT ( ITEM : ANGLE_DEGREE ) ;
procedure PUT ( ITEM : ANGLE_REVOLUTION ) ;
procedure PUT ( ITEM : ANGLE_BAM ) ;
procedure PUT ( ITEM : SOLID_ANGLE_STERADIAN ) ;
end PHYSICAL_UNITS_OUTPUT_BASIC ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_REAL ; use PHYSICAL_REAL ;
with TEXT_IO ; use TEXT_IO ;
with LONG_FLT_IO ; use LONG_FLT_IO ;
package body PHYSICAL_UNITS_OUTPUT_BASIC is
procedure PUT ( ITEM : LENGTH_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " meter " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " feet " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_PICOMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " picometer " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_NANOMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " nanometer " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_MICROMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " micrometer " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_MILLIMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " millimeter " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_CENTIMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " centimeter " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_DECIMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " decimeter " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_DECAMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " decameter " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_HECTOMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " hectometer " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_KILOMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilometer " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_MEGAMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " megameter " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_GIGAMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " gigameter " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_ANGSTROM ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " angstrom " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_MIL ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " mil " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_INCH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " inch " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_YARD ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " yard " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_FATHOM ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " fathom " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_ROD ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " rod " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_CHAIN_SURVEYOR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " chain (surveyor) " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_CHAIN_ENGINEER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " chain (engineer) " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_FURLONG ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " furlong " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_MILE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " mile " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_MILE_NAUTICAL ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " mile (nautical) " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_LEAGUE_LAND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " league (land) " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_LEAGUE_MARINE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " league (marine) " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_LIGHT_YEAR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " light year " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilogram " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pound " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_POUND_TROY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pound (troy) " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_MILLIGRAM ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " milligram " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_GRAM ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " gram " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_GRAIN ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " grain " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_PENNYWEIGHT_TROY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pennyweight (troy) " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_CARAT_TROY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " carat (troy) " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_SCRUPLE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " scruple " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_DRAM_AVDP ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " dram (avdp.) " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_OUNCE_AVDP ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ounce " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_OUNCE_TROY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ounce (troy) " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_TON_SHORT ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ton (short) " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_TON_LONG ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ton (long) " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_TON_METRIC ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ton (metric) " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " second " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_PICOSECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " picosecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_NANOSECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " nanosecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_MICROSECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " microsecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_MILLISECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " millisecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_CENTISECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " centisecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_KILOSECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilosecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_MEGASECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " megasecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_GIGASECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " gigasecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " minute " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_HOUR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " hour " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_DAY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " day " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_FORTNIGHT ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " fortnight " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_MONTH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " month " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_YEAR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " year " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_DECADE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " decade " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_CENTURY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " century " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_MILLENNIA ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " millennia " ) ;
end PUT ;
procedure PUT ( ITEM : CHARGE_COULOMB ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " coulomb " ) ;
end PUT ;
procedure PUT ( ITEM : CHARGE_ELECTRON ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " charge (electron) " ) ;
end PUT ;
procedure PUT ( ITEM : CHARGE_FARADAY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " faraday " ) ;
end PUT ;
procedure PUT ( ITEM : CHARGE_AMPERE_HOURS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ampere hour " ) ;
end PUT ;
procedure PUT ( ITEM : LUMINOUS_INTENSITY_CANDLE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " candel " ) ;
end PUT ;
procedure PUT ( ITEM : TEMPERATURE_KELVIN ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " degree kelvin " ) ;
end PUT ;
procedure PUT ( ITEM : TEMPERATURE_CENTIGRADE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " degree centigrade " ) ;
end PUT ;
procedure PUT ( ITEM : TEMPERATURE_FARENHEIT ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " degree farenheit " ) ;
end PUT ;
procedure PUT ( ITEM : ANGLE_RADIAN ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " radian " ) ;
end PUT ;
procedure PUT ( ITEM : ANGLE_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " second (angle) " ) ;
end PUT ;
procedure PUT ( ITEM : ANGLE_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " minute ( angle) " ) ;
end PUT ;
procedure PUT ( ITEM : ANGLE_DEGREE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " degree (angle) " ) ;
end PUT ;
procedure PUT ( ITEM : ANGLE_REVOLUTION ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " revolution " ) ;
end PUT ;
procedure PUT ( ITEM : ANGLE_BAM ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " bam " ) ;
end PUT ;
procedure PUT ( ITEM : SOLID_ANGLE_STERADIAN ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " steradian " ) ;
end PUT ;
end PHYSICAL_UNITS_OUTPUT_BASIC ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_UNITS_MECHANICAL ; use PHYSICAL_UNITS_MECHANICAL ;
package PHYSICAL_UNITS_OUTPUT_MECHANICAL is
-- This package specification defines a simple PUT for Ada types for physical
-- quantities generally mechanical in nature.
--
-- Notice that there is not a procedure PUT defined for LENGTH_METER
-- or for that matter, any " subtype " defined in the package PHYSICAL_UNITS.
-- It is unnecessary and happens to be illegal ada.
procedure PUT ( ITEM : AREA_MKS ) ;
procedure PUT ( ITEM : AREA_ENGLISH ) ;
procedure PUT ( ITEM : AREA_SQUARE_CENTIMETER ) ;
procedure PUT ( ITEM : AREA_SQUARE_KILOMETER ) ;
procedure PUT ( ITEM : AREA_SQUARE_INCH ) ;
procedure PUT ( ITEM : AREA_SQUARE_YARD ) ;
procedure PUT ( ITEM : AREA_SQUARE_MILE ) ;
procedure PUT ( ITEM : AREA_ACRE ) ;
procedure PUT ( ITEM : AREA_CIRCULAR_MIL ) ;
procedure PUT ( ITEM : AREA_HECTARE ) ;
procedure PUT ( ITEM : AREA_TOWNSHIP ) ;
procedure PUT ( ITEM : VOLUME_MKS ) ;
procedure PUT ( ITEM : VOLUME_ENGLISH ) ;
procedure PUT ( ITEM : VOLUME_MILLILITER ) ;
procedure PUT ( ITEM : VOLUME_LITER ) ;
procedure PUT ( ITEM : VOLUME_KILOLITER ) ;
procedure PUT ( ITEM : VOLUME_CUBIC_CENTIMETER ) ;
procedure PUT ( ITEM : VOLUME_CUBIC_INCH ) ;
procedure PUT ( ITEM : VOLUME_CUBIC_YARD ) ;
procedure PUT ( ITEM : VOLUME_CUBIC_MILE ) ;
procedure PUT ( ITEM : VOLUME_TEASPOON ) ;
procedure PUT ( ITEM : VOLUME_TABLESPOON ) ;
procedure PUT ( ITEM : VOLUME_OUNCE_FLUID ) ;
procedure PUT ( ITEM : VOLUME_JIGGER ) ;
procedure PUT ( ITEM : VOLUME_CUP ) ;
procedure PUT ( ITEM : VOLUME_PINT_LIQUID ) ;
procedure PUT ( ITEM : VOLUME_QUART_LIQUID ) ;
procedure PUT ( ITEM : VOLUME_GALLON ) ;
procedure PUT ( ITEM : VOLUME_KEG ) ;
procedure PUT ( ITEM : VOLUME_BARREL ) ;
procedure PUT ( ITEM : VOLUME_PINT_DRY ) ;
procedure PUT ( ITEM : VOLUME_QUART_DRY ) ;
procedure PUT ( ITEM : VOLUME_PECK ) ;
procedure PUT ( ITEM : VOLUME_BUSHEL ) ;
procedure PUT ( ITEM : VOLUME_CORD ) ;
procedure PUT ( ITEM : VELOCITY_MKS ) ;
procedure PUT ( ITEM : VELOCITY_ENGLISH ) ;
procedure PUT ( ITEM : VELOCITY_CENTIMETER_PER_SECOND ) ;
procedure PUT ( ITEM : VELOCITY_KILOMETER_PER_HOUR ) ;
procedure PUT ( ITEM : VELOCITY_INCHES_PER_SECOND ) ;
procedure PUT ( ITEM : VELOCITY_MILE_PER_HOUR ) ;
procedure PUT ( ITEM : VELOCITY_MILES_PER_SECOND ) ;
procedure PUT ( ITEM : VELOCITY_INCHES_PER_MINUTE ) ;
procedure PUT ( ITEM : VELOCITY_FEET_PER_MINUTE ) ;
procedure PUT ( ITEM : VELOCITY_MILES_PER_HOUR ) ;
procedure PUT ( ITEM : VELOCITY_KNOTS ) ;
procedure PUT ( ITEM : VELOCITY_FURLONG_PER_FORTNIGHT ) ;
procedure PUT ( ITEM : ANGULAR_VELOCITY ) ;
procedure PUT ( ITEM : ANGULAR_VELOCITY_DEGREES_PER_SECOND ) ;
procedure PUT ( ITEM : ANGULAR_VELOCITY_REVOLUTIONS_PER_MINUTE ) ;
procedure PUT ( ITEM : ANGULAR_VELOCITY_REVOLUTIONS_PER_SECOND ) ;
procedure PUT ( ITEM : ACCELERATION_MKS ) ;
procedure PUT ( ITEM : ACCELERATION_ENGLISH ) ;
procedure PUT ( ITEM : ANGULAR_ACCELERATION ) ;
procedure PUT ( ITEM : ANGULAR_ACCELERATION_REVOLUTIONS_PER_MINUTE_SQUARED )
;
procedure PUT ( ITEM : FORCE_MKS ) ;
procedure PUT ( ITEM : FORCE_DYNE ) ;
procedure PUT ( ITEM : FORCE_ENGLISH ) ;
procedure PUT ( ITEM : ENERGY_MKS ) ;
procedure PUT ( ITEM : ENERGY_ERG ) ;
procedure PUT ( ITEM : ENERGY_GRAM_CALORIE ) ;
procedure PUT ( ITEM : ENERGY_KILOGRAM_CALORIE ) ;
procedure PUT ( ITEM : ENERGY_B_T_U ) ;
procedure PUT ( ITEM : ENERGY_FOOT_POUND ) ;
procedure PUT ( ITEM : ENERGY_KILOWATT_HOUR ) ;
procedure PUT ( ITEM : ENERGY_HORSEPOWER_HOUR ) ;
procedure PUT ( ITEM : POWER_MKS ) ;
procedure PUT ( ITEM : POWER_KILOGRAM_CALORIE_PER_SECOND ) ;
procedure PUT ( ITEM : POWER_KILOGRAN_CALORIE_PER_MINUTE ) ;
procedure PUT ( ITEM : POWER_HORSEPOWER_MECHANICAL ) ;
procedure PUT ( ITEM : POWER_HORSEPOWER_ELECTRICAL ) ;
procedure PUT ( ITEM : POWER_HORSEPOWER_METRIC ) ;
procedure PUT ( ITEM : POWER_HORSEPOWER_BOILER ) ;
procedure PUT ( ITEM : POWER_B_T_U_PER_MINUTE ) ;
procedure PUT ( ITEM : POWER_B_T_U_PER_HOUR ) ;
procedure PUT ( ITEM : POWER_FOOT_POUND_PER_MINUTE ) ;
procedure PUT ( ITEM : POWER_FOOT_POUND_PER_SECOND ) ;
procedure PUT ( ITEM : DENSITY_MKS ) ;
procedure PUT ( ITEM : DENSITY_ENGLISH ) ;
procedure PUT ( ITEM : FLOW_RATE_MKS ) ;
procedure PUT ( ITEM : FLOW_RATE_GALLON_PER_MINUTE ) ;
procedure PUT ( ITEM : FLOW_RATE_ENGLISH ) ;
procedure PUT ( ITEM : FLOW_RATE_CUBIC_FEET_PER_MINUTE ) ;
procedure PUT ( ITEM : PRESSURE_MKS ) ;
procedure PUT ( ITEM : PRESSURE_ENGLISH ) ;
procedure PUT ( ITEM : PRESSURE_TON_PER_SQUARE_FOOT ) ;
procedure PUT ( ITEM : PRESSURE_ATMOSPHERE_STANDARD ) ;
procedure PUT ( ITEM : PRESSURE_FEET_OF_WATER ) ;
procedure PUT ( ITEM : PRESSURE_INCHES_OF_MERCURY ) ;
procedure PUT ( ITEM : PRESSURE_MILLIMETER_OF_MERCURY ) ;
procedure PUT ( ITEM : PRESSURE_BAR ) ;
procedure PUT ( ITEM : PRESSURE_MILLIBAR ) ;
procedure PUT ( ITEM : PRESSURE_TORR ) ;
procedure PUT ( ITEM : MOMENTUM_MKS ) ;
procedure PUT ( ITEM : INERTIA_MKS ) ;
procedure PUT ( ITEM : MOMENT_OF_INERTIA_MKS ) ;
procedure PUT ( ITEM : KINEMATIC_VISCOSITY_MKS ) ;
procedure PUT ( ITEM : DYNAMIC_VISCOSITY_MKS ) ;
procedure PUT ( ITEM : LUMINOUS_FLUX_LUMEN ) ;
procedure PUT ( ITEM : ILLUMINATION_MKS ) ;
procedure PUT ( ITEM : LUMINANCE_MKS ) ;
procedure PUT ( ITEM : ENTROPY_MKS ) ;
procedure PUT ( ITEM : SPECIFIC_HEAT_B_T_U_PER_POUND_DEGREE_FARENHEIT ) ;
end PHYSICAL_UNITS_OUTPUT_MECHANICAL ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_REAL ; use PHYSICAL_REAL ;
with TEXT_IO ; use TEXT_IO ;
with LONG_FLT_IO ; use LONG_FLT_IO ;
package body PHYSICAL_UNITS_OUTPUT_MECHANICAL is
procedure PUT ( ITEM : AREA_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " square meter" ) ;
end PUT ;
procedure PUT ( ITEM : AREA_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " square foot " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_SQUARE_CENTIMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " square centimeter " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_SQUARE_KILOMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " square kilometer " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_SQUARE_INCH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " square inch " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_SQUARE_YARD ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " square yard " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_SQUARE_MILE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " square mile " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_ACRE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " acre " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_CIRCULAR_MIL ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " circular mil " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_HECTARE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " hectare " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_TOWNSHIP ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " township " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic meter " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic foot " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_MILLILITER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " milliliter " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_LITER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " liter " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_KILOLITER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kiloliter " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_CUBIC_CENTIMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic centimeter " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_CUBIC_INCH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic inch " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_CUBIC_YARD ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic yard " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_CUBIC_MILE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic mile " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_TEASPOON ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " teaspoon " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_TABLESPOON ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " tablespoon " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_OUNCE_FLUID ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ounce (fluid) " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_JIGGER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " jigger " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_CUP ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cup " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_PINT_LIQUID ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pint (liquid) " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_QUART_LIQUID ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " quart (liquid) " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_GALLON ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " gallon " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_KEG ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " keg " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_BARREL ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " barrel " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_PINT_DRY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pint (dry) " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_QUART_DRY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " quart (dry) " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_PECK ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " peck " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_BUSHEL ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " bushel " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_CORD ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cord " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " meter per second " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " foot per second " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_CENTIMETER_PER_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " centimeter per second " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_KILOMETER_PER_HOUR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilometer per hour " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_INCHES_PER_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " inches per second " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_MILE_PER_HOUR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " mile per hour " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_MILES_PER_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " miles per second " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_INCHES_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " inches per minute " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_FEET_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " feet per minute " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_MILES_PER_HOUR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " miles per hour " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_KNOTS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " knots " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_FURLONG_PER_FORTNIGHT ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " furlong per fortnight " ) ;
end PUT ;
procedure PUT ( ITEM : ANGULAR_VELOCITY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " radian per second " ) ;
end PUT ;
procedure PUT ( ITEM : ANGULAR_VELOCITY_DEGREES_PER_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " degrees per second " ) ;
end PUT ;
procedure PUT ( ITEM : ANGULAR_VELOCITY_REVOLUTIONS_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " revolutions per minute " ) ;
end PUT ;
procedure PUT ( ITEM : ANGULAR_VELOCITY_REVOLUTIONS_PER_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " revolutions per second " ) ;
end PUT ;
procedure PUT ( ITEM : ACCELERATION_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " meter per second squared " ) ;
end PUT ;
procedure PUT ( ITEM : ACCELERATION_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " foot per second squared " ) ;
end PUT ;
procedure PUT ( ITEM : ANGULAR_ACCELERATION ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " radians per second squared " ) ;
end PUT ;
procedure PUT ( ITEM : ANGULAR_ACCELERATION_REVOLUTIONS_PER_MINUTE_SQUARED )
is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " revolutions per minute squared " ) ;
end PUT ;
procedure PUT ( ITEM : FORCE_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " newton " ) ;
end PUT ;
procedure PUT ( ITEM : FORCE_DYNE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " dyne " ) ;
end PUT ;
procedure PUT ( ITEM : FORCE_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " poundal " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " joule " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_ERG ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " erg " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_GRAM_CALORIE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " gram calorie " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_KILOGRAM_CALORIE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilogram calorie " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_B_T_U ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " B.T.U. " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_FOOT_POUND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " foot pound " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_KILOWATT_HOUR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilowat hour " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_HORSEPOWER_HOUR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " horsepower hour " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " watt " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_KILOGRAM_CALORIE_PER_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilogram calorie per second " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_KILOGRAN_CALORIE_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilogram calorie per minute " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_HORSEPOWER_MECHANICAL ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " horsepower (mechanical) " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_HORSEPOWER_ELECTRICAL ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " horsepower (electrical) " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_HORSEPOWER_METRIC ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " horsepower ( metric) " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_HORSEPOWER_BOILER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " horsepower (boiler) " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_B_T_U_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " B.T.U. per minute " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_B_T_U_PER_HOUR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " B.T.U. per hour " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_FOOT_POUND_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " foot pound per minute " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_FOOT_POUND_PER_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " foot pound per second " ) ;
end PUT ;
procedure PUT ( ITEM : DENSITY_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilogram per cubic meter " ) ;
end PUT ;
procedure PUT ( ITEM : DENSITY_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pound per cubic foot " ) ;
end PUT ;
procedure PUT ( ITEM : FLOW_RATE_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic meter per second " ) ;
end PUT ;
procedure PUT ( ITEM : FLOW_RATE_GALLON_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " gallon per minute " ) ;
end PUT ;
procedure PUT ( ITEM : FLOW_RATE_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic feet per second " ) ;
end PUT ;
procedure PUT ( ITEM : FLOW_RATE_CUBIC_FEET_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic feet per minute " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pascal " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pound per square foot " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_TON_PER_SQUARE_FOOT ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ton per square foot " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_ATMOSPHERE_STANDARD ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " atmosphere " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_FEET_OF_WATER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " feet of water " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_INCHES_OF_MERCURY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " inches of mercury " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_MILLIMETER_OF_MERCURY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " millimeter of mercury " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_BAR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " bar " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_MILLIBAR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " millibar " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_TORR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " torr " ) ;
end PUT ;
procedure PUT ( ITEM : MOMENTUM_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " newton per second " ) ;
end PUT ;
procedure PUT ( ITEM : INERTIA_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " joule second " ) ;
end PUT ;
procedure PUT ( ITEM : MOMENT_OF_INERTIA_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilogram meter squared " ) ;
end PUT ;
procedure PUT ( ITEM : KINEMATIC_VISCOSITY_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " meter squared per second " ) ;
end PUT ;
procedure PUT ( ITEM : DYNAMIC_VISCOSITY_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " newton second per square meter " ) ;
end PUT ;
procedure PUT ( ITEM : LUMINOUS_FLUX_LUMEN ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " lumen " ) ;
end PUT ;
procedure PUT ( ITEM : ILLUMINATION_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " lumen per square meter " ) ;
end PUT ;
procedure PUT ( ITEM : LUMINANCE_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " lux " ) ;
end PUT ;
procedure PUT ( ITEM : ENTROPY_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " joule per degree centegrade " ) ;
end PUT ;
procedure PUT ( ITEM : SPECIFIC_HEAT_B_T_U_PER_POUND_DEGREE_FARENHEIT ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " B.T.U. per pound degree farenheit " ) ;
end PUT ;
end PHYSICAL_UNITS_OUTPUT_MECHANICAL ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_UNITS_BASIC ; use PHYSICAL_UNITS_BASIC ;
with PHYSICAL_UNITS_MECHANICAL ; use PHYSICAL_UNITS_MECHANICAL ;
with PHYSICAL_UNITS_OTHER ; use PHYSICAL_UNITS_OTHER ;
-- This package defines operators needed to evaluate equations of
-- physics using dimensional and units checking. Only MKS units
-- are used. A conversion package is available to convert from
-- other metric units and English units to the MKS units.
--
-- This package is not complete. Completeness would imply all
-- possible operators that combine physical dimensions and yeild
-- other physical dimensions. Users can provide local definitions
-- or this package can be augmented.
--
package MKS_PHYSICS_MECHANICAL is
function "*" ( LEFT , RIGHT : LENGTH_MKS ) return AREA_MKS ;
function SQRT ( LEFT : AREA_MKS ) return LENGTH_MKS ;
function "**" ( LEFT : LENGTH_MKS ;
RIGHT : INTEGER ) return AREA_MKS ;
function "**" ( LEFT : LENGTH_MKS ;
RIGHT : INTEGER ) return VOLUME_MKS ;
function "*" ( LEFT : AREA_MKS ;
RIGHT : LENGTH_MKS ) return VOLUME_MKS ;
function "*" ( LEFT : LENGTH_MKS ;
RIGHT : AREA_MKS ) return VOLUME_MKS ;
function CUBE_ROOT ( LEFT : VOLUME_MKS ) return LENGTH_MKS ;
function "/" ( LEFT : VOLUME_MKS ;
RIGHT : LENGTH_MKS ) return AREA_MKS ;
function "/" ( LEFT : LENGTH_MKS ;
RIGHT : TIME_SECOND ) return VELOCITY_MKS ;
function "/" ( LEFT : LENGTH_MKS ;
RIGHT : TIME_SECOND_SQUARED ) return ACCELERATION_MKS ;
function "*" ( LEFT , RIGHT : TIME_SECOND ) return TIME_SECOND_SQUARED ;
function "**" ( LEFT : TIME_SECOND ;
RIGHT : INTEGER ) return TIME_SECOND_SQUARED ;
function "**" ( LEFT : VELOCITY_MKS ;
RIGHT : INTEGER ) return VELOCITY_SQUARED_MKS ;
function SQRT ( LEFT : TIME_SECOND_SQUARED ) return TIME_SECOND ;
function "*" ( LEFT , RIGHT : VELOCITY_MKS ) return VELOCITY_SQUARED_MKS ;
function SQRT ( LEFT : VELOCITY_SQUARED_MKS ) return VELOCITY_MKS ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : TIME_SECOND_SQUARED ) return LENGTH_MKS ;
function "/" ( LEFT : LENGTH_MKS ;
RIGHT : ACCELERATION_MKS ) return TIME_SECOND_SQUARED ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : LENGTH_MKS ) return VELOCITY_SQUARED_MKS ;
function "*" ( LEFT : LENGTH_MKS ;
RIGHT : ACCELERATION_MKS ) return VELOCITY_SQUARED_MKS ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : TIME_SECOND ) return VELOCITY_MKS ;
function "*" ( LEFT : TIME_SECOND ;
RIGHT : ACCELERATION_MKS ) return VELOCITY_MKS ;
function "*" ( LEFT : MASS_MKS ;
RIGHT : ACCELERATION_MKS ) return FORCE_MKS ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : MASS_MKS ) return FORCE_MKS ;
function "*" ( LEFT : PRESSURE_MKS ;
RIGHT : AREA_MKS ) return FORCE_MKS ;
function "*" ( LEFT : AREA_MKS ;
RIGHT : PRESSURE_MKS ) return FORCE_MKS ;
function "/" ( LEFT : POWER_MKS ;
RIGHT : VELOCITY_MKS ) return FORCE_MKS ;
function "/" ( LEFT : ENERGY_MKS ;
RIGHT : LENGTH_MKS ) return FORCE_MKS ;
function "*" ( LEFT : PRESSURE_MKS ;
RIGHT : VOLUME_MKS ) return ENERGY_MKS ;
function "*" ( LEFT : VOLUME_MKS ;
RIGHT : PRESSURE_MKS ) return ENERGY_MKS ;
function "*" ( LEFT : FORCE_MKS ;
RIGHT : LENGTH_MKS ) return ENERGY_MKS ;
function "*" ( LEFT : LENGTH_MKS ;
RIGHT : FORCE_MKS ) return ENERGY_MKS ;
function "*" ( LEFT : MASS_MKS ;
RIGHT : VELOCITY_SQUARED_MKS ) return ENERGY_MKS ;
function "*" ( LEFT : VELOCITY_SQUARED_MKS ;
RIGHT : MASS_MKS ) return ENERGY_MKS ;
function "*" ( LEFT : POWER_MKS ;
RIGHT : TIME_SECOND ) return ENERGY_MKS ;
function "*" ( LEFT : TIME_SECOND ;
RIGHT : POWER_MKS ) return ENERGY_MKS ;
function "*" ( LEFT : FORCE_MKS ;
RIGHT : VELOCITY_MKS ) return POWER_MKS ;
function "*" ( LEFT : VELOCITY_MKS ;
RIGHT : FORCE_MKS ) return POWER_MKS ;
function "/" ( LEFT : ENERGY_MKS ;
RIGHT : TIME_SECOND ) return POWER_MKS ;
pragma INLINE ( "*", "/" , "**", SQRT ) ;
end MKS_PHYSICS_MECHANICAL ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- with LONG_REFUNCT; use LONG_REFUNCT; --Alstad
with PHYSICAL_REAL ; use PHYSICAL_REAL ;
package body MKS_PHYSICS_MECHANICAL is
function "*" ( LEFT , RIGHT : LENGTH_MKS ) return AREA_MKS is
begin
return AREA_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function SQRT ( LEFT : AREA_MKS ) return LENGTH_MKS is
begin
return LENGTH_MKS' ( DIMENSION( SQRT( UNDIMENSION( LEFT )))) ;
end SQRT ;
function "**" ( LEFT : LENGTH_MKS ;
RIGHT : INTEGER ) return AREA_MKS is
begin
if RIGHT /= 2 then
raise NUMERIC_ERROR ;
end if ;
return AREA_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( LEFT ))) ;
end "**" ;
function "**" ( LEFT : LENGTH_MKS ;
RIGHT : INTEGER ) return VOLUME_MKS is
begin
if RIGHT /= 3 then
raise NUMERIC_ERROR ;
end if ;
return VOLUME_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( LEFT ) * UNDIMENSION
( LEFT ))) ;
end "**" ;
function "*" ( LEFT : AREA_MKS ;
RIGHT : LENGTH_MKS ) return VOLUME_MKS is
begin
return VOLUME_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : LENGTH_MKS ;
RIGHT : AREA_MKS ) return VOLUME_MKS is
begin
return VOLUME_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function CUBE_ROOT ( LEFT : VOLUME_MKS ) return LENGTH_MKS is
begin
return LENGTH_MKS' ( DIMENSION( CUBE_ROOT( UNDIMENSION( LEFT )))); --Alstad
end CUBE_ROOT ;
function "/" ( LEFT : VOLUME_MKS ;
RIGHT : LENGTH_MKS ) return AREA_MKS is
begin
return AREA_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) / UNDIMENSION ( RIGHT ))) ;
end "/" ;
function "/" ( LEFT : LENGTH_MKS ;
RIGHT : TIME_SECOND ) return VELOCITY_MKS is
begin
return VELOCITY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) / UNDIMENSION ( RIGHT ))) ;
end "/" ;
function "/" ( LEFT : LENGTH_MKS ;
RIGHT : TIME_SECOND_SQUARED ) return ACCELERATION_MKS is
begin
return ACCELERATION_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) / UNDIMENSION ( RIGHT ))) ;
end "/" ;
function "*" ( LEFT , RIGHT : TIME_SECOND ) return TIME_SECOND_SQUARED is
begin
return TIME_SECOND_SQUARED' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "**" ( LEFT : TIME_SECOND ;
RIGHT : INTEGER ) return TIME_SECOND_SQUARED is
begin
if RIGHT /= 2 then
raise NUMERIC_ERROR ;
end if ;
return TIME_SECOND_SQUARED' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( LEFT ))) ;
end "**" ;
function "**" ( LEFT : VELOCITY_MKS ;
RIGHT : INTEGER ) return VELOCITY_SQUARED_MKS is
begin
if RIGHT /= 2 then
raise NUMERIC_ERROR ;
end if ;
return VELOCITY_SQUARED_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( LEFT ))) ;
end "**" ;
function SQRT ( LEFT : TIME_SECOND_SQUARED ) return TIME_SECOND is
begin
return TIME_SECOND' ( DIMENSION( SQRT( UNDIMENSION( LEFT )))) ;
end SQRT ;
function "*" ( LEFT , RIGHT : VELOCITY_MKS ) return VELOCITY_SQUARED_MKS is
begin
return VELOCITY_SQUARED_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function SQRT ( LEFT : VELOCITY_SQUARED_MKS ) return VELOCITY_MKS is
begin
return VELOCITY_MKS' ( DIMENSION( SQRT( UNDIMENSION( LEFT )))) ;
end SQRT ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : TIME_SECOND_SQUARED ) return LENGTH_MKS is
begin
return LENGTH_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "/" ( LEFT : LENGTH_MKS ;
RIGHT : ACCELERATION_MKS ) return TIME_SECOND_SQUARED is
begin
return TIME_SECOND_SQUARED' --
( DIMENSION( UNDIMENSION( LEFT ) / UNDIMENSION ( RIGHT ))) ;
end "/" ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : LENGTH_MKS ) return VELOCITY_SQUARED_MKS is
begin
return VELOCITY_SQUARED_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : LENGTH_MKS ;
RIGHT : ACCELERATION_MKS ) return VELOCITY_SQUARED_MKS is
begin
return VELOCITY_SQUARED_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : TIME_SECOND ) return VELOCITY_MKS is
begin
return VELOCITY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : TIME_SECOND ;
RIGHT : ACCELERATION_MKS ) return VELOCITY_MKS is
begin
return VELOCITY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : MASS_MKS ;
RIGHT : ACCELERATION_MKS ) return FORCE_MKS is
begin
return FORCE_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : MASS_MKS ) return FORCE_MKS is
begin
return FORCE_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : PRESSURE_MKS ;
RIGHT : AREA_MKS ) return FORCE_MKS is
begin
return FORCE_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : AREA_MKS ;
RIGHT : PRESSURE_MKS ) return FORCE_MKS is
begin
return FORCE_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "/" ( LEFT : POWER_MKS ;
RIGHT : VELOCITY_MKS ) return FORCE_MKS is
begin
return FORCE_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) / UNDIMENSION ( RIGHT ))) ;
end "/" ;
function "/" ( LEFT : ENERGY_MKS ;
RIGHT : LENGTH_MKS ) return FORCE_MKS is
begin
return FORCE_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) / UNDIMENSION ( RIGHT ))) ;
end "/" ;
function "*" ( LEFT : PRESSURE_MKS ;
RIGHT : VOLUME_MKS ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : VOLUME_MKS ;
RIGHT : PRESSURE_MKS ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : FORCE_MKS ;
RIGHT : LENGTH_MKS ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : LENGTH_MKS ;
RIGHT : FORCE_MKS ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : MASS_MKS ;
RIGHT : VELOCITY_SQUARED_MKS ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : VELOCITY_SQUARED_MKS ;
RIGHT : MASS_MKS ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : POWER_MKS ;
RIGHT : TIME_SECOND ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : TIME_SECOND ;
RIGHT : POWER_MKS ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : FORCE_MKS ;
RIGHT : VELOCITY_MKS ) return POWER_MKS is
begin
return POWER_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : VELOCITY_MKS ;
RIGHT : FORCE_MKS ) return POWER_MKS is
begin
return POWER_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "/" ( LEFT : ENERGY_MKS ;
RIGHT : TIME_SECOND ) return POWER_MKS is
begin
return POWER_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) / UNDIMENSION ( RIGHT ))) ;
end "/" ;
end MKS_PHYSICS_MECHANICAL ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- This procedure solves a few physics problems involving
-- time, distance, vecocity and acceleration. All units are
-- in the MKS system of units. Note that all "put" calls
-- on physical quantities are to be printed as the value followed
-- by the unit.
--
-- make available types for physical units
with PHYSICAL_UNITS_BASIC ; use PHYSICAL_UNITS_BASIC ;
with PHYSICAL_UNITS_MECHANICAL ; use PHYSICAL_UNITS_MECHANICAL ;
with PHYSICAL_UNITS_OTHER ; use PHYSICAL_UNITS_OTHER ;
-- make available operations on MKS types
with MKS_PHYSICS_MECHANICAL ; use MKS_PHYSICS_MECHANICAL ;
-- make PUT available for physical units types
with PHYSICAL_UNITS_OUTPUT_BASIC ; use PHYSICAL_UNITS_OUTPUT_BASIC ;
with PHYSICAL_UNITS_OUTPUT_MECHANICAL ; use PHYSICAL_UNITS_OUTPUT_MECHANICAL ;
--
with TEXT_IO ; use TEXT_IO ;
procedure PHYSICS_1 is
-- define acceleration due to gravity
G : ACCELERATION_MKS := DIMENSION ( 9.80665 ) ;
FALL : DISTANCE_METER ;
FALL_TIME : TIME_SECOND ;
V_FINAL : VELOCITY_METER_PER_SECOND ;
begin
PUT ( " Test printout and value of acceleration, " ) ;
PUT ( G ) ;
PUT_LINE ( " = G " ) ;
-- How far will Ball_1 fall in 1.5 second in earths gravity ?
FALL := 0.5 * G * TIME_SECOND' ( DIMENSION( 1.5 )) ** 2 ;
PUT ( FALL ) ;
NEW_LINE ;
-- Cross check that the time for the ball to fall is 1.5 seconds.
FALL_TIME := SQRT ( 2.0 * FALL / G ) ;
PUT ( FALL_TIME ) ;
NEW_LINE ;
-- Now determine the final velocity if the ball falls another 0.2 meter
-- Method : square root of initial velocity squared plus twice
-- the acceleration times the distance
V_FINAL := SQRT (( G * FALL_TIME ) ** 2 + 2.0 * G * FALL) ;
PUT ( V_FINAL ) ;
NEW_LINE ;
end PHYSICS_1 ;
::::::::::
CONPROD.ADA
::::::::::
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
----------------------------------------------------------------------
--
-- PRODUCER / CONSUMER TASKING BENCHMARK
--
-- Version: @(#)conprod.ada 1.3 Date: 6/20/84
--
-- Gerry Fisher
-- Computer Sciences Corporation
-- May 27, 1984
--
-- This benchmark tests tasking performance using the buffering task
-- given as an example in chapter 9.12 of the Ada RM. The consumer
-- task is the main program itself; the producer and buffer tasks
-- are declared as tasks within it. During execution each "write"
-- entry call produces a "." on the standard output file, while each
-- "read" call produces a "*". When all the produced data has been
-- consumed a check is made to see that the data has arrived in the
-- correct order and that no data remains buffered within the buffer
-- task.
--
----------------------------------------------------------------------
with text_io; use text_io;
procedure main is
all_there : boolean;
begin
set_line_length(50);
put_line("*** Producer/Consumer Task Test");
declare
x : array(character) of character := (others => ' ');
pool_size : constant integer := 5;
pool : array(1 .. pool_size) of character;
count : integer range 0 .. pool_size := 0;
task buffer is
entry read (c : out character);
entry write(c : in character);
end buffer;
task producer;
task body producer is
begin
for c in character loop
buffer.write(c);
end loop;
end producer;
task body buffer is
in_index, out_index : integer range 1 .. pool_size := 1;
begin
loop
select
when count < pool_size =>
accept write(c : in character) do
pool(in_index) := c;
end write;
put('.');
in_index := in_index mod pool_size + 1;
count := count + 1;
or when count > 0 =>
accept read(c : out character) do
c := pool(out_index);
end read;
put('*');
out_index := out_index mod pool_size + 1;
count := count - 1;
or
terminate;
end select;
end loop;
end buffer;
function Is_ok return boolean is
begin
for i in x'range loop
if x(i) /= i then return false; end if;
end loop;
return true;
end Is_ok;
begin
for i in x'range loop
buffer.read(x(i));
end loop;
all_there := Is_ok;
end;
new_line;
if all_there then
put_line("*** PASSED Producer/Consumer Task Test");
else
put_line("*** FAILED Producer/Consumer Task Test");
end if;
end main;
::::::::::
DERIVED.ADA
::::::::::
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)derived.ada 1.2 Date: 7/2/84
--
-- Author: Bryce Bardin
-- Ada Projects Section
-- Software Engineering Division
-- Ground Systems Group
-- Hughes Aircraft Company
-- Fullerton, CA
--
-- This program tests the inter-conversion of derived types with
-- different representations. An approriate message is output to
-- indicate "pass" or "fail".
--
--
-- Define the original types:
with Text_IO; use Text_IO;
package Originals is
type Bit is range 0 .. 1;
type Bit_String is array (Positive range <>) of Bit;
subtype Word is Bit_String (1 .. 16);
type Byte is range 0 .. 255;
type Block is
record
First : Byte;
Second : Word;
Third : Byte;
end record;
package Byte_IO is new Integer_IO (Byte);
use Byte_IO;
procedure Put (B : Block);
end Originals;
package body Originals is
procedure Put (B : Block) is
S : String (1 .. Word'Length);
begin
Put("First = ");
Put(B.First);
for N in 1 .. Word'Length loop
if B.Second(N) = 0 then
S(N) := '0';
else
S(N) := '1';
end if;
end loop;
Put(", Second = ");
Put(S);
Put(", Third = ");
Put(B.Third);
Put_Line(".");
end Put;
end Originals;
-- Define the derived types:
with Originals; use Originals;
with System;
package Deriveds is
type New_Block is new Block;
for New_Block use
record at mod System.Storage_Unit;
First at 0 range 0 .. 7;
Second at 0 range 8 .. 23;
Third at 0 range 24 .. 31;
end record;
for New_Block'Size use 32;
end Deriveds;
-- Test conversion from derived to original types and vice versa.
with Originals; use Originals;
with Deriveds; use Deriveds;
with Text_IO; use Text_IO;
procedure Change_Representation is
Original : Block := (First => 85,
Second => (1 .. 8 => 1, 9 .. 16 => 0),
Third => 170);
Derived : New_Block := New_Block(Original);
Copy : Block := Block(Derived);
package Int_IO is new Integer_IO(Integer);
use Int_IO;
begin
Put_Line("Original:");
Put(Original);
New_Line;
Put("Size = ");
Put(Original'Size);
Put_Line(" bits");
New_Line;
Put_Line("Derived:");
Put(Derived);
New_Line;
Put("Size = ");
Put(Derived'Size);
Put_Line(" bits");
New_Line;
Put_Line("Copy:");
Put(Copy);
New_Line(2);
if Copy = Original and Derived'Size = 32 then
Put_Line("TEST PASSED!");
else
Put_Line("** TEST FAILED! **");
end if;
end Change_Representation;
::::::::::
FLOATVEC.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
FRIEND.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
INT_DIR.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
INT_TEXT.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
INTVEC.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
LOWLEV.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
PROCCAL.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
QSORTPAR.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
QSORTSEQ.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
RENDEZ.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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;
::::::::::
SETS.ADA
::::::::::
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)sets.ada 1.3 Date: 10/19/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;
::::::::::
SHARED.ADA
::::::::::
-------------------------------------------------------------------
--------------------- 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);
--
-- C.Stop;
--
-- and writers should do:
--
-- C.Start(Write);
--
-- 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;
--::::::::::
--adafr85.doc
--::::::::::
The messages and programs contained in this file were received from
Ed Colbert in conjunction with Ada Fair '85. If there are any questions
with respect to this file please contact Mr. Colbert at :
trwrb!trwspp!spp1!colbert(ampersand)Berkeley . ( Note: I am unable to
transmit an ampersand over the net without the host saying 'BAD" things
about my computer literacy. ) RAY SZYMANSKI -----------
This is the 1st of 4 messages that you should receive. Included are the
rules for running the programs, a copy of 3 universial arithmatic packages,
and a copy of the 24 programs that were used this year. This years programs
consisted of all of last years programs plus 1 new one, a real world Physics
problem. All of the programs have been tested on a number of validated
compilers and are correct to the best of our knowledge (there was a logic
bug in boolvec.ada, but that has been corrected in the copy I am sending
you).
--------------------------------------------------------------------------
------------------------- 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 (, 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
:= ;
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 := ;
Set_Column(To => );
Put(Vendor);
New_Line(2);
Compilation_Environment
:= ;
Put(Compilation_Environment);
New_Line;
Execution_Environment
:= ;
Put(Execution_Environment);
Set_Line(To => 55);
Put("* Ada is a registered trademark of the U.S. Government " &
"(Ada Joint Program Office)");
Results := ;
for N in Number loop
New_Page;
Put(Results(N));
end loop;
end Summarize;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)akerman.ada 2.4 Date: 6/3/85
--
-- 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) / Real_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.4 Date: 6/17/85
--
-- 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(Iterations);
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;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)physics.ada 1.1 Date: 6/3/85
--
-- Supplied by: John Squires
-- Westinghouse Electric Company
-- (except as noted)
--
-- Edited by: Jim Alstad
-- Software Engineering Laboratories
-- Radar Systems Group
-- Hughes Aircraft Company
-- El Segundo CA USA
--
-- Series of compilation units to test real-world (i.e., heavy) use
-- of packages. Can be compilation & link time benchmark. The main
-- program (PHYSICS_1) should execute quickly.
--
-- Two units were written by Alstad; the rest are taken from
-- the tape distributed by Squires following the San Jose SIGAda meeting
-- (winter 85). Necessary alterations by Alstad
-- are flagged "--Alstad". The compilation units are as follows, where
-- a trailing underscore means a specification unit:
--
-- NthRoot_ Alstad
-- NthRoot Alstad
-- PHYSICAL_REAL Squires
-- LONG_FLT_IO Squires
-- PHYSICAL_UNITS_BASIC Squires
-- PHYSICAL_UNITS_MECHANICAL Squires
-- PHYSICAL_UNITS_ELECTRICAL Squires
-- PHYSICAL_UNITS_OTHER Squires
-- PHYSICAL_UNITS_OUTPUT_BASIC_ Squires
-- PHYSICAL_UNITS_OUTPUT_BASIC Squires
-- PHYSICAL_UNITS_OUTPUT_MECHANICAL_ Squires
-- PHYSICAL_UNITS_OUTPUT_MECHANICAL Squires
-- MKS_PHYSICS_MECHANICAL_ Squires
-- MKS_PHYSICS_MECHANICAL Squires
-- PHYSICS_1 Squires
--
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--
-- Version: NthRoot_.ada 1.0 Date: 5/29/85
--
-- Author: Jim Alstad
-- Software Engineering Laboratories
-- Radar Systems Group
-- Hughes Aircraft Company
-- El Segundo CA USA
--
-- Simple generic package to compute Nth roots.
--
-- Instantiating NthRoot with N, an integer >= 2,
-- and Arith-Type, a floating point type,
-- yields NthRoot.RootOf, a function which computes
-- the Nth root of its argument.
--
-- The result is an approximation, good to (at least) four digits.
-- For simplicity, RootOf (- X) = - RootOf (X), though N may be even.
-- Arith-Type is used for intermediate calculations.
--
generic
N: integer; -- N >= 2
type Arith_Type is digits <>;
package
NthRoot is
function
RootOf (X: Arith_Type) return Arith_Type;
end NthRoot; --spec
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--
-- Version: NthRoot.ada 1.0 Date: 5/29/85
--
--
-- Author: Jim Alstad
-- Software Engineering Laboratories
-- Radar Systems Group
-- Hughes Aircraft Company
-- El Segundo CA USA
--
-- Assisted by Nat Bachman (same affiliation).
--
-- Simple generic package to compute Nth roots.
--
-- The basic approach is to use Newton's method, which computes
-- successive approximations. This may be summarized as follows.
-- Suppose a number X and a function F are given, and it is desired
-- to find a Y such that F(Y) = X. Then Newton's method says that
-- a better approximation YNext may be found via
-- YNext = Y + (X - F(Y)) / F'(Y) .
-- Taking F(Y) to be Y**N, Y to be RootPrev, and YNext to be Root yields
-- Root = ((X/RootPrev**(N-1)) + ((N-1)*RootPrev)) / N ,
-- which is the formula used below. Iteration continues until
-- Root and RootPrev differ by less than Tolerance.
--
-- Convergence is fairly fast once RootPrev gets close to the actual root.
-- To speed this up, X is "normalized" into XNorm, where 1 <= XNorm < 2**N.
-- This means that 1 <= RootOf(XNorm) < 2, so that 2.0 is used as
-- the initial approximation to RootOf(XNorm). A side effect of this is
-- that the approximation to RootOf(XNorm) will never be less than
-- the actual root.
--
-- From a programming point of view, the main point of interest is
-- calculating XNorm (from XG1). This involves dividing XNorm by values
-- Power(C).TwoN, while remembering corresponding values Power(C).Two
-- by which to multiply Root to compensate. This algorithm can be
-- characterized as calculating the integer part of log(X), where
-- the log is base 2**N, by calculating the bits in its binary
-- representation from left to right (!). The initialization of Power
-- is also interesting, as it uses an exception to terminate a loop
-- (no alternative seems as appropriate).
--
-- This routine is used as a vehicle to demonstrate Dijkstra's proof-
-- of-correctness technique, which is based on his "weakest precondition"
-- predicate transformer. (This demonstration has not been carried
-- through 100%.)
--
-- The main consideration in designing this routine has been to achieve
-- reasonable accuracy and efficiency with broad applicability but
-- without an extended effort (i.e., it had to be interesting).
-- Consequently there are some rough edges. Here is a partial list:
-- 1. There is no check for N < 2.
-- 2. Arith-Type'small <= abs (X) < 1 / MaxX causes numeric_error.
--
--
package body
NthRoot is
-- - MaxX <= X <= MaxX
MaxX: constant Arith_Type := Arith_Type'large;
-- (2**N) ** (2**(CBound + 1)) > MaxX
CBound: constant := 10;
subtype
CIndex is integer range 0..CBound;
-- Power assertion (after initialization):
-- for all C in 0..CMax:
-- RootOf(Power(C).TwoN) = Power(C).Two &
-- Power(C+1) = Power(C) ** 2 &
-- Power(CMax+1).TwoN > MaxX &
-- Power(0).TwoN = 2**N
-- (Power(CMax+1) is not actually computed.)
type APower is record
Two, TwoN: Arith_Type;
end record; --APower
Power: array (CIndex) of APower;
CMax: CIndex;
function
RootOf (X: Arith_Type) return Arith_Type is
C: CIndex; -- C <= CMax
-- Sign * (XG1 ** Inverter) = X
Sign: Arith_Type; -- +1 or -1
Inverter: integer range -1..+1; -- +1 or -1
XG1: Arith_Type; -- 1 <= XG1 <= MaxX
-- RootOf (XG1) = RootOf (XNorm) * Unnormalizer
Unnormalizer: Arith_Type;
XNorm: Arith_Type; -- 1 <= XNorm < 2**N
-- Root & RootPrev are approximations to RootOf (XNorm)
Root, RootPrev: Arith_Type;
-- abs (RootOf (XNorm) - Root) <= Tolerance
Tolerance: constant := 1.0E-4;
begin -- body of RootOf
if X = 0.0
then
return (0.0); -- 0 = RootOf (0)
else
--assert: X /= 0
if X > 0.0
then Sign := +1.0; XG1 := +X;
else Sign := -1.0; XG1 := -X;
end if;
--assert: Sign * XG1 = X & XG1 > 0 & Sign = +1 or -1
if XG1 >= 1.0
then Inverter := +1;
else Inverter := -1;
end if;
XG1 := XG1 ** Inverter;
--assert: Sign * (XG1 ** Inverter) = X &
-- XG1 >= 1 &
-- Sign = +1 or -1 &
-- Inverter = +1 or -1
--assert: RootOf (X) = RootOf (Sign * (XG1 ** Inverter))
-- = Sign * (RootOf (XG1) ** Inverter)
--assert: 1 <= XG1 <= MaxX < (2**N) ** (2 ** (CMax + 1))
XNorm := XG1; Unnormalizer := 1.0; C := CMax + 1;
--invariant: RootOf (XG1) = Unnormalizer * RootOf (XNorm) &
-- 1 <= XNorm < (2**N) ** (2**C)
-- (see also Power assertion)
--bound: C
while C /= 0 loop
C := C - 1;
if XNorm >= Power(C).TwoN
then
--assert: RootOf (XNorm)
-- = RootOf ((XNorm / Power(C).TwoN) * Power(C).TwoN)
-- = RootOf (XNorm / Power(C).TwoN) * Power(C).Two
--assert: Power(C).TwoN <= XNorm < Power(C+1).TwoN
-- = Power(C).TwoN ** 2
XNorm := XNorm / Power(C).TwoN;
--assert: 1 <= XNorm < Power(C).TwoN
Unnormalizer := Unnormalizer * Power(C).Two;
end if;
-- invariant has been reestablished
end loop;
--assert: 1 <= XNorm < Power(0).TwoN = 2**N
--assert (incidentally): 1 <= RootOf (XNorm) < 2
--invariant & bound: supplied by Isaac Newton
RootPrev := 2.0;
loop
Root := (XNorm / (RootPrev ** (N - 1))
+ Arith_Type (N - 1) * RootPrev )
/ Arith_Type (N) ;
exit when abs (Root - RootPrev) <= Tolerance;
RootPrev := Root;
end loop;
--assert: abs (Root - RootOf (XNorm) <= Tolerance)
-- i.e., Root ~= RootOf (XNorm)
return (Sign * ((Root * Unnormalizer) ** Inverter));
end if; -- X = 0.0?
end RootOf;
begin -- NthRoot body
-- make Power assertion true (initialize Power)
Power(0).Two := 2.0; Power(0).TwoN := 2.0 ** N;
CMax := 1;
begin -- to catch exceptions
for C in CIndex loop -- escape on exception
--assert: Power(C).TwoN < MaxX
Power(C+1).TwoN := Power(C).TwoN ** 2; --may except
Power(C+1).Two := Power(C).Two ** 2;
CMax := C + 1;
end loop;
-- should never fall out
exception
when numeric_error -- on Power(C).TwoN ** 2 > MaxX
| constraint_error -- on C + 1 > CMax
=>
--assert: Power(CMax).TwoN > MaxX
null; -- just leave block
end; -- exception block
-- Power assertion is true
end NthRoot; -- body
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- The purpose of this package is to define an Ada type that has exactly
-- the operations that are valid for any physical quantity. This package
-- is then used by the packages that define many physical units. These
-- packages are used in turn by packages that define operators on physical
-- units that produce other physical units. Additional packages in this
-- set provide for outputting of physical units, conversions between
-- physical units, and other functions needed when working with physical
-- units.
--
package PHYSICAL_REAL is
type REAL is private ;
-- Operators available for all types derived from REAL
--
-- implicit : := = /=
--
--
-- Physical quantities with the same units can be added
-- preserving their physical units.
function "+" ( LEFT , RIGHT : REAL ) return REAL ;
-- Physical quantities with the same units can be subtracted
-- preserving their physical units.
function "-" ( LEFT , RIGHT : REAL ) return REAL ;
-- Multiplying a physical quantity by itself does not produce
-- the same physical quantity and thus must not be allowed.
-- Multiplying a physical quantity by a non dimensional quantity
-- does preserve the units of the physical quantity.
function "*" ( LEFT : LONG_FLOAT ;
RIGHT : REAL ) return REAL ;
function "*" ( LEFT : REAL ;
RIGHT : LONG_FLOAT ) return REAL ;
-- Dividing a physical quantity by a non dimensional quantity
-- preserves the units of the physical quantity.
function "/" ( LEFT : REAL ;
RIGHT : LONG_FLOAT ) return REAL ;
-- Dividing a physical quantity by itself produces
-- a non dimensional value.
function "/" ( LEFT , RIGHT : REAL ) return LONG_FLOAT ;
-- The absolute value of a physical quantity retains the
-- same physical units.
function "abs" ( LEFT : REAL ) return REAL ;
-- Equality and inequality are implicitly defined. The other
-- relational operators must be explicitly defined.
function "<" ( LEFT , RIGHT : REAL ) return BOOLEAN ;
function ">" ( LEFT , RIGHT : REAL ) return BOOLEAN ;
function "<=" ( LEFT , RIGHT : REAL ) return BOOLEAN ;
function ">=" ( LEFT , RIGHT : REAL ) return BOOLEAN ;
--Alstad start
-- Taking a root of a physical quantity by itself does not produce
-- the same physical quantity and thus must not be allowed.
function SQRT ( LEFT : LONG_FLOAT ) return LONG_FLOAT ;
function CUBE_ROOT ( LEFT : LONG_FLOAT ) return LONG_FLOAT ;
--Alstad end
-- The primary purpose of this function for the user is
-- to make constants into values of a specific physical
-- unit.
-- The use of this function in the set of physics packages
-- is to apply the required Ada type to the result of a
-- non dimensional computation.
function DIMENSION ( LEFT : LONG_FLOAT ) return REAL ;
-- The use of this function in the set of physics packages
-- is to take any physical quantity and get a non dimensional
-- value in the base floating point arithmetic type in order
-- to preform computation. This should not be needed by users
-- of the set of physics packages.
function UNDIMENSION ( LEFT : REAL ) return LONG_FLOAT ;
-- For compilers that can make use of INLINE
pragma INLINE ( "+" , "-" , "*" , "/" , "abs" , "<" , ">" , "<=" , ">=" ,
DIMENSION , UNDIMENSION ) ;
--
private
type REAL is new LONG_FLOAT ;
end PHYSICAL_REAL ;
with NthRoot; --Alstad
package body PHYSICAL_REAL is
--Alstad start
package Square is new NthRoot (N => 2, Arith_Type => LONG_FLOAT);
package Cube is new NthRoot (N => 3, Arith_Type => LONG_FLOAT);
function SQRT (LEFT : LONG_FLOAT) return LONG_FLOAT
is begin
return (Square.RootOf (LEFT));
end; -- SQRT
function CUBE_ROOT (LEFT : LONG_FLOAT) return LONG_FLOAT
is begin
return (Cube.RootOf (LEFT));
end; -- SQRT
pragma INLINE (SQRT, CUBE_ROOT);
--Alstad end
function "+" ( LEFT , RIGHT : REAL ) return REAL is
begin
return REAL ( LONG_FLOAT( LEFT ) + LONG_FLOAT ( RIGHT )) ;
end "+" ;
function "-" ( LEFT , RIGHT : REAL ) return REAL is
begin
return REAL ( LONG_FLOAT( LEFT ) - LONG_FLOAT ( RIGHT )) ;
end "-" ;
function "*" ( LEFT : LONG_FLOAT ;
RIGHT : REAL ) return REAL is
begin
return REAL ( LEFT * LONG_FLOAT( RIGHT )) ;
end "*" ;
function "*" ( LEFT : REAL ;
RIGHT : LONG_FLOAT ) return REAL is
begin
return REAL ( LONG_FLOAT( LEFT ) * RIGHT) ;
end "*" ;
function "/" ( LEFT : REAL ;
RIGHT : LONG_FLOAT ) return REAL is
begin
return REAL ( LONG_FLOAT( LEFT ) / RIGHT) ;
end "/" ;
function "/" ( LEFT , RIGHT : REAL ) return LONG_FLOAT is
begin
return LONG_FLOAT ( LEFT ) / LONG_FLOAT ( RIGHT ) ;
end "/" ;
function "abs" ( LEFT : REAL ) return REAL is
begin
return REAL ( abs( LONG_FLOAT( LEFT ))) ;
end "abs" ;
function "<" ( LEFT , RIGHT : REAL ) return BOOLEAN is
begin
return LONG_FLOAT ( LEFT ) < LONG_FLOAT ( RIGHT ) ;
end "<" ;
function ">" ( LEFT , RIGHT : REAL ) return BOOLEAN is
begin
return LONG_FLOAT ( LEFT ) > LONG_FLOAT ( RIGHT ) ;
end ">" ;
function "<=" ( LEFT , RIGHT : REAL ) return BOOLEAN is
begin
return LONG_FLOAT ( LEFT ) <= LONG_FLOAT ( RIGHT ) ;
end "<=" ;
function ">=" ( LEFT , RIGHT : REAL ) return BOOLEAN is
begin
return LONG_FLOAT ( LEFT ) >= LONG_FLOAT ( RIGHT ) ;
end ">=" ;
function DIMENSION ( LEFT : LONG_FLOAT ) return REAL is
begin
return REAL ( LEFT ) ;
end DIMENSION ;
function UNDIMENSION ( LEFT : REAL ) return LONG_FLOAT is
begin
return LONG_FLOAT ( LEFT ) ;
end UNDIMENSION ;
end PHYSICAL_REAL ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with TEXT_IO ; use TEXT_IO ;
package LONG_FLT_IO is new FLOAT_IO ( LONG_FLOAT ) ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_REAL ; use PHYSICAL_REAL ;
package PHYSICAL_UNITS_BASIC is
-- This package specification defines Ada types for physical
-- quantities. A number of other packages use this package
-- specification in order to provide a comprehensive dimension
-- checking and units conversion system.
--
-- PHYSICAL QUANTITIES AND THEIR ASSOCIATED DIMENSIONS
--
-- Errors can occur in writing equations to solve problems in classical
--physics. Many of these errors can be prevented by performing a dimensionality
--check on the equations. All physical quantities have a fundamental dimension
--that is independent of the units of measurement. The basic physical dimensions
--are: length, mass, time, electrical charge, temperature and luminous intens-
--ity.There are a number of systems of units for measuring physical quantities.
--The MKS system is based on meter, kilogram, second measurement.
--The CGS system is based on centimeter, gram, second measurement.
--The English system is based on feet, pound, second measurement.
--A few physical dimensions and the associated measurement unit in
--these three systems are :
--
--
-- Physical Quantity Unit System
-- Dimension MKS CGS English
--
-- length meter centimeter feet
--
-- mass kilogram gram pound mass
--
-- time second second second
--
-- force newton dyne poundal
--
-- energy joule erg B.t.u.
--
--
-- The checking of a physical equation has two aspects. The first is to check
--the dimensionality. The dimensionality is independent of the unit system. The
--second is to check that a consistent system of units is used in the equation.
-- An example of a dimensionality check is using the basic equation F=ma to
--determine that force has the dimension mass x length / time squared, then
-- 2
--check if F=mv /r is dimensionally correct. The check is performed by
--expanding the dimensions, e.g. mass x (length/time) x (length/time) / length.
--with the dimensions expected for force from the basic equation F=ma. As
--expected, centripetal force has the same dimensionality as the force from
--Newton's second law of motion.
--
-- THE ALGEBRA OF DIMENSIONALITY
--
-- The dimension of any physical quantity can be written as
--
-- a b c d e f
-- L M T Q C K
--
--where a,b,c,d,e and f are integers such as -4, -3, -2 , -1, 0, 1, 2, 3, 4
--and L is length, M is mass, T is time, Q is charge, C is luminous intensity
--and K is temperature. An exponent of zero means the dimension does not apply
--to the physical quantity. The normal rules of algebra for exponents apply
--for combining dimensions.
--
-- In order to add or subtract two physical quantities the quantities must
--have the same dimension. The resulting physical quantity has the same
--dimensions. Physical quantities with the same dimension in different
--systems of units can be added or subtracted by multiplying one of
--the quantities by a units conversion factor to obtain compatible units.
--
-- The multiplication of two physical quantities results in a new physical
--quantity that has the sum of the exponents of the dimensions of the initial
--two quantities.
--
-- The division of one physical quantity by another results in a new physical
--quantity that has the dimension of the exponents of the first quantity minus
--the exponents of the second quantity.
--
-- Taking the square root of a physical quantity results in a new physical
--quantity having a dimension with exponents half of the initial dimension.
--
-- Raising a physical quantity to a power results in a new physical quantity
--having a dimension with the exponents multiplied by the power.
--
-- 2 2 2 2 -2
-- e.g. v has dimension L/T, v has dimension L /T or L T
--
-- The derivative of a physical quantity with respect to another physical
--quantity results in a new physical quantity with the exponents of the
--first dimension minus the exponents of the other dimension.
-- e.g. v has dimension L/T, t has dimension T,
--
-- 2
-- then dv/dt has dimension L/T
--
-- The integral of a physical quantity over the range of another physical
--quantity results in a new physical quantity that has a dimension with the
--sum of the exponents of the two quantities.
--
-- e.g. v has dimension L/T, t has dimension T,
-- then integral v dt has dimension L/T * T or L
--
--
-- The initial thought was to have metric units and English units
-- in separate package specifications. This proved inpractical
-- because time in seconds is both metric and English. Many other
-- units such as watt of power and Farad of capacitance are in
-- both systems. A further impracticallity arose when considering
-- the design of a units system conversion package. e.g. A package
-- that would provide accurate conversion form meters to inches
-- to micrometers to light years. The one package specification became
-- so large that it was inefficient, so, in order to keep the size
-- reasonable, three packages were created. The basic units, the
-- mechanical units and the electrical units. Then a package
-- called other units came into existance for pragmatic reasons.
--
-- Notice that there is not a type called LENGTH because
-- adding length in meters to length in feet is not allowed.
-- Even LENGTH_METRIC and LENGTH_ENGLISH are not acceptable
-- because meters can not be added to centimeters and inches can
-- not be added to feet. Further complication arises because of
-- seconds of time and seconds of arc. There can be ounces of
-- milk ( liquid measure ) and ounces of sugar ( weight measure ).
-- There can be quarts of milk and quarts of strawberries ( dry
-- measure ). Thus the decision was made that every Ada type
-- would be a dimension name followed by a unit name.
--
-- Now, more choices had to be made. Unit names such as
-- DENSITY_KILOGRAM_PER_CUBIC_METER or DENSITY_TONS_PER_CUBIC_YARD
-- start getting long and there are many combinations. The number
-- of combinations for density are all the units of mass times all
-- the units of volume. Thus a subset of all possible units was
-- chosen with the additional short hand notation of _MKS for
-- the meter, kilogram, second system of units and the _ENGLISH for
-- the foot, pound, second system. Additional qualifiers are added
-- to clarify such as VOLUME_QUART_LIQUID and VOLUME_QUART_DRY.
--
-- Some other compromises were made:
-- Only a few units were entered as both singular and plural.
-- The choice of names is the authors. A committee could expand
-- the list. For example a meter can be a length or a distance,
-- length is used as the type and distance is a subtype.
-- A user may provide additional local subtype names for units
-- and thus has the full capability for alternate type names.
--
-- The comments below are organized to present the physical quantity name with
--associated information. The second column is one of the typical symbols used
--for the physical quantity. The third column is the dimension of the physical
--quantity expressed in terms of the fundamental dimensions. The fourth column
--is the name of the unit in the MKS measurement system. The fifth column
--is the typical MKS unit equation. An independent table presents conversion
--factors from the MKS measurement system to other measurement systems.
-- Physics developed over a period of many years by many people from a variety
--of disciplines. Thus, there is ambiguity and duplication of symbols.
--
--
--PHYSICAL QUANTITY SYMBOL DIMENSION MEASUREMENT UNIT UNIT EQUATION
--_________________ ______ _________ ________________ ______________
--
--
-- BASIC UNITS
--
--length s L meter m
--wave length lambda " " "
--
type LENGTH_MKS is new REAL ;
subtype LENGTH_METER is LENGTH_MKS ;
subtype LENGTH_METERS is LENGTH_MKS ; -- This could be done for every type
subtype DISTANCE_METER is LENGTH_MKS ; -- with plurals and alias and
subtype DISTANCE_METERS is LENGTH_MKS ; -- plurals for the alias
subtype WAVE_LENGTH_MKS is LENGTH_MKS ;
subtype WAVE_LENGTH_METER is LENGTH_MKS ;
type LENGTH_ENGLISH is new REAL ;
subtype LENGTH_FOOT is LENGTH_ENGLISH ;
subtype LENGTH_FEET is LENGTH_ENGLISH ;
type LENGTH_PICOMETER is new REAL ;
type LENGTH_NANOMETER is new REAL ;
type LENGTH_MICROMETER is new REAL ;
type LENGTH_MILLIMETER is new REAL ;
type LENGTH_CENTIMETER is new REAL ;
type LENGTH_DECIMETER is new REAL ;
type LENGTH_DECAMETER is new REAL ;
type LENGTH_HECTOMETER is new REAL ;
type LENGTH_KILOMETER is new REAL ;
type LENGTH_MEGAMETER is new REAL ;
type LENGTH_GIGAMETER is new REAL ;
type LENGTH_ANGSTROM is new REAL ;
type LENGTH_MIL is new REAL ;
type LENGTH_INCH is new REAL ;
type LENGTH_YARD is new REAL ;
type LENGTH_FATHOM is new REAL ;
type LENGTH_ROD is new REAL ;
type LENGTH_CHAIN_SURVEYOR is new REAL ;
type LENGTH_CHAIN_ENGINEER is new REAL ;
type LENGTH_FURLONG is new REAL ;
type LENGTH_MILE is new REAL ;
subtype LENGTH_MILE_STATUTE is LENGTH_MILE ;
type LENGTH_MILE_NAUTICAL is new REAL ;
type LENGTH_LEAGUE_LAND is new REAL ;
type LENGTH_LEAGUE_MARINE is new REAL ;
type LENGTH_LIGHT_YEAR is new REAL ;
--
--mass m M kilogram Kg
--
type MASS_MKS is new REAL ;
subtype MASS_KILOGRAM is MASS_MKS ;
type MASS_ENGLISH is new REAL ;
subtype MASS_POUND is MASS_ENGLISH ;
subtype MASS_POUND_AVDP is MASS_ENGLISH ;
type MASS_POUND_TROY is new REAL ;
subtype MASS_POUND_APOTHECARY is MASS_POUND_TROY ;
type MASS_MILLIGRAM is new REAL ;
type MASS_GRAM is new REAL ;
type MASS_GRAIN is new REAL ; -- same inall English systems
type MASS_PENNYWEIGHT_TROY is new REAL ;
type MASS_CARAT_TROY is new REAL ;
type MASS_SCRUPLE is new REAL ;
type MASS_DRAM_AVDP is new REAL ;
type MASS_OUNCE_AVDP is new REAL ;
type MASS_OUNCE_TROY is new REAL ;
type MASS_TON_SHORT is new REAL ;
type MASS_TON_LONG is new REAL ;
type MASS_TON_METRIC is new REAL ;
--
--time t T second sec
--
type TIME_SECOND is new REAL ;
subtype TIME_SECONDS is TIME_SECOND ;
type TIME_PICOSECOND is new REAL ;
type TIME_NANOSECOND is new REAL ;
type TIME_MICROSECOND is new REAL ;
type TIME_MILLISECOND is new REAL ;
type TIME_CENTISECOND is new REAL ;
type TIME_KILOSECOND is new REAL ;
type TIME_MEGASECOND is new REAL ;
type TIME_GIGASECOND is new REAL ;
type TIME_MINUTE is new REAL ;
type TIME_HOUR is new REAL ;
type TIME_DAY is new REAL ;
type TIME_FORTNIGHT is new REAL ;
type TIME_MONTH is new REAL ;
type TIME_YEAR is new REAL ;
type TIME_DECADE is new REAL ;
type TIME_CENTURY is new REAL ;
type TIME_MILLENNIA is new REAL ;
--
--electric charge q Q coulomb c
-- electric flux
--
type CHARGE_COULOMB is new REAL ;
subtype CHARGE_AMPERE_SECOND is CHARGE_COULOMB ;
type CHARGE_AMPERE_HOURS is new REAL ;
type CHARGE_ELECTRON is new REAL ;
type CHARGE_FARADAY is new REAL ;
--
--luminous intensity I C candle cd
--
type LUMINOUS_INTENSITY_CANDLE is new REAL ;
-- o
--temperature T K degree kelvin K
--
type TEMPERATURE_KELVIN is new real ;
type TEMPERATURE_CENTIGRADE is new REAL ;
subtype TEMPERATURE_CELSIUS is TEMPERATURE_CENTIGRADE ;
type TEMPERATURE_FARENHEIT is new REAL ;
--
--angle theta none radian none
--
type ANGLE_RADIAN is new REAL ;
subtype ANGLE_RADIANS is ANGLE_RADIAN ;
subtype PLANE_ANGLE_RADIANS is ANGLE_RADIAN ;
type ANGLE_SECOND is new REAL ;
type ANGLE_MINUTE is new REAL ;
type ANGLE_DEGREE is new REAL ;
type ANGLE_REVOLUTION is new REAL ;
type ANGLE_BAM is new REAL ;
--
--solid angle phi none steradian none
--
type SOLID_ANGLE_STERADIAN is new REAL ;
--
end PHYSICAL_UNITS_BASIC ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_REAL ; use PHYSICAL_REAL ;
package PHYSICAL_UNITS_MECHANICAL is
-- This package specification defines Ada types for physical
-- quantities generally in the mechanical context.
--
-- This package is the logical continuation of PHYSICAL_UNITS_BASIC
--
--
-- DERIVED MECHANICAL UNITS
--
--
-- 2 2
--area A L square meter m
--
type AREA_MKS is new REAL ;
subtype AREA_SQUARE_METER is AREA_MKS ;
subtype AREA_SQUARE_METERS is AREA_MKS ;
type AREA_ENGLISH is new REAL ;
subtype AREA_SQUARE_FEET is AREA_ENGLISH ;
subtype AREA_SQUARE_FOOT is AREA_ENGLISH ;
type AREA_SQUARE_CENTIMETER is new REAL ;
type AREA_SQUARE_KILOMETER is new REAL ;
type AREA_SQUARE_INCH is new REAL ;
type AREA_SQUARE_YARD is new REAL ;
type AREA_SQUARE_MILE is new REAL ;
type AREA_ACRE is new REAL ;
type AREA_CIRCULAR_MIL is new REAL ;
type AREA_HECTARE is new REAL ;
type AREA_TOWNSHIP is new REAL ;
--
-- 3 3
--volume V L stere m
--
type VOLUME_MKS is new REAL ;
subtype VOLUME_STERE is VOLUME_MKS ;
subtype VOLUME_CUBIC_METER is VOLUME_MKS ;
type VOLUME_ENGLISH is new REAL ;
subtype VOLUME_CUBIC_FEET is VOLUME_ENGLISH ;
type VOLUME_MILLILITER is new REAL ;
type VOLUME_LITER is new REAL ;
type VOLUME_KILOLITER is new REAL ;
type VOLUME_CUBIC_CENTIMETER is new REAL ;
type VOLUME_CUBIC_INCH is new REAL ;
type VOLUME_CUBIC_YARD is new REAL ;
type VOLUME_CUBIC_MILE is new REAL ;
type VOLUME_TEASPOON is new REAL ;
type VOLUME_TABLESPOON is new REAL ;
type VOLUME_OUNCE_FLUID is new REAL ;
type VOLUME_JIGGER is new REAL ;
type VOLUME_CUP is new REAL ;
type VOLUME_PINT_LIQUID is new REAL ;
type VOLUME_QUART_LIQUID is new REAL ;
type VOLUME_GALLON is new REAL ;
type VOLUME_KEG is new REAL ;
type VOLUME_BARREL is new REAL ;
type VOLUME_PINT_DRY is new REAL ;
type VOLUME_QUART_DRY is new REAL ;
type VOLUME_PECK is new REAL ;
type VOLUME_BUSHEL is new REAL ;
type VOLUME_CORD is new REAL ;
--
--velocity v L/T meter per second m/sec
--
type VELOCITY_MKS is new REAL ;
subtype VELOCITY_METER_PER_SECOND is VELOCITY_MKS ;
type VELOCITY_ENGLISH is new REAL ;
subtype VELOCITY_FEET_PER_SECOND is VELOCITY_ENGLISH ;
type VELOCITY_CENTIMETER_PER_SECOND is new REAL ;
type VELOCITY_KILOMETER_PER_HOUR is new REAL ;
type VELOCITY_INCHES_PER_SECOND is new REAL ;
type VELOCITY_MILE_PER_HOUR is new REAL ;
type VELOCITY_MILES_PER_SECOND is new REAL ;
type VELOCITY_INCHES_PER_MINUTE is new REAL ;
type VELOCITY_FEET_PER_MINUTE is new REAL ;
type VELOCITY_MILES_PER_HOUR is new REAL ;
type VELOCITY_KNOTS is new REAL ;
type VELOCITY_FURLONG_PER_FORTNIGHT is new REAL ;
--
--angular velocity omega 1/T radians per second 1/sec
--
type ANGULAR_VELOCITY is new REAL ;
subtype ANGULAR_VELOCITY_RADIANS_PER_SECOND is ANGULAR_VELOCITY ;
type ANGULAR_VELOCITY_DEGREES_PER_SECOND is new REAL ;
type ANGULAR_VELOCITY_REVOLUTIONS_PER_MINUTE is new REAL ;
type ANGULAR_VELOCITY_REVOLUTIONS_PER_SECOND is new REAL ;
--
-- 2 2
--acceleration a L/T meter per second m/sec
-- squared
--
type ACCELERATION_MKS is new REAL ;
subtype ACCELERATION_METER_PER_SECOND_SQUARED is ACCELERATION_MKS ;
type ACCELERATION_ENGLISH is new REAL ;
subtype ACCELERATION_FEET_PER_SECOND_SQUARED is ACCELERATION_ENGLISH ;
--
-- 2 2
--angular acceleration alpha 1/T radians per 1/sec
-- square second
--
type ANGULAR_ACCELERATION is new REAL ;
subtype ANGULAR_ACCELERATION_RADIANS_PER_SECOND_SQUARED is
ANGULAR_ACCELERATION ;
type ANGULAR_ACCELERATION_REVOLUTIONS_PER_MINUTE_SQUARED is new REAL ;
--
-- 2 2
--force F ML/T newton Kg m/sec
--
type FORCE_MKS is new REAL ;
subtype FORCE_NEWTON is FORCE_MKS ;
subtype FORCE_KILOGRAM_METER_PER_SECOND_SQUARED is FORCE_MKS ;
type FORCE_DYNE is new REAL ;
type FORCE_ENGLISH is new REAL ;
subtype FORCE_POUNDAL is FORCE_ENGLISH ;
subtype FORCE_POUND_FOOT_PER_PER_SECOND_SQUARED is FORCE_ENGLISH ;
--
-- 2 2 2 2
--energy E ML /T joule Kg m /sec
--work W " " "
--heat Q " " "
--torque (moment) T " newton meter "
--
type ENERGY_MKS is new REAL ;
subtype WORK_MKS is ENERGY_MKS ;
subtype HEAT_MKS is ENERGY_MKS ;
subtype TORQUE_MKS is ENERGY_MKS ;
subtype ENERGY_JOULE is ENERGY_MKS ;
subtype ENERGY_NEWTON_METER is ENERGY_MKS ;
subtype ENERGY_KILOGRAM_METER_SQUARED_PER_SECOND_SQUARED is ENERGY_MKS ;
type ENERGY_ERG is new REAL ;
type ENERGY_GRAM_CALORIE is new REAL ;
type ENERGY_KILOGRAM_CALORIE is new REAL ;
type ENERGY_ENGLISH is new REAL ;
subtype ENERGY_B_T_U is ENERGY_ENGLISH ;
type ENERGY_FOOT_POUND is new REAL ;
type ENERGY_KILOWATT_HOUR is new REAL ;
type ENERGY_HORSEPOWER_HOUR is new REAL ;
--
-- 2 3
--power P ML /T watt joule/sec
--
type POWER_MKS is new REAL ;
subtype POWER_WATT is POWER_MKS ;
subtype POWER_JOULE_PER_SECOND is POWER_MKS ;
subtype POWER_VOLT_AMPERE is POWER_MKS ;
type POWER_KILOGRAM_CALORIE_PER_SECOND is new REAL ;
type POWER_KILOGRAN_CALORIE_PER_MINUTE is new REAL ;
type POWER_HORSEPOWER_MECHANICAL is new REAL ;
type POWER_HORSEPOWER_ELECTRICAL is new REAL ;
type POWER_HORSEPOWER_METRIC is new REAL ;
type POWER_HORSEPOWER_BOILER is new REAL ;
type POWER_B_T_U_PER_MINUTE is new REAL ;
type POWER_B_T_U_PER_HOUR is new REAL ;
type POWER_FOOT_POUND_PER_MINUTE is new REAL ;
type POWER_FOOT_POUND_PER_SECOND is new REAL ;
--
-- 3 3
--density D M/L kilogram per Kg/m
-- cubic meter
--
type DENSITY_MKS is new REAL ;
subtype DENSITY_KILOGRAM_PER_CUBIC_METER is DENSITY_MKS ;
type DENSITY_ENGLISH is new REAL ;
subtype DENSITY_POUND_PER_CUBIC_FOOT is DENSITY_ENGLISH ;
--
-- 3 3
--flow rate f L /T cubic meter per m /sec
-- second
--
type FLOW_RATE_MKS is new REAL ;
subtype FLOW_RATE_CUBIC_METER_PER_SECOND is FLOW_RATE_MKS ;
type FLOW_RATE_ENGLISH is new REAL ;
subtype FLOW_RATE_CUBIC_FEET_PER_SECOND is FLOW_RATE_ENGLISH ;
type FLOW_RATE_GALLON_PER_MINUTE is new REAL ;
type FLOW_RATE_CUBIC_FEET_PER_MINUTE is new REAL ;
--
-- 2 2
--pressure P M/LT pascal Kg/m sec
-- stress newton per
-- energy density square meter
--
type PRESSURE_MKS is new REAL ;
subtype PRESSURE_PASCAL is PRESSURE_MKS ;
subtype PRESSURE_NEWTON_PER_SQUARE_METER is PRESSURE_MKS ;
subtype PRESSURE_FORCE_PER_AREA_MKS is PRESSURE_MKS ;
subtype PRESSURE_JOULE_PER_CUBIC_METER is PRESSURE_MKS ;
subtype PRESSURE_ENERGY_DENSITY_MKS is PRESSURE_MKS ;
type PRESSURE_ENGLISH is new REAL ;
subtype PRESSURE_POUND_PER_SQUARE_FOOT is PRESSURE_ENGLISH ;
type PRESSURE_TON_PER_SQUARE_FOOT is new REAL ;
type PRESSURE_ATMOSPHERE_STANDARD is new REAL ;
type PRESSURE_FEET_OF_WATER is new REAL ;
type PRESSURE_INCHES_OF_MERCURY is new REAL ;
type PRESSURE_MILLIMETER_OF_MERCURY is new REAL ;
type PRESSURE_BAR is new REAL ;
type PRESSURE_MILLIBAR is new REAL ;
type PRESSURE_TORR is new REAL ;
--
--momentum p ML/T newton second Kg m/sec
--
type MOMENTUM_MKS is new REAL ;
subtype MOMENTUM_NEWTON_SECOND is MOMENTUM_MKS ;
subtype MOMENTUM_KILOGRAM_METER_PER_SECOND is MOMENTUM_MKS ;
--
-- 2 2
--inertia I ML /T joule second Kg m /sec
--
type INERTIA_MKS is new REAL ;
subtype INERTIA_JOULE_SECOND is INERTIA_MKS ;
subtype INERTIA_KILOGRAM_METER_SQUARED_PER_SECOND is INERTIA_MKS ;
--
-- 2 2
--moment of inertia M ML kilogram Kg m
-- meter squared
--
type MOMENT_OF_INERTIA_MKS is new REAL ;
subtype MOMENT_OF_INERTIA_KILOGRAM_METER_SQUARED is MOMENT_OF_INERTIA_MKS ;
--
-- 2 2
--kinematic viscosity v M /T kilogram squared Kg /sec
-- per second
--
type KINEMATIC_VISCOSITY_MKS is new REAL ;
subtype KINEMATIC_VISCOSITY_KILOGRAM_SQUARED_PER_SECOND is
KINEMATIC_VISCOSITY_MKS ;
--
--dynamic viscosity d M/LT newton second Kg/m sec
-- per square meter
--
type DYNAMIC_VISCOSITY_MKS is new REAL ;
subtype DYNAMIC_VISCOSITY_NEWTON_PER_SQUARE_METER is DYNAMIC_VISCOSITY_MKS ;
subtype DYNAMIC_VISCOSITY_KILOGRAM_PER_METER_SECOND is DYNAMIC_VISCOSITY_MKS ;
--
--
--luminous flux phi C lumen (4Pi candle cd sr
-- for point source)
--
type LUMINOUS_FLUX_LUMEN is new REAL ;
--
-- 2 2
--illumination E C/L lumen per cd sr/m
-- square meter
--
type ILLUMINATION_MKS is new REAL ;
subtype ILLUMINATION_LUMEN_PER_SQUARE_METER is ILLUMINATION_MKS ;
--
-- 2 2
--luminance l C/L lux cd/m
-- square meter
--
type LUMINANCE_MKS is new REAL ;
subtype LUMINANCE_LUX is LUMINANCE_MKS ;
subtype LUMINANCE_CANDLE_PER_SQUARE_METER is LUMINANCE_MKS ;
--
--
-- 2 2 2
--entropy S ML /T K joule per degree Kg m /
-- 2 o
-- sec K
--
type ENTROPY_MKS is new REAL ;
subtype SPECIFIC_HEAT_MKS is ENTROPY_MKS ;
subtype SPECIFIC_HEAT_JOULE_PER_DEGREE_KELVIN is ENTROPY_MKS ;
type SPECIFIC_HEAT_B_T_U_PER_POUND_DEGREE_FARENHEIT is new REAL ;
--
end PHYSICAL_UNITS_MECHANICAL ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_REAL ; use PHYSICAL_REAL ;
package PHYSICAL_UNITS_ELECTRICAL is
-- This package specification defines Ada types for physical
-- quantities related to electrical units. It ia a logical
-- extension of PHYSICAL_UNITS_MECHANICAL .
--
--
--
-- DERIVED ELECTRICAL
--
--electric current I Q/T ampere c/sec
-- magnetomotive force
type CURRENT_AMPERE is new REAL ;
type CURRENT_MILLIAMPERE is new REAL ;
type CURRENT_MICROAMPERE is new REAL ;
type CURRENT_ABAMPERE is new REAL ;
type CURRENT_STATAMPERE is new REAL ;
--
-- 2 2 2 2
--voltage E ML /T Q volt Kg m /sec c
-- potential difference
-- electromotive force
type VOLTAGE_VOLT is new REAL ;
type VOLTAGE_MILLIVOLT is new REAL ;
type VOLTAGE_MICROVOLT is new REAL ;
type VOLTAGE_KILOVOLT is new REAL ;
--
-- 2 2 2 2
--electric resistance R ML /TQ ohm Kg m /sec c
--
type RESISTANCE_OHM is new REAL ;
type RESISTANCE_MILLIOHM is new REAL ;
type RESISTANCE_KILOHM is new REAL ;
type RESISTANCE_MEGOHM is new REAL ;
--
-- 3 2 3 2
--electric resistivity rho ML /TQ ohm meter Kg m /sec c
--
type RESISTIVITY_OHM_METER is new REAL ;
--
-- 2 2 2 2
--electric conductance G TQ /ML mho sec c /Kg m
--
type CONDUCTANCE_MHO is new REAL ;
--
-- 2 3 2 3
--conductivity sigma TQ /ML mho per meter sec c /Kg m
--
type CONDUCTIVITY_MHO_PER_METER is new REAL ;
--
--
-- 2 2 2 2 2 2
--capacitance C T Q /ML farad sec c /Kg m
--
type CAPACITANCE_FARAD is new REAL ;
type CAPACITANCE_MICROFARAD is new REAL ;
type CAPACITANCE_PICOFARAD is new REAL ;
--
--
-- 2 2 2 2
--inductance L ML /Q henry Kg m /c
-- weber per ampere
-- volt second per ampere
--
type INDUCTANCE_HENRY is new REAL ;
type INDUCTANCE_MILLIHENRY is new REAL ;
type INDUCTANCE_MICROHENRY is new REAL ;
--
-- 2 2
--current density J Q/TL ampere per c/sec m
-- square meter
--
type CURRENT_DENSITY_AMPERE_PER_SQUARE_METER is new REAL ;
--
-- 3 3
--charge density rho Q/L coulomb per c/m
-- cubic meter
--
type CHARGE_DENSITY_COULOMB_PER_CUBIC_METER is new REAL ;
-- 2 2
--magnetic flux F ML /TQ weber Kq m /sec c
-- volt second
--
type MAGNETIC_FLUX_WEBER is new REAL ;
--
--magnetic flux density, B M/TQ tesla Kq/sec c
-- magnetic induction weber per square meter
--
type MAGNETIC_FLUX_DENSITY is new REAL ;
subtype MAGNETIC_FLUX_DENSITY_TESLA is MAGNETIC_FLUX_DENSITY ;
subtype MAGNETIC_FLUX_DENSITY_WEBER_PER_SQUARE_METER is
MAGNETIC_FLUX_DENSITY ;
--
--magnetic intensity H Q/LT ampere per meter c/m sec
-- magnetic field strength
--
type MAGNETIC_INTENSITY is new REAL ;
subtype MAGNETIC_INTENSITY_AMPERE_PER_METER is MAGNETIC_INTENSITY ;
--
--
--magnetic vector potential A ML/TQ weber/meter Kg m/sec c
--
type MAGNETIC_VECTOR_POTENTIAL_WEBER_PER_METER is new REAL ;
--
-- 2 2
--electric field intensity E ML/T Q volt/meter Kg m/sec c
-- electric field strength newton per coulomb
--
type ELECTRIC_FIELD is new REAL ;
subtype ELECTRIC_FIELD_INTENSITY_VOLT_PER_METER is
ELECTRIC_FIELD ;
--
-- 2 2
--electric displacement D Q/L coulomb per c/m
-- square meter
--
type ELECTRIC_DISPLACEMENT is new REAL ;
subtype ELECTRIC_DISPLACEMENT_COULOMB_PER_SQUARE_METER is
ELECTRIC_DISPLACEMENT ;
--
-- 2 2
--permeability mu ML/Q henry per meter Kg m/c
--
type PERMEABILITY is new REAL ;
subtype PERMEABILITY_HENRY_PER_METER is PERMEABILITY ;
--
-- 2 2 3 2 2 3
--permittivity, epsi T Q /ML farad per meter sec c /Kg m
-- dielectric constant
--
type PERMITTIVITY is new REAL ;
subtype PERMITTIVITY_FARAD_PER_METER is PERMITTIVITY ;
subtype DIELECTRIC_CONSTANT is PERMITTIVITY ;
--
-- -1
--frequency f Pi/T hertz sec
--
type FREQUENCY_HERTZ is new REAL ;
type FREQUENCY_KILOHERTZ is new REAL ;
type FREQUENCY_MEGAHERTZ is new REAL ;
type FREQUENCY_GIGAHERTZ is new REAL ;
--
-- -1
--angular frequency omega 1/T radians per second sec
--
type ANGULAR_FREQUENCY_RADIAN_PER_SECOND is new REAL ;
--
end PHYSICAL_UNITS_ELECTRICAL ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_REAL ; use PHYSICAL_REAL ;
package PHYSICAL_UNITS_OTHER is
-- This package specification defines Ada types for physical
-- units that occur as intermediate results.
-- A number of other packages use this package.
--
--
-- The comments below are organized to present the physical quantity unit with
--associated information. The first column is the dimension of the physical
--quantity expressed in terms of the fundamental dimensions. The second column
--is the typical MKS unit equation.
--
-- DIMENSION UNIT EQUATION
-- _________ _____________
--
-- TYPES NEEDED FOR COMPUTATIONS
--
-- 2 2
-- T sec
type TIME_SECOND_SQUARED is new REAL ;
--
-- 2 2 2 2
-- L /T m /sec
type VELOCITY_SQUARED_MKS is new REAL ;
subtype VELOCITY_MKS_SQUARED is VELOCITY_SQUARED_MKS ;
-- 2 2 o
-- ML /T K joule/ K
type JOULE_PER_DEGREE_KELVIN is new REAL ;
--
-- 3 2 2
-- ML /T Q m/farad
type METER_PER_FARAD is new REAL ;
--
-- 2 4 4 2 2
-- M L /T Q volt
type VOLT_SQUARED is new REAL ;
--
-- 2 2 2
-- Q /T ampere
type AMPERE_SQUARED is new REAL ;
--
-- 2
-- Q/T ampere/sec
type AMPERE_PER_SECOND is new REAL ;
--
-- 2 3
-- ML /T Q volt/sec
type VOLT_PER_SECOND is new REAL ;
--
-- 2 2
-- L /MT
type ACCELERATION_PER_KILOGRAM is new REAL ;
--
end PHYSICAL_UNITS_OTHER ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_UNITS_BASIC ; use PHYSICAL_UNITS_BASIC ;
package PHYSICAL_UNITS_OUTPUT_BASIC is
-- This package specification defines a simple PUT for Ada types for physical
-- quantities. The initial thought was to have metric units and English units
-- in separate package specifications. This proved inpractical
-- because time in seconds is both metric and English. Many other
-- units such as watt of power and Farad of capacitance are in
-- both systems. Thus, in order to keep the packages reasonable sizes,
-- the packages are basic units, mechanical units and electrical units.
--
-- Notice that there is not a procedure PUT defined for LENGTH_METER
-- or for that matter, any " subtype " defined in the package PHYSICAL_UNITS.
-- It is unnecessary and happens to be illegal ada.
procedure PUT ( ITEM : LENGTH_MKS ) ;
procedure PUT ( ITEM : LENGTH_ENGLISH ) ;
procedure PUT ( ITEM : LENGTH_PICOMETER ) ;
procedure PUT ( ITEM : LENGTH_NANOMETER ) ;
procedure PUT ( ITEM : LENGTH_MICROMETER ) ;
procedure PUT ( ITEM : LENGTH_MILLIMETER ) ;
procedure PUT ( ITEM : LENGTH_CENTIMETER ) ;
procedure PUT ( ITEM : LENGTH_DECIMETER ) ;
procedure PUT ( ITEM : LENGTH_DECAMETER ) ;
procedure PUT ( ITEM : LENGTH_HECTOMETER ) ;
procedure PUT ( ITEM : LENGTH_KILOMETER ) ;
procedure PUT ( ITEM : LENGTH_MEGAMETER ) ;
procedure PUT ( ITEM : LENGTH_GIGAMETER ) ;
procedure PUT ( ITEM : LENGTH_ANGSTROM ) ;
procedure PUT ( ITEM : LENGTH_MIL ) ;
procedure PUT ( ITEM : LENGTH_INCH ) ;
procedure PUT ( ITEM : LENGTH_YARD ) ;
procedure PUT ( ITEM : LENGTH_FATHOM ) ;
procedure PUT ( ITEM : LENGTH_ROD ) ;
procedure PUT ( ITEM : LENGTH_CHAIN_SURVEYOR ) ;
procedure PUT ( ITEM : LENGTH_CHAIN_ENGINEER ) ;
procedure PUT ( ITEM : LENGTH_FURLONG ) ;
procedure PUT ( ITEM : LENGTH_MILE ) ;
procedure PUT ( ITEM : LENGTH_MILE_NAUTICAL ) ;
procedure PUT ( ITEM : LENGTH_LEAGUE_LAND ) ;
procedure PUT ( ITEM : LENGTH_LEAGUE_MARINE ) ;
procedure PUT ( ITEM : LENGTH_LIGHT_YEAR ) ;
procedure PUT ( ITEM : MASS_MKS ) ;
procedure PUT ( ITEM : MASS_ENGLISH ) ;
procedure PUT ( ITEM : MASS_POUND_TROY ) ;
procedure PUT ( ITEM : MASS_MILLIGRAM ) ;
procedure PUT ( ITEM : MASS_GRAM ) ;
procedure PUT ( ITEM : MASS_GRAIN ) ;
procedure PUT ( ITEM : MASS_PENNYWEIGHT_TROY ) ;
procedure PUT ( ITEM : MASS_CARAT_TROY ) ;
procedure PUT ( ITEM : MASS_SCRUPLE ) ;
procedure PUT ( ITEM : MASS_DRAM_AVDP ) ;
procedure PUT ( ITEM : MASS_OUNCE_AVDP ) ;
procedure PUT ( ITEM : MASS_OUNCE_TROY ) ;
procedure PUT ( ITEM : MASS_TON_SHORT ) ;
procedure PUT ( ITEM : MASS_TON_LONG ) ;
procedure PUT ( ITEM : MASS_TON_METRIC ) ;
procedure PUT ( ITEM : TIME_SECOND ) ;
procedure PUT ( ITEM : TIME_PICOSECOND ) ;
procedure PUT ( ITEM : TIME_NANOSECOND ) ;
procedure PUT ( ITEM : TIME_MICROSECOND ) ;
procedure PUT ( ITEM : TIME_MILLISECOND ) ;
procedure PUT ( ITEM : TIME_CENTISECOND ) ;
procedure PUT ( ITEM : TIME_KILOSECOND ) ;
procedure PUT ( ITEM : TIME_MEGASECOND ) ;
procedure PUT ( ITEM : TIME_GIGASECOND ) ;
procedure PUT ( ITEM : TIME_MINUTE ) ;
procedure PUT ( ITEM : TIME_HOUR ) ;
procedure PUT ( ITEM : TIME_DAY ) ;
procedure PUT ( ITEM : TIME_FORTNIGHT ) ;
procedure PUT ( ITEM : TIME_MONTH ) ;
procedure PUT ( ITEM : TIME_YEAR ) ;
procedure PUT ( ITEM : TIME_DECADE ) ;
procedure PUT ( ITEM : TIME_CENTURY ) ;
procedure PUT ( ITEM : TIME_MILLENNIA ) ;
procedure PUT ( ITEM : CHARGE_COULOMB ) ;
procedure PUT ( ITEM : CHARGE_ELECTRON ) ;
procedure PUT ( ITEM : CHARGE_FARADAY ) ;
procedure PUT ( ITEM : CHARGE_AMPERE_HOURS ) ;
procedure PUT ( ITEM : LUMINOUS_INTENSITY_CANDLE ) ;
procedure PUT ( ITEM : TEMPERATURE_KELVIN ) ;
procedure PUT ( ITEM : TEMPERATURE_CENTIGRADE ) ;
procedure PUT ( ITEM : TEMPERATURE_FARENHEIT ) ;
procedure PUT ( ITEM : ANGLE_RADIAN ) ;
procedure PUT ( ITEM : ANGLE_SECOND ) ;
procedure PUT ( ITEM : ANGLE_MINUTE ) ;
procedure PUT ( ITEM : ANGLE_DEGREE ) ;
procedure PUT ( ITEM : ANGLE_REVOLUTION ) ;
procedure PUT ( ITEM : ANGLE_BAM ) ;
procedure PUT ( ITEM : SOLID_ANGLE_STERADIAN ) ;
end PHYSICAL_UNITS_OUTPUT_BASIC ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_REAL ; use PHYSICAL_REAL ;
with TEXT_IO ; use TEXT_IO ;
with LONG_FLT_IO ; use LONG_FLT_IO ;
package body PHYSICAL_UNITS_OUTPUT_BASIC is
procedure PUT ( ITEM : LENGTH_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " meter " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " feet " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_PICOMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " picometer " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_NANOMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " nanometer " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_MICROMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " micrometer " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_MILLIMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " millimeter " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_CENTIMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " centimeter " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_DECIMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " decimeter " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_DECAMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " decameter " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_HECTOMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " hectometer " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_KILOMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilometer " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_MEGAMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " megameter " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_GIGAMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " gigameter " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_ANGSTROM ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " angstrom " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_MIL ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " mil " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_INCH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " inch " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_YARD ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " yard " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_FATHOM ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " fathom " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_ROD ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " rod " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_CHAIN_SURVEYOR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " chain (surveyor) " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_CHAIN_ENGINEER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " chain (engineer) " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_FURLONG ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " furlong " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_MILE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " mile " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_MILE_NAUTICAL ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " mile (nautical) " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_LEAGUE_LAND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " league (land) " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_LEAGUE_MARINE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " league (marine) " ) ;
end PUT ;
procedure PUT ( ITEM : LENGTH_LIGHT_YEAR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " light year " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilogram " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pound " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_POUND_TROY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pound (troy) " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_MILLIGRAM ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " milligram " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_GRAM ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " gram " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_GRAIN ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " grain " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_PENNYWEIGHT_TROY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pennyweight (troy) " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_CARAT_TROY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " carat (troy) " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_SCRUPLE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " scruple " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_DRAM_AVDP ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " dram (avdp.) " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_OUNCE_AVDP ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ounce " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_OUNCE_TROY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ounce (troy) " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_TON_SHORT ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ton (short) " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_TON_LONG ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ton (long) " ) ;
end PUT ;
procedure PUT ( ITEM : MASS_TON_METRIC ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ton (metric) " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " second " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_PICOSECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " picosecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_NANOSECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " nanosecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_MICROSECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " microsecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_MILLISECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " millisecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_CENTISECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " centisecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_KILOSECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilosecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_MEGASECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " megasecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_GIGASECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " gigasecond " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " minute " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_HOUR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " hour " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_DAY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " day " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_FORTNIGHT ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " fortnight " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_MONTH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " month " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_YEAR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " year " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_DECADE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " decade " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_CENTURY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " century " ) ;
end PUT ;
procedure PUT ( ITEM : TIME_MILLENNIA ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " millennia " ) ;
end PUT ;
procedure PUT ( ITEM : CHARGE_COULOMB ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " coulomb " ) ;
end PUT ;
procedure PUT ( ITEM : CHARGE_ELECTRON ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " charge (electron) " ) ;
end PUT ;
procedure PUT ( ITEM : CHARGE_FARADAY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " faraday " ) ;
end PUT ;
procedure PUT ( ITEM : CHARGE_AMPERE_HOURS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ampere hour " ) ;
end PUT ;
procedure PUT ( ITEM : LUMINOUS_INTENSITY_CANDLE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " candel " ) ;
end PUT ;
procedure PUT ( ITEM : TEMPERATURE_KELVIN ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " degree kelvin " ) ;
end PUT ;
procedure PUT ( ITEM : TEMPERATURE_CENTIGRADE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " degree centigrade " ) ;
end PUT ;
procedure PUT ( ITEM : TEMPERATURE_FARENHEIT ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " degree farenheit " ) ;
end PUT ;
procedure PUT ( ITEM : ANGLE_RADIAN ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " radian " ) ;
end PUT ;
procedure PUT ( ITEM : ANGLE_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " second (angle) " ) ;
end PUT ;
procedure PUT ( ITEM : ANGLE_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " minute ( angle) " ) ;
end PUT ;
procedure PUT ( ITEM : ANGLE_DEGREE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " degree (angle) " ) ;
end PUT ;
procedure PUT ( ITEM : ANGLE_REVOLUTION ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " revolution " ) ;
end PUT ;
procedure PUT ( ITEM : ANGLE_BAM ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " bam " ) ;
end PUT ;
procedure PUT ( ITEM : SOLID_ANGLE_STERADIAN ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " steradian " ) ;
end PUT ;
end PHYSICAL_UNITS_OUTPUT_BASIC ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_UNITS_MECHANICAL ; use PHYSICAL_UNITS_MECHANICAL ;
package PHYSICAL_UNITS_OUTPUT_MECHANICAL is
-- This package specification defines a simple PUT for Ada types for physical
-- quantities generally mechanical in nature.
--
-- Notice that there is not a procedure PUT defined for LENGTH_METER
-- or for that matter, any " subtype " defined in the package PHYSICAL_UNITS.
-- It is unnecessary and happens to be illegal ada.
procedure PUT ( ITEM : AREA_MKS ) ;
procedure PUT ( ITEM : AREA_ENGLISH ) ;
procedure PUT ( ITEM : AREA_SQUARE_CENTIMETER ) ;
procedure PUT ( ITEM : AREA_SQUARE_KILOMETER ) ;
procedure PUT ( ITEM : AREA_SQUARE_INCH ) ;
procedure PUT ( ITEM : AREA_SQUARE_YARD ) ;
procedure PUT ( ITEM : AREA_SQUARE_MILE ) ;
procedure PUT ( ITEM : AREA_ACRE ) ;
procedure PUT ( ITEM : AREA_CIRCULAR_MIL ) ;
procedure PUT ( ITEM : AREA_HECTARE ) ;
procedure PUT ( ITEM : AREA_TOWNSHIP ) ;
procedure PUT ( ITEM : VOLUME_MKS ) ;
procedure PUT ( ITEM : VOLUME_ENGLISH ) ;
procedure PUT ( ITEM : VOLUME_MILLILITER ) ;
procedure PUT ( ITEM : VOLUME_LITER ) ;
procedure PUT ( ITEM : VOLUME_KILOLITER ) ;
procedure PUT ( ITEM : VOLUME_CUBIC_CENTIMETER ) ;
procedure PUT ( ITEM : VOLUME_CUBIC_INCH ) ;
procedure PUT ( ITEM : VOLUME_CUBIC_YARD ) ;
procedure PUT ( ITEM : VOLUME_CUBIC_MILE ) ;
procedure PUT ( ITEM : VOLUME_TEASPOON ) ;
procedure PUT ( ITEM : VOLUME_TABLESPOON ) ;
procedure PUT ( ITEM : VOLUME_OUNCE_FLUID ) ;
procedure PUT ( ITEM : VOLUME_JIGGER ) ;
procedure PUT ( ITEM : VOLUME_CUP ) ;
procedure PUT ( ITEM : VOLUME_PINT_LIQUID ) ;
procedure PUT ( ITEM : VOLUME_QUART_LIQUID ) ;
procedure PUT ( ITEM : VOLUME_GALLON ) ;
procedure PUT ( ITEM : VOLUME_KEG ) ;
procedure PUT ( ITEM : VOLUME_BARREL ) ;
procedure PUT ( ITEM : VOLUME_PINT_DRY ) ;
procedure PUT ( ITEM : VOLUME_QUART_DRY ) ;
procedure PUT ( ITEM : VOLUME_PECK ) ;
procedure PUT ( ITEM : VOLUME_BUSHEL ) ;
procedure PUT ( ITEM : VOLUME_CORD ) ;
procedure PUT ( ITEM : VELOCITY_MKS ) ;
procedure PUT ( ITEM : VELOCITY_ENGLISH ) ;
procedure PUT ( ITEM : VELOCITY_CENTIMETER_PER_SECOND ) ;
procedure PUT ( ITEM : VELOCITY_KILOMETER_PER_HOUR ) ;
procedure PUT ( ITEM : VELOCITY_INCHES_PER_SECOND ) ;
procedure PUT ( ITEM : VELOCITY_MILE_PER_HOUR ) ;
procedure PUT ( ITEM : VELOCITY_MILES_PER_SECOND ) ;
procedure PUT ( ITEM : VELOCITY_INCHES_PER_MINUTE ) ;
procedure PUT ( ITEM : VELOCITY_FEET_PER_MINUTE ) ;
procedure PUT ( ITEM : VELOCITY_MILES_PER_HOUR ) ;
procedure PUT ( ITEM : VELOCITY_KNOTS ) ;
procedure PUT ( ITEM : VELOCITY_FURLONG_PER_FORTNIGHT ) ;
procedure PUT ( ITEM : ANGULAR_VELOCITY ) ;
procedure PUT ( ITEM : ANGULAR_VELOCITY_DEGREES_PER_SECOND ) ;
procedure PUT ( ITEM : ANGULAR_VELOCITY_REVOLUTIONS_PER_MINUTE ) ;
procedure PUT ( ITEM : ANGULAR_VELOCITY_REVOLUTIONS_PER_SECOND ) ;
procedure PUT ( ITEM : ACCELERATION_MKS ) ;
procedure PUT ( ITEM : ACCELERATION_ENGLISH ) ;
procedure PUT ( ITEM : ANGULAR_ACCELERATION ) ;
procedure PUT ( ITEM : ANGULAR_ACCELERATION_REVOLUTIONS_PER_MINUTE_SQUARED )
;
procedure PUT ( ITEM : FORCE_MKS ) ;
procedure PUT ( ITEM : FORCE_DYNE ) ;
procedure PUT ( ITEM : FORCE_ENGLISH ) ;
procedure PUT ( ITEM : ENERGY_MKS ) ;
procedure PUT ( ITEM : ENERGY_ERG ) ;
procedure PUT ( ITEM : ENERGY_GRAM_CALORIE ) ;
procedure PUT ( ITEM : ENERGY_KILOGRAM_CALORIE ) ;
procedure PUT ( ITEM : ENERGY_B_T_U ) ;
procedure PUT ( ITEM : ENERGY_FOOT_POUND ) ;
procedure PUT ( ITEM : ENERGY_KILOWATT_HOUR ) ;
procedure PUT ( ITEM : ENERGY_HORSEPOWER_HOUR ) ;
procedure PUT ( ITEM : POWER_MKS ) ;
procedure PUT ( ITEM : POWER_KILOGRAM_CALORIE_PER_SECOND ) ;
procedure PUT ( ITEM : POWER_KILOGRAN_CALORIE_PER_MINUTE ) ;
procedure PUT ( ITEM : POWER_HORSEPOWER_MECHANICAL ) ;
procedure PUT ( ITEM : POWER_HORSEPOWER_ELECTRICAL ) ;
procedure PUT ( ITEM : POWER_HORSEPOWER_METRIC ) ;
procedure PUT ( ITEM : POWER_HORSEPOWER_BOILER ) ;
procedure PUT ( ITEM : POWER_B_T_U_PER_MINUTE ) ;
procedure PUT ( ITEM : POWER_B_T_U_PER_HOUR ) ;
procedure PUT ( ITEM : POWER_FOOT_POUND_PER_MINUTE ) ;
procedure PUT ( ITEM : POWER_FOOT_POUND_PER_SECOND ) ;
procedure PUT ( ITEM : DENSITY_MKS ) ;
procedure PUT ( ITEM : DENSITY_ENGLISH ) ;
procedure PUT ( ITEM : FLOW_RATE_MKS ) ;
procedure PUT ( ITEM : FLOW_RATE_GALLON_PER_MINUTE ) ;
procedure PUT ( ITEM : FLOW_RATE_ENGLISH ) ;
procedure PUT ( ITEM : FLOW_RATE_CUBIC_FEET_PER_MINUTE ) ;
procedure PUT ( ITEM : PRESSURE_MKS ) ;
procedure PUT ( ITEM : PRESSURE_ENGLISH ) ;
procedure PUT ( ITEM : PRESSURE_TON_PER_SQUARE_FOOT ) ;
procedure PUT ( ITEM : PRESSURE_ATMOSPHERE_STANDARD ) ;
procedure PUT ( ITEM : PRESSURE_FEET_OF_WATER ) ;
procedure PUT ( ITEM : PRESSURE_INCHES_OF_MERCURY ) ;
procedure PUT ( ITEM : PRESSURE_MILLIMETER_OF_MERCURY ) ;
procedure PUT ( ITEM : PRESSURE_BAR ) ;
procedure PUT ( ITEM : PRESSURE_MILLIBAR ) ;
procedure PUT ( ITEM : PRESSURE_TORR ) ;
procedure PUT ( ITEM : MOMENTUM_MKS ) ;
procedure PUT ( ITEM : INERTIA_MKS ) ;
procedure PUT ( ITEM : MOMENT_OF_INERTIA_MKS ) ;
procedure PUT ( ITEM : KINEMATIC_VISCOSITY_MKS ) ;
procedure PUT ( ITEM : DYNAMIC_VISCOSITY_MKS ) ;
procedure PUT ( ITEM : LUMINOUS_FLUX_LUMEN ) ;
procedure PUT ( ITEM : ILLUMINATION_MKS ) ;
procedure PUT ( ITEM : LUMINANCE_MKS ) ;
procedure PUT ( ITEM : ENTROPY_MKS ) ;
procedure PUT ( ITEM : SPECIFIC_HEAT_B_T_U_PER_POUND_DEGREE_FARENHEIT ) ;
end PHYSICAL_UNITS_OUTPUT_MECHANICAL ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_REAL ; use PHYSICAL_REAL ;
with TEXT_IO ; use TEXT_IO ;
with LONG_FLT_IO ; use LONG_FLT_IO ;
package body PHYSICAL_UNITS_OUTPUT_MECHANICAL is
procedure PUT ( ITEM : AREA_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " square meter" ) ;
end PUT ;
procedure PUT ( ITEM : AREA_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " square foot " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_SQUARE_CENTIMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " square centimeter " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_SQUARE_KILOMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " square kilometer " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_SQUARE_INCH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " square inch " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_SQUARE_YARD ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " square yard " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_SQUARE_MILE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " square mile " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_ACRE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " acre " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_CIRCULAR_MIL ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " circular mil " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_HECTARE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " hectare " ) ;
end PUT ;
procedure PUT ( ITEM : AREA_TOWNSHIP ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " township " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic meter " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic foot " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_MILLILITER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " milliliter " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_LITER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " liter " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_KILOLITER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kiloliter " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_CUBIC_CENTIMETER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic centimeter " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_CUBIC_INCH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic inch " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_CUBIC_YARD ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic yard " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_CUBIC_MILE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic mile " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_TEASPOON ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " teaspoon " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_TABLESPOON ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " tablespoon " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_OUNCE_FLUID ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ounce (fluid) " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_JIGGER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " jigger " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_CUP ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cup " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_PINT_LIQUID ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pint (liquid) " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_QUART_LIQUID ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " quart (liquid) " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_GALLON ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " gallon " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_KEG ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " keg " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_BARREL ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " barrel " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_PINT_DRY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pint (dry) " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_QUART_DRY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " quart (dry) " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_PECK ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " peck " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_BUSHEL ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " bushel " ) ;
end PUT ;
procedure PUT ( ITEM : VOLUME_CORD ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cord " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " meter per second " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " foot per second " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_CENTIMETER_PER_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " centimeter per second " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_KILOMETER_PER_HOUR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilometer per hour " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_INCHES_PER_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " inches per second " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_MILE_PER_HOUR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " mile per hour " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_MILES_PER_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " miles per second " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_INCHES_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " inches per minute " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_FEET_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " feet per minute " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_MILES_PER_HOUR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " miles per hour " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_KNOTS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " knots " ) ;
end PUT ;
procedure PUT ( ITEM : VELOCITY_FURLONG_PER_FORTNIGHT ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " furlong per fortnight " ) ;
end PUT ;
procedure PUT ( ITEM : ANGULAR_VELOCITY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " radian per second " ) ;
end PUT ;
procedure PUT ( ITEM : ANGULAR_VELOCITY_DEGREES_PER_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " degrees per second " ) ;
end PUT ;
procedure PUT ( ITEM : ANGULAR_VELOCITY_REVOLUTIONS_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " revolutions per minute " ) ;
end PUT ;
procedure PUT ( ITEM : ANGULAR_VELOCITY_REVOLUTIONS_PER_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " revolutions per second " ) ;
end PUT ;
procedure PUT ( ITEM : ACCELERATION_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " meter per second squared " ) ;
end PUT ;
procedure PUT ( ITEM : ACCELERATION_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " foot per second squared " ) ;
end PUT ;
procedure PUT ( ITEM : ANGULAR_ACCELERATION ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " radians per second squared " ) ;
end PUT ;
procedure PUT ( ITEM : ANGULAR_ACCELERATION_REVOLUTIONS_PER_MINUTE_SQUARED )
is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " revolutions per minute squared " ) ;
end PUT ;
procedure PUT ( ITEM : FORCE_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " newton " ) ;
end PUT ;
procedure PUT ( ITEM : FORCE_DYNE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " dyne " ) ;
end PUT ;
procedure PUT ( ITEM : FORCE_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " poundal " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " joule " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_ERG ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " erg " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_GRAM_CALORIE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " gram calorie " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_KILOGRAM_CALORIE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilogram calorie " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_B_T_U ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " B.T.U. " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_FOOT_POUND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " foot pound " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_KILOWATT_HOUR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilowat hour " ) ;
end PUT ;
procedure PUT ( ITEM : ENERGY_HORSEPOWER_HOUR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " horsepower hour " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " watt " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_KILOGRAM_CALORIE_PER_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilogram calorie per second " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_KILOGRAN_CALORIE_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilogram calorie per minute " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_HORSEPOWER_MECHANICAL ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " horsepower (mechanical) " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_HORSEPOWER_ELECTRICAL ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " horsepower (electrical) " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_HORSEPOWER_METRIC ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " horsepower ( metric) " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_HORSEPOWER_BOILER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " horsepower (boiler) " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_B_T_U_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " B.T.U. per minute " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_B_T_U_PER_HOUR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " B.T.U. per hour " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_FOOT_POUND_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " foot pound per minute " ) ;
end PUT ;
procedure PUT ( ITEM : POWER_FOOT_POUND_PER_SECOND ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " foot pound per second " ) ;
end PUT ;
procedure PUT ( ITEM : DENSITY_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilogram per cubic meter " ) ;
end PUT ;
procedure PUT ( ITEM : DENSITY_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pound per cubic foot " ) ;
end PUT ;
procedure PUT ( ITEM : FLOW_RATE_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic meter per second " ) ;
end PUT ;
procedure PUT ( ITEM : FLOW_RATE_GALLON_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " gallon per minute " ) ;
end PUT ;
procedure PUT ( ITEM : FLOW_RATE_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic feet per second " ) ;
end PUT ;
procedure PUT ( ITEM : FLOW_RATE_CUBIC_FEET_PER_MINUTE ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " cubic feet per minute " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pascal " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_ENGLISH ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " pound per square foot " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_TON_PER_SQUARE_FOOT ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " ton per square foot " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_ATMOSPHERE_STANDARD ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " atmosphere " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_FEET_OF_WATER ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " feet of water " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_INCHES_OF_MERCURY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " inches of mercury " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_MILLIMETER_OF_MERCURY ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " millimeter of mercury " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_BAR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " bar " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_MILLIBAR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " millibar " ) ;
end PUT ;
procedure PUT ( ITEM : PRESSURE_TORR ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " torr " ) ;
end PUT ;
procedure PUT ( ITEM : MOMENTUM_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " newton per second " ) ;
end PUT ;
procedure PUT ( ITEM : INERTIA_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " joule second " ) ;
end PUT ;
procedure PUT ( ITEM : MOMENT_OF_INERTIA_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " kilogram meter squared " ) ;
end PUT ;
procedure PUT ( ITEM : KINEMATIC_VISCOSITY_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " meter squared per second " ) ;
end PUT ;
procedure PUT ( ITEM : DYNAMIC_VISCOSITY_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " newton second per square meter " ) ;
end PUT ;
procedure PUT ( ITEM : LUMINOUS_FLUX_LUMEN ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " lumen " ) ;
end PUT ;
procedure PUT ( ITEM : ILLUMINATION_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " lumen per square meter " ) ;
end PUT ;
procedure PUT ( ITEM : LUMINANCE_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " lux " ) ;
end PUT ;
procedure PUT ( ITEM : ENTROPY_MKS ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " joule per degree centegrade " ) ;
end PUT ;
procedure PUT ( ITEM : SPECIFIC_HEAT_B_T_U_PER_POUND_DEGREE_FARENHEIT ) is
begin
PUT ( UNDIMENSION( ITEM )) ;
PUT ( " B.T.U. per pound degree farenheit " ) ;
end PUT ;
end PHYSICAL_UNITS_OUTPUT_MECHANICAL ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
with PHYSICAL_UNITS_BASIC ; use PHYSICAL_UNITS_BASIC ;
with PHYSICAL_UNITS_MECHANICAL ; use PHYSICAL_UNITS_MECHANICAL ;
with PHYSICAL_UNITS_OTHER ; use PHYSICAL_UNITS_OTHER ;
-- This package defines operators needed to evaluate equations of
-- physics using dimensional and units checking. Only MKS units
-- are used. A conversion package is available to convert from
-- other metric units and English units to the MKS units.
--
-- This package is not complete. Completeness would imply all
-- possible operators that combine physical dimensions and yeild
-- other physical dimensions. Users can provide local definitions
-- or this package can be augmented.
--
package MKS_PHYSICS_MECHANICAL is
function "*" ( LEFT , RIGHT : LENGTH_MKS ) return AREA_MKS ;
function SQRT ( LEFT : AREA_MKS ) return LENGTH_MKS ;
function "**" ( LEFT : LENGTH_MKS ;
RIGHT : INTEGER ) return AREA_MKS ;
function "**" ( LEFT : LENGTH_MKS ;
RIGHT : INTEGER ) return VOLUME_MKS ;
function "*" ( LEFT : AREA_MKS ;
RIGHT : LENGTH_MKS ) return VOLUME_MKS ;
function "*" ( LEFT : LENGTH_MKS ;
RIGHT : AREA_MKS ) return VOLUME_MKS ;
function CUBE_ROOT ( LEFT : VOLUME_MKS ) return LENGTH_MKS ;
function "/" ( LEFT : VOLUME_MKS ;
RIGHT : LENGTH_MKS ) return AREA_MKS ;
function "/" ( LEFT : LENGTH_MKS ;
RIGHT : TIME_SECOND ) return VELOCITY_MKS ;
function "/" ( LEFT : LENGTH_MKS ;
RIGHT : TIME_SECOND_SQUARED ) return ACCELERATION_MKS ;
function "*" ( LEFT , RIGHT : TIME_SECOND ) return TIME_SECOND_SQUARED ;
function "**" ( LEFT : TIME_SECOND ;
RIGHT : INTEGER ) return TIME_SECOND_SQUARED ;
function "**" ( LEFT : VELOCITY_MKS ;
RIGHT : INTEGER ) return VELOCITY_SQUARED_MKS ;
function SQRT ( LEFT : TIME_SECOND_SQUARED ) return TIME_SECOND ;
function "*" ( LEFT , RIGHT : VELOCITY_MKS ) return VELOCITY_SQUARED_MKS ;
function SQRT ( LEFT : VELOCITY_SQUARED_MKS ) return VELOCITY_MKS ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : TIME_SECOND_SQUARED ) return LENGTH_MKS ;
function "/" ( LEFT : LENGTH_MKS ;
RIGHT : ACCELERATION_MKS ) return TIME_SECOND_SQUARED ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : LENGTH_MKS ) return VELOCITY_SQUARED_MKS ;
function "*" ( LEFT : LENGTH_MKS ;
RIGHT : ACCELERATION_MKS ) return VELOCITY_SQUARED_MKS ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : TIME_SECOND ) return VELOCITY_MKS ;
function "*" ( LEFT : TIME_SECOND ;
RIGHT : ACCELERATION_MKS ) return VELOCITY_MKS ;
function "*" ( LEFT : MASS_MKS ;
RIGHT : ACCELERATION_MKS ) return FORCE_MKS ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : MASS_MKS ) return FORCE_MKS ;
function "*" ( LEFT : PRESSURE_MKS ;
RIGHT : AREA_MKS ) return FORCE_MKS ;
function "*" ( LEFT : AREA_MKS ;
RIGHT : PRESSURE_MKS ) return FORCE_MKS ;
function "/" ( LEFT : POWER_MKS ;
RIGHT : VELOCITY_MKS ) return FORCE_MKS ;
function "/" ( LEFT : ENERGY_MKS ;
RIGHT : LENGTH_MKS ) return FORCE_MKS ;
function "*" ( LEFT : PRESSURE_MKS ;
RIGHT : VOLUME_MKS ) return ENERGY_MKS ;
function "*" ( LEFT : VOLUME_MKS ;
RIGHT : PRESSURE_MKS ) return ENERGY_MKS ;
function "*" ( LEFT : FORCE_MKS ;
RIGHT : LENGTH_MKS ) return ENERGY_MKS ;
function "*" ( LEFT : LENGTH_MKS ;
RIGHT : FORCE_MKS ) return ENERGY_MKS ;
function "*" ( LEFT : MASS_MKS ;
RIGHT : VELOCITY_SQUARED_MKS ) return ENERGY_MKS ;
function "*" ( LEFT : VELOCITY_SQUARED_MKS ;
RIGHT : MASS_MKS ) return ENERGY_MKS ;
function "*" ( LEFT : POWER_MKS ;
RIGHT : TIME_SECOND ) return ENERGY_MKS ;
function "*" ( LEFT : TIME_SECOND ;
RIGHT : POWER_MKS ) return ENERGY_MKS ;
function "*" ( LEFT : FORCE_MKS ;
RIGHT : VELOCITY_MKS ) return POWER_MKS ;
function "*" ( LEFT : VELOCITY_MKS ;
RIGHT : FORCE_MKS ) return POWER_MKS ;
function "/" ( LEFT : ENERGY_MKS ;
RIGHT : TIME_SECOND ) return POWER_MKS ;
pragma INLINE ( "*", "/" , "**", SQRT ) ;
end MKS_PHYSICS_MECHANICAL ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- with LONG_REFUNCT; use LONG_REFUNCT; --Alstad
with PHYSICAL_REAL ; use PHYSICAL_REAL ;
package body MKS_PHYSICS_MECHANICAL is
function "*" ( LEFT , RIGHT : LENGTH_MKS ) return AREA_MKS is
begin
return AREA_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function SQRT ( LEFT : AREA_MKS ) return LENGTH_MKS is
begin
return LENGTH_MKS' ( DIMENSION( SQRT( UNDIMENSION( LEFT )))) ;
end SQRT ;
function "**" ( LEFT : LENGTH_MKS ;
RIGHT : INTEGER ) return AREA_MKS is
begin
if RIGHT /= 2 then
raise NUMERIC_ERROR ;
end if ;
return AREA_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( LEFT ))) ;
end "**" ;
function "**" ( LEFT : LENGTH_MKS ;
RIGHT : INTEGER ) return VOLUME_MKS is
begin
if RIGHT /= 3 then
raise NUMERIC_ERROR ;
end if ;
return VOLUME_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( LEFT ) * UNDIMENSION
( LEFT ))) ;
end "**" ;
function "*" ( LEFT : AREA_MKS ;
RIGHT : LENGTH_MKS ) return VOLUME_MKS is
begin
return VOLUME_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : LENGTH_MKS ;
RIGHT : AREA_MKS ) return VOLUME_MKS is
begin
return VOLUME_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function CUBE_ROOT ( LEFT : VOLUME_MKS ) return LENGTH_MKS is
begin
return LENGTH_MKS' ( DIMENSION( CUBE_ROOT( UNDIMENSION( LEFT )))); --Alstad
end CUBE_ROOT ;
function "/" ( LEFT : VOLUME_MKS ;
RIGHT : LENGTH_MKS ) return AREA_MKS is
begin
return AREA_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) / UNDIMENSION ( RIGHT ))) ;
end "/" ;
function "/" ( LEFT : LENGTH_MKS ;
RIGHT : TIME_SECOND ) return VELOCITY_MKS is
begin
return VELOCITY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) / UNDIMENSION ( RIGHT ))) ;
end "/" ;
function "/" ( LEFT : LENGTH_MKS ;
RIGHT : TIME_SECOND_SQUARED ) return ACCELERATION_MKS is
begin
return ACCELERATION_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) / UNDIMENSION ( RIGHT ))) ;
end "/" ;
function "*" ( LEFT , RIGHT : TIME_SECOND ) return TIME_SECOND_SQUARED is
begin
return TIME_SECOND_SQUARED' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "**" ( LEFT : TIME_SECOND ;
RIGHT : INTEGER ) return TIME_SECOND_SQUARED is
begin
if RIGHT /= 2 then
raise NUMERIC_ERROR ;
end if ;
return TIME_SECOND_SQUARED' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( LEFT ))) ;
end "**" ;
function "**" ( LEFT : VELOCITY_MKS ;
RIGHT : INTEGER ) return VELOCITY_SQUARED_MKS is
begin
if RIGHT /= 2 then
raise NUMERIC_ERROR ;
end if ;
return VELOCITY_SQUARED_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( LEFT ))) ;
end "**" ;
function SQRT ( LEFT : TIME_SECOND_SQUARED ) return TIME_SECOND is
begin
return TIME_SECOND' ( DIMENSION( SQRT( UNDIMENSION( LEFT )))) ;
end SQRT ;
function "*" ( LEFT , RIGHT : VELOCITY_MKS ) return VELOCITY_SQUARED_MKS is
begin
return VELOCITY_SQUARED_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function SQRT ( LEFT : VELOCITY_SQUARED_MKS ) return VELOCITY_MKS is
begin
return VELOCITY_MKS' ( DIMENSION( SQRT( UNDIMENSION( LEFT )))) ;
end SQRT ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : TIME_SECOND_SQUARED ) return LENGTH_MKS is
begin
return LENGTH_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "/" ( LEFT : LENGTH_MKS ;
RIGHT : ACCELERATION_MKS ) return TIME_SECOND_SQUARED is
begin
return TIME_SECOND_SQUARED' --
( DIMENSION( UNDIMENSION( LEFT ) / UNDIMENSION ( RIGHT ))) ;
end "/" ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : LENGTH_MKS ) return VELOCITY_SQUARED_MKS is
begin
return VELOCITY_SQUARED_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : LENGTH_MKS ;
RIGHT : ACCELERATION_MKS ) return VELOCITY_SQUARED_MKS is
begin
return VELOCITY_SQUARED_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : TIME_SECOND ) return VELOCITY_MKS is
begin
return VELOCITY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : TIME_SECOND ;
RIGHT : ACCELERATION_MKS ) return VELOCITY_MKS is
begin
return VELOCITY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : MASS_MKS ;
RIGHT : ACCELERATION_MKS ) return FORCE_MKS is
begin
return FORCE_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : ACCELERATION_MKS ;
RIGHT : MASS_MKS ) return FORCE_MKS is
begin
return FORCE_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : PRESSURE_MKS ;
RIGHT : AREA_MKS ) return FORCE_MKS is
begin
return FORCE_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : AREA_MKS ;
RIGHT : PRESSURE_MKS ) return FORCE_MKS is
begin
return FORCE_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "/" ( LEFT : POWER_MKS ;
RIGHT : VELOCITY_MKS ) return FORCE_MKS is
begin
return FORCE_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) / UNDIMENSION ( RIGHT ))) ;
end "/" ;
function "/" ( LEFT : ENERGY_MKS ;
RIGHT : LENGTH_MKS ) return FORCE_MKS is
begin
return FORCE_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) / UNDIMENSION ( RIGHT ))) ;
end "/" ;
function "*" ( LEFT : PRESSURE_MKS ;
RIGHT : VOLUME_MKS ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : VOLUME_MKS ;
RIGHT : PRESSURE_MKS ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : FORCE_MKS ;
RIGHT : LENGTH_MKS ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : LENGTH_MKS ;
RIGHT : FORCE_MKS ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : MASS_MKS ;
RIGHT : VELOCITY_SQUARED_MKS ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : VELOCITY_SQUARED_MKS ;
RIGHT : MASS_MKS ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : POWER_MKS ;
RIGHT : TIME_SECOND ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : TIME_SECOND ;
RIGHT : POWER_MKS ) return ENERGY_MKS is
begin
return ENERGY_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : FORCE_MKS ;
RIGHT : VELOCITY_MKS ) return POWER_MKS is
begin
return POWER_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "*" ( LEFT : VELOCITY_MKS ;
RIGHT : FORCE_MKS ) return POWER_MKS is
begin
return POWER_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) * UNDIMENSION ( RIGHT ))) ;
end "*" ;
function "/" ( LEFT : ENERGY_MKS ;
RIGHT : TIME_SECOND ) return POWER_MKS is
begin
return POWER_MKS' --
( DIMENSION( UNDIMENSION( LEFT ) / UNDIMENSION ( RIGHT ))) ;
end "/" ;
end MKS_PHYSICS_MECHANICAL ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- This procedure solves a few physics problems involving
-- time, distance, vecocity and acceleration. All units are
-- in the MKS system of units. Note that all "put" calls
-- on physical quantities are to be printed as the value followed
-- by the unit.
--
-- make available types for physical units
with PHYSICAL_UNITS_BASIC ; use PHYSICAL_UNITS_BASIC ;
with PHYSICAL_UNITS_MECHANICAL ; use PHYSICAL_UNITS_MECHANICAL ;
with PHYSICAL_UNITS_OTHER ; use PHYSICAL_UNITS_OTHER ;
-- make available operations on MKS types
with MKS_PHYSICS_MECHANICAL ; use MKS_PHYSICS_MECHANICAL ;
-- make PUT available for physical units types
with PHYSICAL_UNITS_OUTPUT_BASIC ; use PHYSICAL_UNITS_OUTPUT_BASIC ;
with PHYSICAL_UNITS_OUTPUT_MECHANICAL ; use PHYSICAL_UNITS_OUTPUT_MECHANICAL ;
--
with TEXT_IO ; use TEXT_IO ;
procedure PHYSICS_1 is
-- define acceleration due to gravity
G : ACCELERATION_MKS := DIMENSION ( 9.80665 ) ;
FALL : DISTANCE_METER ;
FALL_TIME : TIME_SECOND ;
V_FINAL : VELOCITY_METER_PER_SECOND ;
begin
PUT ( " Test printout and value of acceleration, " ) ;
PUT ( G ) ;
PUT_LINE ( " = G " ) ;
-- How far will Ball_1 fall in 1.5 second in earths gravity ?
FALL := 0.5 * G * TIME_SECOND' ( DIMENSION( 1.5 )) ** 2 ;
PUT ( FALL ) ;
NEW_LINE ;
-- Cross check that the time for the ball to fall is 1.5 seconds.
FALL_TIME := SQRT ( 2.0 * FALL / G ) ;
PUT ( FALL_TIME ) ;
NEW_LINE ;
-- Now determine the final velocity if the ball falls another 0.2 meter
-- Method : square root of initial velocity squared plus twice
-- the acceleration times the distance
V_FINAL := SQRT (( G * FALL_TIME ) ** 2 + 2.0 * G * FALL) ;
PUT ( V_FINAL ) ;
NEW_LINE ;
end PHYSICS_1 ;
------- End of Forwarded Message
------- End of Forwarded Message
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
----------------------------------------------------------------------
--
-- PRODUCER / CONSUMER TASKING BENCHMARK
--
-- Version: @(#)conprod.ada 1.3 Date: 6/20/84
--
-- Gerry Fisher
-- Computer Sciences Corporation
-- May 27, 1984
--
-- This benchmark tests tasking performance using the buffering task
-- given as an example in chapter 9.12 of the Ada RM. The consumer
-- task is the main program itself; the producer and buffer tasks
-- are declared as tasks within it. During execution each "write"
-- entry call produces a "." on the standard output file, while each
-- "read" call produces a "*". When all the produced data has been
-- consumed a check is made to see that the data has arrived in the
-- correct order and that no data remains buffered within the buffer
-- task.
--
----------------------------------------------------------------------
with text_io; use text_io;
procedure main is
all_there : boolean;
begin
set_line_length(50);
put_line("*** Producer/Consumer Task Test");
declare
x : array(character) of character := (others => ' ');
pool_size : constant integer := 5;
pool : array(1 .. pool_size) of character;
count : integer range 0 .. pool_size := 0;
task buffer is
entry read (c : out character);
entry write(c : in character);
end buffer;
task producer;
task body producer is
begin
for c in character loop
buffer.write(c);
end loop;
end producer;
task body buffer is
in_index, out_index : integer range 1 .. pool_size := 1;
begin
loop
select
when count < pool_size =>
accept write(c : in character) do
pool(in_index) := c;
end write;
put('.');
in_index := in_index mod pool_size + 1;
count := count + 1;
or when count > 0 =>
accept read(c : out character) do
c := pool(out_index);
end read;
put('*');
out_index := out_index mod pool_size + 1;
count := count - 1;
or
terminate;
end select;
end loop;
end buffer;
function Is_ok return boolean is
begin
for i in x'range loop
if x(i) /= i then return false; end if;
end loop;
return true;
end Is_ok;
begin
for i in x'range loop
buffer.read(x(i));
end loop;
all_there := Is_ok;
end;
new_line;
if all_there then
put_line("*** PASSED Producer/Consumer Task Test");
else
put_line("*** FAILED Producer/Consumer Task Test");
end if;
end main;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
--
-- Version: @(#)derived.ada 1.2 Date: 7/2/84
--
-- Author: Bryce Bardin
-- Ada Projects Section
-- Software Engineering Division
-- Ground Systems Group
-- Hughes Aircraft Company
-- Fullerton, CA
--
-- This program tests the inter-conversion of derived types with
-- different representations. An approriate message is output to
-- indicate "pass" or "fail".
--
--
-- Define the original types:
with Text_IO; use Text_IO;
package Originals is
type Bit is range 0 .. 1;
type Bit_String is array (Positive range <>) of Bit;
subtype Word is Bit_String (1 .. 16);
type Byte is range 0 .. 255;
type Block is
record
First : Byte;
Second : Word;
Third : Byte;
end record;
package Byte_IO is new Integer_IO (Byte);
use Byte_IO;
procedure Put (B : Block);
end Originals;
package body Originals is
procedure Put (B : Block) is
S : String (1 .. Word'Length);
begin
Put("First = ");
Put(B.First);
for N in 1 .. Word'Length loop
if B.Second(N) = 0 then
S(N) := '0';
else
S(N) := '1';
end if;
end loop;
Put(", Second = ");
Put(S);
Put(", Third = ");
Put(B.Third);
Put_Line(".");
end Put;
end Originals;
-- Define the derived types:
with Originals; use Originals;
with System;
package Deriveds is
type New_Block is new Block;
for New_Block use
record at mod System.Storage_Unit;
First at 0 range 0 .. 7;
Second at 0 range 8 .. 23;
Third at 0 range 24 .. 31;
end record;
for New_Block'Size use 32;
end Deriveds;
-- Test conversion from derived to original types and vice versa.
with Originals; use Originals;
with Deriveds; use Deriveds;
with Text_IO; use Text_IO;
procedure Change_Representation is
Original : Block := (First => 85,
Second => (1 .. 8 => 1, 9 .. 16 => 0),
Third => 170);
Derived : New_Block := New_Block(Original);
Copy : Block := Block(Derived);
package Int_IO is new Integer_IO(Integer);
use Int_IO;
begin
Put_Line("Original:");
Put(Original);
New_Line;
Put("Size = ");
Put(Original'Size);
Put_Line(" bits");
New_Line;
Put_Line("Derived:");
Put(Derived);
New_Line;
Put("Size = ");
Put(Derived'Size);
Put_Line(" bits");
New_Line;
Put_Line("Copy:");
Put(Copy);
New_Line(2);
if Copy = Original and Derived'Size = 32 then
Put_Line("TEST PASSED!");
else
Put_Line("** TEST FAILED! **");
end if;
end Change_Representation;
-------------------------------------------------------------------
--------------------- 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.3 Date: 10/19/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);
--
-- C.Stop;
--
-- and writers should do:
--
-- C.Start(Write);
--
-- 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;
-------------------------------------------------------------------
--------------------- Next Program -----------------------------
-------------------------------------------------------------------
------------------------------------------------------------------------
--
--
--
-- U N I V E R S A L A R I T H M E T I C P A C K A G E S
--
-- Version: @(#)univ_ar.ada 1.1 Date: 5/30/84
--
-- written by
--
-- Gerry Fisher
-- Computer Sciences Corporation
-- 4045 Hancock Street
-- San Diego, CA 92110
--
--
--
-- The packages UNIVERSAL_INTEGER_ARITHMETIC and UNIVERSAL_REAL_ARITHMETIC,
-- implement the arithmetic operations for the Ada* universal_integer and
-- universal_real types. Unlimited precision arithmetic is used for the
-- universal_integer type and rational arithmetic for the universal_real
-- type. The implementation is based on the universal arithmetic package
-- written in SETL by Robert Dewar for the NYU Ada/Ed compiler, and was
-- coded in part while the author worked at TeleSoft.
--
-- The implementation presented here is not the most efficient. It is,
-- however, quite general and requires no low level facilities. With some
-- tuning these packages could be used within an Ada compiler to evaluate
-- static expressions. They also provide an excellent example of the use
-- of Ada packages to support an abstract data type.
--
-- * Ada is a registered trademark of the DoD (Ada Joint Program Office)
--
------------------------------------------------------------------------
package UNIVERSAL_INTEGER_ARITHMETIC is
-- This package implements the Ada type Universal_integer.
-- The operations defined on universal integers are those specified in
-- chapter 4 of the RM. Since the equality and inequality operators can
-- not be overloaded, an equality operation is defined. In addition,
-- conversions between INTEGER, STRING and Universal_integer are defined.
type Universal_integer is private;
function "+" (x, y : Universal_integer) return Universal_integer;
function "-" (x, y : Universal_integer) return Universal_integer;
function "*" (x, y : Universal_integer) return Universal_integer;
function "/" (x, y : Universal_integer) return Universal_integer;
function "mod"(x, y : Universal_integer) return Universal_integer;
function "rem"(x, y : Universal_integer) return Universal_integer;
function "**" (x : Universal_integer; y : INTEGER) return Universal_integer;
function "-" (x : Universal_integer) return Universal_integer;
function "abs"(x : Universal_integer) return Universal_integer;
function ">=" (x, y : Universal_integer) return boolean;
function ">" (x, y : Universal_integer) return boolean;
function "<=" (x, y : Universal_integer) return boolean;
function "<" (x, y : Universal_integer) return boolean;
function eql (x, y : Universal_integer) return boolean;
function Int(x : Universal_integer) return INTEGER;
-- Converts a universal integer to a integer. The exception
-- NUMERIC_ERROR is raised if the universal integer x has a value
-- outside the integer range.
function UI(i : INTEGER) return Universal_integer;
-- Constructs a universal integer from an integer.
function IMAGE(x : Universal_integer) return STRING;
-- Converts the universal integer x into its string image, that is, a
-- sequence of characters representing the value in display form. The
-- image of a universal integer value is the corresponding decimal
-- literal; without underlines, leading zeros, exponent or trailing spaces;
-- but with a single leading minus sign or space. The lower bound of the
-- image string is one.
function VALUE(s : STRING) return Universal_integer;
-- Converts the string s into a universal integer value. The string must have
-- the syntax of an optionally signed decimal integer literal; otherwise, the
-- exception CONSTRAINT_ERROR is raised. The exponent of the decimal literal,
-- if present, must not exceed INTEGER'LAST.
private
type VECTOR;
type Universal_integer is access VECTOR;
end UNIVERSAL_INTEGER_ARITHMETIC;
package body UNIVERSAL_INTEGER_ARITHMETIC is
-- A universal integer consists of a sign and a magnitude. The
-- magnitude is a vector of non-negative integers giving from
-- most significant to least significant the "digits" of the
-- number in some convenient base. There are no leading zero digits,
-- unless the value is zero. Universal integers are always normalized.
-- The lower bound of the universal integer vector is always one.
-- Thus, the magnitude for the vector V(1 .. k) is given by:
--
-- V(1) * BASE**(k - 1) + V(2) * BASE**(k - 2) + ... + V(k)
--
-- The maximum number of digits in a universal integer is limited
-- in this implementation only by the amount of available memory.
--
-- The base is 10 ** ((INTEGER'WIDTH - 2) / 2). The universal digits are
-- integers in the range 0 .. BASE - 1. This choice of BASE means that
-- slightly less than half of the integer range is used. However, the
-- choice does ensure that the product of two universal digits is an integer.
-- Also, the number of universal digits required to represent an integer value
-- as a universal integer is at most four.
--
-- To complete the representation the high order universal digit has the sign
-- of the universal integer.
BASE_D : constant := (INTEGER'WIDTH - 2) / 2;
BASE : constant := 10 ** BASE_D;
BASE_SQ : constant := BASE * BASE;
INT_D : constant := 4;
type VECTOR is array(POSITIVE range <>) of INTEGER;
i_zero : constant Universal_integer := new VECTOR'(1 => 0);
i_one : constant Universal_integer := new VECTOR'(1 => 1);
i_two : constant Universal_integer := new VECTOR'(1 => 2);
i_ten : constant Universal_integer := new VECTOR'(1 => 10);
function UI(v : VECTOR; s : BOOLEAN := FALSE) return Universal_integer is
-- Constructs a universal integer from a vector and a sign; the vector
-- need not be normalized. The boolean s is true if the number is negative.
t : Universal_integer;
begin
-- The representation used in this package requires that all
-- Universal_integer values be normalized. The first digit of any
-- value, except zero, must be non-zero.
for j in v'range loop
if v(j) /= 0 then
t := new VECTOR(1 .. v'last - j + 1); -- ensure lower bound of one
t.all := v(j .. v'last);
if s then t(1) := - t(1); end if;
return t;
end if;
end loop;
return i_zero;
end UI;
function UI(i : INTEGER) return Universal_integer is
y : VECTOR(1 .. INT_D) := (1 .. INT_D => 0);
z : INTEGER;
begin
if i < BASE and then i > - BASE then
return new VECTOR'(1 => i);
end if;
z := i;
for j in reverse y'range
loop
y(j) := abs(z rem BASE);
z := z / BASE;
end loop;
return UI(y, i < 0);
end UI;
function Int(x : Universal_integer) return INTEGER is
y : INTEGER;
begin
if x'length = 1 then
return x(1);
end if;
y := 0;
for i in x'range loop -- convert as a negative integer
y := y * BASE - abs x(i); -- this may raise NUMERIC_ERROR, but
end loop; -- only if the magnitude of x is too large.
if x(1) < 0 then
return y;
else
return - y; -- this may raise NUMERIC_ERROR if x is
end if; -- -(integer'first) and range is not symmetric.
end Int;
function IMAGE(x : Universal_integer) return STRING is
m : integer := x'length * BASE_D + 1;
s : string(1 .. m);
y : Universal_integer;
j, d : integer;
begin
if x(1) = 0 then
return " 0";
end if;
j := m;
y := abs x;
while y(1) /= 0 loop
d := Int(y rem i_ten);
y := y / i_ten;
s(j) := character'val(character'pos('0') + d);
j := j - 1;
end loop;
if x(1) < 0 then
s(j) := '-';
else
s(j) := ' ';
end if;
d := m - j + 1;
s(1 .. d) := s(j .. m);
return s(1 .. d);
end IMAGE;
function VALUE(s : STRING) return Universal_integer is
num : Universal_integer := i_zero;
exp : integer := 0;
signed : boolean := false;
has_exp: boolean := false;
c : character;
j : integer;
begin
if s'length = 0 then
raise CONSTRAINT_ERROR;
end if;
j := s'first;
c := s(j);
if c = '-' or else c = '+' then
j := j + 1;
if s(j) not in '0' .. '9' then -- index out of range may also raise
raise CONSTRAINT_ERROR; -- constraint_error here
end if;
signed := c = '-';
end if;
while j <= s'last loop
c := s(j);
case c is
when '0' .. '9' =>
if has_exp then
exp := exp * 10 + (character'pos(c) - character'pos('0'));
else
num := num * i_ten + UI(character'pos(c) - character'pos('0'));
end if;
when '_' =>
if s(j - 1) not in '0' .. '9' or else s(j + 1) not in '0' .. '9' then
raise CONSTRAINT_ERROR;
end if;
when 'E' | 'e' =>
if has_exp or else s(j - 1) not in '0' .. '9' then
raise CONSTRAINT_ERROR;
end if;
has_exp := true;
if s(j + 1) = '+' then j := j + 1; end if;
if s(j + 1) not in '0' .. '9' then
raise CONSTRAINT_ERROR;
end if;
when others =>
raise CONSTRAINT_ERROR;
end case;
j := j + 1;
end loop;
if has_exp then num := num * i_ten ** exp; end if;
if signed then num := - num; end if;
return num;
end VALUE;
function "-" (x : Universal_integer) return Universal_integer is
begin
return new VECTOR'(- x(1) & x(2 .. x'last));
end "-";
function "abs" (x : Universal_integer) return Universal_integer is
begin
return new VECTOR'(abs x(1) & x(2 .. x'last));
end "abs";
function "+" (x, y : Universal_integer) return Universal_integer is
m : integer;
k, r : integer;
xl, yl : integer;
xs, ys : boolean;
begin
xl := x'length;
yl := y'length;
if xl = 1 and then yl = 1 then -- each has one digit
return UI(x(1) + y(1));
else -- either or both operands have > 1 digits
if xl < yl then
m := yl + 1;
else
m := xl + 1;
end if;
declare
u, v : VECTOR(1 .. m);
begin
xs := x(1) < 0;
ys := y(1) < 0;
u := (1 .. m - xl => 0) & abs x(1) & x(2 .. xl);
v := (1 .. m - yl => 0) & abs y(1) & y(2 .. yl);
if xs = ys then -- signs agree so add
k := 0;
for i in reverse 1 .. m loop
r := u(i) + v(i) + k;
if r >= BASE then
r := r - BASE;
k := 1;
else
k := 0;
end if;
u(i) := r;
end loop;
return UI(u, xs);
else
-- signs different, subtract smaller from larger
k := 0;
for i in reverse 1 .. m loop
r := u(i) - v(i) + k;
if r < 0 then
r := r + BASE;
k := - 1;
else
k := 0;
end if;
u(i) := r;
end loop;
if k = 0 then -- x has the larger magnitude
return UI(u, xs);
else -- y has the larger magnitude, so recomplement
k := 1;
for i in reverse 1 .. m loop
r := BASE - 1 - u(i) + k;
if r = BASE then
r := 0;
k := 1;
else
k := 0;
end if;
u(i) := r;
end loop;
return UI(u, ys);
end if;
end if;
end;
end if;
end "+";
function "-" (x, y : Universal_integer) return Universal_integer is
begin
return x + (- y);
end "-";
function "*" (x, y : Universal_integer) return Universal_integer is
-- This function returns the product of the universal integers x
-- and y using essentially the familiar hand algorithm.
xl, yl : integer;
begin
xl := x'length;
yl := y'length;
if xl = 1 and yl = 1 then -- both have a single digit
return UI(x(1) * y(1));
end if;
declare
w : VECTOR(1 .. xl + yl) := (1 .. xl + yl => 0);
k, r : integer;
begin
for j in reverse y'range loop
-- outer loop through digits of the multiplier, inner loop
-- through digits of multiplicand
k := 0;
for i in reverse x'range loop
r := abs(x(i) * y(j)) + w(i + j) + k;
w(i + j) := r rem BASE;
k := r / BASE;
end loop;
w(j) := k;
end loop;
return UI(w, (x(1) < 0) xor (y(1) < 0));
end;
end "*";
function "/" (x, y : Universal_integer) return Universal_integer is
m : integer;
xl, yl : integer;
e : integer;
d, r, t : integer;
qe : integer; -- quotient digit estimate
v1, v2 : integer;
begin
xl := x'length;
yl := y'length;
if xl = 1 and then yl = 1 then -- can use simple integer division
return UI(x(1) / y(1)); -- integer divide catches zero divisor
elsif xl < yl then -- divisor has more digits
return i_zero;
elsif yl = 1 then -- divisor has single digit
-- dividend has more than one digit,
-- important special case for which
-- an efficient algorithm is used
r := 0;
v1 := abs y(1);
if v1 = 0 then -- divisor is zero
raise NUMERIC_ERROR;
end if;
declare
q : VECTOR(1 .. xl);
begin
for j in x'range loop
t := r * BASE + abs x(j);
q(j) := t / v1;
r := t rem v1;
end loop;
return UI(q, (x(1) < 0) xor (y(1) < 0));
end;
end if;
-- At this point the length of the dividend is at least two and
-- at least as much as the length of the divisor. We must do a
-- full long division. The algorithm used here is from Knuth,
-- "The Art of Programming", Volume 2, Section 4.3.1, Algorithm D.
-- The first step is to multiply both the divisor and dividend
-- by a scale factor to ensure that the first digit of the divisor
-- is at least BASE / 2. This condition is required by the
-- quotient digit estimation algorithm used in the division loop.
-- Note that this may increase the size of the dividend by one digit
-- and thus the scaled dividend is placed in u.
m := xl - yl + 1;
declare
u : VECTOR(1 .. xl + 1); -- the dividend
v : VECTOR(1 .. yl); -- the divisor
q : VECTOR(1 .. m); -- the quotient
begin
u := 0 & abs x(1) & x(2 .. xl);
v := abs y(1) & y(2 .. yl);
v1 := v(1);
d := BASE / (v1 + 1); -- scale factor
if d > 1 then -- scale dividend and divisor
r := 0;
for j in reverse u'range loop
t := u(j) * d + r;
u(j) := t rem BASE;
r := t / BASE;
end loop;
r := 0;
for j in reverse v'range loop
t := v(j) * d + r;
v(j) := t rem BASE;
r := t / BASE;
end loop;
end if;
-- This is the major loop, corresponding to long division steps.
v1 := v(1);
v2 := v(2);
for j in q'range loop
-- Guess the next quotient digit, qe, by dividing the first two
-- remaining dividend digits by the high order divisor digit.
-- This estimate is never low and is at most 2 high.
t := u(j) * BASE + u(j + 1);
if u(j) /= v1 then
qe := t / v1;
else
qe := BASE - 1;
end if;
-- Now refine this guess so that it is almost always correct and
-- is at worst one too high.
while v2 * qe > (t - qe * v1) * BASE + u(j + 2) loop
qe := qe - 1;
end loop;
-- Using qe as the quotient digit, we multiply the divisor by
-- qe and subtract from the remaining dividend.
r := 0;
for k in reverse v'range loop
t := u(j + k) - qe * v(k) + r;
e := t rem BASE;
r := t / BASE;
if e < 0 then
e := e + BASE;
r := r - 1;
end if;
u(j + k) := e;
end loop;
u(j) := u(j) + r;
-- If qe was off by one, then u(j) went negative when the last
-- carry was added. So we correct the error by subtracting one
-- from the quotient digit and adding back the divisor to the
-- relevant portion of the dividend.
if u(j) < 0 then
qe := qe - 1;
r := 0;
for k in reverse v'range loop
t := u(j + k) + v(k) + r;
if t > BASE then
t := t - BASE;
r := 1;
else
r := 0;
end if;
u(j + k) := t;
end loop;
u(j) := u(j) + r;
end if;
-- Store the next quotient digit.
q(j) := qe;
end loop;
return UI(q, (x(1) < 0) xor (y(1) < 0));
end;
end "/";
function "rem"(x, y : Universal_integer) return Universal_integer is
begin
if x'length = 1 and then y'length = 1 then
return UI(x(1) rem y(1));
else
return x - (x / y) * y;
end if;
end "rem";
function "mod"(x, y : Universal_integer) return Universal_integer is
r : constant Universal_integer := x rem y;
begin
if (x(1) < 0) = (y(1) < 0) or else r(1) = 0 then
return r;
else
return y + r;
end if;
end "mod";
function "**"(x : Universal_integer; y : INTEGER) return Universal_integer is
-- Raise a universal integer to an integer power using the binary
-- representation of the exponent.
r : Universal_integer := i_one;
v : integer := y;
t : Universal_integer := abs x;
begin
if y < 0 then
raise CONSTRAINT_ERROR;
elsif y = 0 then
return i_one;
elsif x(1) = 0 then
return i_zero;
end if;
-- Starting the variable r at 1 and t at x loop through the binary
-- digits of v, squaring t each time, and multiplying the result r
-- by the current value of t each time a 1-bit is found.
while v /= 0 loop
if v rem 2 = 1 then -- v is odd
r := r * t;
end if;
t := t * t;
v := v / 2; -- halve v
end loop;
-- Compute the sign of the result: positive if y is even, the sign of
-- x if y is odd.
if x(1) < 0 and then y rem 2 = 1 then r(1) := - r(1); end if;
return r;
end "**";
function ">=" (x, y : Universal_integer) return boolean is
z : Universal_integer := x - y;
begin
return z(1) >= 0;
end ">=";
function "<=" (x, y : Universal_integer) return boolean is
z : Universal_integer := x - y;
begin
return z(1) <= 0;
end "<=";
function "<" (x, y : Universal_integer) return boolean is
z : Universal_integer := x - y;
begin
return z(1) < 0;
end "<";
function ">" (x, y : Universal_integer) return boolean is
z : Universal_integer := x - y;
begin
return z(1) > 0;
end ">";
function eql (x, y : Universal_integer) return boolean is
begin
return x.all = y.all;
end eql;
end UNIVERSAL_INTEGER_ARITHMETIC;
with UNIVERSAL_INTEGER_ARITHMETIC;
use UNIVERSAL_INTEGER_ARITHMETIC;
package UNIVERSAL_REAL_ARITHMETIC is
-- This package implements the Ada type Universal_real.
-- The operations defined on universal numbers are those specified in
-- chapter 4 of the RM. Since the equality and inequality operators can
-- not be overloaded, an equality function is defined. A universal real
-- number corresponds to a unique pair of universal integers that represent
-- it as a rational number. A function, UR, is defined that constructs a
-- universal real number from a pair of universal integers. Also, the inverse
-- of this function is provided by two functions, NUMERATOR and DENOMINATOR,
-- that decompose the rational number representation of their universal real
-- argument into its numerator and denominator, respectively. In addition,
-- conversions between Universal_integer and Universal_real are defined.
type Universal_real is private;
function "+" (x, y : Universal_real) return Universal_real;
function "-" (x, y : Universal_real) return Universal_real;
function "*" (x, y : Universal_real) return Universal_real;
function "/" (x, y : Universal_real) return Universal_real;
function "**" (x : Universal_real; y : INTEGER) return Universal_real;
function "*" (x : Universal_integer; y : Universal_real)
return Universal_real;
function "*" (x : Universal_real; y : Universal_integer)
return Universal_real;
function "/" (x : Universal_real; y : Universal_integer)
return Universal_real;
function "-" (x : Universal_real) return Universal_real;
function "abs"(x : Universal_real) return Universal_real;
function ">=" (x, y : Universal_real) return boolean;
function ">" (x, y : Universal_real) return boolean;
function "<=" (x, y : Universal_real) return boolean;
function "<" (x, y : Universal_real) return boolean;
function eql (x, y : Universal_real) return boolean;
function UI(x : Universal_real) return Universal_integer;
-- Converts a universal real to a universal integer by rounding.
function UR(x : Universal_integer) return Universal_real;
-- Converts a universal integer to a universal real.
function UR(n, d : Universal_integer) return Universal_real;
-- Constructs a universal real as the ratio of two universal integers.
-- The value of d must not be ZERO; if it is, NUMERIC_ERROR is raised.
function NUMERATOR(x : Universal_real) return Universal_integer;
-- Returns the numerator of x viewed as a rational number.
function DENOMINATOR(x : Universal_real) return Universal_integer;
-- Returns the denominator of x viewed as a rational number.
private
-- A universal real is represented as a rational number consisting
-- of a pair of universal integers. The numerator is the first
-- member of the pair and the denominator is the second. The
-- denominator must not be zero. Also, the numerator, denominator
-- pair is always reduced to lowest terms.
type Universal_real is
record
num : Universal_integer;
den : Universal_integer;
end record;
end UNIVERSAL_REAL_ARITHMETIC;
with UNIVERSAL_INTEGER_ARITHMETIC;
use UNIVERSAL_INTEGER_ARITHMETIC;
pragma ELABORATE(UNIVERSAL_INTEGER_ARITHMETIC);
package body UNIVERSAL_REAL_ARITHMETIC is
i_zero : constant Universal_integer := UI(0);
i_one : constant Universal_integer := UI(1);
i_two : constant Universal_integer := UI(2);
i_ten : constant Universal_integer := UI(10);
r_zero : constant Universal_real := (i_zero, i_one);
r_one : constant Universal_real := (i_one, i_one);
function UR(n, d : Universal_integer) return Universal_real is
-- Constructs a universal real as the ratio of two universal integers.
-- The value of d must not be ZERO; if it is, NUMERIC_ERROR is raised.
-- Every real number produced as a result of an operation defined in
-- this package must have a positive denominator and the numerator and
-- denominator must be reduced to lowest terms. This ensures uniqueness
-- of the representation.
r : Universal_integer;
y : Universal_integer;
z : Universal_integer;
begin
if eql(d, i_zero) then
raise NUMERIC_ERROR;
elsif eql(n, i_zero) then
return r_zero;
end if;
-- Now reduce to lowest terms; that is, find the gcd of n and d.
y := abs n;
z := abs d;
loop
r := y rem z;
exit when eql(r, i_zero);
y := z;
z := r;
end loop;
if d >= i_zero then
return (n / z, d / z);
else
return (- n / z, - d / z);
end if;
end UR;
function UI(x : Universal_real) return Universal_integer is
i : Universal_integer := x.num / x.den;
r : Universal_real := (i, i_one);
h : Universal_real := (i_two, i_one);
begin
if eql(x.num, i_zero) then
return i_zero;
elsif x.num < i_zero and then x - r <= - h then
return i - i_one;
elsif x.num > i_zero and then x - r >= h then
return i + i_one;
else
return i;
end if;
end UI;
function UR(x : Universal_integer) return Universal_real is
begin
return (x, i_one);
end UR;
function NUMERATOR(x : Universal_real) return Universal_integer is
begin
return x.num;
end NUMERATOR;
function DENOMINATOR(x : Universal_real) return Universal_integer is
begin
return x.den;
end DENOMINATOR;
function "-" (x : Universal_real) return Universal_real is
begin
return (- x.num, x.den);
end "-";
function "abs" (x : Universal_real) return Universal_real is
begin
return (abs x.num, x.den);
end "abs";
function "*" (x : Universal_integer; y : Universal_real)
return Universal_real is
begin
return UR(y.num * x, y.den);
end "*";
function "*"(x : Universal_real; y : Universal_integer)
return Universal_real is
begin
return UR(x.num * y, x.den);
end "*";
function "/"(x : Universal_real; y : Universal_integer)
return Universal_real is
begin
return UR(x.num, x.den * y);
end "/";
function "+" (x, y : Universal_real) return Universal_real is
begin
return UR(x.num * y.den + y.num * x.den, x.den * y.den);
end "+";
function "-" (x, y : Universal_real) return Universal_real is
begin
return x + (- y);
end "-";
function "*" (x, y : Universal_real) return Universal_real is
begin
return UR(x.num * y.num, x.den * y.den);
end "*";
function "/" (x, y : Universal_real) return Universal_real is
begin
return UR(x.num * y.den, x.den * y.num);
end "/";
function "**"(x : Universal_real; y : INTEGER) return Universal_real is
begin
if y = 0 then
return r_one;
elsif y > 0 then
return UR(x.num ** y, x.den ** y);
else
return UR(x.den ** (- y), x.num ** (- y));
end if;
end "**";
function ">=" (x, y : Universal_real) return boolean is
z : Universal_real := x - y;
begin
return z.num >= i_zero;
end ">=";
function "<=" (x, y : Universal_real) return boolean is
z : Universal_real := x - y;
begin
return z.num <= i_zero;
end "<=";
function "<" (x, y : Universal_real) return boolean is
z : Universal_real := x - y;
begin
return z.num < i_zero;
end "<";
function ">" (x, y : Universal_real) return boolean is
z : Universal_real := x - y;
begin
return z.num > i_zero;
end ">";
function eql (x, y : Universal_real) return boolean is
z : Universal_real := x - y;
begin
return eql(z.num, i_zero);
end eql;
end UNIVERSAL_REAL_ARITHMETIC;
------- End of Forwarded Message