Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/metric/sinstrtm.src

Text File | 1988-05-03 | 190.9 KB | 6,119 lines

-----------------------------------
package Implementation_Dependencies is --| Ada Compiler dependencies
-----------------------------------

--| Overview
--| This package contains Ada Compiler Implementation dependencies.
--| The purpose of this package is to isolate compiler dependencies
--| to a single package to simplify rehosting of the Ada Testing
--| and Evaluation Tools Set (ATETS).

--| This version of Implementation_Dependencies is configured for:
--|
--|   - DEC VAX Ada Compiler
--|
--|   - TeleSoft Ada Compiler ( VAX VMS Version 2.5 )


-- Jeff England  04/30/85 (TeleSoft Ada)
--               05/09/85 (DEC VAX Ada)

--------------------------------------


    type Long_Integer  is new integer;  --| Not implemented in TeleSoft Ada

--    type Long_Float    is new float;    --| Not implemented in TeleSoft Ada

--    type Short_Integer is new integer;  --| Not implemented in TeleSoft Ada

    type Short_Float   is new float;    --| Not implemented in TeleSoft Ada

    Line_length : constant := 256;

end Implementation_Dependencies;

package File_Manager is

--| Overview
--| This package provides some host independent file functions.  The provided
--| functions are: Copy, Rename, and Append.  Each of these works on text
--| files only and with a maximun line length of 255 (constant declared in
--| the body which can be changed).  Due to Ada's limitations each file
--| ends up with a form feed inserted as the last character.

--| Requires
--| Each procedure is passed two strings which are the file names to be used.

  procedure Copy(In_File_Name : in string;
                 Out_File_Name: in string);

--| Effects
--| This procedure will take the file specified as In_file_name and make a
--| second copy of the file in the file specified in Out_file_name.
--| The copy of the file in Out_file_name will have a form feed inserted
--| as the last character of the file.

--| Requires
--| The parameter In_file_name must specify a valid file name of an existing
--| file.  The parameter Out_file_name must specify a valid file name for a
--| file that currently does not exist

--| Raises
--| status_error, name_error, use_error

  procedure Rename(In_File_Name : in string;
                   Out_File_Name: in string);

--| Effects
--| This procedure will take the file specified in In_file_name and rename
--| it as the file specified as Out_file_name.  The original file will no
--| longer exist.  The new file will have a form feed inserted as the last
--| character of the file.

--| Requires
--| The parameter In_file_name must specify a valid file name of an existing
--| file.  The parameter Out_file_name must specify a valid file name for a
--| file that currently does not exist

--| Raises
--| status_error, use_error, name_error

  procedure Append(Append_File_Name : in string;
                   To_File_Name     : in string);

--| Effects
--| This procedure will Append one file onto the end of another file.  The
--| First file specified will be added onto the end of the second file
--| specified.

--| Requires
--| Both parameters must be valid file names and must specify files that
--| currently exist.

--| Raises
--| status_error, name_error, use_error

end File_Manager;
with Text_Io; use Text_Io;
package body File_Manager is

--| Overview
--| This package provides some host independent file functions.  These
--| functions work on text files.  The maximun line lengths of the
--| files is specified in the parameter Maximun_Line_Size which can be
--| changed.

  Maximum_Line_Size: constant := 255;

  procedure Copy(In_File_Name : in string;
                 Out_File_Name: in string) is
    Input_Buffer: string(1..Maximum_Line_Size);
    Input_File: File_Type;
    Output_File: File_Type;
    Line_Length: natural;
  begin
    Open(Input_File,In_File, In_File_Name);
    Create(Output_File,Out_File, Out_File_Name);

    while not End_Of_File(Input_File) loop
      Get_Line(Input_File, Input_Buffer, Line_Length);
      Put_Line(Output_File, Input_Buffer(1..Line_Length));
      end loop;

    Close(Input_File);
    Close(Output_File);
  exception
    when
      status_error =>
        put_line("status_error - trying to open a file that is already open");
    when
      name_error =>
        put_line("name_error - trying to open a file that does not exist");
    when
      use_error =>
        put_line("use_error - incorrect form of file name");
  end Copy;

  procedure Rename(In_File_Name : in string;
                   Out_File_Name: in string) is
    Input_File: File_Type;
  begin
    Copy(In_File_Name,Out_File_Name);
    Open(Input_File,In_File,In_File_Name);
    Delete(Input_File);
  exception
    when
      status_error =>
        put_line("status_error - trying to open/close file");
    when
      name_error =>
        put_line("name_error - trying to open a file that does not exist");
    when
      use_error =>
        put_line("use_error - delete access not allowed");
  end Rename;

  procedure Append(Append_File_Name : in string;
                   To_File_Name     : in string) is
    Append_File: File_Type;
    To_File: File_Type;
    Input_Buffer: string(1..Maximum_Line_Size);
    Line_Length: natural;
  begin
    Rename(To_File_Name,"temp0097.rlr");
    Open(Append_File,In_File, "temp0097.rlr");
    Create(To_File,Out_File, To_File_Name);

    while not End_Of_File(Append_File) loop
      Get_Line(Append_File, Input_Buffer, Line_Length);
      Put_Line(To_File, Input_Buffer(1..Line_Length));
      end loop;

    Delete(Append_File);
    Open(Append_File,In_File, Append_File_Name);

    while not End_Of_File(Append_File) loop
      Get_Line(Append_File, Input_Buffer, Line_Length);
      Put_Line(To_File, Input_Buffer(1..Line_Length));
      end loop;

    Close(Append_File);
    Close(To_File);
  exception
    when
      status_error =>
        put_line("status_error - trying to open/close file");
    when
      name_error =>
        put_line("name_error - trying to open a file that does not exist");
    when
      use_error =>
        put_line("use_error - delete access not allowed");
  end Append;

end File_Manager;

package STRING_PKG is

--| Overview:
--| Package string_pkg exports an abstract data type, string_type.  A
--| string_type value is a sequence of characters.  The values have arbitrary
--| length.  For a value, s, with length, l, the individual characters are
--| numbered from 1 to l.  These values are immutable; characters cannot be
--| replaced or appended in a destructive fashion.
--|
--| In the documentation for this package, we are careful to distinguish
--| between string_type objects, which are Ada objects in the usual sense,
--| and string_type values, the members of this data abstraction as described
--| above.  A string_type value is said to be associated with, or bound to,
--| a string_type object after an assignment (:=) operation.
--|
--| The operations provided in this package fall into three categories:
--|
--| 1. Constructors:  These functions typically take one or more string_type
--|      objects as arguments.  They work with the values associated with
--|      these objects, and return new string_type values according to
--|      specification.  By a slight abuse of language, we will sometimes
--|      coerce from string_type objects to values for ease in description.
--|
--| 2. Heap Management:
--|      These operations (make_persistent, flush, mark, release) control the
--|      management of heap space.  Because string_type values are
--|      allocated on the heap, and the type is not limited, it is necessary
--|      for a user to assume some responsibility for garbage collection.
--|      String_type is not limited because of the convenience of
--|      the assignment operation, and the usefulness of being able to
--|      instantiate generic units that contain private type formals.
--|      ** Important: To use this package properly, it is necessary to read
--|      the descriptions of the operations in this section.
--|
--| 3. Queries:  These functions return information about the values
--|      that are associated with the argument objects.  The same conventions
--|      for description of operations used in (1) is adopted.
--|
--| A note about design decisions...  The decision to not make the type
--| limited causes two operations to be carried over from the representation.
--| These are the assignment operation, :=, and the "equality" operator, "=".
--| See the discussion at the beginning of the Heap Management section for a
--| discussion of :=.
--| See the spec for the first of the equal functions for a discussion of "=".
--|
--| The following is a complete list of operations, written in the order
--| in which they appear in the spec.  Overloaded subprograms are followed
--| by (n), where n is the number of subprograms of that name.
--|
--| 1. Constructors:
--|        create
--|        "&" (3)
--|        substr
--|        splice
--|        insert (3)
--|        lower (2)
--|        upper (2)
--| 2. Heap Management:
--|        make_persistent (2)
--|        flush
--|        mark, release
--| 3. Queries:
--|        is_empty
--|        length
--|        value
--|        fetch
--|        equal (3)
--|        "<" (3),
--|       "<=" (3)
--|        match_c
--|        match_not_c
--|        match_s (2)
--|        match_any (2)
--|        match_none (2)

--| Notes:
--| Programmer: Ron Kownacki

  type STRING_TYPE is private;

  BOUNDS          : exception;  --| Raised on index out of bounds.
  ANY_EMPTY       : exception;  --| Raised on incorrect use of match_any.
  ILLEGAL_ALLOC   : exception;  --| Raised by value creating operations.
  ILLEGAL_DEALLOC : exception;  --| Raised by release.


  -- Constructors:

  function CREATE(S : in STRING) return STRING_TYPE;

  --| Raises: illegal_alloc
  --| Effects:
  --| Return a value consisting of the sequence of characters in s.
  --| Sometimes useful for array or record aggregates.
  --| Raises illegal_alloc if string space has been improperly
  --| released.  (See procedures mark/release.)

  function "&"(S1, S2 : in STRING_TYPE) return STRING_TYPE;

  --| Raises: illegal_alloc
  --| Effects:
  --| Return the concatenation of s1 and s2.
  --| Raises illegal_alloc if string space has been improperly
  --| released.  (See procedures mark/release.)

  function "&"(S1 : in STRING_TYPE;
               S2 : in STRING) return STRING_TYPE;

  --| Raises: illegal_alloc
  --| Effects:
  --| Return the concatenation of s1 and create(s2).
  --| Raises illegal_alloc if string space has been improperly
  --| released.  (See procedures mark/release.)

  function "&"(S1 : in STRING;
               S2 : in STRING_TYPE) return STRING_TYPE;

  --| Raises: illegal_alloc
  --| Effects:
  --| Return the concatenation of create(s1) and s2.
  --| Raises illegal_alloc if string space has been improperly
  --| released.  (See procedures mark/release.)

  function SUBSTR(S   : in STRING_TYPE;
                  I   : in POSITIVE;
                  LEN : in NATURAL) return STRING_TYPE;

  --| Raises: bounds, illegal_alloc
  --| Effects:
  --| Return the substring, of specified length, that occurs in s at
  --| position i.  If len = 0, then returns the empty value.
  --| Otherwise, raises bounds if either i or (i + len - 1)
  --| is not in 1..length(s).
  --| Raises illegal_alloc if string space has been improperly
  --| released.  (See procedures mark/release.)

  function SPLICE(S   : in STRING_TYPE;
                  I   : in POSITIVE;
                  LEN : in NATURAL) return STRING_TYPE;

  --| Raises: bounds, illegal_alloc
  --| Effects:
  --| Let s be the string, abc, where a, b and c are substrings.  If
  --| substr(s, i, length(b)) = b, for some i in 1..length(s), then
  --| splice(s, i, length(b)) = ac.
  --| Returns a value equal to s if len = 0.  Otherwise, raises bounds if
  --| either i or (i + len - 1) is not in 1..length(s).
  --| Raises illegal_alloc if string space has been improperly
  --| released.  (See procedures mark/release.)

  function INSERT(S1, S2 : in STRING_TYPE;
                  I      : in POSITIVE) return STRING_TYPE;

  --| Raises: bounds, illegal_alloc
  --| Effects:
  --| Return substr(s1, 1, i - 1) & s2 &
  --|        substr(s1, i, length(s1) - i + 1).
  --| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no
  --| exception is raised by insert.
  --| Raises bounds if is_empty(s1) or else i is not in 1..length(s1).
  --| Raises illegal_alloc if string space has been improperly
  --| released.  (See procedures mark/release.)

  function INSERT(S1 : in STRING_TYPE;
                  S2 : in STRING;
                  I  : in POSITIVE) return STRING_TYPE;

  --| Raises: bounds, illegal_alloc
  --| Effects:
  --| Return substr(s1, 1, i - 1) & s2 &
  --|        substr(s1, i, length(s1) - i + 1).
  --| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no
  --| exception is raised by insert.
  --| Raises bounds if is_empty(s1) or else i is not in 1..length(s1).
  --| Raises illegal_alloc if string space has been improperly
  --| released.  (See procedures mark/release.)

  function INSERT(S1 : in STRING;
                  S2 : in STRING_TYPE;
                  I  : in POSITIVE) return STRING_TYPE;

  --| Raises: bounds, illegal_alloc
  --| Effects:
  --| Return s1(s1'first..i - 1) & s2 &
  --|        s1(i..length(s1) - i + 1).
  --| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no
  --| exception is raised by insert.
  --| Raises bounds if i is not in s'range.
  --| Raises illegal_alloc if string space has been improperly
  --| released.  (See procedures mark/release.)

  function LOWER(S : in STRING) return STRING_TYPE;

  --| Raises: illegal_alloc
  --| Effects:
  --| Return a value that contains exactly those characters in s with
  --| the exception that all upper case characters are replaced by their
  --| lower case counterparts.
  --| Raises illegal_alloc if string space has been improperly
  --| released.  (See procedures mark/release.)

  function LOWER(S : in STRING_TYPE) return STRING_TYPE;

  --| Raises: illegal_alloc
  --| Effects:
  --| Return a value that is a copy of s with the exception that all
  --| upper case characters are replaced by their lower case counterparts.
  --| Raises illegal_alloc if string space has been improperly
  --| released.  (See procedures mark/release.)

  function UPPER(S : in STRING) return STRING_TYPE;

  --| Raises: illegal_alloc
  --| Effects:
  --| Return a value that contains exactly those characters in s with
  --| the exception that all lower case characters are replaced by their
  --| upper case counterparts.
  --| Raises illegal_alloc if string space has been improperly
  --| released.  (See procedures mark/release.)

  function UPPER(S : in STRING_TYPE) return STRING_TYPE;

  --| Raises: illegal_alloc
  --| Effects:
  --| Return a value that is a copy of s with the exception that all
  --| lower case characters are replaced by their upper case counterparts.
  --| Raises illegal_alloc if string space has been improperly
  --| released.  (See procedures mark/release.)


  -- Heap Management (including object/value binding):
  --
-- Two forms of heap management are provided.  The general scheme is to "mark"
  -- the current state of heap usage, and to "release" in order to reclaim all
  -- space that has been used since the last mark.  However, this alone is
  -- insufficient because it is frequently desirable for objects to remain
  -- associated with values for longer periods of time, and this may come into
  -- conflict with the need to clean up after a period of "string hacking."
  -- To deal with this problem, we introduce the notions of "persistent" and
  -- "nonpersistent" values.
  --
  -- The nonpersistent values are those that are generated by the constructors
  -- in the previous section.  These are claimed by the release procedure.
  -- Persistent values are generated by the two make_persistent functions
-- described below.  These values must be disposed of individually by means of
  -- the flush procedure.
  --
  -- This allows a description of the meaning of the ":=" operation.  For a
  -- statement of the form, s := expr, where expr is a string_type expression,
  -- the result is that the value denoted/created by expr becomes bound to the
  -- the object, s.  Assignment in no way affects the persistence of the value.
-- If expr happens to be an object, then the value associated  with it will be
  -- shared.  Ideally, this sharing would not be visible, since values are
  -- immutable.  However, the sharing may be visible because of the memory
-- management, as described below.  Programs which depend on such sharing are
  -- erroneous.

  function MAKE_PERSISTENT(S : in STRING_TYPE) return STRING_TYPE;

  --| Effects:
  --| Returns a persistent value, v, containing exactly those characters in
  --| value(s).  The value v will not be claimed by any subsequent release.
  --| Only an invocation of flush will claim v.  After such a claiming
  --| invocation of flush, the use (other than :=) of any other object to
  --| which v was bound is erroneous, and program_error may be raised for
  --| such a use.

  function MAKE_PERSISTENT(S : in STRING) return STRING_TYPE;

  --| Effects:
  --| Returns a persistent value, v, containing exactly those chars in s.
  --| The value v will not be claimed by any subsequent release.
  --| Only an invocation of flush will reclaim v.  After such a claiming
  --| invocation of flush, the use (other than :=) of any other object to
  --| which v was bound is erroneous, and program_error may be raised for
  --| such a use.

  procedure FLUSH(S : in out STRING_TYPE);

  --| Effects:
  --| Return heap space used by the value associated with s, if any, to
  --| the heap.  s becomes associated with the empty value.  After an
  --| invocation of flush claims the value, v, then any use (other than :=)
  --| of an object to which v was bound is erroneous, and program_error
  --| may be raised for such a use.
  --|
  --| This operation should be used only for persistent values.  The mark
  --| and release operations are used to deallocate space consumed by other
  --| values.  For example, flushing a nonpersistent value implies that a
  --| release that tries to claim this value will be erroneous, and
  --| program_error may be raised for such a use.

  procedure MARK;

  --| Effects:
  --| Marks the current state of heap usage for use by release.
  --| An implicit mark is performed at the beginning of program execution.

  procedure RELEASE;

  --| Raises: illegal_dealloc
  --| Effects:
  --| Releases all heap space used by nonpersistent values that have been
  --| allocated since the last mark.  The values that are claimed include
  --| those bound to objects as well as those produced and discarded during
  --| the course of general "string hacking."  If an invocation of release
  --| claims a value, v, then any subsequent use (other than :=) of any
  --| other object to which v is bound is erroneous, and program_error may
  --| be raised for such a use.
  --|
  --| Raises illegal_dealloc if the invocation of release does not balance
  --| an invocation of mark.  It is permissible to match the implicit
  --| initial invocation of mark.  However, subsequent invocations of
  --| constructors will raise the illegal_alloc exception until an
  --| additional mark is performed.  (Anyway, there is no good reason to
  --| do this.)  In any case, a number of releases matching the number of
  --| currently active marks is implicitly performed at the end of program
  --| execution.
  --|
  --| Good citizens generally perform their own marks and releases
  --| explicitly.  Extensive string hacking without cleaning up will
  --| cause your program to run very slowly, since the heap manager will
  --| be forced to look hard for chunks of space to allocate.

  -- Queries:

  function IS_EMPTY(S : in STRING_TYPE) return BOOLEAN;

  --| Effects:
  --| Return true iff s is the empty sequence of characters.

  function LENGTH(S : in STRING_TYPE) return NATURAL;

  --| Effects:
  --| Return number of characters in s.

  function VALUE(S : in STRING_TYPE) return STRING;

  --| Effects:
  --| Return a string, s2, that contains the same characters that s
  --| contains.  The properties, s2'first = 1 and s2'last = length(s),
  --| are satisfied.  This implies that, for a given string, s3,
  --| value(create(s3))'first may not equal s3'first, even though
  --| value(create(s3)) = s3 holds.  Thus, "content equality" applies
  --| although the string objects may be distinguished by the use of
  --| the array attributes.

  function FETCH(S : in STRING_TYPE;
                 I : in POSITIVE) return CHARACTER;

  --| Raises: bounds
  --| Effects:
  --| Return the ith character in s.  Characters are numbered from
  --| 1 to length(s).  Raises bounds if i not in 1..length(s).

  function EQUAL(S1, S2 : in STRING_TYPE) return BOOLEAN;

  --| Effects:
  --| Value equality relation; return true iff length(s1) = length(s2)
  --| and, for all i in 1..length(s1), fetch(s1, i) = fetch(s2, i).
  --| The "=" operation is carried over from the representation.
  --| It allows one to distinguish among the heap addresses of
  --| string_type values.  Even "equal" values may not be "=", although
  --| s1 = s2 implies equal(s1, s2).
  --| There is no reason to use "=".

  function EQUAL(S1 : in STRING_TYPE;
                 S2 : in STRING) return BOOLEAN;

  --| Effects:
  --| Return equal(s1, create(s2)).

  function EQUAL(S1 : in STRING;
                 S2 : in STRING_TYPE) return BOOLEAN;

  --| Effects:
  --| Return equal(create(s1), s2).

  function "<"(S1 : in STRING_TYPE;
               S2 : in STRING_TYPE) return BOOLEAN;

  --| Effects:
  --| Lexicographic comparison; return value(s1) < value(s2).

  function "<"(S1 : in STRING_TYPE;
               S2 : in STRING) return BOOLEAN;

  --| Effects:
  --| Lexicographic comparison; return value(s1) < s2.

  function "<"(S1 : in STRING;
               S2 : in STRING_TYPE) return BOOLEAN;

  --| Effects:
  --| Lexicographic comparison; return s1 < value(s2).

  function "<="(S1 : in STRING_TYPE;
                S2 : in STRING_TYPE) return BOOLEAN;

  --| Effects:
  --| Lexicographic comparison; return value(s1) <= value(s2).

  function "<="(S1 : in STRING_TYPE;
                S2 : in STRING) return BOOLEAN;

  --| Effects:
  --| Lexicographic comparison; return value(s1) <= s2.

  function "<="(S1 : in STRING;
                S2 : in STRING_TYPE) return BOOLEAN;

  --| Effects:
  --| Lexicographic comparison; return s1 <= value(s2).

  function MATCH_C(S     : in STRING_TYPE;
                   C     : in CHARACTER;
                   START : in POSITIVE := 1) return NATURAL;

  --| Raises: no_match
  --| Effects:
  --| Return the minimum index, i in start..length(s), such that
  --| fetch(s, i) = c.  Returns 0 if no such i exists,
  --| including the case where is_empty(s).

  function MATCH_NOT_C(S     : in STRING_TYPE;
                       C     : in CHARACTER;
                       START : in POSITIVE := 1) return NATURAL;

  --| Raises: no_match
  --| Effects:
  --| Return the minimum index, i in start..length(s), such that
  --| fetch(s, i) /= c.  Returns 0 if no such i exists,
  --| including the case where is_empty(s).

  function MATCH_S(S1, S2 : in STRING_TYPE;
                   START  : in POSITIVE := 1) return NATURAL;

  --| Raises: no_match.
  --| Effects:
  --| Return the minimum index, i, in start..length(s1), such that,
  --| for all j in 1..length(s2), fetch(s2, j) = fetch(s1, i + j - 1).
  --| This is the position of the substring, s2, in s1.
  --| Returns 0 if no such i exists, including the cases
  --| where is_empty(s1) or is_empty(s2).
  --| Note that equal(substr(s1, match_s(s1, s2, i), length(s2)), s2)
  --| holds, providing that match_s does not raise an exception.

  function MATCH_S(S1    : in STRING_TYPE;
                   S2    : in STRING;
                   START : in POSITIVE := 1) return NATURAL;

  --| Raises: no_match.
  --| Effects:
  --| Return the minimum index, i, in start..length(s1), such that,
  --| for all j in s2'range, s2(j) = fetch(s1, i + j - 1).
  --| This is the position of the substring, s2, in s1.
  --| Returns 0 if no such i exists, including the cases
  --| where is_empty(s1) or s2 = "".
  --| Note that equal(substr(s1, match_s(s1, s2, i), s2'length), s2)
  --| holds, providing that match_s does not raise an exception.

  function MATCH_ANY(S, ANY : in STRING_TYPE;
                     START  : in POSITIVE := 1) return NATURAL;

  --| Raises: no_match, any_empty
  --| Effects:
  --| Return the minimum index, i in start..length(s), such that
  --| fetch(s, i) = fetch(any, j), for some j in 1..length(any).
  --| Raises any_empty if is_empty(any).
  --| Otherwise, returns 0 if no such i exists, including the case
  --| where is_empty(s).


  function MATCH_ANY(S     : in STRING_TYPE;
                     ANY   : in STRING;
                     START : in POSITIVE := 1) return NATURAL;

  --| Raises: no_match, any_empty
  --| Effects:
  --| Return the minimum index, i, in start..length(s), such that
  --| fetch(s, i) = any(j), for some j in any'range.
  --| Raises any_empty if any = "".
  --| Otherwise, returns 0 if no such i exists, including the case
  --| where is_empty(s).

  function MATCH_NONE(S, NONE : in STRING_TYPE;
                      START   : in POSITIVE := 1) return NATURAL;

  --| Raises: no_match
  --| Effects:
  --| Return the minimum index, i in start..length(s), such that
  --| fetch(s, i) /= fetch(none, j) for each j in 1..length(none).
  --| If (not is_empty(s)) and is_empty(none), then i is 1.
  --| Returns 0 if no such i exists, including the case
  --| where is_empty(s).

  function MATCH_NONE(S     : in STRING_TYPE;
                      NONE  : in STRING;
                      START : in POSITIVE := 1) return NATURAL;

  --| Raises: no_match.
  --| Effects:
  --| Return the minimum index, i in start..length(s), such that
  --| fetch(s, i) /= none(j) for each j in none'range.
  --| If not is_empty(s) and none = "", then i is 1.
  --| Returns 0 if no such i exists, including the case
  --| where is_empty(s).


private

  type STRING_TYPE is access STRING;

  --| Abstract data type, string_type, is a constant sequence of chars
  --| of arbitrary length.  Representation type is access string.
  --| It is important to distinguish between an object of the rep type
  --| and its value; for an object, r, val(r) denotes the value.
  --|
  --| Representation Invariant:  I: rep --> boolean
  --| I(r: rep) = (val(r) = null) or else
  --|             (val(r).all'first = 1 &
  --|              val(r).all'last >= 0 &
  --|              (for all r2, val(r) = val(r2) /= null => r is r2))
  --|
  --| Abstraction Function:  A: rep --> string_type
  --| A(r: rep) = if r = null then
  --|                 the empty sequence
  --|             elsif r'last = 0 then
  --|                 the empty sequence
  --|             else
  --|                 the sequence consisting of r(1),...,r(r'last).

end STRING_PKG;
with STRING_PKG; use STRING_PKG;    --| for String_Types

------------------------
package TYPE_DEFINITIONS is
------------------------

--| Overview
--| TypeDefs contains global type declarations used by all of the Ada
--| Testing and Analysis Tools.  Its purpose is to provide consistency and
--| uniformity of type declarations for objects common to all of the tools.

--| N/A: Errors, Raises, Modifies, Requires

--  Last Modified: 05/10/85 JEE Converted all records with string lengths
--                              as discriminants to String_Type

  type TOOL_NAMES is ( --| The names of the Testing and Analysis Tools
  PATH_TOOL,           --| Path Analyzer
  AUTOPATH_TOOL,       --| Automatic Path Analyzer
  SMART_TOOL,          --| Self Metric Analysis and Reporting Tool
  PROFILE_TOOL,        --| Performance Analyzer
  DEBUG_TOOL           --| Symbolic Debugger
  );

  type LOGFILE_KEYS is ( --| A unique key for each log file record type
                         --| defines the format of each log file record
  PROGRAM, TOOL, TEST_TIME, TEST_ID,        --| Logfile configuration
  COMPILATION_UNIT_DEFINITION,              --| Unit definitions
  PROGRAM_UNIT_DEFINITION,                  --| Unit definitions
  UNIT_START, UNIT_STOP,                    --| Unit starts and stops
  LOOP_BREAKPOINT, OTHER_BREAKPOINT,        --| All other breakpoints
  AUTOPATH_CALL,                            --| AutoPath procedure call
  INTEGER_VARIABLE,                         --| Variable data types
  LONG_INTEGER_VARIABLE,                    --| Variable data types
  FLOAT_VARIABLE,
  LONG_FLOAT_VARIABLE,
  FIXED_POINT_VARIABLE,
  STRING_VARIABLE,
  DELAY_TIME,                               --| For delays of program units
  TIMING_OVERHEAD                           --| For Unit_Start and Unit_Stop
  );

  subtype FILENAME is STRING_TYPE;   --| filenames are string_types

  subtype USER_INPUT_STRING is STRING_TYPE;  --| for strings read from the kbd

  subtype TEST_IDENTIFIER is STRING_TYPE;

  subtype BREAKPOINT_TYPES is
    LOGFILE_KEYS range LOOP_BREAKPOINT .. OTHER_BREAKPOINT;
    --| The type of each breakpoint is assigned by the source instrumenter


  --| Numeric Type Definitions

  subtype PROGRAM_UNIT_NUMBER_RANGE is NATURAL;
  --| The source instrumenter assigns a unique number to each
  --| program unit within a compilation unit.

  subtype TASK_TYPE_ACTIVATION_NUMBER_RANGE is NATURAL;
  --| Each activation of a task type is assigned a unique number.

  subtype BREAKPOINT_NUMBER_RANGE is NATURAL;
  --| The source instrumenter assigns a unique number to each
  --| breakpoint in the compilation unit.

  subtype COUNT_RANGE is NATURAL;
  --| A count is a non-negative number in the range 0 .. MAX_INT;

  type LONG_COUNT is
    record
      OVERFLOW_COUNT : COUNT_RANGE;
      CURRENT_COUNT  : COUNT_RANGE;
    end record;
    --| A Long_Count record provides a "long integer" type of count
    --| consisting of the current count and a count of the number of
    --| times the current count has overflowed.


  --| Program Unit Type definitions

  type PROGRAM_UNIT_TYPE is ( --| Ada program units can be
    PROCEDURE_TYPE,           --| procedures
    FUNCTION_TYPE,            --| functions
    TASK_TYPE,                --| tasks
    GENERIC_TYPE,             --| generics
    PACKAGE_TYPE              --| and packages
  );

  subtype ADA_NAME is STRING_TYPE;
  --| An Ada name is a string type of variable length

  subtype STRING_VARIABLES is STRING_TYPE;
  --| String Variables are string types of variable length

  type PROGRAM_UNIT_NAME is
    record
      UNIT_IDENTIFIER : ADA_NAME;
      UNIT_TYPE       : PROGRAM_UNIT_TYPE;
    end record;
  --| A table of the names and program unit types of all of the
  --| program units contained within a compilation unit.

  type PROCEDURE_LIST is array(POSITIVE range <>) of PROGRAM_UNIT_NAME;
  --| A table of the names and program unit types of all of the
  --| program units contained within a compilation unit.

  type PROGRAM_UNIT_UNIQUE_IDENTIFIER is
    record
      ENCLOSING_UNIT_IDENTIFIER   : ADA_NAME;
      PROGRAM_UNIT_NUMBER         : PROGRAM_UNIT_NUMBER_RANGE := 0;
      UNIT_TYPE                   : PROGRAM_UNIT_TYPE;
      TASK_TYPE_ACTIVATION_NUMBER : TASK_TYPE_ACTIVATION_NUMBER_RANGE := 1;
    end record;
    --| A Program_Unit_Unique_Identifier record consists of the identifier
    --| of the enclosing unit, a unique number for the current program unit,
    --| and for task types, a unique activation number.

  subtype INPUT_PARAMETER_LIST is STRING_TYPE;


  subtype CURRENT_UNIT_NAME is STRING_TYPE;
  --| The name of the current unit

end TYPE_DEFINITIONS;
with Calendar, Text_IO;

----------------------
package Time_Library_1 is
----------------------

--| Overview
--| TimeLib contains procedures and functions for getting, putting,
--| and calculating times, and dates. It augments the
--| predefined library package Calendar to simplify IO and provide
--| additional time routines common to all Ada Test and Evaluation
--| Tool Set (ATETS) tools.

--| Requires
--| All procedures and functions that perform IO use the
--| predefined library package Text_IO and require that the
--| specified file be opened by the calling program prior to use.
--| All times and durations must be of types declared in the
--| predefined library package Calendar.

--| Errors
--| No error messages or exceptions are raised by any of the TimeLib
--| procedures and functions. However, any Text_IO and Calendar
--| exceptions that may be raised are allowed to pass, unhandled,
--| back to the calling program.

--| N/A:  Raises, Modifies

--  Version         : 1.0
--  Author          : Jeff England
--  Initial Release : 05/19/85
--  Last Modified   : 05/19/85



type Timing_Type is ( Raw, Wall_Clock );


----------------
function Date_of ( --| Convert the date to a string
    Date : Calendar.Time    --| The date to be converted
    ) return string;

  --| Effects
  --| Converts the date to a string in the format MM/DD/YYYY

  --| N/A:  Raises, Requires, Modifies, Errors


----------------------
function Wall_Clock_of ( --| Convert seconds to wall clock time
    Seconds : Calendar.Day_Duration  --| The time to be converted
    ) return string;

  --| Effects
  --| Converts the time of day or elapsed time, in seconds,
  --| to a string in the format HH:MM:SS.FF.

  --| N/A:  Raises, Requires, Modifies, Errors


-------------------------
procedure Put_Time_of_Day ( --| Put the time of day to the file
    Fyle    : in Text_IO.File_Type;    --| The output file
    Seconds : in Calendar.Day_Duration --| The time to be output
    );

  --| Effects
  --| If Timing = WALL_CLOCK then the time is put to the file in the
  --| format HH:MM:SS.FF. If Timing = RAW then the time of
  --| day is put to the file using new Fixed_IO( Day_Duration ).
  --|
  --| Requires
  --| Fyle must have been previously opened by the calling program.

  --| N/A:  Raises, Modifies, Errors


------------------
procedure Put_Time ( --| Put the time to the file
    Fyle : in Text_IO.File_Type;  --| The output file
    Date : in Calendar.Time       --| The time to be output
    );

  --| Effects
  --| If Timing = WALL_CLOCK then the time is put to the file in the
  --| format MM/DD/YYYY HH:MM:SS.FF. If Timing = RAW then the time of
  --| day is put to the file using new Fixed_IO( Day_Duration ).
  --|
  --| Requires
  --| Fyle must have been previously opened by the calling program.

  --| N/A:  Raises, Modifies, Errors


--------------------
procedure Set_Timing ( --| Set the method of recording timing data

    Timing : Timing_Type  --| The type of timing data to be recorded

    );

  --| Effects
  --| Sets th method of recording timing data to either RAW or Wall_Clock.
  --| If Timing = WALL_CLOCK then the time is put to the file in the
  --| format MM/DD/YYYY HH:MM:SS.FF. If Timing = RAW then the time of
  --| day is put to the file using new Fixed_IO( Day_Duration ).
  --| Overhead for either method may vary from system to system.

  --| N/A:  Raises, Requires, Modifies, Errors


end Time_Library_1;
with TYPE_DEFINITIONS, IMPLEMENTATION_DEPENDENCIES, TIME_LIBRARY_1;
with CALENDAR;
-----------------
package WRITE_LOG is
-----------------

--| Overview
--| Write_Log is an output package used by the Run Time Monitor (RTM)
--| for the Ada Testing and Evaluation Tools. It performs all output
--| to the Execution Log File (ELF) that is used to dynamically record
--| information about programs written in the Ada language. The ELF is
--| used for output by the Run Time Monitor (RTM) to record runtime
--| information about the execution of the Ada program being
--| tested. It is used as input by various report generators which
--| summarize the information and present it in a meaningful format.

--| N/A: Errors, Raises, Modifies, Requires

--  Version         : 5.0
--  Author          : Jeff England
--  Last Modified   : 05/13/85

  use TYPE_DEFINITIONS;            --| Global type declarations for all of
                                   --| the Ada Testing and Analysis Tools.

  use IMPLEMENTATION_DEPENDENCIES; --| Ada Compiler dependencies

  use TIME_LIBRARY_1;              --| For Timing_Type ( Wall_Clock, Raw )

  LOGFILE_ACCESS_ERROR : exception;--| Raised if attempt to:
                                   --|   - open already open file
                                   --|   - put to unopened file
                                   --|   - close unopened file

  --------------------
  procedure CREATE_LOG(--| Creates and opens the ELF for output

    LOGFILE_NAME  : in FILENAME;      --| Name of logfile to be created

    TIMING_METHOD : in TIME_LIBRARY_1.TIMING_TYPE := RAW;
                --| The method of recording timing data

    START_TIME    : in CALENDAR.TIME  --| Program start time

      );

    --| Raises: Logfile_Access_Error

    --| Effects
    --| Creates and opens the ELF for output by the Run Time Monitor.
    --| If the logfile already exists it will be overwritten.
    --| The date and time of the test are written
    --| to the logfile. If the logfile is already open then a
    --| Logfile_Access_Error exception is raised. Any other
    --| Text_IO exceptions that may be raised are allowed to pass
    --| unhandled back to the calling program.

    --| Requires
    --| Logfile_Name must conform to the file naming conventions for
    --| the host computer operating system.

    --| N/A:  Modifies, Errors


  --------------------------------
  procedure PUT_CONFIGURATION_DATA(--| Records configuration info in the ELF

    TOOL_NAME    : in TOOL_NAMES;     --| Name of the tool

    PROGRAM_NAME : in ADA_NAME;       --| Program being tested

    TEST_IDENT   : in TEST_IDENTIFIER --| A unique identifier specified
                                      --| by the user

      );

    --| Raises: Logfile_Access_Error

    --| Effects
    --| Records test configuration information in the logfile. The purpose of
    --| recording this information in the logfile is to internally uniquely
    --| identify the logfile for later use by the report generators. If the
    --| logfile already exists it will be overwritten. If the logfile
    --| is already open then the exception Logfile_Access_Error is raised.
    --| Any other Text_IO exceptions that may  be raised are allowed to
    --| pass unhandled back to the calling program.

    --| Requires
    --| The logfile must have been previously opened via a call to the
    --| procedure Create_Log.

    --| N/A:  Modifies, Errors


  --------------------------
  procedure DEFINE_COMPILATION_UNIT(--| Define a new compilation unit

    COMPILATION_UNIT      : in ADA_NAME; --| Name of the compilation unit

    NUMBER_OF_BREAKPOINTS : in BREAKPOINT_NUMBER_RANGE;
      --| Number of breakpoints in the compilation unit

    LIST_OF_PROCEDURES    : in PROCEDURE_LIST --| Array of names and unit
                                              --| types of all program units
                                              --| in this compilation unit
      );

    --| Raises: Logfile_Access_Error

    --| Effects
    --| Defines a new Compilation Unit and all of its program units
    --| to the execution log file. Subsequent references by the calling
    --| program to program units in the current compilation unit will
    --| be by a unit ID of type Program_Unit where:
    --|
    --|   Unit_Identifier.Program_Unit_Number = offset into List_of_Procedures
    --|
    --| If the logfile has not been previously opened via a call to
    --| the procedure Create_Log then the exception Logfile_Access_Error
    --| is raised.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.

    --| N/A:  Modifies, Errors


  --------------------
  procedure START_UNIT(--| starts the current unit in the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    START_TIME    : in out CALENDAR.TIME  --| Program unit start time

      );

    --| Effects
    --| Puts the program unit and start time to the execution log file.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.

    --| N/A:  Raises, Modifies, Errors


  -------------------
  procedure STOP_UNIT(--| Stops the current unit in the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    STOP_TIME       : in out CALENDAR.TIME  --| Program unit stop time

      );

    --| Effects
    --| Puts the program unit and stop time to the execution log file.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors


  -----------------------
  function STARTING_DELAY(--| Records a delay for the specified unit and
                          --| duration in the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    SECONDS         : in DURATION

      ) return DURATION;

    --| Effects
    --| Records a delay for the specified unit and duration in the
    --| Execution Log File. The length of the Delay is returned to
    --| the calling unit.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors


 ------------------------
  procedure PUT_BREAKPOINT(--| Puts info about the current breakpont to ELF

    BREAKPOINT_TYPE    : in BREAKPOINT_TYPES; --| The type of breakpoint

    UNIT_IDENTIFIER    : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    CURRENT_BREAKPOINT : in BREAKPOINT_NUMBER_RANGE
    --| The breakpoint number assigned by the Source Instrumenter
      );

    --| Effects
    --| Puts the program unit, statement type, and current breakpoint
    --| number to the execution log file.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors


  -----------------------------
  procedure PUT_CALL_PARAMETERS(--| Log AutoPath input parameter list to ELF

    CALL_PARAMETERS : in INPUT_PARAMETER_LIST
    --| The user specified input parameter list

      );

    --| Effects
    --| Logs the calling parameter list for a single execution of the
    --| unit under test by the AutoPath shell.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.

    --| N/A:  Raises, Modifies, Errors


  -------------------
  procedure PUT_VALUE(--| Logs value of integer variable to the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    VARIABLE_NAME   : in STRING;  --| The name of the variable

    INTEGER_VALUE   : in INTEGER  --| The variable's value

      );

    --| Effects
    --| Logs integer values to the execution log file.
    --| Puts the program unit, variable name, and current value.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors


  -------------------
  procedure PUT_VALUE(--| Logs value of Long_Integer variable to the ELF

    UNIT_IDENTIFIER    : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    VARIABLE_NAME      : in STRING;      --| The name of the variable

    LONG_INTEGER_VALUE : in LONG_INTEGER --| The variable's value

      );


    --| Effects
    --| Logs long_integer values to the execution log file.
    --| Puts the program unit, variable name, and current value.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors


  -------------------
  procedure PUT_VALUE(--| Logs value of FLOAT variable to the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
      --| A unique ID assigned by the Source Instrumenter for the current unit

    VARIABLE_NAME   : in STRING; --| The name of the variable

    FLOAT_VALUE     : in FLOAT   --| The variable's value

      );

    --| Effects
    --| Logs floating point values to the execution log file
    --| Puts the program unit, variable name, and current value

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Modifies, Errors


  -------------------
  procedure PUT_VALUE(--| Logs value of Long_Float variable to the ELF

    UNIT_IDENTIFIER  : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    VARIABLE_NAME    : in STRING;     --| The name of the variable

    LONG_FLOAT_VALUE : in LONG_FLOAT  --| The variable's value

      );

    --| Effects
    --| Logs long_float values to the execution log file.
    --| Puts the program unit, variable name, and current value.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors


  -------------------
  procedure PUT_VALUE(--| Logs value of string variable to the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    VARIABLE_NAME   : in STRING; --| The name of the variable

    STRING_VALUE    : in STRING  --| The variable's value

      );

    --| Effects
    --| Logs string values to the execution log file
    --| Puts the program unit, variable name, and current value
    --| This procedure used to log the value of
    --|        strings
    --|        characters
    --|        enumerated data types (including booleans)

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors


  -------------------
  procedure CLOSE_LOG(  --| Closes the execution log file

    ACCUMULATED_OVERHEAD : in DURATION  --| Total accumulated tool overhead

      );

    --| Raises:  Logfile_Access_Error

    --| Effects
    --| Closes the execution log file.
    --| If the logfile has not been previously opened via a call to
    --| the procedure Create_Log then the exception Logfile_Access_Error
    --| is raised.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.

    --| N/A:  Modifies, Errors

end WRITE_LOG;
with TYPE_DEFINITIONS; use TYPE_DEFINITIONS;
with STRING_PKG; use STRING_PKG;
with TEXT_IO; use TEXT_IO;


package RTM_LIST_PACKAGE is

--| Overview
--|      The RTM_List_Package is a subset of the Lists package from Inter-
--| metrics in Cambridge.  It is tailored explicitly for the Run_Time_Monitor.
--| The type of the list objects is Program_Unit_Unique_Identifier, which is
--| declared in Type_Definitions.
--| The procedures and functions allow the RTM to create a list, add to a
--| list, delete an item from the list, read and replace an item after
--| incrementing the Task_Type_Activation_Number, and check for an empty
--| list.

--| N/A: Effects, Requires, Modifies, Raises


--  Mary Koppes  Intermetrics Inc, Huntington Beach,Ca  11-June-85


--   TYPES


  type LIST is private;



-------------------------------------------------------------------------------

  function CREATE --| Return an empty list

  return LIST;


-------------------------------------------------------------------------------


  procedure ADD( --| Add an element to the list

    ELEMENT : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| The Unit_ID being added to the list

    TO_LIST : in out LIST --| List being added to

    );

  --| Effects
  --| Adds  an element onto to the end of the list, To_List.  If
  --| To_List is empty then this may change the value of Element.

  --| Modifies
  --| The "NEXT" field of To_List;


-------------------------------------------------------------------------------


  procedure DELETE_HEAD( --|  Remove the Head element

    THE_LIST : in out LIST --|  The list whose head is being removed

    );

  --| Raises
  --| Empty_List

  --| Effects
  --| This will return the space occupied by the first element in the list
  --| to the heap.  If sharing exists between lists, this procedure could
  --| leave a dangling reference.  If The_List is empty, EmptyList is
  --| raised.


-------------------------------------------------------------------------------



  procedure DELETE( --| Delete an element from the list

    ELEMENT   : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;  --| Elt to be deleted

    FROM_LIST : in out LIST --| List to delete from

    );

  --| Raises
  --| Item_Not_Present

  --| Effects
  --| This procedure walks down the list, From_List, and removes the first
  --| element equal to Element.  If there is not an element equal to
  --| Element, ItemNotPresent is raised.

  --| Modifies
  --| Returns the storage being occupied by the deleted element.


-------------------------------------------------------------------------------


  procedure REPLACE_VALUE( --| Finds element and increments the Task number

    NEW_ELEMENT : in out PROGRAM_UNIT_UNIQUE_IDENTIFIER;

    NEW_LIST    : in out LIST);


  --| Effects
  --| Replace_Value walks through New_List searching for New_Element.
  --| If New_Element is found, the Task_Type_Activation_Number is incremented
  --| in the list element and New_Element is assigned this number too.
  --| The Element is replaced in the list.

  --| Modifies
  --| The specified element.Task_Type_Activation_Number is incremented

-------------------------------------------------------------------------------



  function IS_IN_LIST( --| Checks for the presence of Element in The_List.

    THE_LIST : in LIST;

    ELEMENT  : in PROGRAM_UNIT_UNIQUE_IDENTIFIER

    ) return BOOLEAN;


  --| Effects
  --| Walks down the list The_List looking for an element whose value is
  --| Element.


-------------------------------------------------------------------------------


  function IS_EMPTY( --| Checks for an empty list

    THE_LIST : in LIST) return BOOLEAN;



-------------------------------------------------------------------------------


  function EQUAL( --| Compares X to Y and returns TRUE if they are equal

    X, Y : in PROGRAM_UNIT_UNIQUE_IDENTIFIER) return BOOLEAN;


-------------------------------------------------------------------------------


private
  type LIST_ELEMENT;
  type LIST is access LIST_ELEMENT;
  type LIST_ELEMENT is
    record
      INFO         : PROGRAM_UNIT_UNIQUE_IDENTIFIER;
      NEXT_ELEMENT : LIST;
    end record;


end RTM_LIST_PACKAGE;
with IMPLEMENTATION_DEPENDENCIES; use IMPLEMENTATION_DEPENDENCIES;
with TYPE_DEFINITIONS;            use TYPE_DEFINITIONS;
with STRING_PKG;                  use STRING_PKG;

------------------------
package RUN_TIME_MONITOR is
------------------------


--| Overview
--|     This is the Run Time Monitor package for the Ada Test and
--| Analysis Tool Set (ATETS). Its purpose is to dynamically record
--| information about the execution of programs written in the
--| Ada language. The Run Time Monitor is common to the following
--| ATETS tools:
--|
--|   1) Path     - Path Analyzer
--|   2) AutoPath - Automatic Path Analyzer
--|   3) SMART    - Self Metric Analysis and Reporting Tool
--|   4) Profile  - Performance Analyzer
--|
--|     The Run Time Monitor is implemented as a package that is
--| WITHed and USEd by the Ada program being tested.  All WITHs,
--| USEs, and calls to the Run Time Monitor procedures are inserted
--| into the target Ada program by the ATETS Source Instrumenter.
--| The execution data about each Ada program unit that has been
--| instrumented is recorded at runtime in an Execution Log File (ELF).
--|
--|     The user must select the recording options to be used at
--| run time by specifying one of the above tools as a runtime
--| parameter. Additionally, the user may specify the name of the
--| log file to be generated during execution of the target Ada
--| program. If no log file name is specified by the user then the
--| default log file name will be <toolname>".LOG".  The Run Time
--| Monitor checks for the existance of the logfile and if it exists
--| the user must choose to write over it, append to it or select
--| a new filename.
--|
--| Requires
--| The Ada program to be tested must have been instrumented by
--| the Ada Source Instrumenter to insert "hooks", or calls, to the
--| the Runtime Monitor.  Information about each program unit in an
--| instrumented compilation unit must be recorded in the ELF via
--| a call to the procedure Unit_Information prior to execution of
--| the program unit. An Ada program unit is a procedure, function,
--| package, task, or generic.

--| N/A:  Errors, Raises, Modifies

--  Version         : 5.0
--  Author          : Mary Koppes  Intermetrcs, Inc.
--  Initial Release : 03/23/85
--  Last Modified   : 07/16/85


  task RTM is

    --| Overview
    --| The Run Time Monitor has been implemented as a task in order
    --| to synchronize calls from the instrumented program and prevent
    --| interleaving of output to th log file.


    ----------------------
    entry UNIT_INFORMATION( --| Defines a compilation unit to the RTM

      COMPILATION_UNIT   : in ADA_NAME;
      --| The name of the compilation unit

      BREAKPOINT_NUMBER  : in BREAKPOINT_NUMBER_RANGE;
      --| Total number of break points in the compilation unit
      --| assigned by the Source Instrumenter

      LIST_OF_PROCEDURES : in PROCEDURE_LIST
      --| A list of the names of all of the program units in
      --| the compilation unit

        );

    --| Effects
    --| Unit_Information is the procedure used to define information about
    --| each program unit in a compilation unit.  If the program unit is
    --| the first program unit to be defined by a call to Unit_Information
    --| the user is asked to enter the Tool_Name, Logfile Name and a
    --| unique test identification string, if desired.  The logfile is
    --| opened.  The rest of the information is not recorded to the logfile
    --| at this time.  A unique identifier is created by the Source
    --| Instrumenter for each program unit which provides a mechanism for
    --| handling overloading of unit names. This procedure defines the
    --| correlation between program unit names and program unit ID's
    --| assigned by the Source Instrumenter. The information is recorded
    --| in the execution log file for later use by the report generators.

    --| Requires
    --| Each program unit must be previously defined to the Runtime Monitor
    --| by a call to this procedure prior to being "entered" or "exited."

    --| Raises
    --| User_Input_Error

    --| N/A:  Errors, Modifies


    -------------------
    entry ENTERING_UNIT( --| Logs program unit and start time to ELF

      ENCLOSING_UNIT : in STRING_TYPE;
      --| The name of the compilation unit

      UNIT_NUMBER    : in PROGRAM_UNIT_NUMBER_RANGE;
      --| The Program Unit Number

      UNIT_TYPE      : in PROGRAM_UNIT_TYPE;
      --| The type of unit ( procedure, function task generic or package )

      TASK_NUMBER    : in out TASK_TYPE_ACTIVATION_NUMBER_RANGE
      --| A unique number assigned by the Runtime Monitor

      );

    --| Effects
    --| Entering_Unit first creates a Unit_Identifier from the
    --| four procedure parameters.  If the program unit is
    --| the first program unit to be entered outside of Package
    --| initialization and its UNIT_TYPE is PROCEDURE_TYPE, then
    --| it is assumed to be the main program unit.
    --| When the main procedure is entered, the Tool_Name, Test ID and
    --| the Main procedure name are written to the logfile.
    --| For each program unit entered, the Logfile_Key "Unit_START"
    --| and the unit ID assigned by the Source Instrumenter (Unit_Identifier)
    --| are recorded in the log file by calling the Start_Unit procedure
    --| which is part of the Write_Log package.
    --| If the unit being entered is a task then if the Task_List has not
    --| been created it is and the ID is added to the list.  The purpose of
    --| this list is to maintain the Task_Type_Activation_Number. This
    --| number is initially 1 and each time a task of the same type is
    --| added to the Task_List, the activation number is incremented.
    --| The Task_Type_Activation_Number is written to the logfile and is
    --| used by the ATETS report generators to determine which copy of a
    --| task is executing.  The IN OUT parameter, Task_Number is also
    --| updated to pass back to the calling program.

    --| Requires
    --| A program unit must be previously defined to the Runtime Monitor
    --| via a call to the procedure Unit_Information prior to being "entered."

    --| N/A:  Raises, Errors, Modifies


    ------------------
    entry EXITING_UNIT( --| Logs program unit and stop time to ELF

      UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER
      --| A unique ID assigned by the Source Instrumenter

      );

    --| Effects
    --| Exiting_Unit records to the logfile the Logfile_Key "UNIT_STOP"
    --| and the Unit_Identifier assigned by the Source Instrumenter.
    --| If Package Initialization is not in progress, then the
    --| Unit_Identifier is deleted from the Entered_Unit_List.
    --| The main program unit is "held" from exiting until all
    --| other program units have terminated. If the unit being is
    --| the main program unit then the logfile is closed and if
    --| the user has chosen to append to an existing logfile
    --| it is done at this time.

    --| Requires
    --| The program unit must be previously defined to the RTM via a call
    --| to the procedure Unit_Information.
    --| The program unit must have been previously "entered" via a call to
    --| the procedure Entering_Unit prior to being "exited."

    --| Raises
    --| Unit_Exit_Error

    --| N/A:  Errors, Modifies


    -------------------
    entry BREAKPOINT_AT( --| Process program breakpoint

      UNIT_IDENTIFIER    : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
      --| A unique ID assigned by the Source Instrumenter

      BREAKPOINT_TYPE    : in BREAKPOINT_TYPES;
      --| The type of breakpoint

      CURRENT_BREAKPOINT : in BREAKPOINT_NUMBER_RANGE
      --| Breakpoint number assigned by Source Instrumenter

      );

    --| Effects
    --| case TOOL_NAME
    --|   when PATH_TOOL | AUTOPATH_TOOL | SMART_TOOL =>
    --|        log program unit ID (Unit_ID)
    --|        log type of breakpoint (Breakpoint_Type)
    --|        log the current breakpoint number (Current_Breakpoint)
    --|   when PROFILE_TOOL => null;  -- no action for PROFILE
    --|   when others  => null;
    --| end case;

    --| Requires
    --| The program unit must be previously defined to the RTM via a call
    --| to the procedure Unit_Information.
    --| The program unit must have been previously "entered" via a call to
    --| the procedure Entering_Unit.

    --| N/A:  Raises, Errors, Modifies


    -------------------------
    entry PUT_CALL_PARAMETERS(--| Log AutoPath input parameter list to ELF

      CALL_PARAMETERS : in INPUT_PARAMETER_LIST
      --| The user specified input parameter list

      );

    --| Effects
    --| Logs the calling parameter list for a single execution of the
    --| unit under test by the AutoPath shell.

    --| N/A:  Raises, Requires, Modifies, Errors


    ---------------
    entry PUT_VALUE(--| Logs value of integer variable to the ELF

      UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
      --| A unique ID assigned by the Source Instrumenter for the current unit

      VARIABLE_NAME   : in STRING;  --| The name of the variable

      INTEGER_VALUE   : in INTEGER  --| The variable's value

      );

    --| Effects
    --| Logs integer values to the execution log file.
    --| Puts the program unit, variable name, and current value.

    --| N/A:  Raises, Requires, Modifies, Errors


    ---------------
    entry PUT_VALUE(--| Logs value of Long_Integer variable to the ELF

      UNIT_IDENTIFIER    : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
      --| A unique ID assigned by the Source Instrumenter for the current unit

      VARIABLE_NAME      : in STRING;      --| The name of the variable

      LONG_INTEGER_VALUE : in LONG_INTEGER --| The variable's value

      );

    --| Effects
    --| Logs long_integer values to the execution log file.
    --| Puts the program unit, variable name, and current value.

    --| N/A:  Raises, Requires, Modifies, Errors


    ---------------
    entry PUT_VALUE(--| Logs value of FLOAT variable to the ELF

      UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
      --| A unique ID assigned by the Source Instrumenter for the current unit

      VARIABLE_NAME   : in STRING; --| The name of the variable

      FLOAT_VALUE     : in FLOAT   --| The variable's value

      );

    --| Effects
    --| Logs floating point values to the execution log file
    --| Puts the program unit, variable name, and current value

    --| N/A:  Raises, Requires, Modifies, Errors


    ---------------
    entry PUT_VALUE(--| Logs value of Long_Float variable to the ELF

      UNIT_IDENTIFIER  : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
      --| A unique ID assigned by the Source Instrumenter for the current unit

      VARIABLE_NAME    : in STRING;     --| The name of the variable

      LONG_FLOAT_VALUE : in LONG_FLOAT  --| The variable's value

      );

    --| Effects
    --| Logs long_float values to the execution log file.
    --| Puts the program unit, variable name, and current value.

    --| N/A:  Raises, Requires, Modifies, Errors


    ---------------
    entry PUT_VALUE(--| Logs value of string variable to the ELF

      UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
      --| A unique ID assigned by the Source Instrumenter for the current unit

      VARIABLE_NAME   : in STRING; --| The name of the variable

      STRING_VALUE    : in STRING  --| The variable's value

      );

    --| Effects
    --| Logs string values to the execution log file
    --| Puts the program unit, variable name, and current value
    --| This procedure used to log the value of
    --|        strings
    --|        characters
    --|        enumerated data types (including booleans)

    --| N/A:  Raises, Requires, Modifies, Errors


  -----------------
  entry START_DELAY(--| Records a delay for the specified unit and
                          --| duration in the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    SECONDS         : in DURATION
    --| The length of the delay in seconds

      );

    --| Effects
    --| Records a delay for the specified unit and duration in the
    --| Execution Log File. This entry is not called directly by the
    --| the instrumented program. It is called by the function
    --| Starting_Delay.

    --| N/A:  Raises, Requires, Modifies, Errors


  end RTM;


  -----------------------
  function STARTING_DELAY(--| Records a delay for the specified unit and
                          --| duration in the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    SECONDS         : in DURATION

      ) return DURATION;

    --| Effects
    --| Records a delay for the specified unit and duration in the
    --| Execution Log File. The length of the Delay is returned to
    --| the calling unit. This unit is implemented as a function
    --| to enable trapping of delay times in timed entry statements.

    --| N/A:  Raises, Requires, Modifies, Errors


end RUN_TIME_MONITOR;
with IMPLEMENTATION_DEPENDENCIES; use IMPLEMENTATION_DEPENDENCIES;

with TYPE_DEFINITIONS; use TYPE_DEFINITIONS;

with STRING_PKG; use STRING_PKG;

with WRITE_LOG; use WRITE_LOG;

with RTM_LIST_PACKAGE; use RTM_LIST_PACKAGE;

with TEXT_IO; use TEXT_IO;

with TIME_LIBRARY_1; use TIME_LIBRARY_1;

with FILE_MANAGER; use FILE_MANAGER;

with Calendar;

-----------------------------
package body RUN_TIME_MONITOR is
-----------------------------


-- Version         : 5.0
-- Author          : Mary Koppes  Intermetrics, Inc.
-- Initial release : 05/01/85
-- Last modified   : 07/18/85


-----------------------------------------------------------------------

-- Variables to be used by the RTM procedures


  TASK_LIST : LIST;
  --| To keep track of the tasks of task type which have been entered.
  --| This list is used to maintain the Task_Type_Activation_Number,
  --| which is incremented each time the task type is "Entered" via
  --| Entering_Unit.

  LOGFILE_OPEN : BOOLEAN := FALSE;
  --| To flag whether the logfile has been opened for this execution of RTM

  PACKAGE_INITIALIZATION_IN_PROGRESS : BOOLEAN := FALSE;
  --| To flag whether a package is running.

  MAIN_PROCEDURE_ENTERED : BOOLEAN := FALSE;
  --| Flags whether main procedure has been entered

  FIRST_TASK_ENTERED     : BOOLEAN := FALSE;
  --| Flags whether a task has been entered.

  LOGFILE_NAME        : FILENAME;  --| Logfile for this execution
  APPEND_LOGFILE_NAME : FILENAME;  --| Name of the logfile to append to

  APPEND_LOGFILE : BOOLEAN := FALSE;
  --| Flags if the user decided to append. If TRUE then the
  --| logfile is given a temp name and then appended to
  --| Append_Logfile_Name when the program is finished
  --| executing.

  TOOL_IN_USE : TOOL_NAMES; --| The tool being used during this execution

  USER_INPUT_ERROR   : exception;
  --| Raised when user input is bad, not handled by the RTM so it will
  --| propagate back to the instrumented program and cause the program
  --| to end.

  TEST_IDENTIFICATION  : TEST_IDENTIFIER;
  STOP_WATCH           : CALENDAR.TIME;
  ACCUMULATED_OVERHEAD : DURATION := 0.00;

  package TOOL_IO is
    new ENUMERATION_IO(TOOL_NAMES);
  use TOOL_IO;

  --------------------
  procedure QUERY_USER(
  --| Asks the user for the Tool_Name, Logfile_Name, and Test ID

    TOOL_NAME        : in out TOOL_NAMES;
    --| The tool being used during this execution

    LOGFILE_NAME     : in out FILENAME;
    --| The name of the log file

    TEST_DESCRIPTION : out TEST_IDENTIFIER;
    --| User may may enter a brief description of test

    RETURN_ERROR     : out BOOLEAN
    --| Flags a User Input Error

    ) is

  --| Algorithm
  --| Query_User prompts the user for the Tool he wishes to run.  The user must
  --| enter a valid toolname or he will continue to be asked for the toolname.
  --| Next he is prompted for the logfile name. If no logfile name is entered,
  --| the default "Toolname.LOG" is used.  Query_User checks for the existence
  --| of the logfile and if it does exist, the user is asked whether he wishes
  --| to Overwrite the file, Append to the file, or Enter a new filename.
  --| Finally, the user is asked to enter a unique test identification, which
  --| is an Ada string that describes the test being run.  The default is
  --| "Toolname Report".


    MAX_STRING_SIZE : constant NATURAL := 80;
    INPUT_STRING    : STRING(1 .. MAX_STRING_SIZE);
    --| Variable to hold user input from a Get_Line.

    STRING_LENGTH   : NATURAL := 0;
    --| Last char in string (length of string) returned by Get_Line.

    ZERO_LENGTH     : constant NATURAL := 0;


    --  Default Logfile names

    PATH_LOGFILE_NAME      : constant STRING := "Path.Log";
    AUTOPATH_LOGFILE_NAME  : constant STRING := "Autopath.log";
    SMART_LOGFILE_NAME     : constant STRING := "Smart.Log";
    PROFILE_LOGFILE_NAME   : constant STRING := "Profile.Log";

    TEMPORARY_LOGFILE_NAME : constant STRING := "MRKZZZ.LOG";
    --| Temporary name for logfile if it is to be appended to existing file

    -- The following are the defaults for the Test Id
    DEFAULT_IDENTIFICATION : constant array
      (TOOL_NAMES range PATH_TOOL .. PROFILE_TOOL) of STRING(1 .. 30) :=
      ("Path Analysis Report          ", "Automatic Path Analysis Report",
       "Self Metric Analysis Report   ", "Performance Analysis Report   ");

    BAD_USER_INPUT : BOOLEAN := TRUE;  --| General loop flag

    TEST_FILE      : FILE_TYPE;

    type USER_FILE_OPTIONS is (E, O, A);

    FILE_OPTION    : USER_FILE_OPTIONS;

    ENTER_NEW_NAME : constant USER_FILE_OPTIONS := E;
    OVERWRITE_FILE : constant USER_FILE_OPTIONS := O;
    APPEND_TO_FILE : constant USER_FILE_OPTIONS := A;

    package INT_IO is
      new INTEGER_IO(INTEGER);  -- debug
    use INT_IO;

    ------------------------
    function GET_USER_OPTION
    --| Get the user's option if the specified logfile exists.

    return USER_FILE_OPTIONS is

    --| Algorithm
    --| Get_User_Option is one loop which asks the user whether he wishes
    --| to Overwrite an existing logfile, Append to an existing logfile,
    --| or Enter a new filename.  This option is returned to the caller.


      CHOSEN_OPTION : USER_FILE_OPTIONS;

      package OPTION_IO is
        new ENUMERATION_IO(USER_FILE_OPTIONS);
      use OPTION_IO;

    begin
      loop

        -- infinite loop until function return
        begin

          NEW_LINE;
          PUT_LINE("File already exists!!! Do you wish to:");
          PUT_LINE("     E = Enter a New Filename");
          PUT_LINE("     O = Overwrite existing file");
          PUT_LINE("     A = Append to the existing file");
          NEW_LINE;
          PUT("Enter Option ===> ");
          GET(CHOSEN_OPTION);

          --  Get_Line to get rid of the carriage return
          GET_LINE(INPUT_STRING, STRING_LENGTH);
          return CHOSEN_OPTION;

        exception
          when DATA_ERROR =>
            PUT_LINE("Data_Error!! Illegal Option, Try again.");
            --  Get_Line to flush the bad input
            GET_LINE(INPUT_STRING, STRING_LENGTH);

          when others =>
            raise USER_INPUT_ERROR;
        end;
      end loop;

    end GET_USER_OPTION;



  begin

    STRING_PKG.MARK;  --  For Heap Management

    -- First get the Tool_Name, loop until input is correct
    while BAD_USER_INPUT loop
      begin

        NEW_LINE;
        NEW_LINE;

        PUT_LINE("Enter Tool Type : PATH_TOOL, AUTOPATH_TOOL,");
        PUT_LINE("                  SMART_TOOL, or PROFILE_TOOL)");
        PUT("-----> ");
        GET(TOOL_NAME);

        -- Get_Line to flush out the Carriage Return
        GET_LINE(INPUT_STRING, STRING_LENGTH);
        BAD_USER_INPUT := FALSE;

      exception
        when DATA_ERROR =>
          PUT_LINE(" Data_Error !! Illegal Tool Name, try again");

        when others =>
          raise USER_INPUT_ERROR;

      end;
    end loop;


    NEW_LINE;
    NEW_LINE;
    BAD_USER_INPUT := TRUE;

    while BAD_USER_INPUT loop
      begin
        NEW_LINE;
        PUT_LINE("Enter Logfile Name, Null for Default");
        PUT("-----> ");
        GET_LINE(INPUT_STRING, STRING_LENGTH);

        if STRING_LENGTH > ZERO_LENGTH then
          LOGFILE_NAME := MAKE_PERSISTENT(INPUT_STRING(1 .. STRING_LENGTH));

        else  -- length is zero therefore use the default name

          case TOOL_NAME is

            when PATH_TOOL =>
              STRING_LENGTH := PATH_LOGFILE_NAME'LAST;
              INPUT_STRING(1 .. STRING_LENGTH) := PATH_LOGFILE_NAME;
              LOGFILE_NAME := MAKE_PERSISTENT(PATH_LOGFILE_NAME);

            when AUTOPATH_TOOL =>
              STRING_LENGTH := AUTOPATH_LOGFILE_NAME'LAST;
              INPUT_STRING(1 .. STRING_LENGTH) := AUTOPATH_LOGFILE_NAME;
              LOGFILE_NAME := MAKE_PERSISTENT(AUTOPATH_LOGFILE_NAME);

            when SMART_TOOL =>
              STRING_LENGTH := SMART_LOGFILE_NAME'LAST;
              INPUT_STRING(1 .. STRING_LENGTH) := SMART_LOGFILE_NAME;
              LOGFILE_NAME := MAKE_PERSISTENT(SMART_LOGFILE_NAME);

            when PROFILE_TOOL =>
              STRING_LENGTH := PROFILE_LOGFILE_NAME'LAST;
              INPUT_STRING(1 .. STRING_LENGTH) := PROFILE_LOGFILE_NAME;
              LOGFILE_NAME := MAKE_PERSISTENT(PROFILE_LOGFILE_NAME);

            when others =>
              PUT_LINE("Logfile_Name Case Statement: User Input Error!!");
              raise USER_INPUT_ERROR;

          end case;

        end if;

        --  Need begin-end block for exception handling
        --  must check to see if a logfile with the specified name exists

        declare
          TEMPORARY_FILENAME : STRING(1 .. STRING_LENGTH) := INPUT_STRING(1 ..
            STRING_LENGTH);

        begin
          -- Open the file, if Name_Error is raised then the file
          -- does not exist,  If no exception raised must ask
          -- the user what he wishes to do...
          OPEN(TEST_FILE, OUT_FILE, TEMPORARY_FILENAME);
          CLOSE(TEST_FILE);
          FILE_OPTION := GET_USER_OPTION;

          case FILE_OPTION is
            when ENTER_NEW_NAME =>
              null;  -- do nothing so the loop will work

            when OVERWRITE_FILE =>
              -- Set Bad_User_Input to TRUE to make the loop exit
              BAD_USER_INPUT := FALSE;

            when APPEND_TO_FILE =>
              APPEND_LOGFILE_NAME := LOGFILE_NAME;
              LOGFILE_NAME := MAKE_PERSISTENT(TEMPORARY_LOGFILE_NAME);
              APPEND_LOGFILE := TRUE;
              BAD_USER_INPUT := FALSE;

            when others =>
              raise USER_INPUT_ERROR;

          end case;

        exception
          when NAME_ERROR =>
            -- File does not exist so it's ok to create it
            BAD_USER_INPUT := FALSE;

        end;

      end;
    end loop;

    -- Get the Test Identification string from the user.
    -- The default will be  TOOLNAME & " Report"

    PUT_LINE("Enter a unique Test Identification, Null for default.");
    GET_LINE(INPUT_STRING, STRING_LENGTH);

    if STRING_LENGTH > ZERO_LENGTH then
      TEST_DESCRIPTION := MAKE_PERSISTENT(INPUT_STRING(1 .. STRING_LENGTH));

    else
      TEST_DESCRIPTION := MAKE_PERSISTENT(DEFAULT_IDENTIFICATION(TOOL_NAME));

    end if;

    STRING_PKG.RELEASE;  -- Release the Heap space

  end QUERY_USER;


  --------------------------
  procedure OPEN_THE_LOGFILE --| Opens the log file for output

      is

  --| Algorithm
  --| The Query_User procedure is
  --| called to prompt the user for the Toolname, Logfile name and a
  --| unique Test Identification string and the logfile is opened.

    QUERY_ERROR     : BOOLEAN := FALSE; --| Flags bad user input
    TIMING_METHOD   : TIME_LIBRARY_1.TIMING_TYPE := RAW;

  begin

    QUERY_USER(TOOL_IN_USE, LOGFILE_NAME, TEST_IDENTIFICATION, QUERY_ERROR);

    if QUERY_ERROR then
      raise USER_INPUT_ERROR;
    end if;

    -- The arguments have been decoded, now open the logfile.
    CREATE_LOG(LOGFILE_NAME, TIMING_METHOD, STOP_WATCH);

    LOGFILE_OPEN := TRUE;

  end OPEN_THE_LOGFILE;


  -------------
  task body RTM is

  --| Effects
  --| The external interface to the Run Time Monitor has been
  --| implemented as a task in order to synchronize calls from
  --| the instrumented program and prevent interleaving of
  --| output to the log file

    use CALENDAR;

    UNIT_IDENTIFIER : PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    MAIN_PROGRAM    : PROGRAM_UNIT_UNIQUE_IDENTIFIER;

    OK_TO_TERMINATE : BOOLEAN := FALSE; --| Goes TRUE when no more active units
    SECS            : DURATION;         --| The length of a delay in seconds
    ACTIVE_UNITS    : NATURAL := 0;     --| The number of active program units
    ENTRY_TIME      : CALENDAR.TIME;    --| Unit entry time adjusted for ovhd
    Exit_TIME       : CALENDAR.TIME;    --| Unit exit time adjusted for ovhd

    UNIT_EXIT_ERROR : exception;

  begin

    loop

      select

        -----------------------
        accept UNIT_INFORMATION( --| Defines a compilation unit to the RTM

          COMPILATION_UNIT   : in ADA_NAME;
          --| The name of the compilation unit

          BREAKPOINT_NUMBER  : in BREAKPOINT_NUMBER_RANGE;
          --| Total number of break points in the compilation unit
          --| assigned by the Source Instrumenter

          LIST_OF_PROCEDURES : in PROCEDURE_LIST
          --| A list of the names of all of the program units in
          --| the compilation unit

            ) do

          --| Algorithm
          --| If the logfile is not open then the Query_User procedure is
          --| called to prompt the user for the Toolname, Logfile name and a
          --| unique Test Identification string and the logfile is opened.
          --| Define_Compilation_Unit is invoked to define the program unit
          --| for the current execution.

          -- Stop the clock immediately
          STOP_WATCH := CLOCK;

          if not LOGFILE_OPEN then

            OPEN_THE_LOGFILE;

          end if;

          -- Write the information to the Logfile

          DEFINE_COMPILATION_UNIT(COMPILATION_UNIT, BREAKPOINT_NUMBER,
              LIST_OF_PROCEDURES);

          -- Calculate the amount of time required to execute the
          -- rendezvous and add it to the accumulated tool overhead
          ACCUMULATED_OVERHEAD := ACCUMULATED_OVERHEAD + (CLOCK - STOP_WATCH);

        end UNIT_INFORMATION;

      or
        --------------------
        accept ENTERING_UNIT( --| Logs program unit and start time to ELF

          ENCLOSING_UNIT : in STRING_TYPE;
          --| The name of the compilation unit

          UNIT_NUMBER    : in PROGRAM_UNIT_NUMBER_RANGE;
          --| The Program Unit Number

          UNIT_TYPE      : in PROGRAM_UNIT_TYPE;
          --| The type of unit ( procedure, function task generic or package )

          TASK_NUMBER    : in out TASK_TYPE_ACTIVATION_NUMBER_RANGE
          --| A unique number assigned by the Runtime Monitor

            ) do

          --| Algorithm
          --| First, the number of active units is incremented by 1.
          --| A Unit_Identifier record is formed by joining all input
          --| parameters. If Unit_Type = Package or Generic then
          --| Package_Initialization_In_Progress is set to TRUE.
          --| If Unit_Type = Task, then if the Task_List has not already
          --| been created it is created.  Unit_Identifier is added to the
          --| task list. If Task_List exists, it is checked to see if the
          --| Unit_Identifier is contained in the list and if it is in the
          --| list, Replace_Value is invoked to increment the
          --| Task_Type_Activation_Number.  If it is not in the list, it
          --| is added. Next, if the main procedure has not been entered
          --| and the unit being entered is the main procedure, then the
          --| Unit_Identifier is saved and Main_Procedure_Entered is set TRUE.
          --| Put_Configuration_Data is invoked to write the Test information
          --| to the logfile. Start_Unit is invoked to enter the Unit_Id
          --| into the logfile.

          -- Stop the clock immediately and calculate the adjusted
          -- entry time for this program unit
          STOP_WATCH := CLOCK;
          ENTRY_TIME := STOP_WATCH - ACCUMULATED_OVERHEAD;

          UNIT_IDENTIFIER := (ENCLOSING_UNIT, UNIT_NUMBER,
                              UNIT_TYPE, TASK_NUMBER);

          ACTIVE_UNITS := ACTIVE_UNITS + 1;

          if not LOGFILE_OPEN then
            OPEN_THE_LOGFILE;
          end if;


          case UNIT_TYPE is

            when TASK_TYPE =>
              --  Must set the Task_Type_Activation_Number.  First check to
              --  See if the Task_List has been created.  If not create it.
              if not FIRST_TASK_ENTERED then

                TASK_LIST := CREATE;         -- Create the list
                FIRST_TASK_ENTERED := TRUE;  -- Flag that it has been created

                ADD(UNIT_IDENTIFIER, TASK_LIST);

              elsif IS_IN_LIST(TASK_LIST, UNIT_IDENTIFIER) then
                -- If the Task is already in the list then increment the
                -- Task_Activation number to indicate a new copy.
                -- This number is passed back to the instrumented code
                -- via the IN OUT parm Unit_Identifier.

                REPLACE_VALUE(UNIT_IDENTIFIER, TASK_LIST);
                -- Set Task_Number to send it back to the caller
                TASK_NUMBER := UNIT_IDENTIFIER.TASK_TYPE_ACTIVATION_NUMBER;

              else
                -- There is not another copy in the list so the
                -- activation number = 1;
                ADD(UNIT_IDENTIFIER, TASK_LIST);

              end if;

            when PROCEDURE_TYPE | FUNCTION_TYPE =>

              if not MAIN_PROCEDURE_ENTERED and
                 not PACKAGE_INITIALIZATION_IN_PROGRESS and
                 UNIT_IDENTIFIER.PROGRAM_UNIT_NUMBER = 1 then

                -- This must be the main procedure
                MAIN_PROCEDURE_ENTERED := TRUE;
                MAIN_PROGRAM := UNIT_IDENTIFIER;

                --  Write the Configuration data to the log
                PUT_CONFIGURATION_DATA(
                  TOOL_IN_USE,
                  UNIT_IDENTIFIER.ENCLOSING_UNIT_IDENTIFIER,
                  TEST_IDENTIFICATION);

              end if;

            when others =>
              PACKAGE_INITIALIZATION_IN_PROGRESS := TRUE;

          end case;

          -- Record the starting unit in the log file. The starting
          -- time must be adjusted for accumulated tool overhead
          START_UNIT(UNIT_IDENTIFIER, ENTRY_TIME);

          -- Calculate the amount of time required to execute this
          -- rendezvous and add it to the accumulated tool overhead
          ACCUMULATED_OVERHEAD := ACCUMULATED_OVERHEAD + (CLOCK - STOP_WATCH);

        end ENTERING_UNIT;

      or
        ------------------
        accept EXITING_UNIT( --| Logs program unit and stop time to ELF

          UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER
          --| A unique ID assigned by the Source Instrumenter

            ) do

          --| Algorithm
          --| If Package_Initialization_In_Progress := FALSE and
          --| Main_Procedure_Entered = TRUE, then the Unit_ID is deleted
          --| from Entered_List.  If the list is empty, the logfile is closed.
          --| If Unit_Type = Package, Package_Initialization_In_Progress is
          --| set to FALSE.

          -- Stop the clock immediately and calculate the adjusted
          -- exit time for this program unit
          STOP_WATCH := CLOCK;
          EXIT_TIME  := STOP_WATCH - ACCUMULATED_OVERHEAD;

          ACTIVE_UNITS := ACTIVE_UNITS - 1;

          if UNIT_IDENTIFIER.UNIT_TYPE = PACKAGE_TYPE then
            PACKAGE_INITIALIZATION_IN_PROGRESS := FALSE;
          end if;

          if MAIN_PROCEDURE_ENTERED then

            -- Do not stop the main procedure until all other
            -- units have completed execution
            if not EQUAL(UNIT_IDENTIFIER, MAIN_PROGRAM) then

              -- The main procedure has been entered but this isn't it.
              -- It's OK to terminate it.
              -- Record the exiting unit in the log file. The exit
              -- time must be adjusted for accumulated tool overhead
              STOP_UNIT(UNIT_IDENTIFIER, EXIT_TIME);
            end if;


            -- When all units have been terminated, stop the main
            -- program unit, close the log file, and signal the
            -- RTM task that it is OK to terminate execution

            if ACTIVE_UNITS = 0 then
              -- Record the exiting unit in the log file. The exit
              -- time must be adjusted for accumulated tool overhead
              STOP_UNIT(MAIN_PROGRAM, EXIT_TIME);
              CLOSE_LOG(ACCUMULATED_OVERHEAD);

              -- If this log file was supposed to be appended to another
              -- log file then do so
              if APPEND_LOGFILE then
                APPEND(VALUE(LOGFILE_NAME), VALUE(APPEND_LOGFILE_NAME));
              end if;

              OK_TO_TERMINATE := TRUE;

            end if;

          else

            -- The main procedure has not been entered yet
            -- Record the exiting unit in the log file. The exit
            -- time must be adjusted for accumulated tool overhead
            STOP_UNIT(UNIT_IDENTIFIER, EXIT_TIME);

          end if;

          -- Calculate the amount of time required to execute the
          -- rendezvous and add it to the accumulated tool overhead
          ACCUMULATED_OVERHEAD := ACCUMULATED_OVERHEAD + (CLOCK - STOP_WATCH);

        end EXITING_UNIT;

      or
        --------------------
        accept BREAKPOINT_AT( --| Process program breakpoint

          UNIT_IDENTIFIER    : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
          --| A unique ID assigned by the Source Instrumenter

          BREAKPOINT_TYPE    : in BREAKPOINT_TYPES;
          --| The type of breakpoint

          CURRENT_BREAKPOINT : in BREAKPOINT_NUMBER_RANGE
          --| Breakpoint number assigned by Source Instrumenter

            ) do

          --| Algorithm
          --| The Put_Breakpoint procedure is called for all tools except
          --| Profile_Tool.

          case TOOL_IN_USE is
            when PATH_TOOL .. SMART_TOOL =>
              PUT_BREAKPOINT(BREAKPOINT_TYPE, UNIT_IDENTIFIER,
                             CURRENT_BREAKPOINT);

            when others =>
              null;

          end case;

        end BREAKPOINT_AT;

      or
        --------------------------
        accept PUT_CALL_PARAMETERS(--| Log AutoPath input parameter list to ELF

          CALL_PARAMETERS : in INPUT_PARAMETER_LIST
          --| The user specified input parameter list

            ) do

          --| Effects
          --| Logs the calling parameter list for a single execution of the
          --| unit under test by the AutoPath shell.

          --| N/A:  Raises, Requires, Modifies, Errors

          if TOOL_IN_USE = AUTOPATH_TOOL then
            WRITE_LOG.PUT_CALL_PARAMETERS(CALL_PARAMETERS);
          end if;
        end PUT_CALL_PARAMETERS;

      or
        ----------------
        accept PUT_VALUE(--| Logs value of integer variable to the ELF

          UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
          --| A unique ID assigned by the Source Instrumenter for
          --| the current unit

          VARIABLE_NAME   : in STRING;  --| The name of the variable

          INTEGER_VALUE   : in INTEGER  --| The variable's value

            ) do

          --| Effects
          --| Logs integer values to the execution log file.
          --| Puts the program unit, variable name, and current value.

          --| N/A:  Raises, Requires, Modifies, Errors

          if TOOL_IN_USE = SMART_TOOL then
            WRITE_LOG.PUT_VALUE(UNIT_IDENTIFIER, VARIABLE_NAME, INTEGER_VALUE);
          end if;

        end PUT_VALUE;

      or
        ----------------
        accept PUT_VALUE(--| Logs value of Long_Integer variable to the ELF

          UNIT_IDENTIFIER    : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
          --| A unique ID assigned by the Source Instrumenter for
          --| the current unit

          VARIABLE_NAME      : in STRING;      --| The name of the variable

          LONG_INTEGER_VALUE : in LONG_INTEGER --| The variable's value

            ) do

          --| Effects
          --| Logs long_integer values to the execution log file.
          --| Puts the program unit, variable name, and current value.

          --| N/A:  Raises, Requires, Modifies, Errors

          if TOOL_IN_USE = SMART_TOOL then
            WRITE_LOG.PUT_VALUE(UNIT_IDENTIFIER, VARIABLE_NAME,
                                LONG_INTEGER_VALUE);
          end if;

        end PUT_VALUE;

      or
        ----------------
        accept PUT_VALUE(--| Logs value of FLOAT variable to the ELF

          UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
          --| A unique ID assigned by the Source Instrumenter for
          --| the current unit

          VARIABLE_NAME   : in STRING; --| The name of the variable

          FLOAT_VALUE     : in FLOAT   --| The variable's value

            ) do

          --| Effects
          --| Logs floating point values to the execution log file
          --| Puts the program unit, variable name, and current value

          --| N/A:  Raises, Requires, Modifies, Errors

          if TOOL_IN_USE = SMART_TOOL then
            WRITE_LOG.PUT_VALUE(UNIT_IDENTIFIER, VARIABLE_NAME, FLOAT_VALUE);
          end if;

        end PUT_VALUE;

      or
        ----------------
        accept PUT_VALUE(--| Logs value of Long_Float variable to the ELF

          UNIT_IDENTIFIER  : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
          --| A unique ID assigned by the Source Instrumenter for
          --| the current unit

          VARIABLE_NAME    : in STRING;     --| The name of the variable

          LONG_FLOAT_VALUE : in LONG_FLOAT  --| The variable's value

            ) do

          --| Effects
          --| Logs long_float values to the execution log file.
          --| Puts the program unit, variable name, and current value.

          --| N/A:  Raises, Requires, Modifies, Errors

          if TOOL_IN_USE = SMART_TOOL then
            WRITE_LOG.PUT_VALUE(UNIT_IDENTIFIER, VARIABLE_NAME,
                                LONG_FLOAT_VALUE);
          end if;

        end PUT_VALUE;

      or
        ----------------
        accept PUT_VALUE(--| Logs value of string variable to the ELF

          UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
          --| A unique ID assigned by the Source Instrumenter for
          --| the current unit

          VARIABLE_NAME   : in STRING; --| The name of the variable

          STRING_VALUE    : in STRING  --| The variable's value

          ) do

        --| Effects
        --| Logs string values to the execution log file
        --| Puts the program unit, variable name, and current value
        --| This procedure used to log the value of
        --|        strings
        --|        characters
        --|        enumerated data types (including booleans)

        --| N/A:  Raises, Requires, Modifies, Errors

          if TOOL_IN_USE = SMART_TOOL then
            WRITE_LOG.PUT_VALUE(UNIT_IDENTIFIER, VARIABLE_NAME, STRING_VALUE);
          end if;

        end PUT_VALUE;

      or
        ------------------
        accept START_DELAY(--| Records a delay for the specified unit and
                           --| duration in the ELF

          UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
          --| A unique ID assigned by the Source Instrumenter for
          --| the current unit

          SECONDS         : in DURATION
          --| The length of the delay in seconds

            ) do

          --| Effects
          --| Records a delay for the specified unit and duration in the
          --| Execution Log File. This entry is not called directly by the
          --| the instrumented program. It is called by the function
          --| Starting_Delay.

          --| N/A:  Raises, Requires, Modifies, Error

          -- Stop the clock immediately
          STOP_WATCH := CLOCK;

          SECS := WRITE_LOG.STARTING_DELAY(UNIT_IDENTIFIER, SECONDS);

          -- Calculate the amount of time required to execute the
          -- rendezvous and add it to the accumulated tool overhead
          ACCUMULATED_OVERHEAD := ACCUMULATED_OVERHEAD + (CLOCK - STOP_WATCH);

        end START_DELAY;

      or

        when OK_TO_TERMINATE =>

          terminate;

      end select;

    end loop;

  end RTM;


  -----------------------
  function STARTING_DELAY(--| Records a delay for the specified unit and
                          --| duration in the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    SECONDS         : in DURATION
    --| The length of the delay in seconds

    ) return DURATION is

  --| Effects
  --| Records a delay for the specified unit and duration in the
  --| Execution Log File. The length of the Delay is returned to
  --| the calling unit. This unit is implemented as a function
  --| to enable trapping of delay times in timed entry statements.

  --| N/A:  Raises, Requires, Modifies, Errors

    begin

      if TOOL_IN_USE = PROFILE_TOOL then
        RTM.START_DELAY(UNIT_IDENTIFIER, SECONDS);
      end if;

      return SECONDS;

    end STARTING_DELAY;


  end RUN_TIME_MONITOR;


with TYPE_DEFINITIONS; use TYPE_DEFINITIONS;
with STRING_PKG; use STRING_PKG;
with TEXT_IO; use TEXT_IO;

with UNCHECKED_DEALLOCATION;

package body RTM_LIST_PACKAGE is

--| Overview
--|      The RTM_List_Package is a subset of the Lists package from Inter-
--| metrics in Cambridge.  It is tailored explicitly for the Run_Time_Monitor.
--| The type of the list objects is Program_Unit_Unique_Identifier, which is
--| declared in Type_Definitions.
--| The procedures and functions allow the RTM to create a list, add to a
--| list, delete an item from the list, read and replace an item after
--| incrementing the Task_Type_Activation_Number, and check for an empty
--| list.


--  Mary Koppes  Intermetrics Inc, Huntington Beach,Ca  11-June-85


-------------------------------------------------------------------------------


  procedure FREE is
    new UNCHECKED_DEALLOCATION(LIST_ELEMENT, LIST);


-------------------------------------------------------------------------------

    -- Local Declarations for the RTM_ List_Package

  ITEM_NOT_PRESENT : exception;
  EMPTY_LIST       : exception;

-------------------------------------------------------------------------------


  function EQUAL(X, Y : in PROGRAM_UNIT_UNIQUE_IDENTIFIER) return BOOLEAN is

  begin

    if EQUAL(X.ENCLOSING_UNIT_IDENTIFIER, Y.ENCLOSING_UNIT_IDENTIFIER) and
      X.PROGRAM_UNIT_NUMBER = Y.PROGRAM_UNIT_NUMBER and
      X.UNIT_TYPE = Y.UNIT_TYPE then

      return TRUE;

    else

      return FALSE;

    end if;

  end EQUAL;


-------------------------------------------------------------------------------


  function CREATE --| Creates a null List
  return LIST

  is
  begin

    return null;

  end CREATE;


-------------------------------------------------------------------------------


  procedure ADD(ELEMENT : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;

                TO_LIST : in out LIST) is

  --| Algorithm
  --| Allocates new storage for Element and links it to To_List.

  begin
    TO_LIST := new LIST_ELEMENT'(INFO => ELEMENT, NEXT_ELEMENT => TO_LIST);
  end ADD;


-------------------------------------------------------------------------------



  procedure DELETE_HEAD(THE_LIST : in out LIST)

  is

  --| Algorithm
  --| Delete_Head first checks The_List and if it is null, Empty_List
  --| is raised.  If The_List is not null, the first element is freed.


    TEMPORARY_LIST : LIST;

  begin
    if THE_LIST = null then

      raise EMPTY_LIST;

    else

      TEMPORARY_LIST := THE_LIST.NEXT_ELEMENT;
      FREE(THE_LIST);
      THE_LIST := TEMPORARY_LIST;

    end if;

  end DELETE_HEAD;


-------------------------------------------------------------------------------

  procedure DELETE(ELEMENT   : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
                   FROM_LIST : in out LIST)

  is

  --| Algorithm
  --| Delete is a recursive procedure which in effect walks through From_List
  --| looking for the first occurance of Element.  When it is found that
  --| element is deleted by a call to Delete_Head, which frees the element.


  begin
    if EQUAL(FROM_LIST.INFO, ELEMENT) then
      DELETE_HEAD(FROM_LIST);

    else
      DELETE(ELEMENT, FROM_LIST.NEXT_ELEMENT);

    end if;

  exception
    when CONSTRAINT_ERROR =>
      raise ITEM_NOT_PRESENT;

  end DELETE;


-------------------------------------------------------------------------------


  procedure REPLACE_VALUE( --| Find element and increments the Task number

    NEW_ELEMENT : in out PROGRAM_UNIT_UNIQUE_IDENTIFIER;

    NEW_LIST    : in out LIST)

  is

  --| Algorithm
  --| Replace value loops through the list until New_Element is found.
  --| When it is found, the Task_Type_Activation_Number is incremented
  --| and the element is replaced.  New_Element is set to this new value
  --| and returned via the IN OUT parameter.

    POINTER : LIST;

  begin
    POINTER := NEW_LIST;
    while POINTER /= null loop
      if EQUAL(POINTER.INFO, NEW_ELEMENT) then
        POINTER.INFO.TASK_TYPE_ACTIVATION_NUMBER :=
           POINTER.INFO.TASK_TYPE_ACTIVATION_NUMBER + 1;
        NEW_ELEMENT := POINTER.INFO;
        exit;

      else
        POINTER := POINTER.NEXT_ELEMENT;
      end if;

    end loop;

  end REPLACE_VALUE;



-------------------------------------------------------------------------------


  function IS_IN_LIST( --| Checks for the presence of Element in The_List.

    THE_LIST : in LIST;

    ELEMENT  : in PROGRAM_UNIT_UNIQUE_IDENTIFIER

    ) return BOOLEAN

      is

  --| Algorithm
  --| Is_In_List loops through the list, searching fot Element.  It
  --| returns TRUE if it found and FALSE if it is not found.

    POINTER : LIST;

  begin
    POINTER := THE_LIST;

    while POINTER /= null loop
      if EQUAL(POINTER.INFO, ELEMENT) then
        return TRUE;
      end if;

      POINTER := POINTER.NEXT_ELEMENT;

    end loop;

    return FALSE;

  end IS_IN_LIST;



-------------------------------------------------------------------------------



  function IS_EMPTY( --| Checks for an empty list

    THE_LIST : in LIST) return BOOLEAN

  is

  --| Algorithm
  --| If The_List = NULL then return TRUE, else return FALSE.


  begin
    return (THE_LIST = null);

  end IS_EMPTY;


end RTM_LIST_PACKAGE;

generic
  type ITEMTYPE is private;  --| This is the data being manipulated.

  with function EQUAL(X, Y : in ITEMTYPE) return BOOLEAN is "=";
  --| This allows the user to define
  --| equality on ItemType.  For instance
  --| if ItemType is an abstract type
  --| then equality is defined in terms of
  --| the abstract type.  If this function
  --| is not provided equality defaults to
  --| =.
package LISTS is

--| This package provides singly linked lists with elements of type
--| ItemType, where ItemType is specified by a generic parameter.

--| Overview
--| When this package is instantiated, it provides a linked list type for
--| lists of objects of type ItemType, which can be any desired type.  A
--| complete set of operations for manipulation, and releasing
--| those lists is also provided.  For instance, to make lists of strings,
--| all that is necessary is:
--|
--| type StringType is string(1..10);
--|
--| package Str_List is new Lists(StringType); use Str_List;
--|
--|    L:List;
--|    S:StringType;
--|
--| Then to add a string S, to the list L, all that is necessary is
--|
--|    L := Create;
--|    Attach(S,L);
--|
--|
--| This package provides basic list operations.
--|
--| Attach          append an object to an object, an object to a list,
--|                 or a list to an object, or a list to a list.
--| Copy            copy a list using := on elements
--| CopyDeep        copy a list by copying the elements using a copy
--|                 operation provided by the user
--| Create          Creates an empty list
--| DeleteHead      removes the head of a list
--| DeleteItem      delete the first occurrence of an element from a list
--| DeleteItems     delete all occurrences of an element from a list
--| Destroy         remove a list
--| Equal           are two lists equal
--| FirstValue      get the information from the first element of a list
--| IsInList        determines whether a given element is in a given list
--| IsEmpty         returns true if the list is empty
--| LastValue       return the last value of a list
--| Length          Returns the length of a list
--| MakeListIter    prepares for an iteration over a list
--| More            are there any more items in the list
--| Next            get the next item in a list
--| ReplaceHead     replace the information at the head of the list
--| ReplaceTail     replace the tail of a list with a new list
--| Tail            get the tail of a list
--|

--| N/A: Effects, Requires, Modifies, and Raises.

--| Notes
--| Programmer Buddy Altus

--|                           Types
--|                           -----

  type LIST is private;
  type LISTITER is private;


  --|                           Exceptions
  --|                           ----------

  CIRCULARLIST   : exception;  --| Raised if an attemp is made to
  --| create a circular list.  This
  --| results when a list is attempted
  --| to be attached to itself.

  EMPTYLIST      : exception;  --| Raised if an attemp is made to
  --| manipulate an empty list.

  ITEMNOTPRESENT : exception;  --| Raised if an attempt is made to
  --| remove an element from a list in
  --| which it does not exist.

  NOMORE         : exception;  --| Raised if an attemp is made to
  --| get the next element from a list
  --| after iteration is complete.



  --|                           Operations
  --|                           ----------

  ----------------------------------------------------------------------------

  procedure ATTACH( --| appends List2 to List1
                   LIST1 : in out LIST;  --| The list being appended to.
                   LIST2 : in LIST --| The list being appended.
                   );

  --| Raises
  --| CircularList

  --| Effects
  --| Appends List1 to List2.  This makes the next field of the last element
  --| of List1 refer to List2.  This can possibly change the value of List1
  --| if List1 is an empty list.  This causes sharing of lists.  Thus if
  --| user Destroys List1 then List2 will be a dangling reference.
  --| This procedure raises CircularList if List1 equals List2.  If it is
  --| necessary to Attach a list to itself first make a copy of the list and
  --| attach the copy.

  --| Modifies
  --| Changes the next field of the last element in List1 to be List2.

-------------------------------------------------------------------------------

  function ATTACH( --| Creates a new list containing the two
  --| Elements.
                  ELEMENT1 : in ITEMTYPE;
                                 --| This will be first element in list.
                  ELEMENT2 : in ITEMTYPE
                                 --| This will be second element in list.
                  ) return LIST;

  --| Effects
  --| This creates a list containing the two elements in the order
  --| specified.

-------------------------------------------------------------------------------
  procedure ATTACH( --| List L is appended with Element.
                   L       : in out LIST;  --| List being appended to.
                   ELEMENT : in ITEMTYPE
                                    --| This will be last element in l    ist.
                   );

  --| Effects
  --| Appends Element onto the end of the list L.  If L is empty then this
  --| may change the value of L.
  --|
  --| Modifies
  --| This appends List L with Element by changing the next field in List.

--------------------------------------------------------------------------------
  procedure ATTACH( --| Makes Element first item in list L.
                   ELEMENT : in ITEMTYPE;
                                    --| This will be the first element in list.
                   L       : in out LIST --| The List which Element is being
                   --| prepended to.
                   );

  --| Effects
  --| This prepends list L with Element.
  --|
  --| Modifies
  --| This modifies the list L.

  --------------------------------------------------------------------------

  function ATTACH( --| attaches two lists
                  LIST1 : in LIST;  --| first list
                  LIST2 : in LIST --| second list
                  ) return LIST;

  --| Raises
  --| CircularList

  --| Effects
  --| This returns a list which is List1 attached to List2.  If it is desired
  --| to make List1 be the new attached list the following ada code should be
  --| used.
  --|
  --| List1 := Attach (List1, List2);
  --| This procedure raises CircularList if List1 equals List2.  If it is
  --| necessary to Attach a list to itself first make a copy of the list and
  --| attach the copy.

  -------------------------------------------------------------------------

  function ATTACH( --| prepends an element onto a list
                  ELEMENT : in ITEMTYPE;  --| element being prepended to list
                  L       : in LIST --| List which element is being added
                  --| to
                  ) return LIST;

  --| Effects
  --| Returns a new list which is headed by Element and followed by L.

  ------------------------------------------------------------------------

  function ATTACH( --| Adds an element to the end of a list
                  L       : in LIST;
                                   --| The list which element is being added to.
                  ELEMENT : in ITEMTYPE
                                   --| The element being added to the end of
                  --| the list.
                  ) return LIST;

  --| Effects
  --| Returns a new list which is L followed by Element.

  --------------------------------------------------------------------------


  function COPY( --| returns a copy of list1
                L : in LIST --| list being copied
                ) return LIST;

  --| Effects
  --| Returns a copy of L.

  --------------------------------------------------------------------------

  generic
    with function COPY(I : in ITEMTYPE) return ITEMTYPE;


  function COPYDEEP( --| returns a copy of list using a user supplied
  --| copy function.  This is helpful if the type
  --| of a list is an abstract data type.
                    L : in LIST --| List being copied.
                    ) return LIST;

  --| Effects
  --| This produces a new list whose elements have been duplicated using
  --| the Copy function provided by the user.

------------------------------------------------------------------------------

  function CREATE --| Returns an empty List

  return LIST;

------------------------------------------------------------------------------

  procedure DELETEHEAD( --| Remove the head element from a list.
                       L : in out LIST --| The list whose head is being removed.
                       );

  --| Raises
  --| EmptyList
  --|
  --| Effects
  --| This will return the space occupied by the first element in the list
  --| to the heap.  If sharing exists between lists this procedure
  --| could leave a dangling reference.  If L is empty EmptyList will be
  --| raised.

------------------------------------------------------------------------------

  procedure DELETEITEM( --| remove the first occurrence of Element
  --| from L
                       L       : in out LIST;
                                --| list element is being  removed from
                       ELEMENT : in ITEMTYPE --| element being removed
                       );

  --| Raises
  --| ItemNotPresent

  --| Effects
  --| Removes the first element of the list equal to Element.  If there is
  --| not an element equal to Element than ItemNotPresent is raised.

  --| Modifies
  --| This operation is destructive, it returns the storage occupied by
  --| the elements being deleted.

------------------------------------------------------------------------------

  procedure DELETEITEMS( --| remove all occurrences of Element
  --| from  L.
                        L       : in out LIST;
                                --| The List element is being removed from
                        ELEMENT : in ITEMTYPE --| element being removed
                        );

  --| Raises
  --| ItemNotPresent
  --|
  --| Effects
  --| This procedure walks down the list L and removes all elements of the
  --| list equal to Element.  If there are not any elements equal to Element
  --| then raise ItemNotPresent.

  --| Modifies
  --| This operation is destructive the storage occupied by the items
  --| removed is returned.

------------------------------------------------------------------------------

  procedure DESTROY( --| removes the list
                    L : in out LIST --| the list being removed
                    );

  --| Effects
  --| This returns to the heap all the storage that a list occupies.  Keep in
  --| mind if there exists sharing between lists then this operation can leave
  --| dangling references.

------------------------------------------------------------------------------

  function FIRSTVALUE( --| returns the contents of the first record of the
  --| list
                      L : in LIST --| the list whose first element is being
                      --| returned

                      ) return ITEMTYPE;

  --| Raises
  --| EmptyList
  --|
  --| Effects
  --| This returns the Item in the first position in the list.  If the list
  --| is empty EmptyList is raised.

-------------------------------------------------------------------------------

  function ISEMPTY( --| Checks if a list is empty.
                   L : in LIST --| List being checked.
                   ) return BOOLEAN;

  --------------------------------------------------------------------------

  function ISINLIST( --| Checks if element is an element of
  --| list.
                    L       : in LIST;  --| list being scanned for element
                    ELEMENT : in ITEMTYPE --| element being searched for
                    ) return BOOLEAN;

  --| Effects
  --| Walks down the list L looking for an element whose value is Element.

------------------------------------------------------------------------------

  function LASTVALUE( --| Returns the contents of the last record of
  --| the list.
                     L : in LIST --| The list whose first element is being
                     --| returned.
                     ) return ITEMTYPE;

  --| Raises
  --| EmptyList
  --|
  --| Effects
  --| Returns the last element in a list.  If the list is empty EmptyList is
  --| raised.


------------------------------------------------------------------------------

  function LENGTH( --| count the number of elements on a list
                  L : in LIST --| list whose length is being computed
                  ) return INTEGER;

------------------------------------------------------------------------------

  function MAKELISTITER( --| Sets a variable to point to  the head
  --| of the list.  This will be used to
  --| prepare for iteration over a list.
                        L : in LIST --| The list being iterated over.
                        ) return LISTITER;


--| This prepares a user for iteration operation over a list.  The iterater is
  --| an operation which returns successive elements of the list on successive
  --| calls to the iterator.  There needs to be a mechanism which marks the
  --| position in the list, so on successive calls to the Next operation the
  --| next item in the list can be returned.  This is the function of the
  --| MakeListIter and the type ListIter.  MakeIter just sets the Iter to the
  --| the beginning  of the list. On subsequent calls to Next the Iter
  --| is updated with each call.

  -----------------------------------------------------------------------------

  function MORE( --| Returns true if there are more elements in
  --| the and false if there aren't any more
  --| the in the list.
                L : in LISTITER --| List being checked for elements.
                ) return BOOLEAN;

------------------------------------------------------------------------------

  procedure NEXT( --| This is the iterator operation.  Given
  --| a ListIter in the list it returns the
  --| current item and updates the ListIter.
  --| If ListIter is at the end of the list,
  --| More returns false otherwise it
  --| returns true.
                 PLACE : in out LISTITER;
                                --| The Iter which marks the position in
                 --| the list.
                 INFO  : out ITEMTYPE --| The element being returned.

                 );

  --| The iterators subprograms MakeListIter, More, and Next should be used
  --| in the following way:
  --|
  --|         L:        List;
  --|         Place:    ListIter;
  --|         Info:     SomeType;
  --|
  --|
  --|         Place := MakeListIter(L);
  --|
  --|         while ( More(Place) ) loop
  --|               Next(Place, Info);
  --|               process each element of list L;
  --|               end loop;


  ----------------------------------------------------------------------------

  procedure REPLACEHEAD( --| Replace the Item at the head of the list
  --| with the parameter Item.
                        L    : in out LIST;  --| The list being modified.
                        INFO : in ITEMTYPE --| The information being entered.
                        );
  --| Raises
  --| EmptyList

  --| Effects
  --| Replaces the information in the first element in the list.  Raises
  --| EmptyList if the list is empty.

------------------------------------------------------------------------------

  procedure REPLACETAIL( --| Replace the Tail of a list
  --| with a new list.
                        L       : in out LIST;  --| List whose Tail is replaced.
                        NEWTAIL : in LIST --| The list which will become the
                        --| tail of Oldlist.
                        );
  --| Raises
  --| EmptyList
  --|
  --| Effects
  --| Replaces the tail of a list with a new list.  If the list whose tail
  --| is being replaced is null EmptyList is raised.

-------------------------------------------------------------------------------

  function TAIL( --| returns the tail of a list L
                L : in LIST --| the list whose tail is being returned
                ) return LIST;

  --| Raises
  --| EmptyList
  --|
  --| Effects
  --| Returns a list which is the tail of the list L.  Raises EmptyList if
  --| L is empty.  If L only has one element then Tail returns the Empty
  --| list.

------------------------------------------------------------------------------

  function EQUAL( --| compares list1 and list2 for equality
                 LIST1 : in LIST;  --| first list
                 LIST2 : in LIST --| second list
                 ) return BOOLEAN;

  --| Effects
  --| Returns true if for all elements of List1 the corresponding element
  --| of List2 has the same value.  This function uses the Equal operation
  --| provided by the user.  If one is not provided then = is used.

------------------------------------------------------------------------------
private
  type CELL;

  type LIST is access CELL;  --| pointer added by this package
  --| in order to make a list


  type CELL is  --| Cell for the lists being created
    record
      INFO : ITEMTYPE;
      NEXT : LIST;
    end record;


  type LISTITER is new LIST;  --| This prevents Lists being assigned to
  --| iterators and vice versa

end LISTS;

with UNCHECKED_DEALLOCATION;

package body LISTS is

  procedure FREE is
    new UNCHECKED_DEALLOCATION(CELL, LIST);

    --------------------------------------------------------------------------

  function LAST(L : in LIST) return LIST is

    PLACE_IN_L      : LIST;
    TEMP_PLACE_IN_L : LIST;

    --|  Link down the list L and return the pointer to the last element
    --| of L.  If L is null raise the EmptyList exception.

  begin
    if L = null then
      raise EMPTYLIST;
    else

      --|  Link down L saving the pointer to the previous element in
      --|  Temp_Place_In_L.  After the last iteration Temp_Place_In_L
      --|  points to the last element in the list.
      PLACE_IN_L := L;
      while PLACE_IN_L /= null loop
        TEMP_PLACE_IN_L := PLACE_IN_L;
        PLACE_IN_L := PLACE_IN_L.NEXT;
      end loop;
      return TEMP_PLACE_IN_L;
    end if;
  end LAST;


  --------------------------------------------------------------------------

  procedure ATTACH(LIST1 : in out LIST;
                   LIST2 : in LIST) is
    ENDOFLIST1 : LIST;

    --| Attach List2 to List1.
    --| If List1 is null return List2
    --| If List1 equals List2 then raise CircularList
    --| Otherwise get the pointer to the last element of List1 and change
    --| its Next field to be List2.

  begin
    if LIST1 = null then
      LIST1 := LIST2;
      return;
    elsif LIST1 = LIST2 then
      raise CIRCULARLIST;
    else
      ENDOFLIST1 := LAST(LIST1);
      ENDOFLIST1.NEXT := LIST2;
    end if;
  end ATTACH;

  --------------------------------------------------------------------------

  procedure ATTACH(L       : in out LIST;
                   ELEMENT : in ITEMTYPE) is

    NEWEND : LIST;

    --| Create a list containing Element and attach it to the end of L

  begin
    NEWEND := new CELL'(INFO => ELEMENT, NEXT => null);
    ATTACH(L, NEWEND);
  end ATTACH;

  --------------------------------------------------------------------------

  function ATTACH(ELEMENT1 : in ITEMTYPE;
                  ELEMENT2 : in ITEMTYPE) return LIST is
    NEWLIST : LIST;

    --| Create a new list containing the information in Element1 and
    --| attach Element2 to that list.

  begin
    NEWLIST := new CELL'(INFO => ELEMENT1, NEXT => null);
    ATTACH(NEWLIST, ELEMENT2);
    return NEWLIST;
  end ATTACH;

  --------------------------------------------------------------------------

  procedure ATTACH(ELEMENT : in ITEMTYPE;
                   L       : in out LIST) is

  --|  Create a new cell whose information is Element and whose Next
  --|  field is the list L.  This prepends Element to the List L.

  begin
    L := new CELL'(INFO => ELEMENT, NEXT => L);
  end ATTACH;

  --------------------------------------------------------------------------

  function ATTACH(LIST1 : in LIST;
                  LIST2 : in LIST) return LIST is

    LAST_OF_LIST1 : LIST;

  begin
    if LIST1 = null then
      return LIST2;
    elsif LIST1 = LIST2 then
      raise CIRCULARLIST;
    else
      LAST_OF_LIST1 := LAST(LIST1);
      LAST_OF_LIST1.NEXT := LIST2;
      return LIST1;
    end if;
  end ATTACH;

  -------------------------------------------------------------------------

  function ATTACH(L       : in LIST;
                  ELEMENT : in ITEMTYPE) return LIST is

    NEWEND    : LIST;
    LAST_OF_L : LIST;

    --| Create a list called NewEnd and attach it to the end of L.
    --| If L is null return NewEnd
    --| Otherwise get the last element in L and make its Next field
    --| NewEnd.

  begin
    NEWEND := new CELL'(INFO => ELEMENT, NEXT => null);
    if L = null then
      return NEWEND;
    else
      LAST_OF_L := LAST(L);
      LAST_OF_L.NEXT := NEWEND;
      return L;
    end if;
  end ATTACH;

  --------------------------------------------------------------------------

  function ATTACH(ELEMENT : in ITEMTYPE;
                  L       : in LIST) return LIST is

  begin
    return (new CELL'(INFO => ELEMENT, NEXT => L));
  end ATTACH;

  --------------------------------------------------------------------------

  function COPY(L : in LIST) return LIST is

  --| If L is null return null
  --| Otherwise recursively copy the list by first copying the information
  --| at the head of the list and then making the Next field point to
  --| a copy of the tail of the list.

  begin
    if L = null then
      return null;
    else
      return new CELL'(INFO => L.INFO, NEXT => COPY(L.NEXT));
    end if;
  end COPY;


  --------------------------------------------------------------------------

  function COPYDEEP(L : in LIST) return LIST is

  --|  If L is null then return null.
  --|  Otherwise copy the first element of the list into the head of the
  --|  new list and copy the tail of the list recursively using CopyDeep.

  begin
    if L = null then
      return null;
    else
      return new CELL'(INFO => COPY(L.INFO), NEXT => COPYDEEP(L.NEXT));
    end if;
  end COPYDEEP;

  --------------------------------------------------------------------------

  function CREATE return LIST is

  --| Return the empty list.

  begin
    return null;
  end CREATE;

  --------------------------------------------------------------------------
  procedure DELETEHEAD(L : in out LIST) is

    TEMPLIST : LIST;

    --| Remove the element of the head of the list and return it to the heap.
    --| If L is null EmptyList.
    --| Otherwise save the Next field of the first element, remove the first
    --| element and then assign to L the Next field of the first element.

  begin
    if L = null then
      raise EMPTYLIST;
    else
      TEMPLIST := L.NEXT;
      FREE(L);
      L := TEMPLIST;
    end if;
  end DELETEHEAD;

  --------------------------------------------------------------------------

  procedure DELETEITEM(L       : in out LIST;
                       ELEMENT : in ITEMTYPE) is

    TEMP_L : LIST;

    --| Remove the first element in the list with the value Element.
    --| If the first element of the list is equal to element then
    --| remove it.  Otherwise, recurse on the tail of the list.

  begin
    if EQUAL(L.INFO, ELEMENT) then
      DELETEHEAD(L);
    else
      DELETEITEM(L.NEXT, ELEMENT);
    end if;
  exception
    when CONSTRAINT_ERROR =>
      raise ITEMNOTPRESENT;
  end DELETEITEM;

  --------------------------------------------------------------------------

  procedure DELETEITEMS(L       : in out LIST;
                        ELEMENT : in ITEMTYPE) is

    PLACE_IN_L      : LIST;  --| Current place in L.
    LAST_PLACE_IN_L : LIST;  --| Last place in L.
    TEMP_PLACE_IN_L : LIST;  --| Holds a place in L to be removed.
    FOUND           : BOOLEAN := FALSE;  --| Indicates if an element with
    --| the correct value was found.

    --| Walk over the list removing all elements with the value Element.

  begin
    PLACE_IN_L := L;
    LAST_PLACE_IN_L := null;
    while (PLACE_IN_L /= null) loop

      --| Found an element equal to Element
      if EQUAL(PLACE_IN_L.INFO, ELEMENT) then
        FOUND := TRUE;

        --| If Last_Place_In_L is null then we are at first element
        --| in L.
        if LAST_PLACE_IN_L = null then
          TEMP_PLACE_IN_L := PLACE_IN_L;
          L := PLACE_IN_L.NEXT;
        else
          TEMP_PLACE_IN_L := PLACE_IN_L;

          --| Relink the list Last's Next gets Place's Next
          LAST_PLACE_IN_L.NEXT := PLACE_IN_L.NEXT;
        end if;

        --| Move Place_In_L to the next position in the list.
        --| Free the element.
        --| Do not update the last element in the list it remains the
        --| same.
        PLACE_IN_L := PLACE_IN_L.NEXT;
        FREE(TEMP_PLACE_IN_L);
      else

        --| Update the last place in L and the place in L.
        LAST_PLACE_IN_L := PLACE_IN_L;
        PLACE_IN_L := PLACE_IN_L.NEXT;
      end if;
    end loop;

    --| If we have not found an element raise an exception.
    if not FOUND then
      raise ITEMNOTPRESENT;
    end if;

  end DELETEITEMS;

  --------------------------------------------------------------------------

  procedure DESTROY(L : in out LIST) is

    PLACE_IN_L : LIST;
    HOLDPLACE  : LIST;

    --| Walk down the list removing all the elements and set the list to
    --| the empty list.

  begin
    PLACE_IN_L := L;
    while PLACE_IN_L /= null loop
      HOLDPLACE := PLACE_IN_L;
      PLACE_IN_L := PLACE_IN_L.NEXT;
      FREE(HOLDPLACE);
    end loop;
    L := null;
  end DESTROY;

  --------------------------------------------------------------------------

  function FIRSTVALUE(L : in LIST) return ITEMTYPE is

  --| Return the first value in the list.

  begin
    if L = null then
      raise EMPTYLIST;
    else
      return (L.INFO);
    end if;
  end FIRSTVALUE;

  --------------------------------------------------------------------------

  procedure FORWORD(I : in out LISTITER) is

  --| Return the pointer to the next member of the list.

  begin
    I := LISTITER(I.NEXT);
  end FORWORD;

  --------------------------------------------------------------------------

  function ISINLIST(L       : in LIST;
                    ELEMENT : in ITEMTYPE) return BOOLEAN is

    PLACE_IN_L : LIST;

    --| Check if Element is in L.  If it is return true otherwise return false.

  begin
    PLACE_IN_L := L;
    while PLACE_IN_L /= null loop
      if EQUAL(PLACE_IN_L.INFO, ELEMENT) then
        return TRUE;
      end if;
      PLACE_IN_L := PLACE_IN_L.NEXT;
    end loop;
    return FALSE;
  end ISINLIST;

  --------------------------------------------------------------------------

  function ISEMPTY(L : in LIST) return BOOLEAN is

  --| Is the list L empty.

  begin
    return (L = null);
  end ISEMPTY;

  --------------------------------------------------------------------------

  function LASTVALUE(L : in LIST) return ITEMTYPE is

    LASTELEMENT : LIST;

    --| Return the value of the last element of the list. Get the pointer
    --| to the last element of L and then return its information.

  begin
    LASTELEMENT := LAST(L);
    return LASTELEMENT.INFO;
  end LASTVALUE;

  --------------------------------------------------------------------------

  function LENGTH(L : in LIST) return INTEGER is

  --| Recursively compute the length of L.  The length of a list is
  --| 0 if it is null or  1 + the length of the tail.

  begin
    if L = null then
      return (0);
    else
      return (1 + LENGTH(TAIL(L)));
    end if;
  end LENGTH;

  --------------------------------------------------------------------------

  function MAKELISTITER(L : in LIST) return LISTITER is

  --| Start an iteration operation on the list L.  Do a type conversion
  --| from List to ListIter.

  begin
    return LISTITER(L);
  end MAKELISTITER;

  --------------------------------------------------------------------------

  function MORE(L : in LISTITER) return BOOLEAN is

  --| This is a test to see whether an iteration is complete.

  begin
    return L /= null;
  end MORE;

  --------------------------------------------------------------------------

  procedure NEXT(PLACE : in out LISTITER;
                 INFO  : out ITEMTYPE) is
    PLACEINLIST : LIST;

    --| This procedure gets the information at the current place in the List
    --| and moves the ListIter to the next postion in the list.
    --| If we are at the end of a list then exception NoMore is raised.

  begin
    if PLACE = null then
      raise NOMORE;
    else
      PLACEINLIST := LIST(PLACE);
      INFO := PLACEINLIST.INFO;
      PLACE := LISTITER(PLACEINLIST.NEXT);
    end if;
  end NEXT;

  --------------------------------------------------------------------------

  procedure REPLACEHEAD(L    : in out LIST;
                        INFO : in ITEMTYPE) is

  --| This procedure replaces the information at the head of a list
  --| with the given information. If the list is empty the exception
  --| EmptyList is raised.

  begin
    if L = null then
      raise EMPTYLIST;
    else
      L.INFO := INFO;
    end if;
  end REPLACEHEAD;

  --------------------------------------------------------------------------

  procedure REPLACETAIL(L       : in out LIST;
                        NEWTAIL : in LIST) is
    TEMP_L : LIST;

    --| This destroys the tail of a list and replaces the tail with
    --| NewTail.  If L is empty EmptyList is raised.

  begin
    DESTROY(L.NEXT);
    L.NEXT := NEWTAIL;
  exception
    when CONSTRAINT_ERROR =>
      raise EMPTYLIST;
  end REPLACETAIL;

  --------------------------------------------------------------------------

  function TAIL(L : in LIST) return LIST is

  --| This returns the list which is the tail of L.  If L is null Empty
  --| List is raised.

  begin
    if L = null then
      raise EMPTYLIST;
    else
      return L.NEXT;
    end if;
  end TAIL;

  --------------------------------------------------------------------------
  function EQUAL(LIST1 : in LIST;
                 LIST2 : in LIST) return BOOLEAN is

    PLACEINLIST1 : LIST;
    PLACEINLIST2 : LIST;
    CONTENTS1    : ITEMTYPE;
    CONTENTS2    : ITEMTYPE;

    --| This function tests to see if two lists are equal.  Two lists
    --| are equal if for all the elements of List1 the corresponding
    --| element of List2 has the same value.  Thus if the 1st elements
    --| are equal and the second elements are equal and so up to n.
    --|  Thus a necessary condition for two lists to be equal is that
    --| they have the same number of elements.

    --| This function walks over the two list and checks that the
    --| corresponding elements are equal.  As soon as we reach
    --| the end of a list (PlaceInList = null) we fall out of the loop.
    --| If both PlaceInList1 and PlaceInList2 are null after exiting the loop
    --| then the lists are equal.  If they both are not null the lists aren't
    --| equal.  Note that equality on elements is based on a user supplied
    --| function Equal which is used to test for item equality.

  begin
    PLACEINLIST1 := LIST1;
    PLACEINLIST2 := LIST2;
    while (PLACEINLIST1 /= null) and (PLACEINLIST2 /= null) loop
      if not EQUAL(PLACEINLIST1.INFO, PLACEINLIST2.INFO) then
        return FALSE;
      end if;
      PLACEINLIST1 := PLACEINLIST1.NEXT;
      PLACEINLIST2 := PLACEINLIST2.NEXT;
    end loop;
    return ((PLACEINLIST1 = null) and (PLACEINLIST2 = null));
  end EQUAL;
end LISTS;

--------------------------------------------------------------------------

with LISTS;  --| Implementation uses lists.  (private)

generic
  type ELEM_TYPE is private;  --| Component element type.

package STACK_PKG is

--| Overview:
--| This package provides the stack abstract data type.  Element type is
--| a generic formal parameter to the package.  There are no explicit
--| bounds on the number of objects that can be pushed onto a given stack.
--| All standard stack operations are provided.
--|
--| The following is a complete list of operations, written in the order
--| in which they appear in the spec.  Overloaded subprograms are followed
--| by (n), where n is the number of subprograms of that name.
--|
--| Constructors:
--|        create
--|        push
--|        pop (2)
--|        copy
--| Query Operations:
--|        top
--|        size
--|        is_empty
--| Heap Management:
--|        destroy


--| Notes:
--| Programmer: Ron Kownacki

  type STACK is private;  --| The stack abstract data type.

  -- Exceptions:

  UNINITIALIZED_STACK : exception;
  --| Raised on attempt to manipulate an uninitialized stack object.
  --| The initialization operations are create and copy.

  EMPTY_STACK         : exception;
  --| Raised by some operations when empty.


  -- Constructors:

  function CREATE return STACK;

  --| Effects:
  --| Return the empty stack.

  procedure PUSH(S : in out STACK;
                 E : in ELEM_TYPE);

  --| Raises: uninitialized_stack
  --| Effects:
  --| Push e onto the top of s.
  --| Raises uninitialized_stack iff s has not been initialized.

  procedure POP(S : in out STACK);

  --| Raises: empty_stack, uninitialized_stack
  --| Effects:
  --| Pops the top element from s, and throws it away.
  --| Raises empty_stack iff s is empty.
  --| Raises uninitialized_stack iff s has not been initialized.

  procedure POP(S : in out STACK;
                E : out ELEM_TYPE);

  --| Raises: empty_stack, uninitialized_stack
  --| Effects:
  --| Pops the top element from s, returns it as the e parameter.
  --| Raises empty_stack iff s is empty.
  --| Raises uninitialized_stack iff s has not been initialized.

  function COPY(S : in STACK) return STACK;

  --| Raises: uninitialized_stack
  --| Return a copy of s.
  --| Stack assignment and passing stacks as subprogram parameters
  --| result in the sharing of a single stack value by two stack
  --| objects; changes to one will be visible through the others.
  --| copy can be used to prevent this sharing.
  --| Raises uninitialized_stack iff s has not been initialized.


  -- Queries:

  function TOP(S : in STACK) return ELEM_TYPE;

  --| Raises: empty_stack, uninitialized_stack
  --| Effects:
  --| Return the element on the top of s.  Raises empty_stack iff s is
  --| empty.
  --| Raises uninitialized_stack iff s has not been initialized.

  function SIZE(S : in STACK) return NATURAL;

  --| Raises: uninitialized_stack
  --| Effects:
  --| Return the current number of elements in s.
  --| Raises uninitialized_stack iff s has not been initialized.

  function IS_EMPTY(S : in STACK) return BOOLEAN;

  --| Raises: uninitialized_stack
  --| Effects:
  --| Return true iff s is empty.
  --| Raises uninitialized_stack iff s has not been initialized.


  -- Heap Management:

  procedure DESTROY(S : in out STACK);

  --| Effects:
  --| Return the space consumed by s to the heap.  No effect if s is
  --| uninitialized.  In any case, leaves s in uninitialized state.


private

  package ELEM_LIST_PKG is
    new LISTS(ELEM_TYPE);
  subtype ELEM_LIST is ELEM_LIST_PKG.LIST;

  type STACK_REC is
    record
      SIZE : NATURAL := 0;
      ELTS : ELEM_LIST := ELEM_LIST_PKG.CREATE;
    end record;

  type STACK is access STACK_REC;

  --| Let an instance of the representation type, r, be denoted by the
  --| pair, <size, elts>.  Dot selection is used to refer to these
  --| components.
  --|
  --| Representation Invariants:
  --|     r /= null
  --|     elem_list_pkg.length(r.elts) = r.size.
  --|
  --| Abstraction Function:
  --|     A(<size, elem_list_pkg.create>) = stack_pkg.create.
  --|     A(<size, elem_list_pkg.attach(e, l)>) = push(A(<size, l>), e).

end STACK_PKG;

with UNCHECKED_DEALLOCATION;

package body STACK_PKG is

--| Overview:
--| Implementation scheme is totally described by the statements of the
--| representation invariants and abstraction function that appears in
--| the package specification.  The implementation is so trivial that
--| further documentation is unnecessary.

  use ELEM_LIST_PKG;


  -- Constructors:

  function CREATE return STACK is
  begin
    return new STACK_REC'(SIZE => 0, ELTS => CREATE);
  end CREATE;

  procedure PUSH(S : in out STACK;
                 E : in ELEM_TYPE) is
  begin
    S.SIZE := S.SIZE + 1;
    S.ELTS := ATTACH(E, S.ELTS);
  exception
    when CONSTRAINT_ERROR =>
      raise UNINITIALIZED_STACK;
  end PUSH;

  procedure POP(S : in out STACK) is
  begin
    DELETEHEAD(S.ELTS);
    S.SIZE := S.SIZE - 1;
  exception
    when EMPTYLIST =>
      raise EMPTY_STACK;
    when CONSTRAINT_ERROR =>
      raise UNINITIALIZED_STACK;
  end POP;

  procedure POP(S : in out STACK;
                E : out ELEM_TYPE) is
  begin
    E := FIRSTVALUE(S.ELTS);
    DELETEHEAD(S.ELTS);
    S.SIZE := S.SIZE - 1;
  exception
    when EMPTYLIST =>
      raise EMPTY_STACK;
    when CONSTRAINT_ERROR =>
      raise UNINITIALIZED_STACK;
  end POP;

  function COPY(S : in STACK) return STACK is
  begin
    if S = null then
      raise UNINITIALIZED_STACK;
    end if;

    return new STACK_REC'(SIZE => S.SIZE, ELTS => COPY(S.ELTS));
  end COPY;


  -- Queries:

  function TOP(S : in STACK) return ELEM_TYPE is
  begin
    return FIRSTVALUE(S.ELTS);
  exception
    when EMPTYLIST =>
      raise EMPTY_STACK;
    when CONSTRAINT_ERROR =>
      raise UNINITIALIZED_STACK;
  end TOP;

  function SIZE(S : in STACK) return NATURAL is
  begin
    return S.SIZE;
  exception
    when CONSTRAINT_ERROR =>
      raise UNINITIALIZED_STACK;
  end SIZE;

  function IS_EMPTY(S : in STACK) return BOOLEAN is
  begin
    return S.SIZE = 0;
  exception
    when CONSTRAINT_ERROR =>
      raise UNINITIALIZED_STACK;
  end IS_EMPTY;


  -- Heap Management:

  procedure DESTROY(S : in out STACK) is
    procedure FREE_STACK is
      new UNCHECKED_DEALLOCATION(STACK_REC, STACK);
  begin
    DESTROY(S.ELTS);
    FREE_STACK(S);
  exception
    when CONSTRAINT_ERROR =>

      -- stack is null
      return;
  end DESTROY;

end STACK_PKG;

with UNCHECKED_DEALLOCATION;
with LISTS, STACK_PKG;

package body STRING_PKG is

--| Overview:
--| The implementation for most operations is fairly straightforward.
--| The interesting aspects involve the allocation and deallocation of
--| heap space.  This is done as follows:
--|
--|     1. A stack of accesses to lists of string_type values is set up
--|        so that the top of the stack always refers to a list of values
--|        that were allocated since the last invocation of mark.
--|        The stack is called scopes, referring to the dynamic scopes
--|        defined by the invocations of mark and release.
--|        There is an implicit invocation of mark when the
--|        package body is elaborated; this is implemented with an explicit
--|        invocation in the package initialization code.
--|
--|     2. At each invocation of mark, a pointer to an empty list
--|        is pushed onto the stack.
--|
--|     3. At each invocation of release, all of the values in the
--|        list referred to by the pointer at the top of the stack are
--|        returned to the heap.  Then the list, and the pointer to it,
--|        are returned to the heap.  Finally, the stack is popped.

  package STRING_LIST_PKG is
    new LISTS(STRING_TYPE);
  subtype STRING_LIST is STRING_LIST_PKG.LIST;

  type STRING_LIST_PTR is access STRING_LIST;

  package SCOPE_STACK_PKG is
    new STACK_PKG(STRING_LIST_PTR);
  subtype SCOPE_STACK is SCOPE_STACK_PKG.STACK;

  use STRING_LIST_PKG;
  use SCOPE_STACK_PKG;

  SCOPES : SCOPE_STACK;  -- See package body overview.


  -- Utility functions/procedures:

  function ENTER(S : in STRING_TYPE) return STRING_TYPE;

  --| Raises: illegal_alloc
  --| Effects:
  --| Stores s, the address of s.all, in current scope list (top(scopes)),
  --| and returns s.  Useful for functions that create and return new
  --| string_type values.
  --| Raises illegal_alloc if the scopes stack is empty.

  function MATCH_STRING(S1, S2 : in STRING;
                        START  : in POSITIVE := 1) return NATURAL;

  --| Raises: no_match
  --| Effects:
  --| Returns the minimum index, i, in s1'range such that
  --| s1(i..i + s2'length - 1) = s2.  Returns 0 if no such index.
  --| Requires:
  --| s1'first = 1.

  -- Constructors:

  function CREATE(S : in STRING) return STRING_TYPE is
    subtype CONSTR_STR is STRING(1 .. S'LENGTH);
    DEC_S : CONSTR_STR := S;
  begin
    return ENTER(new CONSTR_STR'(DEC_S));

  -- DECada bug; above code (and decl of dec_s) replaces the following:
  --        return enter(new constr_str'(s));
  end CREATE;

  function "&"(S1, S2 : in STRING_TYPE) return STRING_TYPE is
  begin
    if IS_EMPTY(S1) then
      return ENTER(MAKE_PERSISTENT(S2));
    end if;
    if IS_EMPTY(S2) then
      return ENTER(MAKE_PERSISTENT(S1));
    end if;
    return CREATE(S1.all & S2.all);
  end "&";

  function "&"(S1 : in STRING_TYPE;
               S2 : in STRING) return STRING_TYPE is
  begin
    if S1 = null then
      return CREATE(S2);
    end if;
    return CREATE(S1.all & S2);
  end "&";

  function "&"(S1 : in STRING;
               S2 : in STRING_TYPE) return STRING_TYPE is
  begin
    if S2 = null then
      return CREATE(S1);
    end if;
    return CREATE(S1 & S2.all);
  end "&";

  function SUBSTR(S   : in STRING_TYPE;
                  I   : in POSITIVE;
                  LEN : in NATURAL) return STRING_TYPE is
  begin
    if LEN = 0 then
      return null;
    end if;
    return CREATE(S(I .. (I + LEN - 1)));
  exception
    when CONSTRAINT_ERROR =>

      -- on array fetch or null deref
      raise BOUNDS;
  end SUBSTR;

  function SPLICE(S   : in STRING_TYPE;
                  I   : in POSITIVE;
                  LEN : in NATURAL) return STRING_TYPE is
  begin
    if LEN = 0 then
      return ENTER(MAKE_PERSISTENT(S));
    end if;
    if I + LEN - 1 > LENGTH(S) then
      raise BOUNDS;
    end if;

    return CREATE(S(1 .. (I - 1)) & S((I + LEN) .. LENGTH(S)));
  end SPLICE;

  function INSERT(S1, S2 : in STRING_TYPE;
                  I      : in POSITIVE) return STRING_TYPE is
  begin
    if I > LENGTH(S1) then
      raise BOUNDS;
    end if;
    if IS_EMPTY(S2) then
      return CREATE(S1.all);
    end if;

    return CREATE(S1(1 .. (I - 1)) & S2.all & S1(I .. S1'LAST));
  end INSERT;

  function INSERT(S1 : in STRING_TYPE;
                  S2 : in STRING;
                  I  : in POSITIVE) return STRING_TYPE is
  begin
    if I > LENGTH(S1) then
      raise BOUNDS;
    end if;

    return CREATE(S1(1 .. (I - 1)) & S2 & S1(I .. S1'LAST));
  end INSERT;

  function INSERT(S1 : in STRING;
                  S2 : in STRING_TYPE;
                  I  : in POSITIVE) return STRING_TYPE is
  begin
    if not (I in S1'range ) then
      raise BOUNDS;
    end if;
    if S2 = null then
      return CREATE(S1);
    end if;

    return CREATE(S1(S1'FIRST .. (I - 1)) & S2.all & S1(I .. S1'LAST));
  end INSERT;

  function LOWER(S : in STRING) return STRING_TYPE is
    S2 : STRING_TYPE := CREATE(S);

    procedure LC(C : in out CHARACTER) is
    begin
      if ('A' <= C) and then (C <= 'Z') then
        C := CHARACTER'VAL(CHARACTER'POS(C) - CHARACTER'POS('A') + CHARACTER'POS
          ('a'));
      end if;
    end LC;

  begin
    for I in S2'range loop
      LC(S2(I));
    end loop;
    return S2;
  end LOWER;

  function LOWER(S : in STRING_TYPE) return STRING_TYPE is
  begin
    if S = null then
      return null;
    end if;
    return LOWER(S.all);
  end LOWER;

  function UPPER(S : in STRING) return STRING_TYPE is
    S2 : STRING_TYPE := CREATE(S);

    procedure UC(C : in out CHARACTER) is
    begin
      if ('a' <= C) and then (C <= 'z') then
        C := CHARACTER'VAL(CHARACTER'POS(C) - CHARACTER'POS('a') + CHARACTER'POS
          ('A'));
      end if;
    end UC;

  begin
    for I in S2'range loop
      UC(S2(I));
    end loop;
    return S2;
  end UPPER;

  function UPPER(S : in STRING_TYPE) return STRING_TYPE is
  begin
    if S = null then
      return null;
    end if;
    return UPPER(S.all);
  end UPPER;


  -- Heap Management:

  function MAKE_PERSISTENT(S : in STRING_TYPE) return STRING_TYPE is
    subtype CONSTR_STR is STRING(1 .. LENGTH(S));
  begin
    if S = null or else S.all = "" then
      return null;
    else
      return new CONSTR_STR'(S.all);
    end if;
  end MAKE_PERSISTENT;

  function MAKE_PERSISTENT(S : in STRING) return STRING_TYPE is
    subtype CONSTR_STR is STRING(1 .. S'LENGTH);
  begin
    if S = "" then
      return null;
    else
      return new CONSTR_STR'(S);
    end if;
  end MAKE_PERSISTENT;

  procedure REAL_FLUSH is
    new UNCHECKED_DEALLOCATION(STRING, STRING_TYPE);
    --| Effect:
    --| Return space used by argument to heap.  Does nothing if null.
    --| Notes:
    --| This procedure is actually the body for the flush procedure,
    --| but a generic instantiation cannot be used as a body for another
    --| procedure.  You tell me why.

  procedure FLUSH(S : in out STRING_TYPE) is
  begin
    if S /= null then
      REAL_FLUSH(S);
    end if;

  -- Actually, the if isn't needed; however, DECada compiler chokes
  -- on deallocation of null.
  end FLUSH;

  procedure MARK is
  begin
    PUSH(SCOPES, new STRING_LIST'(CREATE));
  end MARK;

  procedure RELEASE is
    procedure FLUSH_LIST_PTR is
      new UNCHECKED_DEALLOCATION(STRING_LIST, STRING_LIST_PTR);
    ITER     : STRING_LIST_PKG.LISTITER;
    TOP_LIST : STRING_LIST_PTR;
    S        : STRING_TYPE;
  begin
    POP(SCOPES, TOP_LIST);
    ITER := MAKELISTITER(TOP_LIST.all);
    while MORE(ITER) loop
      NEXT(ITER, S);
      FLUSH(S);

    -- real_flush is bad, DECada bug
    --          real_flush(s);
    end loop;
    DESTROY(TOP_LIST.all);
    FLUSH_LIST_PTR(TOP_LIST);
  exception
    when EMPTY_STACK =>
      raise ILLEGAL_DEALLOC;
  end RELEASE;


  -- Queries:

  function IS_EMPTY(S : in STRING_TYPE) return BOOLEAN is
  begin
    return (S = null) or else (S.all = "");
  end IS_EMPTY;

  function LENGTH(S : in STRING_TYPE) return NATURAL is
  begin
    if S = null then
      return 0;
    end if;
    return (S.all'LENGTH);
  end LENGTH;

  function VALUE(S : in STRING_TYPE) return STRING is
    subtype NULL_RANGE is POSITIVE range 1 .. 0;
    subtype NULL_STRING is STRING(NULL_RANGE);
  begin
    if S = null then
      return NULL_STRING'("");
    end if;
    return S.all;
  end VALUE;

  function FETCH(S : in STRING_TYPE;
                 I : in POSITIVE) return CHARACTER is
  begin
    if IS_EMPTY(S) or else (not (I in S'range )) then
      raise BOUNDS;
    end if;
    return S(I);
  end FETCH;

  function EQUAL(S1, S2 : in STRING_TYPE) return BOOLEAN is
  begin
    if IS_EMPTY(S1) then
      return IS_EMPTY(S2);
    end if;
    return (S2 /= null) and then (S1.all = S2.all);

  -- The above code replaces the following.  (DECada buggy)
  --        return s1.all = s2.all;
  --    exception
  --    when constraint_error =>     -- s is null
  --        return is_empty(s1) and is_empty(s2);
  end EQUAL;

  function EQUAL(S1 : in STRING_TYPE;
                 S2 : in STRING) return BOOLEAN is
  begin
    if S1 = null then
      return S2 = "";
    end if;
    return S1.all = S2;
  end EQUAL;

  function EQUAL(S1 : in STRING;
                 S2 : in STRING_TYPE) return BOOLEAN is
  begin
    if S2 = null then
      return S1 = "";
    end if;
    return S1 = S2.all;
  end EQUAL;

  function "<"(S1 : in STRING_TYPE;
               S2 : in STRING_TYPE) return BOOLEAN is
  begin
    if IS_EMPTY(S1) then
      return (not IS_EMPTY(S2));
    else
      return (S1.all < S2);
    end if;

  -- Got rid of the following code:  (Think that DECada is buggy)
  --return s1.all < s2.all;
  --exception
  --when constraint_error =>   -- on null deref
  --return (not is_empty(s2));
  -- one of them must be empty
  end "<";

  function "<"(S1 : in STRING_TYPE;
               S2 : in STRING) return BOOLEAN is
  begin
    if S1 = null then
      return S2 /= "";
    end if;
    return S1.all < S2;
  end "<";

  function "<"(S1 : in STRING;
               S2 : in STRING_TYPE) return BOOLEAN is
  begin
    if S2 = null then
      return FALSE;
    end if;
    return S1 < S2.all;
  end "<";

  function "<="(S1 : in STRING_TYPE;
                S2 : in STRING_TYPE) return BOOLEAN is
  begin
    if IS_EMPTY(S1) then
      return TRUE;
    end if;
    return (S1.all <= S2);

  -- Replaces the following:  (I think DECada is buggy)
  --return s1.all <= s2.all;
  --exception
  --when constraint_error =>   -- on null deref
  --return is_empty(s1);   -- one must be empty, so s1<=s2 iff s1 = ""
  end "<=";

  function "<="(S1 : in STRING_TYPE;
                S2 : in STRING) return BOOLEAN is
  begin
    if S1 = null then
      return TRUE;
    end if;
    return S1.all <= S2;
  end "<=";

  function "<="(S1 : in STRING;
                S2 : in STRING_TYPE) return BOOLEAN is
  begin
    if S2 = null then
      return S1 = "";
    end if;
    return S1 <= S2.all;
  end "<=";

  function MATCH_C(S     : in STRING_TYPE;
                   C     : in CHARACTER;
                   START : in POSITIVE := 1) return NATURAL is
  begin
    if S = null then
      return 0;
    end if;
    for I in START .. S.all'LAST loop
      if S(I) = C then
        return I;
      end if;
    end loop;
    return 0;
  end MATCH_C;

  function MATCH_NOT_C(S     : in STRING_TYPE;
                       C     : in CHARACTER;
                       START : in POSITIVE := 1) return NATURAL is
  begin
    if S = null then
      return 0;
    end if;
    for I in START .. S.all'LAST loop
      if S(I) /= C then
        return I;
      end if;
    end loop;
    return 0;
  end MATCH_NOT_C;

  function MATCH_S(S1, S2 : in STRING_TYPE;
                   START  : in POSITIVE := 1) return NATURAL is
  begin
    if (S1 = null) or else (S2 = null) then
      return 0;
    end if;
    return MATCH_STRING(S1.all, S2.all, START);
  end MATCH_S;

  function MATCH_S(S1    : in STRING_TYPE;
                   S2    : in STRING;
                   START : in POSITIVE := 1) return NATURAL is
  begin
    if S1 = null then
      return 0;
    end if;
    return MATCH_STRING(S1.all, S2, START);
  end MATCH_S;

  function MATCH_ANY(S, ANY : in STRING_TYPE;
                     START  : in POSITIVE := 1) return NATURAL is
  begin
    if ANY = null then
      raise ANY_EMPTY;
    end if;
    return MATCH_ANY(S, ANY.all, START);
  end MATCH_ANY;

  function MATCH_ANY(S     : in STRING_TYPE;
                     ANY   : in STRING;
                     START : in POSITIVE := 1) return NATURAL is
  begin
    if ANY = "" then
      raise ANY_EMPTY;
    end if;
    if S = null then
      return 0;
    end if;

    for I in START .. S.all'LAST loop
      for J in ANY'range loop
        if S(I) = ANY(J) then
          return I;
        end if;
      end loop;
    end loop;
    return 0;
  end MATCH_ANY;

  function MATCH_NONE(S, NONE : in STRING_TYPE;
                      START   : in POSITIVE := 1) return NATURAL is
  begin
    if IS_EMPTY(S) then
      return 0;
    end if;
    if IS_EMPTY(NONE) then
      return 1;
    end if;

    return MATCH_NONE(S, NONE.all, START);
  end MATCH_NONE;

  function MATCH_NONE(S     : in STRING_TYPE;
                      NONE  : in STRING;
                      START : in POSITIVE := 1) return NATURAL is
    FOUND : BOOLEAN;
  begin
    if IS_EMPTY(S) then
      return 0;
    end if;

    for I in START .. S.all'LAST loop
      FOUND := TRUE;
      for J in NONE'range loop
        if S(I) = NONE(J) then
          FOUND := FALSE;
          exit;
        end if;
      end loop;
      if FOUND then
        return I;
      end if;
    end loop;
    return 0;
  end MATCH_NONE;


  -- Utilities:

  function ENTER(S : in STRING_TYPE) return STRING_TYPE is
  begin
    TOP(SCOPES).all := ATTACH(TOP(SCOPES).all, S);
    return S;
  exception
    when EMPTY_STACK =>
      raise ILLEGAL_ALLOC;
  end ENTER;

  function MATCH_STRING(S1, S2 : in STRING;
                        START  : in POSITIVE := 1) return NATURAL is
    OFFSET : NATURAL;
  begin
    OFFSET := S2'LENGTH - 1;
    for I in START .. (S1'LAST - OFFSET) loop
      if S1(I .. (I + OFFSET)) = S2 then
        return I;
      end if;
    end loop;
    return 0;
  exception
    when CONSTRAINT_ERROR =>

      -- on offset := s2'length (= 0)
      return 0;
  end MATCH_STRING;

begin

  -- Initialize the scopes stack with an implicit mark.
  SCOPES := CREATE;
  MARK;
end STRING_PKG;
with Text_IO, Calendar;

---------------------------
package body Time_Library_1 is
---------------------------

--| Overview
--| TimeLib contains procedures and functions for getting, putting,
--| and calculating times, and dates. It augments the
--| predefined library package Calendar to simplify IO and provide
--| additional time routines common to all Ada Test and Evaluation
--| Tool Set (ATETS) tools.

--| Requires
--| All procedures and functions that perform IO use the
--| predefined library package Text_IO and require that the
--| specified file be opened by the calling program prior to use.
--| All times and durations must be of types declared in the
--| predefined library package Calendar.

--| Errors
--| No error messages or exceptions are raised by any of the TimeLib
--| procedures and functions. However, any Text_IO and Calendar
--| exceptions that may be raised are allowed to pass, unhandled,
--| back to the calling program.

--| N/A:  Raises, Modifies

--  Version         : 1.1
--  Author          : Jeff England
--  Initial Release : 05/19/85
--  Last Modified   : 06/07/85


package Time_IO is new Text_IO.Fixed_IO( Calendar.Day_Duration );
package Int_IO  is new Text_IO.Integer_IO( Integer );

Timing_Method : Timing_Type := Wall_Clock;
            --| When Timing_Method = WALL_CLOCK then Put_Time
            --| puts the time to the file in the form HH:MM:SS:FF.
            --| When Timing_Method = RAW the time put using
            --| Fixed_IO(Day_Duration).


----------------
function Convert( --| Convert an integer to a string
    Input_Number : in integer;
    Width        : in integer := 0
    ) return string is

  --| Effects:
  --| Converts an integer to a string of length Width. If the
  --| number if digits in Input_Number is less than Width then
  --| the digits are right justified in the output string and
  --| filled with zeros (0) on the left.

    Temp_Text : string (1 .. 16);
    Index     : integer;


begin

    Int_IO.Put(Temp_Text, Input_Number);
    if Width <= 0 then
        Index := Temp_Text'last;
        for i in Temp_Text'range loop
            if Temp_Text(i) /= ' ' then
                Index := i;
                exit;
            end if;
        end loop;
    else
        Index := Temp_Text'last - Width + 1;
        for i in Index .. Temp_Text'last loop
            if Temp_Text(i) = ' ' then
                Temp_Text(i) := '0';
            end if;
        end loop;
    end if;
    return Temp_Text(Index .. Temp_Text'last);

end Convert;


-----------------
function Fraction ( --| returns the fraction portion of the time in seconds
    Seconds : Calendar.Day_Duration
    ) return string is

Temp_Secs : String(1..10);

begin
    Time_IO.Put( Temp_Secs, Seconds, 2, 0 );
    return Temp_Secs( Temp_Secs'Last-2 .. Temp_Secs'Last );
end Fraction;


----------------
function Date_of ( --| Convert the date to a string
    Date : Calendar.Time    --| The date to be converted
    ) return string is

  --| Effects
  --| Converts the date to a string in the format MM/DD/YY

  --| N/A:  Raises, Requires, Modifies, Errors

    Year        : Calendar.Year_Number;
    Month       : Calendar.Month_Number;
    Day         : Calendar.Day_Number;
    Seconds     : Calendar.Day_Duration;

begin

    Calendar.Split(Date, Year, Month, Day, Seconds );
    return Convert(integer(Month), 2) & "/"
           & Convert(integer(Day), 2) & "/"
           & Convert(integer(Year mod 100), 2);

end Date_of;



----------------------
function Wall_Clock_of ( --| Convert seconds to wall clock time
    Seconds : Calendar.Day_Duration  --| The time to be converted
    ) return string is

  --| Effects
  --| Converts the time of day or elapsed time, in seconds,
  --| to a string in the format HH:MM:SS.FF.

  --| N/A:  Raises, Requires, Modifies, Errors

    use Calendar;  -- For "-" of times and durations

    Half_Second : Day_Duration := 0.5;

begin

    If Seconds < Half_Second then
        Half_Second := 0.0;
    end if;

    return Convert(   integer(Seconds - Half_Second) / 3600, 2)
         & ":"
         & Convert( ( integer(Seconds - Half_Second) mod 3600 ) / 60, 2 )
         & ":"
         & Convert(   integer(Seconds - Half_Second) mod 60, 2 )
         & Fraction( Seconds );

end Wall_Clock_of;


-------------------------
procedure Put_Time_of_Day ( --| Put the time of day to the file
    Fyle : in Text_IO.File_Type;        --| The output file
    Seconds : in Calendar.Day_Duration  --| The time to be output
    ) is

  --| Effects
  --| If Timing = WALL_CLOCK then the time is put to the file in the
  --| format HH:MM:SS.FF. If Timing = RAW then the time of
  --| day is put to the file using new Fixed_IO( Day_Duration ).
  --|
  --| Requires
  --| Fyle must have been previously opened by the calling program.

  --| N/A:  Raises, Modifies, Errors


begin

    if Timing_Method = Wall_Clock then
        Text_IO.Put( Fyle, Wall_Clock_of( Seconds ) );
    else
        Time_IO.Put( Fyle, Seconds, 0, 2, 0 );
    end if;

end Put_Time_of_Day;


------------------
procedure Put_Time ( --| Put the time to the file
    Fyle : in Text_IO.File_Type;  --| The output file
    Date : in Calendar.Time       --| The time to be output
    ) is

  --| Effects
  --| If Timing = WALL_CLOCK then the time is put to the file in the
  --| format MM/DD/YYYY HH:MM:SS.FF. If Timing = RAW then the time of
  --| day is put to the file using new Fixed_IO( Day_Duration ).
  --|
  --| Requires
  --| Fyle must have been previously opened by the calling program.

  --| N/A:  Raises, Modifies, Errors


begin

    Text_IO.Put( Fyle, Date_of( Date ) );

    Text_IO.Put( Fyle, ' ' );

    Put_Time_of_Day( Fyle, Calendar.Seconds( Date ) );

end Put_Time;


--------------------
procedure Set_Timing ( --| Set the method of recording timing data

    Timing : Timing_Type  --| The type of timing data to be recorded

    ) is

  --| Effects
  --| Sets th method of recording timing data to either RAW or Wall_Clock.
  --| If Timing = WALL_CLOCK then the time is put to the file in the
  --| format MM/DD/YYYY HH:MM:SS.FF. If Timing = RAW then the time of
  --| day is put to the file using new Fixed_IO( Day_Duration ).
  --| Overhead for either method may vary from system to system.

  --| N/A:  Raises, Requires, Modifies, Errors

begin

    Timing_Method := Timing; --| Set timing method to RAW or WALL_CLOCK

end Set_Timing;

end Time_Library_1;
with Run_Time_Monitor; use Run_Time_Monitor;
with Type_Definitions; use Type_Definitions;
with Implementation_Dependencies; use Implementation_Dependencies;
with Text_IO;
with System;
with Calendar;

package Trace_Predefined_Types is

   --| types defined in package Standard

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Integer);

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Short_Integer);

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Long_Integer);

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Float);

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Short_Float);

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Long_Float);

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Duration);

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: String);

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Character);

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Boolean);


   --| types defined in package Text_IO;

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Text_IO.File_Type);

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Text_IO.File_Mode);

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Text_IO.Count);

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Text_IO.Type_Set);


   --| types defined in package System

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: System.Address);

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: System.Name);


   --| types defined in package Calendar

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Calendar.Time);

end Trace_Predefined_Types ;

---------------------------------------------------------------------

package body Trace_Predefined_Types is

   --| Types defined in package Standard

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Integer) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name, Current_Value);
   end;

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Short_Integer) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name, Integer(Current_Value));
   end;

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Long_Integer) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name, Integer(Current_Value));
   end;

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Float) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name, Current_Value);
   end;

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Short_Float) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name, Float(Current_Value));
   end;

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Long_Float) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name, Float(Current_Value));
   end;

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Duration) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name, Float(Current_Value));
   end;

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: String) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name, Current_Value);
  end;

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Character) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name,
                     character'image(Current_Value));
   end;

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Boolean) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name,
                     Boolean'image(Current_Value));
   end;


   --| types defined in package Text_IO

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Text_IO.File_Type) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name,
                     "Values of type Text_IO.File_Type cannot be displayed");
   end;

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Text_IO.File_Mode) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name,
                     Text_IO.File_Mode'image(Current_Value));
   end;

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Text_IO.Count) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name,
                     integer(Current_Value));
   end;

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Text_IO.Type_Set) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name,
                     Text_IO.Type_Set'image(Current_Value));
   end;


   --| types defined in package System

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: System.Address) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name,
                     "Values of type System.Address cannot be displayed");
   end;

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: System.Name) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name,
                     System.Name'image(Current_Value));
   end;


   --| types defined in package Calendar

   procedure Source_Instrumenter_Added_Tracevar
      (Current_Unit: Program_Unit_Unique_Identifier;
       Variable_Name: String;
       Current_Value: Calendar.Time) is
   begin
      RTM.Put_Value (Current_Unit, Variable_Name,
                     "Values of type System.Time cannot be displayed");
   end;


end Trace_Predefined_Types;
with TYPE_DEFINITIONS, IMPLEMENTATION_DEPENDENCIES, TIME_LIBRARY_1, TEXT_IO,
  CALENDAR, STRING_PKG;

----------------------
package body WRITE_LOG is
----------------------

--| Overview
--| Write_Log is an output package used by the Run Time Monitor (RTM)
--| for the Ada Testing and Evaluation Tools. It performs all output
--| to the Execution Log File (ELF) that is used to dynamically record
--| information about programs written in the Ada language. The ELF is
--| used for output by the Run Time Monitor (RTM) to record runtime
--| information about the execution of the Ada program being
--| tested. It is used as input by various report generators which
--| summarize the information and present it in a meaningful format.

--| N/A: Errors, Raises, Modifies, Requires

--  Version         : 5.0
--  Author          : Jeff England
--  Initial Release : 04/09/85
--  Last Modified   : 07/18/85

  use TYPE_DEFINITIONS;            --| Global type declarations for all of
                                   --| the Ada Testing and Analysis Tools.

  use IMPLEMENTATION_DEPENDENCIES; --| Ada Compiler dependencies

  use STRING_PKG;                  --| for String_Types;

  use TIME_LIBRARY_1;

  use TEXT_IO;

  package NEW_INTEGER_IO is
    new INTEGER_IO(INTEGER);
  use NEW_INTEGER_IO;

  LOGFILE         : TEXT_IO.FILE_TYPE;
  TOOL_NAME       : TOOL_NAMES;       --| Name of the tool
  TIMING          : BOOLEAN := TRUE;  --| Timing option is used by Profile
  LOGFILE_IS_OPEN : BOOLEAN := FALSE; --| Goes true when logfile is opened

  LAST_TIME       : CALENDAR.TIME;


  --------------------
  procedure CREATE_LOG(--| Creates and opens the ELF for output

    LOGFILE_NAME  : in FILENAME; --| Name of logfile to be created

    TIMING_METHOD : in TIMING_TYPE := RAW;
                --| The method of recording Timing data

    START_TIME    : in CALENDAR.TIME   --| Program start time

      ) is

    --| Raises: Logfile_Access_Error

    --| Effects
    --| Creates and opens the ELF for output by the Run Time Monitor.
    --| If the logfile already exists it will be overwritten.
    --| The date and time of the test are written
    --| to the logfile. If the logfile is already open then a
    --| Logfile_Access_Error exception is raised. Any other
    --| Text_IO exceptions that may be raised are allowed to pass
    --| unhandled back to the calling program.

    --| Requires
    --| Logfile_Name must conform to the file naming conventions for
    --| the host computer operating system.

    --| N/A:  Modifies, Errors

    use TIME_LIBRARY_1;

  begin

    if LOGFILE_IS_OPEN then
      raise LOGFILE_ACCESS_ERROR;
    end if;

    CREATE(LOGFILE, OUT_FILE, VALUE(LOGFILE_NAME)); --| Create log file
    LOGFILE_IS_OPEN := TRUE;                        --| Open for business
    PUT(LOGFILE, LOGFILE_KEYS'POS(TEST_TIME), 0);   --| Log date and time

    case TIMING_METHOD is
      when WALL_CLOCK => PUT(LOGFILE, " W ");
      when RAW        => PUT(LOGFILE, " R ");
    end case;

    TIME_LIBRARY_1.SET_TIMING(TIMING_METHOD);
    PUT_TIME(LOGFILE, START_TIME);
    LAST_TIME := START_TIME;
    NEW_LINE(LOGFILE);

  end CREATE_LOG;


  --------------------------------
  procedure PUT_CONFIGURATION_DATA(--| Records configuration info in the ELF

    TOOL_NAME    : in TOOL_NAMES;      --| Name of the tool

    PROGRAM_NAME : in ADA_NAME;        --| Program being tested

    TEST_IDENT   : in TEST_IDENTIFIER  --| A unique identifier specified
                                       --| by the user

      ) is

    --| Raises: Logfile_Access_Error

    --| Effects
    --| Records test configuration information in the logfile. The purpose of
    --| recording this information in the logfile is to internally uniquely
    --| identify the logfile for later use by the report generators. If the
    --| logfile already exists it will be overwritten. If the logfile
    --| is already open then the exception Logfile_Access_Error is raised.
    --| Any other Text_IO exceptions that may  be raised are allowed to
    --| pass unhandled back to the calling program.

    --| Requires
    --| The logfile must have been previously opened via a call to the
    --| procedure Create_Log.

    --| N/A:  Modifies, Errors

    use CALENDAR;

  begin

    if not LOGFILE_IS_OPEN then
      raise LOGFILE_ACCESS_ERROR;
    end if;

    PUT(LOGFILE, LOGFILE_KEYS'POS(PROGRAM), 0);     --| Log program name
    PUT(LOGFILE, " ");
    PUT_LINE(LOGFILE, VALUE(PROGRAM_NAME));
    PUT(LOGFILE, LOGFILE_KEYS'POS(TOOL), 0);        --| Log tool name
    PUT(LOGFILE, " ");
    PUT_LINE(LOGFILE, TOOL_NAMES'IMAGE(TOOL_NAME));
    PUT(LOGFILE, LOGFILE_KEYS'POS(TEST_ID), 0);     --| Log test id
    PUT(LOGFILE, " ");
    PUT_LINE(LOGFILE, VALUE(TEST_IDENT));

    case TOOL_NAME is
      when PROFILE_TOOL => TIMING := TRUE;
      when others       => TIMING := FALSE;
    end case;

  end PUT_CONFIGURATION_DATA;


  ---------------------
  procedure PUT_UNIT_ID( --| Puts the program unit id to the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER
    --| A unique ID assigned by the Source Instrumenter for the current unit

      ) is

    --| Effects
    --| This is a local procedure that logs the program unit id to the
    --| log file.

    --| Requires
    --| The log file must have been previously opened via a call
    --| to Create_Log. This procedure assumes that the correct
    --| logfile key has already been written to the log file.

    --| N/A:  Raises, Modifies, Errors

  begin

    PUT(LOGFILE, " " & VALUE(UNIT_IDENTIFIER.ENCLOSING_UNIT_IDENTIFIER) & " ");
    PUT(LOGFILE, UNIT_IDENTIFIER.PROGRAM_UNIT_NUMBER, 0);

    case UNIT_IDENTIFIER.UNIT_TYPE is
      when PROCEDURE_TYPE =>
        PUT(LOGFILE, " P ");
      when FUNCTION_TYPE =>
        PUT(LOGFILE, " F ");
      when TASK_TYPE =>
        PUT(LOGFILE, " T ");
        PUT(LOGFILE, UNIT_IDENTIFIER.TASK_TYPE_ACTIVATION_NUMBER, 0);
        PUT(LOGFILE, " ");
      when GENERIC_TYPE =>
        PUT(LOGFILE, " G ");
      when PACKAGE_TYPE =>
        PUT(LOGFILE, " K ");
      when others =>
        null;
    end case;

  end PUT_UNIT_ID;


  ---------------------------------
  procedure DEFINE_COMPILATION_UNIT( --| Define a new compilation unit

    COMPILATION_UNIT      : in ADA_NAME; --| Name of the compilation unit

    NUMBER_OF_BREAKPOINTS : in BREAKPOINT_NUMBER_RANGE;
    --| Number of breakpoints in the compilation unit

    LIST_OF_PROCEDURES    : in PROCEDURE_LIST
    --| Array of names and unit types of all program units in compilation unit

      ) is

    --| Raises: Logfile_Access_Error

    --| Effects
    --| Defines a new Compilation Unit and all of its program units
    --| to the execution log file. Subsequent references by the calling
    --| program to program units in the current compilation unit will
    --| be by a unit ID of type Program_Unit where:
    --|
    --|   Unit_Identifier.Program_Unit_Number = offset into List_of_Procedures
    --|
    --| If the logfile has not been previously opened via a call to
    --| the procedure Create_Log then the exception Logfile_Access_Error
    --| is raised.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.

    --| N/A:  Modifies, Errors

    use CALENDAR;

    UNIT_IDENTIFIER : PROGRAM_UNIT_UNIQUE_IDENTIFIER;

  begin

    if not LOGFILE_IS_OPEN then
      raise LOGFILE_ACCESS_ERROR;
    end if;

    PUT(LOGFILE, LOGFILE_KEYS'POS(COMPILATION_UNIT_DEFINITION), 0);
    PUT(LOGFILE, " " & VALUE(COMPILATION_UNIT) & " ");
    PUT(LOGFILE, NUMBER_OF_BREAKPOINTS, 0);
    NEW_LINE(LOGFILE);

    for UNIT_NUMBER in LIST_OF_PROCEDURES'range loop

      PUT(LOGFILE, LOGFILE_KEYS'POS(PROGRAM_UNIT_DEFINITION), 0);
      UNIT_IDENTIFIER := (COMPILATION_UNIT, UNIT_NUMBER,
                          LIST_OF_PROCEDURES(UNIT_NUMBER).UNIT_TYPE,
                          0); -- Task_Type_Activation_Number
      PUT_UNIT_ID(UNIT_IDENTIFIER);
      PUT_LINE(LOGFILE,
               VALUE(LIST_OF_PROCEDURES(UNIT_NUMBER).UNIT_IDENTIFIER));

    end loop;

  end DEFINE_COMPILATION_UNIT;


  --------------------
  procedure START_UNIT( --| starts the current unit in the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    START_TIME      : in out CALENDAR.TIME   --| Program unit start time

      ) is

    --| Effects
    --| Puts the program unit and start time to the execution log file.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.

    --| N/A:  Raises, Modifies, Errors

    use CALENDAR;

  begin

    if TIMING then

      if START_TIME < LAST_TIME then
        START_TIME := LAST_TIME;
      else
        LAST_TIME := START_TIME;
      end if;

      PUT(LOGFILE, LOGFILE_KEYS'POS(UNIT_START), 0);
      PUT_UNIT_ID(UNIT_IDENTIFIER);
      PUT_TIME_OF_DAY(LOGFILE, SECONDS(START_TIME));
      NEW_LINE(LOGFILE);

    else

      PUT(LOGFILE, LOGFILE_KEYS'POS(UNIT_START), 0);
      PUT_UNIT_ID(UNIT_IDENTIFIER);
      NEW_LINE(LOGFILE);

    end if;

  end START_UNIT;


  -------------------
  procedure STOP_UNIT(--| Stops the current unit in the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    STOP_TIME       : in out CALENDAR.TIME   --| Program unit stop time

      ) is

    --| Effects
    --| Puts the program unit and stop time to the execution log file.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors

    use CALENDAR;

  begin

    if TIMING then

      if STOP_TIME < LAST_TIME then
        STOP_TIME := LAST_TIME;
      else
        LAST_TIME := STOP_TIME;
      end if;

      PUT(LOGFILE, LOGFILE_KEYS'POS(UNIT_STOP), 0);
      PUT_UNIT_ID(UNIT_IDENTIFIER);
      PUT_TIME_OF_DAY(LOGFILE, SECONDS(STOP_TIME));
      NEW_LINE(LOGFILE);

    else

      PUT(LOGFILE, LOGFILE_KEYS'POS(UNIT_STOP), 0);
      PUT_UNIT_ID(UNIT_IDENTIFIER);
      NEW_LINE(LOGFILE);

    end if;

  end STOP_UNIT;


  -----------------------
  function STARTING_DELAY(--| Records a delay for the specified unit and
                          --| duration in the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    SECONDS         : in DURATION

      ) return DURATION is

    --| Effects
    --| Records a delay for the specified unit and duration in the
    --| Execution Log File. The length of the Delay is returned to
    --| the calling unit.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors

    use CALENDAR;

  begin

    if TIMING then
      PUT(LOGFILE, LOGFILE_KEYS'POS(DELAY_TIME), 0);
      PUT_UNIT_ID(UNIT_IDENTIFIER);
      PUT_TIME_OF_DAY(LOGFILE, SECONDS);
      NEW_LINE(LOGFILE);
    end if;

    return SECONDS;

  end STARTING_DELAY;


  ------------------------
  procedure PUT_BREAKPOINT(--| Puts info about the current breakpont to ELF

    BREAKPOINT_TYPE    : in BREAKPOINT_TYPES; --| The type of breakpoint

    UNIT_IDENTIFIER    : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    CURRENT_BREAKPOINT : in BREAKPOINT_NUMBER_RANGE
    --| The breakpoint number assigned by the Source Instrumenter

      ) is

    --| Effects
    --| Puts the program unit, statement type, and current breakpoint
    --| number to the execution log file.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors

    use CALENDAR;

  begin

    PUT(LOGFILE, LOGFILE_KEYS'POS(BREAKPOINT_TYPE), 0);
    PUT_UNIT_ID(UNIT_IDENTIFIER);
    PUT(LOGFILE, CURRENT_BREAKPOINT, 0);
    NEW_LINE(LOGFILE);

  end PUT_BREAKPOINT;


  -----------------------------
  procedure PUT_CALL_PARAMETERS( --| Log AutoPath input parameter list to ELF

    CALL_PARAMETERS : in INPUT_PARAMETER_LIST
                  --| The user specified input parameter list

      ) is

    --| Effects
    --| Logs the calling parameter list for a single execution of the
    --| unit under test by the AutoPath shell.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.

    --| N/A:  Raises, Modifies, Errors

  begin

    PUT(LOGFILE, LOGFILE_KEYS'POS(AUTOPATH_CALL), 0);
    PUT_LINE(LOGFILE, " " & VALUE(CALL_PARAMETERS));

  end PUT_CALL_PARAMETERS;


  -------------------
  procedure PUT_VALUE(--| Logs value of integer variable to the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    VARIABLE_NAME   : in STRING; --| The name of the variable

    INTEGER_VALUE   : in INTEGER --| The variable's value

      ) is

    --| Effects
    --| Logs integer values to the execution log file.
    --| Puts the program unit, variable name, and current value.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors

  begin

    PUT(LOGFILE, LOGFILE_KEYS'POS(INTEGER_VARIABLE), 0);
    PUT_UNIT_ID(UNIT_IDENTIFIER);
    PUT(LOGFILE, VARIABLE_NAME & " ");
    PUT(LOGFILE, INTEGER_VALUE, 0);
    NEW_LINE(LOGFILE);

  end PUT_VALUE;


  -------------------
  procedure PUT_VALUE(--| Logs value of Long_Integer variable to the ELF

    UNIT_IDENTIFIER    : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    VARIABLE_NAME      : in STRING;      --| The name of the variable

    LONG_INTEGER_VALUE : in LONG_INTEGER --| The variable's value

      ) is

    --| Effects
    --| Logs long_integer values to the execution log file.
    --| Puts the program unit, variable name, and current value.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors

    package NEW_LONG_INTEGER_IO is
      new INTEGER_IO(LONG_INTEGER);
    use NEW_LONG_INTEGER_IO;

  begin
    NEW_INTEGER_IO.PUT(LOGFILE, LOGFILE_KEYS'POS(LONG_INTEGER_VARIABLE), 0);
    PUT_UNIT_ID(UNIT_IDENTIFIER);
    PUT(LOGFILE, VARIABLE_NAME & " ");
    NEW_LONG_INTEGER_IO.PUT(LOGFILE, LONG_INTEGER_VALUE, 0);
    NEW_LINE(LOGFILE);
  end PUT_VALUE;


  -------------------
  procedure PUT_VALUE(--| Logs value of FLOAT variable to the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    VARIABLE_NAME   : in STRING; --| The name of the variable

    FLOAT_VALUE     : in FLOAT   --| The variable's value

      ) is

    --| Effects
    --| Logs floating point values to the execution log file
    --| Puts the program unit, variable name, and current value

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors

    package NEW_FLOAT_IO is
      new FLOAT_IO(FLOAT);
    use NEW_FLOAT_IO;

  begin

    PUT(LOGFILE, LOGFILE_KEYS'POS(FLOAT_VARIABLE), 0);
    PUT_UNIT_ID(UNIT_IDENTIFIER);
    PUT(LOGFILE, VARIABLE_NAME & " ");
    PUT(LOGFILE, FLOAT_VALUE, 0);
    NEW_LINE(LOGFILE);

  end PUT_VALUE;


  -------------------
  procedure PUT_VALUE(--| Logs value of Long_Float variable to the ELF

    UNIT_IDENTIFIER  : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    VARIABLE_NAME    : in STRING;    --| The name of the variable

    LONG_FLOAT_VALUE : in LONG_FLOAT --| The variable's value

      ) is

    --| Effects
    --| Logs long_float values to the execution log file.
    --| Puts the program unit, variable name, and current value.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors

    package NEW_LONG_FLOAT_IO is
      new FLOAT_IO(LONG_FLOAT);
    use NEW_LONG_FLOAT_IO;

  begin
    PUT(LOGFILE, LOGFILE_KEYS'POS(LONG_FLOAT_VARIABLE), 0);
    PUT_UNIT_ID(UNIT_IDENTIFIER);
    PUT(LOGFILE, VARIABLE_NAME & " ");
    PUT(LOGFILE, LONG_FLOAT_VALUE, 0);
    NEW_LINE(LOGFILE);
  end PUT_VALUE;


  -------------------
  procedure PUT_VALUE(--| Logs value of string variable to the ELF

    UNIT_IDENTIFIER : in PROGRAM_UNIT_UNIQUE_IDENTIFIER;
    --| A unique ID assigned by the Source Instrumenter for the current unit

    VARIABLE_NAME   : in STRING; --| The name of the variable

    STRING_VALUE    : in STRING  --| The variable's value

      ) is

    --| Effects
    --| Logs string values to the execution log file
    --| Puts the program unit, variable name, and current value
    --| This procedure used to log the value of
    --|        strings
    --|        characters
    --|        enumerated data types (including booleans)
    --| If STRING_VALUE contains trailing blanks then the
    --| trailing blanks are suppressed and the notation <<N blanks>>
    --| is appended, where N is the number of trailing blanks

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.
    --| The program unit must have been previously defined to the log file by
    --| the calling program via a call to the procedure Define_Compilation_Unit.

    --| N/A:  Raises, Modifies, Errors

    NUMBER_OF_BLANKS : NATURAL := 0;

  begin
    PUT(LOGFILE, LOGFILE_KEYS'POS(STRING_VARIABLE), 0);
    PUT_UNIT_ID(UNIT_IDENTIFIER);
    for i in reverse STRING_VALUE'range loop
      if STRING_VALUE(i) = ' ' then
        NUMBER_OF_BLANKS := NUMBER_OF_BLANKS + 1;
      else
        exit;
      end if;
    end loop;

    PUT(LOGFILE, VARIABLE_NAME & " ");

    if STRING_VALUE'last > NUMBER_OF_BLANKS then
      PUT(LOGFILE, STRING_VALUE(1..STRING_VALUE'last - NUMBER_OF_BLANKS));
    end if;

    case NUMBER_OF_BLANKS is
      when 0 =>
        NEW_LINE(LOGFILE);
      when 1 =>
        PUT_LINE(LOGFILE, "<<1 blank>>");
      when others =>
        PUT(LOGFILE, "<<");
        PUT(LOGFILE, NUMBER_OF_BLANKS, 0);
        PUT_LINE(LOGFILE, " blanks>>");
    end case;
  end PUT_VALUE;


  -------------------
  procedure CLOSE_LOG(  --| Closes the execution log file

    ACCUMULATED_OVERHEAD : in DURATION  --| Total accumulated tool overhead

      ) is

    --| Raises:  Logfile_Access_Error

    --| Effects
    --| Closes the execution log file.
    --| If the logfile has not been previously opened via a call to
    --| the procedure Create_Log then the exception Logfile_Access_Error
    --| is raised.

    --| Requires
    --| The log file must have been previously opened by the calling
    --| program via a call to Create_Log.

    --| N/A:  Modifies, Errors

    use CALENDAR;

  begin

    if not LOGFILE_IS_OPEN then
      raise LOGFILE_ACCESS_ERROR;
    end if;

    if TIMING then
      PUT(LOGFILE, LOGFILE_KEYS'POS(TIMING_OVERHEAD), 0);
      PUT(LOGFILE, ' ');
      PUT_TIME_OF_DAY(LOGFILE, ACCUMULATED_OVERHEAD);
    end if;

    CLOSE(LOGFILE);

    LOGFILE_IS_OPEN := FALSE;  --| Logfile is now closed for business

    --| Reset Timing to true just in case AutoPath
    --| tries to create more than 1 logfile
    TIMING := TRUE;

  end CLOSE_LOG;

end WRITE_LOG;