Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/misc/abstract.src

Text File | 1988-05-03 | 559.2 KB | 17,977 lines

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--VMSLIB.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

package VMS_Lib is

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

procedure Set_Error;

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

procedure get_foreign(
    P : out STRING
    );

pragma interface (EXTERNAL,GET_FOREIGN);
pragma IMPORT_VALUED_PROCEDURE(GET_FOREIGN,"LIB$GET_FOREIGN",
    (STRING),
    (DESCRIPTOR(S))
    );

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

end VMS_Lib;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--STRING.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/abstractions/string/RCS/string.spc,v $
-- $Revision: 1.1 $ -- $Date: 85/01/10 17:51:46 $ -- $Author: ron $

-- $Source: /nosc/work/abstractions/string/RCS/string.spc,v $
-- $Revision: 1.1 $ -- $Date: 85/01/10 17:51:46 $ -- $Author: ron $

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: 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: 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: string_type; s2: 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: string; s2: 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: string_type; i: positive; len: 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: string_type; i: positive; len: 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: string_type; i: 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: string_type; s2: string; i: 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: string; s2: string_type; i: 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: 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: 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: 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: 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: 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: 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: string_type)
        return boolean;

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

    function length(s: string_type)
        return natural;

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

    function value(s: 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: string_type; i: 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: 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: string_type; s2: string)
        return boolean;

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

    function equal(s1: string; s2: string_type)
        return boolean;

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

    function "<"(s1: string_type; s2: string_type)
        return boolean;

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

    function "<"(s1: string_type; s2: string)
        return boolean;

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

    function "<"(s1: string; s2: string_type)
        return boolean;

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

    function "<="(s1: string_type; s2: string_type)
        return boolean;

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

    function "<="(s1: string_type; s2: string)
        return boolean;

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

    function "<="(s1: string; s2: string_type)
        return boolean;

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

    function match_c(s: string_type; c: character; start: 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: string_type; c: character; start: 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: string_type; start: 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: string_type; s2: string; start: 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: string_type; start: 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: string_type; any: string; start: 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: string_type; start: 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: string_type; none: string; start: 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;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--SCANNER.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with String_Pkg;            use String_Pkg;

package String_Scanner is

--| Functions for scanning tokens from strings.
                                                    pragma Page;
--| Overview
--| This package provides a set of functions used to scan tokens from
--| strings.  After the function make_Scanner is called to convert a string
--| into a string Scanner, the following functions may be called to scan
--| various tokens from the string:
--|-
--| Make_Scanner    Given a string returns a Scanner
--| Destroy_Scanner    Free storage used by Scanner
--| More        Return TRUE iff unscanned characters remain
--| Forward             Bump the Scanner
--| Backward        Bump back the Scanner
--| Get            Return character
--| Next        Return character and bump the Scanner
--| Get_String        Return String_Type in Scanner
--| Get_Remainder    Return String_Type in Scanner from current Index
--| Mark        Mark the current Index for Restore
--| Restore        Restore the previously marked Index
--| Position        Return the current position of the Scanner
--| Is_Word        Return TRUE iff Scanner is at a non-blank character
--| Scan_Word        Return sequence of non blank characters
--| Is_Number        Return TRUE iff Scanner is at a digit
--| Scan_Number (2)    Return sequence of decimal digits
--| Is_Signed_Number    Return TRUE iff Scanner is at a digit or sign
--| Scan_Signed_Number (2)
--|            sequence of decimal digits with optional sign (+/-)
--| Is_Space        Return TRUE iff Scanner is at a space or tab
--| Scan_Space        Return sequence of spaces or tabs
--| Skip_Space        Advance Scanner past white space
--| Is_Ada_Id        Return TRUE iff Scanner is at first character of ada id
--| Scan_Ada_Id        Scan an Ada identifier
--| Is_Quoted        Return TRUE iff Scanner is at a double quote
--| Scan_Quoted        Scan quoted string, embedded quotes doubled
--| Is_Enclosed        Return TRUE iff Scanner is at an enclosing character
--| Scan_Enclosed    Scan enclosed string, embedded enclosing character doubled
--| Is_Sequence        Return TRUE iff Scanner is at some character in sequence
--| Scan_Sequence    Scan user specified sequence of chars
--| Is_Not_Sequence    Return TRUE iff Scanner is not at the characters in sequence
--| Scan_Not_Sequence    Scan string up to but not including a given sequence of chars
--| Is_Literal            Return TRUE iff Scanner is at literal
--| Scan_Literal    Scan user specified literal
--| Is_Not_Literal    Return TRUE iff Scanner is not a given literal
--| Scan_Not_Literal    Scan string up to but not including a given literal
--|+

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

Out_Of_Bounds : exception;    --| Raised when a operation is attempted on a
                --| Scanner that has passed the end
Scanner_Already_Marked : exception;
                --| Raised when a Mark is attemped on a Scanner
                --| that has already been marked

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

type Scanner is private;    --| Scanner type

----------------------------------------------------------------
                                                    pragma Page;
function Make_Scanner(        --| Construct a Scanner from S.
    S : in String_Type        --| String to be scanned.
    ) return Scanner;

--| Effects: Construct a Scanner from S.
--| N/A: Raises, Modifies, Errors

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

procedure Destroy_Scanner(    --| Free Scanner storage
    T : in out Scanner        --| Scanner to be freed
    );

--| Effects: Free space occupied by the Scanner.
--| N/A: Raises, Modifies, Errors

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

function More(            --| Check if Scanner is exhausted
    T : in Scanner        --| Scanner to check
    ) return boolean;

--| Effects: Return TRUE iff additional characters remain to be scanned.
--| N/A: Raises, Modifies, Errors

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

procedure Forward(        --| Bump scanner
    T : in Scanner        --| Scanner
    );

--| Effects: Update the scanner position.
--| N/A: Raises, Modifies, Errors

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

procedure Backward(        --| Bump back scanner
    T : in Scanner        --| Scanner
    );

--| Effects: Update the scanner position.
--| N/A: Raises, Modifies, Errors

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

function Get(            --| Return character
    T : in     Scanner        --| Scanner to check
    ) return character;

--| Raises: Out_Of_Bounds
--| Effects: Return character at the current Scanner position.
--| The scanner position remains unchanged.
--| N/A: Modifies, Errors

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

procedure Next(            --| Return character and bump scanner
    T : in     Scanner;        --| Scanner to check
    C :    out character    --| Character to be returned
    );

--| Raises: Out_Of_Bounds
--| Effects: Return character at the current Scanner position and update
--| the position.
--| N/A: Modifies, Errors

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

function Position(        --| Return current Scanner position
    T : in Scanner        --| Scanner to check
    ) return positive;

--| Raises: Out_Of_Bounds
--| Effects: Return a positive integer indicating the current Scanner position,
--| N/A: Modifies, Errors

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

function Get_String(        --| Return contents of Scanner
    T : in Scanner        --| Scanner
    ) return String_Type;

--| Effects: Return a String_Type corresponding to the contents of the Scanner
--| N/A: Raises, Modifies, Errors

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

function Get_Remainder(        --| Return contents of Scanner from index
    T : in Scanner
    ) return String_Type;

--| Effects: Return a String_Type starting at the current index of the Scanner
--| N/A: Raises, Modifies, Errors

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

procedure Mark(
    T : in Scanner
    );

--| Raises: Scanner_Already_Marked
--| Effects: Mark the current index for possible future use
--| N/A: Modifies, Errors

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

procedure Restore(
    T : in Scanner
    );

--| Effects: Restore the index to the previously marked value
--| N/A: Raises, Modifies, Errors

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

                                                    pragma Page;
function Is_Word(        --| Check if Scanner is at the start of a word.
    T : in Scanner        --| Scanner to check
    ) return boolean;

--| Effects: Return TRUE iff Scanner is at the start of a word.
--| N/A: Raises, Modifies, Errors

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

procedure Scan_word(        --| Scan sequence of non blank characters
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff a word found
    Result :    out String_Type;--| Word scanned from string
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan T for a sequence of non blank
--| characters.  If at least one is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.

--| N/A: Raises, Modifies, Errors
                                                    pragma Page;
function Is_Number(        --| Return TRUE iff Scanner is at a decimal digit
    T : in Scanner        --| The string being scanned
    ) return boolean;

--| Effects: Return TRUE iff Scan_Number would return a non-null string.
--| N/A: Raises, Modifies, Errors

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

procedure Scan_Number(        --| Scan sequence of digits
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff one or more digits found
    Result :    out String_Type;--| Number scanned from string
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan T for a sequence of digits.
--| If at least one is found, return Found => TRUE, Result => <the digits>.
--| Otherwise return Found => FALSE and Result is unpredictable.

--| Modifies: Raises, Modifies, Errors

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

procedure Scan_Number(        --| Scan sequence of digits
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff one or more digits found
    Result :    out integer;    --| Number scanned from string
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan T for a sequence of digits.
--| If at least one is found, return Found => TRUE, Result => <the digits>.
--| Otherwise return Found => FALSE and Result is unpredictable.

--| Modifies: Raises, Modifies, Errors
                                                    pragma Page;
function Is_Signed_Number(    --| Check if Scanner is at a decimal digit or
                --| sign (+/-)
    T : in Scanner        --| The string being scanned
    ) return boolean;

--| Effects: Return TRUE iff Scan_Signed_Number would return a non-null
--| string.

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

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

procedure Scan_Signed_Number(    --| Scan signed sequence of digits
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff one or more digits found
    Result :    out String_Type;--| Number scanned from string
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan T for a sequence of digits preceeded with optional sign.
--| If at least one digit is found, return Found => TRUE,
--| Result => <the digits>.
--| Otherwise return Found => FALSE and Result is unpredictable.

--| Modifies: Raises, Modifies, Errors

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

procedure Scan_Signed_Number(    --| Scan signed sequence of digits
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff one or more digits found
    Result :    out integer;    --| Number scanned from string
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan T for a sequence of digits preceeded with optional sign.
--| If at least one digit is found, return Found => TRUE,
--| Result => <the digits>.
--| Otherwise return Found => FALSE and Result is unpredictable.

--| Modifies: Raises, Modifies, Errors
                                                    pragma Page;
function Is_Space(        --| Check if T is at a space or tab
    T : in Scanner        --| The string being scanned
    ) return boolean;

--| Effects: Return TRUE iff Scan_Space would return a non-null string.
--| Modifies: Raises, Modifies, Errors

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

procedure Scan_Space(        --| Scan sequence of white space characters
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff space found
    Result :    out String_Type    --| Spaces scanned from string
    );

--| Effects: Scan T past all white space (spaces
--| and tabs.  If at least one is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.

--| Modifies: Raises, Modifies, Errors

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

procedure Skip_Space(        --| Skip white space
    T : in Scanner        --| String to be scanned
    );

--| Effects: Scan T past all white space (spaces and tabs).
--| Modifies: Raises, Modifies, Errors
                                                    pragma Page;
function Is_Ada_Id(        --| Check if T is at an Ada identifier
    T : in Scanner        --| The string being scanned
    ) return boolean;

--| Effects: Return TRUE iff Scan_Ada_Id would return a non-null string.
--| Modifies: Raises, Modifies, Errors

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

procedure Scan_Ada_Id(        --| Scan Ada identifier
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff an Ada identifier found
    Result :    out String_Type;--| Identifier scanned from string
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan T for a valid Ada identifier.
--| If one is found, return Found => TRUE, Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.

--| Modifies: Raises, Modifies, Errors
                                                    pragma Page;
function Is_Quoted(        --| Check if T is at a double quote
    T : in Scanner        --| The string being scanned
    ) return boolean;

--| Effects: Return TRUE iff T is at a quoted string (eg. ... "Hello" ...).
--| Modifies: Raises, Modifies, Errors

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

procedure Scan_Quoted(        --| Scan a quoted string
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff a quoted string found
    Result :    out String_Type;--| Quoted string scanned from string
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan at T for an opening quote
--| followed by a sequence of characters and ending with a closing
--| quote.  If successful, return Found => TRUE, Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| A pair of quotes within the quoted string is converted to a single quote.
--| The outer quotes are stripped.

--| Modifies: Raises, Modifies, Errors
                                                    pragma Page;
function Is_Enclosed(        --| Check if T is at an enclosing character
    B : in character;        --| Enclosing open character
    E : in character;        --| Enclosing close character
    T : in Scanner        --| The string being scanned
    ) return boolean;

--| Effects: Return TRUE iff T as encosed by B and E (eg. ... [ABC] ...).
--| Modifies: Raises, Modifies, Errors

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

procedure Scan_Enclosed(    --| Scan an enclosed string
    B      : in character;    --| Enclosing open character
    E      : in character;    --| Enclosing close character
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff a quoted string found
    Result :    out String_Type;--| Quoted string scanned from string
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan at T for an enclosing character
--| followed by a sequence of characters and ending with an enclosing character.
--| If successful, return Found => TRUE, Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| The enclosing characters are stripped.

--| Modifies: Raises, Modifies, Errors
                                                    pragma Page;
function Is_Sequence(        --| Check if T is at some sequence characters
    Chars : in String_Type;    --| Characters to be scanned
    T     : in Scanner        --| The string being scanned
    ) return boolean;

--| Effects: Return TRUE iff T is at some character of Chars.
--| Modifies: Raises, Modifies, Errors

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

function Is_Sequence(        --| Check if T is at some sequence characters
    Chars : in string;        --| Characters to be scanned
    T     : in Scanner        --| The string being scanned
    ) return boolean;

--| Effects: Return TRUE iff T is at some character of Chars.
--| Modifies: Raises, Modifies, Errors

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

procedure Scan_Sequence(    --| Scan arbitrary sequence of characters
    Chars  : in     String_Type;--| Characters that should be scanned
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff a sequence found
    Result :    out String_Type;--| Sequence scanned from string
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan T for a sequence of characters C such that C appears in
--| Char.  If at least one is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.

--| Modifies: Raises, Modifies, Errors

--| Notes:
--| Scan_Sequence("0123456789", S, Index, Found, Result)
--| is equivalent to Scan_Number(S, Index, Found, Result)
--| but is less efficient.

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

procedure Scan_Sequence(    --| Scan arbitrary sequence of characters
    Chars  : in     string;    --| Characters that should be scanned
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff a sequence found
    Result :    out String_Type;--| Sequence scanned from string
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan T for a sequence of characters C such that C appears in
--| Char.  If at least one is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.

--| Modifies: Raises, Modifies, Errors

--| Notes:
--| Scan_Sequence("0123456789", S, Index, Found, Result)
--| is equivalent to Scan_Number(S, Index, Found, Result)
--| but is less efficient.
                                                    pragma Page;
function Is_Not_Sequence(    --| Check if T is not at some seuqnce of character
    Chars : in String_Type;    --| Characters to be scanned
    T     : in Scanner        --| The string being scanned
    ) return boolean;

--| Effects: Return TRUE iff T is not at some character of Chars.
--| Modifies: Raises, Modifies, Errors

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

function Is_Not_Sequence(    --| Check if T is at some sequence of characters
    Chars : in string;        --| Characters to be scanned
    T     : in Scanner        --| The string being scanned
    ) return boolean;

--| Effects: Return TRUE iff T is not at some character of Chars.
--| Modifies: Raises, Modifies, Errors

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

procedure Scan_Not_Sequence(    --| Scan arbitrary sequence of characters
    Chars  : in     String_Type;--| Characters that should be scanned
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff a sequence found
    Result :    out String_Type;--| Sequence scanned from string
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan T for a sequence of characters C such that C does not appear
--| in Chars.  If at least one such C is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.

--| Modifies: Raises, Modifies, Errors

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

procedure Scan_Not_Sequence(    --| Scan arbitrary sequence of characters
    Chars  : in     string;    --| Characters that should be scanned
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff a sequence found
    Result :    out String_Type;--| Sequence scanned from string
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan T for a sequence of characters C such that C does not appear
--| in Chars.  If at least one such C is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.

--| Modifies: Raises, Modifies, Errors
                                                    pragma Page;
function Is_Literal(        --| Check if T is at literal Chars
    Chars : in String_Type;    --| Characters to be scanned
    T     : in Scanner        --| The string being scanned
    ) return boolean;

--| Effects: Return TRUE iff T is at literal Chars.
--| Modifies: Raises, Modifies, Errors

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

function Is_Literal(        --| Check if T is at literal Chars
    Chars : in string;        --| Characters to be scanned
    T     : in Scanner        --| The string being scanned
    ) return boolean;

--| Effects: Return TRUE iff T is at literal Chars.
--| Modifies: Raises, Modifies, Errors

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

procedure Scan_Literal(        --| Scan arbitrary literal
    Chars  : in     String_Type;--| Literal that should be scanned
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff a sequence found
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan T for a litral Chars such that Char matches the sequence
--| of characters in T.  If found, return Found => TRUE,
--| Otherwise return Found => FALSE

--| Modifies: Raises, Modifies, Errors

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

procedure Scan_Literal(        --| Scan arbitrary literal
    Chars  : in     string;    --| Literal that should be scanned
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff a sequence found
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan T for a litral Chars such that Char matches the sequence
--| of characters in T.  If found, return Found => TRUE,
--| Otherwise return Found => FALSE

--| Modifies: Raises, Modifies, Errors
                                                    pragma Page;
function Is_Not_Literal(    --| Check if T is not at literal Chars
    Chars : in string;        --| Characters to be scanned
    T     : in Scanner        --| The string being scanned
    ) return boolean;

--| Effects: Return TRUE iff T is not at literal Chars
--| Modifies: Raises, Modifies, Errors

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

function Is_Not_Literal(    --| Check if T is not at literal Chars
    Chars : in String_Type;    --| Characters to be scanned
    T     : in Scanner        --| The string being scanned
    ) return boolean;

--| Effects: Return TRUE iff T is not at literal Chars
--| Modifies: Raises, Modifies, Errors

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

procedure Scan_Not_Literal(    --| Scan arbitrary literal
    Chars  : in     string;    --| Literal that should be scanned
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff a sequence found
    Result :    out String_Type;--| String up to literal
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan T for a litral Chars such that Char does not match the
--| sequence of characters in T.  If found, return Found => TRUE,
--| Otherwise return Found => FALSE

--| Modifies: Raises, Modifies, Errors

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

procedure Scan_Not_Literal(    --| Scan arbitrary literal
    Chars  : in     String_Type;--| Literal that should be scanned
    T      : in     Scanner;    --| String to be scanned
    Found  :    out boolean;    --| TRUE iff a sequence found
    Result :    out String_Type;--| String up to literal
    Skip   : in     boolean := false
                --| Skip white spaces before scan
    );

--| Effects: Scan T for a litral Chars such that Char does not match the
--| sequence of characters in T.  If found, return Found => TRUE,
--| Otherwise return Found => FALSE

--| Modifies: Raises, Modifies, Errors
                                                    pragma Page;
private
                                                    pragma List(off);
    type Scan_Record is
    record
        text  : String_Type;    --| Copy of string being scanned
        index : positive := 1;    --| Current position of Scanner
        mark  : natural := 0;    --| Mark
    end record;

    type Scanner is access Scan_Record;
                                                    pragma List(on);
end String_Scanner;
                                                    pragma Page;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--CLI.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with String_pkg;
use String_pkg;

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

Package command_line_interface is
--| Provides primitives for getting at the command line arguments.

--| Overview
--| This package provides a universal and portable interface to
--| the arguments typed on a command line when a program is invoked.
--| Each command line argument is either a Word (sequence of non-blank
--| characters) or a quoted string, with embedded quotes doubled.
--|
--| Both named and positional arguments may be given on the command
--| line.  However, once a named parameter is used, all the subseqent
--| parameters on the command line must be named parameters.  For example,
--| the commands
--|-
--|     compile  abc pqr xyz library => plib
--|     compile  abc,pqr,unit=>xyz,library=>plib
--|+
--| have one named argument and three positional arguments.  This
--| package separates the named parameters from the positional
--| parameters, ignores spaces around the "bound to" (=>) symbol, and
--| allows parameters to be separated by either spaces or commas,
--| so these command lines are indistinguishable.
--|
--| At program elaboration time, the command line string is automatically
--| obtained from the host operating system and parsed into
--| individual arguments.  The following operations may then be used:
--|-
--| Named_arg_count()        Returns number of named arguments entered
--| Positional_arg_count()    Returns number of positional arguments
--| Positional_arg_value(N)    Returns the Nth positional argument
--| Named_arg_value(Name, Dflt)    Returns value of a named argument
--| Arguments()            Returns the entire command line
--|+

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

max_args: constant := 255;
--| Maximum number of command line arguments (arbitrary).

subtype Argument_count is integer range 0..max_args;
--| For number of arguments
subtype Argument_index is Argument_count range 1..Argument_count'last;
--| Used to number the command line arguments.

no_arg: exception;
  --| Raised when request made for nonexistent argument

missing_positional_arg: exception;
  --| Raised when command line is missing positional argument (A,,B)

invalid_named_association: exception;
  --| Raised when command line is missing named argument value (output=> ,A,B)

unreferenced_named_arg: exception;
  --| Raised when not all named parameters have been retrieved

invalid_parameter_order: exception;
  --| Raised when a positional parameter occurs after a named parameter
  --  in the command line

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

procedure Initialize;           --| Initializes command_line_interface

--| N/A: modifies, errors, raises

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

function Named_arg_count    --| Return number of named arguments
  return Argument_count;
--| N/A: modifies, errors, raises


function Positional_arg_count    --| Return number of positional arguments
  return Argument_count;
--| N/A: modifies, errors, raises


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

function Positional_arg_value(    --| Return an argument value
  N: Argument_index            --| Position of desired argument
  ) return string;              --| Raises: no_arg

--| Effects: Return the Nth argument.  If there is no argument at
--| position N, no_arg is raised.

--| N/A: modifies, errors


function Positional_arg_value(        --| Return an argument value
  N: Argument_index                --| Position of desired argument
  ) return String_type;             --| Raises: no_arg

--| Effects: Return the Nth argument.  If there is no argument at
--| position N, no_arg is raised.

--| N/A: modifies, errors

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

function Named_arg_value(--| Return a named argument value
  Name: string;
  Default: string
  ) return string;

--| Effects: Return the value associated with Name on the command
--| line.  If there was none, return Default.

--| N/A: modifies, errors


function Named_arg_value(--| Return a named argument value
  Name: string;
  Default: String_type
  ) return String_type;

--| Effects: Return the value associated with Name on the command
--| line.  If there was none, return Default.

--| N/A: modifies, errors

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

function Arguments    --| Return the entire argument string
  return string;
--| Effects: Return the entire command line, except for the name
--| of the command itself.

--| N/A: modifies, errors, raises

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

procedure Finalize ;    --| Raises: unrecognized parameters

--| Effects: If not all named parameters have been retrieved
--| unrecognized parameters is raised.
--| N/A: modifies, errors

end command_line_interface;

----------------------------------------------------------------
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--CLI.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with Text_IO; use Text_IO;
with VMS_Lib;    -- For lib$get_foreign
with String_pkg;
with String_scanner;
----------------------------------------------------------------

Package body command_line_interface is
--| Provides primitives for getting at the command line arguments.

--| Overview

Package sp renames String_pkg;
Package ss renames String_scanner;

type Name_value is                  --| Name/Value pair
  record
    Name:  sp.String_type;          --| Name of value
    Value: sp.String_type;          --| Value associated with name
    Was_retrieved: boolean:=FALSE;  --| Flag indicating whether name-value
  end record;                       --  association has been retrieved by tool

type Token_type is (Ada_ID,Word,Bound_to,None);

Package Token_type_IO is new Enumeration_IO(Token_type);
use Token_type_IO;

Arg_string: string(1..132);        --| String obtained from operating system
                                    --  (ie. from get_foreign)
N_arg_count: Argument_count;        --| Count of named args
P_arg_count: Argument_count;        --| Count of positional args
Rejected: boolean := FALSE;

Named_args: array(argument_index)
   of Name_value;

Positional_args: array(argument_index)
   of sp.String_type;

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

-- Local functions:

procedure Get_token(
  Scan_string : in out ss.Scanner;
  Argument : in out sp.String_type;
  Kind: in out Token_type
  ) is

  Last_arg: sp.String_type;
  Last_kind: Token_type;
  Found: boolean;
  Delimeter: sp.String_type;
  Delim_string: ss.Scanner;
  More_commas: boolean := FALSE;
  Tail: sp.String_type;

begin

  if Rejected then
    Argument := Last_arg;
    Kind := Last_kind;
    Rejected := FALSE;
  else
    if ss.Is_sequence(" ,",Scan_string) then
        ss.Scan_sequence(" ,",Scan_string,Found,Delimeter);
        Delim_string := ss.Make_scanner(Delimeter);
        loop
            ss.Skip_space(Delim_string);
            exit when not ss.More(Delim_string);
            ss.Forward(Delim_string);
            if More_commas then
                raise missing_positional_arg;
            end if;
            More_commas := TRUE;
        end loop;
    end if;
       if ss.Is_Ada_Id(Scan_string) then
        ss.Scan_Ada_Id(Scan_string,Found,Argument);
        if ss.Is_Literal("=>",Scan_string) or
           ss.Is_Literal("""",Scan_string) or
           ss.Is_sequence(" ,",Scan_string) or
           not ss.More(Scan_string) then
            Kind := Ada_ID;
        else
            if ss.Is_not_sequence(" ,",Scan_string) then
                ss.Scan_not_sequence(" ,",Scan_string,Found,Tail);
                Argument := sp."&"(Argument,Tail);
                Kind := Word;
            else
                ss.Scan_word(Scan_string,Found,Tail);
                Argument := sp."&"(Argument,Tail);
                Kind := Word;
            end if;
        end if;
    elsif ss.Is_Literal("=>",Scan_string) then
        ss.Scan_Literal("=>",Scan_string,Found);
        Argument := sp.Create("=>");
        Kind := Bound_to;
    elsif ss.Is_quoted(Scan_string) then
        ss.Scan_quoted(Scan_string,Found,Argument);
        Kind := Word;
    elsif ss.Is_enclosed('(',')',Scan_string) then
        ss.Scan_enclosed('(',')',Scan_string,Found,Argument);
        Kind := Word;
    elsif ss.Is_not_sequence(" ,",Scan_string) then
        ss.Scan_not_sequence(" ,",Scan_string,Found,Argument);
        Kind := Word;
       elsif ss.Is_word(Scan_string) then
        ss.Scan_word(Scan_string,Found,Argument);
        Kind := Word;
    else
          Argument := sp.Create("");
        Kind := None;
    end if;
    Last_kind := Kind;
    Last_arg := Argument;
  end if;
end Get_token;

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

procedure Save_named(
  Name : in sp.String_type;
  Value : in sp.String_type
  ) is

begin
  N_arg_count := N_arg_count + 1;
  Named_args(N_arg_count).Name := Name;
  Named_args(N_arg_count).Value := Value;
end Save_named;

procedure Save_positional(
  Value : in sp.String_type
  ) is

begin
  if N_arg_count > 0 then
    raise invalid_parameter_order;
  end if;
  P_arg_count := P_arg_count + 1;
  Positional_args(P_arg_count) := Value;
end Save_positional;

procedure Reject_token is

begin
  Rejected := TRUE;
end Reject_token;

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

procedure Initialize is

begin

  declare

     type State_type is (Have_nothing,Have_Ada_ID,Have_bound_to);

     Index: integer;            --| Index of characters in argument string
     Scan_string: ss.Scanner;  --| Scanned argument string
     Argument: sp.String_Type; --| Argument scanned from argument string
     Kind: Token_type;         --| Kind of argument- WORD, =>, Ada_ID
     Old_arg: sp.String_Type;  --| Previously scanned argument
     Found: boolean;

     State: State_type := Have_nothing;
     --| State of argument in decision tree

  begin

     Index := Arg_string'first;
     N_arg_count := 0;
     P_arg_count := 0;

     -- Get the command line from the operating system
     VMS_Lib.get_foreign(Arg_string);

     -- Remove trailing blanks and final semicolon
     for i in reverse Arg_string'range loop
    if Arg_string(i) /= ' ' then
        if Arg_string(i) = ';' then
        Index := i - 1;
        else
        Index := i;
        end if;
        exit;
    end if;
     end loop;

     -- Convert argument string to scanner and remove enclosing parantheses

     Scan_string :=  ss.Make_scanner(sp.Create(Arg_string(Arg_string'first..index)));
     if ss.Is_enclosed('(',')',Scan_string) then
    ss.Mark(Scan_string);
    ss.Scan_enclosed('(',')',Scan_string,Found,Argument);
    ss.Skip_Space(Scan_string);
    if not ss.More(Scan_string) then
        ss.Destroy_Scanner(Scan_string);
        Scan_string :=  ss.Make_scanner(Argument);
    else
        ss.Restore(Scan_string);
    end if;
     end if;

     -- Parse argument string and save arguments
     loop
    Get_token(Scan_string,Argument,Kind);
    case State is
        when Have_nothing =>
            case Kind is
                when Ada_ID =>
                    Old_arg := Argument;
                    State := Have_Ada_ID;
                when Word =>
                    Save_positional(Argument);
                    State := Have_nothing;
                when Bound_to =>
                    State := Have_nothing;
                    raise invalid_named_association;
                when None =>
                    null;
            end case;
        when Have_Ada_ID =>
            case Kind is
                when Ada_ID =>
                    Save_positional(Old_arg);
                    Old_arg := Argument;
                    State := Have_Ada_ID;
                when Word =>
                    Save_positional(Old_arg);
                    Save_positional(Argument);
                    State := Have_nothing;
                when Bound_to =>
                    State := Have_bound_to;
                when None =>
                    Save_positional(Old_arg);
            end case;
        when Have_bound_to =>
            case Kind is
                when Ada_ID | Word =>
                    Save_named(Old_arg,Argument);
                    State := Have_nothing;
                when Bound_to =>
                    State := Have_bound_to;
                    raise invalid_named_association;
                when None =>
                    raise invalid_named_association;

            end case;
    end case;
    exit when Kind = None;
     end loop;
  end;
end Initialize;

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

function Named_arg_count    --| Return number of named arguments
  return Argument_count is

begin
  return N_arg_count;
end;

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

function Positional_arg_count    --| Return number of positional arguments
  return Argument_count is

begin
  return P_arg_count;
end;

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

function Positional_arg_value(    --| Return an argument value
  N: Argument_index         --| Position of desired argument
  ) return string is            --| Raises: no_arg

--| Effects: Return the Nth argument.  If there is no argument at
--| position N, no_arg is raised.

--| N/A: modifies, errors

begin
  if N > P_arg_count then
     raise no_arg;
  else
     return sp.Value(Positional_args(N));
  end if;
end;

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

function Positional_arg_value(    --| Return an argument value
  N: Argument_index         --| Position of desired argument
  ) return sp.String_type is    --| Raises: no_arg

--| Effects: Return the Nth argument.  If there is no argument at
--| position N, no_arg is raised.

--| N/A: modifies, errors

begin
  if N > P_arg_count then
     raise no_arg;
  else
     return Positional_args(N);
  end if;
end;

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

function Named_arg_value(--| Return a named argument value
  Name: string;
  Default: string
  ) return string is

--| Effects: Return the value associated with Name on the command
--| line.  If there was none, return Default.

begin
  for i in 1..N_arg_count
  loop
     if sp.Equal(sp.Upper(Named_args(i).Name),sp.Upper(sp.Create(Name))) then
        Named_args(i).Was_retrieved := TRUE;
    return sp.Value(Named_args(i).Value);
     end if;
  end loop;
  return Default;
end;
----------------------------------------------------------------

function Named_arg_value(--| Return a named argument value
  Name: string;
  Default: sp.String_type
  ) return sp.String_type is

--| Effects: Return the value associated with Name on the command
--| line.  If there was none, return Default.

begin
  for i in 1..N_arg_count
  loop
     if sp.Equal(sp.Upper(Named_args(i).Name),sp.Upper(sp.Create(Name))) then
        Named_args(i).Was_retrieved := TRUE;
    return Named_args(i).Value;
     end if;
  end loop;
  return Default;
end;

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

function Arguments    --| Return the entire argument string
  return string is

--| Effects: Return the entire command line, except for the name
--| of the command itself.

begin
  return Arg_string;
end;
----------------------------------------------------------------

procedure Finalize is   --| Raises: unreferenced_named_arg

begin
  for i in 1..Named_arg_count loop
     if Named_args(i).Was_retrieved = FALSE then
        raise unreferenced_named_arg;
     end if;
  end loop;
end Finalize;

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

end command_line_interface;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--LISTS.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

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;



--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--LISTS.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

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;

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

   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;

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

   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;

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

   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;

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

   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;

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

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--SET.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/abstractions/set2/RCS/set.spc,v $
-- $Revision: 1.2 $ -- $Date: 85/02/01 12:07:55 $ -- $Author: ron $

with lists;   --| Implementation uses lists.
pragma elaborate(lists);

generic
    type elem_type is private;

      --| Component type of the set.

    with function equal(e1, e2: elem_type) return boolean is "=";

      --| equal is required to form an equality relation on elem_type.


package set_pkg is

--| Overview:
--| This package provides the set abstract data type.  All standard set
--| operations are provided.  Standard mathematical set notation is
--| employed to describe the effects of the operations.
--|
--| The component type, and an equality relation used for membership
--| tests, are generic formals of the package. The implementation isn't
--| particularly fast, since the only available information about the
--| component type is the equality relation. However, this shouldn't be a
--| concern unless the sets become large or speed becomes important.
--| See scalar_set_pkg, hashed_set_pkg and ordered_set_pkg for other
--| implementations.
--|
--| The following is a complete list of operations, written in the order
--| in which they appear in the spec.
--|
--| Constructors:
--|        create
--|        insert
--|        delete
--|        intersect
--|        union
--|        copy
--| Query Operations:
--|        equal
--|        is_empty
--|        is_member
--|        size
--| Iterators:
--|        make_members_iter, more, next
--| Heap Management:
--|        destroy

--| Notes:
--| Programmer: Ron Kownacki
--| One of a family of set packages:
--| sets, scalar sets, hashed sets, ordered sets

    type set is private;      --| The set abstract data type.


  -- Exceptions:

    no_more: exception;       --| Raised on incorrect use of an iterator.

  -- Iterators:


    type members_iter is private;  --| Members of a set in arbitrary order


  -- Constructors:

    function create
        return set;

      --| Effects:
      --| Return {}.  This operation is not strictly necessary, since an
      --| uninitialized set object is viewed as the empty set.

    procedure insert(s: in out set;
                     e: in     elem_type);

      --| Effects:
      --| Insert the element, e, into the set, s.

    procedure delete(s: in out set;
                     e: in     elem_type);

      --| Effects:
      --| If e is in s, then remove e from s.  Otherwise, no effect.

    function intersect(s1, s2: set)
    return set;

      --| Effects:
      --| Return {e | member(s1, e) and member(s2, e)}.

    function union(s1, s2: set)
    return set;

      --| Effects:
      --| Return {e | member(s1, e) or member(s2, e)}.

    function copy(s: set)
    return set;

      --| Effects:
      --| Returns a copy of s.  Subsequent changes to s will not be
      --| visible through the application of operations to the copy of s.
      --| Assignment or parameter passing without copying will result
      --| in a single set value being shared among objects.
      --| The assignment operation is used to transfer the values of
      --| the elem_type components of s; consequently, changes in these
      --| values may be observable through both sets if these types are
      --| access types, or if they contain access type components.


  -- Query Operations:

    function equal(s1, s2: set)
        return boolean;

      --| Effects:
      --| Return (for all e: elem_type (member(s1, e) iff member(s2, e))).
      --| Note that (s1 = s2) implies equal(s1, s2) holds for all time.
      --| "=" is object equality, equal is state equality.

    function is_empty(s: set)
        return boolean;

      --| Effects:
      --| Return s = {}.

    function is_member(s: set;
                       e: elem_type)
        return boolean;

      --| Effects:
      --| Return true iff e is a member of s.

    function size(s: set)
        return natural;

      --| Effects:
      --| Return |s|, the cardinality of s.


  -- Iterators:

    function make_members_iter(s: set)
        return members_iter;

      --| Effects:
      --| Create and return a members iterator based on s.  This object
      --| can then be used in conjunction with the more function and the
      --| next procedure to iterate over the members of s in some
      --| arbitrary order.

    function more(iter: members_iter)
        return boolean;

      --| Effects:
      --| Return true iff the members iterator has not been exhausted.

    procedure next(iter: in out members_iter;
                   e:    out    elem_type);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the set, s.  Successive calls of next
      --| will return the members of s in some arbitrary order.
      --| After all members have been returned, then the procedure will
      --| raise no_more.
      --| Requires:
      --| s must not be changed between the invocations of
      --| make_nodes_iterator(g) and next.


  -- Heap management:

    procedure destroy(s: in out set);

      --| Effects:
      --| Return space consumed by the set value associated with object
      --| s to the heap.  If other objects share the same set value, then
      --| further use of these objects is erroneous.  Components of type
      --| elem_type, if they are access types, are not garbage collected.
      --| It is the user's responsibility to dispose of these objects.
      --| s is set to {}.


private

    package list_pkg is new lists(elem_type, equal);
    use list_pkg;

    type set is new list;

      --| Representation Invariants:
      --|   None; all lists are legal representations of sets.
      --| Abstraction Function:  A: representation --> set
      --|   A(null) = create.
      --|   A(attach(r, e)) = insert(A(r), e).
      --|   Sufficient since all lists can be generated by null, attach.
      --|
      --|     Note that this implementation allows faster insertion and
      --| membership testing than if duplicate insertions of an element
      --| caused a check to ensure that each element is only kept once in
      --| the list.  This implies that deleting an element always involves
      --| a scan of the entire list.

    type members_iter is new list;

      --| For a set, s, make returns members_iter(copy(list(s))).
      --| More(iter) returns true iff list(iter) isn't empty.
      --| Next(iter) returns the first element in list(iter).  Before doing
      --| this, it removes all occurrences of this element from list(iter).

end set_pkg;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--HASHMAP.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/abstractions/mapping/RCS/hash_map.spc,v $
-- $Revision: 1.2 $ -- $Date: 85/02/01 13:24:20 $ -- $Author: ron $

with lists;       -- Lists used in implementation.  (private)
pragma elaborate(lists);

generic
    type key_type is private;

      --| Domain type of the mapping.

     with function equal(k1, k2: key_type) return boolean is "=";

      --| equal is required to form an equality relation on key_type.

     type bucket_range is range <>;

      --| Defines the number of hash buckets, one for each member of
      --| bucket_range.

     with function hash(k: key_type) return bucket_range;

      --| Required property: equal(e1, e2) => hash(e1) = hash(e2).
      --| Best results if hash produces a uniform distribution
      --| over bucket_range.

     type value_type is private;

      --| Target type of the mapping.


package hashed_mapping_pkg is

--| Overview:
--| This package provides a mapping from one arbitrary type, key_type, to
--| another arbitrary type, value_type.  These types are generic formals
--| to the package, along with an equality relation on key_type, an
--| integer subtype that determines the number of hash buckets, and a
--| hashing function on key_type that maps to that integer subtype.
--|
--| For the purpose of specifying the operations in this package, we will
--| view a mapping as a set of bindings, or key/value pairs.  This allows
--| the use of set notation in description.
--|
--| The following is a complete list of operations, written in the order
--| in which they appear in the spec.
--|
--| Constructors:
--|        create
--|        bind
--|        unbind
--|        copy
--| Query Operations:
--|        is_empty
--|        size
--|        is_bound
--|        fetch
--| Iterators:
--|        make_keys_iter, more, next
--|        make_values_iter, more, next
--|        make_bindings_iter, more, next
--| Heap Management:
--|        destroy

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


    type mapping is private;    --| The hashed mapping abstract data type.


  -- Exceptions:

    no_more: exception;
      --| Raised on incorrect use of an iterator.

    uninitialized_mapping: exception;
        --| Raised on use of an unitialized mapping by most operations.

    already_bound: exception;
        --| Raised on attempt to rebind a key that is currently bound.

    not_bound: exception;
        --| Raised when a key that is expected to be bound is unbound.

  -- Iterators:

    type keys_iter is private;     --| Bound keys in arbitrary order.
    type values_iter is private;   --| Bound values in arbitrary order.
    type bindings_iter is private; --| Key,value pairs in arbitrary order


  -- Constructors:

    function create
        return mapping;

      --| Effects:
      --| Return {}.

    procedure bind(map:   in out mapping;
                   key:   in     key_type;
                   value: in     value_type);

      --| Raises: already_bound, uninitialized_mapping
      --| Effects:
      --| Insert the binding, <key, value>, into map.  Raises
      --| already_bound iff a pair, <k', v'>, where equal(key, k'),
      --| is in map.
      --| Raises uninitialized_mapping iff map has not been initialized.

    procedure unbind(map: in out mapping;
                     key: in     key_type);

      --| Raises: not_bound, uninitialized_mapping
      --| Effects:
      --| If <k, v>, where equal(key, k), is in map, then removes
      --| <k, v> from map.  Raises not_bound if no such pair exists.
      --| Raises uninitialized_mapping iff map has not been initialized.

    function copy(map: mapping)
    return mapping;

      --| Raises: uninitialized_mapping
      --| Effects:
      --| Returns a copy of map.  Subsequent changes to map will not be
      --| visible through applying operations to the copy of map.
      --| Assignment or parameter passing without copying will result
      --| in a single mapping value being shared among mapping objects.
      --| Raises uninitialized_mapping iff map has not been initialized.
      --| The assignment operation is used to transfer the values of the
      --| key_type and value_type type components of map; consequently,
      --| changes in the values of these types may be observable through
      --| both mappings if these are access types, or if they contain
      --| components of an access type.


  -- Query Operations:

    function is_empty(map: mapping)
        return boolean;

      --| Raises: uninitialized_mapping
      --| Effects:
      --| Return map = {}.
      --| Raises uninitialized_mapping iff map has not been initialized.

    function size(map: mapping)
        return natural;

      --| Raises: uninitialized_mapping
      --| Effects:
      --| Return |map|, the number of bindings in map.
      --| Raises uninitialized_mapping iff map has not been initialized.

    function is_bound(map: mapping;
                      key: key_type)
    return boolean;

       --| Raises: uninitialized_mapping
       --| Return true iff equal(key, k) for some <k, v> in map.
       --| Raises uninitialized_mapping iff map has not been initialized.

    function fetch(map: mapping;
                   key: key_type)
    return value_type;

      --| Raises: not_bound, uninitialized_mapping
      --| If <k, v>, where equal(key, k), is in map, then return v.
      --| Raises not_bound if no such <k, v> exists.
      --| Raises uninitialized_mapping iff map has not been initialized.


  -- Iterators:

    function make_keys_iter(map: mapping)
        return keys_iter;

      --| Raises: uninitialized_mapping
      --| Effects:
      --| Create and return a keys iterator based on map.  This object
      --| can then be used in conjunction with the more function and the
      --| next procedure to iterate over all keys that are bound in map.
      --| Raises uninitialized_mapping iff map has not been initialized.

    function more(iter: keys_iter)
        return boolean;

      --| Effects:
      --| Return true iff the keys iterator has not been exhausted.

    procedure next(iter: in out keys_iter;
                   key:  out    key_type);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the mapping, map.  Successive calls of next
      --| will return the bound keys of map in some arbitrary order.
      --| After all bound keys have been returned, then the procedure will
      --| raise no_more.
      --| Requires:
      --| map must not be changed between the invocations of
      --| make_keys_iterator(map) and next.

    function make_values_iter(map: mapping)
    return values_iter;

      --| Raises: uninitialized_mapping
      --| Effects:
      --| Create and return a values iterator based on map.  This object
      --| can then be used in conjunction with the more function and the
      --| next procedure to iterate over all values that are bound to keys
      --| in map.
      --| Raises uninitialized_mapping iff map has not been initialized.

    function more(iter: values_iter)
    return boolean;

      --| Effects:
      --| Return true iff the values iterator has not been exhausted.

    procedure next(iter: in out values_iter;
           val:  out    value_type);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the mapping, map.  Successive calls of next
      --| will return the bound values of map in some arbitrary order.
      --| After all bound values have been returned, then the procedure
      --| will raise no_more.
      --| Requires:
      --| map must not be changed between the invocations of
      --| make_values_iterator(map) and next.

    function make_bindings_iter(map: mapping)
    return bindings_iter;

      --| Raises: uninitialized_mapping
      --| Effects:
      --| Create and return a bindings iterator based on map.  This object
      --| can then be used in conjunction with the more function and the
      --| next procedure to iterate over all key/value pairs in map.
      --| Raises uninitialized_mapping iff map has not been initialized.

    function more(iter: bindings_iter)
    return boolean;

      --| Effects:
      --| Return true iff the bindings iterator has not been exhausted.

    procedure next(iter: in out bindings_iter;
           key:  out    key_type;
           val:  out    value_type);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the mapping, map.  Successive calls of next
      --| will return the key/value pairs of map in some arbitrary order.
      --| After all such pairs have been returned, then the procedure will
      --| raise no_more.
      --| Requires:
      --| map must not be changed between the invocations of
      --| make_bindings_iterator(map) and next.


  -- Heap management:

    procedure destroy(m: in out mapping);

      --| Effects:
      --| Return space consumed by mapping value associated with object
      --| m to the heap.  (If m is uninitialized, this operation does
      --| nothing.)  If other objects share the same mapping value, the
      --| further use of these objects is erroneous.  Components of type
      --| value_type, if they are access types, are not garbage collected.
      --| It is the user's responsibility to dispose of these objects.
      --| m is left in the uninitialized state.


private

    type component is record
        key: key_type;
    val: value_type;
    end record;

    function equal(c1, c2: component) return boolean;
        --| Effects: Return true iff equal(c1.key, c2.key).

    package bucket_pkg is new lists(component, equal);
    use bucket_pkg;


    type bucket_array is array(bucket_range) of list;

    type mapping_rec is record
        size: natural;
        buckets: bucket_array;
    end record;

    type mapping is access mapping_rec;

    --| Representation Invariants:
    --| 1. r /= null.  (This would be the uninitialized case)
    --| 2. If for some i, a component, c, is in bucket r.buckets(i),
    --|    then hash(c.key) = i.
    --| 3. If a component, c1, is in bucket, r.buckets(i), then there is
    --|    no other c2 in r.buckets(i) such that equal(c1, c2).
    --|    (Enforce one binding to a given key at any time.)
    --| 4. r.size equals the total number of components in buckets
    --|    r.buckets(bucket_range'first) through
    --|    r.buckets(bucket_range'last).
    --|
    --| Abstraction Function:
    --| A(r) is the set consisting of all key, value pairs that appear as
    --| components in buckets r.buckets(bucket_range'first) through
    --| r.buckets(bucket_range'last).


    type general_iter is record
        map: mapping;
    current: bucket_range;
    position: list;
    end record;

    --| For a given general_iter, i, the make, more and next operations
    --| have the following effects:
    --| make: Sets map field to the given mapping, sets i.current to the
    --| lowest idx of a nonempty bucket, and sets i.position to the head
    --| of that bucket.
    --| more: Returns not empty(i.position).
    --| next: key, val fields of first component of i.position.
    --| Advances i.position to next component in bucket, if it exists.
    --| Otherwise, increments i.current until a nonempty bucket, and sets
    --| i.position to this bucket.  When this fails, sets i.position to an
    --| empty bucket.


    type keys_iter is new general_iter;
    type values_iter is new general_iter;
    type bindings_iter is new general_iter;

end hashed_mapping_pkg;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--SET.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/abstractions/set2/RCS/set.bdy,v $
-- $Revision: 1.2 $ -- $Date: 85/02/01 12:07:30 $ -- $Author: ron $

package body set_pkg is

--| Overview:
--| See the package spec, private part, for the representation invariants
--| and abstraction function for sets.  These define the implementation
--| scheme.


  -- Constructors:

    function create
        return set is
    begin
        return set(list'(create));
    end create;

    procedure insert(s: in out set;
                     e: in     elem_type) is
    begin
    s := set(attach(e, list(s)));
    end insert;


    procedure delete(s: in out set;
                     e: in     elem_type) is
    begin
    DeleteItems(list(s), e);
    exception
        when ItemNotPresent =>
            null;
    end delete;

    function intersect(s1, s2: set)
    return set is
    intersect_list: list := create;
    iter: ListIter;
    e: elem_type;
    begin
    iter := MakeListIter(list(s1));
    while more(iter) loop
        next(iter, e);
        if IsInList(list(s2), e) then
        intersect_list := attach(intersect_list, e);
        end if;
    end loop;
    return set(intersect_list);
    end intersect;

    function union(s1, s2: set)
    return set is
    union_list: list;
    begin
    return set(attach(copy(list(s1)), copy(list(s2))));
    end union;

    function copy(s: set)
    return set is
    begin
    return set(copy(list(s)));
    end copy;


  -- Query Operations:

    function equal(s1, s2: set)
        return boolean is
        iter: members_iter;
        e: elem_type;
    begin
        -- s2 contains s1?
        iter := make_members_iter(s1);
        while more (iter) loop
            next(iter, e);
            if not is_member(s2, e) then return false; end if;
        end loop;

        -- s1 contains s2?
        iter := make_members_iter(s2);
        while more (iter) loop
            next(iter, e);
            if not is_member(s1, e) then return false; end if;
        end loop;

        -- s2 contains s1 and s1 contains s2 => equal(s1 = s2)
        return true;
    end equal;

    function is_empty(s: set)
        return boolean is
    begin
    return IsEmpty(list(s));
    end is_empty;

    function is_member(s: set;
                       e: elem_type)
        return boolean is
    begin
        return IsInList(list(s), e);
    end is_member;

    function size(s: set)
        return natural is
    l: list := copy(list(s));
    count: natural := 0;
    begin
    while not IsEmpty(l) loop
        count := count + 1;
        DeleteItems(l, FirstValue(l));
    end loop;
    return count;
    end size;


  -- Iterators:

    function make_members_iter(s: set)
        return members_iter is
    begin
        return members_iter(copy(list(s)));
    end make_members_iter;

    function more(iter: members_iter)
        return boolean is
    begin
    return not IsEmpty(list(iter));
    end more;

    procedure next(iter: in out members_iter;
                   e:    out    elem_type) is
        e2: elem_type;
    begin
        e := FirstValue(list(iter));
        DeleteItems(list(iter), FirstValue(list(iter)));
    exception
        when EmptyList =>
        raise no_more;
    end next;


-- Heap Management:

    procedure destroy(s: in out set) is
    begin
    destroy(list(s));
    end destroy;

end set_pkg;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--HASHMAP.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/abstractions/mapping/RCS/hash_map.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 14:48:43 $ -- $Author: ron $

with unchecked_deallocation;

package body hashed_mapping_pkg is

    function equal(c1, c2: component)
    return boolean is
    begin
    return equal(c1.key, c2.key);
    end equal;


  -- Utilities:

    procedure free is new unchecked_deallocation(mapping_rec, mapping);

    function make_general_iter(map: mapping)
    return general_iter;
      --| Raises: uninitialized_mapping
      --| Effects:
      --| Create and return a general iterator based on map.  Sets up
      --| map, current and position fields as in the spec.
      --| Raises uninitialized_mapping iff map has not been initialized.

    function more(iter: general_iter)
    return boolean;
      --| Effects:
      --| Returns true iff the general iter has not been exhausted, i.e.,
      --| returns not IsEmpty(iter.position).

    procedure advance(iter: in out general_iter);
      --| Effects:
      --| Advances iter.position, and if necessary, iter.current to the
      --| next component, as detailed in the spec.  iter.position will
      --| be empty if no more elements remain to be iterated over.
      --| Requires:
      --| iter.position is not null, i.e., caller has determined that iter
      --| was not exhausted before calling advance.


  -- Constructors:

    function create
        return mapping is
        m: mapping;
    begin
        -- deleted because of Decada bug:
--      return new mapping_rec'(size => 0,
--                              buckets => (bucket_range => create));
        m := new mapping_rec;
        m.size := 0;
        m.all.buckets := (bucket_array'range => create);
        return m;
    end create;

    procedure bind(map:   in out mapping;
                   key:   in     key_type;
                   value: in     value_type) is
    idx: bucket_range := hash(key);
    c: component := (key => key, val => value);
    begin
    if IsInList(map.buckets(idx), c) then
        raise already_bound;
    end if;

    map.buckets(idx) := attach(c, map.buckets(idx));
    map.size := map.size + 1;

    exception
        when constraint_error =>       -- null dereference
        raise uninitialized_mapping;
    end bind;

    procedure unbind(map: in out mapping;
                     key: in     key_type) is
    idx: bucket_range := hash(key);
    tmpc: component;
    begin
    tmpc.key := key;   -- don't need a value, equality just tests keys
    DeleteItem(map.buckets(idx), tmpc);
    map.size := map.size - 1;

    exception
        when ItemNotPresent =>
            raise not_bound;
    when constraint_error =>       -- null dereference
        raise uninitialized_mapping;
    end unbind;

    function copy(map: mapping)
    return mapping is
    new_map: mapping;
    begin
    if map = null then raise uninitialized_mapping; end if;

    new_map := new mapping_rec;
    new_map.size := map.size;
    for idx in bucket_range loop
        new_map.buckets(idx) := copy(map.buckets(idx));
    end loop;
    return new_map;
    end copy;


  -- Query Operations:

    function is_empty(map: mapping)
        return boolean is
    begin
    return map.size = 0;
    exception
    when constraint_error =>       -- null dereference
        raise uninitialized_mapping;
    end is_empty;

    function size(map: mapping)
        return natural is
    begin
    return map.size;
    exception
    when constraint_error =>       -- null dereference
        raise uninitialized_mapping;
    end size;

    function is_bound(map: mapping;
                      key: key_type)
    return boolean is
    tmpc: component;
    begin
    tmpc.key := key;   -- don't need a value, equality just tests keys
    return IsInList(map.buckets(hash(key)), tmpc);
    exception
        when constraint_error =>     -- null dereference
        raise uninitialized_mapping;
    end is_bound;

    function fetch(map: mapping;
                   key: key_type)
    return value_type is
    buck: list;
    begin
    buck := map.buckets(hash(key));

    while not IsEmpty(buck) loop
            if equal(key, FirstValue(buck).key) then
        return FirstValue(buck).val;
        end if;
        buck := tail(buck);
    end loop;
    raise not_bound;

    exception
    when constraint_error =>       -- null dereference
        raise uninitialized_mapping;
    end fetch;


  -- Iterators:

    function make_keys_iter(map: mapping)
        return keys_iter is
    begin
    return keys_iter(make_general_iter(map));
    end make_keys_iter;

    function more(iter: keys_iter)
        return boolean is
    begin
    return more(general_iter(iter));
    end more;

    procedure next(iter: in out keys_iter;
                   key:  out    key_type) is
    begin
    key := FirstValue(iter.position).key;
    advance(general_iter(iter));
    exception
        when EmptyList =>
        raise no_more;
    end next;

    function make_values_iter(map: mapping)
    return values_iter is
    begin
    return values_iter(make_general_iter(map));
    end make_values_iter;

    function more(iter: values_iter)
    return boolean is
    begin
    return more(general_iter(iter));
    end more;

    procedure next(iter: in out values_iter;
           val:  out    value_type) is
    begin
    val := FirstValue(iter.position).val;
    advance(general_iter(iter));
    exception
        when EmptyList =>
        raise no_more;
    end next;

    function make_bindings_iter(map: mapping)
    return bindings_iter is
    begin
        return bindings_iter(make_general_iter(map));
    end make_bindings_iter;

    function more(iter: bindings_iter)
    return boolean is
    begin
    return more(general_iter(iter));
    end more;

    procedure next(iter: in out bindings_iter;
           key:  out    key_type;
           val:  out    value_type) is
    comp: component;
    begin
    comp := FirstValue(iter.position);
    key := comp.key;
    val := comp.val;
    advance(general_iter(iter));
    exception
        when EmptyList =>
        raise no_more;
    end next;


  -- Heap management:

    procedure destroy(m: in out mapping) is
    begin
        for i in bucket_range loop
            destroy(m.buckets(i));
        end loop;
        free(m);
    exception
        when constraint_error =>    -- m is null
        return;
    end destroy;


-- Utilities:

    function make_general_iter(map: mapping)
    return general_iter is
    iter: general_iter;
    begin
    if map = null then raise uninitialized_mapping; end if;

    for idx in bucket_range loop
        if not IsEmpty(map.buckets(idx)) then
        iter.map := map;
        iter.current := idx;
        iter.position := map.buckets(idx);
        return iter;
        end if;
    end loop;

    iter.position := create;   -- no elements, makes next(iter) false.
    return iter;
    end make_general_iter;

    function more(iter: general_iter)
    return boolean is
    begin
    return not IsEmpty(iter.position);
    end more;

    procedure advance(iter: in out general_iter) is
    begin
    iter.position := tail(iter.position);
        if IsEmpty(iter.position) and then iter.current /= bucket_range'last then
        for idx in iter.current + 1..bucket_range'last loop
        if not IsEmpty(iter.map.buckets(idx)) then
            iter.current := idx;
            iter.position := iter.map.buckets(idx);
            return;
        end if;
        end loop;
        end if;
        -- At this point, IsEmpty(iter.position) => not more(iter)
    end advance;

end hashed_mapping_pkg;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--DAG.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/abstractions/dag/RCS/dag.spc,v $
-- $Revision: 1.12 $ -- $Date: 85/02/04 12:58:36 $ -- $Author: ron $

-- $Source: /nosc/work/abstractions/dag/RCS/dag.spc,v $
-- $Revision: 1.12 $ -- $Date: 85/02/04 12:58:36 $ -- $Author: ron $

with set_pkg,             --| Used in the implementation.  (private)
     lists,               --| Used in the implementation.  (private)
     hashed_mapping_pkg,  --| Used in the implementation.  (private)
     text_io;             --| Used in interface to put_image.

     pragma elaborate(set_pkg);
     pragma elaborate(lists);
     pragma elaborate(hashed_mapping_pkg);

generic
    type label is private;
      --| Labels of nodes.

    with function equal(l1, l2: label) return boolean is "=";
      --| equal is required to form an equality relation on label.

    type value is private;
      --| Values of nodes.  The assignment operation is assumed to be
      --| available, i.e., value is not limited.

 -- The following formals allow a faster implementation:

    type bucket_range is range <>;

     --| Defines the number of hash buckets, one for each member of
     --| bucket_range.

    with function hash(l: label) return bucket_range;

     --| Required property: equal(l1, l2) => hash(l1) = hash(l2).
     --| Best results if hash produces a uniform distribution
     --| over bucket_range.


package dag_pkg is

--| Overview:
--| This package provides the dag abstract data type.  A dag is a directed
--| acyclic graph.  A directed graph is a set of nodes and a set of
--| directed edges connecting pairs of nodes.  A directed graph, g, is
--| acyclic iff for each node, n, in g, there is no sequence of edges in g
--| that leads to n.  This package maintains acyclicity.
--|
--| The nodes consist of labels and their associated values.  Both types
--| are generic formals.  There are no explicit bounds on the size
--| of dags, as they are implemented on the heap.  All standard graph
--| operations are provided.
--|
--| In the description of this package, we will denote a dag, g, by the
--| pair, <labels, edges>.  For a given label, l, value(l) is the value
--| that is associated with the node labelled l.  An edge, from nodes
--| with labels l1 and l2, is written as (l1, l2).  Dot selection notation
--| is used to refer to the components of a dag, e.g., g.labels and
--| g.edges.
--|
--| 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
--|        add_node, add_edge
--|        set_value
--|        copy
--| Query Operations:
--|        is_empty
--|        is_root, is_leaf
--|        is_successor, is_descendent
--|        get_value
--|        root_count, node_count, edge_count, pred_count, succ_count
--|        put_image
--| Iterators:
--|        make_nodes_iter, more, next (2)
--|        make_edges_iter, more, next
--|        make_roots_iter, more, next (2)
--|        make_leaves_iter, more, next (2)
--|        make_preds_iter, more, next (2)
--|        make_succs_iter, more, next (2)
--|        make_preorder_iter (2), more, next (2)
--|        make_postorder_iter (2), more, next (2)
--| Heap Managment:
--|        destroy_dag
--|        destroy_dag_and_labels
--|        destroy_dag_and_values
--|        destroy_dag_and_nodes

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


    type dag is private;    --| The dag abstract data type.


  -- Exceptions:

    no_more: exception;       --| Raised on incorrect use of an iterator.

    illegal_node: exception;  --| Raised when a node is not in a dag,
                              --| or when it is and shouldn't be.

    duplicate_edge: exception; --| Rasised by add_ege on attempt to
                               --| add an edge that is already there.

    makes_cycle: exception;   --| Raised if new edge would cause a cycle.

    uninitialized_dag: exception;
        --| Raised on use of an uninitialized dag by most operations.


  -- Iterators:

    type nodes_iter is private;       --| Nodes in arbitrary order.
    type edges_iter is private;       --| Edges in arbitrary order.
    type roots_iter is private;       --| Roots in arbitrary order.
    type leaves_iter is private;      --| Leaves in arbitrary order.
    type preds_iter is private;       --| Nodes leading to a node.
    type succs_iter is private;       --| Nodes following a node.
    type preorder_iter is private;    --| Nodes in preorder traversal.
    type postorder_iter is private;   --| Nodes in postorder traversal.


  -- Constructors:

    function create
        return dag;

      --| Effects:
      --| Return <{}, {}>.

    procedure add_node(g: in out dag;
                       l: in     label;
                       v: in     value);

      --| Raises: illegal_node, uninitialized_dag
      --| Effects:
      --| Set g to <insert(g.labels, l), g.edges>.  Set value(l) to v.
      --| Raises illegal_node if a node labelled l is already in g.
      --| Raises uninitialized_dag iff g has not been initialized.

    procedure add_edge(g:  in out dag;
                       l1: in     label;
                       l2: in     label);

      --| Raises: makes_cycle, illegal_node, duplicate_edge, uninitialized_dag
      --| Effects:
      --| Set g to <g.labels, insert(g.edges, (l1, l2))> unless (l1, l2)
      --| would would cause a cycle in g.  If a cycle would be caused,
      --| raises makes_cycle and leaves g unchanged.  Raise illegal_node
      --| if l1 or l2 is not a member of g.labels.
      --| Raises duplicate_edge if (l1, l2) is already in g.edges.
      --| Raises uninitialized_dag iff g has not been initialized.

    procedure set_value(g: in out dag;
                        l: in     label;
                        v: in     value);

      --| Raises: illegal_node, uninitialized_dag
      --| Effects:
      --| Set the value(l) to v.  Raise illegal_node if l is not a member
      --| of g.labels.
      --| Raises uninitialized_dag iff g has not been initialized.

    function copy(g: dag)
    return dag;

      --| Raises: uninitialized_dag
      --| Effects:
      --| Returns a copy of d.  Subsequent changes to d will not be
      --| visible through the application of operations to the copy of d.
      --| Assignment or parameter passing without copying will result
      --| in a single dag value being shared among objects.
      --| Raises uninitialized_dag iff d has not been initialized.
      --| The assignment operation is used to transfer the values of
      --| the label and value typed components of d; consequently,
      --| changes in these values may be observable through both dags if
      --| these types are access types, or if they contain access type
      --| components.
      --| Notes:
      --| This operation is implemented inefficiently; the entire dag is
      --| rebuilt using basically the same method employed to build it
      --| originally.  It is mostly useful for testing.  If you find that this
      --| function is necessary for your application, see me and I'll work on
      --| it.  Otherwise, it will stay as it is; there's a substantial amount
      --| of effort involved in doing it correctly.

  -- Query Operations:

    function is_empty(g: dag)
        return boolean;

      --| Raises: uninitialized_dag
      --| Effects:
      --| Return g.labels = {}.
      --| Raises uninitialized_dag iff g has not been initialized.

    function is_root(g:  dag;
               l:  label)
    return boolean;

      --| Raises: illegal_node, uninitialized_dag
      --| Effects:
      --| Return true if there is no edge, (l1, l2), in g.edges, such that
      --| equal(l, l2).
      --| Raises illegal_node if l1 not a member of g.labels.
      --| Raises uninitialized_dag iff g has not been initialized.

    function is_leaf(g:  dag;
             l: label)
    return boolean;

      --| Raises: illegal_node, uninitialized_dag
      --| Return true if there is no edge, (l1, l2), in g.edges, such that
      --| equal(l, l1).
      --| Raises illegal_node if l not a member of g.labels.
      --| Raises uninitialized_dag iff g has not been initialized.

    function is_successor(g:  dag;
              l1: label;
              l2: label)
    return boolean;

      --| Raises: illegal_node, uninitialized_dag
      --| Effects:
      --| Return true if (l1, l2) is in g.edges.
      --| Raises illegal_node if l1 not a member of g.labels.
      --| Raises uninitialized_dag iff g has not been initialized.

    function is_descendent(g:  dag;
               l1: label;
               l2: label)
    return boolean;

      --| Raises: illegal_node, uninitialized_dag
      --| Effects:
      --| Return true if there is a sequence of edges, in g.edges,
      --| beginning at l1 and ending at l2.
      --| Raises illegal_node if either l1 or l2 is not in g.labels.
      --| Raises uninitialized_dag iff g has not been initialized.

    function get_value(g: dag;
                       l: label)
        return value;

      --| Raises: illegal_node, uninitialized_dag
      --| Effects:
      --| Return value(l).  Raise illegal_node if l is not a member of
      --| g.labels.
      --| Raises illegal_node if l not a member of g.labels.
      --| Raises uninitialized_dag iff g has not been initialized.

    function root_count(g: dag)
        return natural;

      --| Raises: uninitialized_dag
      --| Effects:
      --| Return the number of root nodes in g.
      --| Raises uninitialized_dag iff g has not been initialized.

    function node_count(g: dag)
        return natural;

      --| Raises: uninitialized_dag
      --| Effects:
      --| Return |g.labels|.
      --| Raises uninitialized_dag iff g has not been initialized.

    function edge_count(g: dag)
        return natural;

      --| Raises: uninitialized_dag
      --| Effects:
      --| Return |g.edges|.
      --| Raises uninitialized_dag iff g has not been initialized.

    function pred_count(g: dag;
                l: label)
        return natural;

      --| Raises: illegal_node, uninitialized_dag
      --| Effects:
      --| Return the number of edges, (l1, l2), in g.edges, such that
      --| equal(l, l2).
      --| Raises illegal_node if l not a member of g.labels.
      --| Raises uninitialized_dag iff g has not been initialized.

    function succ_count(g: dag;
                l: label)
        return natural;

      --| Raises: illegal_node, uninitialized_dag
      --| Effects:
      --| Return the number of edges, (l1, l2), in g.edges, such that
      --| equal(l, l).
      --| Raises illegal_node if l not a member of g.labels.
      --| Raises uninitialized_dag iff g has not been initialized.


    generic
        with function label_image(l: label) return string;
               --| Literal form of a label.

    procedure put_image(g: dag;
                        f: text_io.file_type);

      --| Raises: uninitialized_dag, io_exceptions.layout_error,
      --|         io_exceptions.mode_error, io_exceptions.status_error
      --| Effects:
      --| Outputs a literal form of g onto file_type f.  The format is one
      --| line per node in g, each line appearing as:
      --| l: l1 l2 ... ln,
      --| where the l's are the label_images of the labels of nodes in g.
      --| The li denote the immediate successors of l in g.
      --| Useful for debugging abstractions that use this package.
      --| Raises uninitialized_dag iff g has not been initialized.
      --| Raises other exceptions according to the rules detailed in
      --| LRM 14.3.5 for put and put_line of strings.


  -- Iterators:

    function make_nodes_iter(g: dag)
        return nodes_iter;

      --| Raises: uninitialized_dag
      --| Effects:
      --| Create and return a nodes iterator based on g.  This object can
      --| then be used in conjunction with the more function and the
      --| next procedures to iterate over the members of g.labels, and
      --| optionally, their associated values.
      --| Raises uninitialized_dag iff g has not been initialized.

    function more(iter: nodes_iter)
        return boolean;

      --| Effects:
      --| Return true iff the nodes iterator has not been exhausted.

    procedure next(iter: in out nodes_iter;
                   l:    out    label);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the dag, g.  Successive calls of next
      --| will return the members of g.labels in some arbitrary order.
      --| After all nodes have been returned, then the procedure will
      --| raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_nodes_iterator(g) and next.

    procedure next(iter: in out nodes_iter;
                   l:    out    label;
                   v:    out    value);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the dag, g.  Successive calls of next
      --| will return the members of {<l, value(l)> | l in g.labels} in
      --| some arbitrary order.  After all nodes have been returned, the
      --| procedure will raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_nodes_iterator(g) and next.

    function make_edges_iter(g: dag)
        return edges_iter;

      --| Raises: uninitialized_dag
      --| Effects:
      --| Create and return an edges iterator based on g.  This object
      --| can then be used in conjunction with the more and next
      --| procedures to iterate over the edges of g.
      --| Raises uninitialized_dag iff g has not been initialized.

    function more(iter: edges_iter)
        return boolean;

      --| Effects:
      --| Return true iff the edges iterator has not been exhausted.

    procedure next(iter: in out edges_iter;
                   from: out    label;
                   to:   out    label);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the dag, g.  Successive calls of next
      --| will return each edge, (from, to), in g.edges, in some arbitrary
      --| order.  After all edges have been returned, then the procedure
      --| will raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_edges_iterator(g) and next.

    function make_roots_iter(g: dag)
        return roots_iter;

      --| Raises: uninitialized_dag
      --| Effects:
      --| Create and return a roots iterator based on g.  This object
      --| can then be used in conjunction with the more function and the
      --| next procedures to iterate over the labels of the root nodes,
      --| i.e., {l in g.labels | for all (l1, l2) in g.edges, l /= l2},
      --| and optionally, their associated values.
      --| Raises uninitialized_dag iff g has not been initialized.

    function more(iter: roots_iter)
        return boolean;

      --| Effects:
      --| Return true iff the roots iterator has not been exhausted.

    procedure next(iter: in out roots_iter;
                   root: out    label);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the dag, g.  Successive calls of next
      --| will return each root label, in g.labels, in some arbitrary
      --| order.  After all roots have been returned, then the procedure
      --| will raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_roots_iterator(g) and next.

    procedure next(iter: in out roots_iter;
                   root: out    label;
                   val:  out    value);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the dag, g.  Successive calls of next
      --| will return each pair, <l, value(l)>, where l is the label of a
      --| root node in g, in some arbitrary order.  After all roots have
      --| been returned, then the procedure will raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_roots_iterator(g) and next.

    function make_leaves_iter(g: dag)
        return leaves_iter;

      --| Raises: uninitialized_dag
      --| Effects:
      --| Create and return a leaves iterator based on g.  This object
      --| can then be used in conjunction with the more function and the
      --| next procedures to iterate over the labels of the leaf nodes,
      --| i.e., {l in g.labels | for all (l1, l2) in g.edges, l /= l1},
      --| and optionally, their associated values.
      --| Raises uninitialized_dag iff g has not been initialized.

    function more(iter: leaves_iter)
        return boolean;

      --| Effects:
      --| Return true iff the leaves iterator has not been exhausted.

    procedure next(iter: in out leaves_iter;
                   leaf: out    label);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the dag, g.  Successive calls of next
      --| will return each leaf label, in g.labels, in some arbitrary
      --| order.  After all leaves have been returned, then the procedure
      --| will raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_leaves_iterator(g) and next.

    procedure next(iter: in out leaves_iter;
                   leaf: out    label;
                   val:  out    value);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the dag, g.  Successive calls of next
      --| will return each pair, <l, value(l)>, where l is the label of a
      --| leaf node in g, in some arbitrary order.  After all leaves have
      --| been returned, then the procedure will raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_leaves_iterator(g) and next.

    function make_preds_iter(g: dag;
                             l: label)
        return preds_iter;

      --| Raises: illegal_node, uninitialized_dag
      --| Effects:
      --| Create and return a predecessors iterator based on g.  This
      --| object can then be used in conjunction with the more function
      --| and next procedures to iterate over the predecessors of l,
      --| the members of {l1 | (l1, l) is in g.edges}, and optionally,
      --| their associated values.
      --| Raises illegal_node iff l not in g.labels.
      --| Raises uninitialized_dag iff g has not been initialized.

    function more(iter: preds_iter)
        return boolean;

      --| Effects:
      --| Return true iff the preds iterator has not been exhausted.

    procedure next(iter: in out preds_iter;
                   l:    out    label);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the dag, g.  Successive calls of next
      --| will return the predecessors of l, in g, in some arbitrary
      --| order.  After all have been returned, then the procedure will
      --| raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_preds_iterator(g) and next.

    procedure next(iter: in out preds_iter;
                   l:    out    label;
                   val:  out    value);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the dag, g.  Successive calls of next
      --| will return each pair, <l1, value(l1)>, where l1 is a
      --| predecessor of l in g, in some arbitrary order.  After all
      --| have been returned, then the procedure will raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_preds_iterator(g) and next.

    function make_succs_iter(g: dag;
                             l: label)
        return succs_iter;

      --| Raises: illegal_node, uninitialized_dag
      --| Effects:
      --| Create and return a successors iterator based on g.  This
      --| object can then be used in conjunction with the more function
      --| and next procedures to iterate over the successors of l,
      --| the members of {l1 | (l, l1) is in g.edges}, and optionally,
      --| their associated values.
      --| Raises illegal_node iff l not in g.labels.
      --| Raises uninitialized_dag iff g has not been initialized.

    function more(iter: succs_iter)
        return boolean;

      --| Effects:
      --| Return true iff the succs iterator has not been exhausted.

    procedure next(iter: in out succs_iter;
                   l:    out    label);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the dag, g.  Successive calls of next
      --| will return the successors of l, in g, in some arbitrary
      --| order.  After all have been returned, then the procedure will
      --| raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_succs_iterator(g) and next.

    procedure next(iter: in out succs_iter;
                   l:    out    label;
                   val:  out    value);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the dag, g.  Successive calls of next
      --| will return each pair, <l1, value(l1)>, where l1 is a
      --| successor of l in g, in some arbitrary order.  After all pairs
      --| have been returned, then the procedure will raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_succs_iterator(g) and next.

    function make_preorder_iter(g: dag;
                                l: label)
        return preorder_iter;

      --| Raises: illegal_node, uninitialized_dag
      --| Effects:
      --| Create and return an iterator that supports a preorder traversal
      --| of the nodes in the subgraph of g reachable from the node
      --| labelled l.  This object can then be used in conjunction with
      --| the more function and the next procedures to perform the
      --| traversal.  A preorder traversal has the property that, for any
      --| nodes, n1 and n2, in g, if there is a path in g from n1 to n2,
      --| then n1 is visited before n2.
      --| Raises illegal_node iff l not in g.labels.
      --| Raises uninitialized_dag iff g has not been initialized.

    function make_preorder_iter(g: dag)
        return preorder_iter;

      --| Raises: uninitialized_dag
      --| Effects:
      --| Create and return an iterator that supports a preorder traversal
      --| of the nodes in g. This object is used with the more function
      --| and the next procedures to perform the traversal.
      --| Raises uninitialized_dag iff g has not been initialized.

    function more(iter: preorder_iter)
        return boolean;

      --| Effects:
      --| Return true iff the preorder iterator has not been exhausted.

    procedure next(iter: in out preorder_iter;
                   l:    out    label);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the subgraph, g1, of g.  Successive calls
      --| of next will return, in preorder, the labels of nodes in g1.
      --| After all such nodes have been returned, then the procedure will
      --| raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_preorder_iterator(g) and next.

    procedure next(iter: in out preorder_iter;
                   l:    out    label;
                   val:  out    value);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the subgraph, g1, of g.  Successive calls
      --| of next will return, in preorder, the pairs <l, value(l)>, where
      --| l is a label of a node in g1.  After all such nodes have been
      --| returned, then the procedure will raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_preorder_iterator(g) and next.

    function make_postorder_iter(g: dag;
                                 l: label)
        return postorder_iter;

      --| Raises: illegal_node, uninitialized_dag
      --| Effects:
      --| Create and return an iterator that supports postorder traversal
      --| of the nodes in the subgraph of g reachable from the node
      --| labelled l.  This object can then be used in conjunction with
      --| the more function and the next procedures to perform the
      --| traversal.  A postorder traversal has the property that, for any
      --| nodes, n1 and n2, in g, if there is a path in g from n1 to n2,
      --| then n2 is visited before n1.
      --| Raises illegal_node iff l not in g.labels.
      --| Raises uninitialized_dag iff g has not been initialized.

    function make_postorder_iter(g: dag)
        return postorder_iter;

      --| Raises: uninitialized_dag
      --| Effects:
      --| Create and return an iterator that supports postorder traversal
      --| of the nodes in g. This object is used with the more function
      --| and the next procedures to perform the traversal.
      --| Raises uninitialized_dag iff g has not been initialized.

    function more(iter: postorder_iter)
        return boolean;

      --| Effects:
      --| Return true iff the postorder iterator has not been exhausted.

    procedure next(iter: in out postorder_iter;
                   l:    out    label);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the subgraph, g1, of g.  Successive calls
      --| of next will return, in postorder, the labels of nodes in g1.
      --| After all such nodes have been returned, then the procedure will
      --| raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_postorder_iterator(g) and next.

    procedure next(iter: in out postorder_iter;
                   l:    out    label;
                   val:  out    value);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the subgraph, g1, of g.  Successive calls
      --| of next will return, in postorder, the pairs <l, value(l)>,
      --| where l is a label of a node in g1.  After all such nodes have
      --| been returned, then the procedure will raise no_more.
      --| Requires:
      --| g must not be changed between the invocations of
      --| make_postorder_iterator(g) and next.


  -- Heap management:

  procedure destroy_dag(g: in out dag);

    --| Effects:
    --| Return space consumed by the dag value associated with object
    --| g to the heap.  (If g is uninitialized, this operation does
    --| nothing.)  If other objects share the same dag value, then
    --| further use of these objects is erroneous.  Components of type
    --| elem_type, if they are access types, are not garbage collected.
    --| It is the user's responsibility to dispose of these objects.
    --| g is left in the uninitialized state.

    generic
    with procedure destroy(l: in out label);
    procedure destroy_dag_and_labels(g: in out dag);

      --| Effects:
      --| Same as destroy, except that the label components of g are also
      --| destroyed using the procedure supplied as the generic actual.

    generic
    with procedure destroy(v: in out value);
    procedure destroy_dag_and_values(g: in out dag);

      --| Effects:
      --| Same as destroy, except that the value components of g are also
      --| destroyed using the procedure supplied as the generic actual.

    generic
    with procedure destroy(l: in out label);
    with procedure destroy(v: in out value);
    procedure destroy_dag_and_nodes(g: in out dag);

      --| Effects:
      --| Same as destroy, except that the nodes of g are also destroyed
      --| using the two procedures supplied as generic actuals.


private

    type info_rec;
    type info is access info_rec;

    package info_set_pkg is new set_pkg(info);

    type info_rec is
        record
             id: label;
             val: value;
             preds: info_set_pkg.set;
             succs: info_set_pkg.set;
             all_preds: info_set_pkg.set;
             all_succs: info_set_pkg.set;
        end record;

      --| Component of dag.  See dag representation invariants,
      --| abstraction function.


    package info_list_pkg is new lists(info);


    --| Component of dag.  See dag representation invariants,
    --| abstraction function.


    package label_to_info_map_pkg is
    new hashed_mapping_pkg(label, equal, bucket_range, hash, info);

    --| Component of dag.  See dag representation invariants,
    --| abstraction function.

    type dag_info is
        record
        edges: natural := 0;
        nodes: natural := 0;
            roots: info_set_pkg.set;
            infos: info_list_pkg.list;
            id_map: label_to_info_map_pkg.mapping;
        end record;

    type dag is access dag_info;

    --| In the following description, we denote the fetch operation in
    --| label_to_info_map_pkg by writing m(i) for fetch(m, i).
    --|
    --| Representation Invariants:
    --| Let r be an instance of the representation type.
    --| 1. r /= null, and r.roots, r.infos, r.id_map must all be
    --|    initialized.
    --| 2. r.edges always equals the number of calls to add_edge that did
    --|    not raise an exception.
    --| 3. r.nodes always equals the number of calls to add_node that did
    --|    not raise an exception.
    --| 4. For any label, l, in r.id_map, r.id_map(l) is in r.infos.
    --|    For any info, i, in r.infos, i.id is in the domain of r.id_map.
    --|    No info appears more than once in r.infos.
    --| 5. r.id_map(i.id) = i, for each info, i, in r.infos.
    --|    r.id_map(l).id = l.
    --| 6. For each info, i, in r.infos, i.all_preds contains i and
    --|    i.all_succs contains i.
    --| 7. For all i in r.infos, i in r.roots iff i.preds = {} and
    --|    i.all_preds = {i}.
    --| 8. For all i, i1, i2 in r.infos,
    --|    a. i.all_preds contains i.preds.
    --|    b. if i2 in i1.preds, then i1.all_preds contains i2.all_preds.
    --|    c. i.all_preds contains no elements not required by a and b.
    --| 9. For all i1, i2, in r.infos,
    --|    a. i1 in i2.preds iff i2 in i1.succs.
    --|    b. i1 in i2.all_preds iff i2 in i1.all_succs.
    --|
    --| Abstraction Function:
    --| For a given representation object, r, define A(r) = <N, E> by:
    --| 1. N = {label i.id, with value i.val | i in r.infos}
    --| 2. E = {<id1, id2> | there exists i1, i2 in r.infos such that
    --|                      i1.id = id1, i2.id = id2, and
    --|                      i is a member of id1.succs)


  -- Nodes Iterator:

    type nodes_iter is new info_list_pkg.ListIter;

      --| Let g be the dag that a nodes_iter, i, is based on.  Initially,
      --| i = nodes_iter(info_list_pkg.make_elements_iter(g.infos)).
      --| more(i) = info_list_pkg.more(info_list_elements_iter(i)).
      --| next(i) = .id, .val fields of
      --|           info_list_pkg.next(info_list_elements_iter(i)).


  -- Edges Iterator:

    type edge is
        record
            from, to: label;
        end record;

    package edge_list_pkg is new lists(edge);

    type edges_iter is new edge_list_pkg.list;

      --| Let g be the dag that an edges_iter, i, is based on.
      --| Initially, all of the edges in g are stored in the edge_list,
      --| edge_list(i).
      --| more(i) = not edge_list_pkg.empty(edge_list(i)).
      --| next(i) = edge_list_pkg.car(edge_list(i)).
      --|           next removes the first element of i.

  -- Roots Iterator:

    type roots_iter is new info_set_pkg.members_iter;

      --| Let g be the dag that a roots_iter, i, is based on.
      --| Initially, i is
      --| roots_iter(info_set_pkg.make_elements_iter(g.roots)).
      --| more(i) = info_set_pkg.more(info_set_pkg.members_iter(i)).
      --| next(i) = id, val fields of
      --| info_set_pkg.next(info_set_pkg.members_iter(i)).

  -- Leaves Iterator:

    type leaves_iter is new info_list_pkg.list;

    --| Let i be a leaves_iter based on the dag, g.  i is a sublist of g.infos.
    --| Initially, i points to the first info in g.infos that has an empty set
    --| in the succs field.  If no such info exists, then i is initially empty.
    --| more(i) = i /= null.
    --| next(i) = .id, .val fields of FirstValue(i).  next advances i to next
    --| info that has an empty set for the succs field; if no such info exists,
    --| then i becomes the empty list.

  -- Preds Iterator:

    type preds_iter is new info_set_pkg.members_iter;

      --| Let g be the dag that a preds_iter, i, is based on.
      --| Initially, i is
      --| preds_iter(info_set_pkg.make_elements_iter(g.id_map(l).preds),
      --| for the label, l.
      --| more(i) = info_set_pkg.more(info_set_pkg.members_iter(i)).
      --| next(i) = id, val fields of
      --| info_set_pkg.next(info_set_pkg.members_iter(i)).

  -- Succs Iterator:

    type succs_iter is new info_set_pkg.members_iter;

      --| Let g be the dag that a succs_iter, i, is based on.
      --| Initially, i is
      --| succs_iter(info_set_pkg.make_elements_iter(g.id_map(l).succs),
      --| for the label, l.
      --| more(i) = info_set_pkg.more(info_set_pkg.members_iter(i)).
      --| next(i) = id, val fields of
      --| info_set_pkg.next(info_set_pkg.members_iter(i)).

  -- Preorder Traversal Iterator:

    type preorder_iter is new info_list_pkg.list;

    --| Let i be a preorder_iter based on the dag, g.  Initially, i is
    --| a list of info's, each taken from g.infos, ordered so that their
    --| corresponding nodes form a preorder traversal of g.
    --| more(i) = i /= null.
    --| next(i) = .id, .val fields of car(i).  next removes the car.

  -- Postorder Traversal Iterator:

    type postorder_iter is new info_list_pkg.list;

    --| Let i be a postorder_iter based on the dag, g.  Initially, i is
    --| a list of info's, each taken from g.infos, ordered so that their
    --| corresponding nodes form a postorder traversal of g.
    --| more(i) = i /= null.
    --| next(i) = .id, .val fields of car(i).  next removes the car.

end dag_pkg;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--DAG.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/abstractions/dag/RCS/dag.bdy,v $
-- $Revision: 1.4 $ -- $Date: 85/01/31 16:21:16 $ -- $Author: ron $

-- $Source: /nosc/work/abstractions/dag/RCS/dag.bdy,v $
-- $Revision: 1.4 $ -- $Date: 85/01/31 16:21:16 $ -- $Author: ron $

with unchecked_deallocation;

package body dag_pkg is


--| Notes:
--| 1. plan to put a count field in the info_rec.  Each new node is
--| given g.node_count at creation, allowing <= to be written over info,
--| and leading to a faster implementation of set(info).
--| 2. put_image has code that allows additional aspects of the
--| representation to be printed.  This can be commented out for a release.
--| 3. copy function is inefficient, but difficult (and interesting) to write
--| in an efficient manner.  Determine if there is demand for this.

  -- Utilities:

    procedure destroy_info is
        new unchecked_deallocation(info_rec, info);


  -- Constructors:

    function create
        return dag is
    begin
        return new dag_info'(edges => 0,
                             nodes => 0,
                             roots => info_set_pkg.create,
                             infos => info_list_pkg.create,
                     id_map => label_to_info_map_pkg.create);
    end create;

    procedure add_node(g: in out dag;
                       l: in     label;
                       v: in     value) is
        new_info: info;
    begin
        -- Create info that will be bound to l in the id_map.

        new_info := new info_rec;
        new_info.id := l;
        new_info.val := v;
    new_info.preds := info_set_pkg.create;
    new_info.succs := info_set_pkg.create;
    new_info.all_preds := info_set_pkg.create;
    info_set_pkg.insert(new_info.all_preds, new_info);
    new_info.all_succs := info_set_pkg.create;
    info_set_pkg.insert(new_info.all_succs, new_info);

        -- Bind the info to the label.
    -- This new node is now a root of g.

        label_to_info_map_pkg.bind(g.id_map, l, new_info);
    info_set_pkg.insert(g.roots, new_info);

    -- Increment the node count and add the new info to the info list.

    g.nodes := g.nodes + 1;
        g.infos := info_list_pkg.attach(new_info, g.infos);

    exception
    when constraint_error =>
        raise uninitialized_dag;
    when label_to_info_map_pkg.already_bound =>      -- Node with this label is already here
        destroy_info(new_info);
        raise illegal_node;
    end add_node;

    procedure add_edge(g:  in out dag;
                       l1: in     label;
                       l2: in     label) is
        l1_info: info;
        l1_preds: info_set_pkg.members_iter;
        pred: info;
        l2_info: info;
        l2_succs: info_set_pkg.members_iter;
        succ: info;

    begin
    -- Convert labels to info pointers.

    l1_info := label_to_info_map_pkg.fetch(g.id_map, l1);
    l2_info := label_to_info_map_pkg.fetch(g.id_map, l2);

        -- Raise duplicate_edge if this edge is already in g.

        if info_set_pkg.is_member(l2_info.preds, l1_info) then
            raise duplicate_edge;
        end if;

    -- Get out if this will cause a cycle.  Otherwise, add the edge,
    -- increment edge counter and remove the target from the root set.

    if info_set_pkg.is_member(l1_info.all_preds, l2_info) then
        raise makes_cycle;
    end if;
    info_set_pkg.insert(l1_info.succs, l2_info);
    info_set_pkg.insert(l2_info.preds, l1_info);
    g.edges := g.edges + 1;
    info_set_pkg.delete(g.roots, l2_info);

    -- Maintain transitive closure for future cycle checking:

        l1_preds := info_set_pkg.make_members_iter(l1_info.all_preds);
    while info_set_pkg.more(l1_preds) loop
            info_set_pkg.next(l1_preds, pred);
        l2_succs := info_set_pkg.make_members_iter(l2_info.all_succs);
        while info_set_pkg.more(l2_succs) loop
        info_set_pkg.next(l2_succs, succ);
        info_set_pkg.insert(pred.all_succs, succ);
        info_set_pkg.insert(succ.all_preds, pred);
        end loop;
        end loop;

    exception
        when constraint_error =>
            raise uninitialized_dag;
        when label_to_info_map_pkg.not_bound =>    -- Either l1 or l2 is not the label of a node
            raise illegal_node;
    end add_edge;

    procedure set_value(g: in out dag;
                        l: in     label;
                        v: in     value) is
    begin
    label_to_info_map_pkg.fetch(g.id_map, l).val := v;
    exception
    when label_to_info_map_pkg.not_bound =>         -- l does not label a node.
        raise illegal_node;
    when constraint_error =>
        raise uninitialized_dag;
    end set_value;

    function copy(g: dag)
    return dag is
    ni: nodes_iter; l: label; v: value;   -- Iterate over (l, v) pairs
    ei: edges_iter; l1, l2: label;           -- Iterate over (l1, l2) edges
    g2: dag;
    begin
    g2 := create;
    ni := make_nodes_iter(g);
    while more(ni) loop
        next(ni, l, v);
        add_node(g2, l, v);
     end loop;

    ei := make_edges_iter(g);
    while more(ei) loop
        next(ei, l1, l2);
        add_edge(g2, l1, l2);
    end loop;

      return g2;
    end copy;


  -- Query Operations:

    function is_empty(g: dag)
        return boolean is
    begin
    return g.nodes = 0;
    exception
        when constraint_error =>
            raise uninitialized_dag;
    end is_empty;

    function is_root(g:  dag;
               l:  label)
    return boolean is
    begin
    return info_set_pkg.is_empty(label_to_info_map_pkg.fetch(g.id_map, l).preds);
    exception
    when constraint_error =>
        raise uninitialized_dag;
    when label_to_info_map_pkg.not_bound =>
        raise illegal_node;
    end is_root;

    function is_leaf(g:  dag;
             l: label)
    return boolean is
    begin
    return info_set_pkg.is_empty(label_to_info_map_pkg.fetch(g.id_map, l).succs);
    exception
    when constraint_error =>
        raise uninitialized_dag;
    when label_to_info_map_pkg.not_bound =>
        raise illegal_node;
    end is_leaf;

    function is_successor(g:  dag;
              l1: label;
              l2: label)
    return boolean is
    begin
    return info_set_pkg.is_member(label_to_info_map_pkg.fetch(g.id_map, l1).succs,
             label_to_info_map_pkg.fetch(g.id_map, l2));
    exception
    when constraint_error =>
        raise uninitialized_dag;
    when label_to_info_map_pkg.not_bound =>
        raise illegal_node;
    end is_successor;

    function is_descendent(g:  dag;
               l1: label;
               l2: label)
    return boolean is
    i1, i2: info;  -- info's assoc with l1, l2, respectively.
    begin
    i1 := label_to_info_map_pkg.fetch(g.id_map, l1);
    i2 := label_to_info_map_pkg.fetch(g.id_map, l2);
    return info_set_pkg.is_member(i1.all_succs, i2) and then not (i1 = i2);
      -- Second condition necessary because of rep invariant #6.
    exception
    when constraint_error =>
        raise uninitialized_dag;
    when label_to_info_map_pkg.not_bound =>
        raise illegal_node;
    end is_descendent;

    function get_value(g: dag;
                       l: label)
        return value is
    begin
    return label_to_info_map_pkg.fetch(g.id_map, l).val;
    exception
        when label_to_info_map_pkg.not_bound =>
        raise illegal_node;
        when constraint_error =>
        raise uninitialized_dag;
    end get_value;

    function root_count(g: dag)
        return natural is
    begin
    return info_set_pkg.size(g.roots);
    exception
        when constraint_error =>
            raise uninitialized_dag;
    end root_count;

    function node_count(g: dag)
        return natural is
    begin
    return g.nodes;
    exception
        when constraint_error =>
            raise uninitialized_dag;
    end node_count;

    function edge_count(g: dag)
        return natural is
    begin
    return g.edges;
    exception
        when constraint_error =>
            raise uninitialized_dag;
    end edge_count;

    function pred_count(g: dag;
                l: label)
        return natural is
    begin
    return info_set_pkg.size(label_to_info_map_pkg.fetch(g.id_map, l).preds);
    exception
    when constraint_error =>
        raise uninitialized_dag;
    when label_to_info_map_pkg.not_bound =>
        raise illegal_node;
    end pred_count;

    function succ_count(g: dag;
                l: label)
        return natural is
    begin
    return info_set_pkg.size(label_to_info_map_pkg.fetch(g.id_map, l).succs);
    exception
    when constraint_error =>
        raise uninitialized_dag;
    when label_to_info_map_pkg.not_bound =>
        raise illegal_node;
    end succ_count;

    procedure put_image(g: dag;
                        f: text_io.file_type) is
        list_iter: info_list_pkg.ListIter;
        inf: info;

        procedure put_header_and_set(header: in     string;
                          s:      in     info_set_pkg.set) is
            set_iter: info_set_pkg.members_iter;
            inf: info;
        begin
            text_io.put(f, header);
        set_iter := info_set_pkg.make_members_iter(s);
        while info_set_pkg.more(set_iter) loop
                info_set_pkg.next(set_iter, inf);
        text_io.put(f, " " & label_image(inf.id));
        end loop;
            text_io.put_line(f, "");
    end put_header_and_set;

    begin
    list_iter := info_list_pkg.MakeListIter(g.infos);
        while info_list_pkg.more(list_iter) loop
            info_list_pkg.next(list_iter, inf);

            -- Temporary debugging version:
        put_header_and_set(label_image(inf.id) & " (succs):", inf.succs);
        put_header_and_set(label_image(inf.id) & " (preds):", inf.preds);
        put_header_and_set(label_image(inf.id) & " (all_succs):",
                   inf.all_succs);
        put_header_and_set(label_image(inf.id) & " (all_preds):",
                   inf.all_preds);

            -- Real version:
        -- put_header_and_set(label_image(inf.id) & ":", inf.succs);

        end loop;

    exception
        when constraint_error =>
        raise uninitialized_dag;
    end put_image;


  -- Iterators:

    function make_nodes_iter(g: dag)
        return nodes_iter is
    begin
    return nodes_iter(info_list_pkg.MakeListIter(g.infos));
    exception
    when constraint_error =>
        raise uninitialized_dag;
    end make_nodes_iter;

    function more(iter: nodes_iter)
        return boolean is
    begin
    return info_list_pkg.more(info_list_pkg.ListIter(iter));
    end more;

    procedure next(iter: in out nodes_iter;
                   l:    out    label) is
    i: info;
    begin
    info_list_pkg.next(info_list_pkg.ListIter(iter), i);
        l := i.id;
    exception
    when info_list_pkg.NoMore =>
        raise dag_pkg.no_more;
    end next;

    procedure next(iter: in out nodes_iter;
                   l:    out    label;
                   v:    out    value) is
    i: info;
    begin
    info_list_pkg.next(info_list_pkg.ListIter(iter), i);
    l := i.id;
    v := i.val;
    exception
    when info_list_pkg.NoMore =>
        raise dag_pkg.no_more;
    end next;

    function make_edges_iter(g: dag)
        return edges_iter is
    from: info;
    to: info;
    edges: edge_list_pkg.list;
    info_list_iter: info_list_pkg.ListIter;
    info_set_iter: info_set_pkg.members_iter;
    begin
    edges := edge_list_pkg.create;
    info_list_iter := info_list_pkg.MakeListIter(g.infos);
    while info_list_pkg.more(info_list_iter) loop
        info_list_pkg.next(info_list_iter, from);
        info_set_iter := info_set_pkg.make_members_iter(from.succs);
        while info_set_pkg.more(info_set_iter) loop
        info_set_pkg.next(info_set_iter, to);
        edge_list_pkg.attach(edges, (from => from.id, to => to.id));
        end loop;
    end loop;
    return edges_iter(edges);

    exception
        when constraint_error =>
        raise uninitialized_dag;
    end make_edges_iter;

    function more(iter: edges_iter)
        return boolean is
    begin
    return not edge_list_pkg.IsEmpty(edge_list_pkg.list(iter));
    end more;

    procedure next(iter: in out edges_iter;
                   from: out    label;
                   to:   out    label) is
    e: edge;
    begin
    e := edge_list_pkg.FirstValue(edge_list_pkg.list(iter));
    edge_list_pkg.DeleteHead(edge_list_pkg.list(iter));
    from := e.from;
    to := e.to;
    exception
    when edge_list_pkg.EmptyList =>
        raise dag_pkg.no_more;
    end next;

    function make_roots_iter(g: dag)
        return roots_iter is
    begin
    return roots_iter(info_set_pkg.make_members_iter(g.roots));
    exception
    when constraint_error =>
        raise uninitialized_dag;
    end make_roots_iter;

    function more(iter: roots_iter)
        return boolean is
    begin
    return info_set_pkg.more(info_set_pkg.members_iter(iter));
    end more;

    procedure next(iter: in out roots_iter;
                   root: out    label) is
    inf: info;
    begin
    info_set_pkg.next(info_set_pkg.members_iter(iter), inf);
    root := inf.id;
    exception
        when info_set_pkg.no_more =>
        raise dag_pkg.no_more;
    end next;

    procedure next(iter: in out roots_iter;
                   root: out    label;
                   val:  out    value) is
    inf: info;
    begin
    info_set_pkg.next(info_set_pkg.members_iter(iter), inf);
    root := inf.id;
    val := inf.val;
    exception
        when info_set_pkg.no_more =>
        raise dag_pkg.no_more;
    end next;

    function make_leaves_iter(g: dag)
        return leaves_iter is
    l: info_list_pkg.list;
    begin
    l := g.infos;
    loop
        exit when info_list_pkg.IsEmpty(l);
        exit when info_set_pkg.is_empty(info_list_pkg.FirstValue(l).succs);
        l := info_list_pkg.tail(l);
    end loop;
    return leaves_iter(l);
    exception
    when constraint_error =>
        raise uninitialized_dag;
    end make_leaves_iter;

    function more(iter: leaves_iter)
        return boolean is
    begin
    return not info_list_pkg.IsEmpty(info_list_pkg.list(iter));
    end more;

    procedure next(iter: in out leaves_iter;
                   leaf: out    label) is
    begin
    leaf := info_list_pkg.FirstValue(info_list_pkg.list(iter)).id;
    loop
        iter := leaves_iter(info_list_pkg.tail(info_list_pkg.list(iter)));
        exit when info_list_pkg.IsEmpty(info_list_pkg.list(iter));
        exit when info_set_pkg.is_empty(info_list_pkg.FirstValue(info_list_pkg.list(iter)).succs);
    end loop;
    exception
    when info_list_pkg.EmptyList =>
        raise no_more;
    end next;

    procedure next(iter: in out leaves_iter;
                   leaf: out    label;
                   val:  out    value) is
    inf: info;
    begin
    inf := info_list_pkg.FirstValue(info_list_pkg.list(iter));
    leaf := inf.id;
    val := inf.val;
    leaf := info_list_pkg.FirstValue(info_list_pkg.list(iter)).id;
    loop
        iter := leaves_iter(info_list_pkg.tail(info_list_pkg.list(iter)));
        exit when info_list_pkg.IsEmpty(info_list_pkg.list(iter));
        exit when info_set_pkg.is_empty(info_list_pkg.FirstValue(info_list_pkg.list(iter)).succs);
    end loop;
    exception
    when info_list_pkg.EmptyList =>
        raise no_more;
    end next;

    function make_preds_iter(g: dag;
                             l: label)
        return preds_iter is
    inf: info;
    begin
    return preds_iter(info_set_pkg.make_members_iter(label_to_info_map_pkg.fetch(g.id_map, l).preds));
    exception
    when constraint_error =>
        raise uninitialized_dag;
    when label_to_info_map_pkg.not_bound =>
        raise illegal_node;
    end make_preds_iter;

    function more(iter: preds_iter)
        return boolean is
    begin
    return info_set_pkg.more(info_set_pkg.members_iter(iter));
    end more;

    procedure next(iter: in out preds_iter;
                   l:    out    label) is
    inf: info;
    begin
    info_set_pkg.next(info_set_pkg.members_iter(iter), inf);
    l := inf.id;
    exception
        when info_set_pkg.no_more =>
        raise dag_pkg.no_more;
    end next;

    procedure next(iter: in out preds_iter;
           l:    out    label;
           val:  out    value) is
    inf: info;
    begin
    info_set_pkg.next(info_set_pkg.members_iter(iter), inf);
    l := inf.id;
    val := inf.val;
    exception
    when info_set_pkg.no_more =>
        raise dag_pkg.no_more;
    end next;

    function make_succs_iter(g: dag;
                             l: label)
        return succs_iter is
    inf: info;
    begin
    return succs_iter(info_set_pkg.make_members_iter(label_to_info_map_pkg.fetch(g.id_map, l).succs));
    exception
    when constraint_error =>
        raise uninitialized_dag;
    when label_to_info_map_pkg.not_bound =>
        raise illegal_node;
    end make_succs_iter;

    function more(iter: succs_iter)
        return boolean is
    begin
    return info_set_pkg.more(info_set_pkg.members_iter(iter));
    end more;

    procedure next(iter: in out succs_iter;
                   l:    out    label) is
    inf: info;
    begin
    info_set_pkg.next(info_set_pkg.members_iter(iter), inf);
    l := inf.id;
    exception
        when info_set_pkg.no_more =>
        raise dag_pkg.no_more;
    end next;

    procedure next(iter: in out succs_iter;
           l:    out    label;
           val:  out    value) is
    inf: info;
    begin
    info_set_pkg.next(info_set_pkg.members_iter(iter), inf);
    l := inf.id;
    val := inf.val;
    exception
    when info_set_pkg.no_more =>
        raise dag_pkg.no_more;
    end next;

    procedure preorder_traversal(i:              in     info;
                                 traversal_list: in out info_list_pkg.list;
                 traversed:      in out info_set_pkg.set) is
    succs_iter: info_set_pkg.members_iter;
    succ: info;
    begin
    if info_set_pkg.is_member(traversed, i) then return; end if;
    info_set_pkg.insert(traversed, i);
    succs_iter := info_set_pkg.make_members_iter(i.succs);
    while info_set_pkg.more(succs_iter) loop
        info_set_pkg.next(succs_iter, succ);
        preorder_traversal(succ, traversal_list, traversed);
    end loop;
    traversal_list := info_list_pkg.attach(i, traversal_list);
    end preorder_traversal;

    function make_preorder_iter(g: dag;
                l: label)
    return preorder_iter is
    traversal_list: info_list_pkg.list := info_list_pkg.create;
    traversed: info_set_pkg.set := info_set_pkg.create;
    inf: info;
    begin
    inf := label_to_info_map_pkg.fetch(g.id_map, l);
    preorder_traversal(inf, traversal_list, traversed);
    info_set_pkg.destroy(traversed);
    return preorder_iter(traversal_list);
    exception
    when constraint_error =>
        raise uninitialized_dag;
    when label_to_info_map_pkg.not_bound =>
        raise illegal_node;
    end make_preorder_iter;

    function make_preorder_iter(g: dag)
        return preorder_iter is
    traversal_list: info_list_pkg.list := info_list_pkg.create;
    traversed: info_set_pkg.set := info_set_pkg.create;
    roots_set_iter: info_set_pkg.members_iter;
    root: info;
    begin
    roots_set_iter := info_set_pkg.make_members_iter(g.roots);
    while info_set_pkg.more(roots_set_iter) loop
        info_set_pkg.next(roots_set_iter, root);
        preorder_traversal(root, traversal_list, traversed);
    end loop;
    info_set_pkg.destroy(traversed);
    return preorder_iter(traversal_list);
    exception
    when constraint_error =>
        raise uninitialized_dag;
    end make_preorder_iter;

    function more(iter: preorder_iter)
        return boolean is
    begin
    return not info_list_pkg.IsEmpty(info_list_pkg.list(iter));
    end more;

    procedure next(iter: in out preorder_iter;
                   l:    out    label) is
    i: info;
    begin
    i := info_list_pkg.FirstValue(info_list_pkg.list(iter));
    info_list_pkg.DeleteHead(info_list_pkg.list(iter));
    l := i.id;
    exception
    when info_list_pkg.EmptyList =>
        raise dag_pkg.no_more;
    end next;

    procedure next(iter: in out preorder_iter;
                   l:    out    label;
                   val:  out    value) is
    i: info;
    begin
    i := info_list_pkg.FirstValue(info_list_pkg.list(iter));
    info_list_pkg.DeleteHead(info_list_pkg.list(iter));
    l := i.id;
    val := i.val;
    exception
    when info_list_pkg.EmptyList =>
        raise dag_pkg.no_more;
    end next;

    procedure postorder_traversal(i:              in     info;
                                  traversal_list: in out info_list_pkg.list;
                  traversed:      in out info_set_pkg.set) is
    succs_iter: info_set_pkg.members_iter;
    succ: info;
    begin
    if info_set_pkg.is_member(traversed, i) then return; end if;
    succs_iter := info_set_pkg.make_members_iter(i.succs);
    while info_set_pkg.more(succs_iter) loop
        info_set_pkg.next(succs_iter, succ);
        postorder_traversal(succ, traversal_list, traversed);
    end loop;
    traversal_list := info_list_pkg.attach(traversal_list, i);
    info_set_pkg.insert(traversed, i);
    end postorder_traversal;

    function make_postorder_iter(g: dag;
                 l: label)
    return postorder_iter is
    traversal_list: info_list_pkg.list := info_list_pkg.create;
    traversed: info_set_pkg.set := info_set_pkg.create;
    inf: info;
    begin
    inf := label_to_info_map_pkg.fetch(g.id_map, l);
    postorder_traversal(inf, traversal_list, traversed);
    info_set_pkg.destroy(traversed);
    return postorder_iter(traversal_list);
    exception
    when constraint_error =>
        raise uninitialized_dag;
    when label_to_info_map_pkg.not_bound =>
        raise illegal_node;
    end make_postorder_iter;

    function make_postorder_iter(g: dag)
        return postorder_iter is
    traversal_list: info_list_pkg.list := info_list_pkg.create;
    traversed: info_set_pkg.set := info_set_pkg.create;
    roots_set_iter: info_set_pkg.members_iter;
    root: info;
    begin
    roots_set_iter := info_set_pkg.make_members_iter(g.roots);
    while info_set_pkg.more(roots_set_iter) loop
        info_set_pkg.next(roots_set_iter, root);
        postorder_traversal(root, traversal_list, traversed);
    end loop;
    info_set_pkg.destroy(traversed);
    return postorder_iter(traversal_list);
    exception
    when constraint_error =>
        raise uninitialized_dag;
    end make_postorder_iter;

    function more(iter: postorder_iter)
        return boolean is
    begin
    return not info_list_pkg.IsEmpty(info_list_pkg.list(iter));
    end more;

    procedure next(iter: in out postorder_iter;
                   l:    out    label) is
    i: info;
    begin
    i := info_list_pkg.FirstValue(info_list_pkg.list(iter));
    info_list_pkg.DeleteHead(info_list_pkg.list(iter));
    l := i.id;
    exception
    when info_list_pkg.EmptyList =>
        raise dag_pkg.no_more;
    end next;

    procedure next(iter: in out postorder_iter;
                   l:    out    label;
                   val:  out    value) is
    i: info;
    begin
    i := info_list_pkg.FirstValue(info_list_pkg.list(iter));
    info_list_pkg.DeleteHead(info_list_pkg.list(iter));
    l := i.id;
    val := i.val;
    exception
    when info_list_pkg.EmptyList =>
        raise dag_pkg.no_more;
    end next;


  -- Heap Management:


    procedure null_destroy_label(l: in out label) is
    begin null; end null_destroy_label;

    procedure null_destroy_value(v: in out value) is
    begin null; end null_destroy_value;

    procedure destroy_dag(g: in out dag) is
    procedure implement_destroy is new
        destroy_dag_and_nodes(null_destroy_label, null_destroy_value);
    begin
        implement_destroy(g);
    end destroy_dag;

    procedure destroy_dag_and_labels(g: in out dag) is
    procedure implement_destroy is new
        destroy_dag_and_nodes(destroy, null_destroy_value);
    begin
    implement_destroy(g);
    end destroy_dag_and_labels;

    procedure destroy_dag_and_values(g: in out dag) is
    procedure implement_destroy is new
        destroy_dag_and_nodes(null_destroy_label, destroy);
    begin
    implement_destroy(g);
    end destroy_dag_and_values;

    procedure destroy_dag_and_nodes(g: in out dag) is
    info_iter: info_list_pkg.ListIter;
    i: info;

    procedure free_dag is
        new unchecked_deallocation(dag_info, dag);

    procedure free_info is
        new unchecked_deallocation(info_rec, info);

        procedure destroy_info(i: in out info) is
        begin
            destroy(i.id);
            destroy(i.val);
            info_set_pkg.destroy(i.preds);
            info_set_pkg.destroy(i.succs);
            info_set_pkg.destroy(i.all_preds);
            info_set_pkg.destroy(i.all_succs);
            free_info(i);
        end destroy_info;

    begin
    info_set_pkg.destroy(g.roots);
    label_to_info_map_pkg.destroy(g.id_map);

    info_iter := info_list_pkg.MakeListIter(g.infos);
    while info_list_pkg.more(info_iter) loop
        info_list_pkg.next(info_iter, i);
        destroy_info(i);
    end loop;
    info_list_pkg.destroy(g.infos);

    free_dag(g);

    exception
    when constraint_error =>         -- uninitialized dag
        return;
    end destroy_dag_and_nodes;

end dag_pkg;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--DARRAY.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/abstractions/darray/RCS/darray.spc,v $
-- $Revision: 1.1 $ -- $Date: 85/01/10 17:49:30 $ -- $Author: ron $

-- $Source: /nosc/work/abstractions/darray/RCS/darray.spc,v $
-- $Revision: 1.1 $ -- $Date: 85/01/10 17:49:30 $ -- $Author: ron $

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

    with function equal(e1, e2: elem_type)
        return boolean is "=";   --| An equality relation on elem_type.

package darray_pkg is

--| Overview:
--| This package provides the dynamic array (darray) abstract data type.
--| A darray has completely dynamic bounds, which change during runtime as
--| elements are added to/removed from the top/bottom. darrays are similar
--| to deques, differing only in that operations for indexing into the
--| structure are also provided.  A darray is indexed by integers that
--| fall within the current bounds.  The component type, elem_type, of a
--| darray is a generic formal parameter of this package, along with a
--| function, equal, that is assumed to form an equality relation over
--| over elem_type.
--|
--| The notation, <first, elts>, will be used to denote a darray.
--| first is the current low bound of the darray.  elts is the sequence
--| of elements contained in the darray.  For a given darray, d, the
--| dot selection mechanism is used to refer to these components, e.g.,
--| d.first and d.elts.  & is used for sequence concatenation, and also
--| for prepending/postpending a single element to a sequence.  |s| is
--| the number of elements in a sequence, s, and () is the null sequence.
--| Standard Ada array indexing notation is adopted for sequences.
--|
--| The following is a complete list of operations, written in the order
--| in which they appear in the spec:
--|
--| Constructors:
--|        create
--|        array_to_darray
--|        set_first
--|        add_low, add_high
--|        remove_low, remove_high
--|        store
--|        copy, copy_deep (generic)
--|
--| Query Operations:
--|        fetch
--|        low, high
--|        first, last
--|        is_empty
--|        length
--|        equal
--|
--| Iterators:
--|        make_elements_iter, more, next
--|
--| Heap Management:
--|        destroy
--|

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

  -- Primary Types:

    type darray is limited private;    --| The darray abstract data type.

    type array_type is array (integer range <>) of elem_type;
        --| darray/array_type conversion operations are provided.


  -- Storage Management Constants and Types:  (see create procedure)

    default_predict: constant positive := 100;

    default_high: constant positive := 50;

    default_expand: constant positive := 100;


  -- Exceptions:

    no_more: exception;        --| Raised on incorrect use of an iterator.

    out_of_bounds: exception;  --| Raised on index out of current bounds.

    uninitialized_darray: exception;
        --| Raised on use of uninitialized darray by most operations.


 -- Iterators:

    type elements_iter is private;     --| Component elements iterator.


  -- Constructors:

    procedure create(first:          in     integer := 1;
                     predict:        in     positive := default_predict;
                     high_percent:   in     positive := default_high;
                     expand_percent: in     positive := default_expand;
                     d:              in out darray);

      --| Effects:
      --| Sets d to <first, ()>.  If d has previously been initialized,
      --| then a destroy(d) is first performed.  The predict parameter
      --| specifies the initial space allocated.  (predict  = #elements).
      --| The high_percent parameter is the caller's expectation of the
      --| percentage of add_highs, out of total adds, to the darray.  For
      --| example, a caller would specify 100 if it was known that no
      --| add_lows would be performed.  The expand_percent parameter
      --| specifies the amount of additional space, as a percentage of
      --| currently allocated space, that is to be allocated whenever an
      --| expansion becomes necessary.  For example, 100 doubles the
      --| allocated space.

    procedure array_to_darray(a:              in     array_type;
                              first:          in     integer := 1;
                  predict:        in     positive;
                              high_percent:   in     positive
                                                       := default_high;
                              expand_percent: in     positive
                                                       := default_expand;
                              d:              in out darray);

      --| Raises: out_of_bounds
      --| Effects:
      --| Sets d to <first, a(a'first..a'last)>.  If d has previously
      --| been initialized, then an implicit destroy(d) is performed.
      --| The high_percent and expand_percent parameters are defined
      --| as for create.  Raises out_of_bounds iff predict < a'length.

    procedure set_first(d:     in out darray;
                        first: in     integer);

      --| Raises: uninitialized_darray
      --| Effects:
      --| Sets d.first to first.
      --| Raises uninitialized_darray if d has not been initialized.

    procedure add_low(d: in out darray;
                      e: in     elem_type);

      --| Raises: uninitialized_darray
      --| Effects:
      --| Sets d to <d.first - 1, e & d.elts>.
      --| Raises uninitialized_darray if d has not been initialized.

    procedure add_high(d: in out darray;
                       e: in     elem_type);

      --| Raises: uninitialized_darray
      --| Effects:
      --| Sets d.elts to d.elts & e.
      --| Raises uninitialized_darray if d has not been initialized.

    procedure remove_low(d: in out darray);

      --| Raises: out_of_bounds, uninitialized_darray
      --| Effects:
      --| Sets d to <d.first + 1, d.elts(d.first + 1 .. last(d))>.
      --| Raises out_of_bounds iff is_empty(d).
      --| Raises uninitialized_darray if d has not been initialized.

    procedure remove_high(d: in out darray);

      --| Raises: out_of_bounds, uninitialized_darray
      --| Effects:
      --| Sets d.elts to d.elts(d.first..last(d) - 1).
      --| Raises out_of_bounds iff is_empty(d).
      --| Raises uninitialized_darray if d has not been initialized.

    procedure store(d: in out darray;
                   i:  in     integer;
                   e:  in     elem_type);

      --| Raises: out_of_bounds, uninitialized_darray
      --| Effects:
      --| Replaces d.elts(i) with e.  Raises out_of_bounds iff
      --| either is_empty(d) or i is not in d.first..last(d).
      --| Raises uninitialized_darray if d has not been initialized.

    function copy(d: darray)
    return darray;

      --| Raises: uninitialized_darray
      --| Effects:
      --| Returns a copy of d.  Subsequent changes to the structure of d
      --| will not be visible through the application of operations to
      --| the copy of d, and vice versa.  Assignment or parameter passing
      --| without using copy (or copy_deep, described below) will result
      --| in a single darray value being shared among objects.
      --| Raises uninitialized_darray if d has not been initialized.
      --| The assignment operation is used to transfer the values of
      --| the elem_type component objects of d; consequently, changes
      --| in these values may be observable through both darrays if
      --| elem_type is an access type, or contains access type
      --| components.

    generic
        with function copy(e: elem_type) return elem_type;

    function copy_deep(d: darray)
    return darray;

      --| Raises: uninitialized_darray
      --| Effects:
      --| Returns a copy of d.  Subsequent changes to the structure of d
      --| will not be visible through the application of operations to
      --| the copy of d, and vice versa.  Assignment or parameter passing
      --| without using copy_deep or copy will result in a single
      --| darray value being shared among objects.
      --| Raises uninitialized_darray if d has not been initialized.
      --| The transfer of elem_type component objects is accomplished by
      --| using the assignment operation in conjunction with the copy
      --| function.  Consequently, the user can prevent sharing of
      --| elem_type access components.


  -- Query Operations:

    function fetch(d: darray;
                   i: integer)
        return elem_type;

      --| Raises: out_of_bounds, uninitialized_darray
      --| Effects:
      --| Returns d.elts(i).  Raises out_of_bounds iff either is_empty(d)
      --| or i is not in d.first..last(d).
      --| Raises uninitialized_darray if d has not been initialized.

    function low(d: in darray)
        return elem_type;

      --| Raises: out_of_bounds, uninitialized_darray
      --| Effects:
      --| Returns d.elts(d.first).  Raises out_of_bounds iff is_empty(d).
      --| Raises uninitialized_darray if d has not been initialized.

    function high(d: in darray)
        return elem_type;

      --| Raises: out_of_bounds, uninitialized_darray
      --| Effects:
      --| Returns d.elts(last(d)).  Raises out_of_bounds iff is_empty(d).
      --| Raises uninitialized_darray if d has not been initialized.

    function first(d: in darray)
        return integer;

      --| Raises: uninitialized_darray
      --| Effects:
      --| Returns d.first.
      --| Raises uninitialized_darray if d has not been initialized.

    function last(d: in darray)
        return integer;

      --| Raises: uninitialized_darray
      --| Effects:
      --| Returns d.first + |d.elts| - 1.
      --| Raises uninitialized_darray if d has not been initialized.

    function is_empty(d: in darray)
        return boolean;

      --| Raises: uninitialized_darray
      --| Effects:
      --| Returns length(d) = 0, or equivalently, last(d) < d.first.
      --| Raises uninitialized_darray if d has not been initialized.

    function length(d: in darray)
        return natural;

      --| Raises: uninitialized_darray
      --| Effects:
      --| Returns |d.elts|.
      --| Raises uninitialized_darray if d has not been initialized.

    function equal(d1, d2: darray)
        return boolean;

      --| Raises: uninitialized_darray
      --| Effects:
      --| Return (d1.first = d2.first and
      --|         last(d1) = last(d2) and
      --|         for each i in d1.first..last(d1),
      --|             equal(d1.elts(i), d2.elts(i)).
      --| Raises uninitialized_darray if either d1 or d2 has not been
      --| initialized.  Note that (d1 = d2) implies that equal(d1, d2)
      --| will always hold.  "=" is object equality, equal is state
      --| equality.

    function darray_to_array(d: darray)
        return array_type;

      --| Raises: uninitialized_darray
      --| Effects:
      --| Let bounds_range be d.first..d.first + length(d) - 1.  If
      --| bounds_range is empty, then return an empty array with bounds
      --| of 1..0.  Otherwise, return bounds_range'(d.elts).
      --| Raises uninitialized_darray if d has not been initialized.


  -- Iterators:

    function make_elements_iter(d: darray)
        return elements_iter;

      --| Raises: uninitialized_darray
      --| Effects:
      --| Create and return an elements itererator based on d.  This
      --| object can then be used in conjunction with the more function
      --| and the next procedure to iterate over the components of d.
      --| Raises uninitialized_darray if d has not been initialized.

    function more(iter: elements_iter)
        return boolean;

      --| Effects:
      --| Return true iff the elements iterator has not been exhausted.

    procedure next(iter: in out elements_iter;
                   e:       out elem_type);

      --| Raises: no_more
      --| Effects:
      --| Let iter be based on the darray, d.  Successive calls of next
      --| will return, in e, successive elements of d.elts.  Each call
      --| updates the state of the elements iterator.  After all elements
      --| have been returned, an invocation of next will raise no_more.
      --| Requires:
      --| d must not be changed between the invocations of
      --| make_elements_iterator(d) and next.


  -- Heap Management:

    procedure destroy(d: in out darray);
      --| Effects:
      --| Return space consumed by the darray value associated with object
      --| d to the heap.  (If d is uninitialized, this operation does
      --| nothing.)  If other objects share the same darray value, then
      --| further use of these objects is erroneous.  Components of type
      --| elem_type, if they are access types, are not garbage collected.
      --| It is the user's responsibility to dispose of these objects.
      --| d is left in the uninitialized state.


private

    type array_ptr is access array_type;

    type darray_info is
        record
            first_idx: positive;
            last_idx: natural;
            first: integer;
            high_percent: positive;
            expand_percent: positive;
            arr: array_ptr := null;
        end record;

    type darray is access darray_info;

    --| Let r be an instance of the representation type.
    --| Representation Invariants:
    --| 1. r /= null, r.arr /= null (must be initialized to be valid.)
    --| 2. r.arr'first = 1 and
    --|    r.arr'last >= 1
    --| 3. r.first_idx <= r.last_idx or
    --|    r.first_idx = r.last_idx + 1
    --| 4. r.first_idx <= r.last_idx =>
    --|        r.first_idx, r.last_idx in r.arr'range
    --| 5. r.expand_percent, r.high_percent get values at creation time,
    --|    and these never change.
    --|
    --| Abstraction Function:  (denoted by A(r))
    --| if r.last_idx < r.first_idx then
    --|     <r.first, ()>
    --| else
    --|     <r.first, (r.arr(r.first_idx),...,r.arr(r.last_idx))>
    --|
    --| These properties follow:
    --| 1. length(A(r)) = r.last_idx - r.first_idx + 1
    --| 2. last(A(r)) = r.first + r.last_idx - r.first_idx
    --| 3. fetch(A(r), i) =
    --|        if (i - r.first + r.first_idx) in r.first_idx..r.last_idx
    --|            then r.arr(i - r.first + r.first_idx)
    --|            else undefined.  (out_of_bounds)

    type elements_iter is
        record
            last: integer := 0;
            current: integer := 1;
            arr: array_ptr;
        end record;

      --| Let d be the darray that an elements_iter, i, is based on.
      --| Initially, i.current = d.first_idx, i.last = d.last_idx, and
      --| i.arr = d.arr.
      --| more(i) = i.current <= i.last.
      --| next(i) = i.arr(current).  i.current incremented by next.
      --| Note that if an elements_iter object is not initialized, then
      --| more is false.

end darray_pkg;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--DARRAY.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/abstractions/darray/RCS/darray.bdy,v $
-- $Revision: 1.2 $ -- $Date: 85/02/01 10:50:50 $ -- $Author: ron $

-- $Source: /nosc/work/abstractions/darray/RCS/darray.bdy,v $
-- $Revision: 1.2 $ -- $Date: 85/02/01 10:50:50 $ -- $Author: ron $

with unchecked_deallocation;

package body darray_pkg is

    -- Utilities:

    procedure free_array_ptr is
        new unchecked_deallocation(array_type, array_ptr);

    procedure free_darray is
    new unchecked_deallocation(darray_info, darray);

    function down_index(i: integer;
                        d: darray)
        return integer;

      --| Raises: out_of_bounds
      --| Effects:
      --| Map from abstraction indices to representation indices.
      --| Raises out_of_bounds iff either is_empty(d) or i is not in
      --| d.first..last(d).
      --| Requires: d must be initialized.

    procedure initialization_check(d: darray);

      --| Raises: uninitialized_darray
      --| Effects:
      --| Returns normally iff d has been the target of a create, copy,
      --| or array_to_darray operation, and has not since been destroyed.
      --| Otherwise, raises uninitialized_darray.
      --| This procedure will not detect the case where another object
      --| sharing the same darray value has been destroyed; this is
      --| erroneous use.

    procedure expand(d: in out darray);

      --| Effects:
      --| Allocates additional space in d.arr.  The old contents of d.arr
      --| are copied to a slice of the new array.  The expansion amount is
      --| a percentage (d.expand_percent) of currently allocated space.
      --| Sets d.first_idx and d.last_idx to appropriate positions in the
      --| new array; these positions are selected according to the
      --| expected distribution of add_highs/add_lows (d.high_percent).
      --| Requires: d must be initialized.

    procedure contract(d: in out darray);

      --| Effects:
      --| Checks whether d.arr consumes too much space in proportion to
      --| the slice that is being used to hold the darray elements.  If
      --| so, halves the size of d.arr.  The old contents of d.arr are
      --| copied to a slice of the new array.  Sets d.first_idx and
      --| and d.last_idx to appropriate positions in the new array; these
      --| positions are selected according to the expected distribution of
      --| add_highs/add_lows (d.high_percent).
      --| Requires: d must be initialized and nonempty.

    procedure reallocate(d:          in out darray;
             new_length: in     positive);

      --| Raises: out_of_bounds
      --| Effects:
      --| Replaces d.arr with a pointer to an array of length new_length,
      --| fills a slice of this array with the old contents of d.arr, and
      --| adjusts d.first_idx and d.last_idx appropriately.  Everything is
      --| done according to d.high_percent.  Used by both expand/contract.
      --| Raises out_of_bounds iff new_length < length(d).
      --| Requires: d must be initialized.

    procedure determine_position(array_length: in  positive;
                                 slice_length: in  natural;
                                 high_percent: in  positive;
                 first_idx:    out positive;
                 last_idx:     out natural);

      --| Raises: out_of_bounds
      --| Effects:
      --| Determines the appropriate position of a slice of length
      --| slice_length in an array with range 1..array_length.  This
      --| position is calculated according to the high_percent parameter.
      --| Raises out_of_bounds iff slice_length > array_length.
      --| Used by create, array_to_darray, reallocate.


  -- Constructors:

    procedure create(first:          in     integer := 1;
                     predict:        in     positive := default_predict;
                     high_percent:   in     positive := default_high;
                     expand_percent: in     positive := default_expand;
                     d:              in out darray) is
    begin
        destroy(d);
    d := new darray_info;
        determine_position(predict, 0, high_percent,
               d.first_idx, d.last_idx);
        d.first := first;
        d.high_percent := high_percent;
        d.expand_percent := expand_percent;
        d.arr := new array_type(1..predict);
    exception
        when out_of_bounds =>    -- determine_position fails
        destroy(d);
        raise;
    end create;

    procedure array_to_darray(a:              in    array_type;
                              first:          in    integer:= 1;
                              predict:        in    positive;
                              high_percent:   in    positive
                                                       := default_high;
                              expand_percent: in    positive
                                                       := default_expand;
                              d:              in out darray) is
    begin
        free_array_ptr(d.arr);
    d := new darray_info;
        determine_position(predict, a'length, high_percent,
               d.first_idx, d.last_idx);
        d.first := first;
        d.high_percent := high_percent;
        d.expand_percent := expand_percent;
        d.arr := new array_type(1..predict);
        d.arr.all := a;
    exception
        when out_of_bounds =>     -- determine_position fails
        destroy(d);
        raise;
    end array_to_darray;

    procedure set_first(d:     in out darray;
                        first: in     integer) is
    begin
        initialization_check(d);
        d.first := first;
    end set_first;

    procedure add_low(d: in out darray;
                      e: in     elem_type) is
    begin
        initialization_check(d);
        d.arr(d.first_idx - 1) := e;
        d.first_idx := d.first_idx - 1;
        d.first := d.first - 1;
    exception
        when constraint_error =>    -- on array store
            expand(d);
            d.arr(d.first_idx - 1) := e;
            d.first_idx := d.first_idx - 1;
            d.first := d.first - 1;
    end add_low;

    procedure add_high(d: in out darray;
                       e: in     elem_type) is
    begin
        initialization_check(d);
        d.arr(d.last_idx + 1) := e;
        d.last_idx := d.last_idx + 1;
    exception
        when constraint_error =>    -- on array store
            expand(d);
            d.arr(d.last_idx + 1) := e;
            d.last_idx := d.last_idx + 1;
    end add_high;

    procedure remove_low(d: in out darray) is
    begin
        initialization_check(d);
    if d.last_idx < d.first_idx then raise out_of_bounds; end if;

    d.first_idx := d.first_idx + 1;
    d.first := d.first + 1;
    contract(d);
    end remove_low;

    procedure remove_high(d: in out darray) is
    begin
        initialization_check(d);
        if d.last_idx < d.first_idx then raise out_of_bounds; end if;

        d.last_idx := d.last_idx - 1;
        contract(d);
    end remove_high;

    procedure store(d: in out darray;
                    i: in     integer;
                    e: in     elem_type) is
    begin
        initialization_check(d);
        d.arr(down_index(i, d)) := e;
    end store;

   function copy(d: darray)
       return darray is
       d2: darray;
   begin
       initialization_check(d);
       d2 := new darray_info'(first_idx => d.first_idx,
                  last_idx => d.last_idx,
                  first => d.first,
                  high_percent => d.high_percent,
                  expand_percent => d.expand_percent,
                  arr => new array_type(1..d.arr'length));
       d2.arr.all := d.arr.all;
       return d2;
    end copy;

    function copy_deep(d: darray)
    return darray is
    d2: darray;
    i: integer;
    begin
    initialization_check(d);
    d2 := new darray_info'(first_idx => d.first_idx,
                   last_idx => d.last_idx,
                   first => d.first,
                   high_percent => d.high_percent,
                   expand_percent => d.expand_percent,
                   arr => new array_type(1..d.arr'length));
    for i in d.first_idx..d.last_idx loop
        d2.arr(i) := copy(d.arr(i));
    end loop;
    return d2;
     end copy_deep;


  -- Query Operations:

    function fetch(d: darray;
                   i: integer)
        return elem_type is
    begin
        initialization_check(d);
        return d.arr(down_index(i, d));
    end fetch;

    function low(d: in darray)
        return elem_type is
    begin
        initialization_check(d);
        return d.arr(down_index(d.first, d));
    end low;

    function high(d: in darray)
        return elem_type is
    begin
        if is_empty(d) then      -- is_empty checks for initialization
            raise out_of_bounds;
        end if;
        return d.arr(d.last_idx);
    end high;

    function first(d: in darray)
        return integer is
    begin
        initialization_check(d);
        return d.first;
    end first;

    function last(d: in darray)
        return integer is
    begin
        initialization_check(d);
        return d.first + d.last_idx - d.first_idx;
    end last;

    function is_empty(d: in darray)
        return boolean is
    begin
        initialization_check(d);
        return d.last_idx < d.first_idx;
    end is_empty;

    function length(d: in darray)
        return natural is
    begin
        initialization_check(d);
        return d.last_idx - d.first_idx + 1;
    end length;

    function equal(d1, d2: darray)
        return boolean is
    i2: integer;
    begin
        initialization_check(d1);
        initialization_check(d2);

        if d1.first /= d2.first or else length(d1) /= length(d2) then
            return false;
        end if;

    i2 := d2.first_idx;
    for i1 in d1.first_idx..d1.last_idx loop
        if not equal(d1.arr(i1), d2.arr(i2)) then
        return false;
        end if;
        i2 := i2 + 1;
    end loop;

    return true;
    end equal;

    function darray_to_array(d: darray)
        return array_type is
        subtype dbounds_array is array_type(d.first..last(d));
        -- invocation of last performs initialization check.
    begin
        return dbounds_array'(d.arr(d.first_idx..d.last_idx));
    end darray_to_array;


  -- Iterators:

    function make_elements_iter(d: darray)
        return elements_iter is
    begin
        initialization_check(d);
        return (current => d.first_idx,
                last => d.last_idx,
                arr => d.arr);
    end make_elements_iter;

    function more(iter: elements_iter)
        return boolean is
    begin
        return iter.current <= iter.last;
    end more;

    procedure next(iter: in out elements_iter;
                   e:       out elem_type) is
    begin
        if not more(iter) then raise no_more; end if;

        e := iter.arr(iter.current);
        iter.current := iter.current + 1;
    end next;


    -- Heap Management:

    procedure destroy(d: in out darray) is
    begin
        free_array_ptr(d.arr);
    free_darray(d);
    exception
        when constraint_error =>    -- d is null, d.arr is illegal.
            return;
    end destroy;


    -- Utilities:

    function down_index(i: integer;
                        d: darray)
        return integer is
        down_idx: integer := i - d.first + d.first_idx;
    begin
        if d.last_idx < d.first_idx or else                -- empty array
           not (down_idx in d.first_idx..d.last_idx) then  -- bogus index
            raise out_of_bounds;
        end if;

        return down_idx;
    end down_index;

    procedure initialization_check(d: darray) is
    begin
        if d = null then raise uninitialized_darray; end if;
    end initialization_check;

    procedure expand(d: in out darray) is
        new_length: integer :=
        (d.arr'length * (100 + d.expand_percent))/100;
    begin
        -- Specified percent, in relation to length, may be too small to
    -- force any growth.  In this case, force growth.  This is rare.
    -- The choice to double is arbitrary.

    if new_length = d.arr'length then
        new_length := 2 * d.arr'length;
    end if;

        reallocate(d, new_length);
    end expand;

    procedure contract(d: in out darray) is
      -- <<A better contraction strategy is needed.  Justification is weak
      -- for this one.>>
    begin
        null;
    end contract;

    procedure reallocate(d:          in out darray;
             new_length: in     positive) is

    new_arr: array_ptr;
    new_first_idx: integer;
    new_last_idx: integer;

    begin
        determine_position(new_length, length(d), d.high_percent,
               new_first_idx, new_last_idx);
    new_arr := new array_type(1..new_length);
    new_arr(new_first_idx..new_last_idx) :=
        d.arr(d.first_idx..d.last_idx);
    free_array_ptr(d.arr);
    d.arr := new_arr;
    d.first_idx := new_first_idx;
    d.last_idx := new_last_idx;
    end reallocate;

    procedure determine_position(array_length: in  positive;
                                 slice_length: in  natural;
                                 high_percent: in  positive;
                 first_idx:    out positive;
                 last_idx:     out natural) is

        left_over: integer := array_length - slice_length;
        high_space: integer := (high_percent * left_over)/100;
        low_space: integer := left_over - high_space;

    begin
    if left_over < 0 then raise out_of_bounds; end if;

        first_idx := low_space + 1;
        last_idx := low_space + slice_length;
    end determine_position;

end darray_pkg;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--SLISTS.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with String_Pkg;
with Lists;

package String_Lists is new Lists(String_Pkg.String_Type, String_Pkg.Equal);
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--FILEMGR.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with String_Pkg;            use String_Pkg;
with String_Lists;            pragma elaborate(String_Lists);

--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--
--   WARNING : THIS PACKAGE IS HOST DEPENDENT THUS NOT PORATABLE  --
--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--

package File_Manager is

--| The File_Manager package provides procedures to manipulate files
--| in a file system under a given operating system.
                                                    pragma Page;
--| Overview:
--| The File_Manager provides routines to manipulate closed files.
--| It provides procedures to rename, copy, move, delete and expand
--| a name containing wild card characters to a list of filenames.

--| N/A: Raises, Effects, Requires, Modifies, Error
                                                    pragma Page;
            -- Types --

type Mode_Type is (FULL, NO_VERSION, NO_DIRECTORY, FILE_ONLY);

            -- Exceptions --

Delete_Error        : exception;
                --| raised when unable to delete a file
Device_Not_Ready    : exception;
                --| raised when device is not ready
Device_Write_Locked : exception;
                --| raised when device is write locked
Directory_Not_Found : exception;
                --| raised when unable to find the directory
Expand_Error        : exception;
                --| raised when name expansion error occurs
File_Already_Exists : exception;
                --| raised when a file already exists
File_Locked         : exception;
                --| raised when file is locked
File_Name_Error     : exception;
                --| raised when the file name is too long
File_Not_Found      : exception;
                --| raised when the file is not found
Input_File_Error    : exception;
                --| raised when unable to read a file to copy
Output_File_Error   : exception;
                --| raised when unable to write a new file
Parse_Error         : exception;
                --| raised when parsing error
Privilege_Violation : exception;
                --| raised when privilege violation is detected
Rename_Error        : exception;
                --| raised when error is detected in rename operation
                                                    pragma Page;

            -- Operations --

procedure Rename (        --| rename a file in the file system
    Old_File : in String_Type;    --| name the file presently has
    New_File : in String_Type    --| new name to give the file
    );

--| Raises:
--| Device_Not_Ready, Directory_Not_Found, File_Not_Found,
--| Parse_Error, Privilege_Violation, Rename_Error

--| Requires:
--| The name of the file to be renamed and a filename of the new
--| file.

--| Effects:
--| It renames a file in the file system with a new name.  The contents
--| of the file are not changed.

--| Modifies:
--| The external filename is changed to a new name.

--| N/A: Errors
                                                    pragma Page;
procedure Rename (        --| rename a file in the file system
    Old_File : in String_Type;    --| name the file presently has
    New_File : in string    --| new name to give the file
    );

--| Raises:
--| Device_Not_Ready, Directory_Not_Found, File_Not_Found,
--| Parse_Error, Privilege_Violation, Rename_Error

--| Requires:
--| The name of the file to be renamed and a filename of the new
--| file.

--| Effects:
--| It renames a file in the file system with a new name.  The contents
--| of the file are not changed.

--| Modifies:
--| The external filename is changed to a new name.

--| N/A: Errors
                                                    pragma Page;
procedure Rename (        --| rename a file in the file system
    Old_File : in string;    --| name the file presently has
    New_File : in String_Type    --| new name to give the file
    );

--| Raises:
--| Device_Not_Ready, Directory_Not_Found, File_Not_Found,
--| Parse_Error, Privilege_Violation, Rename_Error

--| Requires:
--| The name of the file to be renamed and a filename of the new
--| file.

--| Effects:
--| It renames a file in the file system with a new name.  The contents
--| of the file are not changed.

--| Modifies:
--| The external filename is changed to a new name.

--| N/A: Errors
                                                    pragma Page;
procedure Rename (        --| rename a file in the file system
    Old_File : in string;    --| name the file presently has
    New_File : in string    --| new name to give the file
    );

--| Raises:
--| Device_Not_Ready, Directory_Not_Found, File_Not_Found,
--| Parse_Error, Privilege_Violation, Rename_Error

--| Requires:
--| The name of the file to be renamed and a filename of the new
--| file.

--| Effects:
--| It renames a file in the file system with a new name.  The contents
--| of the file are not changed.

--| Modifies:
--| The external filename is changed to a new name.

--| N/A: Errors
                                                    pragma Page;
procedure Delete (        --| deletes the named file
    File : in String_Type    --| name of the file to be deleted
    );

--| Raises:
--| Delete_Error, Device_Not_Ready, Device_Write_Locked,
--| Directory_Not_Found, Parse_Error, Privilege_Violation

--| Requires:
--| Name of the file to be deleted.

--| Effects:
--| Deletes the named file from the file system.

--| Modifies:
--| The external file is delete from the file system.

--| N/A: Errors
                                                    pragma Page;
procedure Delete (        --| deletes the named file
    File : in string        --| name of the file to be deleted
    );

--| Raises:
--| Delete_Error, Device_Not_Ready, Device_Write_Locked,
--| Directory_Not_Found, Parse_Error, Privilege_Violation

--| Requires:
--| Name of the file to be deleted.

--| Effects:
--| Deletes the named file from the file system.

--| Modifies:
--| The external file is delete from the file system.

--| N/A: Errors
                                                    pragma Page;
procedure Copy (        --| copy one file to another.
    Input_File  : in String_Type;
                --| name of the old file
    Output_File : in String_Type
                --| name of the file to copy it into
    );

--| Raises:
--| Device_Not_Ready, Device_Write_Locked, Directory_Not_Found,
--| File_Already_Exists, File_Locked, File_Not_Found, Parse_Error,
--| Input_File_Error, Output_File_Error, Privilege_Violation

--| Requires:
--| Name of the file to be copied and a new name of a file to be
--| created with the same contents.

--| Effects:
--| Copies old file to new file.  The contents of the
--| new file are identical to the contents of the old file.

--| Modifies:
--| A new file with the same contents is created.

--| N/A: Errors
                                                    pragma Page;
procedure Copy (        --| copy one file to another.
    Input_File  : in String_Type;
                --| name of the old file
    Output_File : in string    --| name of the file to copy it into
    );

--| Raises:
--| Device_Not_Ready, Device_Write_Locked, Directory_Not_Found,
--| File_Already_Exists, File_Locked, File_Not_Found, Parse_Error,
--| Input_File_Error, Output_File_Error, Privilege_Violation

--| Requires:
--| Name of the file to be copied and a new name of a file to be
--| created with the same contents.

--| Effects:
--| Copies old file to new file.  The contents of the
--| new file are identical to the contents of the old file.

--| Modifies:
--| A new file with the same contents is created.

--| N/A: Errors
                                                    pragma Page;
procedure Copy (        --| copy one file to another.
    Input_File  : in string;    --| name of the old file
    Output_File : in String_Type
                --| name of the file to copy it into
    );

--| Raises:
--| Device_Not_Ready, Device_Write_Locked, Directory_Not_Found,
--| File_Already_Exists, File_Locked, File_Not_Found, Parse_Error,
--| Input_File_Error, Output_File_Error, Privilege_Violation

--| Requires:
--| Name of the file to be copied and a new name of a file to be
--| created with the same contents.

--| Effects:
--| Copies old file to new file.  The contents of the
--| new file are identical to the contents of the old file.

--| Modifies:
--| A new file with the same contents is created.

--| N/A: Errors
                                                    pragma Page;
procedure Copy (        --| copy one file to another.
    Input_File  : in string;    --| name of the old file
    Output_File : in string    --| name of the file to copy it into
    );

--| Raises:
--| Device_Not_Ready, Device_Write_Locked, Directory_Not_Found,
--| File_Already_Exists, File_Locked, File_Not_Found, Parse_Error,
--| Input_File_Error, Output_File_Error, Privilege_Violation

--| Requires:
--| Name of the file to be copied and a new name of a file to be
--| created with the same contents.

--| Effects:
--| Copies old file to new file.  The contents of the
--| new file are identical to the contents of the old file.

--| Modifies:
--| A new file with the same contents is created.

--| N/A: Errors
                                                    pragma Page;
procedure Append (        --| Appends a file to another file
    Input_File  : in String_Type;
                --| File to append
    Append_File : in String_Type
                --| File to be appended
    );

--| Raises:

--| Requires:
--| Name of the file to be appended and a name of a file to append.

--| Effects:
--| Appends file to another file.

--| Modifies:

--| N/A: Errors
                                                    pragma Page;
procedure Append (        --| Appends a file to another file
    Input_File  : in String_Type;
                --| File to append
    Append_File : in string    --| File to be appended
    );

--| Raises:

--| Requires:
--| Name of the file to be appended and a name of a file to append.

--| Effects:
--| Appends file to another file.

--| Modifies:

--| N/A: Errors
                                                    pragma Page;
procedure Append (        --| Appends a file to another file
    Input_File  : in string;    --| File to append
    Append_File : in String_Type
                --| File to be appended
    );

--| Raises:

--| Requires:
--| Name of the file to be appended and a name of a file to append.

--| Effects:
--| Appends file to another file.

--| Modifies:

--| N/A: Errors
                                                    pragma Page;
procedure Append (        --| Appends a file to another file
    Input_File  : in string;    --| File to append
    Append_File : in string    --| File to be appended
    );

--| Raises:

--| Requires:
--| Name of the file to be appended and a name of a file to append.

--| Effects:
--| Appends file to another file.

--| Modifies:

--| N/A: Errors
                                                    pragma Page;
function Expand (        --| Expands a name containing wild card
                --| to a full filename
    File : in String_Type;    --| string to be expanded
    Mode : in Mode_Type := FULL    --| filename expansion mode
    ) return String_Lists.List;

--| Raises:
--| Device_Not_Ready, Directory_Not_Found, Expand_Error,
--| File_Not_Found, Parse_Error

--| Requires:
--| A string of characters with/without system dependent wild card
--| characters.

--| Effects:
--| It expands a string into a list of filenames matching all wild
--| card characters.

--| Modifies:
--| List contains a list of filename matching the given string.

--| N/A: Errors
                                                    pragma Page;
function Expand (        --| Expands a name containing wild card
                --| to a full filename
    File : in string;        --| string to be expanded
    Mode : in Mode_Type := FULL    --| filename expansion mode
    ) return String_Lists.List;

--| Raises:
--| Device_Not_Ready, Directory_Not_Found, Expand_Error,
--| File_Not_Found, Parse_Error

--| Requires:
--| A string of characters with/without system dependent wild card
--| characters.

--| Effects:
--| It expands a string into a list of filenames matching all wild
--| card characters.

--| Modifies:
--| List contains a list of filename matching the given string.

--| N/A: Errors
                                                    pragma Page;
procedure Destroy (
    Name_List : in out String_Lists.List
    );

--| Raises:

--| Requires:
--| A list of filenames whose storate is to be released.

--| Effects:
--| All storeage associated with the given list is released.

--| Modifies:
--| Name_List

--| N/A: Errors
                                                    pragma Page;
function Strip_Dir (
    Long_Name : in String_Type
    ) return String_Type;

--| Raises:

--| Requires:
--| A filename whose name without device/directory is to be returned.

--| Effects:
--| Strips the device and directory name off a long file name

--| Modifies:

--| N/A: Errors


end  File_Manager;
                                                    pragma Page;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--FILEMGR.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with System;            use System;
with Starlet;            use Starlet;
with Condition_Handling;    use Condition_Handling;
with String_Pkg;        use String_Pkg;

package body File_Manager is

subtype File_String is string (1 .. 255);

procedure Raise_Error (
    STS : Unsigned_Longword
    ) is

begin

    case STS is
    when RMS_DNF =>
        raise Directory_Not_Found;
    when RMS_DNR =>
        raise Device_Not_Ready;
    when RMS_FEX =>
        raise File_Already_Exists;
    when RMS_FLK =>
        raise File_Locked;
    when RMS_FNF =>
        raise File_Not_Found;
    when RMS_PRV =>
        raise Privilege_Violation;
    when RMS_WLK =>
        raise Device_Write_Locked;
    when others =>
        return;
    end case;

end Raise_Error;
                                                    pragma Page;
procedure Set_FAB_NAM (
    File  : in string;
    FAB   : in out FAB_Type;
    NAM   : in out NAM_Type;
    ES    : in out File_String
    ) is

    Status : Cond_Value_Type;
    From   : integer;
    To     : integer;

begin

    if File'length > 255 then
    raise File_Name_Error;
    end if;
    FAB     := FAB_Type_Init;
    FAB.FNA := File'address;
    FAB.FNS := Unsigned_Byte(File'length);
    FAB.NAM := NAM'address;

    NAM     := NAM_Type_Init;
    NAM.ESA := ES'address;
    NAM.ESS := Unsigned_Byte(ES'length);

    Starlet.Parse(Status, FAB);
    if Condition_Handling.Success(Status) then
    FAB.FOP.NAM := true;
    return;
    end if;

    Raise_Error(FAB.STS);
    raise Parse_Error;

end Set_FAB_NAM;
                                                    pragma Page;
procedure Copy_Append (
    File1 : in string;
    File2 : in string;
    CIF   : in boolean
    ) is

    FAB1 : FAB_Type;
    NAM1 : NAM_Type;
    RAB1 : RAB_Type;
    ES1  : File_String;
    FAB2 : FAB_Type;
    NAM2 : NAM_Type;
    RAB2 : RAB_Type;
    ES2  : File_String;
    Buffer  : string (1 .. 1024);
    Status  : Cond_Value_Type;

begin

    Set_FAB_NAM(File => File1, FAB => FAB1, NAM => NAM1, ES => ES1);
    FAB1.FAC.GET := true;
    Starlet.Open(Status, FAB1);
    if not Condition_Handling.Success(Status) then
    Raise_Error(FAB1.STS);
    raise Input_File_Error;
    end if;

    RAB1     := RAB_Type_Init;
    RAB1.FAB := FAB1'address;
    RAB1.MBF := 2;
    RAB1.ROP.RAH := true;
    Starlet.Connect(Status, RAB1);
    if not Condition_Handling.Success(Status) then
    raise Input_File_Error;
    end if;
    RAB1.UBF := Buffer'address;
    RAB1.USZ := Unsigned_Word(Buffer'length);

    Set_FAB_NAM(File => File2, FAB => FAB2, NAM => NAM2, ES => ES2);
    FAB2.FAC.PUT := true;
    FAB2.FOP.CTG := true;
    FAB2.FOP.CIF := CIF;
    FAB2.RAT.CR  := true;
    Starlet.Create(Status, FAB2);
    if not Condition_Handling.Success(Status) then
    Raise_Error(FAB2.STS);
    raise Output_File_Error;
    end if;
    RAB2 := RAB_Type_Init;
    RAB2.FAB := FAB2'address;
    RAB2.MBF := 2;
    RAB2.ROP.EOF := CIF;
    RAB2.ROP.WBH := true;
    Starlet.Connect(Status, RAB2);
    if not Condition_Handling.Success(Status) then
    raise Output_File_Error;
    end if;

    Read_Write: loop
    Starlet.Get(Status, RAB1);
    if Condition_Handling.Success(Status) then
        RAB2.ROP.TPT := true;
        RAB2.RBF := RAB1.RBF;
        RAB2.RSZ := RAB1.RSZ;
        Starlet.Put(Status, RAB2);
        if not Condition_Handling.Success(Status) then
        Raise_Error(RAB2.STS);
        raise Output_File_Error;
        end if;
    else
        if RAB1.STS = RMS_EOF then
        exit Read_Write;
        end if;
        Raise_Error(RAB1.STS);
        raise Input_File_Error;
    end if;
    end loop Read_Write;

    Close(Status, FAB1);
    if not Condition_Handling.Success(Status) then
    Raise_Error(FAB1.STS);
    raise Input_File_Error;
    end if;

    Close(Status, FAB2);
    if not Condition_Handling.Success(Status) then
    Raise_Error(FAB2.STS);
    raise Output_File_Error;
    end if;

end Copy_Append;
                                                    pragma Page;
 procedure Rename (
    Old_File : in String_Type;
    New_File : in String_Type
    ) is

begin

    Rename(Old_File => String_Pkg.Value(Old_File),
       New_File => String_Pkg.Value(New_File));

end Rename;
                                                    pragma Page;
procedure Rename (
    Old_File : in String_Type;
    New_File : in string
    ) is

begin

    Rename(Old_File => String_Pkg.Value(Old_File),
       New_File => New_File);

end Rename;
                                                    pragma Page;
procedure Rename (
    Old_File : in string;
    New_File : in String_Type
    ) is

begin

    Rename(Old_File => Old_File,
       New_File => String_Pkg.Value(New_File));

end Rename;
                                                    pragma Page;
procedure Rename (
    Old_File : in string;
    New_File : in string
    ) is

    Old_FAB : FAB_Type;
    Old_NAM : NAM_Type;
    Old_ES  : File_String;
    Old_RS  : File_String;
    New_FAB : FAB_Type;
    New_NAM : NAM_Type;
    New_ES  : File_String;
    New_RS  : File_String;
    Status  : Cond_Value_Type;

begin

    Set_FAB_NAM(File => Old_File, FAB => Old_FAB, NAM => Old_NAM, ES => Old_ES);
    Old_NAM.RSA := Old_RS'address;
    Old_NAM.RSS := Unsigned_Byte(Old_RS'length);

    Set_FAB_NAM(File => New_File, FAB => New_FAB, NAM => New_NAM, ES => New_ES);
    New_NAM.RSA := New_RS'address;
    New_NAM.RSS := Unsigned_Byte(New_RS'length);

    Starlet.Rename(Status, OldFAB => Old_FAB, NewFAB => New_FAB);
    if Condition_Handling.Success(Status) then
    return;
    end if;

    Raise_Error(Old_FAB.STS);
    raise Rename_Error;

end Rename;
                                                    pragma Page;
procedure Delete (
    File : in String_Type
    ) is

begin

    Delete (File => String_Pkg.Value(File));

end Delete;
                                                    pragma Page;
procedure Delete (
    File : in string
    ) is

    FAB    : FAB_Type;
    NAM    : NAM_Type;
    ES     : File_String;
    Status : Cond_Value_Type;

begin

    Set_FAB_NAM(File => File, FAB => FAB, NAM => NAM, ES => ES);
    Starlet.Erase(Status, FAB);
    if Condition_Handling.Success(Status) then
    return;
    end if;

    Raise_Error(FAB.STS);
    raise Delete_Error;

end Delete;
                                                    pragma Page;
procedure Copy (
    Input_File  : in String_Type;
    Output_File : in String_Type
    ) is

begin

    Copy_Append(File1 => String_Pkg.Value(Input_File),
        File2 => String_Pkg.Value(Output_File),
        CIF   => false);

end Copy;
                                                    pragma Page;
procedure Copy (
    Input_File  : in String_Type;
    Output_File : in string
    ) is

begin

    Copy_Append(File1 => String_Pkg.Value(Input_File),
        File2 => Output_File,
        CIF   => false);

end Copy;
                                                    pragma Page;
procedure Copy (
    Input_File  : in string;
    Output_File : in String_Type
    ) is

begin

    Copy_Append(File1 => Input_File,
        File2 => String_Pkg.Value(Output_File),
        CIF   => false);

end Copy;
                                                    pragma Page;
procedure Copy (
    Input_File  : in string;
    Output_File : in string
    ) is

begin

    Copy_Append(File1 => Input_File,
        File2 => Output_File,
        CIF   => false);

end Copy;
                                                    pragma Page;
procedure Append (
    Input_File  : in String_Type;
    Append_File : in String_Type
    ) is

begin

    Copy_Append(File1 => String_Pkg.Value(Input_File),
        File2 => String_Pkg.Value(Append_File),
        CIF   => true);

end Append;
                                                    pragma Page;
procedure Append (
    Input_File  : in String_Type;
    Append_File : in string
    ) is

begin

    Copy_Append(File1 => String_Pkg.Value(Input_File),
        File2 => Append_File,
        CIF   => true);

end Append;
                                                    pragma Page;
procedure Append (
    Input_File  : in string;
    Append_File : in String_Type
    ) is

begin

    Copy_Append(File1 => Input_File,
        File2 => String_Pkg.Value(Append_File),
        CIF   => true);

end Append;
                                                    pragma Page;
procedure Append (
    Input_File  : in string;
    Append_File : in string
    ) is

begin

    Copy_Append(File1 => Input_File,
        File2 => Append_File,
        CIF   => true);

end Append;
                                                    pragma Page;
function Expand (
    File : in String_Type;
    Mode : in Mode_Type := FULL
    ) return String_Lists.List is

begin

    return Expand (File => String_Pkg.Value(File), Mode => Mode);

end Expand;
                                                    pragma Page;
function Expand (
    File : in string;
    Mode : in Mode_Type := FULL
    ) return String_Lists.List is

    FAB      : FAB_Type;
    NAM      : NAM_Type;
    ES       : File_String;
    RS       : File_String;
    Status   : Cond_Value_Type;
    Files    : String_Lists.List;
    New_List : boolean := true;
    Index1   : integer := RS'last;
    Index2   : integer := RS'first;

begin

    Set_FAB_NAM(File => File, FAB => FAB, NAM => NAM, ES => ES);
    FAB.IFI := FAB_IFI_Type_Init;
    NAM.RSA := RS'address;
    NAM.RSS := Unsigned_Byte(RS'length);

    String_Pkg.Mark;
    loop
    Starlet.Search(Status, FAB);
    if Condition_Handling.Success(Status) then
        if New_List then
        Files := String_Lists.Create;
        New_List := false;
        end if;
        case Mode is
        when NO_DIRECTORY | FILE_ONLY =>
            for i in 1 .. integer(NAM.RSL) loop
            if RS(i) = ']' then
                Index1 := i + 1;
                exit;
            end if;
            end loop;
        when others =>
            Index1 := RS'first;
        end case;
        case Mode is
        when NO_VERSION | FILE_ONLY =>
            for i in reverse 1 .. natural(NAM.RSL) loop
            if RS(i) = ';' then
                Index2 := i - 1;
                exit;
            end if;
            end loop;
        when others =>
            Index2 := integer(NAM.RSL);
        end case;
        declare
        File_ID : string(1 .. Index2 - Index1 + 1);
        begin
        File_ID(File_ID'first .. File_ID'last) := RS(Index1 .. Index2);
        String_Lists.Attach(Files, String_Pkg.Make_Persistent(File_ID));
        end;
    else
        if FAB.STS = RMS_NMF then
        return Files;
        end if;
        Raise_Error(FAB.STS);
        raise Expand_Error;
    end if;
    end loop;
    String_Pkg.Release;

end Expand;
                                                    pragma Page;
procedure Destroy (
    Name_List : in out String_Lists.List
    ) is

    Iterator : String_Lists.ListIter;
    Name     : String_Type;

begin

    Iterator := String_Lists.MakeListIter(Name_List);
    while (String_Lists.More(Iterator)) loop
    String_Lists.Next(Iterator, Name);
    String_Pkg.Flush(Name);
    end loop;
    String_Lists.Destroy(Name_List);

end Destroy;
                                                    pragma Page;
function Strip_Dir (
    Long_Name : in String_Type
    ) return String_Type is

    N : natural;

    begin

    N := String_Pkg.Match_C (Long_Name, ']', 1);
    if N = 0 then
        return Long_Name;
    else
        return String_Pkg.Substr
            (Long_Name, N + 1, String_Pkg.Length(Long_Name) - N);
    end if;

    end Strip_Dir;


end  File_Manager;
                                                    pragma Page;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--HASHFCNS.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package hashing_functions_pkg is

    generic
    prime_num: in positive;
            --| Required to be prime.

    function hash_string(s: string) return natural;
      --| Effects:
      --| Produces a uniform distribution over the range 0..prime - 1.

end hashing_functions_pkg;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--HASHFCNS.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with unchecked_conversion;

package body hashing_functions_pkg is

    function hash_string(s: string) return natural is

    type word is array(1..32) of boolean;

    function word_to_int is new
        unchecked_conversion(source => word, target => integer);

    chars_per_word: constant := 4;
    subtype word_str is string(1..chars_per_word);

    function word_str_to_word is new
        unchecked_conversion(source => word_str, target => word);

    words_in_s: natural;
    left_over: natural;

    hash_word: word := (word'range => false);

    hack_word_str: word_str;   --Decbug
    hack_word: word;       --Decbug
    result1: integer;       --Decbug
    result2: natural;        --Decbug

    begin
    words_in_s := s'length/chars_per_word;
    left_over := s'length mod chars_per_word;

--Decbugs replacement:
    for i in 1..words_in_s loop
        hack_word_str :=  s(s'first + chars_per_word * (i - 1) ..
                s'first + chars_per_word * i - 1);
        hack_word := word_str_to_word(hack_word_str);
        hash_word := hash_word xor hack_word;
--        hash_word :=
--        hash_word xor
--        word_str_to_word(s(s'first + chars_per_word * (i - 1) ..
--                   s'first + chars_per_word * i - 1));
    end loop;

-- Decbug Replacements:
        hack_word_str(1..left_over) :=
        s(s'first + chars_per_word * words_in_s .. s'last);
        hack_word := word_str_to_word(hack_word_str);
        hash_word(1..left_over) :=
        hash_word(1..left_over) xor hack_word(1..left_over);

--    hash_word(1..left_over) :=
--        hash_word(1..left_over) xor
--        word_str_to_word(s(s'first + chars_per_word * words_in_s..s'last));

    result1 := word_to_int(hash_word);
    result2 := result1 mod prime_num;
    return result2;

--    return word_to_int(hash_word) mod prime_num;
    end hash_string;

end hashing_functions_pkg;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--VMSLIB.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with TEXT_IO;

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

package body VMS_Lib is

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

procedure Set_Error is

    FileType : TEXT_IO.FILE_TYPE;

    begin

        TEXT_IO.Create(File => FileType, Name => "SYS$ERROR");
        TEXT_IO.Set_Output(FileType);

    end Set_Error;

end VMS_Lib;

----------------------------------------------------------------
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--HOSTDEP.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

package Host_Dependencies is
--| Simple data types and constants involving the Host Machine.

                    -- Types and Objects --

    MaxColumn : constant := 250;
    subtype Source_Column is Natural range 0..MaxColumn;
    MaxLine : constant := 100000; -- This is completely arbitrary
    subtype Source_Line is Natural range 0..MaxLine;

                        -- Operations --

    function FindTabColumn (       --| returns source column a tab is in
        InColumn : Source_Column   --| source column before tab
        ) return Source_Column;

    --| Effects

    --| This subprogram implements the tab positioning strategy
    --| of the Host system.

end Host_Dependencies;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--ERRMSG.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

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

with Host_Dependencies;           -- host dependent constants

package Lexical_Error_Message is  --| handles lexical error messages

--| Overview
--|
--| Contains text, identifiers of text, and output subprograms
--| for package Lex.
--|

    package HD renames Host_Dependencies;

    --------------------------------------------------------------
    -- Declarations Global to Package Lexical_Error_Message
    ------------------------------------------------------------------

    type Message_Type is (
        Base_Out_Of_Legal_Range_Use_16,
        Based_Literal_Delimiter_Mismatch,
        Character_Can_Not_Start_Token,
        Character_Is_Non_ASCII,
        Character_Is_Non_Graphic,
        Consecutive_Underlines,
        Digit_Invalid_For_Base,
        Digit_Needed_After_Radix_Point,
        Digit_Needed_Before_Radix_Point,
        Exponent_Missing_Integer_Field,
        Illegal_Use_Of_Single_Quote,
        Integer_Literal_Conversion_Exception_Use_1,
        Leading_Underline,
        Missing_Second_Based_Literal_Delimiter,
        Negative_Exponent_Illegal_In_Integer,
        No_Ending_String_Delimiter,
        No_Integer_In_Based_Number,
        Only_Graphic_Characters_In_Strings,
        Real_Literal_Conversion_Exception_Use_1,
        Source_Line_Maximum_Exceeded,
        Source_Line_Too_Long,
        Space_Must_Separate_Num_And_Ids,
        Terminal_Underline,
        Too_Many_Radix_Points);

    --------------------------------------------------------------
    -- Subprogram Bodies Global to Package Lexical_Error_Message
    --------------------------------------------------------------

    procedure Output_Message(             --| output lexical error message
        In_Line   : in HD.Source_Line;    --| line number of error.
        In_Column : in HD.Source_Column;  --| column number of error.
        In_Message_Id : in Message_Type); --| which message to output.

    --| Effects
    --|
    --| Output error message for lexer.
    --|

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

    procedure Output_Message(             --| output lexical error message
        In_Line   : in HD.Source_Line;    --| line number of error.
        In_Column : in HD.Source_Column;  --| column number of error.
        In_Insertion_Text : in string;    --| text to insert.
        In_Message_Id : in Message_Type); --| which message to output.

    --| Effects
    --|
    --| Output error message with inserted text.  The text is appended
    --| to the message if there are no insertion flags.

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

end Lexical_Error_Message;

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

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--ERRMSG.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::


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

with TEXT_IO;

package body Lexical_Error_Message is

------------------------------------------------------------------
-- Declarations Local to Package Lexical_Error_Message
------------------------------------------------------------------

    Insertion_Flag : character := '@';

    subtype Message_Text_Range is positive range 1..64;

    Message_Text : constant array (Message_Type) of
        string (Message_Text_Range) := (
    -- 1234567890123456789012345678901234567890123456789012345678901234
    -- Base_Out_Of_Legal_Range_Use_16   =>
      "This base " &
           Insertion_Flag  -- insert a String
           & " is not in the range 2 to 16. Assuming base 16.      ",
    -- Based_Literal_Delimiter_Mismatch =>
      "Based_literal delimiters must be the same.                      ",
    -- Character_Can_Not_Start_Token    =>
      "This character " &
            Insertion_Flag  -- insert a character
            & " can not start a token.                         ",
    -- Character_Is_Non_ASCII  =>
      "This value x@VALUE@x is not an ASCII character.                 ",
        --|? should display the value, but this message is unlikely.
        --|? see Lex.bdy
    -- Character_Is_Non_Graphic=>
      "This character with decimal value" &
                      Insertion_Flag
                                          -- insert the decimal value
                      & " is not a graphic_character.  ",
    -- Consecutive_Underlines  =>
      "Consecutive underlines are not allowed.                         ",
    -- Digit_Invalid_For_Base  =>
      "This digit " &
           Insertion_Flag  -- insert a Character
        & " is out of range for the base specified.            ",
    -- Digit_Needed_After_Radix_Point   =>
      "At least one digit must appear after a radix point              ",
    -- Digit_Needed_Before_Radix_Point  =>
      "At least one digit must appear before a radix point             ",
    -- Exponent_Missing_Integer_Field   =>
      "The exponent is missing its integer field.                      ",
    -- Illegal_Use_Of_Single_Quote  =>
      "Single quote is not used for an attribute or character literal. ",
    -- Integer_Literal_Conversion_Exception_Using_1 =>
      "Error while evaluating a integer_literal. Using a value of '1'. ",
    -- Leading_Underline    =>
      "Initial underlines are not allowed.                             ",
    -- Missing_Second_Based_Literal_Delimiter   =>
      "Second based_literal delimiter is missing.                      ",
    -- Negative_Exponent_Illegal_In_Integer =>
      "A negative exponent is illegal in an integer literal.           ",
    -- No_Ending_String_Delimiter   =>
      "String is improperly terminated by the end of the line.         ",
    -- No_Integer_In_Based_Number   =>
      "A based number must have a value.                               ",
    -- Only_Graphic_Characters_In_Strings   =>
      "This non-graphic character with decimal value" &
                            Insertion_Flag
                                               -- insert the decimal value
                          & " found in string. ",
    -- Real_Literal_Conversion_Exception_Using_1    =>
      "Error while evaluating a real_literal. Using a value of '1.0'.  ",
    -- Source_Line_Maximum_Exceeded =>
      "Maximum allowable source line number of " &
                           Insertion_Flag
                                               -- insert an Integer'IMAGE
                                             & " exceeded.             ",
    -- Source_Line_Too_Long =>
      "Source line number " &
                Insertion_Flag  -- insert an Integer'IMAGE
            & " is too long.                               ",
    -- Space_Must_Separate_Num_And_Ids      =>
      "A space must separate numeric_literals and identifiers.         ",
    -- Terminal_Underline   =>
      "Terminal underlines are not allowed.                            ",
    -- Too_Many_Radix_Points        =>
      "A real_literal may have only one radix point.                   ");

    ------------------------------------------------------------------
    -- Subprogram Bodies Global to Package Lexical_Error_Message
    ------------------------------------------------------------------

    procedure Output_Message(
    In_Line       : in HD.Source_Line;
    In_Column     : in HD.Source_Column;
    In_Message_Id : in Message_Type) is

    begin

        -- output error message including line and column number
    TEXT_IO.NEW_LINE(TEXT_IO.STANDARD_OUTPUT);
    TEXT_IO.PUT_LINE(
            FILE => TEXT_IO.STANDARD_OUTPUT,
        ITEM =>
         "Lexical Error: Line: "
        & HD.Source_Line'IMAGE  (In_Line)
        & " Column: "
        & HD.Source_Column'IMAGE(In_Column)
        & " - "
        & Message_Text(In_Message_Id));

    end Output_Message;

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

    procedure Output_Message(
    In_Line       : in HD.Source_Line;
    In_Column     : in HD.Source_Column;
    In_Insertion_Text : in string; --| text to insert.
    In_Message_Id : in Message_Type) is

        --------------------------------------------------------------
        -- Declarations for SubProgram Output_Message
        --------------------------------------------------------------

        Insertion_Index : positive :=
            (Message_Text_Range'Last + 1);
        --| if insertion flag is not found,
        --| then we append the In_Message_Text to the message

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

    begin

    --| Algorithm
    --|
    --| Find the insertion point.
    --| if the Message_Text doesn't have an Insertion_Flag,
    --| then set the Insertion_Index to the end of the message.

    for i in Message_Text_Range loop
        if (Insertion_Flag = Message_Text(In_Message_Id)(i) ) then
            Insertion_Index := i;
            exit;
        end if;
    end loop;

    -- output error message with test, line and column number
    TEXT_IO.NEW_LINE(TEXT_IO.STANDARD_OUTPUT);
    TEXT_IO.PUT_LINE(
            FILE => TEXT_IO.STANDARD_OUTPUT,
        ITEM =>
          "Lexical Error: Line: "
        & HD.Source_Line'IMAGE  (In_Line)
        & " Column: "
        & HD.Source_Column'IMAGE(In_Column)
        & " - "
        & Message_Text(In_Message_Id)(1..(Insertion_Index-1))
        & In_Insertion_Text
        & Message_Text(In_Message_Id)
                    ((Insertion_Index+1)..Message_Text_Range'Last));

    end Output_Message;

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

end Lexical_Error_Message;

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

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--HOSTDEP.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

package body Host_Dependencies is
--| Simple data types and constants involving the host machine

                            -- Operations --

    function FindTabColumn (          -- see subprogram specification
        InColumn : Source_Column
        ) return Source_Column is

    --| Effects
    --| Tabs are positioned every eight columns starting at column 1.

    Tab_Width : constant := 8; --| number of columns a tab takes up.

    begin
        return (InColumn + ( Tab_Width - ( InColumn mod Tab_Width) ) );
    end FindTabColumn;

end Host_Dependencies;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--GRMCONST.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::


package Grammar_Constants is


      type ParserInteger is range 0..400000; -- arbitrary upper bound
          --| range of possible values for parser's integer values

    function setGrammarSymbolCount return ParserInteger;

    function setActionCount return ParserInteger;

    function setStateCountPlusOne return ParserInteger;

    function setLeftHandSideCount return ParserInteger;

    function setRightHandSideCount return ParserInteger;

end Grammar_Constants;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--PTBLS.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
----------------------------------------------------------------------
with Host_Dependencies;      -- host dependent constants for the compiler.
with Grammar_Constants;      -- constants generated by parser generator
use Grammar_Constants;

package ParseTables is          --| Table output of parse tables generator

--| Overview
--|
--| This package contains the constants and tables generated by running
--| the LALR(1) parse tables generator on the Ada Grammar.
--| It also contains subprograms to access values in the more complex
--| tables, that could have their structures tuned later.
--|

--| Tuning
--|
--| --------------------------------------------------------------
--|
--| The Parser Generator has two options that effect the speed of
--| compilation:
--|
--| NODEFAULT : Eliminates the default reductions.
--| This also would improve error recovery.
--| Note that the table DefaultMap is still produced, though it
--| will never be referenced.
--| Thus, there need be no change to the code
--| in ParserUtilities.GetAction .
--|
--| LF : This changes the load factor used to pack and size the
--| ActionTables. It can range between 0 and 100.
--| A low LF means fewer collisions and faster parsing.
--| A high LF means more collisions and slower parsing.
--| ----------------------------------------------------------------
--|
--| The types GrammarSymbolRecord and FollowSymbolRecord
--| have a lot of unused space. The space/time tradeoff of
--| converting these into discriminated records or another
--| alternative representation, could be investigated.
--| This investigation should take the elaboration time
--| of the initializing aggregates into account.
--|
--| ----------------------------------------------------------------
--|
--| The Action Tables might be made made smaller by a restructuring of
--| the grammar.
--| For example: Have a rule for the token sequence:
--|
--| BEGIN seq_Of_Statements [EXCP..]
--|
--| ----------------------------------------------------------------
--|
--| The ParserGenerator might be modified along with
--| ParseTables.GetAction to produce smaller tables.
--| See:
--|
--| "Combined Actions to Reduce LR-Parsertables"
--| by K.Groneing. SIGPLAN Notices, Volume 19, Number 3, March 1984.
--|
--| ----------------------------------------------------------------
--|

--| Notes
--|
--| Abbreviations Used
--|
--| Rep : Representation
--|

--| RUN-TIME INPUT OF NYU LALR GENERATED TABLES AND CONSTANTS
--|
--|
--| followed by the current correct value of the
--| constant supplied by the NYU LALR Parser Generator:
--|
--| GrammarSymbolCount
--| LeftHandSideCount
--| RightHandSideCount
--| ActionTableOneLength
--| ActionTableTwoLength
--| DefaultMapLength
--| InSymbolMapLength
--| FollowMapLength
--| StateCountPlusOne
--| GrammarSymbolCountPlusOne
--| ActionCount
--| ActionTableSize
--|
--| in each of the eight declarations:
--|
--| GrammarSymbolTable
--| LeftHandSide
--| RightHandSide
--| ActionTableOne
--| ActionTableTwo
--| DefaultMap
--| InSymbolMap
--| FollowSymbolMap
--|

    package GC renames Grammar_Constants;

    ------------------------------------------------------------------
    -- Common Declarations for Action_Token_Map
    ------------------------------------------------------------------

    Max_Action_Token_Count : constant := 48;
        --| This constant may need to be made larger if the grammar
        --| ever gets too large.
        --| It could be automatically generated.


    ------------------------------------------------------------------
    -- Common Declarations for Shift_State_Map
    ------------------------------------------------------------------

    Max_Shift_State_Count : constant := 90;
        --| This constant may need to be made larger if the grammar
        --| ever gets too large.
        --| It could be automatically generated.



    subtype ParserStringRangePlusZeroCommon is natural
            range 0..Host_Dependencies.MaxColumn;
        --| Parser's string should never be greater than a source line
        --| worth of text.

    subtype GrammarSymbolRepRangePlusZeroCommon is
            ParserStringRangePlusZeroCommon range 0..57;

    subtype FollowSymbolRangeCommon is GC.ParserInteger range 1..50;

    ------------------------------------------------------------------
    -- Declarations Global to Package ParseTables
    ------------------------------------------------------------------

    subtype PositiveParserInteger is GC.ParserInteger range
        1..GC.ParserInteger'last ;

    subtype ParserStringRangePlusZero is
        ParserStringRangePlusZeroCommon;
        --| Parser's string should never be greater than a source line
        --| worth of text.

----------------------------------------------------------------------
-- The first constant used to  the Parse Tables
----------------------------------------------------------------------

GrammarSymbolCount : constant GC.ParserInteger :=
    GC.setGrammarSymbolCount ;
    --| Number of terminals and nonterminals in the Ada grammar
    --| rules input to the parse tables generator

    subtype GrammarSymbolRange is
        GC.ParserInteger range 1..GrammarSymbolCount;
        --| valid range of values for grammar symbols

    ------------------------------------------------------------------
    -- Parser Table Generated Token Values for Terminals
    ------------------------------------------------------------------

    -- WARNING: need to be checked after each Parser Generator Run.
    -- This could be made part of the ParseTables/ErrorParseTables
    -- generator program(s) at some point.

    ------------------------------------------------------------------
    -- Special Empty Terminal
    ------------------------------------------------------------------

    Empty_TokenValue    : constant GrammarSymbolRange :=  1;

    ------------------------------------------------------------------
    -- Reserved Words
    ------------------------------------------------------------------

    AbortTokenValue     : constant GrammarSymbolRange :=  2;
    AbsTokenValue       : constant GrammarSymbolRange :=  3;
    AcceptTokenValue    : constant GrammarSymbolRange :=  4;
    AccessTokenValue    : constant GrammarSymbolRange :=  5;
    AllTokenValue       : constant GrammarSymbolRange :=  6;
    AndTokenValue       : constant GrammarSymbolRange :=  7;
    ArrayTokenValue     : constant GrammarSymbolRange :=  8;
    AtTokenValue        : constant GrammarSymbolRange :=  9;
    BeginTokenValue     : constant GrammarSymbolRange := 10;
    BodyTokenValue      : constant GrammarSymbolRange := 11;
    CaseTokenValue      : constant GrammarSymbolRange := 12;
    ConstantTokenValue  : constant GrammarSymbolRange := 13;
    DeclareTokenValue   : constant GrammarSymbolRange := 14;
    DelayTokenValue     : constant GrammarSymbolRange := 15;
    DeltaTokenValue     : constant GrammarSymbolRange := 16;
    DigitsTokenValue    : constant GrammarSymbolRange := 17;
    DoTokenValue        : constant GrammarSymbolRange := 18;
    ElseTokenValue      : constant GrammarSymbolRange := 19;
    ElsifTokenValue     : constant GrammarSymbolRange := 20;
    EndTokenValue       : constant GrammarSymbolRange := 21;
    EntryTokenValue     : constant GrammarSymbolRange := 22;
    ExceptionTokenValue : constant GrammarSymbolRange := 23;
    ExitTokenValue      : constant GrammarSymbolRange := 24;
    ForTokenValue       : constant GrammarSymbolRange := 25;
    FunctionTokenValue  : constant GrammarSymbolRange := 26;
    GenericTokenValue   : constant GrammarSymbolRange := 27;
    GotoTokenValue      : constant GrammarSymbolRange := 28;
    IfTokenValue        : constant GrammarSymbolRange := 29;
    InTokenValue        : constant GrammarSymbolRange := 30;
    IsTokenValue        : constant GrammarSymbolRange := 31;
    LimitedTokenValue   : constant GrammarSymbolRange := 32;
    LoopTokenValue      : constant GrammarSymbolRange := 33;
    ModTokenValue       : constant GrammarSymbolRange := 34;
    NewTokenValue       : constant GrammarSymbolRange := 35;
    NotTokenValue       : constant GrammarSymbolRange := 36;
    NullTokenValue      : constant GrammarSymbolRange := 37;
    OfTokenValue        : constant GrammarSymbolRange := 38;
    OrTokenValue        : constant GrammarSymbolRange := 39;
    OthersTokenValue    : constant GrammarSymbolRange := 40;
    OutTokenValue       : constant GrammarSymbolRange := 41;
    PackageTokenValue   : constant GrammarSymbolRange := 42;
    PragmaTokenValue    : constant GrammarSymbolRange := 43;
    PrivateTokenValue   : constant GrammarSymbolRange := 44;
    ProcedureTokenValue : constant GrammarSymbolRange := 45;
    RaiseTokenValue     : constant GrammarSymbolRange := 46;
    RangeTokenValue     : constant GrammarSymbolRange := 47;
    RecordTokenValue    : constant GrammarSymbolRange := 48;
    RemTokenValue       : constant GrammarSymbolRange := 49;
    RenamesTokenValue   : constant GrammarSymbolRange := 50;
    ReturnTokenValue    : constant GrammarSymbolRange := 51;
    ReverseTokenValue   : constant GrammarSymbolRange := 52;
    SelectTokenValue    : constant GrammarSymbolRange := 53;
    SeparateTokenValue  : constant GrammarSymbolRange := 54;
    SubtypeTokenValue   : constant GrammarSymbolRange := 55;
    TaskTokenValue      : constant GrammarSymbolRange := 56;
    TerminateTokenValue : constant GrammarSymbolRange := 57;
    ThenTokenValue      : constant GrammarSymbolRange := 58;
    TypeTokenValue      : constant GrammarSymbolRange := 59;
    UseTokenValue       : constant GrammarSymbolRange := 60;
    WhenTokenValue      : constant GrammarSymbolRange := 61;
    WhileTokenValue     : constant GrammarSymbolRange := 62;
    WithTokenValue      : constant GrammarSymbolRange := 63;
    XorTokenValue       : constant GrammarSymbolRange := 64;

    ------------------------------------------------------------------
    -- Identifier and Literals
    ------------------------------------------------------------------

    IdentifierTokenValue : constant GrammarSymbolRange := 65;
    NumericTokenValue    : constant GrammarSymbolRange := 66;
    StringTokenValue     : constant GrammarSymbolRange := 67;
    CharacterTokenValue  : constant GrammarSymbolRange := 68;

    ------------------------------------------------------------------
    -- Single Delimiters
    ------------------------------------------------------------------

    Ampersand_TokenValue  : constant GrammarSymbolRange := 69;
    Apostrophe_TokenValue : constant GrammarSymbolRange := 70;
    LeftParen_TokenValue  : constant GrammarSymbolRange := 71;
    RightParen_TokenValue : constant GrammarSymbolRange := 72;
    Star_TokenValue       : constant GrammarSymbolRange := 73;
    Plus_TokenValue       : constant GrammarSymbolRange := 74;
    Comma_TokenValue      : constant GrammarSymbolRange := 75;
    Minus_TokenValue      : constant GrammarSymbolRange := 76;
    Dot_TokenValue        : constant GrammarSymbolRange := 77;
    Slash_TokenValue      : constant GrammarSymbolRange := 78;
    Colon_TokenValue      : constant GrammarSymbolRange := 79;
    SemiColon_TokenValue  : constant GrammarSymbolRange := 80;
    LT_TokenValue         : constant GrammarSymbolRange := 81;
    EQ_TokenValue         : constant GrammarSymbolRange := 82;
    GT_TokenValue         : constant GrammarSymbolRange := 83;
    Bar_TokenValue        : constant GrammarSymbolRange := 84;


    ------------------------------------------------------------------
    -- Double Delimiters
    ------------------------------------------------------------------

    EQGT_TokenValue     : constant GrammarSymbolRange := 85;
    DotDot_TokenValue   : constant GrammarSymbolRange := 86;
    StarStar_TokenValue : constant GrammarSymbolRange := 87;
    ColonEQ_TokenValue  : constant GrammarSymbolRange := 88;
    SlashEQ_TokenValue  : constant GrammarSymbolRange := 89;
    GTEQ_TokenValue     : constant GrammarSymbolRange := 90;
    LTEQ_TokenValue     : constant GrammarSymbolRange := 91;
    LTLT_TokenValue     : constant GrammarSymbolRange := 92;
    GTGT_TokenValue     : constant GrammarSymbolRange := 93;
    LTGT_TokenValue     : constant GrammarSymbolRange := 94;

    ------------------------------------------------------------------
    -- Comment Terminal
    ------------------------------------------------------------------

    Comment_TokenValue  : constant GrammarSymbolRange := 95;

    ------------------------------------------------------------------
    -- Special Terminals
    ------------------------------------------------------------------

    EOF_TokenValue      : constant GrammarSymbolRange := 96;

    ------------------------------------------------------------------
    -- Special Non-Terminals
    ------------------------------------------------------------------

    ACC_TokenValue      : constant GrammarSymbolRange := 97;

    ------------------------------------------------------------------
    -- Grammar Symbol Classes
    ------------------------------------------------------------------

    subtype TokenRange is GrammarSymbolRange range 1..EOF_TokenValue;

    subtype TokenRangeLessEOF is
        GrammarSymbolRange range 1..(EOF_TokenValue - 1);

    subtype NonTokenRange is
        GrammarSymbolRange range (EOF_TokenValue + 1)..GrammarSymbolCount;

    ActionCount : constant GC.ParserInteger :=
        GC.setActionCount ;
        --| Number of actions in the parse tables.
    -- NYU Reference Name: NUM_ACTIONS

    StateCountPlusOne : constant GC.ParserInteger :=
        GC.setStateCountPlusOne ;
        --| Number of states plus one in the parse tables.
    -- NYU Reference Name: NUM_STATES

    subtype StateRange is
        GC.ParserInteger range 1..(StateCountPlusOne - 1);

    subtype ActionRange is GC.ParserInteger range 0..ActionCount;

    LeftHandSideCount :
        constant GC.ParserInteger := GC.setLeftHandSideCount;
        --| Number of left hand sides in the Ada grammar rules.

    subtype LeftHandSideRange is
        GC.ParserInteger range 1..LeftHandSideCount;

    function Get_LeftHandSide(
        GrammarRule : LeftHandSideRange) return GrammarSymbolRange;
    pragma inline (Get_LeftHandSide) ;

    RightHandSideCount : constant GC.ParserInteger :=
        GC.setRightHandSideCount ;
    --| Number of right hand sides in the Ada grammar rules.

    subtype RightHandSideRange is
        GC.ParserInteger range 1..RightHandSideCount;

    function Get_RightHandSide(
        GrammarRule : RightHandSideRange) return GC.ParserInteger;
    pragma inline (Get_RightHandSide) ;

    ------------------------------------------------------------------
    -- Subprogram Bodies Global to Package ParseTables
    ------------------------------------------------------------------

    function GetAction(
        InStateValue  : in StateRange;
        InSymbolValue : in GrammarSymbolRange
        )  return ActionRange;

    function Get_Grammar_Symbol(    --| return the string representation
                    --| of the grammar symbol
    In_Index : in GrammarSymbolRange) return string;

    --| Effects
    --|
    --| This subprogram returns the string representation of the
    --| GrammarSymbolRange passed in.
    --|

    ------------------------------------------------------------------
    subtype FollowMapRange is NonTokenRange;

    type FollowSymbolArray is array(PositiveParserInteger range <>)
                    of GrammarSymbolRange;

    type FollowSymbolRecord is
    record
        follow_symbol_count : TokenRange;
        follow_symbol       : FollowSymbolArray (TokenRange);
    end record;
    ------------------------------------------------------------------

    function Get_Follow_Map(        --| return the array of follow symbols
                    --| of the grammar symbol passed in
    In_Index : in FollowMapRange) return FollowSymbolRecord;


    --| Effects
    --|
    --| This subprogram returns the array of follow symbols for the
    --| grammar symbol passed in.
    --|

    ------------------------------------------------------------------
    -- The following declarations are for Error Recovery.
    ------------------------------------------------------------------
    ------------------------------------------------------------------
    -- Action_Token_Map
    ------------------------------------------------------------------

    subtype Action_Token_Range is
        GC.ParserInteger range 1..Max_Action_Token_Count;

    subtype Action_Token_Range_Plus_Zero is
        GC.ParserInteger range 0..Max_Action_Token_Count;
    --| for the set_size (which could be null!)

    type Action_Token_Array is array (PositiveParserInteger range <>)
    of TokenRangeLessEOF;

    type Action_Token_Record is
    record
        set_size : Action_Token_Range_Plus_Zero;
        set      : Action_Token_Array (Action_Token_Range);
    end record;

    ------------------------------------------------------------------
    -- Shift_State_Map
    ------------------------------------------------------------------

    subtype Shift_State_Range is
        GC.ParserInteger range 1..Max_Shift_State_Count;

    subtype Shift_State_Range_Plus_Zero is
        GC.ParserInteger range 0..Max_Shift_State_Count;
    --| for the set_size (which could be null!)

    type Shift_State_Array is array (PositiveParserInteger range <>)
    of StateRange;

    type Shift_State_Record is
    record
        set_size : Shift_State_Range_Plus_Zero;
        set      : Shift_State_Array (Shift_State_Range);
    end record;

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

    function Get_Action_Token_Map(  --| return the array of action tokens
                    --| for the state passed in.
    In_Index : in StateRange
                    --| the state to return action tokens
                    --| for.
    ) return Action_Token_Record;

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

    function Get_Shift_State_Map(   --| return the array of shift states
                    --| for the grammar symbol passed in.
    In_Index : in GrammarSymbolRange
                    --| grammar symbol to return shifts
                    --| for.
    ) return Shift_State_Record;

    -- The following variables contain statistics information
    -- collected during the parse:
    ParserDecisionCount : Natural := 0 ; --| Total number of times that
                                         --| GetAction was called.
    MaxCollisions       : Natural := 0 ; --| Of all the calls to GetAction
      --| The one which resulted in the greatest number of collisions
    TotalCollisions     : Natural := 0 ;
      --| Total number of collisions which occurred during parsing.

end ParseTables;


--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--LEXIDVAL.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

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

with ParseTables;               -- tables from parser generator

package Lex_Identifier_Token_Value is
    --| Classify identifiers and reserved words and determine which
    --| identifiers are in package STANDARD.

    ------------------------------------------------------------------
    -- Subprogram Bodies Global to
    -- Package Lex_Identifier_Token_Value
    ------------------------------------------------------------------

    procedure Find(
    --| returns token value and whether identifier is in package STANDARD.

        In_Identifier   : in string;   --| text of identifier to identify

        Out_Token_Value : out ParseTables.TokenRange);
        --| TokenValue of this identifier

    --| Effects
    --|
    --| This subprogram determines if the identifier is
    --| a reserved word or a plain identifier.
    --|
    --| The answer is indicated by returning the appropriate TokenValue.
    --|

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

end Lex_Identifier_Token_Value;

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

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--LEXIDVAL.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::


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

with Grammar_Constants;           -- constants from the parser generator
use Grammar_Constants;
    --| to gain visibility on ParserInteger's operations

package body Lex_Identifier_Token_Value is

--| Overview
--|
--| This perfect hash algorithm taken from
--|  "A Perfect Hash Function for Ada Reserved Words"
--|  by David Wolverton, published in Ada Letters Jul-Aug 1984
--|
    use ParseTables;
    package PT renames ParseTables;

    ------------------------------------------------------------------
    -- Declarations Local to Package Lex_Identifier_Token_Value
    ------------------------------------------------------------------

    subtype HashRange is integer ;
    subtype HashIdentifierSubrange is HashRange range 0..70 ;

    type XlateArray is array(character) of HashRange ;
    Xlate : constant XlateArray := XlateArray'(
        'A' => 0,    'B' => 49,   'C' => 0,   'D' => -7,   'E' => -20,
        'F' => 18,   'G' => -2,   'H' =>-38,  'I' => 33,   'J' =>  0,
        'K' => -9,   'L' =>  9,   'M' => 29,   'N' => -9,   'O' =>  6,
        'P' => 26,   'Q' =>  0,   'R' =>  8,   'S' =>  1,   'T' =>  1,
        'U' => -9,   'V' =>  0,   'W' => 56,   'X' =>-28,   'Y' => 11,
        'Z' =>  0, others => 0) ;

    type HashTableArray is array( HashIdentifierSubrange)
        of ParseTables.TokenRange ;
    --| Mapping from hash value into the token values.

    HashTable : constant HashTableArray := HashTableArray'(
        40 => 2,   -- ABORT
        6 => 3,    -- ABS
        37 => 4,   -- ACCEPT
        43 => 5,   -- ACCESS
        34 => 6,   -- ALL
        22 => 7,   -- AND
        16 => 8,   -- ARRAY
        3 => 9,    -- AT
        61 => 10,  -- BEGIN
        70 => 11,  -- BODY
        20 => 12,  -- CASE
        35 => 13,  -- CONSTANT
        14 => 14,  -- DECLARE
        9 => 15,   -- DELAY
        36 => 16,  -- DELTA
        38 => 17,  -- DIGITS
        7 => 18,   -- DO
        0 => 19,   -- ELSE
        19 => 20,  -- ELSIF
        2 => 21,   -- END
        30 => 22,  -- ENTRY
        8 => 23,   -- EXCEPTION
        1 => 24,   -- EXIT
        57 => 25,  -- FOR
        45 => 26,  -- FUNCTION
        21 => 27,  -- GENERIC
        46 => 28,  -- GOTO
        69 => 29,  -- IF
        42 => 30,  -- IN
        52 => 31,  -- IS
        17 => 32,  -- LIMITED
        67 => 33,  -- LOOP
        53 => 34,  -- MOD
        58 => 35,  -- NEW
        23 => 36,  -- NOT
        26 => 37,  -- NULL
        54 => 38,  -- OF
        44 => 39,  -- OR
        47 => 40,  -- OTHERS
        50 => 41,  -- OUT
        25 => 42,  -- PACKAGE
        56 => 43,  -- PRAGMA
        51 => 44,  -- PRIVATE
        49 => 45,  -- PROCEDURE
        29 => 46,  -- RAISE
        5 => 47,   -- RANGE
        41 => 48,  -- RECORD
        48 => 49,  -- REM
        24 => 50,  -- RENAMES
        39 => 51,  -- RETURN
        31 => 52,  -- REVERSE
        12 => 53,  -- SELECT
        27 => 54,  -- SEPARATE
        18 => 55,  -- SUBTYPE
        32 => 56,  -- TASK
        28 => 57,  -- TERMINATE
        4 => 58,   -- THEN
        15 => 59,  -- TYPE
        10 => 60,  -- USE
        59 => 61,  -- WHEN
        63 => 62,  -- WHILE
        60 => 63,  -- WITH
        11 => 64,  -- XOR
        others => PT.IdentifierTokenValue
    ) ;

    --| These are used to convert lower to upper case.
    convert : array(character) of character ;
    difference : constant := character'pos('a') - character'pos('A');

    ------------------------------------------------------------------
    -- Subprogram Specifications Local to
    -- Package Lex_Identifier_Token_Value
    ------------------------------------------------------------------

    function NormalizeToUpperCase ( --| normalize SYMREP to upper case
    In_String: in String) return String;

    ------------------------------------------------------------------
    -- Subprogram Bodies Global to Package Lex_Identifier_Token_Value
    ------------------------------------------------------------------

    procedure Find(
        In_Identifier   : in string;
        Out_Token_Value : out ParseTables.TokenRange) is

        subtype id_string is string(In_Identifier'Range);

        In_Identifier_Normalized : id_string;

        Length : HashRange := In_Identifier_Normalized'length ;
        --| Length of string

        First : HashRange := In_Identifier_Normalized'first ;
        --| Lower bound

        FirstChar, LastChar : character ;
        --| First and last characters

        SecondToLastChar : character ;
        --| Second to last character

        SecondToLast : HashRange;
        --| Alphabetic position of 2nd to last char.

        HashValue : HashRange ;
        --| Perfect hash value.

        TokenValue : ParseTables.GrammarSymbolRange ;

    begin
        In_Identifier_Normalized := NormalizeToUpperCase(In_Identifier);

        -- Assume In_Identifier is a plain identifier.
        Out_Token_Value   := PT.IdentifierTokenValue;

        if (Length <= 1) or else (Length >= 10) then
            -- Couldn't be a reserved word.
            return;
        else
            FirstChar := In_Identifier_Normalized(First) ;
            LastChar := In_Identifier_Normalized( (First+Length) -1 ) ;
            SecondToLastChar := In_Identifier_Normalized(
                (First+Length) -2 ) ;
            SecondToLast := character'pos(SecondToLastChar)
                - character'pos('A') ;
            HashValue := XLate(FirstChar) + XLate(LastChar) +
                2*SecondToLast + Length ;
        end if;

        if HashValue in HashIdentifierSubrange then
            -- index and see if it matches a reserved word value.
            -- if so, then compare the string to the reserved word text.
            TokenValue := ParseTables.GrammarSymbolRange(
        HashTable(HashValue)) ; -- conversion
            if TokenValue /= PT.IdentifierTokenValue then
                if (In_Identifier_Normalized =
            PT.Get_Grammar_Symbol(TokenValue) ) then
                    Out_Token_Value := PT.TokenRange(TokenValue) ;
                                     -- conversion
                end if;
            end if;
        end if;
    end Find;

    ------------------------------------------------------------------
    -- Subprogram Bodies Local to
    -- Package Lex_Identifier_Token_Value
    ------------------------------------------------------------------

    function NormalizeToUpperCase(  --| normalize SYMREP to upper case
    In_String: in String) return String is

        OutString : string (In_String'range);

    begin
        for i in In_String'range loop
            OutString(i) := convert(In_String(i));
        end loop;
        return OutString;
    end NormalizeToUpperCase;

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

    begin

    --| Initialize the conversion array for lower to upper case conversion
    for i in character loop
        case i is
            when 'a' .. 'z' =>
        convert(i) := character'val(character'pos(i)
                    - difference);
            when others =>
        convert(i) := i;
        end case;
    end loop;

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

end Lex_Identifier_Token_Value;

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

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--PDECLS.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

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

with Host_Dependencies;    -- host dependent constants
with ParseTables;          -- constants and state tables
use ParseTables;

with Grammar_Constants;
use Grammar_Constants;

package ParserDeclarations is   --| Objects used by the Parser

--| Notes

--| Abbreviations used in this compilation unit:
--|
--| gram : grammar
--| sym  : symbol
--| val  : value
--|

    package HD renames Host_Dependencies;
    package PT renames ParseTables;
    package GC renames Grammar_Constants;

                        -- Exceptions --

    MemoryOverflow : exception;  --| raised if Parser runs out of
                                 --| newable memory.
    Parser_Error   : exception;  --| raised if an error occurs during
                                 --| parsing.

    --| The double delimiters were named with a combination of the name of
    --| each component symbol.

    Arrow_TokenValue          : GrammarSymbolRange
        renames EQGT_TokenValue;
    Exponentiation_TokenValue : GrammarSymbolRange
        renames StarStar_TokenValue;
    Assignment_TokenValue     : GrammarSymbolRange
        renames ColonEQ_TokenValue;
    NotEquals_TokenValue      : GrammarSymbolRange
        renames SlashEQ_TokenValue;
    StartLabel_TokenValue     : GrammarSymbolRange
        renames LTLT_TokenValue;
    EndLabel_TokenValue       : GrammarSymbolRange
        renames GTGT_TokenValue;
    Box_TokenValue            : GrammarSymbolRange
        renames LTGT_TokenValue;

    ------------------------------------------------------------------
    -- Grammar Symbol Classes
    ------------------------------------------------------------------

    subtype ReservedWordRange is GrammarSymbolRange
    range AbortTokenValue .. XorTokenValue;

    subtype SingleDelimiterRange is GrammarSymbolRange
    range Ampersand_TokenValue .. Bar_TokenValue;

    subtype DoubleDelimiterRange is GrammarSymbolRange
    range Arrow_TokenValue .. Box_TokenValue;

    ------------------------------------------------------------------
    -- ParseTables.GetAction return values
    ------------------------------------------------------------------

    subtype Error_Action_Range is    --| ActionRange that indicates
        ActionRange range 0..0;      --| the error range

    subtype Shift_Action_Range is    --| ActionRange that indicates
                                     --| a shift action.
        ActionRange range 1..(StateCountPlusOne - 1);

    subtype Accept_Action_Range is   --| ActionRange that indicates
                                     --| the accept action.
        ActionRange range StateCountPlusOne..StateCountPlusOne;

    subtype Reduce_Action_Range is   --| ActionRange that indicates
                                     --| a reduce action.
        ActionRange range (StateCountPlusOne + 1)..ActionCount;

    ------------------------------------------------------------------
    -- Queue and Stack Management
    ------------------------------------------------------------------

    subtype StateParseStacksIndex is --| range of index values for
        GC.ParserInteger range 0..200;  --| StateStack and ParseStack

    subtype StateParseStacksRange is --| array index values for
                                     --| StateStack and ParseStack
        StateParseStacksIndex range 1..StateParseStacksIndex'Last;

    Look_Ahead_Limit : positive := 5;--| Look ahead limit for parser

    ------------------------------------------------------------------
    -- StateStack Element
    ------------------------------------------------------------------

    subtype StateStackElement is StateRange;

    type Source_Text is access String;

    Null_Source_Text : constant Source_Text
        := null;

    ------------------------------------------------------------------
    -- ParseStack and Grammar Symbol Elements
    ------------------------------------------------------------------

    type Token is
        record
        text            : Source_Text;
        srcpos_line     : HD.Source_Line;
        srcpos_column   : HD.Source_Column;
        end record;

    type ParseStackElement is
        record
        gram_sym_val  : GrammarSymbolRange;
        --| used by parser to identify kind of grammar symbol
        lexed_token : Token;
        --| lexed tokens not yet reduced (eliminated)
        --| by ReduceActions.
        end record;

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

    CurToken : ParseStackElement;
        --| return from Lex.GetNextSourceToken
        --| Token used in subprogram Parse to determine
        --| next action from.
        --| Also used in ReduceActionsUtilities to determine last
        --| compilation unit in a compilation.

    ------------------------------------------------------------------
    -- Subprogram Bodies Global to Package ParserDeclarations
    ------------------------------------------------------------------

    function Get_Source_Text(       --| get a string from a Source_Text
                    --| object
        In_Source_Text :            --| the object to get the string from
            in Source_Text
    ) return string;

    --| Effects

    --| This subprogram gets a string from a Source_Text object.
    --| It exists to concentrate the interface to Source_Text objects.

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

    procedure Put_Source_Text(     --| put a string into a Source_Text
                   --| object
        In_String : in string;     --| the string to store
        In_Out_Source_Text :       --| the object to store the string in
            in out Source_Text);


    --| Effects

    --| This subprogram stores a string in a Source_Text object.
    --| It exists to concentrate the interface to Source_Text objects.

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

    function Dump_Parse_Stack_Element(  --| return the data in a
                                        --| ParseStackElement or
                                        --| TokenQueueElement as a string
        In_PSE : in ParseStackElement   --| the Element to display.
    ) return string;

    --| Effects

    --| This subprogram returns the data in a ParseStackElement or its
    --| sub-type a TokenQueueElement as a string.

    --| Notes

    --| Abbreviations used in this compilation unit
    --|
    --| PSE : ParseStackElement
    --|
    --| Only the lexed_token variant is currently fully displayed.
    --| The other variants would have to make use of an IDL
    --| writer.

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

end ParserDeclarations;

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

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--PDECLS.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

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

package body ParserDeclarations is

    subtype Dump_String_Range_Plus_Zero is
        STANDARD.NATURAL range 0 .. 4000;

    Dump_String        : string (1..Dump_String_Range_Plus_Zero'Last);

    Dump_String_Length : Dump_String_Range_Plus_Zero;
    -- must be set to zero before each use.

    ------------------------------------------------------------------
    -- Subprograms Local to Package ParserDeclarations
    ------------------------------------------------------------------

    procedure Append_To_Dump_String (   --| Add In_String to Dump_String
        In_String : in string           --| String to append
    );

    --| Effects

    --| This subprogram appends In_String to the package Body global
    --| Dump_String.

    --| Modifies
    --|
    --| Dump_String
    --| Dump_String_Length

    ------------------------------------------------------------------
    -- Subprogram Bodies Global to Package ParserDeclarations
    -- (declared in package specification).
    ------------------------------------------------------------------

    function Get_Source_Text(
        In_Source_Text : in Source_Text
    ) return string is

    begin

        if (In_Source_Text = Null_Source_Text) then
            return "" ;
        else
            return In_Source_Text.all ;
        end if;

    end Get_Source_Text;

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

    procedure Put_Source_Text(
        In_String          : in     string ;
        In_Out_Source_Text : in out Source_Text
    ) is

    begin

        In_Out_Source_Text := new string'(In_String);

    end Put_Source_Text;

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

    function Dump_Parse_Stack_Element(
        In_PSE : in ParseStackElement
    ) return string is

    --| Notes

    --| Abbreviations used in this compilation unit
    --|
    --| PSE : ParseStackElement
    --|

    begin

        Dump_String_Length := 0;

        -- Output data common to all ParseStackElements
        Append_To_Dump_String
            ("Element Kind:  "
            & PT.Get_Grammar_Symbol(In_PSE.gram_sym_val)
            & " "       -- give extra space to help highlight delimiters
            );

        -- Output data common to all lexed_tokens
        Append_To_Dump_String
            (" Token - Line: "
            & HD.Source_Line'IMAGE  (In_PSE.lexed_token.srcpos_line)
            &       " Column: "
            & HD.Source_Column'IMAGE(In_PSE.lexed_token.srcpos_column)
            );

        Append_To_Dump_String
            ( " Text: %"
            & Get_Source_Text(In_PSE.lexed_token.text)
        & "%"
            );


        -- Finally, finish up the message
        Append_To_Dump_String("");

        return Dump_String(1..Dump_String_Length);

    end Dump_Parse_Stack_Element;

    ------------------------------------------------------------------
    -- Subprogram Bodies Local to Package ParserDeclarations
    ------------------------------------------------------------------

    procedure Append_To_Dump_String(
        In_String : in string       --| String to append
    ) is

    begin

        Dump_String((Dump_String_Length + 1) ..
            (Dump_String_Length + In_String'Last)) := In_String;

        Dump_String_Length := Dump_String_Length + In_String'Length;

    end Append_To_Dump_String;

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

end ParserDeclarations;

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

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--LEX.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

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

with ParserDeclarations;        -- declarations for the Parser
with Host_Dependencies;         -- Host dependents constants

package Lex is                  --| perform lexical analysis

--| Overview
--|
--| This package is used to identify tokens in the source file and
--| return them to subprogram Parser.
--|
--| The useful reference is Chapter 2 of the Ada (Trade Mark) LRM.

--| Effects
--|
--| The subprograms in package Lex are used to sequentially read
--| a source file and identify lexical units (tokens) in the file.
--| Comments and error messages are saved for use by the lister.

    package HD renames Host_Dependencies;
    package PD renames ParserDeclarations;
    -- other package renames are in the package body

    ------------------------------------------------------------------
    -- Subprogram Declarations Global to Package Lex
    ------------------------------------------------------------------

    procedure Initialization;     --| Initializes the lexer

    --| Effects
    --|
    --| This subprogram initializes the lexer.

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

   function GetNextNonCommentToken  --| returns next non-comment token
                                    --| in source file.
       return PD.ParseStackElement;

    --| Effects
    --|
    --| This subprogram scans the source file for the next token not
    --| including comment tokens.

    --| Requires
    --|
    --| This subprogram requires an opened source file,
    --| and the state information internal to the package body.

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

    function GetNextSourceToken  --| returns next token in source file.
        return PD.ParseStackElement;

    --| Effects
    --|
    --| This subprogram scans the source file for the next token.
    --| The tokens returned include any comment literal tokens.

    --| Requires
    --|
    --| This subprogram requires an opened source file,
    --| and the state information internal to the package body.

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

    function Show_Current_Line
    return HD.Source_Line;

    --| Effects
    --|
    --| Returns the current line number being processed

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

    procedure Write_Line;

    --| Effects
    --|
    --| Write a line to an appropriate file

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

end Lex;

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

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--PARSESTK.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/parser/RCS/ParseStk.spc,v $
-- $Revision: 4.0 $ -- $Date: 85/02/19 11:33:03 $ -- $Author: carol $

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

with ParserDeclarations;        -- declarations for the Parser
use ParserDeclarations;

package ParseStack is           --| Elements awaiting parsing

--| Overview
--|
--| The ParseStack used by the parser.
--|
--| This data structure has the following sets of operations:
--|
--| 1) A set that add and delete elements.  This set can
--| raise the exceptions: UnderFlow and OverFlow.
--| The set includes:
--|
--|     Pop
--|     Push
--|     Reduce
--|
--| 2) A function that returns the number of elements in the
--| data structure. This set raises no exceptions.
--| The set includes:
--|
--|     Length

--|
--| Notes
--|
--|     Under some implementations the exception
--| ParserDeclarations.MemoryOverflow could be raised.
--|

    package PD renames ParserDeclarations;

    ------------------------------------------------------------------
    -- Declarations Global to Package ParseStack
    ------------------------------------------------------------------

    OverFlow  : exception;
        --| raised if no more space in stack.
    UnderFlow : exception;
        --| raised if no more elements in stack.

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

    procedure Push(         --| Adds new top element to stack
        Element: in PD.ParseStackElement); --| element to add

    --| Raises
    --|
    --| OverFlow - no more space in stack.

    --| Effects
    --|
    --| This subprogram adds an element to the top of the stack.
    --|

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

    function Pop                 --| Removes top element in stack
        return PD.ParseStackElement;

    --| Raises
    --|
    --| UnderFlow - no more elements in stack.

    --| Effects
    --|
    --| This subprogram obtains the element at the top of the stack.
    --|

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

    function Length                 --| Returns the number of
                                    --| elements in the stack
        return PD.StateParseStacksIndex;

    --| Effects
    --|
    --| This subprogram returns the number of elements in the stack.
    --|

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

    procedure Reduce(           --| Pops and discards top n elements on
                                --| the stack.
        TopN : in PD.StateParseStacksIndex);
        --| Number of elements to pop.

    --| Raises
    --|
    --| Underflow - no more elements in stack.

    --| Effects
    --|
    --| Pops and discards top N elements on the stack.
    --| If TopN is greater than the number of elements in the stack,
    --| Underflow is raised.
    --| This subprogram is used by the parser to reduce the stack during
    --| a reduce action.
    --| This stack reduction could be done with a for loop and
    --| the Pop subprogram at a considerable cost in execution time.
    --|

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

end ParseStack;

----------------------------------------------------------------------
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--STATESTK.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/parser/RCS/StateStk.spc,v $
-- $Revision: 4.0 $ -- $Date: 85/02/19 11:43:44 $ -- $Author: carol $

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

with ParserDeclarations;  -- declarations for the Parser
use ParserDeclarations;

package StateStack is     --| Elements awaiting parsing

--| Overview
--|
--| The StateStack used by the parser.
--|
--| This data structure has the following sets of operations:
--|
--| 1) A set that add and delete elements.
--| This set can raise the exceptions Underflow and Overflow.
--| The set includes:
--|
--|     Pop
--|     Push
--|     Reduce
--|
--| 2) A function that returns the number of elements in the
--| data structure.
--| This set raises no exceptions.
--| The set includes:
--|
--|     Length
--|
--| 3) A copy operations, to return the top of the stack.
--| The exception, UnderFlow,
--| is utilized to indicate the end of a sequential examination.
--| The set includes:
--|
--|     CopyTop
--|     InitCopy
--|     CopyNext

--| Notes
--|
--|     Under some implementations the exception
--| ParserDeclarations.MemoryOverflow could be raised.
--|

    ------------------------------------------------------------------
    -- Declarations Global to Package StateStack
    ------------------------------------------------------------------

    OverFlow  : exception;
    --| raised if no more space in stack.
    UnderFlow : exception;
    --| raised if no more elements in stack.

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

    procedure Push(                     --| Adds new top element to stack
        Element: in StateStackElement); --| element to add

    --|
    --| Raises
    --|
    --| OverFlow - no more space in stack.

    --| Effects
    --|
    --| This subprogram adds an element to the top of the stack.
    --|

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

    function Pop return StateStackElement;--| Removes top element in stack

    --| Raises
    --|
    --| UnderFlow - no more elements in stack.

    --| Effects
    --|
    --| This subprogram pops the element at the top of the stack.
    --|

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

    function CopyTop return StateStackElement;
    --| Copy top element in stack

    --| Raises
    --|
    --| UnderFlow - no more elements in stack.
    --|

    --| Effects
    --|
    --| Returns the top of the stack.

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

    function CopyNext return StateStackElement;
    --| Copy element after previous one copied

    --| Raises
    --|
    --| UnderFlow - no more elements in stack.

    --| Effects
    --|
    --| This subprogram is used in conjunction with
    --| CopyTop or Init Copy to sequentially examine the stack.
    --|

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

    function Length return StateParseStacksIndex;
   --| Returns the number of elements in the stack

    --| Effects
    --|
    --| This subprogram returns the number of elements in the stack.
    --|

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

    procedure InitCopy;           --| Initialize sequential examination of
                                  --| the data structure

    --| Effects
    --|
    --| Initializes the copy function,
    --| so that subsequent calls to CopyNext will sequentially examine
    --| the elements in the data structure.
    --|

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

    function CopyThisOne (  --| returns element given by parm 'which_one'
    which_one:  StateParseStacksRange) return StateStackElement;

    --| Overview
    --|
    --| Returns the state stack element indicated by the parameter
    --| 'which_one'.  This operation is needed by LocalStateStack
    --| because, in essence, the state stack is being copied in two
    --| nested loops and the Next_To_Copy counter can therefore only
    --| be used for one of the series of copies.

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

    procedure Reduce(           --| Pops and discards top n elements on
                                --| the stack.
    TopN : StateParseStacksIndex);    --| Number of elements to pop.

    --| Raises:
    --|
    --| Underflow - no more elements in stack.

    --| Effects
    --|
    --| Pops and discards TopN elements on the stack.
    --| If TopN is greater than the number of elements in the stack,
    --| Underflow is raised.
    --| This subprogram is used by the parser to reduce the stack during
    --| a reduce action.
    --| This stack reduction could be done with a for
    --| loop and the Pop subprogram at a considerable cost in execution
    --| time.
    --|

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

end StateStack;

----------------------------------------------------------------------
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--PARSE.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/parser/RCS/Parse.spc,v $
-- $Revision: 4.0 $ -- $Date: 85/02/19 11:48:41 $ -- $Author: carol $

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

with ParserDeclarations;        -- declarations for the Parser
use ParserDeclarations;

package Parser is

    --| Notes
    --|
    --| WARNING:
    --|
    --| Some of the code for this package is in the grammar source that is
    --| input to the parse table generator. One of the ouputs of the
    --| parse table generator is the source for the body of the procedure
    --| Apply_Actions used in this package. This procedure provides case
    --| statements to select the number of the rule to be used.
    --| This procedure is declared as separate subunits in the
    --| body of this package. It is strongly recommended that
    --| the code of these functions be kept integrated with the grammar
    --| for the following reasons.
    --|
    --| 1) to keep the case select numbers consistent with the reduce
    --| action numbers in the parse tables.
    --|
    --| 2) to associate each grammar rule with the code for its actions.
    --|

    package PD renames ParserDeclarations;

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

    procedure Apply_Actions(
        Rule_Number : in PT.LeftHandSideRange);

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

    function Parse                  --| NYU LALR style parser
        return PD.ParseStackElement;

    --| Raises
    --|
    --| ParserDeclarations.MemoryOverflow
    --|

    --| Effects
    --|
    --| This parser takes input from a Lexer and parses it according
    --| to a set of grammar rules that have been converted into a set of
    --| ParseTables by the NYU LALR Parser Generator.

    --| Requires
    --|
    --| The parser expects the Lexer and other units it uses to be
    --| initialized.
    --|
    --| The units that stay the same for different grammars are:
    --|
    --| Parser.Parse (this subprogram)
    --| ParseStack
    --|
    --| The units that need to be changed for different grammars are:
    --|
    --| Parser.Apply_Actions
    --| Lex
    --| ParserDeclarations
    --| ParseTables
    --|

    --| Modifies
    --|
    --| The following are modified:
    --|
    --| ParseStack
    --|

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

end Parser;

----------------------------------------------------------------------
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--PARSE.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/parser/RCS/Parse.bdy,v $
-- $Revision: 4.0 $ -- $Date: 85/02/19 12:00:03 $ -- $Author: carol $

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

with Lex;                       -- the lexical analyzer
with ParseStack;                -- elements awaiting parsing
with StateStack;                -- stack of parse states
with ParseTables;               -- state tables generated by parser
                                -- generator
use ParseTables;

with Grammar_Constants;         -- constants generated by parser generator
use Grammar_Constants;

package body Parser is

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

    procedure Apply_Actions(
        Rule_Number : in PT.LeftHandSideRange) is separate;

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

    function Parse return PD.ParseStackElement is

    --| Overview
    --|
    --| The appropriate reference is:
    --|
    --| Using the NYU LALR Parser Generator. Philippe Charles and
    --| Gerald Fisher. Courant Institute, New York University, 251 Mercer
    --| Street, New York, N.Y.  10012. Unpublished paper. 1981.
    --|

    --|
    --| Notes
    --|
    --| Abbreviations Used:
    --|
    --| Cur : Current - used as prefix
    --| LH  : LeftHand
    --| RH  : RightHand
    --|

    ------------------------------------------------------------------
    -- Reduce Action Work Variables
    ------------------------------------------------------------------

    Reduce_Action_Number   : PT.LeftHandSideRange;
        --| reduction to perform

    Reduce_Action_LH_Value : GrammarSymbolRange;
        --| grammar symbol number of left hand side of reduction

    Reduce_Action_RH_Size  : PD.StateParseStacksIndex;
        --| number of elements in right hand side of reduction

    ------------------------------------------------------------------
    -- Other Objects
    ------------------------------------------------------------------

    Current_Action      : ActionRange;
        --| return from PT.GetAction.

    Start_State         : constant := 1;
        --| Start state for parser.

    Last_Element_Popped : PD.ParseStackElement;
        --| Last element popped from parse stack

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

    begin

    --|
    --| Algorithm
    --|
    --| Function PT.GetAction returns an action value,
    --| which indicate one of four possible actions:
    --|
    --| Error:  action value = 0.
    --| Shift:  0 < action value < StateCountPlusOne.
    --| Accept: action value = StateCountPlusOne.
    --| Reduce: action value > StateCountPlusOne.
    --|
    --| The action is processed (as described below).
    --| This is repeated until no more tokens are obtained.
    --|
    --| The basic action processing is:
    --|
    --| SHIFT ACTION: the next token is placed on the ParseStack.
    --|
    --| REDUCE ACTION: the handle (a grammar rule's right hand side)
    --| found on the ParseStack is replaced with a
    --| non-terminal (grammar rule's left hand side) to which
    --| it has been reduced, and a new state.
    --|
    --| ACCEPT ACTION: the ParseStack contains the root
    --| of the parse tree, and processing is finished for
    --| If another compilation unit is present, parsing continues.
    --|
    --| ERROR ACTION: the exception Parser_Error is raised.

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

        -- Initialize Lexical Analyzer
        Lex.Initialization;

        PD.CurToken := Lex.GetNextNonCommentToken;

        StateStack.Push(Start_State);

        Do_Parse: loop

            Current_Action := PT.GetAction(
                StateStack.CopyTop,
                PD.CurToken.gram_sym_val);

            -- Accept action
            exit when (Current_Action in PD.Accept_Action_Range);

            if Current_Action in PD.Shift_Action_Range then

                -- Shift token from CurToken to ParseStack.
                ParseStack.Push(PD.CurToken);

                -- Add new state to top of StateStack
                StateStack.Push(Current_Action);

                -- Get next token.
                PD.CurToken := Lex.GetNextNonCommentToken;

            elsif Current_Action in PD.Reduce_Action_Range then

                Reduce_Action_Number := Current_Action -
                    StateCountPlusOne;

                Reduce_Action_LH_Value  :=
                    PT.Get_LeftHandSide(Reduce_Action_Number);

                Reduce_Action_RH_Size :=
                    PT.Get_RightHandSide(Reduce_Action_Number);

                -- Reduce Parse Stack
                ParseStack.Reduce(Reduce_Action_RH_Size);

                ParseStack.Push((
                    gram_sym_val => Reduce_Action_LH_Value,
                    lexed_token => (
                        text => PD.Null_Source_Text,
                        srcpos_line => 0,
                        srcpos_column => 0)));

                -- Reduce State Stack
                StateStack.Reduce(Reduce_Action_RH_Size);

                StateStack.Push(PT.GetAction(
                    StateStack.CopyTop,
                    Reduce_Action_LH_Value));

                Apply_Actions(Reduce_Action_Number);

                else -- Current_Action is in PD.Error_Action_Range
                    raise PD.Parser_Error;
            end if;
        end loop Do_Parse;
        return ParseStack.Pop;

    exception
        when PD.MemoryOverflow =>
            -- raised if Parse runs out of newable memory.
            raise PD.MemoryOverflow;

    end Parse;

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

end Parser;

----------------------------------------------------------------------
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--PARSESTK.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/parser/RCS/ParseStk.bdy,v $
-- $Revision: 4.0 $ -- $Date: 85/02/19 11:34:13 $ -- $Author: carol $

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

with ParseTables;               -- state tables generated by parser
                                --     generator
use ParseTables;

with Grammar_Constants;
use Grammar_Constants;          -- to have visibility on operations
                                -- on type ParserInteger declared there.
package body ParseStack is

--| Overview
--|
--| The data structure is implemented as an array.
--|

    ------------------------------------------------------------------
    -- Declarations Global to Package Body ParseStack
    ------------------------------------------------------------------

    Index       : PD.StateParseStacksIndex := 0;
        --| top element in stack.

    Space : array (PD.StateParseStacksRange) of PD.ParseStackElement;
        --| Storage used to hold stack elements

    ------------------------------------------------------------------
    -- Subprogram Bodies Global to Package ParseStack
        -- (declared in package specification).
    ------------------------------------------------------------------

    procedure Push(Element : in PD.ParseStackElement) is

    begin

        if (Index >= PD.StateParseStacksRange'Last) then
            raise OverFlow;
        end if;

        Index := Index + 1;
        Space (Index) := Element;

    end Push;

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

    function Pop return PD.ParseStackElement is

    begin

        if (Index < PD.StateParseStacksRange'First) then
            raise UnderFlow;
        end if;

        Index := Index - 1;
        return Space (Index + 1);

    end Pop;

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

    function Length return PD.StateParseStacksIndex is

    begin

        return Index;

    end Length;

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

    procedure Reduce(TopN : in PD.StateParseStacksIndex) is

    begin
        if (TopN > Index) then
            raise UnderFlow;
        end if;

        Index := Index - TopN;

    end Reduce; -- procedure

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

end ParseStack;

----------------------------------------------------------------------
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--STATESTK.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/parser/RCS/StateStk.bdy,v $
-- $Revision: 4.0 $ -- $Date: 85/02/19 11:45:59 $ -- $Author: carol $

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

with ParseTables;               -- state tables generated
                                -- by parser generator
use ParseTables;
with Grammar_Constants;         -- constants generated by parser generator
use Grammar_Constants;          -- to have visiblity on operations
                                -- on type ParserInteger.

package body StateStack is

--| Overview
--|
--| The data structure is implemented as an array.
--|

--| Notes
--|
--| Abbreviations used in this compilation unit:
--|
--| Init : used as prefix for Initialize
--|

    ------------------------------------------------------------------
    -- Declarations Global to Package Body StateStack
    ------------------------------------------------------------------

    Index        : StateParseStacksIndex := 0;
    --| top element in stack.
    Next_To_Copy : StateParseStacksIndex := 0;
    --| next element to copy in stack.

    Space : array (StateParseStacksRange) of StateStackElement;
    --| Storage used to hold stack elements


    ------------------------------------------------------------------
    -- Subprogram Bodies Global to Package StateStack
        -- (declared in package specification).
    ------------------------------------------------------------------

    procedure Push(Element: in StateStackElement) is

    begin

        if (Index >= StateParseStacksRange'Last) then
            raise OverFlow;
        end if;

        Index := Index + 1;
        Space (Index) := Element;

    end Push;

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

    function Pop return StateStackElement is

    begin

        if (Index < StateParseStacksRange'First) then
            raise UnderFlow;
        end if;

       Index := Index - 1;
       return Space (Index + 1);

    end Pop;

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

    function CopyTop return StateStackElement is

    begin

        InitCopy;
        return CopyNext;

    end CopyTop;

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

    function CopyNext return StateStackElement is

    begin

        Next_To_Copy := Next_To_Copy - 1;

        if (Next_To_Copy < StateParseStacksRange'First) then
            raise UnderFlow;
        end if;

        return Space (Next_To_Copy);

    end CopyNext;

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

    function Length return StateParseStacksIndex is

    begin

        return Index;

    end Length;

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

    procedure InitCopy is

    begin

        Next_To_Copy := Index + 1;  -- start examination here

    end InitCopy;

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

    function CopyThisOne (    --| returns the which_oneth element
        which_one:   StateParseStacksRange) return StateStackElement is

    begin

        if which_one > Index then
            raise OverFlow;
        end if;

        return (Space (which_one));

    end CopyThisOne;

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

    procedure Reduce (TopN : StateParseStacksIndex) is

    begin

        if (TopN > Index) then
            raise UnderFlow;
        end if;

        Index := Index - TopN;

    end Reduce;

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

end StateStack;

----------------------------------------------------------------------
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--PGFILE.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with Text_IO;
with String_Pkg;

package Paginated_Output is

--| Create paginated text files with user defined heading,
--| footing, and page length.
                                                    pragma Page;
--| Overview:

--| The Paginated_Output package is used to create paginated
--| output files.  When such a file is created, the page length,
--| page header and footer length are specified. Several
--| operations are provided for setting/replacing the header or
--| the footer text which will appear on each output page.
--| The following escapes can be used in the header/footer texts:
--|-
--|     ~f    the current external file name
--|     ~p    the current page number
--|     ~d    the current date (eg. 03/15/85)
--|     ~c    the current calendar date (eg. March 15, 1985)
--|     ~t    the current time (eg. 04:53:32)
--|+
--| Case is not significant after the tilde (~).  If the tilde
--| is followed by any other character, only the second character
--| is printed unless the line ends with a tilde in which case
--| the line will be terminated one character before the tilde.
--|
--| The header is printed just before the first line of a page
--| is output, and the footer is printed just after the last line.
--| Thus, if a paginated file is opened and closed without any calls
--| to print a line in between, the output is a null file.
--|
--| This package knows nothing about (and places no limits on)
--| the length or contents of each line sent to the output file.
--| In particular, if the line contains ASCII control codes
--| for new line, form feed, and/or vertical tab the output file
--| will not be properly paginated.  Normal usage is to call
--| Create_Paginated_File, call Set_Header/Set_Footer, call Put_Line
--| repeatedly to output a sequence of lines of text, and finally
--| call Close_Paginated_File to complete the last page and close
--| the file.

--| N/A: Effects, Requires, Modifies, Raises
                                                    pragma Page;
            -- Exceptions --

Files_Already_Linked        --| Raised if an attempt is made to
          : exception;    --| link two linked paginated files
File_Already_Open : exception;    --| Raised if create is attempted
                --| for an already existing file.
File_Error        : exception;    --| Raised if unable to open a file
                --| other than File_Already_Open
File_Not_Open     : exception;    --| Raised if close is attempted
                --| for an unopened file.
Invalid_Count     : exception;    --| Raised if a requested count
                --| can not be serviced.
Invalid_File      : exception;    --| Raised if output is attempted
                --| with an invalid file handle.
Output_Error      : exception;    --| Raised if error is encountered
                --| during an output operation.
Page_Layout_Error : exception;    --| Raised if page specification
                --| is invalid.
Page_Overflow     : exception;    --| Raised if specified reserve
                --| value exceeds the page size.
Text_Overflow     : exception;    --| Raised if header/footer text
                --| overflows area.
Text_Underflow    : exception;    --| Raised if header/footer text
                --| underflows area.
                                                    pragma Page;
               -- Types --

subtype Host_File_Name is string;
                --| String of valid characters for
                --| external file name.

type Variable_String_Array is    --| Array of variable length strings
    array (positive range <>) of String_Pkg.String_Type;

type Paginated_File_Handle is    --| Handle to be passed around in a
    limited private;        --| program that uses paginated output.

type Paginated_Output_Mode is (OUTPUT, ERROR);
                --| Paginated output mode
                                                    pragma Page;
            -- Operations --

procedure Create_Paginated_File(--| Create a paginated output file
                --| and return the file handle.
    File_Name   : in Host_File_Name   := "";
                --| The name of the file to be created.
    File_Handle : in out Paginated_File_Handle;
                --| Handle to be used for subsequent
                --| operations
    Page_Size   : in integer          := 66;
                --| The number of lines per page
    Header_Size : in integer          := 6;
                --| The number of header text lines
    Footer_Size : in integer          := 6;
                --| The number of footer text lines
    Output_Mode : in Paginated_Output_Mode := OUTPUT
                --| Output mode
    );

--| Raises:
--| File_Already_Open, File_Error, Page_Layout_Error

--| Requires:
--| File_Name is an valid external name of the file to be created (If
--| it is omitted, the current output file is selected).  Page_Size,
--| Header_Size, and Footer_Size are optional values (if omitted 66,
--| 6, and 6 are set, respectively) to be used for the page layout
--| of the file to be created.  Page_Size specifies the total number
--| of lines per page (including the areas for header and footer).
--| Header_Size and Footer_Size specify the number of lines to be
--| reserved for the header and footer areas, respectively.

--| Effects:
--| Creates a new paginated file with Page_Size number of lines
--| per page and Header_Size and Footer_Size number of lines
--| reserved for header and footer, respectively.  Access to the
--| paginated file control structure Paginated_File_Handle is
--| returned for use in subsequent operations.

--| Errors:
--| If any of the page layout values are negative, the exception
--| Page_Layout_Error is raised.  Also if the total number of lines
--| in the header and footer plus one exceeds Page_Size, the same
--| exception is raised.  This guarantees that at least one line of
--| text can appear on each output page.
--| If the output file with the specified File_Name is already open
--| File_Already_Open exception is raised.
--| If the file cannot be opened for any other reason, the exception
--| File_Error is raise.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Standard_Paginated_File(
                --| Set the standard paginated output file
                --| characteristics.
    File_Name   : in Host_File_Name;
                --| The name of the file to be set.
    Page_Size   : in integer;    --| The number of lines per page
    Header_Size : in integer;    --| The number of header text lines
    Footer_Size : in integer    --| The number of footer text lines
    );

--| Raises:
--| File_Already_Open, File_Error, Page_Layout_Error

--| Requires:
--| File_Name is an valid external name of the file to be created
--| Page_Size, Header_Size, and Footer_Size are used for the page layout
--| of the file.

--| Effects:
--| Sets the standard paginated file to the given file name and sets the
--| page layout as specified.

--| Errors:
--| If any of the page layout values are negative, the exception
--| Page_Layout_Error is raised.  Also if the total number of lines
--| in the header and footer plus one exceeds Page_Size, the same
--| exception is raised.  This guarantees that at least one line of
--| text can appear on each output page.
--| If the output file with the specified File_Name is already open
--| File_Already_Open exception is raised.
--| If the file cannot be opened for any other reason, the exception
--| File_Error is raise.

--| N/A: Modifies
                                                    pragma Page;
procedure Duplicate_Paginated_File(
                --| Duplicate an already existing
                --| paginated file and return the
                --| file handle.
    Old_Handle : in Paginated_File_Handle;
                --| Existing paginated file handle
    New_Handle : in out Paginated_File_Handle
                --| Handle of the new paginated file
    );

--| Requires:
--| Old_Handle for the existing paginated file to be duplicated.
--| The new handle (duplocated from Old_Handle) to be used to refer
--| to the same paginated file.

--| Effects:
--| Handle for the aginated file refered to be Old_Handle will be
--| duplicated in New_Handle.

--| N/A: Raises, Modifies, Errors
                                                    pragma Page;
procedure Set_Page_Layout(    --| Set the page layout for the
                --| paginated file.
    Page_Size   : in integer;    --| The number of lines per page
    Header_Size : in integer;    --| The number of header text lines
    Footer_Size : in integer    --| The number of footer text lines
    );

--| Raises:
--| Page_Layout_Error

--| Requires:
--| Page_Size specifies the total number of lines per page (including the
--| area for header & footer).
--| Header_Size and Footer_Size specifies the number of lines to be
--| reserved for the header and footer area, respectively.

--| Effects:
--| A paginated file is set with Page_Size number of lines per
--| page and Header_Size and Footer_Size number of lines
--| reserved for header and footer, respectively.
--| A page eject is performed if not at the top of the page before
--| the new page layout values are set.

--| Errors:
--| If any of the page layout values are negative, the exception
--| Page_Layout_Error is raised.  Also if the total number of lines
--| in the header and footer plus one exceeds Page_Size, the exception
--| Page_Layout_Error is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Page_Layout(    --| Set the page layout for the
                --| paginated file.
    File_Handle : in Paginated_File_Handle;
                --| The paginated file to be set
                --| with the given page layout
    Page_Size   : in integer;    --| The number of lines per page
    Header_Size : in integer;    --| The number of header text lines
    Footer_Size : in integer    --| The number of footer text lines
    );

--| Raises:
--| Page_Layout_Error

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Page_Size specifies the total
--| number of lines per page (including the area for header & footer).
--| Header_Size and Footer_Size specifies the number of lines to be
--| reserved for the header and footer area, respectively.

--| Effects:
--| A paginated file is set with Page_Size number of lines per
--| page and Header_Size and Footer_Size number of lines
--| reserved for header and footer, respectively.
--| A page eject is performed if not at the top of the page before
--| the new page layout values are set.

--| Errors:
--| If any of the page layout values are negative, the exception
--| Page_Layout_Error is raised.  Also if the total number of lines
--| in the header and footer plus one exceeds Page_Size, the exception
--| Page_Layout_Error is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Link_Paginated_File(    --| Link paginated files into a chain
    File_Handle1 : in Paginated_File_Handle;
                --| Handle to be linked
    File_Handle2 : in Paginated_File_Handle
                --| Handle to be linked
    );

--| Raises:
--| Files_Already_Linked

--| Requires:
--| File_Handle1 and File_Handle2, access to the paginated file control
--| structures.

--| Effects:
--| File_Handle1 and File_Handle2 in a chain so in the given order such that
--| subsequent operations to File_Handle1 are reflected in both files.
--| Any operations to File_Handle2 are NOT performed for File_Handle1.

--| Errors:
--| If either of the files have been linked, raises Files_Already_Linked.

--| N/A: Modifies
                                                    pragma Page;
procedure Unlink_Paginated_File(
    File_Handle : in Paginated_File_Handle
    );

--| Requires:
--| File_Handle which accesses a paginated file control structure.

--| Effects:
--| Takes File_Handle out of a previously linked chain.

--| N/A: Raises, Modifies, Errors
                                                    pragma Page;
procedure Set_Header(
    Header_Text : in Variable_String_Array
    );

procedure Set_Header(        --| Set the header text on a paginated
                --| output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the header text
    Header_Text : in Variable_String_Array
                --| Sequence of header lines
    );

--| Raises:
--| Invalid_File, Text_Overflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Header_Text is the array
--| of text to be used for the page header.

--| Effects:
--| The header text of File_Handle is set to Header_Text.  Note that
--| the replaced header text will not be printed until the next
--| page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of a header text array which implies a greater
--| number of lines than reserved for by Create_Paginated_File or
--| Set_Page_Layout results in Text_Overflow exception to be raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Header(
    Header_Line : in integer;
    Header_Text : in string
    );

procedure Set_Header(        --| Replace a line of header text on a
                --| paginated output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the header text
    Header_Line : in integer;    --| Line number of header to be replaced
    Header_Text : in string    --| Header line to replace
    );

--| Raises:
--| Invalid_File, Text_Overflow, Text_Underflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Header_Text is the text
--| to replace the existing header line at Header_Line.

--| Effects:
--| The header text of File_Handle at Header_Line is set to Header_Text.
--| Note that the replaced header text will not be printed until
--| the next page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Header_Line greater than the number of header
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| If the specified Header_Line is less than or equal to 0 then
--| Text_Underflow exception is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Header(
    Header_Line : in integer;
    Header_Text : in String_Pkg.String_Type
    );

procedure Set_Header(        --| Replace a line of header text on a
                --| paginated output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the header text
    Header_Line : in integer;    --| Line number of header to be replaced
    Header_Text : in String_Pkg.String_Type
                --| Header line to replace
    );

--| Raises:
--| Invalid_File, Text_Overflow, Text_Underflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Header_Text is the text
--| to replace the existing header line at Header_Line.

--| Effects:
--| The header text of File_Handle at Header_Line is set to Header_Text.
--| Note that the replaced header text will not be printed until
--| the next page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Header_Line greater than the number of header
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| If the specified Header_Line is less than or equal to 0 then
--| Text_Underflow exception is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Odd_Header(
    Header_Text : in Variable_String_Array
    );

procedure Set_Odd_Header(    --| Set the header text for the odd
                --| pages of a paginated output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the header text
    Header_Text : in Variable_String_Array
                --| Sequence of header lines
    );

--| Raises:
--| Invalid_File, Text_Overflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Header_Text is the array
--| of text to be used for the odd page header.

--| Effects:
--| The header text for odd pages of File_Handle is set to Header_Text.
--| Note that the replaced header text will not be printed until
--| the next odd page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of a header text array which implies a greater
--| number of lines than reserved for by Create_Paginated_File or
--| Set_Page_Layout results in Text_Overflow exception to be raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Odd_Header(
    Header_Line : in integer;
    Header_Text : in string
    );

procedure Set_Odd_Header(    --| Replace a line of header text on
                --| the odd pages of a paginated
                --| output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the header text
    Header_Line : in integer;    --| Line number of header to be replaced
    Header_Text : in string    --| Header line to replace
    );

--| Raises:
--| Invalid_File, Text_Overflow, Text_Underflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Header_Text is the text
--| to replace the existing odd page header line at Header_Line.

--| Effects:
--| The odd page header text of File_Handle at Header_Line is set
--| to Header_Text.  Note that the replaced header text will not be
--| printed until the next odd page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Header_Line greater than the number of header
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| If the specified Header_Line is less than or equal to 0 then
--| Text_Underflow exception is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Odd_Header(
    Header_Line : in integer;
    Header_Text : in String_Pkg.String_Type
    );

procedure Set_Odd_Header(    --| Replace a line of header text on
                --| the odd pages of a paginated
                --| output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the header text
    Header_Line : in integer;    --| Line number of header to be replaced
    Header_Text : in String_Pkg.String_Type
                --| Header line to replace
    );

--| Raises:
--| Invalid_File, Text_Overflow, Text_Underflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Header_Text is the text
--| to replace the existing odd page header line at Header_Line.

--| Effects:
--| The odd page header text of File_Handle at Header_Line is set
--| to Header_Text.  Note that the replaced header text will not be
--| printed until the next odd page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Header_Line greater than the number of header
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| If the specified Header_Line is less than or equal to 0 then
--| Text_Underflow exception is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Even_Header(
    Header_Text : in Variable_String_Array
    );

procedure Set_Even_Header(    --| Set the header text for the even
                --| pages of a paginated output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the header text
    Header_Text : in Variable_String_Array
                --| Sequence of header lines
    );

--| Raises:
--| Invalid_File, Text_Overflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Header_Text is the array
--| of text to be used for the even page header.

--| Effects:
--| The header text for even pages of File_Handle is set to Header_Text.
--| Note that the replaced header text will not be printed until
--| the next even page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of a header text array which implies a greater
--| number of lines than reserved for by Create_Paginated_File or
--| Set_Page_Layout results in Text_Overflow exception to be raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Even_Header(
    Header_Line : in integer;
    Header_Text : in string
    );

procedure Set_Even_Header(    --| Replace a line of header text on
                --| the even pages of a paginated
                --| output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the header text
    Header_Line : in integer;    --| Line number of header to be replaced
    Header_Text : in string    --| Header line to replace
    );

--| Raises:
--| Invalid_File, Text_Overflow, Text_Underflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Header_Text is the text
--| to replace the existing even page header line at Header_Line.

--| Effects:
--| The even page header text of File_Handle at Header_Line is set
--| to Header_Text.  Note that the replaced header text will not be
--| printed until the next even page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Header_Line greater than the number of header
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| If the specified Header_Line is less than or equal to 0 then
--| Text_Underflow exception is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Even_Header(
    Header_Line : in integer;
    Header_Text : in String_Pkg.String_Type
    );

procedure Set_Even_Header(    --| Replace a line of header text on
                --| the even pages of a paginated
                --| output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the header text
    Header_Line : in integer;    --| Line number of header to be replaced
    Header_Text : in String_Pkg.String_Type
                --| Header line to replace
    );

--| Raises:
--| Invalid_File, Text_Overflow, Text_Underflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Header_Text is the text
--| to replace the existing even page header line at Header_Line.

--| Effects:
--| The even page header text of File_Handle at Header_Line is set
--| to Header_Text.  Note that the replaced header text will not be
--| printed until the next even page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Header_Line greater than the number of header
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| If the specified Header_Line is less than or equal to 0 then
--| Text_Underflow exception is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Footer(
    Footer_Text : in Variable_String_Array
    );

procedure Set_Footer(        --| Set the footer text on a paginated
                --| output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the footer text
    Footer_Text : in Variable_String_Array
                --| Sequence of lines for the footer
    );

--| Raises:
--| Invalid_File, Text_Overflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Footer_Text is the array
--| of text to be used for the page footer.

--| Effects:
--| The footer text of File_Handle is set to Footer_Text.  Note that
--| the replaced footer text will not be printed until the next
--| page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of a footer text array which implies a greater
--| number of lines than reserved for by Create_Paginated_File or
--| Set_Page_Layout results in Text_Overflow exception to be raised.
--| If the specified Footer_Line is less than or equal to 0 then
--| Text_Underflow exception is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Footer(
    Footer_Line : in integer;
    Footer_Text : in string
    );

procedure Set_Footer(        --| Replace a line of header text on a
                --| paginated output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the footer text
    Footer_Line : in integer;    --| Line number of footer to be replaced
    Footer_Text : in string    --| Footer line to replace
    );

--| Raises:
--| Invalid_File, Text_Overflow, Text_Underflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Footer_Text is the text
--| to replace the existing footer line at Footer_Line.

--| Effects:
--| The footer text of File_Handle at Footer_Line is set to Header_Text.
--| Note that the replaced footer text will not be printed until
--| the next page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Footer_Line greater than the number of footer
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| If the specified Footer_Line is less than or equal to 0 then
--| Text_Underflow exception is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Footer(
    Footer_Line : in integer;
    Footer_Text : in String_Pkg.String_Type
    );

procedure Set_Footer(        --| Replace a line of footer text on a
                --| paginated output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the footer text
    Footer_Line : in integer;    --| Line number of footer to be replaced
    Footer_Text : in String_Pkg.String_Type
                --| Footer line to replace
    );

--| Raises:
--| Invalid_File, Text_Overflow, Text_Underflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Footer_Text is the text
--| to replace the existing footer line at Footer_Line.

--| Effects:
--| The footer text of File_Handle at Footer_Line is set to Header_Text.
--| Note that the replaced footer text will not be printed until
--| the next page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Footer_Line greater than the number of footer
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| If the specified Footer_Line is less than or equal to 0 then
--| Text_Underflow exception is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Odd_Footer(
    Footer_Text : in Variable_String_Array
    );

procedure Set_Odd_Footer(    --| Set the footer text for the odd
                --| pages of a paginated output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the footer text
    Footer_Text : in Variable_String_Array
                --| Sequence of lines for the footer
    );

--| Raises:
--| Invalid_File, Text_Overflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Footer_Text is the array
--| of text to be used for the odd page footer.

--| Effects:
--| The footer text for odd pages of File_Handle is set to Footer_Text.
--| Note that the replaced footer text will not be printed until
--| the next odd page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of a footer text array which implies a greater
--| number of lines than reserved for by Create_Paginated_File or
--| Set_Page_Layout results in Text_Overflow exception to be raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Odd_Footer(
    Footer_Line : in integer;
    Footer_Text : in string
    );

procedure Set_Odd_Footer(    --| Replace a line of footer text on
                --| the odd pages of a paginated
                --| output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the footer text
    Footer_Line : in integer;    --| Line number of footer to be replaced
    Footer_Text : in string    --| Footer line to replace
    );

--| Raises:
--| Invalid_File, Text_Overflow, Text_Underflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Footer_Text is the text
--| to replace the existing odd page footer line at Footer_Line.

--| Effects:
--| The odd page footer text of File_Handle at Footer_Line is set
--| to Footer_Text.  Note that the replaced footer text will not be
--| printed until the next odd page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Footer_Line greater than the number of footer
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| If the specified Footer_Line is less than or equal to 0 then
--| Text_Underflow exception is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Odd_Footer(
    Footer_Line : in integer;
    Footer_Text : in String_Pkg.String_Type
    );

procedure Set_Odd_Footer(    --| Replace a line of footer text on
                --| the odd pages of a paginated
                --| output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the footer text
    Footer_Line : in integer;    --| Line number of footer to be replaced
    Footer_Text : in String_Pkg.String_Type
                --| Footer line to replace
    );

--| Raises:
--| Invalid_File, Text_Overflow, Text_Underflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Footer_Text is the text
--| to replace the existing odd page footer line at Footer_Line.

--| Effects:
--| The odd page footer text of File_Handle at Footer_Line is set
--| to Footer_Text.  Note that the replaced footer text will not be
--| printed until the next odd page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Footer_Line greater than the number of footer
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| If the specified Footer_Line is less than or equal to 0 then
--| Text_Underflow exception is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Even_Footer(
    Footer_Text : in Variable_String_Array
    );

procedure Set_Even_Footer(    --| Set the footer text for the even
                --| pages of a paginated output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the footer text
    Footer_Text : in Variable_String_Array
                --| Sequence of lines for the footer
    );

--| Raises:
--| Invalid_File, Text_Overflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Footer_Text is the array
--| of text to be used for the even page footer.

--| Effects:
--| The footer text for even pages of File_Handle is set to Footer_Text.
--| Note that the replaced footer text will not be printed until
--| the next even page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of a footer text array which implies a greater
--| number of lines than reserved for by Create_Paginated_File or
--| Set_Page_Layout results in Text_Overflow exception to be raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Even_Footer(
    Footer_Line : in integer;
    Footer_Text : in string
    );

procedure Set_Even_Footer(    --| Replace a line of footer text on
                --| the even pages of a paginated
                --| output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the footer text
    Footer_Line : in integer;    --| Line number of footer to be replaced
    Footer_Text : in string    --| Footer line to replace
    );

--| Raises:
--| Invalid_File, Text_Overflow, Text_Underflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Footer_Text is the text
--| to replace the existing even page footer line at Footer_Line.

--| Effects:
--| The even page footer text of File_Handle at Footer_Line is set
--| to Footer_Text.  Note that the replaced footer text will not be
--| printed until the next even page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Footer_Line greater than the number of footer
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| If the specified Footer_Line is less than or equal to 0 then
--| Text_Underflow exception is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Set_Even_Footer(
    Footer_Line : in integer;
    Footer_Text : in String_Pkg.String_Type
    );

procedure Set_Even_Footer(    --| Replace a line of footer text on
                --| the even pages of a paginated
                --| output file.
    File_Handle : in Paginated_File_Handle;
                --| Paginated file to be set
                --| with the footer text
    Footer_Line : in integer;    --| Line number of footer to be replaced
    Footer_Text : in String_Pkg.String_Type
                --| Footer line to replace
    );

--| Raises:
--| Invalid_File, Text_Overflow, Text_Underflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Footer_Text is the text
--| to replace the existing even page footer line at Footer_Line.

--| Effects:
--| The even page footer text of File_Handle at Footer_Line is set
--| to Footer_Text.  Note that the replaced footer text will not be
--| printed until the next even page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.
--| Specification of Footer_Line greater than the number of footer
--| lines reserved by Create_Paginated_File or Set_Page_Layout
--| results in Text_Overflow exception to be raised.
--| If the specified Footer_Line is less than or equal to 0 then
--| Text_Underflow exception is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Clear_Header;

procedure Clear_Header(        --| Set the header text on a paginated
                --| output file to null lines
    File_Handle : in Paginated_File_Handle
                --| Paginated file to be set
                --| with the header text
    );

--| Raises:
--| Invalid_File

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.

--| Effects:
--| The header text of File_Handle is cleared to null lines.
--| The replaced null header will not be printed until the next
--| page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Clear_Odd_Header;

procedure Clear_Odd_Header(    --| Set the header text for the odd
                --| pages to null lines
    File_Handle : in Paginated_File_Handle
                --| Paginated file to be set
                --| with the header text
    );

--| Raises:
--| Invalid_File, Text_Overflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.

--| Effects:
--| The header text for odd pages of File_Handle is cleared to null.
--| Note that the replaced null header text will not be printed until
--| the next odd page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Clear_Even_Header;

procedure Clear_Even_Header(    --| Set the header text for the even
                --| pages to null lines
    File_Handle : in Paginated_File_Handle
                --| Paginated file to be set
                --| with the header text
    );

--| Raises:
--| Invalid_File, Text_Overflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.

--| Effects:
--| The header text for even pages of File_Handle is cleared to null.
--| Note that the replaced null header text will not be printed until
--| the next even page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Clear_Footer;

procedure Clear_Footer(        --| Set the footer text on a paginated
                --| output file to null lines
    File_Handle : in Paginated_File_Handle
                --| Paginated file to be set
                --| with the footer text
    );

--| Raises:
--| Invalid_File

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.

--| Effects:
--| The footer text of File_Handle is cleared to null lines.
--| The replaced null footer will not be printed until the next
--| page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Clear_Odd_Footer;

procedure Clear_Odd_Footer(    --| Set the footer text for the odd
                --| pages to null lines
    File_Handle : in Paginated_File_Handle
                --| Paginated file to be set
                --| with the footer text
    );

--| Raises:
--| Invalid_File, Text_Overflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.

--| Effects:
--| The footer text for odd pages of File_Handle is cleared to null.
--| Note that the replaced null footer text will not be printed until
--| the next odd page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Clear_Even_Footer;

procedure Clear_Even_Footer(    --| Set the footer text for the even
                --| pages to null lines
    File_Handle : in Paginated_File_Handle
                --| Paginated file to be set
                --| with the footer text
    );

--| Raises:
--| Invalid_File, Text_Overflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.

--| Effects:
--| The footer text for even pages of File_Handle is cleared to null.
--| Note that the replaced null footer text will not be printed until
--| the next even page of the output.

--| Errors:
--| If File_Handle is not a valid access to a paginated file control
--| structure exception Invalid_File is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Close_Paginated_File;
                                                    pragma Page;
procedure Close_Paginated_File(    --| Complete the last page and close
                --| the paginated file.
    File_Handle : in out Paginated_File_Handle
                --| The paginated file to be closed
    );

--| Raises:
--| Invalid_File, File_Not_Open

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.

--| Effects:
--| Completes the last page of output and closes the output file.

--| Errors:
--| If File_Handle is not a valid Paginated_File_Handle, the exception
--| Invalid_File is raised.  If an error occurs in closing the file,
--| File_Not_Open is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Put(
    Text        : in Variable_String_Array
    );

procedure Put(            --| Output a line on a paginated file
    File_Handle : in Paginated_File_Handle;
                --| The paginated file to
                --| output the text
    Text        : in Variable_String_Array
                --| The text to be output.
    );

--| Raises:
--| Invalid_File, Output_Error

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Text is a string of
--| characters to be written to the paginated output file.

--| Effects:
--| Outputs Text of text to File_Handle.  If Text is the first string of the
--| first line to be printed on a page, the page header is printed before
--| printing the text.

--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised.  If an error
--| occurs during output, Output_Error is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Put(
    Text        : in String_Pkg.String_Type
    );

procedure Put(            --| Output a line on a paginated file
    File_Handle : in Paginated_File_Handle;
                --| The paginated file to
                --| output the text
    Text        : in String_Pkg.String_Type
                --| The text to be output.
    );

--| Raises:
--| Invalid_File, Output_Error

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Text is a string of
--| characters to be written to the paginated output file.

--| Effects:
--| Outputs Text of text to File_Handle.  If Text is the first string of the
--| first line to be printed on a page, the page header is printed before
--| printing the text.

--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised.  If an error
--| occurs during output, Output_Error is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Put(
    Text        : in string
    );

procedure Put(            --| Output a line on a paginated file
    File_Handle : in Paginated_File_Handle;
                --| The paginated file to
                --| output the text
    Text        : in string    --| The text to be output.
    );

--| Raises:
--| Invalid_File, Output_Error

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Text is a string of
--| characters to be written to the paginated output file.

--| Effects:
--| Outputs Text of text to File_Handle.  If Text is the first string of the
--| first line to be printed on a page, the page header is printed before
--| printing the string.

--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised.  If an error
--| occurs during output, Output_Error is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Put(
    Text        : in character
    );

procedure Put(            --| Output a line on a paginated file
    File_Handle : in Paginated_File_Handle;
                --| The paginated file to
                --| output the text
    Text        : in character    --| The text to be output.
    );

--| Raises:
--| Invalid_File, Output_Error

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Text is a the characters to be
--| written to the paginated output file.

--| Effects:
--| Outputs Text of text to File_Handle.  If Text is the first character of the
--| first line to be printed on a page, the page header is printed before
--| printing the string.

--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised.  If an error
--| occurs during output, Output_Error is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Space(
    Count       : in integer
    );

procedure Space(        --| Output a specified number of spaces
    File_Handle : in Paginated_File_Handle;
                --| The paginated file to output the line
    Count       : in integer    --| Number of spaces
    );

--| Raises:
--| Invalid_File, Output_Error

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Count is the number of horizontal
--| spaces to be output.

--| Effects:
--| Output Count number of blanks to File_Handle.

--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised.  If an error
--| occurs during output, Output_Error is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Put_Line(
    Text_Line   : in Variable_String_Array
    );

procedure Put_Line(        --| Output a line on a paginated file
    File_Handle : in Paginated_File_Handle;
                --| The paginated file to output the line
    Text_Line   : in Variable_String_Array
                --| The line to be output.
    );

--| Raises:
--| Invalid_File, Output_Error

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Text_Line is a string of
--| characters to be written to the paginated output file.

--| Effects:
--| Outputs Text_Line of text to File_Handle.  If Text_Line is the
--| first line to be printed on a page, the page header is printed
--| before the line.  If it is the last line on a page, the page
--| footer followed by a page terminator is written immediately
--| after the line is written.

--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised.  If an error
--| occurs during output, Output_Error is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Put_Line(
    Text_Line   : in String_Pkg.String_Type
    );

procedure Put_Line(        --| Output a line on a paginated file
    File_Handle : in Paginated_File_Handle;
                --| The paginated file to
                --| output the line
    Text_Line   : in String_Pkg.String_Type
                --| The line to be output.
    );

--| Raises:
--| Invalid_File, Output_Error

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Text_Line is a string of
--| characters to be written to the paginated output file.

--| Effects:
--| Outputs Text_Line of text to File_Handle.  If Text_Line is the
--| first line to be printed on a page, the page header is printed
--| before the line.  If it is the last line on a page, the page
--| footer followed by a page terminator is written immediately
--| after the line is written.

--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised.  If an error
--| occurs during output, Output_Error is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Put_Line(
    Text_Line   : in string
    );

procedure Put_Line(        --| Output a line on a paginated file
    File_Handle : in Paginated_File_Handle;
                --| The paginated file to
                --| output the line
    Text_Line   : in string    --| The line to be output.
    );

--| Raises:
--| Invalid_File, Output_Error

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Text_Line is a string of
--| characters to be written to the paginated output file.

--| Effects:
--| Outputs Text_Line of text to File_Handle.  If Text_Line is the
--| first line to be printed on a page, the page header is printed
--| before the line.  If it is the last line on a page, the page
--| footer followed by a page terminator is written immediately
--| after the line is written.

--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised.  If an error
--| occurs during output, Output_Error is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Space_Line(
    Count       : in integer := 1
    );

procedure Space_Line(        --| Output one or more spaces on a
                --| paginated file
    File_Handle : in Paginated_File_Handle;
                --| The paginated file to
                --| output spaces
    Count       : in integer := 1
                --| The number of spaces.
    );

--| Raises:
--| Invalid_File, Output_Error, Invalid_Count

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Count is the number of
--| spaces to be output to File_Handle.  If Count is omitted, 1 is
--| assumed.

--| Effects:
--| Count number of line terminators are output to File_Handle.
--| If Count is greater than the number of lines remaining on
--| the page, the page footer, a page terminator, and the page header
--| are written before the remainder of the spaces are output.
--| If the specified Count is less than equal to 0, no operation
--| takes place.

--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised.  If the requested space
--| count is greater than a predetermined amount, Invalid_Count
--| is raised.  If an error occurs during output, Output_Error
--| is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Skip_Line(
    Count       : in integer := 1
    );

procedure Skip_Line(        --| Output one or more spaces on a
                --| paginated file
    File_Handle : in Paginated_File_Handle;
                --| The paginated file to
                --| output skips
    Count       : in integer := 1
                --| The number of spaces.
    );

--| Raises:
--| Invalid_File, Output_Error, Invalid_Count

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Count is the number of
--| spaces to be output to File_Handle.  If Count is omitted, 1 is
--| assumed.

--| Effects:
--| Count number of line terminators are output to File_Handle.
--| If Count is greater than the number of lines remaining on
--| the page, the page footer is printed, a page terminator is
--| output and the remainder of the skips are NOT output.
--| If the specified Count is less than equal to 0, no operation
--| takes place.

--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised.  If the requested skip
--| count is greater than a predetermined amount, Invalid_Count
--| is raised.  If an error occurs during output, Output_Error
--| is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Put_Page(
    Count       : in integer := 1
    );

procedure Put_Page(        --| Output one or more page ejects
                --| on a paginated file
    File_Handle : in Paginated_File_Handle;
                --| The paginated file to
                --| output page ejects
    Count       : in integer := 1
                --| The number of pages.
    );

--| Raises:
--| Invalid_File, Output_Error, Invalid_Count

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Count is the number of
--| pages to be output to File_Handle.  If Count is omitted, 1 is
--| assumed.

--| Effects:
--| Outputs Count number of page ejects. The page footer and the page
--| header are printed as appropriate.
--| If the specified Count is less than equal to 0, no operation
--| takes place.

--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised.  If the requested page
--| count is greater than a predetermined amount, Invalid_Count
--| is raised.  If an error occurs during output, Output_Error
--| is raised.

--| N/A: Modifies
                                                    pragma Page;
function Available_Lines
    return integer;

function Available_Lines(    --| Query the number of lines that
                --| are available on the current page
    File_Handle : in Paginated_File_Handle
                --| The paginated file to be
                --| queried for available lines
    ) return integer;

--| Raises:
--| Invalid_File

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.

--| Effects:
--| Return the number of lines (excluding the header and the footer
--| spaces) remaining on the current output page.

--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised.

--| N/A: Modifies
                                                    pragma Page;
procedure Reserve_Lines(
    Count       : in integer
    );

procedure Reserve_Lines(    --| Assure that there are at least
                --| a specified number of contiguous
                --| lines on a paginated file.
    File_Handle : in Paginated_File_Handle;
                --| The paginated file to
                --| reserve the lines
    Count       : in integer    --| The number of lines needed
    );

--| Raises :
--| Invalid_File, Page_Overflow

--| Requires:
--| File_Handle is the access to the paginated file control structure
--| returned by Create_Paginated_File.  Count is the number of
--| contiguous lines needed on File_Handle.

--| Effects:
--| If Count is greater than the number of lines remaining on
--| the page, Put_Page is executed to assure that there are Count
--| number of contiguous lines.
--| Specifying value less than or equal to 0 for Count will result
--| in no operation

--| Errors:
--| If File_Handle is not a valid, open Paginated_File_Handle,
--| the exception Invalid_File is raised.  If Count is greater than
--| the maximum number of lines available on a page as set by
--| Set_Page_Layout, exception Page_Overflow is raised and Put_Page
--| is NOT executed.
                                                    pragma Page;
private
                                                    pragma List(on);
    type Variable_String_Array_Handle is
    access Variable_String_Array;
                --| Handle to array of variable length
                --| strings

    type Paginated_File_Structure;
                --| Data structure to store state of
                --| the output file.

    type Paginated_File_Handle is
    access Paginated_File_Structure;
                --| Handle to be passed around in a
                --| program that uses paginated_output.

    type Paginated_File_Structure is
                --| a structure to store state of
    record            --| the output file.
        access_count     : integer;
                --| Number of accesses to this structure
        forward_link     : Paginated_File_Handle := null;
                --| Access to next file structure
        reverse_link     : Paginated_File_Handle := null;
                --| Access to previous file structure
        standard_flag    : boolean := false;
                --| Standard output flag
        file_name        : String_Pkg.String_Type;
                --| External file name
        file_reference   : Text_IO.File_Type;
                --| External file reference
        output_mode      : Paginated_Output_Mode := OUTPUT;
                --| Output mode (OUTPUT or ERROR)
        page_size        : integer;
                --| The number of lines per page
        maximum_line     : integer;
                --| The maximum number of text lines
        current_calendar : String_Pkg.String_Type;
                --| Creation date (eg. March 15, 1985)
        current_date     : string (1 .. 8);
                --| Creation date (eg. 03/15/85)
        current_time     : string (1 .. 8);
                --| Creation time (eg. 15:24:07)
        current_page     : integer := 0;
                --| The number of lines per page
        current_line     : integer := 0;
                --| The number of lines used
        header_size      : integer;
                --| Number of lines of header text
        odd_page_header  : Variable_String_Array_Handle := null;
                --| Access to odd page header text
        even_page_header : Variable_String_Array_Handle := null;
                --| Access to even page header text
        footer_size      : integer;
                --| Number of lines of footer text
        odd_page_footer  : Variable_String_Array_Handle := null;
                --| Access to odd page footer text
        even_page_footer : Variable_String_Array_Handle := null;
                --| Access to even page footer text
    end record;
                                                    pragma List(on);
end  Paginated_Output;
                                                    pragma Page;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--PGFILE.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with Text_IO;            use Text_IO;
with Calendar;            use Calendar;
with String_Pkg;        use String_Pkg;
with Unchecked_Deallocation;


package body Paginated_Output is

    package Int_IO is new Integer_IO(integer);

    type Odd_Even is (Odd, Even);
                --| Odd/Even page indicator

    type Header_Footer is (Header,Footer);
                --| Header/Footer selection

    type Kind_Of_Text is    --| Text selection switches
    record
        page: Odd_Even;
        text: Header_Footer;
    end record;

    Month_Name : constant Variable_String_Array(1 .. 12) :=
    ( 1 => Create("January"),
      2 => Create("February"),
      3 => Create("March"),
      4 => Create("April"),
      5 => Create("May"),
      6 => Create("June"),
      7 => Create("July"),
      8 => Create("August"),
      9 => Create("September"),
     10 => Create("October"),
     11 => Create("November"),
     12 => Create("December") );

    Paginated_Standard_Output : Paginated_File_Handle;
                                                    pragma Page;
    function Convert(
    Input_Number : in integer;
    Digit        : in integer := 0
    ) return string is

--|-Algorithm:
--| If integer value is negative or greater than 99
--|    then return null text
--| If input value is less than 10 (ie. single decimal digit)
--|    then concatenate 0 and character equivalent of the given value
--|    else convert value to character equivalent
--| Return converted text
--|+

    Temp_Text : string (1 .. 16);
    Index     : integer;

    begin

    if Digit > Temp_Text'last then
        return "";
    end if;
    Int_IO.Put(Temp_Text, Input_Number);
    if Digit <= 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 - Digit + 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;
                                                    pragma Page;
    procedure Set_Date_Time(
    File_Handle : in Paginated_File_Handle
    ) is

--|-Algorithm:
--| Get the current system date/time
--| Separate date/time into appropriate components
--| Calculate in terms of hours, minutes, and seconds
--| Set current date/time in the file structure
--| Set the current date in "English" (eg. January 1, 1985)
--|    in the file structure
--| Exit
--|+

    Clock_Value : Calendar.Time;
    Year        : Calendar.Year_Number;
    Month       : Calendar.Month_Number;
    Day         : Calendar.Day_Number;
    Duration    : Calendar.Day_Duration;

    begin

    Clock_Value := Calendar.Clock;
    Calendar.Split(Clock_Value, Year, Month, Day, Duration);
    File_Handle.current_date := Convert(integer(Month), 2) & "/"
                  & Convert(integer(Day), 2) & "/"
                  & Convert(integer(Year mod 100), 2);
    File_Handle.current_time := Convert(integer(Duration) / (60 * 60), 2) & ":"
                  & Convert((integer(Duration) mod (60 * 60)) / 60, 2) & ":"
                  & Convert(integer(Duration) mod 60, 2);
    String_Pkg.Mark;
    File_Handle.current_calendar := String_Pkg.Make_Persistent(
                    Month_Name(integer(Month)) &
                    integer'image(Day) &
                    "," &
                    integer'image(Year));
    String_Pkg.Release;
    return;

    end Set_Date_Time;
                                                    pragma Page;
    procedure Check_Valid(
    File_Handle : in Paginated_File_Handle
    ) is

--|-Algorithm:
--| If handle is null or external file name is null
--|    then raise an error
--| Exit
--|+

    begin

    if File_Handle = null then
        raise Invalid_File;
    end if;
    return;

    end Check_Valid;
                                                    pragma Page;
    procedure Clear_Text(
    Text_Handle : in Variable_String_Array_Handle
    ) is

--|-Algorithm:
--| If valid access to text array
--|    then return text array storage to the heap (access set to null)
--| Exit
--|+

    begin

    if Text_Handle /= null then
        for i in Text_Handle'range loop
        String_Pkg.Flush(Text_Handle(i));
        end loop;
    end if;
    return;

    end Clear_Text;
                                                    pragma Page;
    procedure Set_Text(
    File_Handle  : in Paginated_File_Handle;
    Text_String  : in Variable_String_Array;
    Text_Control : in Kind_Of_Text
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If requested text array is too large
--|    then raise an error
--| Clear old text array
--| Set new text array with specified justification (top or bottom)
--| in the area as specified
--| Exit
--|+

    Text_Handle : Variable_String_Array_Handle;
    Text_Index  : integer;
    Text_Size   : integer;
    Handle      : Paginated_File_Handle;

    begin
    Check_Valid(File_Handle);
    Handle := File_Handle;
    loop
        exit when Handle = null;
        case Text_Control.text is
        when Header =>
            Text_Size := Handle.header_size;
            Text_Index := 1;
            case Text_Control.page is
            when Odd =>
                Text_Handle := Handle.odd_page_header;
            when Even =>
                Text_Handle := Handle.even_page_header;
            end case;
        when Footer =>
            Text_Size := Handle.footer_size;
            Text_Index := Text_Size - Text_String'last + 1;
            case Text_Control.page is
            when Odd =>
                Text_Handle := Handle.odd_page_footer;
            when Even =>
                Text_Handle := Handle.even_page_footer;
            end case;
        end case;
        if Text_Size < Text_String'last then
        raise Text_Overflow;
        end if;
        Clear_Text(Text_Handle);
        for i in Text_String'range loop
        Text_Handle(Text_Index) := String_Pkg.Make_Persistent(Text_String(i));
        Text_Index := Text_Index + 1;
        end loop;
        Handle := Handle.forward_link;
    end loop;
    return;

    end Set_Text;
                                                    pragma Page;
    function Tilde_Substitute(
    File_Handle : in Paginated_File_Handle;
    Input_Text : in String_Pkg.String_Type
    ) return string is

--|-Algorithm:
--| Set the length of the text in question
--| Clear the result string to null
--| Loop until all input characters are processed
--|    Fetch one character
--|    If the character is a tilde (~)
--|       then bump input index and if past the end exit the loop
--|            Fetch the next character
--|            Based on this character substitute appropriately
--|        else add this to the output
--|     Bump input index and loop
--| Return the output (substituted) string
--| Exit
--|+

    Output_Text : String_Pkg.String_Type;
    S_Str       : String_Pkg.String_Type;
    Letter      : character;
    Index       : natural;

    begin

    S_Str := Input_Text;
    loop
        Index := String_Pkg.Match_C(S_Str, '~');
        if Index = 0 then
        Output_Text := Output_Text & S_Str;
        exit;
        end if;
        if Index > 1 then
        Output_Text := Output_Text & String_Pkg.Substr(S_Str, 1, Index - 1);
        end if;
        if Index < String_Pkg.Length(S_Str) then
        Letter := String_Pkg.Fetch(S_Str, Index + 1);
        else
        exit;
        end if;
        case Letter is
        when 'f' | 'F' =>
            Output_Text := Output_Text & File_Handle.file_name;
        when 'c' | 'C' =>
            Output_Text := Output_Text & File_Handle.current_calendar;
        when 'd' | 'D' =>
            Output_Text := Output_Text & File_Handle.current_date;
        when 't' | 'T' =>
            Output_Text := Output_Text & File_Handle.current_time;
        when 'p' | 'P' =>
            Output_Text := Output_Text & Convert(File_Handle.current_page, 0);
        when others    =>
            Output_Text := Output_Text & ("" & Letter);
        end case;
        Index := Index + 2;
        if Index > String_Pkg.Length(S_Str) then
        exit;
        end if;
        S_Str := String_Pkg.Substr(S_Str, Index, String_Pkg.Length(S_Str) - Index + 1);
    end loop;

    return String_Pkg.Value(Output_Text);

    end Tilde_Substitute;
                                                    pragma Page;
    procedure Put_Text(
    File_Handle  : in Paginated_File_Handle;
    Text_Control : in Kind_Of_Text
    ) is

--|-Algorithm:
--| If access to text array is null
--|    then write appropriate number of line terminators
--|         exit
--| Loop over the depth of the text array
--|    If text is null
--|       then write line terminator
--|       else resolve tilde substitution
--|            write a line of text followed by a line terminator
--| Exit
--|+

    Text_Handle : Variable_String_Array_Handle;
    Text_Size   : integer;

    begin
    case Text_Control.text is
        when Header =>
        if File_Handle.header_size = 0 then
            return;
        end if;
        Text_Size := File_Handle.header_size;
        if File_Handle.current_page mod 2 = 0 then
            Text_Handle := File_Handle.even_page_header;
        else
            Text_Handle := File_Handle.odd_page_header;
        end if;
        when Footer =>
        if File_Handle.footer_size = 0 then
            return;
        end if;
        Text_Size := File_Handle.footer_size;
        if File_Handle.current_page mod 2 = 0 then
            Text_Handle := File_Handle.even_page_footer;
        else
            Text_Handle := File_Handle.odd_page_footer;
        end if;
    end case;
    if Text_Handle = null then
        if String_Pkg.Equal(File_Handle.file_name, "") then
        if File_Handle.output_mode = OUTPUT then
            Text_IO.New_Line(Text_IO.Standard_Output,
                     Text_IO.Positive_Count(Text_Size));
        else
            Text_IO.New_Line(Text_IO.Current_Output,
                     Text_IO.Positive_Count(Text_Size));
        end if;
        else
        Text_IO.New_Line(File_Handle.file_reference,
                 Text_IO.Positive_Count(Text_Size));
        end if;
        return;
    end if;
    for i in 1 .. Text_Size loop
        String_Pkg.Mark;
        if String_Pkg.Is_Empty(Text_Handle(i)) then
            if String_Pkg.Equal(File_Handle.file_name, "") then
            if File_Handle.output_mode = OUTPUT then
            Text_IO.New_Line(Text_IO.Standard_Output, 1);
            else
            Text_IO.New_Line(Text_IO.Current_Output, 1);
            end if;
        else
            Text_IO.New_Line(File_Handle.file_reference, 1);
        end if;
        else
            if String_Pkg.Equal(File_Handle.file_name, "") then
            if File_Handle.output_mode = OUTPUT then
            Text_IO.Put_Line(Text_IO.Standard_Output,
                     Tilde_Substitute(File_Handle, Text_Handle(i)));
            else
            Text_IO.Put_Line(Text_IO.Current_Output,
                     Tilde_Substitute(File_Handle, Text_Handle(i)));
            end if;
        else
            Text_IO.Put_Line(File_Handle.file_reference,
                     Tilde_Substitute(File_Handle, Text_Handle(i)));
        end if;
        end if;
        String_Pkg.Release;
    end loop;
    return;

    end Put_Text;
                                                    pragma Page;
    procedure Free_Structure is
    new Unchecked_Deallocation(Paginated_File_Structure, Paginated_File_Handle);

    procedure Abort_Paginated_Output(
    File_Handle : in out Paginated_File_Handle
    ) is

--|-Algorithm:
--| If given handle is null
--|    return
--| Return header/footer text array storage to the heap
--| Close file
--| Return file structure storage to the heap
--| Exit
--|+

    begin
    if File_Handle = null then
        return;
    end if;
    Clear_Text(File_Handle.odd_page_header);
    Clear_Text(File_Handle.even_page_header);
    Clear_Text(File_Handle.odd_page_footer);
    Clear_Text(File_Handle.even_page_footer);
    String_Pkg.Flush(File_Handle.current_calendar);
    if not String_Pkg.Equal(File_Handle.file_name, "") then
        String_Pkg.Flush(File_Handle.file_name);
        Text_IO.Close(File_Handle.file_reference);
    end if;
    Free_Structure(File_Handle);
    return;

    exception

    when Text_IO.Status_Error =>
        Free_Structure(File_Handle);

    end Abort_Paginated_Output;
                                                    pragma Page;
    procedure Line_Feed(
    File_Handle : in Paginated_File_Handle;
    Count       : in integer
    ) is

--|-Algorithm:
--| If at top of the page
--|    then write header
--| If the request count is 0
--|    then return
--| If the request is greater than the remainder on the page
--|    then write remainder number of new lines
--|         decrement request by this amount
--|         write footer
--|         eject page and update page and line count
--|         if more space needed
--|            then recursively call self with count
--|    else write requested number of new lines
--|         update line count
--| Exit
--|+

    Skip_Count : integer;
    Text_Kind  : Kind_Of_Text;

    begin

    if File_Handle.current_line = 0 and File_Handle.page_size /= 0 then
        File_Handle.current_line := 1;
        File_Handle.current_page := File_Handle.current_page + 1;
        if String_Pkg.Equal(File_Handle.file_name, "") then
        if File_Handle.output_mode = OUTPUT then
            Text_IO.New_Page(Text_IO.Standard_Output);
        else
            Text_IO.New_Page(Text_IO.Current_Output);
        end if;
        else
        Text_IO.New_Page(File_Handle.file_reference);
        end if;
        Text_Kind.text := Header;
        Put_Text(File_Handle, Text_Kind);
    end if;
    if Count <= 0 then
        return;
    end if;
    Skip_Count := File_Handle.maximum_line - File_Handle.current_line + 1;
    if Count >= Skip_Count and File_Handle.page_size /= 0 then
        if String_Pkg.Equal(File_Handle.file_name, "") then
        if File_Handle.output_mode = OUTPUT then
            Text_IO.New_Line(Text_IO.Standard_Output,
                     Text_IO.Positive_Count(Skip_Count));
        else
            Text_IO.New_Line(Text_IO.Current_Output,
                     Text_IO.Positive_Count(Skip_Count));
        end if;
        else
        Text_IO.New_Line(File_Handle.file_reference,
                 Text_IO.Positive_Count(Skip_Count));
        end if;
        Skip_Count := Count - Skip_Count;
        Text_Kind.text := footer;
        Put_Text(File_Handle, Text_Kind);
        File_Handle.current_line := 0;
        if Skip_Count /= 0 then
        Line_Feed(File_Handle, Skip_Count);
        end if;
    else
        if String_Pkg.Equal(File_Handle.file_name, "") then
        if File_Handle.output_mode = OUTPUT then
            Text_IO.New_Line(Text_IO.Standard_Output,
                     Text_IO.Positive_Count(Count));
        else
            Text_IO.New_Line(Text_IO.Current_Output,
                     Text_IO.Positive_Count(Count));
        end if;
        else
        Text_IO.New_Line(File_Handle.file_reference,
                 Text_IO.Positive_Count(Count));
        end if;
        if File_Handle.page_size /= 0 then
        File_Handle.current_line := File_Handle.current_line + Count;
        end if;
    end if;
    return;

    end Line_Feed;
                                                    pragma Page;
    procedure Page_Eject(
    File_Handle : in Paginated_File_Handle;
    Count       : in integer := 1
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Raise Invalid_Count if page request is too large
--| Convert the number of pages to skip into number of lines
--| Write out this number of new line control characters
--| while taking into account header, footer, and pagination.
--| Exit
--|+

    begin

    if File_Handle.page_size = 0 then
        Line_Feed(File_Handle, 1);
        return;
    end if;
    if Count > 99 then
        raise Invalid_Count;
    end if;
    if File_Handle.current_line = 0 then
        Line_Feed(File_Handle,
        (Count * File_Handle.maximum_line));
    else
        Line_Feed(File_Handle,
        (Count * File_Handle.maximum_line - File_Handle.current_line + 1));
    end if;
    return;

    end Page_Eject;
                                                    pragma Page;
    procedure Set_Text_Area(
    Text_Handle : in out Variable_String_Array_Handle;
    Area_Size   : in     integer
    ) is

    Temp_Handle : Variable_String_Array_Handle;

    begin

    if Area_Size <= 0 then
        return;
    end if;
    if Text_Handle = null or else
       Text_Handle'last < Area_Size then
        Temp_Handle := Text_Handle;
        Text_Handle := new Variable_String_Array (1 .. Area_Size);
        if Temp_Handle /= null then
        for i in Temp_Handle'range loop
            Text_Handle(i) := String_Pkg.Make_Persistent(Temp_Handle(i));
        end loop;
        Clear_Text(Temp_Handle);
        end if;
      end if;

    end Set_Text_Area;
                                                    pragma Page;
    procedure Write(
    File_Handle : in Paginated_File_Handle;
    Text_Line   : in string;
    Feed        : in boolean
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If at the top of the page
--|    then write out the header
--| Output the given line of text to the paginated file
--| Write out a new line control character
--| If at the bottom of the page
--|    then write out the footer and eject the page
--| Exit
--|+

    Handle : Paginated_File_Handle;

    begin

    Check_Valid(File_Handle);
    Handle := File_Handle;
    loop
        exit when Handle = null;
        Line_Feed(Handle, 0);
        if String_Pkg.Equal(Handle.file_name, "") then
        if Handle.output_mode = OUTPUT then
            Text_IO.Put(Text_IO.Standard_Output, Text_Line);
        else
            Text_IO.Put(Text_IO.Current_Output, Text_Line);
        end if;
        else
        Text_IO.Put(Handle.file_reference, Text_Line);
        end if;
        if Feed then
        Line_Feed(Handle, 1);
        end if;
        Handle := Handle.forward_link;
    end loop;
    return;

    end Write;
                                                    pragma Page;
    procedure Create_Paginated_File(
    File_Name   : in Host_File_Name             := "";
    File_Handle : in out Paginated_File_Handle;
    Page_Size   : in integer                    := 66;
    Header_Size : in integer                    := 6;
    Footer_Size : in integer                    := 6;
    Output_Mode : in Paginated_Output_Mode      := OUTPUT
    ) is

--|-Algorithm:
--| If an active (ie. non-null) handle is given
--|    then close that file first
--| Create a paginated file structure
--| If no file name is given
--|    then assume standard output
--|    else create (open) an external file
--| Fill the paginated file structure with external file information,
--| page layout information, and current date/time
--| Return access to the completed structure
--| Exit
--|+

    begin

    Close_Paginated_File(File_Handle);
    File_Handle := new Paginated_File_Structure;
    if File_Name /= "" then
        File_Handle.file_name := String_Pkg.Make_Persistent(File_Name);
        Text_IO.Create(File => File_Handle.file_reference,
               Name => File_Name);
    end if;
    Set_Page_Layout(File_Handle, Page_Size, Header_Size, Footer_Size);
    Set_Date_Time(File_Handle);
    File_Handle.output_mode := Output_Mode;
    File_Handle.access_count := 1;
    return;

    exception

    when Text_IO.Status_Error =>
        Abort_Paginated_Output(File_Handle);
        raise File_Already_Open;
    when Text_IO.Name_Error | Text_IO.Use_Error =>
        Abort_Paginated_Output(File_Handle);
        raise File_Error;
    when Page_Layout_Error =>
        Abort_Paginated_Output(File_Handle);
        raise Page_Layout_Error;

    end Create_Paginated_File;
                                                    pragma Page;
    procedure Set_Standard_Paginated_File(
    File_Name   : in Host_File_Name;
    Page_Size   : in integer;
    Header_Size : in integer;
    Footer_Size : in integer
    ) is

    begin

    Create_Paginated_File(File_Name,
                  Paginated_Standard_Output,
                  Page_Size,
                  Header_Size,
                  Footer_Size);
    Paginated_Standard_Output.standard_flag := true;

    end Set_Standard_Paginated_File;
                                                    pragma Page;
    procedure Duplicate_Paginated_File(
    Old_Handle : in Paginated_File_Handle;
    New_Handle : in out Paginated_File_Handle
    ) is

--|-Algorithm:
--| Close file refered to by the handle to which the existing handle
--| is to be copied (if such file exists)
--| Duplicate the handle
--| Exit
--|+

    begin

    Close_Paginated_File(New_Handle);
    Old_Handle.access_count := Old_Handle.access_count + 1;
    New_Handle := Old_Handle;
    return;

    end Duplicate_Paginated_File;
                                                    pragma Page;
    procedure Set_Page_Layout(
    Page_Size   : in integer;
    Header_Size : in integer;
    Footer_Size : in integer
    ) is

    begin

    Set_Page_Layout(Paginated_Standard_Output,
            Page_Size,
            Header_Size,
            Footer_Size);

    end Set_Page_Layout;
                                                    pragma Page;
    procedure Set_Page_Layout(
    File_Handle : in Paginated_File_Handle;
    Page_Size   : in integer;
    Header_Size : in integer;
    Footer_Size : in integer
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If page layout is contradictory
--|    then raise an error
--| If not at the top of the page
--|    then eject current page
--| Set page size, header size, footer size, and text area size
--| per page
--| Exit
--|+

    Temp_Handle : Variable_String_Array_Handle;

    begin

    Check_Valid(File_Handle);
    if Page_Size < 0 or Header_Size < 0 or Footer_Size < 0 or
       (Page_Size /= 0 and Page_Size <= Header_Size + Footer_Size) then
        raise Page_Layout_Error;
        return;
    end if;
    if File_Handle.current_line /= 0 and File_Handle.page_size /= 0 then
        Page_Eject(File_Handle, 1);
    end if;
    File_Handle.page_size := Page_Size;
    if Page_Size = 0 then
        File_Handle.maximum_line := 0;
    else
        File_Handle.maximum_line := Page_Size - (Header_Size + Footer_Size);
    end if;
    File_Handle.header_size := Header_Size;
    Set_Text_Area(File_Handle.odd_page_header, File_Handle.header_size);
    Set_Text_Area(File_Handle.even_page_header, File_Handle.header_size);
    File_Handle.footer_size := Footer_Size;
    Set_Text_Area(File_Handle.odd_page_footer, File_Handle.footer_size);
    Set_Text_Area(File_Handle.even_page_footer, File_Handle.footer_size);
    return;

    end Set_Page_Layout;
                                                    pragma Page;
    procedure Link_Paginated_File(
    File_Handle1 : in Paginated_File_Handle;
    File_Handle2 : in Paginated_File_Handle
    ) is

    begin

    Check_Valid(File_Handle1);
    Check_Valid(File_Handle2);
    if File_Handle1.forward_link = null and
       File_Handle2.reverse_link = null then
        File_Handle1.forward_link := File_Handle2;
        File_Handle2.reverse_link := File_Handle1;
        return;
    end if;

    raise Files_Already_Linked;

    end Link_Paginated_File;
                                                    pragma Page;
    procedure Unlink_Paginated_File(
    File_Handle : in Paginated_File_Handle
    ) is

    begin

    Check_Valid(File_Handle);
    if File_Handle.reverse_link /= null then
        File_Handle.reverse_link.forward_link := File_Handle.forward_link;
        File_Handle.reverse_link := null;
    end if;
    if File_Handle.forward_link /= null then
        File_Handle.forward_link.reverse_link := File_Handle.reverse_link;
        File_Handle.forward_link := null;
    end if;
    return;

    end Unlink_Paginated_File;
                                                    pragma Page;
    procedure Set_Header(
    Header_Text : in Variable_String_Array
    ) is

    begin
    Set_Header(Paginated_Standard_Output,
           Header_Text);

    end Set_Header;
                                                pragma Page;
    procedure Set_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Text : in Variable_String_Array
    ) is

--|-Algorithm:
--| Set given header text as odd page header
--| Set given header text as even page header
--| Exit
--|+

    begin

    Set_Text(File_Handle, Header_Text, (Odd, Header));
    Set_Text(File_Handle, Header_Text, (Even, Header));
    return;

    end Set_Header;
                                                    pragma Page;
    procedure Set_Header(
    Header_Line : in integer;
    Header_Text : in String_Pkg.String_Type
    ) is

    begin

    Set_Header(Paginated_Standard_Output,
           Header_Line,
           Header_Text);

    end Set_Header;
                                                    pragma Page;
    procedure Set_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Line : in integer;
    Header_Text : in String_Pkg.String_Type
    ) is

--|-Algorithm:
--| Set odd page header
--| Set even page header
--| Exit
--|+

    begin

    Set_Odd_Header(File_Handle, Header_Line, Header_Text);
    Set_Even_Header(File_Handle, Header_Line, Header_Text);
    return;

    end Set_Header;
                                                    pragma Page;
    procedure Set_Header(
    Header_Line : in integer;
    Header_Text : in string
    ) is

    begin

    Set_Header(Paginated_Standard_Output,
           Header_Line,
           Header_Text);

    end Set_Header;
                                                    pragma Page;
    procedure Set_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Line : in integer;
    Header_Text : in string
    ) is

--|-Algorithm:
--| Create a variable string
--| Set odd page header
--| Set even page header
--| Exit
--|+

    Text : String_Pkg.String_Type;

    begin

    Text :=    String_Pkg.Make_Persistent(Header_Text);
    Set_Odd_Header(File_Handle, Header_Line, Text);
    Set_Even_Header(File_Handle, Header_Line, Text);
    String_Pkg.Flush(Text);
    return;

    end Set_Header;
                                                    pragma Page;
    procedure Set_Odd_Header(
    Header_Text : in Variable_String_Array
    ) is

    begin

    Set_Odd_Header(Paginated_Standard_Output,
               Header_Text);

    end Set_Odd_Header;
                                                    pragma Page;
    procedure Set_Odd_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Text : in Variable_String_Array
    ) is

--|-Algorithm:
--| Set given header text as odd page header
--| Exit
--|+

    begin

    Set_Text(File_Handle, Header_Text, (Odd, Header));
    return;

    end Set_Odd_Header;
                                                    pragma Page;
    procedure Set_Odd_Header(
    Header_Line : in integer;
    Header_Text : in String_Pkg.String_Type
    ) is

    begin

    Set_Odd_Header(Paginated_Standard_Output,
               Header_Line,
               Header_Text);

    end Set_Odd_Header;
                                                    pragma Page;
    procedure Set_Odd_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Line : in integer;
    Header_Text : in String_Pkg.String_Type
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If requested header line number is out of range
--|     then raise an error
--| Set header text at requested line for odd pages
--| Exit
--|+

    begin

    Check_Valid(File_Handle);
    if Header_Line < 1 then
        raise Text_Underflow;
    end if;
    if Header_Line > File_Handle.header_size then
        raise Text_Overflow;
    end if;
    File_Handle.odd_page_header(Header_Line) := String_Pkg.Make_Persistent(Header_Text);
    return;

    end Set_Odd_Header;
                                                    pragma Page;
    procedure Set_Odd_Header(
    Header_Line : in integer;
    Header_Text : in string
    ) is

    begin

    Set_Odd_Header(Paginated_Standard_Output,
               Header_Line,
               Header_Text);

    end Set_Odd_Header;
                                                    pragma Page;
    procedure Set_Odd_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Line : in integer;
    Header_Text : in string
    ) is

--|-Algorithm:
--| Create a variable string
--| Set odd page header
--| Exit
--|+

    Text : String_Pkg.String_Type;

    begin

    Text := String_Pkg.Make_Persistent(Header_Text);
    Set_Odd_Header(File_Handle, Header_Line, Text);
    String_Pkg.Flush(Text);
    return;

    end Set_Odd_Header;
                                                    pragma Page;
    procedure Set_Even_Header(
    Header_Text : in Variable_String_Array
    ) is

    begin

    Set_Even_Header(Paginated_Standard_Output,
            Header_Text);

    end Set_Even_Header;
                                                    pragma Page;
    procedure Set_Even_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Text : in Variable_String_Array
    ) is

--|-Algorithm:
--| Set given header text as even page header
--| Exit
--|+

    begin

    Set_Text(File_Handle, Header_Text, (Even, Header));
    return;

    end Set_Even_Header;
                                                    pragma Page;
    procedure Set_Even_Header(
    Header_Line : in integer;
    Header_Text : in String_Pkg.String_Type
    ) is

    begin

    Set_Even_Header(Paginated_Standard_Output,
            Header_Line,
            Header_Text);

    end Set_Even_Header;
                                                    pragma Page;
    procedure Set_Even_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Line : in integer;
    Header_Text : in String_Pkg.String_Type
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If requested header line number is out of range
--|     then raise an error
--| Set header text at requested line for even pages
--| Exit
--|+

    begin

    Check_Valid(File_Handle);
    if Header_Line < 1 then
        raise Text_Underflow;
    end if;
    if Header_Line > File_Handle.header_size then
        raise Text_Overflow;
    end if;
    String_Pkg.Flush(File_Handle.even_page_header(Header_Line));
    File_Handle.even_page_header(Header_Line) := String_Pkg.Make_Persistent(Header_Text);
    return;

    end Set_Even_Header;
                                                    pragma Page;
    procedure Set_Even_Header(
    Header_Line : in integer;
    Header_Text : in string
    ) is

    begin

    Set_Even_Header(Paginated_Standard_Output,
            Header_Line,
            Header_Text);

    end Set_Even_Header;
                                                    pragma Page;
    procedure Set_Even_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Line : in integer;
    Header_Text : in string
    ) is

--|-Algorithm:
--| Create a variable string
--| Set even page header
--| Exit
--|+

    Text : String_Pkg.String_Type;

    begin

    Text :=    String_Pkg.Make_Persistent(Header_Text);
    Set_Even_Header(File_Handle, Header_Line, Text);
    String_Pkg.Flush(Text);
    return;

    end Set_Even_Header;
                                                    pragma Page;
    procedure Set_Footer(
    Footer_Text : in Variable_String_Array
    ) is

    begin

    Set_Footer(Paginated_Standard_Output,
           Footer_Text);

    end Set_Footer;
                                                    pragma Page;
    procedure Set_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Text : in Variable_String_Array
    ) is

--|-Algorithm:
--| Set given footer text as odd page header
--| Set given footer text as even page header
--| Exit
--|+

    begin

    Set_Text(File_Handle, Footer_Text, (Odd, Footer));
    Set_Text(File_Handle, Footer_Text, (Even, Footer));
    return;

    end Set_Footer;
                                                    pragma Page;
    procedure Set_Footer(
    Footer_Line : in integer;
    Footer_Text : in String_Pkg.String_Type
    ) is

    begin

    Set_Footer(Paginated_Standard_Output,
           Footer_Line,
           Footer_Text);

    end Set_Footer;
                                                    pragma Page;
    procedure Set_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Line : in integer;
    Footer_Text : in String_Pkg.String_Type
    ) is

--|-Algorithm:
--| Set odd page footer
--| Set even page footer
--| Exit
--|+

    begin

    Set_Odd_Footer(File_Handle, Footer_Line, Footer_Text);
    Set_Even_Footer(File_Handle, Footer_Line, Footer_Text);
    return;

    end Set_Footer;
                                                    pragma Page;
    procedure Set_Footer(
    Footer_Line : in integer;
    Footer_Text : in string
    ) is

    begin

    Set_Footer(Paginated_Standard_Output,
           Footer_Line,
           Footer_Text);

    end Set_Footer;
                                                    pragma Page;
    procedure Set_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Line : in integer;
    Footer_Text : in string
    ) is

--|-Algorithm:
--| Create a variable string
--| Set odd page footer
--| Set even page footer
--| Exit
--|+

    Text : String_Pkg.String_Type;

    begin

    Text := String_Pkg.Make_Persistent(Footer_Text);
    Set_Odd_Footer(File_Handle, Footer_Line, Text);
    Set_Even_Footer(File_Handle, Footer_Line, Text);
    String_Pkg.Flush(Text);
    return;

    end Set_Footer;
                                                    pragma Page;
    procedure Set_Odd_Footer(
    Footer_Text : in Variable_String_Array
    ) is

    begin

    Set_Odd_Footer(Paginated_Standard_Output,
               Footer_Text);

    end Set_Odd_Footer;
                                                                               pragma Page;
    procedure Set_Odd_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Text : in Variable_String_Array
    ) is

--|-Algorithm:
--| Set given footer text as odd page header
--| Exit
--|+

    begin

    Set_Text(File_Handle, Footer_Text, (Odd, Footer));
    return;

    end Set_Odd_Footer;
                                                    pragma Page;
    procedure Set_Odd_Footer(
    Footer_Line : in integer;
    Footer_Text : in String_Pkg.String_Type
    ) is

    begin

    Set_Odd_Footer(Paginated_Standard_Output,
               Footer_Line,
               Footer_Text);

    end Set_Odd_Footer;
                                                                pragma Page;
    procedure Set_Odd_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Line : in integer;
    Footer_Text : in String_Pkg.String_Type
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If requested footer line number is out of range
--|     then raise an error
--| Set footer text at requested line for odd pages
--| Exit
--|+

    begin

    Check_Valid(File_Handle);
    if Footer_Line < 1 then
        raise Text_Underflow;
    end if;
    if Footer_Line > File_Handle.footer_size then
        raise Text_Overflow;
    end if;
    String_Pkg.Flush(File_Handle.odd_page_footer(Footer_Line));
    File_Handle.odd_page_footer(Footer_Line) := String_Pkg.Make_Persistent(Footer_Text);
    return;

    end Set_Odd_Footer;
                                                    pragma Page;
    procedure Set_Odd_Footer(
    Footer_Line : in integer;
    Footer_Text : in string
    ) is

    begin

    Set_Odd_Footer(Paginated_Standard_Output,
               Footer_Line,
               Footer_Text);

    end Set_Odd_Footer;
                                                    pragma Page;
    procedure Set_Odd_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Line : in integer;
    Footer_Text : in string
    ) is

    Text : String_Pkg.String_Type;

    begin

    Text := String_Pkg.Make_Persistent(Footer_Text);
    Set_Odd_Footer(File_Handle, Footer_Line, Text);
    String_Pkg.Flush(Text);
    return;

    end Set_Odd_Footer;
                                                    pragma Page;
    procedure Set_Even_Footer(
    Footer_Text : in Variable_String_Array
    ) is

    begin

    Set_Even_Footer(Paginated_Standard_Output,
            Footer_Text);

    end Set_Even_Footer;
                                                    pragma Page;
    procedure Set_Even_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Text : in Variable_String_Array
    ) is

--|-Algorithm:
--| Set given footer text as even page header
--| Exit
--|+

    begin

    Set_Text(File_Handle, Footer_Text, (Even, Footer));
    return;

    end Set_Even_Footer;
                                                    pragma Page;
    procedure Set_Even_Footer(
    Footer_Line : in integer;
    Footer_Text : in String_Pkg.String_Type
    ) is

    begin

    Set_Even_Footer(Paginated_Standard_Output,
            Footer_Line,
            Footer_Text);

    end Set_Even_Footer;
                                                    pragma Page;
    procedure Set_Even_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Line : in integer;
    Footer_Text : in String_Pkg.String_Type
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If requested footer line number is out of range
--|     then raise an error
--| Set footer text at requested line for even pages
--| Exit
--|+

    begin

    Check_Valid(File_Handle);
    if Footer_Line < 1 then
        raise Text_Underflow;
    end if;
    if Footer_Line > File_Handle.footer_size then
        raise Text_Overflow;
    end if;
    String_Pkg.Flush(File_Handle.even_page_footer(Footer_Line));
    File_Handle.even_page_footer(Footer_Line) := String_Pkg.Make_Persistent(Footer_Text);
    return;

    end Set_Even_Footer;
                                                    pragma Page;
    procedure Set_Even_Footer(
    Footer_Line : in integer;
    Footer_Text : in string
    ) is

    begin

    Set_Even_Footer(Paginated_Standard_Output,
            Footer_Line,
            Footer_Text);

    end Set_Even_Footer;
                                                    pragma Page;
    procedure Set_Even_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Line : in integer;
    Footer_Text : in string
    ) is

--|-Algorithm:
--| Create a variable string
--| Set even page footer
--| Exit
--|+
    Text : String_Pkg.String_Type;

    begin

    Text := String_Pkg.Make_Persistent(Footer_Text);
    Set_Even_Footer(File_Handle, Footer_Line, Text);
    String_Pkg.Flush(Text);
    return;

    end Set_Even_Footer;
                                                    pragma Page;
    procedure Clear_Header
    is

    begin

    Clear_Header(Paginated_Standard_Output);

    end Clear_Header;
                                                    pragma Page;
    procedure Clear_Header(
    File_Handle : in Paginated_File_Handle
    ) is

--|-Algorithm:
--| Clear odd page header
--| Clear even page header
--| Exit
--|+

    begin

    Clear_Odd_Header(File_Handle);
    Clear_Even_Header(File_Handle);
    return;

    end Clear_Header;
                                                    pragma Page;
    procedure Clear_Odd_Header
    is

    begin

    Clear_Odd_Header(Paginated_Standard_Output);

    end Clear_Odd_Header;
                                                    pragma Page;
    procedure Clear_Odd_Header(
    File_Handle : in Paginated_File_Handle
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Clear all text for odd page header lines
--| Exit
--|+

    begin

    Check_Valid(File_Handle);
    Clear_Text(File_Handle.odd_page_header);
    return;

    end Clear_Odd_Header;
                                                    pragma Page;
    procedure Clear_Even_Header
    is

    begin

    Clear_Even_Header(Paginated_Standard_Output);

    end Clear_Even_Header;
                                                    pragma Page;
    procedure Clear_Even_Header(
    File_Handle : in Paginated_File_Handle
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Clear all text for even page header lines
--| Exit
--|+

    begin

    Check_Valid(File_Handle);
    Clear_Text(File_Handle.even_page_header);
    return;

    end Clear_Even_Header;
                                                    pragma Page;
    procedure Clear_Footer
    is

    begin

    Clear_Footer(Paginated_Standard_Output);

    end Clear_Footer;
                                                    pragma Page;
    procedure Clear_Footer(
    File_Handle : in Paginated_File_Handle
    ) is

--|-Algorithm:
--| Clear odd page footer
--| Clear even page footer
--| Exit
--|+

    begin

    Clear_Odd_Footer(File_Handle);
    Clear_Even_Footer(File_Handle);
    return;

    end Clear_Footer;
                                                    pragma Page;
    procedure Clear_Odd_Footer
    is

    begin

    Clear_Odd_Footer(Paginated_Standard_Output);

    end Clear_Odd_Footer;
                                                    pragma Page;
    procedure Clear_Odd_Footer(
    File_Handle : in Paginated_File_Handle
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Clear all text for odd page footer lines
--| Exit
--|+

    begin

    Check_Valid(File_Handle);
    Clear_Text(File_Handle.odd_page_footer);
    return;

    end Clear_Odd_Footer;
                                                    pragma Page;
    procedure Clear_Even_Footer
    is

    begin

    Clear_Even_Footer(Paginated_Standard_Output);

    end Clear_Even_Footer;
                                                    pragma Page;
    procedure Clear_Even_Footer(
    File_Handle : in Paginated_File_Handle
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Clear all text for even footer lines
--| Exit
--|+

    begin

    Check_Valid(File_Handle);
    Clear_Text(File_Handle.even_page_footer);
    return;

    end Clear_Even_Footer;
                                                    pragma Page;
    procedure Close_Paginated_File
    is

    begin

    Close_Paginated_File(Paginated_Standard_Output);
    Create_Paginated_File("", Paginated_Standard_Output, 0, 0, 0);
    Paginated_Standard_Output.standard_flag := true;

    end Close_Paginated_File;
                                                    pragma Page;
    procedure Close_Paginated_File(
    File_Handle : in out Paginated_File_Handle
    ) is

--|-Algorithm:
--| If no file (ie. handle is null)
--|    then return
--| Decrement access count to this file structure
--| If other accesses still exist for this structure
--|    then null this handle and return
--| If not at the top of the page
--|    then eject current page
--| Return all storage used for this file to the heap
--| Close the external file
--| Exit
--|+

    begin

    if File_Handle = null then
        return;
    end if;
    File_Handle.access_count := File_Handle.access_count - 1;
    if File_Handle.access_count > 0 then
        File_Handle := null;
        return;
    end if;
    Unlink_Paginated_File(File_Handle);
    if File_Handle.current_line /= 0 and File_Handle.page_size /= 0 then
        Page_Eject(File_Handle, 1);
    end if;
    Abort_Paginated_Output(File_Handle);
    return;

    end Close_Paginated_File;
                                                    pragma Page;
    procedure Put(
    Text        : in character
    ) is

    begin

    Put(Paginated_Standard_Output,
        Text);

    end Put;
                                                    pragma Page;
    procedure Put(
    File_Handle : in Paginated_File_Handle;
    Text        : in character
    ) is

    begin

    Write(File_Handle, "" & Text, false);

    end Put;
                                                    pragma Page;
    procedure Put(
    Text        : in string
    ) is

    begin

    Write(Paginated_Standard_Output, Text, false);

    end Put;
                                                    pragma Page;
    procedure Put(
    File_Handle : in Paginated_File_Handle;
    Text        : in string
    ) is

--|-Algorithm:
--| Execute Write procedure with feed
--| Exit
--|+

    begin

    Write(File_Handle, Text, false);

    end Put;
                                                    pragma Page;
    procedure Put(
    Text        : in String_Pkg.String_Type
    ) is

    begin

    Put(Paginated_Standard_Output,
        String_Pkg.Value(Text));

    end Put;
                                                    pragma Page;
    procedure Put(
    File_Handle : in Paginated_File_Handle;
    Text        : in String_Pkg.String_Type
    ) is

--|-Algorithm:
--| Create a fixed length string
--| Output the line
--| Exit
--|+

    begin

    Put(File_Handle, String_Pkg.Value(Text));
    return;

    end Put;
                                                    pragma Page;
    procedure Put(
    Text        : in Variable_String_Array
    ) is

    begin

    for i in Text'range loop
        Put(Paginated_Standard_Output, String_Pkg.Value(Text(i)));
    end loop;
    return;

    end Put;
                                                    pragma Page;
    procedure Put(
    File_Handle : in Paginated_File_Handle;
    Text        : in Variable_String_Array
    ) is

--|-Algorithm:
--| Loop for all elements of the variable string array
--|    Create a fixed length string
--|    Output the line
--| Exit
--|+

    begin

    for i in Text'range loop
        Put(File_Handle, String_Pkg.Value(Text(i)));
    end loop;
    return;

    end Put;
                                                    pragma Page;
    procedure Space(
    Count       : in integer
    ) is

    begin

    Space(Paginated_Standard_Output,
          Count);

    end Space;
                                                    pragma Page;
    procedure Space(
    File_Handle : in Paginated_File_Handle;
    Count       : in integer
    ) is

    begin

    Check_Valid(File_Handle);
    if Count <= 0 then
        return;
    end if;
    declare
        Space_String : string (1 .. Count) := (1 .. Count => ' ');
    begin
        Put(File_Handle, Space_String);
    end;

    end Space;
                                                    pragma Page;
    procedure Put_Line(
    Text_Line   : in string
    ) is

    begin

    Write(Paginated_Standard_Output, Text_Line, true);

    end Put_Line;
                                                    pragma Page;
    procedure Put_Line(
    File_Handle : in Paginated_File_Handle;
    Text_Line   : in string
    ) is

--|-Algorithm:
--| Execute Write procedure with feed
--| Exit
--|+

    begin

    Write(File_Handle, Text_Line, true);

    end Put_Line;
                                                    pragma Page;
    procedure Put_Line(
    Text_Line   : in String_Pkg.String_Type
    ) is

    begin

    Put_Line(Paginated_Standard_Output,
         String_Pkg.Value(Text_Line));
    return;

    end Put_Line;
                                                    pragma Page;
    procedure Put_Line(
    File_Handle : in Paginated_File_Handle;
    Text_Line   : in String_Pkg.String_Type
    ) is

--|-Algorithm:
--| Create a fixed length string
--| Output the line
--| Exit
--|+

    begin

    Put_Line(File_Handle, String_Pkg.Value(Text_Line));
    return;

    end Put_Line;
                                                    pragma Page;
    procedure Put_Line(
    Text_Line   : in Variable_String_Array
    ) is

    begin

    for i in Text_Line'range loop
        Put_Line(Paginated_Standard_Output,
             String_Pkg.Value(Text_Line(i)));
    end loop;
    return;

    end Put_Line;
                                                    pragma Page;
    procedure Put_Line(
    File_Handle : in Paginated_File_Handle;
    Text_Line   : in Variable_String_Array
    ) is

--|-Algorithm:
--| Loop for all elements of the variable string array
--|    Create a fixed length string
--|    Output the line
--| Exit
--|+

    begin

    for i in Text_Line'range loop
        Put_Line(File_Handle, String_Pkg.Value(Text_Line(i)));
    end loop;
    return;

    end Put_Line;
                                                    pragma Page;
    procedure Space_Line(
    Count       : in integer := 1
    ) is

    begin

    Space_Line(Paginated_Standard_Output,
           Count);

    end Space_Line;
                                                    pragma Page;
    procedure Space_Line(
    File_Handle : in Paginated_File_Handle;
    Count       : in integer := 1
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Raise Invalid_Count if space request is too large
--| Write out the given number of new line control characters
--| while taking into account header, footer, and pagination.
--| Exit
--|+

    Handle : Paginated_File_Handle;

    begin

    Check_Valid(File_Handle);
    Handle := File_Handle;
    loop
        exit when Handle = null;
        Line_Feed(Handle, Count);
        Handle := Handle.forward_link;
    end loop;
    return;

    end Space_Line;
                                                    pragma Page;
    procedure Skip_Line(
    Count       : in integer := 1
    ) is

    begin

    Skip_Line(Paginated_Standard_Output,
          Count);

    end Skip_Line;
                                                    pragma Page;
    procedure Skip_Line(
    File_Handle : in Paginated_File_Handle;
    Count       : in integer := 1
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Set the number of new line characters to be written as the
--| number specified or the number of lines remaining on the
--| page which ever is smaller.
--| Write out this number of new line control characters
--| while taking into account header, footer, and pagination.
--| (If at the top of the page then Skip_Lines does nothing)
--| Exit
--|+

    Skip_Count : integer;
    Handle     : Paginated_File_Handle;

    begin

    Check_Valid(File_Handle);
    Handle := File_Handle;
    loop
        exit when Handle = null;
        if Handle.current_line /= 0 or Handle.page_size = 0 then
        Skip_Count := Handle.maximum_line - Handle.current_line + 1;
        if Skip_Count > Count or Handle.page_size = 0 then
            Skip_Count := Count;
        end if;
        Line_Feed(Handle, Skip_Count);
        end if;
        Handle := Handle.forward_link;
    end loop;
    return;

    end Skip_Line;
                                                    pragma Page;
    procedure Put_Page(
    Count       : in integer := 1
    ) is

    begin

    Put_Page(Paginated_Standard_Output,
         Count);

    end Put_Page;
                                                    pragma Page;
    procedure Put_Page(
    File_Handle : in Paginated_File_Handle;
    Count       : in integer := 1
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Raise Invalid_Count if page request is too large
--| Convert the number of pages to skip into number of lines
--| Write out this number of new line control characters
--| while taking into account header, footer, and pagination.
--| Exit
--|+

    Handle : Paginated_File_Handle;

    begin

    Check_Valid(File_Handle);
    Handle := File_Handle;
    loop
        exit when Handle = null;
        Page_Eject(Handle, Count);
        Handle := Handle.forward_link;
    end loop;
    return;

    end Put_Page;
                                                    pragma Page;
    function Available_Lines
    return integer is

    begin

    return Available_Lines(Paginated_Standard_Output);

    end Available_Lines;
                                                    pragma Page;
    function Available_Lines(
    File_Handle : in Paginated_File_Handle
    ) return integer is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| Return the number of lines remaining on the page
--|+

    begin

    Check_Valid(File_Handle);
    if File_Handle.page_size = 0 then
        return -1;
    end if;
    if File_Handle.current_line = 0 then
        return File_Handle.maximum_line;
    else
        return File_Handle.maximum_line - File_Handle.current_line + 1;
    end if;

    end Available_Lines;
                                                    pragma Page;
    procedure Reserve_Lines(
    Count       : in integer
    ) is

    begin

    Reserve_Lines(Paginated_Standard_Output,
              Count);

    end Reserve_Lines;
                                                                 pragma Page;
    procedure Reserve_Lines(
    File_Handle : in Paginated_File_Handle;
    Count       : in integer
    ) is

--|-Algorithm:
--| Validate paginated file structure (raise error if not valid)
--| If the requested number of lines is greater than the page size
--|    then raise an error
--| If the requested is greater than the remaining space
--|    then eject page
--| Exit
--|+

    begin

    Check_Valid(File_Handle);
    if File_Handle.page_size = 0 then
        return;
    end if;
    if Count > File_Handle.page_size then
        raise Page_Overflow;
    end if;
    if Count > Available_Lines(File_Handle) then
        Page_Eject(File_Handle, 1);
    end if;
    return;

    end Reserve_Lines;
                                                                 pragma Page;
begin

    Create_Paginated_File("", Paginated_Standard_Output, 0, 0, 0);
    Paginated_Standard_Output.standard_flag := true;

end Paginated_Output;
                                                                 pragma Page;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--SCANNER.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with String_Pkg;            use String_Pkg;
with Unchecked_Deallocation;

package body String_Scanner is


White_Space   : constant string := " " & ASCII.HT;
Number_1      : constant string := "0123456789";
Number        : constant string := Number_1 & "_";
Quote         : constant string := """";
Ada_Id_1      : constant string := "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
Ada_Id        : constant string := Ada_Id_1 & Number;

procedure Free_Scanner is
    new Unchecked_Deallocation(Scan_Record, Scanner);
                                                    pragma Page;
function Is_Valid(
    T : in Scanner
    ) return boolean is

begin

    return T /= null;

end Is_Valid;

function Make_Scanner(
    S : in String_Type
    ) return Scanner is

    T : Scanner := new Scan_Record;

begin

    T.text := String_Pkg.Make_Persistent(S);
    return T;

end Make_Scanner;

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

procedure Destroy_Scanner(
    T : in out Scanner
    ) is

begin

    if Is_Valid(T) then
    String_Pkg.Flush(T.text);
    Free_Scanner(T);
    end if;

end Destroy_Scanner;

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

function More(
    T : in Scanner
    ) return boolean is

begin

    if Is_Valid(T) then
    if T.index > String_Pkg.Length(T.text) then
        return false;
    else
            return true;
    end if;
    else
    return false;
    end if;

end More;

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

function Get(
    T : in Scanner
    ) return character is

begin

    if not More(T) then
    raise Out_Of_Bounds;
    end if;
    return String_Pkg.Fetch(T.text, T.index);

end Get;

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

procedure Forward(
    T : in Scanner
    ) is

begin

    if Is_Valid(T) then
    if String_Pkg.Length(T.text) >= T.index then
        T.index := T.index + 1;
    end if;
    end if;

end Forward;

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

procedure Backward(
    T : in Scanner
    ) is

begin

    if Is_Valid(T) then
    if T.index > 1 then
        T.index := T.index - 1;
    end if;
    end if;

end Backward;

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

procedure Next(
    T : in     Scanner;
    C :    out character
    ) is

begin

    C := Get(T);
    Forward(T);

end Next;

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

function Position(
    T : in Scanner
    ) return positive is

begin

    if not More(T) then
    raise Out_Of_Bounds;
    end if;
    return T.index;

end Position;

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

function Get_String(
    T : in Scanner
    ) return String_Type is

begin

    if Is_Valid(T) then
    return String_Pkg.Make_Persistent(T.text);
    else
    return String_Pkg.Make_Persistent("");
    end if;

end Get_String;

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

function Get_Remainder(
    T : in Scanner
    ) return String_Type is

    S_Str : String_Type;

begin

    if More(T) then
    String_Pkg.Mark;
    S_Str := String_Pkg.Make_Persistent(
    String_Pkg.Substr(T.text,
              T.index,
              String_Pkg.Length(T.text) - T.index + 1));
    String_Pkg.Release;
    else
    S_Str := String_Pkg.Make_Persistent("");
    end if;
    return S_Str;

end Get_Remainder;

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

procedure Mark(
    T : in Scanner
    ) is

begin

    if Is_Valid(T) then
    if T.mark /= 0 then
        raise Scanner_Already_Marked;
    else
        T.mark := T.index;
    end if;
    end if;

end Mark;

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

procedure Restore(
    T : in Scanner
    ) is

begin

    if Is_Valid(T) then
    if T.mark /= 0 then
        T.index := T.mark;
        T.mark  := 0;
    end if;
    end if;

end Restore;
                                                    pragma Page;
function Is_Any(
    T : in Scanner;
    Q : in string
    ) return boolean is

    N     : natural;

begin

    if not More(T) then
    return false;
    end if;
    String_Pkg.Mark;
    N := String_Pkg.Match_Any(T.text, Q, T.index);
    if N /= T.index then
    N := 0;
    end if;
    String_Pkg.Release;
    return N /= 0;

end Is_Any;
                                                     pragma Page;
procedure Scan_Any(
    T      : in     Scanner;
    Q      : in     string;
    Found  :    out boolean;
    Result : in out String_Type
    ) is

    S_Str : String_Type;
    N     : natural;

begin

    if Is_Any(T, Q) then
    N := String_Pkg.Match_None(T.text, Q, T.index);
    if N = 0 then
        N := String_Pkg.Length(T.text) + 1;
    end if;
    Result  := Result & String_Pkg.Substr(T.text, T.index, N - T.index);
    T.index := N;
    Found   := true;
    else
    Found := false;
    end if;

end Scan_Any;
                                                    pragma Page;
function Quoted_String(
    T : in Scanner
    ) return integer is

    Count : integer := 0;
    I     : positive;
    N     : natural;

begin

    if not Is_Valid(T) then
    return Count;
    end if;
    I := T.index;
    while Is_Any(T, """") loop
    T.index := T.index + 1;
    if not More(T) then
        T.index := I;
        return 0;
    end if;
    String_Pkg.Mark;
    N := String_Pkg.Match_Any(T.text, """", T.index);
    String_Pkg.Release;
    if N = 0 then
        T.index := I;
        return 0;
    end if;
    T.index := N + 1;
    end loop;
    Count := T.index - I;
    T.index := I;
    return Count;

end Quoted_String;
                                                    pragma Page;
function Enclosed_String(
    B : in character;
    E : in character;
    T : in Scanner
    ) return natural is

    Count : natural := 1;
    I     : positive;
    Inx_B : natural;
    Inx_E : natural;
    Depth : natural := 1;

begin

    if not Is_Any(T, B & "") then
    return 0;
    end if;
    I := T.index;
    Forward(T);
    while Depth /= 0 loop
    if not More(T) then
        T.index := I;
        return 0;
    end if;
    String_Pkg.Mark;
    Inx_B   := String_Pkg.Match_Any(T.text, B & "", T.index);
    Inx_E   := String_Pkg.Match_Any(T.text, E & "", T.index);
    String_Pkg.Release;
    if Inx_E = 0 then
        T.index := I;
        return 0;
    end if;
    if Inx_B /= 0 and then Inx_B < Inx_E then
        Depth := Depth + 1;
    else
        Inx_B := Inx_E;
        Depth := Depth - 1;
    end if;
    T.index := Inx_B + 1;
    end loop;
    Count := T.index - I;
    T.index := I;
    return Count;

end Enclosed_String;
                                                     pragma Page;
function Is_Word(
    T : in Scanner
    ) return boolean is

begin

    if not More(T) then
    return false;
    else
    return not Is_Any(T, White_Space);
    end if;

end Is_Word;

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

procedure Scan_Word(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    S_Str : String_Type;
    N     : natural;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Word(T) then
    String_Pkg.Mark;
    N := String_Pkg.Match_Any(T.text, White_Space, T.index);
    if N = 0 then
        N := String_Pkg.Length(T.text) + 1;
    end if;
    Result  := String_Pkg.Make_Persistent
           (String_Pkg.Substr(T.text, T.index, N - T.index));
    T.index := N;
    Found   := true;
    String_Pkg.Release;
    else
    Found   := false;
    end if;
    return;

end Scan_Word;
                                                    pragma Page;
function Is_Number(
    T : in Scanner
    ) return boolean is

begin

    return Is_Any(T, Number_1);

end Is_Number;

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

procedure Scan_Number(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    C     : character;
    S_Str : String_Type;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if not Is_Number(T) then
    Found := false;
    return;
    end if;
    String_Pkg.Mark;
    while Is_Number(T) loop
    Scan_Any(T, Number_1, Found, S_Str);
    if More(T) then
        C := Get(T);
        if C = '_' then
        Forward(T);
        if Is_Number(T) then
            S_Str := S_Str & "_";
        else
            Backward(T);
        end if;
        end if;
    end if;
    end loop;
    Result := String_Pkg.Make_Persistent(S_Str);
    String_Pkg.Release;

end Scan_Number;

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

procedure Scan_Number(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out integer;
    Skip   : in     boolean := false
    ) is

    F     : boolean;
    S_Str : String_Type;

begin

    Scan_Number(T, F, S_Str, Skip);
    if F then
    Result := integer'value(String_Pkg.Value(S_Str));
    end if;
    Found := F;

end Scan_Number;
                                                    pragma Page;
function Is_Signed_Number(
    T : in Scanner
    ) return boolean is

    I : positive;
    C : character;
    F : boolean;

begin

    if More(T) then
    I := T.index;
    C := Get(T);
    if C = '+' or C = '-' then
        T.index := T.index + 1;
    end if;
    F := Is_Any(T, Number_1);
    T.index := I;
    return F;
    else
    return false;
    end if;

end Is_Signed_Number;

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

procedure Scan_Signed_Number(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    C     : character;
    S_Str : String_Type;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Signed_Number(T) then
    C := Get(T);
    if C = '+' or C = '-' then
        Forward(T);
    end if;
    Scan_Number(T, Found, S_Str);
    String_Pkg.Mark;
    if C = '+' or C = '-' then
        Result := String_Pkg.Make_Persistent(("" & C) & S_Str);
    else
        Result := String_Pkg.Make_Persistent(S_Str);
    end if;
    String_Pkg.Release;
    String_Pkg.Flush(S_Str);
    else
    Found := false;
    end if;

end Scan_Signed_Number;

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

procedure Scan_Signed_Number(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out integer;
    Skip   : in     boolean := false
    ) is

    F     : boolean;
    S_Str : String_Type;

begin

    Scan_Signed_Number(T, F, S_Str, Skip);
    if F then
    Result := integer'value(String_Pkg.Value(S_Str));
    end if;
    Found := F;

end Scan_Signed_Number;
                                                    pragma Page;
function Is_Space(
    T : in Scanner
    ) return boolean is

begin

    return Is_Any(T, White_Space);

end Is_Space;

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

procedure Scan_Space(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type
    ) is

    S_Str : String_Type;

begin

    String_Pkg.Mark;
    Scan_Any(T, White_Space, Found, S_Str);
    Result := String_Pkg.Make_Persistent(S_Str);
    String_Pkg.Release;

end Scan_Space;

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

procedure Skip_Space(
    T : in Scanner
    ) is

    S_Str : String_Type;
    Found : boolean;

begin

    String_Pkg.Mark;
    Scan_Any(T, White_Space, Found, S_Str);
    String_Pkg.Release;

end Skip_Space;
                                                    pragma Page;
function Is_Ada_Id(
    T : in Scanner
    ) return boolean is

begin

    return Is_Any(T, Ada_Id_1);

end Is_Ada_Id;

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

procedure Scan_Ada_Id(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    C     : character;
    F     : boolean;
    S_Str : String_Type;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Ada_Id(T) then
    String_Pkg.Mark;
    Next(T, C);
    Scan_Any(T, Ada_Id, F, S_Str);
    Result := String_Pkg.Make_Persistent(("" & C) & S_Str);
    Found := true;
    String_Pkg.Release;
    else
    Found := false;
    end if;

end Scan_Ada_Id;
                                                    pragma Page;
function Is_Quoted(
    T : in Scanner
    ) return boolean is

begin

    if Quoted_String(T) = 0 then
    return false;
    else
    return true;
    end if;

end Is_Quoted;

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

procedure Scan_Quoted(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    Count : integer;

begin

    if Skip then
    Skip_Space(T);
    end if;
    Count := Quoted_String(T);
    if Count /= 0 then
    Count := Count - 2;
    T.index := T.index + 1;
    if Count /= 0 then
        String_Pkg.Mark;
        Result := String_Pkg.Make_Persistent
              (String_Pkg.Substr(T.text, T.index, positive(Count)));
        String_Pkg.Release;
    else
        Result := String_Pkg.Make_Persistent("");
    end if;
    T.index := T.index + Count + 1;
    Found := true;
    else
    Found := false;
    end if;

end Scan_Quoted;
                                                    pragma Page;
function Is_Enclosed(
    B : in character;
    E : in character;
    T : in Scanner
    ) return boolean is

begin

    if Enclosed_String(B, E, T) = 0 then
    return false;
    else
    return true;
    end if;

end Is_Enclosed;

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

procedure Scan_Enclosed(
    B      : in     character;
    E      : in     character;
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    Count : natural;

begin

    if Skip then
    Skip_Space(T);
    end if;
    Count := Enclosed_String(B, E, T);
    if Count /= 0 then
    Count := Count - 2;
    T.index := T.index + 1;
    if Count /= 0 then
        String_Pkg.Mark;
        Result := String_Pkg.Make_Persistent(String_Pkg.Substr(T.text, T.index, positive(Count)));
        String_Pkg.Release;
    else
        Result := String_Pkg.Make_Persistent("");
    end if;
    T.index := T.index + Count + 1;
    Found := true;
    else
    Found := false;
    end if;

end Scan_Enclosed;
                                                    pragma Page;
function Is_Sequence(
    Chars  : in String_Type;
    T      : in Scanner
    ) return boolean is

begin

    return Is_Any(T, String_Pkg.Value(Chars));

end Is_Sequence;

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

function Is_Sequence(
    Chars  : in string;
    T      : in Scanner
    ) return boolean is

begin

    return Is_Any(T, Chars);

end Is_Sequence;

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

procedure Scan_Sequence(
    Chars  : in     String_Type;
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    I     : positive;
    Count : integer := 0;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if not Is_Valid(T) then
    Found := false;
    return;
    end if;
    I := T.index;
    while Is_Any(T, Value(Chars)) loop
    Forward(T);
    Count := Count + 1;
    end loop;
    if Count /= 0 then
    String_Pkg.Mark;
    Result := String_Pkg.Make_Persistent
          (String_Pkg.Substr(T.text, I, positive(Count)));
    Found  := true;
    String_Pkg.Release;
    else
    Found := false;
    end if;

end Scan_Sequence;

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

procedure Scan_Sequence(
    Chars  : in     string;
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

begin

    String_Pkg.Mark;
    Scan_Sequence(String_Pkg.Create(Chars), T, Found, Result, Skip);
    String_Pkg.Release;

end Scan_Sequence;
                                                    pragma Page;
function Is_Not_Sequence(
    Chars  : in String_Type;
    T      : in Scanner
    ) return boolean is

    N : natural;

begin

    if not Is_Valid(T) then
    return false;
    end if;
    String_Pkg.Mark;
    N := String_Pkg.Match_Any(T.text, Chars, T.index);
    if N = T.index then
    N := 0;
    end if;
    String_Pkg.Release;
    return N /= 0;

end Is_Not_Sequence;

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

function Is_Not_Sequence(
    Chars  : in string;
    T      : in Scanner
    ) return boolean is

begin

    return Is_Not_Sequence(String_Pkg.Create(Chars), T);

end Is_Not_Sequence;

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

procedure Scan_Not_Sequence(
    Chars  : in     string;
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    N     : natural;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Not_Sequence(Chars, T) then
    String_Pkg.Mark;
    N := String_Pkg.Match_Any(T.text, Chars, T.index);
    Result := String_Pkg.Make_Persistent
          (String_Pkg.Substr(T.text, T.index, N - T.index));
    T.index := N;
    Found   := true;
    String_Pkg.Release;
    else
    Found := false;
    end if;

end Scan_Not_Sequence;

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

procedure Scan_Not_Sequence(
    Chars  : in     String_Type;
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

begin

    Scan_Not_Sequence(String_Pkg.Value(Chars), T, Found, Result, Skip);

end Scan_Not_Sequence;
                                                    pragma Page;
function Is_Literal(
    Chars  : in String_Type;
    T      : in Scanner
    ) return boolean is

    N : natural;

begin

    if not Is_Valid(T) then
    return false;
    end if;
    String_Pkg.Mark;
    N := String_Pkg.Match_S(T.text, Chars, T.index);
    if N /= T.index then
    N := 0;
    end if;
    String_Pkg.Release;
    return N /= 0;

end Is_Literal;

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

function Is_Literal(
    Chars  : in string;
    T      : in Scanner
    ) return boolean is

    Found : boolean;

begin

    String_Pkg.Mark;
    Found := Is_Literal(String_Pkg.Create(Chars), T);
    String_Pkg.Release;
    return Found;

end Is_Literal;

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

procedure Scan_Literal(
    Chars  : in     String_Type;
    T      : in     Scanner;
    Found  :    out boolean;
    Skip   : in     boolean := false
    ) is

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Literal(Chars, T) then
    T.index := T.index + String_Pkg.Length(Chars);
    Found   := true;
    else
    Found   := false;
    end if;

end Scan_Literal;

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

procedure Scan_Literal(
    Chars  : in     string;
    T      : in     Scanner;
    Found  :    out boolean;
    Skip   : in     boolean := false
    ) is

begin

    String_Pkg.Mark;
    Scan_Literal(String_Pkg.Create(Chars), T, Found, Skip);
    String_Pkg.Release;

end Scan_Literal;
                                                    pragma Page;
function Is_Not_Literal(
    Chars : in string;
    T     : in Scanner
    ) return boolean is

    N     : natural;

begin

    if not Is_Valid(T) then
    return false;
    end if;
    String_Pkg.Mark;
    N := String_Pkg.Match_S(T.text, Chars, T.index);
    if N = T.index then
    N := 0;
    end if;
    String_Pkg.Release;
    return N /= 0;

end Is_Not_Literal;

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

function Is_Not_Literal(
    Chars : in String_Type;
    T     : in Scanner
    ) return boolean is

begin

    if not More(T) then
    return false;
    end if;
    return Is_Not_Literal(String_Pkg.Value(Chars), T);

end Is_Not_Literal;

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

procedure Scan_Not_Literal(
    Chars  : in     string;
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    N : natural;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Not_Literal(Chars, T) then
    String_Pkg.Mark;
    N := String_Pkg.Match_S(T.text, Chars, T.index);
    Result := String_Pkg.Make_Persistent(String_Pkg.Substr(T.text, T.index, N - T.index));
    T.index := N;
    Found   := true;
    String_Pkg.Release;
    else
    Found := false;
    return;
    end if;

end Scan_Not_Literal;

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

procedure Scan_Not_Literal(
    Chars  : in     String_Type;
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

begin

    Scan_Not_Literal(String_Pkg.Value(Chars), T, Found, Result, Skip);

end Scan_Not_Literal;


end String_Scanner;
                                                    pragma Page;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--SORT.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/abstractions/sort/RCS/sort.spc,v $
-- $Revision: 1.2 $ -- $Date: 85/01/31 16:43:49 $ -- $Author: ron $

-- $Source: /nosc/work/abstractions/sort/RCS/sort.spc,v $
-- $Revision: 1.2 $ -- $Date: 85/01/31 16:43:49 $ -- $Author: ron $

generic
    type item_type is private;
        --| Component type of array to be sorted.

    with function "<="(x, y: item_type) return boolean;
        --| Required to totally order item_type;

    type index_type is (<>);
        --| Index type of array to be sorted.

    type sequence is array(index_type range <>) of item_type;
        --| Type of array to be sorted.

procedure heap_sort(s: in out sequence);
    --| Overview:
    --| Heap sort is an O(n lg n) guaranteed time sorting algorithm.
    --| This procedure provides heap sort for arrays of arbitrary index
    --| and component type.

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

    --| Effects:
    --|     Let s1 and s2 denote the value of s before and after an
    --| invocation of heap_sort.  Then s1 and s2 have the following
    --| properties:
    --|   1. For i,j in s'range, i <= j implies that s2(i) <= s2(j).
    --|   2. s2(s'first) through s2(s'last) is a permutation of
    --|      s1(s'first) through s1(s'last).
    --|
    --| Requires:
    --|     <= must form a total order over item_type.
    --|
    --| Algorithm:
    --|     The algorithm is described in Knuth, vol 3, and Aho et al,
    --| The Design and Analysis of Computer Algorithms.

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--SORT.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/abstractions/sort/RCS/sort.bdy,v $
-- $Revision: 1.2 $ -- $Date: 85/02/01 10:10:41 $ -- $Author: ron $

-- $Source: /nosc/work/abstractions/sort/RCS/sort.bdy,v $
-- $Revision: 1.2 $ -- $Date: 85/02/01 10:10:41 $ -- $Author: ron $

procedure heap_sort(s: in out sequence) is

--| Notes:
--| Implementation is taken directly from The Design and Analysis of
--| Computer Algorithms, by Aho, Hopcroft and Ullman.  The only change
--| of any significance is code to map between the index_type subrange
--| defined by the sequence bounds and the subrange, 1..s'length, of
--| the integers.  This mapping is necessary because the algorithm
--| represents binary trees as an array such that the sons of s(i) are
--| located at s(2i) and s(2i + 1).

    subtype int_range is integer range 1..s'length;

    function int_range_to_index(i: int_range)
        return index_type is
      --| Effects:
      --| Map 1 --> s'first, ..., s'length --> s'last.
    begin
        return index_type'val(i + index_type'pos(s'first) - 1);
    end int_range_to_index;

    function index_to_int_range(i: index_type)
        return int_range is
      --| Effects:
      --| Map s'first --> 1, ..., s'last --> s'length.
    begin
        return (index_type'pos(i) - index_type'pos(s'first) + 1);
    end index_to_int_range;

    procedure swap(i, j: index_type) is
      --| Effects:
      --| Exchange the values of s(i) and s(j).

        t: item_type := s(i);
    begin
        s(i) := s(j);
        s(j) := t;
    end swap;

    procedure heapify(root, boundary: index_type) is
      --| Effects:
      --|     Give s(root..boundary) the heap property:
      --|        s(i) > s(2i) and s(i) > s(2i + 1).
      --| (provided that 2i, 2i + 1 are less than boundary.  Note that
      --| the property is being expressed in terms of the integer range,
      --| 1..s'last.)
      --| Requires:
      --|     s(i + 1, ..., boundary) already has the heap property.

        max: index_type := root;
        boundary_position: int_range := index_to_int_range(boundary);
        left_son_position: integer := 2 * index_to_int_range(root);
        right_son_position: integer := 2 * index_to_int_range(root) + 1;
        left_son: index_type;
        right_son: index_type;
    begin
        -- If root is not a leaf, and if a son of root contains a larger
        -- value than the root value, then let max be the son with the
        -- largest value.

        if left_son_position <= boundary_position then    -- has left son?
            left_son := int_range_to_index(left_son_position);
            if s(root) <= s(left_son) then
                max := left_son;
            end if;
        else
            return;   -- no sons, meets heap property trivially.
        end if;

        if right_son_position <= boundary_position then  -- has right son?
            right_son := int_range_to_index(right_son_position);
            if s(max) <= s(right_son) then              -- biggest so far?
                max := right_son;
            end if;
        end if;

        if max /= root then          -- If a larger son found then
            swap(root, max);         -- carry out exchange and
            heapify(max, boundary);  -- propagate heap propery to subtree
        end if;
    end heapify;

    procedure build_heap is
      --| Effects:
      --| Give all of s the heap property.

        mid: index_type :=
                 int_range_to_index(index_to_int_range(s'last)/2);
    begin
        for i in reverse s'first..mid loop
            heapify(i, s'last);
        end loop;
    end build_heap;

begin
    -- Make s into a heap.  Then, repeat until sorted:
    --   1. exchange the largest element, located at the root, with the
    --      last element that has not yet been ordered, and
    --   2. reheapify the unsorted portion of s.

    build_heap;
    for i in reverse index_type'succ(s'first)..s'last loop
        swap(s'first, i);
        heapify(s'first, index_type'pred(i));
    end loop;

exception
    when constraint_error =>    -- On succ(s'first) for array of length <= 1.
        return;                 -- Such arrays are trivially sorted.
end heap_sort;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--STACK.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/abstractions/stack/RCS/stack.spc,v $
-- $Revision: 1.5 $ -- $Date: 85/02/01 09:57:17 $ -- $Author: ron $

-- $Source: /nosc/work/abstractions/stack/RCS/stack.spc,v $
-- $Revision: 1.5 $ -- $Date: 85/02/01 09:57:17 $ -- $Author: ron $

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

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--STACK.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/abstractions/stack/RCS/stack.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:19:36 $ -- $Author: ron $

-- $Source: /nosc/work/abstractions/stack/RCS/stack.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:19:36 $ -- $Author: ron $

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


  -- Queries:

    function top(s: 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: stack)
        return natural is
    begin
        return s.size;
    exception
        when constraint_error =>
        raise uninitialized_stack;
    end size;

    function is_empty(s: 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;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--STRING.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- $Source: /nosc/work/abstractions/string/RCS/string.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:58:51 $ -- $Author: ron $

-- $Source: /nosc/work/abstractions/string/RCS/string.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:58:51 $ -- $Author: ron $

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: 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: string; start: 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: 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: 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: string_type; s2: string)
        return string_type is
    begin
    if s1 = null then return create(s2); end if;
    return create(s1.all & s2);
    end "&";

    function "&"(s1: string; s2: 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: string_type; i: positive; len: 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: string_type; i: positive; len: 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: string_type; i: 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: string_type; s2: string; i: 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: string; s2: string_type; i: 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: 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: string_type)
    return string_type is
    begin
    if s = null then return null; end if;
    return lower(s.all);
    end lower;

    function upper(s: 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: 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: 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: 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: string_type)
        return boolean is
    begin
        return (s = null) or else (s.all = "");
    end is_empty;

    function length(s: string_type)
        return natural is
    begin
    if s = null then return 0; end if;
        return(s.all'length);
    end length;

    function value(s: 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: string_type; i: 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: 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: string_type; s2: string)
        return boolean is
    begin
    if s1 = null then return s2 = ""; end if;
        return s1.all = s2;
    end equal;

    function equal(s1: string; s2: string_type)
        return boolean is
    begin
    if s2 = null then return s1 = ""; end if;
        return s1 = s2.all;
    end equal;

    function "<"(s1: string_type; s2: 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: string_type; s2: string)
        return boolean is
    begin
    if s1 = null then return s2 /= ""; end if;
        return s1.all < s2;
    end "<";

    function "<"(s1: string; s2: string_type)
        return boolean is
    begin
    if s2 = null then return false; end if;
        return s1 < s2.all;
    end "<";

    function "<="(s1: string_type; s2: 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: string_type; s2: string)
        return boolean is
    begin
    if s1 = null then return true; end if;
        return s1.all <= s2;
    end "<=";

    function "<="(s1: string; s2: string_type)
        return boolean is
    begin
    if s2 = null then return s1 = ""; end if;
        return s1 <= s2.all;
    end "<=";

    function match_c(s: string_type; c: character; start: 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: string_type; c: character; start: 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: string_type; start: 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: string_type; s2: string; start: 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: string_type; start: 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: string_type; any: string; start: 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: string_type; start: 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: string_type; none: string; start: 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: 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: string; start: 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;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--BTREES.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

with Lists;
generic

    type ItemType is private;
                       --| Information being contained in a node of tree


    with function "<"(X,Y: in ItemType) return boolean;
                       --| Function which defines ordering of nodes

package BinaryTrees is


--| Overview
--| This package creates an ordered binary tree.  This will allow for
--| quick insertion, and search.
--|
--| The tree is organized such that
--|
--|  leftchild < root    root < rightchild
--|
--| This means that by doing a left to right search of the tree will can
--| produce the nodes of the tree in ascending order.





--                             Types
--                             -----

type Tree is  private;     --| This is the type exported to represent the
                           --| tree.


type TreeIter is private;  --| This is the type which is used to iterate
                           --| over the set.

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

--|                          Operations
--|                          ----------
--|
--| Create           Creates a tree.
--| Deposit          Replaces the given node's information with
--|                  the given information.
--| DestroyTree      Destroys the given tree and returns the spaces.
--| InsertNode       This inserts a node n into a tree t.
--| MakeTreeIter     This returns an iterator to the user in order to start
--|                  an iteration.
--| More             This returns true if there are more elements to iterate
--|                  over in the tree.
--| Next             This returns the information associated with the current
--|                  iterator and advances the iterator.


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

function Create             --| This function creates the tree.

return Tree;

--| Effects
--| This creates a tree containing no information and no children.  An
--| emptytree.

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

procedure Deposit (              --| This deposits the information I in the
                                 --| root of the Tree S.
          I :in     ItemType;    --| The information being deposited.
          S :in     Tree         --| The tree where the information is being
                                 --| stored.
);

--| Modifies
--| This changes the information stored at the root of the tree S.

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


procedure DestroyTree (         --| Destroys a tree.
          T  :in out Tree       --| Tree being destroyed.
);

--| Effects
--| Destroys a tree and returns the space which it is occupying.

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

Procedure Insertnode(           --| This Procedure Inserts A Node Into The
                                --| Specified Tree.
       N      :In Out Itemtype; --| The Information To Be Contained In The
                                --| Node Being Inserted.

       T      :In Out Tree;     --| Tree Being Inserted Into.
       Root   :   Out Tree;     --| Root of the subtree which Node N heads.
                                --| This is the position of the node N in T.
       Exists :   out boolean   --| If this node already exists in the tree
                                --| Exists is true.  If this is the first
                                --| insertion Exists is false.
);

--| Effects
--| This adds the node N to the tree T inserting in the proper postion.

--| Modifies
--| This modifies the tree T by add the node N to it.

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

function MakeTreeIter (         --| Sets a variable to a position in the
                                --| tree
                                --| where the iteration is to begin.  In this
                                --| case the position is a pointer to the
                                --| the deepest leftmost leaf in the tree.
        T:in Tree               --| Tree being iterated over
) return TreeIter;


--| Effects


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

function More (                 --| Returns true if there are more elements
                                --| in the tree to iterate over.
          I :in TreeIter
) return boolean;


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

procedure Next (                --| This is the iterator operation.  Given
                                --| an Iter in the Tree it returns the
                                --| item Iter points to and updates the
                                --| iter. If Iter is at the end of the Tree,
                                --| yielditer returns false otherwise it
                                --| returns true.
    I        :in out TreeIter;  --| The iter which marks the position in the
                                --| Tree.

    Info     :   out ItemType   --| Information being returned from a node.
);


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

private

   type Node;
   type Tree is access Node;

   type Node is
        record
            Info           :ItemType;
            LeftChild      :Tree;
            RightChild     :Tree;
        end record;

   package NodeOrder is new Lists (Tree);


   type TreeIter is
      record
          NodeList :NodeOrder.List;
          State    :NodeOrder.ListIter;
      end record;


end BinaryTrees;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--BTREES.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

with unchecked_deallocation;

package body Binarytrees is

----------------------------------------------------------------------------
--                   Local Subprograms
----------------------------------------------------------------------------

procedure Free is new unchecked_deallocation (Node, Tree);

function equal (X, Y: in ItemType) return boolean is

begin

    return (not (X < Y))  and  (not (Y < X));
end;

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

function generate (T :in Tree ) return  Nodeorder.List is
    L : Nodeorder.List;

--| This routine generates a list of pointers to nodes in the tree t.
--| The list is ordered with respect to the order of the nodes in the tree.

--| generate does a depth first search of the tree.
--| 1.   It first visits the leftchild of t and generates the list for that.
--| 2.   It then appends the root node of t to the list generated for the left
--|      child.
--| 3.   It then appends the list generated for the rightchild to the list
--|      generated for the leftchild and the root.
--|

begin
    L := NodeOrder.Create;
    if T /= null then
        L := Generate (T.Leftchild);
        Nodeorder.Attach (L, T);
        Nodeorder.Attach (L, Generate (T.Rightchild));
    end if;
    return L;
End Generate;

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



------------------------------------------------------------------------------
--                    Visible Subprograms
------------------------------------------------------------------------------





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

function Create  return Tree is

begin
    return null;
end;

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

procedure Deposit (
          I :in      ItemType;
          S :in      Tree         ) is

begin
    S.Info := I;
end;

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

procedure DestroyTree ( T :in out Tree) is

--| This procedure recursively destroys the tree T.
--|  1.  It destroy the leftchild of T
--|  2.  It then destroys the rightchild of T.
--|  3.  It then destroy the root T and set T to be null.

begin
    if T.leftchild /= null then
     DestroyTree (T.leftchild);
     DestroyTree (T.rightchild);
     Free (T);
end if;
end DestroyTree;

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

procedure InsertNode (
        N           :in out ItemType;    --| Node being inserted.
        T           :in out Tree;        --| Tree node is being inserted
                                         --| into.
        Root        :   out Tree;        --| Root of the subtree which node N
                                         --| heads.  This is the position of
                                         --| node N in T;
        Exists      :   out boolean      --| If this node already exists in
                                         --| the tree then Exists is true. If
                                         --| If this is the first insertion
                                         --| Exists is false.

                                                                       ) is
--| This inserts the node N in T.
--| 1.  If T is null then a new node is allocated and assigned to T
--| 2.  If T is not null then T is searched for the proper place to insert n.
--|     This is first done by checking whether N < rightchild
--| 3.  If this is not true then we check to see if leftchild < N
--| 4.  If this is not true then N is in the tree.

begin
    if T = null then
        T := new Node ' (Info => N, leftchild => null, rightchild => null);
        Root := T;
        Exists := false;
        N := T.Info;
    elsif N < T.Info then
        InsertNode (N, T.leftchild, Root, Exists);
    elsif T.Info < N then
        InsertNode (N, T.rightchild, Root, Exists);
    else
        Root := T;
        Exists := true;
        N := T.Info;

    end if;
end InsertNode;

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

function MakeTreeIter (T :in     Tree ) return TreeIter is

    I :TreeIter;
--| This sets up the iterator for a tree T.
--| The NodeList keeps track of the order of the nodes of T.  The NodeList
--| is computed by first invoking Generate of the leftchild then append
--| the root node to NodeList and then append the result of Generate
--| to NodeList.  Since the tree is ordered such that
--|
--|    leftchild < root    root < rightchild
--|
--| NodeOrder returns the nodes in ascending order.
--|
--| Thus NodeList keeps the list alive for the duration of the iteration
--| operation.  The variable State is the a pointer into the NodeList
--| which is the current place of the iteration.

begin
    I.NodeList := NodeOrder.Create;
    if T /= null then
        I.NodeList := Generate (T.leftchild);
        NodeOrder.Attach (I.NodeList, T);
        NodeOrder.Attach (I.NodeList, Generate (T.rightChild));
    end if;
    I.State := NodeOrder.MakeListIter (I.NodeList);
    return I;
end;

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

function More (I :in TreeIter) return boolean is

begin
    return NodeOrder.More (I.State);
end;

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

procedure Next (
          I    :in out TreeIter;
          Info :   out ItemType       ) is
  T: Tree;

--| Next returns the information at the current position in the iterator
--| and increments the iterator.  This is accomplished by using the iterater
--| associated with the NodeOrder list.  This returns a pointer into the Tree
--| and then the information found at this node in T is returned.


begin
    NodeOrder.Next (I.State, T);
    Info := T.Info;
end;

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

end BinaryTrees;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--ORDSET.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with BinaryTrees;

generic
      type ItemType is private;
        --| Information being contained a the member of the set.

      with function "<" (X, Y :in    ItemType) return boolean;

package OrderedSets is

--| Overview
--| This abstractions is a counted ordered set.  This means that
--| associated with each member of the set is a count of the number of
--| times it appears in the set.  The order part means that there is
--| an ordering associated with the members.  This allows fast insertion.
--| It also makes it easy to iterate over the set in order.



--                    Types
--                    -----

      type Set is private;  --| This is the type exported to represent
                            --| the ordered set.

      type SetIter is private;  --| This is the type exported whose
                                --| purpose is to walk over a set.


--                   Operations
--                   ----------

--| Cardinality              Returns cardinality of the set.
--| Create                   Creates the empty set.
--| CountMember              Returns the number of times the member appears in
--|                          the set.
--| Destroy                  Destroys a set and returns the space it occupies.
--| Insert                   Insert a member into  the set.
--| MakeSetIter              Return a SetIter which will begin an iteration.
--| More                     Are there more elements to iterate over in the
--|                          set.
--| Next                     Return the next element in the iteration and
--|                          bump the iterator.


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

function Cardinality (   --| Return the number of members in the set.
         S     :in Set   --| The set whose members are being counted.
) return natural;

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


function Create   --| Return the empty set.
return Set;

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

procedure Destroy (        --| Destroy a set and return its space.
          S   :in out Set  --| Set being destroyed.

);

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

function GetCount (            --| This returns the count associated with
                               --| member which corresponds to the current
                               --| iterator I.
         I :in     SetIter
) return natural;

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

procedure Insert (             --| Insert a member M into set S.
         M :in     ItemType;   --| Member being inserted.
         S :in out Set         --| Set being inserted into.
);

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

function MakeSetIter (      --| Prepares a user for an iteration operation by
                            --| by returning a SetIter.
         S :in     Set     --| Set being iterate over.
) return SetIter;

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

function More (             --| Returns true if there are more elements in the
                            --| set to iterate over.
         I :in    SetIter   --| The iterator.

) return boolean;

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

procedure Next (              --| Returns the current member in the iteration
                              --| an increments the iterator.
         I :in out SetIter;   --| The iterator.
         M :   out ItemType   --| The current member being returned.
);

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

private

   type Member is
       record
         Info   :ItemType;
         Count  :natural;
       end record;

   function "<" (
            X:in    Member;
            Y:in    Member
   ) return boolean;

   package TreePkg is new BinaryTrees ( ItemType => Member, "<" => "<" );

   type Set is
       record
         SetRep :TreePkg.Tree;
       end record;

   type SetIter is
       record
         Place :TreePkg.TreeIter;
         Count :natural;
       end record;

end OrderedSets;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--ORDSET.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package body OrderedSets is
-------------------------------------------------------------------------------
--                Local Subprograms
-------------------------------------------------------------------------------

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

function "<" (     --| Implements "<" for the type member.
         X :in   Member;
         Y :in   Member
) return boolean is

begin
     return X.Info < Y.Info;
end;

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


-------------------------------------------------------------------------------
--               Visible Subprograms
-------------------------------------------------------------------------------


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

function Cardinality (
              S :in Set  --| The set whose size is being computed.
) return natural is

    T        :TreePkg.TreeIter;
    M        :Member;
    count    :natural := 0;
begin
    T := TreePkg.MakeTreeIter (S.SetRep);
    while TreePkg.More (T) loop
        TreePkg.Next (T, M);
        count := count + 1;
    end loop;
    return count;
end Cardinality;

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

function Create

return Set is
    S :Set;
begin
    S.SetRep := TreePkg.Create;
    return S;
end Create;

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

procedure Destroy (
         S :in out Set
) is

begin
    TreePkg.DestroyTree (S.SetRep);
end Destroy;

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

function GetCount (
         I :in    SetIter
) return natural is

begin
     return I.Count;
end;

-----------------------------------------------------------------------------
procedure Insert(
          M :in     ItemType;
          S :in out Set
) is
    Subtree       :TreePkg.Tree;
    Exists        :boolean;
    MemberToEnter :Member := ( Info => M, count => 1);
begin
    --| If NewMember doesn't exist in SetRep it is added.  If it does exist
    --| Exists comes back true and then M's count is updated.  Since the
    --| first argument of TreePkg.Insert is in out, after Insert
    --| MemberToEnter has the value stored in the tree.  Thus if we
    --| need to update the count we can simple bump the count in MemberToEnter.

    TreePkg.InsertNode (MemberToEnter, S.SetRep, SubTree, Exists);
    if Exists then
        MemberToEnter.Count := MemberToEnter.Count + 1;
        TreePkg.Deposit (MemberToEnter, SubTree);
    end if;
end Insert;

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

function MakeSetIter (
         S :in Set
)        return SetIter is

    I :SetIter;
begin
    I.Place := TreePkg.MakeTreeIter (S.SetRep);
    I.Count := 0;
    return I;
end;

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

function More (
          I :in     SetIter
)         return boolean is

begin
    return TreePkg.More (I.Place);
end;

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

procedure Next (
         I :in out SetIter;
         M :   out ItemType
) is
    TempMember :Member;
begin
    TreePkg.Next (I.Place, TempMember);
    M := TempMember.Info;
    I.Count := TempMember.Count;
end;

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

end OrderedSets;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--LEX.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

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

with Host_Dependencies;         -- Host dependents constants
with Lex_Identifier_Token_Value;
                                -- contains data structures and subprogram
                                --    to distinguish identifiers from
                                --    reserved words
with Lexical_Error_Message;     -- outputs error messages.
with ParseTables;               -- tables from parser generator
use ParseTables;
with Grammar_Constants;         -- constants from the parser generator
use Grammar_Constants;
with TEXT_IO;


package body Lex is

--| Overview
--|
--| Package Lex is implemented as a state machine via case statements.
--| The implementation is optimized to minimize the number of times
--| each character is handled.  Each character is handled twice: once
--| on input and once on lexing based on the character.
--|
--| The algorithm depends on having an End_Of_Line_Character
--| terminate each source file line.  This concludes the final token
--| on the line for the case statement scanners.

--| Notes
--|
--| Abbreviations Used:
--|
--| Char : Character
--| CST  : Current_Source_Token
--| gram : grammar
--| sym  : symbol
--| val  : value
--| RW   : Reserved Word
--|

    use ParserDeclarations;
    package LEM  renames Lexical_Error_Message;
    package PT   renames ParseTables;
    package GC   renames Grammar_Constants;
    -- other package renames are in the package spec

    ------------------------------------------------------------------
    -- Character Types
    ------------------------------------------------------------------

    subtype Graphic_Character
        is character range ' ' .. ASCII.TILDE;

    subtype Upper_Case_Letter
        is character range 'A'..'Z';

    subtype Lower_Case_Letter
        is character range ASCII.LC_A .. ASCII.LC_Z;

    subtype Digit
        is character range '0'..'9';

    subtype Valid_Base_Range is GC.ParserInteger
        range 2..16;

    subtype End_Of_Line_Character
        is character range ASCII.LF .. ASCII.CR;

    ------------------------------------------------------------------
    -- Source position management
    ------------------------------------------------------------------

    Current_Column :  HD.Source_Column := 1;
    Current_Line   :  HD.Source_Line   := 1;
    --| the position of Next_Char in the source file.
    --| Visible so the Lexical_Error_message package can use them.

    ------------------------------------------------------------------
    -- Source Input Buffers and their Management
    ------------------------------------------------------------------

    Next_Char : character := ' ';    --| input buffer for next character
                                     --| to scan from source file

    End_Of_Line_Buffer :             --| character that signals end of
                                     --| line buffer
        constant character := End_Of_Line_Character'First;

    subtype Line_Buffer_Range is
        positive range 1..(( HD.Source_Column'Last) + 2);
    --| The first extra element is needed to hold the End_Of_Line_Buffer
    --| character. The second extra element allows Line_Buffer_Index
    --| to exceed Line_Buffer_Last.

    Line_Buffer : string (Line_Buffer_Range) := (-- 1 =>
        End_Of_Line_Buffer, others => ' ');
    --| input buffer containing source file line being lexed.

    Line_Buffer_Last : HD.Source_Column := Line_Buffer'First;
    --| length of source file line being lexed.

    Line_Buffer_Index : Line_Buffer_Range;
    --| index of character being lexed.

    End_Of_File_Reached : boolean := false;
    --| true when end of the input source has been reached

    ------------------------------------------------------------------
    -- Token to be Returned and its Management
    ------------------------------------------------------------------

    CST : PD.ParseStackElement;    --| token being assembled for return by
                                   --| subprogram GetNextSourceToken

    subtype CST_Initialization_Type is PD.ParseStackElement;

    CST_Initializer : CST_Initialization_Type;
    --| short cut to initializing discriminants properly

    End_Of_File_Token : CST_Initialization_Type;

    ------------------------------------------------------------------
    -- Other objects
    ------------------------------------------------------------------

    Exit_After_Get_Next_Char : boolean := false;
    --| true; call Get_Next_Char before exiting, so that
    --| Next_Char contains the next character to be scanned.
    --| This object is not located in subprogram GetNextSourceToken,
    --| to save the time of re-elaboration on each call.

    Previous_Token_Value : PT.TokenRange := PT.StringTokenValue;
    --| used to resolve tick use as a token in T'('a') versus
    --| use as a delimiter in a character literal.

    Source_File : TEXT_IO.FILE_TYPE;

    ------------------------------------------------------------------
    -- Declarations for Scan_Numeric_Literal and Scan_Comment
    ------------------------------------------------------------------

    Temp_Source_Text : PD.Source_Text; --| temporary to hold value of
                                       --| Source_Text

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

    subtype Work_String_Range_Plus_Zero is
        natural range 0 .. natural(HD.Source_Column'Last);

    Work_String        : string (1..Work_String_Range_Plus_Zero'Last);

    Work_String_Length : Work_String_Range_Plus_Zero;
    -- Must initialize to 0 before each use.

    ------------------------------------------------------------------
    -- Declarations for Procedures:
    --
    -- Scan_Exponent, Scan_Based_Integer, Scan_Integer,
    -- and Scan_Numeric_Literal
    ------------------------------------------------------------------

    Seen_Radix_Point : boolean := false;
    --| true  : real
    --| false : integer

    ------------------------------------------------------------------
    -- Subprogram Specifications Local to Package Lex
    ------------------------------------------------------------------

    procedure Get_Next_Char;          --| Obtains next character

    --| Requires
    --|
    --| This subprogram requires an opened source file, and
    --| Current Column > Line_Buffer_Last on its first call to initialize
    --| the input buffers Next_Char and Line_Buffer correctly.
    --|

    --| Effects
    --|
    --| This subprogram places the next character from the source file
    --| in Next_Char and updates the source file position.
    --| Subprogram Get_Next_Line sets End_Of_File_Reached true, and causes
    --| Next_Char to be set to the last character in Line_Buffer.
    --|

    --| Modifies
    --|
    --| Current_Column
    --| Current_Line
    --| Next_Char
    --| Line_Buffer
    --| Line_Buffer_Last
    --| Line_Buffer_Index
    --| End_Of_File_Reached
    --|

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

    procedure Get_Next_Line;      --| gets next source file line to lex

    --| Requires
    --|
    --| This subprogram requires the source file to be open.
    --|

    --| Effects
    --|
    --| This subprogram gets next source line from input file.
    --| Sets Current_Column and Line_Buffer_Index to 1, and
    --| increments Current_Line.
    --| If the End of File is detected,
    --| End_Of_File_Reached is set true,
    --| End_Of_File_Token is set up,
    --| and Next_Char is set to End_Of_Line_Buffer.
    --|

    --| Modifies
    --|
    --| Current_Line
    --| End_Of_File_Reached
    --| End_Of_File_Token - only when the end of file is reached.
    --| Line_Buffer
    --| Line_Buffer_Last
    --|

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

    function Look_Ahead(        --| Return character n columns ahead
                                --| in current in current line.
        In_Columns_Ahead :      --| Number of columns ahead to get
            in HD.Source_Column --| return character from.
        ) return character;

    --| Requires
    --|
    --| Line_Buffer
    --| Line_Buffer_Last
    --|

    --| Effects
    --|
    --| Return character In_Columns_Ahead in Line_Buffer.
    --| If this character is off the end of Line_Buffer,
    --| End_Of_Line_Buffer character is returned.
    --|

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

    procedure Set_CST_Gram_Sym_Val(  --| Sets gram_sym_val for current
                                     --| token.
        In_Token_Value : in PT.TokenRange); --| value of token

    --| Effects
    --|
    --| This subprogram fills in gram_sym_val for the current token.
    --|

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

    procedure Set_CST_Source_Rep(    --| Saves the symbol representation
                                     --| in the current token.
        In_String : in string);      --| string holding symbol.

    --| Effects
    --|
    --| This subprogram fills in lexed_token.symrep for the current token.
    --|

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

    procedure Initialize_CST;        --| Sets lx_srcpos for current token.

    --| Requires
    --|
    --| This subprogram requires Current_Column and Current_Line.
    --|

    --| Effects
    --|
    --| This subprogram sets common fields in CST.
    --|

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

    procedure Add_Next_Char_To_Source_Rep;
                                --| appends Next_Char to growing
                                --| source representation

    --| Requires
    --|
    --| Next_Char
    --|

    --| Effects
    --|
    --| This subprogram appends Next_Char to the growing source
    --| representation.
    --|

    --| Modifies
    --|
    --| Work_String
    --| Work_String_Length
    --|

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

    procedure Check_For_Consecutive_Underlines;
                                --| Issues an error message if
                                --| consecutive underlines occur.

    --| Requires
    --|
    --| Work_String
    --| Work_String_Length
    --|

    --| Effects
    --|
    --| Issues an error message if consecutive underlines occur.
    --|

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

    procedure Check_For_Terminal_Underline;
                                --| Issues an error message if
                                --| a terminal underline occurs.

    --| Requires
    --|
    --| Work_String
    --| Work_String_Length
    --|

    --| Effects
    --|
    --| This subprogram issues an error message if a terminal underline
    --| occurs.

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

    procedure Scan_Comment;       --| Scans comments.

    --| Requires
    --|
    --| This subprogram requires an opened source file.
    --|

    --| Effects
    --|
    --| This subprogram scans the rest of a comment.
    --|

    --| Modifies
    --|
    --| CST
    --|

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

    procedure Scan_Identifier_Including_RW;
                                --| Scans identifiers including
                                --| reserved words

    --| Requires
    --|
    --| This subprogram requires an opened source file.
    --|

    --| Effects
    --|
    --| This subprogram scans the rest of the identifier,
    --| and determines if its a reserved word.
    --|

    --| Modifies
    --|
    --| CST
    --|

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

    procedure Scan_Exponent;    --| Scans exponent field in
                                --| appropriate numeric_literals

    --| Requires
    --|
    --| This subprogram requires an opened source file.
    --|

    --| Effects
    --|
    --| This subprogram scans the end of numeric_literals which
    --| contain exponents.
    --|

    --| Modifies
    --|
    --| Work_String
    --| Work_String_Length
    --|

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

    procedure Scan_Based_Integer(  --| scans a based integer field of
                                   --| a numeric literal
        In_Base_To_Use :           --| the base to use for lexing.
            in Valid_Base_Range);

    --| Requires
    --|
    --| This subprogram requires an opened source file.

    --| Effects
    --|
    --| This subprogram scans a based integer field in a numeric literal,
    --| verifying that is lexically correct.
    --|

    --| Modifies
    --|
    --| Work_String
    --| Work_String_Length
    --|

    --| Notes
    --|
    --| This subprogram and Scan_Integer are nearly identical.
    --| They are separate to save the overhead of:
    --|
    --| - passing a base in for decimal literals; and
    --|
    --| - distinguishing the extended digit 'E' from the exponent
    --| delimiter 'E'.
    --|

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

    procedure Scan_Integer;     --| scans an integer field of
                                --|  a numeric literal

    --| Requires
    --|
    --| This subprogram requires an opened source file.
    --|

    --| Effects
    --|
    --| This subprogram scans an integer field in a numeric literal,
    --| verifying it is lexically correct.
    --|

    --| Modifies
    --|
    --| Work_String
    --| Work_String_Length
    --|

    --| Notes
    --|
    --| This subprogram and Scan_Based_Integer are nearly identical.
    --| They are separate to save the overhead of:
    --|
    --| - passing a base in for decimal literals; and
    --|
    --| - distinguishing the extended digit 'E' from the exponent
    --| delimiter 'E'.
    --|

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

    procedure Scan_Numeric_Literal;   --| Scans numbers

    --| Requires
    --|
    --| This subprogram requires an opened source file, and the
    --| Universal Arithmetic package to handle conversions.
    --|

    --| Effects
    --|
    --| This subprogram scans the rest of the numeric literal and converts
    --| it to internal universal number format.
    --|

    --| Modifies
    --|
    --| CST
    --|

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

    procedure Scan_String_Literal;   --| Scans string literals

    --| Requires
    --|
    --| This subprogram requires an opened source file.
    --|

    --| Effects
    --|
    --| This subprogram scans the rest of the string literal.
    --|

    --| Modifies
    --|
    --| CST
    --|

    ------------------------------------------------------------------
    -- Subprogram Bodies Global to Package Lex
    -- (declared in package specification).
    ------------------------------------------------------------------

    procedure Initialization is

    begin

    End_Of_File_Reached := false;
        -- forces Get_Next_Char to call Get_Next_Line
    Current_Column := Line_Buffer_Last + 1;
        Get_Next_Char;

    end Initialization;

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

    function GetNextNonCommentToken return PD.ParseStackElement is
        separate;

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

    function GetNextSourceToken return PD.ParseStackElement is

    --| Overview
    --|
    --| Note the following LRM Sections:
    --|     LRM Section 2.2  - Lexical Elements, Separators and Delimiters
    --|     LRM Section 2.2  - Notes
    --|     LRM Section 2.5  - Character Literals
    --|     LRM Section 2.7  - Comments
    --|     LRM Section 2.7  - Note
    --|     LRM Section 2.10 - Allowed Replacements of Characters
    --|

    begin

        if (End_Of_File_Reached) then
            CST := End_Of_File_Token;
        else -- this else terminates
             -- shortly before the return statement

        -- This loop performs the following functions:
        --
        -- 1) It scans for and ignores repeated separators.
        -- 2) It reports illegal characters between tokens.
        -- 3) It identifies and lexes tokens.
        --    Delimiters and character literals are handled
        --    by code inside this loop.
        --    Complex tokens: identifiers, string and
        --    numeric literals are lexed by called
        --    subprograms.
        -- 4) It recognizes and processes comments that
        --    occur before the first token found.  Comments
        --    after tokens are processed by a separate loop
        --    after this one.

            Scan_For_Token: loop
                case Next_Char is
                    when Upper_Case_Letter |
                        Lower_Case_Letter =>
                        Initialize_CST;
                        Scan_Identifier_Including_RW;
                        exit Scan_For_Token;
                        -- Next_Char already updated

                    when Digit =>
                        Initialize_CST;
                        Scan_Numeric_Literal;
                        exit Scan_For_Token;
                        -- Next_Char already updated

                    when ASCII.QUOTATION |  -- '"'
                        ASCII.PERCENT  => -- '%'
                        Initialize_CST;
                        Scan_String_Literal;
                        exit Scan_For_Token;
                        -- Next_Char already updated

                    when ''' =>
                        Initialize_CST;
                        if ((GC."="(Previous_Token_Value,
                                    PT.IdentifierTokenValue))
                            or else (GC."="(Previous_Token_Value,
                                            PT.AllTokenValue))
                            or else (GC."="(Previous_Token_Value,
                                            PT.StringTokenValue))
                            or else (GC."="(Previous_Token_Value,
                                            PT.CharacterTokenValue))
                            or else (GC."="(Previous_Token_Value,
                                     PT.RightParen_TokenValue)) ) then
                            --  CST is a ' delimiter
                            Set_CST_Gram_Sym_Val(
                                PT.Apostrophe_TokenValue);
                        elsif (Look_Ahead(2) = ''') then
                            -- CST is a character literal
                            CST.gram_sym_val := PT.CharacterTokenValue;
                            Get_Next_Char;
                            if not (Next_Char in Graphic_Character) then
                                -- flag as an error
                                LEM.Output_Message(
                                    Current_Line
                                    , Current_Column
                                    , Integer'Image(
                                        Character'Pos(Next_Char))
                                    -- convert to string
                                    , LEM.Character_Is_Non_Graphic);
                            end if;
                            -- save the source representation.
                            Set_CST_Source_Rep ("'" & Next_Char);
                            Get_Next_Char;  -- pass by the closing
                                            -- single quote
                        else
                            -- flag single quote use as illegal
                            LEM.Output_Message(
                                Current_Line
                                , Current_Column
                                , LEM.Illegal_Use_Of_Single_Quote);
                                --  assume CST is a ' delimiter;
                            Set_CST_Gram_Sym_Val(
                                PT.Apostrophe_TokenValue);
                        end if;
                        Exit_After_Get_Next_Char := true;


                    when ASCII.AMPERSAND =>    -- '&'
                        Initialize_CST;
                        Set_CST_Gram_Sym_Val(PT.Ampersand_TokenValue);
                        Exit_After_Get_Next_Char := true;

                    when '(' =>
                        Initialize_CST;
                        Set_CST_Gram_Sym_Val(PT.LeftParen_TokenValue);
                        Exit_After_Get_Next_Char := true;

                    when ')' =>
                        Initialize_CST;
                        Set_CST_Gram_Sym_Val(PT.RightParen_TokenValue);
                        Exit_After_Get_Next_Char := true;

                    when '*' =>
                        Initialize_CST;
                        Get_Next_Char;
                        case Next_Char is
                            when '*' =>
                                Set_CST_Gram_Sym_Val(
                                    PD.Exponentiation_TokenValue);
                                Exit_After_Get_Next_Char := true;
                            when others =>
                                Set_CST_Gram_Sym_Val(PT.Star_TokenValue);
                                exit Scan_For_Token;
                                -- Next_Char already updated
                        end case;

                    when '+' =>
                        Initialize_CST;
                        Set_CST_Gram_Sym_Val(PT.Plus_TokenValue);
                        Exit_After_Get_Next_Char := true;

                    when ',' =>
                        Initialize_CST;
                        Set_CST_Gram_Sym_Val(PT.Comma_TokenValue);
                        Exit_After_Get_Next_Char := true;

                    when '-' =>                -- Minus_Sign or Hyphen
                           Initialize_CST;
                           Get_Next_Char;
                           case Next_Char is
                            when '-' =>     -- Minus_Sign or Hyphen
                                -- two hyphens indicate a comment
                                Set_CST_Gram_Sym_Val(
                                    PT.Comment_TokenValue);
                                Scan_Comment;
                                Exit_After_Get_Next_Char := true;
                            when others =>
                                Set_CST_Gram_Sym_Val(PT.Minus_TokenValue);
                                exit Scan_For_Token;
                                -- Next_Char already updated
                        end case;

                    when '.' =>
                        Initialize_CST;
                        Get_Next_Char;
                        case Next_Char is
                            when '.' =>
                                Set_CST_Gram_Sym_Val(
                                    PT.DotDot_TokenValue);
                                Exit_After_Get_Next_Char := true;
                            when others =>
                                Set_CST_Gram_Sym_Val(PT.Dot_TokenValue);
                                exit Scan_For_Token;
                                -- Next_Char already updated
                        end case;

                    when '/' =>
                        Initialize_CST;
                        Get_Next_Char;
                        case Next_Char is
                            when '=' =>
                                Set_CST_Gram_Sym_Val(
                                    PD.NotEquals_TokenValue);
                                Exit_After_Get_Next_Char := true;
                            when others =>
                                Set_CST_Gram_Sym_Val(
                                    PT.Slash_TokenValue);
                                exit Scan_For_Token;
                                -- Next_Char already updated
                        end case;

                    when ASCII.COLON =>        -- ':'
                        Initialize_CST;
                        Get_Next_Char;
                        case Next_Char is
                            when '=' =>
                                Set_CST_Gram_Sym_Val(
                                    PD.Assignment_TokenValue);
                                Exit_After_Get_Next_Char := true;
                            when others =>
                                Set_CST_Gram_Sym_Val(PT.Colon_TokenValue);
                                exit Scan_For_Token;
                                -- Next_Char already updated
                        end case;

                    when ASCII.SEMICOLON =>    -- ';'
                        Initialize_CST;
                        Set_CST_Gram_Sym_Val(PT.SemiColon_TokenValue);
                        Exit_After_Get_Next_Char := true;

                    when '<' =>
                        Initialize_CST;
                        Get_Next_Char;
                        case Next_Char is
                            when '=' =>
                                Set_CST_Gram_Sym_Val(PT.LTEQ_TokenValue);
                                Exit_After_Get_Next_Char := true;
                            when '<' =>
                                Set_CST_Gram_Sym_Val(
                                    PD.StartLabel_TokenValue);
                                Exit_After_Get_Next_Char := true;
                            when '>' =>
                                Set_CST_Gram_Sym_Val(PD.Box_TokenValue);
                                Exit_After_Get_Next_Char := true;
                            when others =>
                                Set_CST_Gram_Sym_Val(PT.LT_TokenValue);
                                exit Scan_For_Token;
                                -- Next_Char already updated
                        end case;

                    when '=' =>
                        Initialize_CST;
                        Get_Next_Char;
                        case Next_Char is
                            when '>' =>
                                Set_CST_Gram_Sym_Val(PD.Arrow_TokenValue);
                                Exit_After_Get_Next_Char := true;
                            when others =>
                                Set_CST_Gram_Sym_Val(PT.EQ_TokenValue);
                                exit Scan_For_Token;
                                -- Next_Char already updated
                        end case;

                    when '>' =>
                        Initialize_CST;
                        Get_Next_Char;
                        case Next_Char is
                            when '=' =>
                                Set_CST_Gram_Sym_Val(PT.GTEQ_TokenValue);
                                Exit_After_Get_Next_Char := true;
                            when '>' =>
                                Set_CST_Gram_Sym_Val(
                                    PD.EndLabel_TokenValue);
                                Exit_After_Get_Next_Char := true;
                            when others =>
                                Set_CST_Gram_Sym_Val(PT.GT_TokenValue);
                                exit Scan_For_Token;
                                -- Next_Char already updated
                        end case;

                    when ASCII.BAR    |  -- '|'
                        ASCII.EXCLAM => -- '!'
                        -- vertical bar and its alternative
                        Initialize_CST;
                        Set_CST_Gram_Sym_Val(PT.Bar_TokenValue);
                        Exit_After_Get_Next_Char := true;

                    when ASCII.HT =>   -- Horizontal Tab
                        -- a lexical unit separator - skip it.
                        -- position Current_Column properly. This is done
                        --     here to save the cost of a test on every
                        --     character in Get_Next_Char.

                        Current_Column :=
                            HD.FindTabColumn(Current_Column);

                    when ' ' | End_Of_Line_Character =>
                        -- rest of the lexical unit separators

                        if (End_Of_File_Reached) then
                            return End_Of_File_Token;
                        end if;


                    when ASCII.UNDERLINE =>    -- '_'
                        case Look_Ahead(1) is
                            when Upper_Case_Letter | Lower_Case_Letter =>
                                -- flag illegal leading under line
                                LEM.Output_Message(
                                    Current_Line
                                    , Current_Column
                                    , LEM.Leading_Underline);
                                Initialize_CST;
                                Scan_Identifier_Including_RW;
                                exit Scan_For_Token;
                                -- Next_Char already updated
                            when Digit =>
                                -- flag illegal leading under line
                                LEM.Output_Message(
                                    Current_Line
                                    , Current_Column
                                    , LEM.Leading_Underline);
                                Initialize_CST;
                                Scan_Numeric_Literal;
                                exit Scan_For_Token;
                                -- Next_Char already updated
                            when others =>
                                -- flag illegal character for start
                                -- of token
                                LEM.Output_Message(
                                    Current_Line
                                    , Current_Column
                                    , "_"
                                    , LEM.Character_Can_Not_Start_Token);
                        end case;


                    when ASCII.SHARP           |  -- '#'
                         ASCII.DOLLAR          |  -- '$'
                         ASCII.QUERY           |  -- '?'
                         ASCII.AT_SIGN         |  -- '@'
                         ASCII.L_BRACKET       |  -- '['
                         ASCII.BACK_SLASH      |  -- '\'
                         ASCII.R_BRACKET       |  -- ']'
                         ASCII.CIRCUMFLEX      |  -- '^'
                         ASCII.GRAVE           |  -- '`'
                         ASCII.L_BRACE         |  -- '{'
                         ASCII.R_BRACE         |  -- '}'
                         ASCII.TILDE           => -- '~'
                            -- flag illegal character for start of token
                            LEM.Output_Message(
                                Current_Line
                                , Current_Column
                                , Next_Char & ""  -- convert to string
                                , LEM.Character_Can_Not_Start_Token);

                    when ASCII.NUL ..          -- Null to
                                ASCII.BS  |    --  Back Space
                         ASCII.SO ..           -- Shift Out to
                                ASCII.US  |    --  Unit Separator
                         ASCII.DEL        =>   -- Delete
                            -- flag as non-graphic ASCII control character
                        LEM.Output_Message(
                            Current_Line
                            , Current_Column
                            , Integer'Image(Character'Pos(Next_Char))
                                                  -- convert to string
                            , LEM.Character_Is_Non_Graphic);

                    when others =>
                        -- should never happen due to 's
                        -- definition of CHARACTER. flag as illegal anyhow
                        LEM.Output_Message(
                            Current_Line
                            , Current_Column
                            , LEM.Character_Is_Non_ASCII);
                end case;

                Get_Next_Char;    -- for next time through loop.

                if (Exit_After_Get_Next_Char) then
                    Exit_After_Get_Next_Char := false;
                    exit Scan_For_Token;
                end if;

            end loop Scan_For_Token;    -- Next_Char already updated

            Previous_Token_Value := CST.gram_sym_val;
            -- for resolving T'('c')

        end if; -- (End_Of_File_Reached)

        return CST;

        -- On leaving: object Next_Char should contain character
        -- to scan on next call of this function.

    end GetNextSourceToken;

    ------------------------------------------------------------------
    -- Subprogram Bodies Local to Package Lex
    ------------------------------------------------------------------

    procedure Get_Next_Char is

    begin

    --| Algorithm
    --|
    --| Source File is scanned returning each character until the
    --| end of the file is found. Proper column positioning for a tab
    --| character is done in GetNextSourceToken for speed.
    --|

    -- The End_Of_Line_Character that Get_Next_Line
    -- inserts needs to be seen by the scanning
    -- case statements to terminate tokens correctly.

        Current_Column    := Current_Column    + 1;
        Line_Buffer_Index := Line_Buffer_Index + 1;
        Next_Char := Line_Buffer (Line_Buffer_Index);

        if (Line_Buffer_Index > Line_Buffer_Last) then
            Get_Next_Line;
            -- Current_Column and Line_Buffer_Index are handled there.
            Next_Char := Line_Buffer (Line_Buffer_Index);
        end if;

    end Get_Next_Char; -- procedure

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

    procedure Get_Next_Line is

    begin

        -- Get next source line from CURRENT_INPUT. Update column and
        -- line counts
        Current_Column := 1;
        Line_Buffer_Index := 1;

        Ignore_Null_Line:
        loop
            -- do NOT move next statement out of loop
            if (Current_Line < HD.Source_Line'Last) then
                begin  -- block
                    Current_Line := HD.Source_Line  -- type conversion
                        (TEXT_IO.LINE(FILE => TEXT_IO.CURRENT_INPUT));
                    if (Current_Line >= HD.Source_Line'Last) then
                        raise CONSTRAINT_ERROR;
                    end if;
                exception
                    when others =>
                        Current_Line := HD.Source_Line'Last;
                        LEM.Output_Message(
                            Current_Line
                            , Current_Column
                            , HD.Source_Line'IMAGE(HD.Source_Line'Last)
                            , LEM.Source_Line_Maximum_Exceeded);
                end; -- block
            end if;
            TEXT_IO.GET_LINE(
                FILE => TEXT_IO.CURRENT_INPUT,
                ITEM => Line_Buffer(1..(Line_Buffer'Last - 1)),
                LAST => Line_Buffer_Last);
                -- flag a line that is too long as an error
                if (Line_Buffer_Last >= Line_Buffer'Last - 1) and then
                   (TEXT_IO.END_OF_LINE(FILE => TEXT_IO.CURRENT_INPUT) )
                then
                    LEM.Output_Message(
                        Current_Line
                        , Current_Column
                        , LEM.Source_Line_Too_Long);
                end if;
        Write_Line;
                exit Ignore_Null_Line when
                    (Line_Buffer_Last /= (Line_Buffer'First - 1));
        end loop Ignore_Null_Line;

        Line_Buffer_Last              := Line_Buffer_Last + 1;
        Line_Buffer(Line_Buffer_Last) := End_Of_Line_Buffer;

    exception
        -- when end of file is reached
        when TEXT_IO.END_ERROR =>
            -- save that state for GetNextSourceToken
            End_Of_File_Reached := true;

            -- update column and line counts
            Line_Buffer_Last  := 1;
            Line_Buffer(Line_Buffer_Last) := End_Of_Line_Buffer;
            Line_Buffer_Index := 1;
            Current_Column    := 1;
            -- Current_Line is ok.
            -- Last call to GET_LINE advanced it one.

            -- set the value of End_Of_File_Token
            -- the discriminants were set up by the object declaration
            End_Of_File_Token.gram_sym_val := PT.EOF_TokenValue;
            End_Of_File_Token.lexed_token := (
                srcpos_line     => Current_Line,
                srcpos_column   => Current_Column,
                text            => PD.Null_Source_Text);

    end Get_Next_Line;

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

    function Look_Ahead(
        In_Columns_Ahead : in HD.Source_Column) return character is

    ------------------------------------------------------------------
    -- Declarations for subprogram Look_Ahead
    ------------------------------------------------------------------

    Position_To_Try : Integer := Integer   --type conversion
                                        ( Line_Buffer_Index
                                    + In_Columns_Ahead);

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

    begin

        -- if request is past the end of line
        if (Position_To_Try > Integer(Line_Buffer_Last) ) then
                                   -- type conversion
            -- return the end_of_line character
            return End_Of_Line_Buffer;
        else
            -- else return the requested character
            return Line_Buffer(Position_To_Try);
        end if;

    end Look_Ahead; -- function

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

    procedure Set_CST_Gram_Sym_Val(
        In_Token_Value : in PT.TokenRange) is

    begin

        CST.gram_sym_val := In_Token_Value;

    end Set_CST_Gram_Sym_Val;

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

    procedure Set_CST_Source_Rep(
        In_String : in string) is

    begin

        -- store the representation
        PD.Put_Source_Text(
            In_String,
            CST.lexed_token.text);

    end Set_CST_Source_Rep;

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

    procedure Initialize_CST is

    begin

        -- Set up discriminants, and source position properly
        -- Set other CST fields to null values
        CST := CST_Initializer;

        CST.lexed_token := (
            srcpos_line     => Current_Line,
            srcpos_column   => Current_Column,
            text            => PD.Null_Source_Text);

    end Initialize_CST;

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

    procedure Add_Next_Char_To_Source_Rep is

    begin

        -- append the character to growing source representation
        Work_String_Length              := Work_String_Length + 1;
        Work_String(Work_String_Length) := Next_Char;

    end Add_Next_Char_To_Source_Rep;

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

    procedure Check_For_Consecutive_Underlines is

    begin

        -- flag consecutive underlines as an error (leading
        -- underlines are handled in GetNextSourceToken).
        if (Work_String(Work_String_Length) = ASCII.UNDERLINE)
        then
            LEM.Output_Message(
                Current_Line
                , Current_Column
                , LEM.Consecutive_Underlines);
        end if;

    end Check_For_Consecutive_Underlines; -- procedure

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

    procedure Check_For_Terminal_Underline is

    begin

        -- flag a trailing underline as an error.
        -- trailing underlines are saved for the same
        -- reason as leading ones.
        -- See comment in GetNextSourceToken.

        if (Work_String(Work_String_Length) = ASCII.UNDERLINE)
        -- check the preceeding character
        then
            LEM.Output_Message(
                Current_Line
                , Current_Column
                , LEM.Terminal_Underline);
        end if;

    end Check_For_Terminal_Underline;

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

    procedure Scan_Comment is

    --| Overview
    --|
    --| Note the following LRM Sections:
    --|     LRM Section 2.7  - Comments
    --|     LRM Section 2.7  - Note
    --|

    begin

        -- get to the beginning of the comment
        Get_Next_Char;
        Set_CST_Source_Rep(
            Line_Buffer(Line_Buffer_Index .. Line_Buffer_Last - 1));
        -- subtract 1 so that the carridge return is not also returned.

        Line_Buffer_Index := Line_Buffer_Last + 1;
        -- force next call to Get_Next_Char to call Get_Next_Line

    end Scan_Comment;

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

    procedure Scan_Identifier_Including_RW is

    --| Overview
    --|
    --| Note the following LRM Sections:
    --|     LRM Section 2.3 - Identifiers
    --|     LRM Section 2.3 - Note
    --|     LRM Section 2.9 - Reserved Words
    --|     LRM Section 2.9 - Notes
    --|

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

    begin

        Work_String_Length := 0;

        -- scan source file for rest of token
        -- note that first character of the token is stored first
        Scan_For_Identifier_Including_RW: loop
            Add_Next_Char_To_Source_Rep;

            -- set up for processing next characte
            Get_Next_Char;

            case Next_Char is
                when Upper_Case_Letter | Lower_Case_Letter | Digit =>
                    -- action is at start of next loop cycle
                    null;
                when ASCII.UNDERLINE =>        -- '_'
                    Check_For_Consecutive_Underlines;
                when others =>
                    Check_For_Terminal_Underline;

                    -- token is terminated by any character except letter
                    --     digit, or underline;
                    exit Scan_For_Identifier_Including_RW; -- this loop
            end case;

        end loop Scan_For_Identifier_Including_RW;

        -- find out what kind of token it is
        Lex_Identifier_Token_Value.Find(
            In_Identifier       =>
                Work_String(1..Work_String_Length),
            Out_Token_Value     => CST.gram_sym_val);

        -- store the source representation of the token found
        Set_CST_Source_Rep(Work_String(1..Work_String_Length) );

    end Scan_Identifier_Including_RW;

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

    procedure Scan_Exponent is

    --| Overview
    --|
    --| Note the following LRM Sections:
    --|     LRM Section 2.4.1 - Decimal Literals
    --|     LRM Section 2.4.1 - Notes
    --|     LRM Section 2.4.2 - Based Literals
    --|

    begin

        -- Check for missing 'E' or 'e',
        -- and for existence of the exponent
        case Next_Char is
            when 'E' | 'e' =>
                null;    -- normal case
            when others =>
                return;  -- no exponent to process
        end case;
        -- add first character to growing literal
        Add_Next_Char_To_Source_Rep;


        -- scan source file for rest of the exponent
        -- verify that next character is legal for an integer field
        Get_Next_Char;

        case Next_Char is
            when '+' =>
                -- add sign character to growing literal
                Add_Next_Char_To_Source_Rep;

                Get_Next_Char;
            when '-' =>     -- Minus_Sign
                if not (Seen_Radix_Point) then
                    -- flag negative exponent as illegal in an integer
                    LEM.Output_Message(
                        Current_Line
                        , Current_Column
                        , LEM.Negative_Exponent_Illegal_In_Integer);
                end if;

                -- add sign character to growing literal
                Add_Next_Char_To_Source_Rep;

                Get_Next_Char;
            when others =>
                null;
        end case;

        case Next_Char is
            when Digit =>
                -- scan the integer field of the exponent
                Scan_Integer;
            when ASCII.UNDERLINE =>        -- '_'
                if (Look_Ahead(1) in Digit) then
                    -- flag illegal leading under line
                    LEM.Output_Message(
                        Current_Line
                        , Current_Column
                        , LEM.Leading_Underline);
                    -- scan the integer field of the exponent
                    Scan_Integer;
                else
                    -- issue error message that integer field is missing
                    LEM.Output_Message(
                    Current_Line
                        , Current_Column
                        , LEM.Exponent_Missing_Integer_Field);
                end if;
            when others =>
                -- issue an error message that integer field is missing
                LEM.Output_Message(
                    Current_Line
                    , Current_Column
                    , LEM.Exponent_Missing_Integer_Field);
        end case;

    end Scan_Exponent;

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

    procedure Scan_Based_Integer(
        In_Base_To_Use : in Valid_Base_Range) is

    --| Overview
    --|
    --| Note the following LRM Sections:
    --|     LRM Section 2.4   - Numeric Literals
    --|     LRM Section 2.4.2 - Based Literals
    --|

    ------------------------------------------------------------------
    -- Declarations for Procedure Scan_Based_Integer
    ------------------------------------------------------------------

    BAD : constant GC.ParserInteger := GC.ParserInteger'Last;
        --| an integer value greater than 15 to use as a flag to indicate
        --| illegal values.

    Transform : constant array(CHARACTER) of GC.ParserInteger :=

    -------- ( nul,  soh,  stx,  etx,     eot,  enq,  ack,  bel,
             ( BAD,  BAD,  BAD,  BAD,     BAD,  BAD,  BAD,  BAD,
    --------   bs,   ht,   lf,   vt,      ff,   cr,   so,   si,
               BAD,  BAD,  BAD,  BAD,     BAD,  BAD,  BAD,  BAD,
    --------   dle,  dc1,  dc2,  dc3,     dc4,  nak,  syn,  etb,
               BAD,  BAD,  BAD,  BAD,     BAD,  BAD,  BAD,  BAD,
    --------   can,  em,   sub,  esc,     fs,   gs,   rs,   us,
               BAD,  BAD,  BAD,  BAD,     BAD,  BAD,  BAD,  BAD,

    --------   ' ',  '!',  '"',  '#',     '$',  '%',  '&',  ''',
               BAD,  BAD,  BAD,  BAD,     BAD,  BAD,  BAD,  BAD,
    --------   '(',  ')',  '*',  '+',     ',',  '-',  '.',  '/',
               BAD,  BAD,  BAD,  BAD,     BAD,  BAD,  BAD,  BAD,
    --------   '0',  '1',  '2',  '3',     '4',  '5',  '6',  '7',
                0 ,   1 ,   2 ,   3 ,      4 ,   5 ,   6 ,   7 ,
    --------   '8',  '9',  ':',  ';',     '<',  '=',  '>',  '?',
                8 ,   9 ,  BAD,  BAD,     BAD,  BAD,  BAD,  BAD,

    --------   '@',  'A',  'B',  'C',     'D',  'E',  'F',  'G',
               BAD,  10 ,  11 ,  12 ,     13 ,  14 ,  15 ,  BAD,
    --------   'H',  'I',  'J',  'K',     'L',  'M',  'N',  'O',
               BAD,  BAD,  BAD,  BAD,     BAD,  BAD,  BAD,  BAD,
    --------   'P',  'Q',  'R',  'S',     'T',  'U',  'V',  'W',
               BAD,  BAD,  BAD,  BAD,     BAD,  BAD,  BAD,  BAD,
    --------   'X',  'Y',  'Z',  '[',     '\',  ']',  '^',  '_',
               BAD,  BAD,  BAD,  BAD,     BAD,  BAD,  BAD,  BAD,

    --------   '`',  'a',  'b',  'c',     'd',  'e',  'f',  'g',
               BAD,  10 ,  11 ,  12 ,     13 ,  14 ,  15 ,  BAD,
    --------   'h',  'i',  'j',  'k',     'l',  'm',  'n',  'o',
               BAD,  BAD,  BAD,  BAD,     BAD,  BAD,  BAD,  BAD,
    --------   'p',  'q',  'r',  's',     't',  'u',  'v',  'w',
               BAD,  BAD,  BAD,  BAD,     BAD,  BAD,  BAD,  BAD,
    --------   'x',  'y',  'z',  '{',     '|',  '}',  '~',   del);
               BAD,  BAD,  BAD,  BAD,     BAD,  BAD,  BAD,  BAD );
    --| used to transform a character value to an integer value for
    --| purpose of checking that a digit is within the legal range
    --| for the base passed in via In_Base_To_Use.

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

    begin

        -- check that first character, if not an under line,
        -- is a valid digit for base being used.
        if (Next_Char /= ASCII.UNDERLINE) and then
           (Transform(Next_Char) >= In_Base_To_Use)
        then
            -- flag digit as invalid for base
            LEM.Output_Message(
                Current_Line
                , Current_Column
                , Next_Char & ""  -- convert to string
                , LEM.Digit_Invalid_For_Base);
        end if;

        -- scan source file for rest of the field
        -- note that first character of the field is stored first
        Scan_For_Based_Integer: loop

            Add_Next_Char_To_Source_Rep;

            -- set up for processing next character
            Get_Next_Char;

            case Next_Char is
                when 'A' .. 'F' | 'a' .. 'f' | Digit =>
                    -- check if Next_Char is in valid base range
                    if (Transform(Next_Char) >= In_Base_To_Use) then
                        -- flag digit as invalid for base
                        LEM.Output_Message(
                            Current_Line
                            , Current_Column
                            , Next_Char & ""  -- convert to string
                            , LEM.Digit_Invalid_For_Base);
                    end if;
                    -- rest of action is at start of next loop cycle
                when ASCII.UNDERLINE =>    -- '_'
                    Check_For_Consecutive_Underlines;
                when others =>
                    Check_For_Terminal_Underline;
                    -- field is terminated by any character except
                    -- extended digit (letters a to f and digits),
                    -- or underline
                    exit Scan_For_Based_Integer; -- this loop
            end case;

        end loop Scan_For_Based_Integer;
        -- Next_Char already updated

    end Scan_Based_Integer;

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

    procedure Scan_Integer is

    --| Overview
    --|
    --| Note the following LRM Sections:
    --|     LRM Section 2.4   - Numeric Literals
    --|     LRM Section 2.4.1 - Decimal Literals
    --|     LRM Section 2.4.1 - Notes
    --|

    begin

        -- scan source file for rest of the field
        -- note that first character of the field is stored first
        Scan_For_Integer: loop

            Add_Next_Char_To_Source_Rep;

            -- set up for processing next character
            Get_Next_Char;

            case Next_Char is
                when Digit =>
                    -- rest of action is at start of next loop cycle
                    null;
                when ASCII.UNDERLINE =>    -- '_'
                    Check_For_Consecutive_Underlines;
                when others =>
                    Check_For_Terminal_Underline;

                    -- field is terminated by any character except
                    --     digit, or underline
                    exit Scan_For_Integer; -- this loop
            end case;

        end loop Scan_For_Integer; -- Next_Char already updated

    end Scan_Integer;

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

    procedure Scan_Numeric_Literal is

    --| Overview
    --|
    --| Note the following LRM Sections:
    --|     LRM Section 2.4   - Numeric Literals
    --|     LRM Section 2.4.1 - Decimal Literals
    --|     LRM Section 2.4.1 - Notes
    --|     LRM Section 2.4.2 - Based Literals
    --|     LRM Section 2.10  - Allowed Replacements of Characters
    --|

    ------------------------------------------------------------------
    -- Declarations for Scan_Numeric_Literal
    ------------------------------------------------------------------

    Based_Literal_Delimiter : character;
        --| holds value of first based_literal delimeter:
        --| ASCII.COLON (':') or ASCII.SHARP ('#');
        --| so the second one can be checked to be identical.

    Base_Being_Used : GC.ParserInteger;
        --| base value to be passed to Scan_Based_Literal.

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

    begin

        CST.gram_sym_val := PT.NumericTokenValue;

        Work_String_Length := 0;
        -- also used by sub-scanners called from this subprogram.

        -- Scan first field
        Scan_Integer;

        -- Now, scan rest of literal dependent on what Next_char is
        case Next_Char is

            -- have a decimal_literal
            when '.' =>
                if (Look_Ahead(1) = '.') then
                    -- next token is a range double delimiter.
                    -- finished with numeric_literal.
                    Seen_Radix_Point := false;  -- have an integer_literal
                    -- already set_up for next scanner,
                    -- no call to Get_Next_Char.
                else
                    Seen_Radix_Point := true;
                    Add_Next_Char_To_Source_Rep;
                    Get_Next_Char;
                    case Next_Char is
                        when Digit =>
                            Scan_Integer;
                            -- check and flag multiple radix points
                            while (Next_Char = '.') and then
                                (Look_Ahead(1) in digit) loop
                                    LEM.Output_Message
                                        ( Current_Line
                                        , Current_Column
                                        , LEM.Too_Many_Radix_Points);
                                    Add_Next_Char_To_Source_Rep;
                                    Get_Next_Char;
                                    Scan_Integer;
                            end loop;
                        when ASCII.UNDERLINE =>        -- '_'
                            -- flag illegal leading under line
                            LEM.Output_Message(
                                Current_Line
                                , Current_Column
                                , LEM.Leading_Underline);
                            Scan_Integer;
                            -- not flagging an integer consisting of a
                            -- single underline as a trailing radix
                            -- point case.  Check and flag multiple radix
                            -- points.
                            while (Next_Char = '.') and then
                                (Look_Ahead(1) in digit) loop
                                LEM.Output_Message(
                                    Current_Line
                                    , Current_Column
                                    , LEM.Too_Many_Radix_Points);
                                Add_Next_Char_To_Source_Rep;
                                Get_Next_Char;
                                Scan_Integer;
                            end loop;
                        when others =>
                            -- flag trailing radix point as an error
                            LEM.Output_Message(
                                Current_Line
                                , Current_Column
                                , LEM.Digit_Needed_After_Radix_Point);
                    end case;

                    Scan_Exponent;  -- check for and process exponent

                end if;

            -- have a based_literal
            when ASCII.SHARP |     -- '#'
                 ASCII.COLON =>    -- ':'
                Based_Literal_Delimiter := Next_Char;
                Base_Being_Used := GC.ParserInteger'VALUE
                                (Work_String(1..Work_String_Length));
                if (Base_Being_Used not in Valid_Base_Range) then
                    -- flag illegal bases as errors
                    LEM.Output_Message(
                        Current_Line
                        , Current_Column
                        , Work_String(1..Work_String_Length)
                        , LEM.Base_Out_Of_Legal_Range_Use_16);
                    Base_Being_Used := 16;
                    -- we use the maximum base to pass all the
                    -- extended_digits as legal.
                end if;

                Add_Next_Char_To_Source_Rep;  -- save the base delimiter
                Get_Next_Char;

                case Next_Char is
                    when 'A' .. 'F' | 'a' .. 'f' | Digit =>
                        Scan_Based_Integer(Base_Being_Used);
                    when ASCII.UNDERLINE =>    -- '_'
                        -- flag illegal leading under line
                    LEM.Output_Message(
                        Current_Line
                        , Current_Column
                        , LEM.Leading_Underline);
                    -- not flagging an integer consisting of a single
                    -- under line as a trailing radix point case.
                    Scan_Based_Integer(Base_Being_Used);
                    when '.' =>
                        -- flag leading radix point as an error
                        LEM.Output_Message(
                            Current_Line
                            , Current_Column
                            , LEM.Digit_Needed_Before_Radix_Point);
                    when ASCII.SHARP |         -- '#'
                         ASCII.COLON =>        -- ':'
                        -- flag missing field as an error
                        LEM.Output_Message(
                            Current_Line
                            , Current_Column
                            , LEM.No_Integer_In_Based_Number);

                        -- based_literal_delimiter_mismatch handled in
                        -- next case statement.
                    when others =>
                        -- flag missing field as an error
                        LEM.Output_Message(
                            Current_Line
                            , Current_Column
                            , LEM.No_Integer_In_Based_Number);
                end case;

                case Next_Char is
                    when '.' =>
                        Seen_Radix_Point := true;  -- have a real_literal
                        Add_Next_Char_To_Source_Rep;

                        Get_Next_Char;
                        case Next_Char is
                            when 'A' .. 'F' | 'a' .. 'f' | Digit =>
                                Scan_Based_Integer(Base_Being_Used);
                                -- check and flag multiple radix points
                                while (Next_Char = '.') and then
                                    ((Look_Ahead(1) in digit) or
                                    (Look_Ahead(1) in 'A' .. 'F') or
                                    (Look_Ahead(1) in 'a' .. 'f')) loop
                                    LEM.Output_Message(
                                        Current_Line
                                        , Current_Column
                                        , LEM.Too_Many_Radix_Points);
                                    Add_Next_Char_To_Source_Rep;
                                    Get_Next_Char;
                                    Scan_Based_Integer(Base_Being_Used);
                                end loop;
                            when ASCII.UNDERLINE =>        -- '_'
                                -- flag illegal leading under lined
                                LEM.Output_Message(
                                    Current_Line
                                    , Current_Column
                                    , LEM.Leading_Underline);
                                -- not flagging an integer consisting of
                                -- a single underline as a trailing
                                -- radix point case.
                                Scan_Based_Integer(Base_Being_Used);
                            when others =>
                                -- flag trailing radix point as an error
                                LEM.Output_Message(
                                    Current_Line
                                    , Current_Column
                                    , LEM.Digit_Needed_After_Radix_Point);
                        end case;

                        case Next_Char is
                            when ASCII.SHARP |         -- '#'
                                 ASCII.COLON =>        -- ':'

                                Add_Next_Char_To_Source_Rep;
                                -- save the base delimiter

                                if (Next_Char /= Based_Literal_Delimiter)
                                then
                                    -- flag based_literal delimiter
                                    -- mismatch as an error
                                    LEM.Output_Message(
                                        Current_Line
                                        , Current_Column
                                        ,   "Opener: "
                                        & Based_Literal_Delimiter
                                        & " Closer: " & Next_Char
                                        , LEM.Based_Literal_Delimiter_Mismatch);
                                end if;

                                Get_Next_Char; -- after base delimiter
                                -- check for and process exponent
                                Scan_Exponent;

                            when others =>
                                -- flag missing second
                                -- based_literal delimiter as an error
                                LEM.Output_Message(
                                    Current_Line
                                    , Current_Column
                                    , LEM.Missing_Second_Based_Literal_Delimiter);
                        end case;

                    when ASCII.SHARP |         -- '#'
                         ASCII.COLON =>        -- ':'
                        -- have an integer_literal
                        Seen_Radix_Point := false;
                        -- save the base delimiter
                        Add_Next_Char_To_Source_Rep;

                        if (Next_Char /= Based_Literal_Delimiter) then
                        -- flag based_literal delimiter mismatch error
                            LEM.Output_Message(
                                Current_Line
                                , Current_Column
                                ,   "Opener: "  & Based_Literal_Delimiter
                                  & " Closer: " & Next_Char
                                , LEM.Based_Literal_Delimiter_Mismatch);
                        end if;

                        Get_Next_Char;  -- get character after base delimiter
                        Scan_Exponent;  -- check for and process exponent

                    when others =>
                        -- assume an integer_literal
                        Seen_Radix_Point := false;
                        -- flag missing second
                        -- based_literal delimiter as an error
                        LEM.Output_Message(
                            Current_Line
                            , Current_Column
                            , LEM.Missing_Second_Based_Literal_Delimiter);
                end case;

            --we have an integer_literal
            when others =>
                Seen_Radix_Point := false;  -- have an integer_literal
                Scan_Exponent;  -- check for and process exponent
        end case;

        -- one last error check
        if (Next_Char in Upper_Case_Letter) or
           (Next_Char in Lower_Case_Letter) then
            -- flag missing space between numeric_literal and
            -- identifier (including RW) as an error.
            LEM.Output_Message
                ( Current_Line
                , Current_Column
                , LEM.Space_Must_Separate_Num_And_Ids);
        end if;

        -- now store the source representation of the token found.
        Set_CST_Source_Rep(Work_String(1..Work_String_Length));

    end Scan_Numeric_Literal;

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

    procedure Scan_String_Literal is

    --| Overview
    --|
    --| Note the following LRM Sections:
    --|     LRM Section 2.6  - String Literals
    --|     LRM Section 2.6  - Note
    --|     LRM Section 2.10 - Allowed Replacements of Characters
    --|

        String_Delimiter : character := Next_Char;

    begin

        Work_String_Length := 0;

        CST.gram_sym_val := PT.StringTokenValue;

        -- scan until matching string delimiter or end of line is found
        Scan_For_String: loop
            Get_Next_Char;

            if (Next_Char = String_Delimiter) then
                Get_Next_Char;
                if (Next_Char = String_Delimiter) then
                    -- add one string delimiter to growing string
                    Add_Next_Char_To_Source_Rep;
                else     -- string is ended
                    exit Scan_For_String;
                end if;
            elsif (Next_Char in Graphic_Character) then
                -- add graphic character to growing string
                Add_Next_Char_To_Source_Rep;
            elsif (Next_Char in End_Of_Line_Character) then
                -- string is ended. flag the error.
                LEM.Output_Message(
                    Current_Line
                    , Current_Column
                    , LEM.No_Ending_String_Delimiter);
                exit Scan_For_String;
            else    -- flag non-graphic characters as errors
                LEM.Output_Message(
                    Current_Line
                    , Current_Column
                    , Integer'Image(Character'Pos(Next_Char))
                                      -- convert to string
                    , LEM.Only_Graphic_Characters_In_Strings);
            end if;

        end loop Scan_For_String;    -- Next_Char already updated

        -- now store the source representation found without the
        -- string delimiters
        Set_CST_Source_Rep(Work_String(1..Work_String_Length));

        return;

    end Scan_String_Literal;

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

    function Show_Current_Line
    return HD.Source_Line is

    --| Overview
    --| Return current line number

    begin

    return Current_Line;

    end Show_Current_Line;

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

    procedure Write_Line is separate;

    ------------------------------------------------------------------
end Lex;

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

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--WRITELINE.SUB
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
separate (Lex)
procedure Write_Line is
    begin
    null;
    end Write_Line;