Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/test/adaf85.doc

Text File | 1988-05-03 | 236.2 KB | 8,765 lines

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 (<List of participating vendors>, None);
       Vendor : Vendor_Name := None;

       Columns : constant := 80;

       subtype Comment is String (1 .. Columns);
       Blank_Comment : constant Comment := (1 .. Columns => ' ');

       type Note is array (1 .. 5) of String (1 .. Columns);
       Blank_Note : constant Note := (1 .. 5 => (1 .. Columns => ' '));

       Compilation_Environment : Note := Blank_Note;
       Execution_Environment : Note := Blank_Note;

       type Test_Result is (Passed,
                            Failed,
                            Uncertain,
                            Unable_To_Run,
                            Not_Attempted,
                            Disqualified,
                            Test_Has_Been_Dropped);

       Seconds : constant Integer := 1;

       type Size is digits 6;
       Kilo_Bytes : constant Size := 1.0; -- represents 1024 bytes

       type Result_Record is
          record
            Class : Test_Result := Not_Attempted;
            Class_Comment : Comment := Blank_Comment;

            Challenged_By_Vendor : Boolean := False;
            Challenge_Comment : Comment := Blank_Comment;

            -- Officially requested results go here:
            Performance_Data : Note := Blank_Note;
            Performance_Comment : Comment := Blank_Comment;

            -- Explanations and objections go here:
            Explanations : Note := Blank_Note;

            -- This includes any intermediate translations by other
            -- compilers or assemblers:
            Compilation_Time : Duration := 0.0 * Seconds;
            Compilation_Comment : Comment := Blank_Comment;

            -- A value of zero indicates load- or execution-time binding:

            Link_Or_Binding_Time : Duration := 0.0 * Seconds;
            Linkage_Comment : Comment := Blank_Comment;

            -- A value of zero indicates load time is included in
            -- execution time (and cannot be reported separately).
            Load_Time : Duration := 0.0 * Seconds;
            Loading_Comment : Comment := Blank_Comment;

            -- This includes Load_Time if it is not reported above:
            Execution_Time : Duration := 0.0 * Seconds;
            Execution_Comment : Comment := Blank_Comment;

            -- This includes only the units whose source is in the
            -- compilation;
            -- it excludes predefined packages which they "with":
            Object_Code_Size : Size := 0.000 * Kilo_Bytes;
            Object_Code_Comment : Comment := Blank_Comment;

            -- This includes pure code only; it excludes data and the
            -- run-time support library:
            Code_Image_Size : Size := 0.000 * Kilo_Bytes;
            Code_Image_Comment : Comment := Blank_Comment;

            -- This includes it all -- code, data, and run-time support:
            Maximum_Memory_Used : Size := 0.000 * Kilo_Bytes;
            Memory_Used_Comment : Comment := Blank_Comment;
          end record;

       Number_Of_Programs : constant
                               := <Number actually submitted to vendors>;

       type Number is range 1 .. Number_Of_Programs;

       type Result_Array is array (Number) of Result_Record;

       Results : Result_Array;

       procedure Put (N : Note) is ... end Put;

       procedure Put (R : Result_Record) is ... end Put;

    begin

      Set_Line(To => 10);
      Set_Column(To => 31);
      Put_Line("LA AdaTEC Ada* Fair");

      Set_Column(To => 33);
      Put_Line("30 June, 1984");

      Set_Column(To => 29);
      Put_Line("COMPILER TEST RESULTS");
      New_Line;

      Vendor := <This vendor's name>;
      Set_Column(To => <TBD>);
      Put(Vendor);
      New_Line(2);

      Compilation_Environment
         := <Description of the host computer and compiler toolset>;
      Put(Compilation_Environment);
      New_Line;
      Execution_Environment
         := <Description of the target computer and run-time environment>;
      Put(Execution_Environment);

      Set_Line(To => 55);
      Put("* Ada is a registered trademark of the U.S. Government " &
          "(Ada Joint Program Office)");

      Results := <Vendor's actual results>;

      for N in Number loop
         New_Page;
         Put(Results(N));
      end loop;

    end Summarize;


-------------------------------------------------------------------
---------------------  Next  Program  -----------------------------
-------------------------------------------------------------------


--
-- Version: @(#)akerman.ada    2.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);
--       <read all or part of O>
--       C.Stop;
--
--    and writers should do:
--
--       C.Start(Write);
--       <update all or part of O>
--       C.Stop;

package Readers_Writers is

   type Service is (Read, Write);

   task type Control is
      entry Start (Mode : Service);  -- start readers or writers
      entry Stop;                    -- stop readers or writers
   end Control;

end Readers_Writers;

package body Readers_Writers is

   task body Control is
      Read_Count : Natural := 0;
   begin
      loop
         select
            -- remove the first reader or writer from the queue
            accept Start (Mode : Service) do
               if Mode = Read then
                  Read_Count := Read_Count + 1;
               else
                  -- when writer, wait for readers which have already
                  -- started to finish before allowing the writer to
                  -- perform the update
                  while Read_Count > 0 loop
                     -- when a write is pending, readers stop here
                     accept Stop;
                     Read_Count := Read_Count - 1;
                  end loop;
               end if;
            end Start;

            if Read_Count = 0 then
               -- when writer, wait for writer to stop before allowing
               -- other readers or writers to start
               accept Stop;
            end if;
         or
            -- when no write is pending, readers stop here
            accept Stop;
            Read_Count := Read_Count -1;
         or
            -- quit when everyone agrees to do so
            terminate;
         end select;
      end loop;
   end Control;

end Readers_Writers;



-- This package allows any number of concurrent programs to read and/or
-- indivisibly write a particular (possibly composite) variable object
-- without interference and in FIFO order.  Similar packages can be
-- constructed to perform partial reads and writes of composite objects.
-- If service cannot be started before the appropriate time limit expires,
-- the exception Timed_Out will be raised.  (By default, service must be
-- started within Duration'Last (24+) hours.  Setting the time limits to
-- 0.0 will require immediate service.)
--
generic

   type Object_Type is private;
   Object : in out Object_Type;

   Read_Time_Limit : in Duration := Duration'Last;
   Write_Time_Limit : in Duration := Duration'Last;

   -- for testing only
   with procedure Read_Put (Item : in Object_Type) is <>;

   -- for testing only
   with procedure Write_Put (Item : in Object_Type) is <>;

   -- for testing only
   with procedure Copy (From : in Object_Type; To : in out Object_Type);

package Shared_Variable is

   -- for testing only: Item made "in out" instead of "out"
   procedure Read (Item : in out Object_Type);
   procedure Write (Item : in Object_Type);

   Timed_Out : exception;

end Shared_Variable;

with Readers_Writers; use Readers_Writers;
package body Shared_Variable is

   C : Control;

   -- for testing only: Item made "in out" instead of "out"
   procedure Read (Item : in out Object_Type) is
   begin

      select
     C.Start(Read);
      or
     delay Read_Time_Limit;
     raise Timed_Out;
      end select;

-- for testing only; this allows the scheduler to screw up!
      Copy(From => Object, To => Item);
-- temporarily replaces
--    Item := Object;

-- for testing only
      Read_Put(Item);

      C.Stop;
   end Read;

   procedure Write (Item : in Object_Type) is
   begin

      select
     C.Start(Write);
      or
     delay Write_Time_Limit;
     raise Timed_Out;
      end select;

-- for testing only; this allows the scheduler to screw up!
      Copy(From => Item, To => Object);
-- temporarily replaces
      Object := Item;

-- for testing only
      Write_Put(Item);

      C.Stop;
   end Write;

end Shared_Variable;



with Shared_Variable;
package Encapsulate is

   Max : constant := 2;

   subtype Index is Positive range 1 .. Max;

   type Composite is array (Index) of Integer;

   procedure Read (C : out Composite);

   procedure Write (C : in Composite);

-- This is a help function for testing
   function Set_To (I : Integer) return Composite;

-- This is a help function for testing
   function Value_Of (C : Composite) return Integer;

-- This entry is used to serialize debug output to Standard_Output
   task Msg is
      entry Put (S : String);
   end Msg;

end Encapsulate;


with Text_IO;
package body Encapsulate is

   Shared : Composite;

   function Set_To (I : Integer) return Composite is
      Temp : Composite;
   begin
      for N in Index loop
     Temp(N) := I;
      end loop;
      return Temp;
   end Set_To;

   function Value_Of (C : Composite) return Integer is
   begin
      return C(Index'First);
   end Value_Of;

   -- for testing only; this allows the scheduler to overlap readers and
   -- writers and thus screw up if Readers_Writers doesn't do its job.
   -- it also checks that the copy is consistent.
   procedure Copy (From : in Composite; To : in out Composite) is
   begin
      for I in Index loop
     To(I) := From(I);
         -- delay so that another access could be made:
     delay 0.5;
      end loop;
      -- test for consistency:
      for I in Index range Index'Succ(Index'First) .. Index'Last loop
     if To(I) /= To(Index'First) then
        raise Program_Error;
     end if;
      end loop;
   end Copy;

   procedure Read_Put (Item : Composite) is
   begin
      Msg.Put(Integer'Image(Value_Of(Item)) & " read");
   end Read_Put;

   procedure Write_Put (Item : Composite) is
   begin
      Msg.Put(Integer'Image(Value_Of(Item)) & " written");
   end Write_Put;

   task body Msg is
   begin
      loop
     select
        accept Put (S : String) do
           Text_IO.Put (S);
           Text_IO.New_Line;
        end Put;
     or
        terminate;
     end select;
      end loop;
   end Msg;

   package Share is new Shared_Variable
      (Object_Type => Composite, Object => Shared, Read_Put => Read_Put,
      Write_Put => Write_Put, Copy => Copy);
   use Share;

   procedure Read (C : out Composite) is
      Temp : Composite;
   begin
      Share.Read(Temp);
      C := Temp;
   end Read;

   procedure Write (C : in Composite) is
   begin
      Share.Write(C);
   end Write;

begin

   Shared := Set_To (0);

end Encapsulate;


with Encapsulate; use Encapsulate;
with Text_IO; use Text_IO;
procedure Test_Shared is

   Local : Composite := Set_To (-1);

   task A;
   task B;
   task C;

   procedure Put(C : Character; I : Integer);

   task body A is
   begin
      Read(Local);
      Put('A',Value_Of(Local));

      Write(Set_To(1));

      Read(Local);
      Put('A',Value_Of(Local));

      Write(Set_To(2));

      Read(Local);
      Put('A',Value_Of(Local));
   end A;

   task body B is
   begin
      Read(Local);
      Put('B',Value_Of(Local));

      Write(Set_To(3));

      Read(Local);
      Put('B',Value_Of(Local));
   end B;

   task body C is
   begin
      Write(Set_To(4));

      Read(Local);
      Put('C',Value_Of(Local));

      Write(Set_To(5));

      Read(Local);
      Put('C',Value_Of(Local));
   end C;

   procedure Put(C : Character; I : Integer) is
   begin
      Msg.Put("Task " & C & " read the value " & Integer'Image(I));
   end Put;

begin
   null;
end Test_Shared;






-------------------------------------------------------------------
---------------------  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