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

Text File | 1988-05-03 | 644.3 KB | 22,641 lines

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--CISC.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package case_insensitive_string_comparison is

--| Overview
--| This package provides a complete set of comparison functions on strings
--| where case is NOT important ("a" = "A").

--| Standard_Renaming: CISC or simply SC
--| Programmer: M. Gordon

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

function toUpper(    --| Return upper case equivalent of C.
    C: character
    ) return character;

--| Effects: If C is in 'a'..'z' return the corresponding upper case
--| character.  Otherwise, return C.  This is implemented by a table
--| lookup for speed.

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


procedure upCase(    --| Convert all characters in S to upper case
    S: in out String
    );

--| Effects: Convert all characters in S to upper case.
--| N/A: Raises, Requires, Modifies

    pragma inline(upCase);


function upCase(    --| Return copy of S with all characters upper case
    S: String
    ) return String;

--| Effects: Make a copy of S, convert all lower case characters to upper
--| case and return the copy.

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

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

function toLower(    --| Return lower case equivalent of C.
    C: character
    ) return character;

--| Effects: If C is in 'A'..'Z' return the corresponding lower case
--| character.  Otherwise, return C.  This is implemented by a table
--| lookup for speed.

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


procedure downCase(    --| Convert all characters in S to lower case
    S: in out String
    );

--| Effects: Convert all characters in S to lower case.
--| N/A: Raises, Requires, Modifies

    pragma inline(downCase);


function downCase(    --| Return copy of S with all characters lower case
    S: String
    ) return String;

--| Effects: Make a copy of S, convert all lower case characters to lower
--| case and return the copy.

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

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

function compare(    --| Compare two strings
    P, Q: String
    ) return integer;

--| Effects: Return an integer less than zero if P < Q, zero if P = Q, and
--| an integer greater than zero if P > Q.

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

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

function equal(        --| Return True iff P = Q.
    P, Q: String
    ) return boolean;

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

function less(        --| Return True iff P < Q.
    P, Q: String
    ) return boolean;
--| N/A: Raises, Requires, Modifies, Effects


function less_or_equal(    --| Return True iff P <= Q.
    P, Q: String
    ) return boolean;

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


function greater(    --| Return True iff P > Q.
    P, Q: String
    ) return boolean;

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


function greater_or_equal(    --| Return True iff P >= Q.
    P, Q: String
    ) return boolean;

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

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

private
    pragma inline(equal, less, less_or_equal, greater, greater_or_equal);
    pragma inline(toUpper, toLower);

end case_insensitive_string_comparison;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--CSSC.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package case_sensitive_string_comparison is

--| Overview
--| This package provides a complete set of comparison functions on strings
--| where case is important ("a" /= "A").  In most cases these have the same
--| effect as the Ada predefined operators.  However, using this package
--| makes it easier to substitute case-insensitive comparison later

--| Standard_Renaming: CSSC or simply SC
--| Programmer: M. Gordon

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

function compare(    --| Compare two strings
    P, Q: String
    ) return integer;

--| Effects: Return an integer less than zero if P < Q, zero if P = Q, and
--| an integer greater than zero if P > Q.

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

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

function equal(        --| Return True iff P = Q.
    P, Q: String
    ) return boolean;

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

function less(        --| Return True iff P < Q.
    P, Q: String
    ) return boolean;
--| N/A: Raises, Requires, Modifies, Effects


function less_or_equal(    --| Return True iff P <= Q.
    P, Q: String
    ) return boolean;

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

function greater(    --| Return True iff P > Q.
    P, Q: String
    ) return boolean;

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


function greater_or_equal(    --| Return True iff P >= Q.
    P, Q: String
    ) return boolean;

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

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

private
    pragma inline(equal, less, less_or_equal, greater, greater_or_equal);

end case_sensitive_string_comparison;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--CISC.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package body case_insensitive_string_comparison is

--| Overview
--| Strings are compared one character at a time, stopping as soon as
--| possible.

--| Programmer: M. Gordon

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

Up_ConvertArray: array(Character) of Character;
Down_ConvertArray: array(Character) of Character;
Difference: constant := Character'pos('a') - Character'pos('A');

function toUpper(C: character) return character is
begin
    return Up_ConvertArray(C);

end toUpper;


function upCase(    --| Return copy of S with all characters lower case
    S: String
    ) return String
is
    R: String(S'Range) := S;

begin
    for i in R'Range loop
    R(i) := toUpper(R(i));
    end loop;
    return R;

end upCase;


procedure upCase(    --| Convert all characters in S to lower case
    S: in out String
    ) is

begin
    for i in S'Range loop
    S(i) := toUpper(S(i));
    end loop;

end upCase;

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

function toLower(C: character) return character is
begin
    return Down_ConvertArray(C);

end toLower;


function downCase(    --| Return copy of S with all characters lower case
    S: String
    ) return String
is
    R: String(S'Range) := S;

begin
    for i in R'Range loop
    R(i) := toLower(R(i));
    end loop;
    return R;

end downCase;

procedure downCase(    --| Convert all characters in S to lower case
    S: in out String
    ) is

begin
    for i in S'Range loop
    S(i) := toLower(S(i));
    end loop;

end downCase;

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

function compare(    --| Compare two strings
    P, Q: String
    ) return integer
is
    PI, QI: natural;
    PC, QC: character;

begin
    QI := Q'First;
    for PI in P'First .. P'Last loop
      if QI > Q'Last then
    return 1;    -- Q ran out before P did.
      end if;
      PC := toUpper(P(PI));
      QC := toUpper(Q(QI));
      if PC /= QC then
    return character'pos(PC) - character'pos(QC);
      end if;
      QI := QI + 1;
    end loop;
    return P'Length - Q'Length;    -- Equal so far: longer string is greater

end compare;

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

function equal(
    P, Q: String
    ) return boolean is
begin
    return compare(P, Q) = 0;

end equal;

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

function less(
    P, Q: String
    ) return boolean is
begin
    return compare(P, Q) < 0;
end less;


function less_or_equal(
    P, Q: String
    ) return boolean is
begin
    return compare(P, Q) <= 0;
end less_or_equal;


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

function greater(
    P, Q: String
    ) return boolean is
begin
    return compare(P, Q) > 0;
end greater;

function greater_or_equal(
    P, Q: String
    ) return boolean is
begin
    return compare(P, Q) >= 0;
end greater_or_equal;

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

begin

  for I in Character loop
    case I is
      when 'a' .. 'z' =>
        Up_ConvertArray(I) := Character'val(Character'pos(I) - Difference);
      when others =>
        Up_ConvertArray(I) := I;
    end case;
  end loop;

  for I in Character loop
    case I is
      when 'A' .. 'Z' =>
        Down_ConvertArray(I) := Character'val(Character'pos(I) + Difference);
      when others =>
        Down_ConvertArray(I) := I;
    end case;
  end loop;

end case_insensitive_string_comparison;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--CSSC.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package body case_sensitive_string_comparison is

--| Overview
--| Strings are compared one character at a time, stopping as soon as
--| possible.

--| Programmer: M. Gordon

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

function compare(    --| Compare two strings
    P, Q: String
    ) return integer
is
    PI, QI: natural;

begin
    QI := Q'First;
    for PI in P'First .. P'Last loop
      if QI > Q'Last then
    return 1;    -- Q ran out before P did.
      end if;
      if P(PI) /= Q(QI) then
    return character'pos(P(PI)) - character'pos(Q(QI));
      end if;
      QI := QI + 1;
    end loop;
    return P'Length - Q'Length;    -- Equal so far: longer string is greater

end  compare;

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

function equal(
    P, Q: String
    ) return boolean is
begin
    return P = Q;

end equal;

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

function less(
    P, Q: String
    ) return boolean is
begin
    return P < Q;
end less;


function less_or_equal(
    P, Q: String
    ) return boolean is
begin
    return P <= Q;
end less_or_equal;


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

function greater(
    P, Q: String
    ) return boolean is
begin
    return P > Q;
end greater;

function greater_or_equal(
    P, Q: String
    ) return boolean is
begin
    return P >= Q;
end greater_or_equal;

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

end case_sensitive_string_comparison;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--BINTREE.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
generic
    type Value_Type is private;    --| Type of values stored in the tree.

    with function Difference(P, Q: Value_Type) return integer is <>;
    --| Must return a value > 0 if P > Q, 0 if P = Q, and less than
    --| zero otherwise.

package binary_trees_pkg is    --| Efficient implementation of binary trees.

--| OVERVIEW

--| This package is an efficient implementation of unbalanced binary trees.
--| These trees have the following properties:
--|-
--|  1. Inserting a value is cheap (log n Differences per insertion).
--|  2. Finding a value is cheap (log n Differences per querey).
--|  3. Can iterate over the values in sorted order in linear time.
--|  4. Space overhead is moderate (2 "pointers" per value stored).
--|+
--| They are thus useful both for sorting sequences of indeterminate size
--| and for lookup tables.
--|
--| OPERATIONS
--|
--|-The following operations are provided:
--|
--| Insert        Insert a node into a tree
--| Insert_if_not_Found    Insert a node into a tree if not there already
--| Replace_if_Found    Replace a node if duplicate exists, else insert.
--| Destroy        Destroy a tree
--| Destroy_Deep*    Destroy a tree and its contents
--| Balanced_Tree*    Create a balanced tree from values supplied in order
--| Copy*        Copy a tree.  The copy is balanced.
--|
--| Queries:
--|   Is_Empty        Return TRUE iff a tree is empty.
--|   Find        Search tree for a node
--|   Is_Found        Return TRUE iff tree contains specified value.
--|   Size        Return number of nodes in the tree.
--|
--| Iterators:
--|   Visit*        Apply a procedure to every node in specified order
--|   Make_Iter        Create an iterator for ordered scan
--|   More        Test for exhausted iterator
--|   Next        Bump an iterator to the next element
--|
--| * Indicates generic subprogram
--|
--| USAGE
--|
--| The following example shows how to use this package where nodes in
--| the tree are labeled with a String_Type value (for which a natural
--| Difference function is not available).
--|-
--|     package SP renames String_Pkg;
--|
--|     type my_Value is record
--|       label: SP.string_type;
--|       value: integer;
--|     end record;
--|
--|     function differ_label(P, Q: SP.string_type) return integer is
--|     begin
--|       if SP."<"(P, Q) then return -1;
--|       elsif SP."<"(Q, P) then return 1;
--|       else return 0;
--|       end if;
--|     end differ_label;
--|
--|     package my_Tree is new Binary_Trees_pkg(my_Value, differ_Label);
--|
--| Note that the required Difference function may be easily written in terms
--| of "<" if that is available, but that frequently two comparisons must
--| be done for each Difference.  However, both comparisons would have
--| to be done internally by this package for every instantiation if the
--| generic parameter were "<" instead of Difference.
--|
--| PERFORMANCE
--|
--| Every node can be visited in the tree in linear time.  The cost
--| of creating an iterator is small and independent of the size
--| of the tree.
--|
--| Recognizing that comparing values can be expensive, this package
--| takes a Difference function as a generic parameter.  If it took
--| a comparison function such as "<", then two comparisons would be
--| made per node visited during a search of the tree.  Of course this
--| is more costly when "<" is a trivial operation, but in those cases,
--| Difference can be bound to "-" and the overhead in negligable.
--|
--| Two different kinds of iterators are provided.  The first is the
--| commonly used set of functions Make_Iter, More, and Next.  The second
--| is a generic procedure called Visit.  The generic parameter to Visit is
--| a procedure which is called once for each value in the tree.  Visit
--| is more difficult to use and results in code that is not quite as clear,
--| but its overhead is about 20% of the More/Next style iterator.  It
--| is therefore recommended for use only in time critical inner loops.


----------------------------------------------------------------------------
                -- Exceptions --
----------------------------------------------------------------------------

Duplicate_Value: exception;
--| Raised on attempt to insert a duplicate node into a tree.

Not_Found: exception;
--| Raised on attempt to find a node that is not in a tree.

No_More: exception;
--| Raised on attempt to bump an iterator that has already scanned the
--| entire tree.

Out_Of_Order: exception;
--| Raised if a problem in the ordering of a tree is detected.

Invalid_Tree: exception;
--| Value is not a tree or was not properly initialized.

----------------------------------------------------------------------------
                -- Types --
----------------------------------------------------------------------------

type Scan_Kind is (inorder, preorder, postorder);
--| Used to specify the order in which values should be scanned from a tree:
--|-
--| inorder: Left, Node, Right (nodes visited in increasing order)
--| preorder: Node, Left, Right (top down)
--| postorder: Left, Right, Node (bottom up)

type Tree is private;
type Iterator is private;

----------------------------------------------------------------------------
                -- Operations --
----------------------------------------------------------------------------

Function Create        --| Return an empty tree.
    return Tree;

--| Effects: Create and return an empty tree.  Note that this allocates
--| a small amount of storage which can only be reclaimed through
--| a call to Destroy.

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

Procedure Insert(    --| Insert a value into a tree.
    V: Value_Type;    --| Value to be inserted
    T: Tree        --| Tree to contain the new value
    );
--| Raises: Duplicate_Value, Invalid_Tree.

--| Effects: Insert V into T in the proper place.  If a value equal
--| to V (according to the Difference function) is already contained
--| in the tree, the exception Duplicate_Value is raised.
--| Caution: Since this package does not attempt to balance trees as
--| values are inserted, it is important to remember that inserting
--| values in sorted order will create a degenerate tree, where search
--| and insertion is proportional to the N instead of to Log N.  If
--| this pattern is common, use the Balanced_Tree function below.

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

procedure Insert_if_not_Found(
--| Insert a value into a tree, provided a duplicate value is not already there
    V: Value_Type;    --| Value to be inserted
    T: Tree;        --| Tree to contain the new value
    Found: out boolean;    --| Becomes True iff V already in tree
    Duplicate: out Value_Type    --| the duplicate value, if there is one
    ); --| Raises: Invalid_Tree.

--| Effects: Insert V into T in the proper place.  If a value equal
--| to V (according to the Difference function) is already contained
--| in the tree, Found will be True and Duplicate will be the duplicate
--| value.  This might be a sequence of values with the same key, and
--| V can then be added to the sequence.

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

procedure Replace_if_Found(
--| Replace a value if label exists, otherwise insert it.
    V: Value_Type;    --| Value to be inserted
    T: Tree;        --| Tree to contain the new value
    Found: out boolean;    --| Becomes True iff L already in tree
    Old_Value: out Value_Type    --| the duplicate value, if there is one
    ); --| Raises: Invalid_Tree.

--| Effects: Search for V in T.  If found, replace the old value with V,
--| and return Found => True, Old_Value => the old value.  Otherwise,
--| simply insert V into T and return Found => False.

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

procedure Destroy(    --| Free space allocated to a tree.
    T: in out Tree    --| The tree to be reclaimed.
    );

--| Effects: The space allocated to T is reclaimed.  The space occupied by
--| the values stored in T is not however, recovered.

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

generic
    with procedure free_Value(V: in out Value_Type) is <>;

procedure Destroy_Deep(    --| Free all space allocated to a tree.
    T: in out Tree    --| The tree to be reclaimed.
    );

--| Effects: The space allocated to T is reclaimed.  The values stored
--| in T are reclaimed using Free_Value, and the tree nodes themselves
--| are then reclaimed (in a single walk of the tree).

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

generic
    with function next_Value return Value_Type is <>;
    --| Each call to this procedure should return the next value to be
    --| inserted into the balanced tree being created.  If necessary,
    --| this function should check that each value is greater than the
    --| previous one, and raise Out_of_Order if necessary.  If values
    --| are not returned in strictly increasing order, the results are
    --| unpredictable.

Function Balanced_Tree(
    Count: natural
    ) return Tree;

--| Effects: Create a balanced tree by calling next_Value Count times.
--| Each time Next_Value is called, it must return a value that compares
--| greater than the preceeding value.  This function is useful for balancing
--| an existing tree (next_Value iterates over the unbalanced tree) or
--| for creating a balanced tree when reading data from a file which is
--| already sorted.

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

generic
    with function Copy_Value(V: Value_Type) return Value_Type is <>;
    --| This function is called to copy a value from the old tree to the
    --| new tree.

Function Copy_Tree(
    T: Tree
    ) return Tree; --| Raises Invalid_Tree.

--| Effects: Create a balanced tree that is a copy of the tree T.
--| The exception Invalid_Tree is raised if T is not a valid tree.

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

Function Is_Empty(    --| Check for an empty tree.
    T: Tree
    ) return boolean;

--| Effects: Return TRUE iff T is an empty tree or if T was not initialized.

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

Function Find(        --| Search a tree for a value.
    V: Value_Type;    --| Value to be located
    T: Tree        --| Tree to be searched
    ) return Value_Type; --| Raises: Not_Found, Invalid_Tree.

--| Effects: Search T for a value that matches V.  The matching value is
--| returned.  If no matching value is found, the exception Not_Found
--| is raised.


Procedure Find(            --| Search a tree for a value.
    V: Value_Type;        --| Value to be located
    T: Tree;            --| Tree to be searched
    Found: out Boolean;        --| TRUE iff a match was found
    Match: out Value_Type    --| Matching value found in the tree
    ); --| Raises: Invalid_Tree;

--| Effects: Search T for a value that matches V.  On return, if Found is
--| TRUE then the matching value is returned in Match.  Otherwise, Found
--| is FALSE and Match is undefined.

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

function is_Found(    --| Check a tree for a value.
    V: Value_Type;    --| Value to be located
    T: Tree        --| Tree to be searched
    ) return Boolean; --| Raises: Invalid_Tree;

--| Effects: Return TRUE iff V is found in T.

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

function Size(        --| Return the count of values in T.
    T: Tree        --| a tree
    ) return natural;

--| Effects: Return the number of values stored in T.

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

generic
    with procedure Process(V: Value_Type) is <>;

procedure Visit(
    T: Tree;
    Order: Scan_Kind
    ); --| Raises: Invalid_Tree;

--| Effects: Invoke Process(V) for each value V in T.  The nodes are visited
--| in the order specified by Order.  Although more limited than using
--| an iterator, this function is also much faster.

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

function Make_Iter(    --| Create an iterator over a tree
    T: Tree
    ) return Iterator; --| Raises: Invalid_Tree;

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

function More(        --| Test for exhausted iterator
    I: Iterator        --| The iterator to be tested
    ) return boolean;

--| Effects: Return TRUE iff unscanned nodes remain in the tree being
--| scanned by I.


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

procedure Next(        --| Scan the next value in I
    I: in out Iterator;    --| an active iterator
    V: out Value_Type    --| Next value scanned
    ); --| Raises: No_More.

--| Effects: Return the next value in the tree being scanned by I.
--| The exception No_More is raised if there are no more values to scan.

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

private

type Node;
type Node_Ptr is access Node;

type Node is
    record
    Value: Value_Type;
    Less: Node_Ptr;
    More: Node_Ptr;
    end record;

type Tree_Header is
    record
    Count: natural := 0;
    Root: Node_Ptr := Null;
    end record;

type Tree is access Tree_Header;

type Iter_State is (Left, Middle, Right, Done);

type Iterator_Record;
type Iterator is access Iterator_Record;

type Iterator_Record is
    record
    State: Iter_State;
    Parent: Iterator;
    subtree: Node_Ptr;
    end record;


end binary_trees_pkg;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--BINTREE.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with unchecked_deallocation;

Package body Binary_Trees_Pkg is
--| Efficient implementation of binary trees.


----------------------------------------------------------------------------
            -- Local Operations --
----------------------------------------------------------------------------

procedure Free_Node is
    new unchecked_deallocation(Node, Node_Ptr);

procedure Free_Tree is
    new unchecked_deallocation(Tree_Header, Tree);

procedure Free_Iterator is
    new unchecked_deallocation(Iterator_Record, Iterator);

----------------------------------------------------------------------------
            -- Visible Operations --
----------------------------------------------------------------------------

Function Create        --| Return an empty tree.
    return Tree is

begin
    return new Tree_Header'(0, Null);

end Create;

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

Procedure Insert_Node(
    V: Value_Type;
    N: in out Node_Ptr;
    Found: out boolean;
    Duplicate: out Value_Type
    )
is
    D: integer;

begin
    Found := False;
    if N = null then
       N := new Node'(V, Null, Null);
    else
      D := Difference(V, N.Value);
      if D < 0 then
        Insert_Node(V, N.Less, Found, Duplicate);
      elsif D > 0 then
        Insert_Node(V, N.More, Found, Duplicate);
      else
    Found := True;
    Duplicate := N.Value;
      end if;
    end if;
end Insert_Node;

Procedure Replace_Node(
    V: Value_Type;
    N: in out Node_Ptr;
    Found: out boolean;
    Duplicate: out Value_Type
    )
is
    D: integer;

begin
    Found := False;
    if N = null then
       N := new Node'(V, Null, Null);
    else
      D := Difference(V, N.Value);
      if D < 0 then
        Replace_Node(V, N.Less, Found, Duplicate);
      elsif D > 0 then
        Replace_Node(V, N.More, Found, Duplicate);
      else
    Found := True;
    Duplicate := N.Value;
    N.Value := V;
      end if;
    end if;
end Replace_Node;


Procedure Insert(    --| Insert a value into a tree.
    V: Value_Type;    --| Value to be inserted
    T: Tree        --| Tree to contain the new value
    ) --| Raises: Duplicate_Value, Invalid_Tree.
is
    Found: boolean;
    Duplicate: Value_Type;

begin
    if T = null then
    raise Invalid_Tree;
    end if;
    Insert_Node(V, T.Root, Found, Duplicate);
    if Found then
        raise Duplicate_Value;
    end if;
    T.Count := T.Count + 1;
end Insert;


Procedure Insert_if_not_Found(
--| Insert a value into a tree, provided a duplicate value is not already there
    V: Value_Type;    --| Value to be inserted
    T: Tree;        --| Tree to contain the new value
    Found: out boolean;
    Duplicate: out Value_Type
    ) --| Raises: Invalid_Tree.
is
    was_Found: boolean;

begin
    if T = null then
    raise Invalid_Tree;
    end if;
    Insert_Node(V, T.Root, was_Found, Duplicate);
    Found := was_Found;
    if not was_Found then
    T.Count := T.Count + 1;
    end if;

end Insert_if_Not_Found;

procedure Replace_if_Found(
--| Replace a value if label exists, otherwise insert it.
    V: Value_Type;    --| Value to be inserted
    T: Tree;        --| Tree to contain the new value
    Found: out boolean;    --| Becomes True iff L already in tree
    Old_Value: out Value_Type    --| the duplicate value, if there is one
    ) --| Raises: Invalid_Tree.

is
    was_Found: boolean;
    Duplicate: Value_Type;

begin
    if T = null then
    raise Invalid_Tree;
    end if;
    Replace_Node(V, T.Root, was_Found, Duplicate);
    Found := was_Found;
    if was_Found then
    Old_Value := Duplicate;
    else
    T.Count := T.Count + 1;
    end if;

end Replace_if_Found;

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

procedure Destroy_Nodes(
    N: in out Node_Ptr
    ) is
begin
    if N /= null then
        Destroy_Nodes(N.Less);
        Destroy_Nodes(N.More);
        Free_Node(N);
    end if;
end Destroy_Nodes;

procedure Destroy(    --| Free space allocated to a tree.
    T: in out Tree    --| The tree to be reclaimed.
    ) is

begin
    if T /= Null then
      Destroy_Nodes(T.Root);
      Free_Tree(T);
    end if;

end Destroy;

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

procedure Destroy_Deep(    --| Free all space allocated to a tree.
    T: in out Tree    --| The tree to be reclaimed.
    )
is
    procedure Destroy_Nodes(
    N: in out node_Ptr
    ) is
    begin
    if N /= null then
        Free_Value(N.Value);
            Destroy_Nodes(N.Less);
        Destroy_Nodes(N.More);
        Free_Node(N);
    end if;
    end Destroy_Nodes;

begin
    if T /= Null then
      Destroy_Nodes(T.Root);
      Free_Tree(T);
    end if;

end Destroy_Deep;

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

Function Balanced_Tree(
    Count: natural
    ) return Tree

is
    new_Tree: Tree := Create;

    procedure subtree(Count: natural; N: in out Node_Ptr)
    is
    new_Node: Node_Ptr;

    begin
    if Count = 1 then
      new_Node := new Node'(next_Value, Null, Null);
    elsif Count > 1 then
      new_node := new Node;
      subtree(Count/2, new_Node.Less);        -- Half are less
      new_Node.Value := next_Value;            -- Median value
      subtree(Count - Count/2 - 1, new_Node.More);    -- Other half are more
    end if;
    N := new_Node;
    end subtree;

begin
    new_Tree.Count := Count;
    subtree(Count, new_Tree.Root);
    return new_Tree;

end Balanced_Tree;

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

Function Copy_Tree(
    T: Tree
    ) return Tree
is
    I: Iterator;

    function next_Val return Value_type
    is
    V: Value_Type;

    begin
    Next(I, V);
    return copy_Value(V);
    end next_Val;

    function copy_Balanced is new Balanced_Tree(next_Val);

begin
    I := Make_Iter(T);    -- Will raise Invalid_Tree if necessary
    return copy_Balanced(Size(T));

end Copy_Tree;

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

Function Is_Empty(    --| Check for an empty tree.
    T: Tree
    ) return boolean is
begin
    return T = Null or else T.Root = Null;

end Is_Empty;

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

procedure Find_Node(
    V: Value_Type;        --| Value to be located
    N: Node_Ptr;        --| subtree to be searched
    Match: out Value_Type;    --| Matching value found in the tree
    Found: out Boolean        --| TRUE iff a match was found
    )
is
    D: integer;

begin
    if N = null then
        Found := False;
    return;
    end if;
    D := Difference(V, N.Value);
    if D < 0 then
        Find_Node(V, N.Less, Match, Found);
    elsif D > 0 then
        Find_Node(V, N.More, Match, Found);
    else
        Match := N.Value;
    Found := TRUE;
    end if;
end Find_Node;

Function Find(        --| Search a tree for a value.
    V: Value_Type;    --| Value to be located
    T: Tree        --| Tree to be searched
    ) return Value_Type --| Raises: Not_Found.
is
    Found: Boolean;
    Match: Value_Type;

begin
    if T = Null then
    raise Invalid_Tree;
    end if;
    Find_Node(V, T.Root, Match, Found);
    if Found then
    return Match;
    else
    raise Not_Found;
    end if;
end Find;

Procedure Find(            --| Search a tree for a value.
    V: Value_Type;        --| Value to be located
    T: Tree;            --| Tree to be searched
    Found: out Boolean;        --| TRUE iff a match was found
    Match: out Value_Type    --| Matching value found in the tree
    ) is
begin
    if T = Null then
    raise Invalid_Tree;
    end if;
    Find_Node(V, T.Root, Match, Found);
end Find;

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

function is_Found(    --| Check a tree for a value.
    V: Value_Type;    --| Value to be located
    T: Tree        --| Tree to be searched
    ) return Boolean
is
    Found: Boolean;
    Match: Value_Type;

begin
    if T = Null then
    raise Invalid_Tree;
    end if;
    Find_Node(V, T.Root, Match, Found);
    return Found;

end is_Found;

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

function Size(        --| Return the count of values in T.
    T: Tree        --| a tree
    ) return natural is

begin
    if T = Null then
    Return 0;
    else
        Return T.Count;
    end if;

end Size;

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

procedure Visit(
    T: Tree;
    Order: Scan_Kind
    ) is

    procedure visit_Inorder(N: Node_Ptr) is
    begin
    if N.Less /= null then
      visit_Inorder(N.Less);
    end if;
    Process(N.Value);
    if N.More /= null then
      visit_Inorder(N.More);
    end if;
    end visit_Inorder;

    procedure visit_preorder(N: Node_Ptr) is
    begin
    Process(N.Value);
    if N.Less /= null then
      visit_preorder(N.Less);
    end if;
    if N.More /= null then
      visit_preorder(N.More);
    end if;
    end visit_preorder;

    procedure visit_postorder(N: Node_Ptr) is
    begin
    if N.Less /= null then
      visit_postorder(N.Less);
    end if;
    if N.More /= null then
      visit_postorder(N.More);
    end if;
    Process(N.Value);
    end visit_postorder;

begin
    if T = Null then
    raise Invalid_Tree;
    else
      case Order is
    when inorder =>
      Visit_Inorder(T.Root);
    when preorder =>
      Visit_preorder(T.Root);
    when postorder =>
      Visit_postorder(T.Root);
      end case;
    end if;
end Visit;

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

function subtree_Iter(    --| Create an iterator over a subtree
    N: Node_Ptr;
    P: Iterator
    ) return Iterator is

begin
    if N = Null then
      return new Iterator_Record'(State => Done, Parent => P, subtree => N);
    elsif N.Less = Null then
      return new Iterator_Record'(State => Middle, Parent => P, subtree => N);
    else
      return new Iterator_Record'(State => Left, Parent => P, subtree => N);
    end if;

end subtree_Iter;

function Make_Iter(    --| Create an iterator over a tree
    T: Tree
    ) return Iterator is

begin
    if T = Null then
    raise Invalid_Tree;
    end if;
    return subtree_Iter(T.Root, Null);

end Make_Iter;

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

function More(        --| Test for exhausted iterator
    I: Iterator        --| The iterator to be tested
    ) return boolean is

begin
    if I = Null then
    return False;
    elsif I.Parent = Null then
    return I.State /= Done and I.subtree /= Null;
    elsif I.State = Done then
    return More(I.Parent);
    else
    return True;
    end if;

end More;

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

procedure pop_Iterator(
    I: in out Iterator
    )
is
    NI: Iterator;
begin
    loop
      NI := I;
      I := I.Parent;
      Free_Iterator(NI);
      exit when I = Null;
      exit when I.State /= Done;
    end loop;
end pop_Iterator;

procedure Next(        --| Scan the next value in I
    I: in out Iterator;    --| an active iterator
    V: out Value_Type    --| Next value scanned
    ) --| Raises: No_More.
is
    NI: Iterator;

begin
    if I = Null or I.State = Done then
    raise No_More;
    end if;
    case I.State is
      when Left =>    -- Return the leftmost value
    while I.subtree.Less /= Null loop    -- Find leftmost subtree
      I.State := Middle;    -- Middle is next at this level
      I := subtree_Iter(I.subtree.Less, I);
    end loop;
    V := I.subtree.Value;
    if I.subtree.More /= Null then    -- There will be more...
      I.State := Right;        -- ... coming from the right
    else                -- Nothing else here
      pop_Iterator(I);        -- Pop up to parent iterator
    end if;
      when Middle =>
    V := I.subtree.Value;
    if I.subtree.More /= Null then    -- There will be more...
      I.State := Right;        -- ... coming from the right
    else                -- Nothing else here so...
      pop_Iterator(I);        -- ... Pop up to parent iterator
    end if;
      when Right =>    -- Return the value on the right
    I.State := Done;    -- No more at this level
    I := subtree_Iter(I.subtree.More, I);
    Next(I, V);
      when Done =>
    pop_Iterator(I);
    Next(I, V);
    end case;

end Next;

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


end binary_trees_pkg;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--LBINTREE.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with Binary_Trees_Pkg;

generic
    type Label_Type is private;    --| Type for labels stored in the tree.
    type Value_Type is private;    --| Type for values stored in the tree.

    with function Difference(P, Q: Label_Type) return integer is <>;
    --| Must return a value > 0 if P > Q, 0 if P = Q, and less than
    --| zero otherwise, where P and Q are labels.

package labeled_binary_trees_pkg is
--| Efficient implementation of labeled binary trees.

--| OVERVIEW

--| This package provides labeled binary trees, which are the same as
--| unlabeled binary trees except that when searching for or inserting
--| a value into the tree, only the label field is compared.
--|
--| OPERATIONS
--|
--|-The following operations are provided:
--|
--| Insert        Insert a node into a tree
--| Destroy        Destroy a tree
--| Destroy_Deep*    Destroy a tree and its contents
--| Balanced_Tree*    Create a balanced tree from values supplied in order
--| Copy*        Copy a tree.  The copy is balanced.
--|
--| Queries:
--|   Is_Empty        Return TRUE iff a tree is empty.
--|   Find        Search tree for a node
--|   Is_Found        Return TRUE iff tree contains specified value.
--|   Size        Return number of nodes in the tree.
--|
--| Iterators:
--|   Visit*        Apply a procedure to every node in specified order
--|   Make_Iter        Create an iterator for ordered scan
--|   More        Test for exhausted iterator
--|   Next        Bump an iterator to the next element
--|
--| * Indicates generic subprogram
--|
--| USAGE: (See Overview of Binary_Trees_Package)
--|
--| PERFORMANCE: (See Overview of Binary_Trees_Package)


----------------------------------------------------------------------------
-- This should be private (but cannot be)

type Label_Value_Pair is
    record
    Label: Label_Type;
    Value: Value_Type;
    end record;

function LV_Differ(P, Q: Label_Value_Pair) return integer;
package LVT is new Binary_Trees_Pkg(Label_Value_Pair, LV_Differ);

----------------------------------------------------------------------------
                -- Exceptions --
----------------------------------------------------------------------------

Duplicate_Value: exception renames LVT.Duplicate_Value;
--| Raised on attempt to insert a duplicate label into a tree.

Not_Found: exception renames LVT.Not_Found;
--| Raised on attempt to find a label that is not in a tree.

No_More: exception renames LVT.No_More;
--| Raised on attempt to bump an iterator that has already scanned the
--| entire tree.

Out_Of_Order: exception renames LVT.Out_Of_Order;
--| Raised if a problem in the ordering of a tree is detected.

Invalid_Tree: exception renames LVT.Invalid_Tree;
--| Value is not a tree or was not properly initialized.

----------------------------------------------------------------------------
                -- Types --
----------------------------------------------------------------------------

subtype Scan_Kind is LVT.Scan_Kind;

--? function InOrder return LVT.Scan_Kind renames LVT.InOrder;

InOrder: constant Scan_Kind := LVT.InOrder;
PreOrder: constant Scan_Kind := LVT.PreOrder;
PostOrder: constant Scan_Kind := LVT.PostOrder;

--| is (inorder, preorder, postorder);
--| Used to specify the order in which values should be scanned from a tree:
--|-
--| inorder: Left, Node, Right (nodes visited in increasing order)
--| preorder: Node, Left, Right (top down)
--| postorder: Left, Right, Node (bottom up)

subtype Tree is LVT.Tree;
subtype Iterator is LVT.Iterator;

----------------------------------------------------------------------------
                -- Operations --
----------------------------------------------------------------------------

Function Create        --| Return an empty tree.
    return Tree renames LVT.Create;

--| Effects: Create and return an empty tree.  Note that this allocates
--| a small amount of storage which can only be reclaimed through
--| a call to Destroy.

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

Procedure Insert(    --| Insert a label/value into a tree.
    L: Label_Type;    --| Label to be associated with a value
    V: Value_Type;    --| Value to be inserted
    T: Tree        --| Tree to contain the new value
    );
--| Raises: Duplicate_Value, Invalid_Tree.

--| Effects: Insert (L, V) into T in the proper place.  If a label equal
--| to L (according to the Difference function) is already contained
--| in the tree, the exception Duplicate_Label is raised.
--| Caution: Since this package does not attempt to balance trees as
--| values are inserted, it is important to remember that inserting
--| labels in sorted order will create a degenerate tree, where search
--| and insertion is proportional to the N instead of to Log N.  If
--| this pattern is common, use the Balanced_Tree function below.

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

procedure Insert_if_not_Found(
--| Insert a value into a tree, provided a duplicate value is not already there
    L: Label_Type;    --| Label to look for
    V: Value_Type;    --| Value to be inserted
    T: Tree;        --| Tree to contain the new value
    Found: out boolean;    --| Becomes True iff L already in tree
    Duplicate: out Value_Type    --| the duplicate value, if there is one
    ); --| Raises: Invalid_Tree.

--| Effects: Insert V into T in the proper place.  If a value equal
--| to V (according to the Difference function) is already contained
--| in the tree, Found will be True and Duplicate will be the duplicate
--| value.  This might be a sequence of values with the same key, and
--| V can then be added to the sequence.

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

procedure Replace_if_Found(
--| Replace a value if label exists, otherwise insert it.
    L: Label_Type;    --| Label to look for
    V: Value_Type;    --| Value to be inserted
    T: Tree;        --| Tree to contain the new value
    Found: out boolean;    --| Becomes True iff L already in tree
    Old_Value: out Value_Type    --| the duplicate value, if there is one
    ); --| Raises: Invalid_Tree.

--| Effects: Search for L in T.  If found, replace the old value with V,
--| and return Found => True, Old_Value => the old value.  Otherwise,
--| simply insert the L, V pair into T and return Found => False.

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

procedure Destroy(    --| Free space allocated to a tree.
    T: in out Tree    --| The tree to be reclaimed.
    ) renames LVT.Destroy;

--| Effects: The space allocated to T is reclaimed.  The space occupied by
--| the values stored in T is not however, recovered.

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

generic
    with procedure free_Value(V: in out Value_Type) is <>;
    with procedure free_Label(L: in out Label_Type) is <>;

procedure Destroy_Deep(    --| Free all space allocated to a tree.
    T: in out Tree    --| The tree to be reclaimed.
    );

--| Effects: The space allocated to T is reclaimed.  The values and
--| labels stored it T are reclaimed using Free_Label and
--| Free_Value, and the tree nodes themselves
--| are then reclaimed (in a single walk of the tree).

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

generic
    with Procedure Next_Pair(
    L: in out Label_Type;
    V: in out Value_Type
    )
    is <>;

    --| Each call to this procedure should return the next (Label, Value)
    --| pair to be
    --| inserted into the balanced tree being created.  If necessary,
    --| this function should check that each value is greater than the
    --| previous one, and raise Out_of_Order if necessary.  If values
    --| are not returned in strictly increasing order, the results are
    --| unpredictable.

Function Balanced_Tree(
    Count: natural
    ) return Tree;

--| Effects: Create a balanced tree by calling next_Pair Count times.
--| Each time Next_Pair is called, it must return a label that compares
--| greater than the preceeding label.  This function is useful for balancing
--| an existing tree (next_Pair iterates over the unbalanced tree) or
--| for creating a balanced tree when reading data from a file which is
--| already sorted.

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

generic
    with function Copy_Label(L: Label_Type) return Label_Type is <>;
    with function Copy_Value(V: Value_Type) return Value_Type is <>;
    --| This function is called to copy a value from the old tree to the
    --| new tree.

Function Copy_Tree(
    T: Tree
    ) return Tree; --| Raises Invalid_Tree.

--| Effects: Create a balanced tree that is a copy of the tree T.
--| The exception Invalid_Tree is raised if T is not a valid tree.

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

Function Is_Empty(    --| Check for an empty tree.
    T: Tree
    ) return boolean renames LVT.Is_Empty;

--| Effects: Return TRUE iff T is an empty tree or if T was not initialized.

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

Function Find(        --| Search a tree for a value.
    L: Label_Type;    --| Label to be located
    T: Tree        --| Tree to be searched
    ) return Value_Type; --| Raises: Not_Found, Invalid_Tree.

--| Effects: Search T for a label that matches L.  The corresponding value
--| is returned.  If no matching label is found, the exception Not_Found
--| is raised.


Procedure Find(            --| Search a tree for a value.
    L: Label_Type;        --| Label to be located
    T: Tree;            --| Tree to be searched
    Found: out Boolean;        --| TRUE iff a match was found
    Match: out Value_Type    --| Matching value found in the tree
    ); --| Raises: Invalid_Tree;

--| Effects: Search T for a label that matches L.  On return, if Found is
--| TRUE then the corresponding value is returned in Match.  Otherwise,
--| Found is FALSE and Match is undefined.

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

function is_Found(    --| Check a tree for a value.
    L: Label_Type;    --| Label to be located
    T: Tree        --| Tree to be searched
    ) return Boolean; --| Raises: Invalid_Tree;

--| Effects: Return TRUE iff L is found in T.

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

function Size(        --| Return the count of values in T.
    T: Tree        --| a tree
    ) return natural renames LVT.Size;

--| Effects: Return the number of values stored in T.

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

generic
    with procedure Process(L: Label_Type; V: Value_Type) is <>;

procedure Visit(
    T: Tree;
    Order: Scan_Kind
    ); --| Raises: Invalid_Tree;

--| Effects: Invoke Process(V) for each value V in T.  The nodes are visited
--| in the order specified by Order.  Although more limited than using
--| an iterator, this function is also much faster.

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

function Make_Iter(    --| Create an iterator over a tree
    T: Tree
    ) return Iterator renames LVT.Make_Iter; --| Raises: Invalid_Tree;

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

function More(        --| Test for exhausted iterator
    I: Iterator        --| The iterator to be tested
    ) return boolean renames LVT.More;

--| Effects: Return TRUE iff unscanned nodes remain in the tree being
--| scanned by I.


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

procedure Next(        --| Scan the next value in I
    I: in out Iterator;    --| an active iterator
    L: out Label_Type;    --| Next label scanned
    V: out Value_Type    --| Next value scanned
    ); --| Raises: No_More.

--| Effects: Return the next value in the tree being scanned by I.
--| The exception No_More is raised if there are no more values to scan.

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

end labeled_binary_trees_pkg;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--LBINTREE.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package body labeled_binary_trees_pkg is
--| Efficient implementation of labeled binary trees.

--| OVERVIEW

--| Implemented using Binary_Trees_Pkg.

----------------------------------------------------------------------------
                -- Implementation --
----------------------------------------------------------------------------
-- For the pseudo-private part

function LV_Differ(P, Q: Label_Value_Pair) return integer is
begin
    return Difference(P.Label, Q.Label);

end LV_Differ;

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

Procedure Insert(    --| Insert a label/value into a tree.
    L: Label_Type;    --| Label to be associated with a value
    V: Value_Type;    --| Value to be inserted
    T: Tree        --| Tree to contain the new value
    ) is

begin
    LVT.Insert(Label_Value_Pair'(L, V), T);

end Insert;

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

Procedure Insert_if_not_Found(
--| Insert a value into a tree, provided a duplicate value is not already there
    L: Label_Type;    --| Label to look for
    V: Value_Type;    --| Value to be inserted
    T: Tree;        --| Tree to contain the new value
    Found: out boolean;
    Duplicate: out Value_Type
    ) --| Raises: Invalid_Tree.
is
    was_Found: boolean;
    Match: Label_Value_Pair;

begin
    LVT.Insert_If_Not_Found(Label_Value_Pair'(L, V), T, was_Found, Match);
    Found := was_Found;
    if was_Found then
    Duplicate := Match.Value;
    end if;

end Insert_if_Not_Found;

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

procedure Replace_if_Found(
--| Replace a value if label exists, otherwise insert it.
    L: Label_Type;    --| Label to look for
    V: Value_Type;    --| Value to be inserted
    T: Tree;        --| Tree to contain the new value
    Found: out boolean;    --| Becomes True iff L already in tree
    Old_Value: out Value_Type    --| the duplicate value, if there is one
    ) --| Raises: Invalid_Tree.
is
    was_Found: boolean;
    Match: Label_Value_Pair;

begin
    LVT.Replace_if_Found(Label_Value_Pair'(L, V), T, was_Found, Match);
    Found := was_Found;
    if was_Found then
    Old_Value := Match.Value;
    end if;

end Replace_if_Found;

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

procedure Destroy_Deep(    --| Free all space allocated to a tree.
    T: in out Tree    --| The tree to be reclaimed.
    ) is

    procedure Destroy_Pair(P: in out Label_Value_Pair) is
    begin
    free_Value(P.Value);
    free_Label(P.Label);

    end Destroy_Pair;

    procedure LV_Destroy_Deep is new LVT.Destroy_Deep(Destroy_Pair);

begin
    LV_Destroy_Deep(T);

end Destroy_Deep;

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

function Balanced_Tree(
    Count: natural
    ) return Tree
is
    function Next return Label_Value_Pair is
    L: Label_Type;
    V: Value_Type;
    begin
    Next_Pair(L, V);    -- this is provided with instantiation
    return Label_Value_Pair'(L, V);

    end Next;

    function LV_Balanced_Tree is new LVT.Balanced_Tree(Next);

begin
    return LV_Balanced_Tree(Count);

end Balanced_Tree;

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

function Copy_Tree(
    T: Tree
    ) return Tree
is
    function Copy_Pair(P: Label_Value_Pair) return Label_Value_Pair is
    begin
    return Label_Value_Pair'(copy_Label(P.Label), copy_Value(P.Value));

    end Copy_Pair;

    function LV_Copy_Tree is new LVT.Copy_Tree(Copy_Pair);

begin
    return LV_Copy_Tree(T);

end Copy_Tree;

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

Function Find(        --| Search a tree for a value.
    L: Label_Type;    --| Label to be located
    T: Tree        --| Tree to be searched
    ) return Value_Type --| Raises: Not_Found, Invalid_Tree.
is
    P: Label_Value_Pair;

begin
    P.Label := L;
    P := LVT.Find(P, T);
    return P.Value;

end Find;


Procedure Find(            --| Search a tree for a value.
    L: Label_Type;        --| Label to be located
    T: Tree;            --| Tree to be searched
    Found: out Boolean;        --| TRUE iff a match was found
    Match: out Value_Type    --| Matching value found in the tree
    ) --| Raises: Invalid_Tree;

is
    P: Label_Value_Pair;
    was_Found: boolean;

begin
    P.Label := L;
    LVT.Find(P, T, was_Found, P);
    Found := was_Found;
    if was_Found then
      Match := P.Value;
    end if;

end Find;

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

function is_Found(    --| Check a tree for a value.
    L: Label_Type;    --| Label to be located
    T: Tree        --| Tree to be searched
    ) return Boolean    --| Raises: Invalid_Tree;
is
    P: Label_Value_Pair;
    Found: Boolean;

begin
    P.Label := L;
    LVT.Find(P, T, Found, P);
    return Found;

end is_Found;


--| Effects: Return TRUE iff L is found in T.

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

procedure Visit(
    T: Tree;
    Order: Scan_Kind
    )
is
    procedure Process_Pair(P: Label_Value_Pair) is
    begin
    Process(P.Label, P.Value);

    end Process_Pair;

    procedure LV_Visit is new LVT.Visit(Process_Pair);

begin
    LV_Visit(T, Order);

end Visit;


--| Effects: Invoke Process(V) for each value V in T.  The nodes are visited
--| in the order specified by Order.  Although more limited than using
--| an iterator, this function is also much faster.

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

procedure Next(        --| Scan the next value in I
    I: in out Iterator;    --| an active iterator
    L: out Label_Type;    --| Next label scanned
    V: out Value_Type    --| Next value scanned
    )
is
    P: Label_Value_Pair;

begin
    LVT.Next(I, P);
    L := P.Label;
    V := P.Value;

end Next;

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


end labeled_binary_trees_pkg;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--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
--| DestroyDeep     destroy a list as well as the elements in that list
--| Equal           are two lists equal
--| FirstValue      get the information from the first element of a list
--| Forward         advances an iterator
--| 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
--| MakeList        this takes a single element and returns 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
--| CellValue       this takes an iterator and returns the value of the element
--|                 whose position the iterator holds
--|

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

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

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

function DeleteItem(            --| remove the first occurrence of Element
                                --| from L
      L:       in     List;     --| list element is being  removed from
      Element: in     ItemType  --| element being removed
) return List;

--| EFFECTS
--| This returns the List L with the first occurrence of Element removed.

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

function DeleteItems (          --| remove all occurrences of Element
                                --| from  L.
      L:       in     List;     --| The List element is being removed from
      Element: in     ItemType  --| element being removed
) return List;

--| EFFECTS
--| This function returns a copy of the list L which has all elements which
--| have value Element removed.

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

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

--| EFFECTS
--| This procedure removes all occurrences of Element from the List L.  This
--| is a destructive procedure.

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

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.

------------------------------------------------------------------------------
generic
    with procedure Dispose (I :in out ItemType);

procedure DestroyDeep (  --| Destroy a list as well as all objects which
                         --| comprise an element of the list.
    L :in out List
);


--| OVERVIEW
--| This procedure is used to destroy a list and all the objects contained
--| in an element of the list.  For example if L is a list of lists
--| then destroy L does not destroy the lists which are elements of L.
--| DestroyDeep will now destroy L and all the objects in the elements of L.
--| The produce Dispose is a procedure which will destroy the objects which
--| comprise an element of a list.  For example if package  L was  a list
--| of lists then Dispose for L would be the Destroy of list type package L was
--| instantiated with.

--| REQUIRES
--| This procedure requires no sharing  between elements of lists.
--| For example if L_int is a list of integers and L_of_L_int is a list
--| of lists of integers and two elements of L_of_L_int have the same value
--| then doing a DestroyDeep will cause an access violation to be raised.
--| The best way to avoid this is not to have sharing between list elements
--| or use copy functions when adding to the list of lists.

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

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.

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

procedure Forward (            --| Advances the iterator.
          I :in out ListIter   --| The iterator.
);

--| OVERVIEW
--| This procedure can be used in conjunction with Cell to iterate over a list.
--| This is in addition to Next.  Instead of writing
--|
--|  I :ListIter;
--|  L :List;
--|  V :List_Element_Type;
--|
--|  I := MakeListIter(L);
--|  while More(I) loop
--|      Next (I, V);
--|      Print (V);
--|  end loop;
--|
--| One can write
--| I := MakeListIter(L);
--| while More (I) loop
--|     Print (Cell (I));
--|     Forward (I);
--| end loop;

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

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 MakeList (   --| This takes in an element and returns a List.
       E :in     ItemType
) return List;

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

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 CellValue (    --| Return the value of the element where the iterator is
            --| positioned.
         I :in     ListIter
) return ItemType;

--| OVERVIEW
--| This returns the value of the element at the position of the iterator.
--| This is used in conjunction with Forward.

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


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;

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

function DeleteItem(            --| remove the first occurrence of Element
                                --| from L
      L:       in     List;     --| list element is being  removed from
      Element: in     ItemType  --| element being removed
) return List is
    I       :List;
    Result  :List;
    Found   :boolean := false;
begin
    --| ALGORITHM
    --| Attach all elements of L to Result except the first element in L
    --| whose value is Element.  If the current element pointed to by I
    --| is not equal to element or the element being skipped was found
    --| then attach the current element to Result.

    I := L;
    while (I /= null) loop
        if (not Equal (I.Info, Element)) or (Found) then
            Attach (Result, I.Info);
        else
           Found := true;
        end if;
        I := I.Next;
    end loop;
    return Result;
end DeleteItem;

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

function DeleteItems (          --| remove all occurrences of Element
                                --| from  L.
      L:       in     List;     --| The List element is being removed from
      Element: in     ItemType  --| element being removed
) return List is
    I       :List;
    Result  :List;
begin
    --| ALGORITHM
    --| Walk over the list L and if the current element does not equal
    --| Element then attach it to the list to be returned.

    I := L;
    while I /= null loop
        if not Equal (I.Info, Element) then
            Attach (Result, I.Info);
        end if;
        I := I.Next;
    end loop;
    return Result;
end DeleteItems;

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

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

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

   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;

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

   procedure DestroyDeep (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;
           Dispose (HoldPlace.Info);
           Free (HoldPlace);
       end loop;
       L := null;
   end DestroyDeep;

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

   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 Forward (I: in out ListIter) is

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

   begin
       if I = null then
           raise NoMore;
       else
           I := ListIter (I.Next);
       end if;
   end Forward;

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

   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 MakeList (
          E :in     ItemType
   ) return List is

   begin
       return new Cell ' (Info => E, Next => null);
   end;

--------------------------------------------------------------------------
   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
    --| EmptyList is raised.

    begin
    if L = null then
        raise EmptyList;
    else
        return L.Next;
    end if;
    end Tail;

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

    function CellValue (
           I :in ListIter
    ) return ItemType is
        L :List;
    begin
          -- Convert I to a List type and then return the value it points to.
        L := List(I);
        return L.Info;
    end CellValue;

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

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


--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--ltrees.spc
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

with Lists;
generic
    type Label_Type is private;
                       --| This is used to identify nodes in the tree.

    type Value_Type is private;
                       --| Information being contained in a node of tree


    with function "<" (
               X  :in    Label_Type;
               Y  :in    Label_Type
    ) return boolean is <> ;
                       --| Function which defines ordering of nodes
                       --| a < b -> not (b < a) and  (b /= a) for all a and b.
package Labeled_Trees  is

--| Overview
--| This package creates an ordered binary tree.  This will allow for
--| quick insertion, and search.
--|
--| The tree is organized such that
--|
--|  label (leftchild) < label (root)    label (root) < label (rightchild)
--|
--| This means that by doing a left to right search of the tree will
--| produce the nodes of the tree in ascending order.





--                             Types
--                             -----

type Tree is  private;     --| This is the type exported to represent the
                           --| tree.


type Tree_Iter is private;  --| This is the type which is used to iterate
                            --| over the set.

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

Label_Already_Exists_In_Tree :exception;
Label_Not_Present            :exception;
No_More                      :exception;
Tree_Is_Empty                :exception;

--|                          Operations
--|                          ----------
--|
--| Create              Creates a tree.
--| Destroy_Tree        Destroys the given tree and returns the spaces.
--| Destroy_Deep_Tree   Destroys all space associated with a tree.  This
--|                     includes all nodes and the label and value associated
--|                     with each node.
--| Fetch_Value         Given a tree and or a label this returns the value
--|                     associated with the tree or label.
--| Get_Tree            Given a tree and a label this returns the tree
--|                     whose root is at the label.
--| Forward             This advances the iterator to the next node in the
--|                     iteration.
--| Insert_Node         This inserts a node n into a tree t.
--| Is_Empty            Returns true if the tree is empty false otherwise.
--| Iterator_Label      This returns the label of the node which corresponds
--|                     to the given iterator.
--| Iterator_Value      This returns the value of the node which corresponds
--|                     to the given iterator.
--| Make_Tree           This takes a label and a value and returns a tree.
--| Make_Tree_Iter_In   This returns an iterator to the user in order to start
--|                     an inorder iteration of the tree.  Inorder means
--|                     scan left child, scan node, scan right child.
--| Make_Tree_Iter_Pre  This returns an iterator to the use in order to
--|                     start a preorder scan of the tree. Preorder is
--|                     scan node, scan left child, scan right child.
--| Make_Tree_Iter_Post This returns an iterator to the user in order to
--|                     start a postorder scan of the tree. Postorder
--|                     means scan the left child, right child and then the
--|                     node.
--| 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.
--| Store_Value         Replaces the given node's information with
--|                     the given information.

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

function Create             --| This function creates the tree.

return Tree;

--| Effects
--| This creates a tree containing no information and no children.  An
--| emptytree.

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

generic
  with procedure Dispose_Label (L :in out Label_Type);
  with procedure Dispose_Value (V :in out Value_Type);
procedure Destroy_Deep_Tree (     --| Procedure destroys all nodes in a tree
                                  --| and the label and value assoiciated with
                                  --| each node.
  T :in out Tree
);

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

procedure Destroy_Tree (         --| Destroys a tree.
          T  :in out Tree        --| Tree being destroyed.
);

--| Effects
--| Destroys a tree and returns the space which it is occupying.

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

function Fetch_Value (         --| Get the value of the node with the given
                               --| label.
       T :in     Tree;         --| The tree which contains the node.
       L :in     Label_Type    --| The label of the node.
) return Value_Type;

--| Effects
--| If the label is not present Label_Not_Present is raised.

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

function Fetch_Value (  --| Return the value stored at the root node
                        --| of the given tree.
         T :in Tree
) return Value_Type;

--| Effects
--| Raises Label_Not_Present if the tree T is empty.

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

function Get_Tree (         --| Get the subtree whose root is labelled L.
       T :in    Tree;       --| Tree which contains the label L.
       L :in    Label_Type  --| The label being searched for.
) return Tree;

--| Raises
--| Raises Label_Not_Present if the label L is not in T.

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

procedure Forward (        --| Advances the iterator to the next node in
                           --| the iteration.
  I :in out Tree_Iter      --| Iterator being advance.
);

--| OVERVIEW
--| This is used to advance the iterator.  Typically this is used in
--| conjunction with Node_Value and Node_Label.

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

procedure Insert_Node(            --| This procedure inserts a node into the
                                  --| specified tree.
       T      :in out Tree;       --| Tree being inserted into.
       L      :in     Label_Type; --| The label for the value being inserted.
       V      :in     Value_Type  --| The information to be contained in the
                                  --| node being inserted.

);
--| EFFECTS
--| This adds the node with label L to the tree T.  Label_Already_Exists is
--| raised if L already exists in T.

--| MODIFIES
--| This modifies the tree T by adding a node whose label is l and value is v.

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

function Is_Empty (        --| Returns true if the tree is empty false
                           --| otherwise.
         T :in     Tree
) return boolean;

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


function Is_Label_In_Tree (            --| Is the given label in the given
                                       --| tree.
         T :in    Tree;                --| The tree being searched.
         L :in    Label_Type           --| The label being searched for.
) return boolean;

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

procedure Is_Label_In_Tree (      --| Sets the variable Present to true if
                                  --| the given label is in the given tree.
           T       :in     Tree;        --| Tree being searched.
           L       :in     Label_Type;  --| Label being searched for.
           Subtree :   out Tree;        --| Subtree which is contains label.
           Present :   out boolean      --| True if label is in tree, false
                                        --| if not.
);

--| OVERVIEW
--| This operation can be used to see if a label is in the tree.
--| If it is the Subtree out parameter can then be used to
--| to update the value field of the label.  The sequence would be
--|
--|  Is_Label_In_Tree (T, L, Subtree, Present);
--|  if Present then
--|     Store_Value (Subtree, SomeValue);
--|  end if;
--|
--| If the label is not Present then Subtree is the root of the tree
--| where the label would be stored if it were present.  Thus the following
--| sequence would be useful.
--|
--| Is_Label_In_Tree (T, L, Subtree, Present);
--| if not Present then
--|    Insert_Node (Subtree, L, V);
--| end if;
--|
--| The advantage to this routine is that the tree need only be searched
--| once instead of twice once for the existence check and then once for
--| the insertion.

--| MODIFIES
--| The tree T, also sets the variables Present and Subtree.

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

function Iterator_Label (  --| Returns the label of the node corresponding
                           --| to the iterator.
  I :in      Tree_Iter     --| Iterator.
) return Label_Type;

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

function Iterator_Value (  --| Returns the value of the node corresponding
                           --| to the iterator.
  I :in      Tree_Iter     --| Iterator.
) return Value_Type;

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

function Make_Tree (          --| This creates a tree given a label and a
                              --| value.
       L :in     Label_Type;  --| The label.
       V :in     Value_Type   --| The value.
) return Tree;

--| EFFECTS
--| Creates a tree whose root has the given label and value.

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

function Make_Tree_Iter_In  (  --| This sets up an iteration of the nodes
                               --| of the tree in inorder.
        T :in     Tree         --| Tree being iterated over
) return Tree_Iter;


--| EFFECTS
--| By using the Next operations the nodes of the tree are returned in
--| in post order. Inorder means return the left child then the node
--| then the right child.

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

function Make_Tree_Iter_Post (  --| This sets up an iteration of the nodes
                                --| of the tree in postorder.
        T :in     Tree          --| Tree being iterated over
) return Tree_Iter;


--| EFFECTS
--| By using the Next operations the nodes of the tree are returned in
--| post order. Post order means return the node first then its left child
--| and then its right child.

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

function Make_Tree_Iter_Pre (   --| This sets up an iteration of the nodes
                                --| of the tree in preorder.  Then nodes
                                --| of the tree are returned in ascending
                                --| order.
        T :in     Tree          --| Tree being iterated over
) return Tree_Iter;


--| EFFECTS
--| By using the Next operations the nodes of the tree are returned in
--| ascending order.

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

function More (                 --| Returns true if there are more elements
                                --| in the tree to iterate over.
          I :in Tree_Iter
) return boolean;


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

procedure Next (                --| This returns the next element in the
                                --| iteration.
    I :in out Tree_Iter;        --| The Iter which marks the position in the
                                --| Tree.
    V :   out Value_Type        --| Information being returned from a node.
);
--| EFFECTS
--| No_More is raised when after the last element has been returned an attempt
--| is made to get another element.


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

procedure Next (                --| This is the iterator operation.
    I :in out Tree_Iter;        --| The iterator which marks the position in
                                --| the Tree.
    V :   out Value_Type;       --| Information being returned from a node.
    L :   out Label_Type        --| The label of the node in the iteration.

);

--| EFFECTS
--| This iteration operation returns the label of a node as well as the
--| nodes value.  No_More is raised if Next is called after the last
--| element of the tree has been returned.


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

procedure Store_Value (
        T :in out Tree;          --| The tree which contains the label
                                 --| whose value is being changed.
        L :in     Label_Type;    --| The label of the node where the
                                 --| information is being stored.
        V :in     Value_Type     --| The value being stored.
);

--| MODIFIES
--| The tree T, and the node identified by the label L.

--| EFFECTS
--| Label_Not_Present is raised if L is not in T.

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

procedure Store_Value (          --| This stores the value V in the root
                                 --| node of the tree T.
        T :in out Tree;          --| Tree value being stored in the tree.
        V :in     Value_Type     --| The value being stored.
);

--| MODIFIES
--| The tree T, and the node identified by the label L.

--| EFFECTS
--| Raises Label_Not_Present if T is empty.

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

private

   type Node;
   type Tree is access Node;

   type Node is
        record
            Label           :Label_Type;
            Value           :Value_Type;
            Left_Child      :Tree;
            Right_Child     :Tree;
        end record;

   package Node_Order is new Lists (Tree);


   type Tree_Iter is
      record
          Node_List :Node_Order.List;
          State     :Node_Order.ListIter;
      end record;


end Labeled_Trees;


--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--ltrees.bdy
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with unchecked_deallocation;
package body Labeled_Trees is

----------------------------------------------------------------------------
--                   Local Subprograms
----------------------------------------------------------------------------

procedure Free is new unchecked_deallocation (Node, Tree);

function equal (
       X :in     Label_Type;
       Y :in     Label_Type
) return boolean is

begin
    return (not (X < Y))  and  (not (Y < X));
end equal;

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

procedure Internal_Is_Label_In_Tree (
   T         :in      Tree;
   L         :in      Label_Type;
   Parent    :in out Tree;
   Present   :   out boolean;
   recursed  :in out boolean
) is
begin
    --| OVERVIEW
    --| This procedure is used so that
    --| Is_Label_In_Tree (T, L, Subtree, Present) returns more useful
    --| information.  If the label L is not in the tree then Subtree is
    --| the root of the tree where L should be inserted.  If L is in
    --| the tree then Subtree is the root of the tree where L is.
    --| This procedure is necessary because in Is_Label_In_Tree has Subtree
    --| as an out parameter not as in out.

    --| The variable Recursed is used to indicate whether we have called
    --| the procedure recursively.  It is used when T is null.  If T is
    --| null and we haven't called recursively then T's parent is null.
    --| If T is null and we have called the procedure recusively then
    --| T's parent is not null.

    if T = null then
        Present := false;
        if not Recursed then
            Parent := null;
        end if;
    elsif L < T.Label then
        Parent := T;
        recursed := true;
        Internal_Is_Label_In_Tree (T.Left_Child, L, Parent, Present, Recursed);
    elsif T.Label < L then
        Parent := T;
        Recursed := true;
        Internal_Is_Label_In_Tree (
          T.Right_Child , L, Parent, Present, Recursed
                                  );
    else
        Parent := T;
        Present := true;
    end if;
end Internal_Is_Label_In_Tree;

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

function Pre_Order_Generate (
          T :in Tree
) return  Node_Order.List is


--| This routine generates a list of pointers to nodes in the tree t.
--| The list of nodes is a pre order list of the nodes of the tree.

    L : Node_Order.List;
begin
    L := Node_Order.Create;
    if T /= null then
        Node_Order.Attach (L, T);
        Node_Order.Attach (L, Pre_Order_Generate (T.Left_Child));
        Node_Order.Attach (L, Pre_Order_Generate (T.Right_Child));
    end if;
    return L;
end Pre_Order_Generate;

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

function Post_Order_Generate (
          T :in Tree
) return  Node_Order.List is


--| This routine generates a list of pointers to nodes in the tree t.
--| The list is a post ordered list of nodes of the tree.

    L : Node_Order.List;
begin
    L := Node_Order.Create;
    if T /= null then
        L := Post_Order_Generate (T.Left_Child);
        Node_Order.Attach (L, Post_Order_Generate (T.Right_Child));
        Node_Order.Attach (L, T);
    end if;
    return L;
end Post_Order_Generate;

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

function In_Order_Generate (
          T :in Tree
) return  Node_Order.List is


--| 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.
--| The nodes in the list are such the element 1 < element 2 < ....
--| element (n - 1) < element (n).  Where < is passed in .

    L : Node_Order.List;
begin
    L := Node_Order.Create;
    if T /= null then
        L := In_Order_Generate (T.Left_Child);
        Node_Order.Attach (L, T);
        Node_Order.Attach (L, In_Order_Generate (T.Right_Child));
    end if;
    return L;
end In_Order_Generate;

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



------------------------------------------------------------------------------
--                    Visible Subprograms
------------------------------------------------------------------------------

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

function Create  return Tree is

begin
    return null;
end;

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

procedure Destroy_Deep_Tree (
  T :in out Tree
) is

begin
    --| ALGORITHM
    --| Walk over the tree destroying the value, the label, and then the node
    --| itself.  Do this in post order.  This means destroy the left child
    --| destroy the right child and then destroy the node.

    if T /= null then
       Destroy_Deep_Tree (T.Left_Child);
       Destroy_Deep_Tree (T.Right_Child);
       Dispose_Label (T.Label);
       Dispose_Value (T.Value);
       Destroy_Tree (T);
    end if;
end;

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

procedure Destroy_Tree ( T :in out Tree) is


begin
    --| OVERVIEW
    --| This procedure recursively destroys the tree T.
    --|  1.  It destroy the Left_Child of T
    --|  2.  It then destroys the Right_Child of T.
    --|  3.  It then destroy the root T and set T to be null.

    if T /= null then
        Destroy_Tree (T.Left_Child);
        Destroy_Tree (T.Right_Child);
        Free (T);
    end if;
end Destroy_Tree;

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

function Fetch_Value (         --| Get the value of the node with the given
                               --| value.
       T :in     Tree;         --| The tree which contains the node.
       L :in     Label_Type    --| The label of the node.
) return Value_Type is

begin
    if T = null then
        raise Label_Not_Present;
    elsif L < T.Label then
        return Fetch_Value (T.Left_Child, L);
    elsif T.Label < L then
        return Fetch_Value (T.Right_Child, L);
    else
        return T.Value;
    end if;
end Fetch_Value;

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

function Fetch_Value (  --| Return the value stored at the root node
                        --| of the given tree.
         T :in Tree
) return Value_Type is

begin
    if T = null then
       raise Tree_Is_Empty;
    else
       return T.Value;
    end if;
end Fetch_Value;

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

procedure Forward (        --| Advances the iterator to the next node in
                           --| the iteration.
  I :in out Tree_Iter      --| Iterator being advance.
) is
begin
    Node_Order.Forward (I.State);
end Forward;

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

function Get_Tree (         --| Get the tree whose root is labelled L.
       T :in    Tree;       --| Tree which contains the label L.
       L :in    Label_Type  --| The label being searched for.
) return Tree is

begin
    if T = null then
        raise Label_Not_Present;
    elsif L < T.Label then
        return Get_Tree (T.Left_Child, L);
    elsif T.Label < L then
        return Get_Tree (T.Right_Child, L);
    else
       return T;
    end if;
end Get_Tree;

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

procedure Insert_Node (       --| This procedure inserts a node into
                              --| the tree T with label and value V.
      T  :in out Tree;
      L  :in     Label_Type;
      V  :in     Value_Type
) is

begin
    if T = null then
       T := new Node '
            ( Value => V, Label => L, Left_Child => null, Right_Child => null);
    elsif L < T.Label then
       Insert_Node (T.Left_Child, L, V);
    elsif T.Label < L then
       Insert_Node (T.Right_Child, L, V);
    elsif T.Label = L then
       raise Label_Already_Exists_In_Tree;
    end if;
end Insert_Node;

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

function Is_Empty (        --| Returns true if the tree is empty false
                           --| otherwise.
         T :in     Tree
) return boolean is
begin
    return T = null;
end Is_Empty;

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

function Is_Label_In_Tree (            --| Is the given label in the given
                                       --| tree.
         T :in    Tree;                --| The tree being searched.
         L :in    Label_Type           --| The label being searched for.
) return boolean is
begin
    if T = null then
         return false;
    elsif L < T.Label then
         return Is_Label_In_Tree (T.Left_Child, L);
    elsif T.Label < L then
         return Is_Label_In_Tree (T.Right_Child, L);
    else
        return true;
    end if;
end Is_Label_In_Tree;

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

procedure Is_Label_In_Tree (            --| Checks if the given label is
                                        --| in the given tree.
           T       :in     Tree;        --| Tree being searched.
           L       :in     Label_Type;  --| Label being searched for.
           Subtree :   out Tree;        --| Subtree which is contains label.
           Present :   out boolean      --| True if label is in tree, false
                                        --| if not.
) is
    Recursed          :boolean := false;
    Internal_Subtree  :Tree;    -- This variable is needed because
                                -- in Internal_Is_Label subtree is an in out
                                -- parameter.

begin
     --| Sets the variable Present to true if the given label is in the given
     --| tree. Also sets the variable Subtree to
     --| the root of the subtree which contains the label.  If L isn't in the
     --| tree then Subtree is the root of the tree where label should be
     --| inserted.  This internal routine is called so that if L isn't in T
     --| then Subtree will be the root of the tree where L should be inserted.
     --| In order to do this we need the extra variable Recursed.

    Internal_Is_Label_In_Tree (T, L, Internal_Subtree, Present, Recursed);
    Subtree := Internal_Subtree;
end Is_Label_In_Tree;

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

function Iterator_Label (  --| Returns the label of the node corresponding
                           --| to the iterator.
  I :in      Tree_Iter     --| Iterator.
) return Label_Type is
    T :Tree;
begin
    T := Node_Order.CellValue (I.State);
    return T.Label;
end Iterator_Label;

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

function Iterator_Value (  --| Returns the value of the node corresponding
                           --| to the iterator.
  I :in      Tree_Iter     --| Iterator.
) return Value_Type is
    T :Tree;
begin
    T := Node_Order.CellValue (I.State);
    return T.Value;
end;

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

function Make_Tree (          --| This creates a tree given a label and a
                              --| value.
       L :in     Label_Type;  --| The label.
       V :in     Value_Type   --| The value.
) return Tree is

begin
     return  new Node ' (
                   Value => V,
                   Label => L,
                   Left_Child => null,
                   Right_Child => null
                        );
end;

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

function Make_Tree_Iter_In  (  --| This sets up an inoder iteration of the
                               --| nodes of the tree.
        T :in     Tree         --| Tree being iterated over
) return Tree_Iter is

--| This sets up the iterator for a tree T.
--| The NodeList keeps track of the order of the nodes of T.  The Node_List
--| is computed by first invoking In_Generate of the Left_Child then append
--| the root node to Node_List and then append the result of In_Generate
--| to Node_List.  Since the tree is ordered such that
--|
--|    Left_Child < root    root < Right_Child
--|
--| Node_Order returns the nodes in ascending order.
--|
--| Thus Node_List keeps the list alive for the duration of the iteration
--| operation.  The variable State is the a pointer into the Node_List
--| which is the current place of the iteration.

    I :Tree_Iter;
begin
    I.Node_List := Node_Order.Create;
    if T /= null then
        Node_Order.Attach (I.Node_List, In_Order_Generate (T));
    end if;
    I.State := Node_Order.MakeListIter (I.Node_List);
    return I;
end Make_Tree_Iter_In;

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

function Make_Tree_Iter_Post (  --| This sets up a postorder iteration of the
                                --| nodes of the tree.
        T :in     Tree          --| Tree being iterated over
) return Tree_Iter is

--| A postorder iteration of the tree ( + a b)  where the root is + and
--| the left child is a and the right child is b will return the nodes
--| in the order a b +.
--| Node_List is a post_ordered list of the nodes of the tree generated
--| by Post_Order Generate. Thus Node_List keeps the list alive for the
--| duration of the iteration operation.  The variable State is the a pointer
--| into the Node_List which is the current place of the iteration.

    I :Tree_Iter;
begin
    I.Node_List := Node_Order.Create;
    if T /= null then
        Node_Order.Attach (I.Node_List, Post_Order_Generate (T));
    end if;
    I.State := Node_Order.MakeListIter (I.Node_List);
    return I;
end Make_Tree_Iter_Post;

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

function Make_Tree_Iter_Pre (   --| This sets up an iteration of the nodes
                                --| of the tree in preorder.  Then nodes
                                --| of the tree are returned in ascending
                                --| order.
        T :in     Tree          --| Tree being iterated over
) return Tree_Iter is


--| A preorder iteration of the tree ( + a b)  where the root is + and
--| the left child is a and the right child is b will return the nodes
--| in the order + a b .
--| Node_List is a pre_ordered list of the nodes of the tree generated
--| by Pre_Order_Generate. Thus Node_List keeps the list alive for the
--| duration of the iteration operation.  The variable State is the a pointer
--| into the Node_List which is the current place of the iteration.

    I :Tree_Iter;
begin
    I.Node_List := Node_Order.Create;
    if T /= null then
        Node_Order.Attach (I.Node_List, Pre_Order_Generate (T));
    end if;
    I.State := Node_Order.MakeListIter (I.Node_List);
    return I;
end Make_Tree_Iter_Pre;

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

function More (
     I :in Tree_Iter
) return boolean is

begin
    return Node_Order.More (I.State);
end More;

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

procedure Next (
          I     :in out Tree_Iter;
          V     :   out Value_Type
) is


    T :Tree;
begin
    --| OVERVIEW
    --| 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 Node_Order list.  This returns a pointer into the Tree
    --| and then the information found at this node in T is returned.
    Node_Order.Next (I.State, T);
    V := T.Value ;
exception
    when Node_Order.NoMore =>
      raise No_More;
    when others =>
      raise;
end Next;

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

procedure Next (
          I :in out Tree_Iter;
          V :   out Value_Type;
          L :   out Label_Type
) is

    T :Tree;
begin
    --| OVERVIEW
    --| 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 Node_Order list.  This returns a
    --| pointer into the Tree and then the information found at this node in
    --| T is returned.

    Node_Order.Next (I.State, T);
    V := T.Value ;
    L := T.Label;

exception
    when Node_Order.NoMore =>
      raise No_More;
    when others =>
      raise;
end Next;

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

procedure Store_Value (
        T :in out Tree;          --| Tree value is being stored in.
        L :in     Label_Type;    --| The label of the node where the
                                 --| information is being stored.
        V :in     Value_Type     --| The value being stored.
) is

begin
    if T = null then
        raise Label_Not_Present;
    elsif L < T.Label then
        Store_Value (T.Left_Child, L, V);
    elsif T.Label < L then
        Store_Value (T.Right_Child, L, V);
    else
        T.Value := V;
    end if;
end Store_Value;

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

procedure Store_Value (          --| This stores the value V in the root
                                 --| node of the tree T.
        T :in out Tree;          --| Tree value being stored in the tree.
        V :in     Value_Type     --| The value being stored.
) is
begin
    if T /= null then
        T.Value := V;
    else
        raise Label_Not_Present;
    end if;
end Store_Value;

-----------------------------------------------------------------------------
end Labeled_Trees;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--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;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--DOCREF.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package Document_Ref is
--| Defines and supports a standard form for expressing references to a
--| document.

--| Overview
--| This package defines and supports a notation for naming documents
--| and positions within the document (by paragraph).  The syntax of a
--| reference to a document is as follows:
--|-
--|     Reference    ::= DocID ParagraphID
--|     DocID        ::= Name [ Version ] { '.' Name [ Version ] }
--|     ParagraphID  ::= DottedNumber
--|     Name         ::= Letter { [ Underline ] Letter | Digit }
--|     Version      ::= '(' DottedNumber ')'
--|     DottedNumber ::= Number { '.' Number }
--|+
--| This package defines types for each of the non-terminals in the
--| above grammar, functions for scanning values of each type from
--| a string, and functions for comparing objects of each type.
--|
--| For purposes of comparison, each of the string types defined
--| here are considered to be made up of components.  For example, in
--| the ParagraphID "(1.2.3)", the components are "1", "2", and "3".
--| In comparing one string to another, the strings are compared one
--| component at a time.  If the components differ, the result is
--| determined by those components.  If the components are the same,
--| the result is determined by comparing the next pair of components.
--| If one string runs out of components before the other one does,
--| the one with fewer components is less than the one with more of
--| them.  Thus, "(1.2.1)" < "(1.3)" but "(1.2)" < "(1.2.3)", and
--| the null string is less than any other string.
--| When comparing DocID strings, all of the name components are
--| compared before any of the version components are.  Thus:
--|-
--|     A(1) < A(2) < A(1).B < A(2).B < A(1).C < A(2).C
--|+
--| Reference strings are compared by first comparing their Document Id
--| strings, and, if equal, then comparing their Paragraph Id strings.

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

subtype Small_Num is INTEGER range 0 .. 255;
    -- used for discriminants which may sometimes be default
    -- initialized, and which need a good-sized name length


------------------------------------------------------------------------
     ---------------- ParagraphID Strings ----------------
------------------------------------------------------------------------

Invalid_ParagraphID_String:    --| Raised if a string does not correspond
    exception;            --| to the syntax for a ParagraphID

type ParagraphID_String(length : Small_Num := 0)
  is private;    --| String of the form: ( Number { '.' Number } )


function Image(   --| return string image of the paragraphid_string
    PS : in ParagraphID_String
    ) return STRING;

--| Effects: Convert a ParagraphID_String into an ordinary string.
--| N/A: Modifies, Errors, Raises, Requires


function Compare(    --| -1 if S1 < S2, 0 if S1 = S2, 1 if S1 > S2
    S1 : in ParagraphID_String;
    S2 : in ParagraphID_String
    ) return INTEGER;

--| Effects: Compare S1 to S2 and return the "difference".
--| N/A: Modifies, Errors, Raises, Requires


function EQ(            --| Return TRUE iff S1 = S2
    S1 : in ParagraphID_String;
    S2 : in ParagraphID_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE if they are equal.


function "<"(            --| Return TRUE iff S1 < S2
    S1 : in ParagraphID_String;
    S2 : in ParagraphID_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE if S1 < S2


function ">"(            --| Return TRUE iff S1 > S2
    S1 : in ParagraphID_String;
    S2 : in ParagraphID_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE if S1 > S2


function "<="(            --| Return TRUE iff S1 <= S2
    S1 : in ParagraphID_String;
    S2 : in ParagraphID_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE if S1 <= S2


function ">="(            --| Return TRUE iff S1 >= S2
    S1 : in ParagraphID_String;
    S2 : in ParagraphID_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE if S1 >= S2


------------------------------------------------------------------------
        ---------------- DocID Strings ----------------
------------------------------------------------------------------------

Invalid_DocID_String:        --| Raised if a string does not
    exception;            --| correspond to the syntax for a DocID

type DocID_String(length : Small_Num := 0) is private;
--| String of the form: Name [Version] { . Name [Version] }


function Image(            --| return string image of the docid_string
    DS : in DocID_String
    ) return STRING;

--| Effects: Convert a DocID_String into human readable form.
--| N/A: Modifies, Errors, Raises, Requires


function Compare(    --| Return -1 if S1 < S2, 0 if S1 = S2, 1 if S1 > S2
    S1 : in DocID_String;
    S2 : in DocID_String
    ) return INTEGER;

--| Effects: Return the "difference" between S1 and S2, ignoring upper/
--| lower case differences.
--| N/A: Modifies, Errors, Raises, Requires


function EQ(            --| Return TRUE iff S1 = S2
    S1 : in DocID_String;
    S2 : in DocID_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE if S1 = S2


function "<"(            --| Return TRUE iff S1 < S2
    S1 : in DocID_String;
    S2 : in DocID_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE if S1 < S2


function ">"(            --| Return TRUE iff S1 > S2
    S1 : in DocID_String;
    S2 : in DocID_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE if S1 > S2


function "<="(            --| Return TRUE iff S1 <= S2
    S1 : in DocID_String;
    S2 : in DocID_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE if S1 <= S2


function ">="(            --| Return TRUE iff S1 >= S2
    S1 : in DocID_String;
    S2 : in DocID_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE if S1 >= S2


------------------------------------------------------------------------
      ---------------- Reference Strings ----------------
------------------------------------------------------------------------

Invalid_Reference_String:    --| Raised if a string does not
    exception;            --| correspond to the syntax for a
                --| Reference

type Reference_String is private;
--| String of the form: DocID [ ParagraphID ]


procedure Scan(            --| Scan the string S starting at
                --| S(Index) for a Reference
    S     : in     STRING;    --| String to scan
    Index : in out NATURAL;    --| Position where scan starts and ends
    RS    : in out Reference_String
    );

--| Raises: Invalid_Reference_String

--| Effects
--| Starting at S(Index), skip leading white space, and check for
--| sequence of names with optional version numbers separated by dots,
--| followed by an optional ParagraphID, leaving Index just past the
--| last number.  If a syntax error is detected during the scan,
--| Index is unchanged and the exception Invalid_ParagraphID_String
--| or Invalid_DocID_String is raised.

--| N/A: Modifies, Errors


function Image(      --| return string image of a Reference_String
    RS : in Reference_String
    ) return STRING;

--| Effects: Convert a Reference_String into human-readable form.
--| N/A: Modifies, Errors, Raises, Requires


function Compare(
    S1 : in Reference_String;
    S2 : in Reference_String
    ) return INTEGER;

--| Effects: Return the "difference" between S1 and S2.
--| N/A: Modifies, Errors, Raises, Requires


procedure Split(        --| Splits the reference string
                --| into DocID and ParagraphID
    RS: in Reference_String;    --| reference string
    DS: in out DocID_String;    --| DocID string
    PS: in out ParagraphID_String --| ParagraphID string
    );

--| Effects: Split RS into its component parts.
--| N/A: Modifies, Errors, Raises


procedure Join(            --| Joint DocID and ParagraphID
                --| into a Reference string
    RS: in out Reference_String;    --| reference string
    DS: in DocID_String;        --| DocID string
    PS: in ParagraphID_String         --| ParagraphID string
    );

--| Effects: Join DS and PS into a single Reference_String RS.
--| N/A: Modifies, Errors, Raises

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

function EQ(            --| Return TRUE iff S1 = S2
    S1 : in Reference_String;
    S2 : in Reference_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE iff they are equal.


function "<"(            --| Return TRUE iff S1 < S2
    S1 : in Reference_String;
    S2 : in Reference_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE iff S1 < S2.


function ">"(            --| Return TRUE iff S1 > S2
    S1 : in Reference_String;
    S2 : in Reference_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE iff S1 > S2.


function "<="(            --| Return TRUE iff S1 <= S2
    S1 : in Reference_String;
    S2 : in Reference_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE iff S1 <= S2.


function ">="(            --| Return TRUE iff S1 >= S2
    S1 : in Reference_String;
    S2 : in Reference_String
    ) return BOOLEAN;

--| N/A: Raises, Modifies, Errors
--| Effects: Compare S1 to S2 and return TRUE iff S1 >= S2.

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

private

pragma inline(EQ, "<", "<=", ">", ">=");

type DottedNumber is access ParagraphID_String;

type ParagraphID_String(length : Small_Num := 0) is
    record            --| a linked list of number strings
    number_string : String(1..length);
    next : DottedNumber := null;
    end record;

subtype DottedNumberRecord is ParagraphID_String;

type NameList is access DocID_String;

type DocID_String(length : Small_Num := 0) is
    record            --| a linked list of names/versions
    name_string : String(1..length);
    version : DottedNumber := null;
    next : NameList := null;
    end record;

subtype NameListRecord is DocID_String;

type Reference_String is
    record            --| String of the form:
    doc_id : NameList;      --| DocID
    par_id : DottedNumber;  --| ParagraphID
    end record;

end Document_Ref;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--DOCREF.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with case_insensitive_string_comparison;

package body Document_Ref is

    package SC renames case_insensitive_string_comparison;

    BadReferenceString : exception;

    -- some character subtypes
    subtype Digit   is Character range '0' .. '9';
    subtype UC_Char is Character range 'A' .. 'Z';
    subtype LC_Char is Character range 'a' .. 'z';

    type TokenKind is (lparen, rparen, dot, number, name, eos);
    --| an enumeration of lexer tokens

    type TokenRecord(kind : TokenKind := eos; length : small_num := 0) is
    --| a lexical token structure
      record
    case kind is
    when number | name => String_value : STRING(1..length);
    when others => null;
    end case;
      end record;

    GlobalToken : TokenRecord;    -- our "lookahead" token
    -- lexical token constants used by lexer for efficiency
    LParenToken: constant TokenRecord
        := TokenRecord'(kind => lparen, length => 1);
    RParenToken: constant TokenRecord
        := TokenRecord'(kind => rparen, length => 1);
    DotToken: constant TokenRecord
        := TokenRecord'(kind => dot, length => 1);
    EOSToken: constant TokenRecord := TokenRecord'(kind => eos, length => 0);

pragma Page;

procedure GetNumberToken(  --| get a number type of lexical object
    Str : in STRING;
    Token : out TokenRecord
    )
is
    I : Natural := Str'first;

begin
    while I <= Str'last and then Str(I) in Digit loop
    I := I + 1;
    end loop;
    declare
    -- Adjust the index range in Token
      tempstr: STRING(1..I-Str'first) := Str(Str'first..I - 1);
    begin
      Token := TokenRecord'(kind => number,
                length => I - Str'first,
                String_value => tempStr);
    end;

end GetNumberToken;


procedure GetNameToken(  --| get a token whose lexical structure is
                     --| that of an Aa identifier
    Str : in STRING;
    Token : out TokenRecord
    )
is
    I : Natural := Str'first;

begin
    while I <= Str'last loop
    -- we know the first char is alphabetic, so the below case stmt is ok
    case Str(I) is
    when UC_Char | LC_Char | Digit =>
        null;
    when '_' =>
        -- Check for adjacent underscores
        if Str(I-1) = '_' then
            raise BadReferenceSTRING;
        end if;
    when others =>
        -- Cannot end with an underscore
        if Str(I-1) = '_' then
            raise BadReferenceSTRING;
        else
            exit;
        end if;
    end case;
    I := I + 1;
    end loop;

    declare
      -- Adjust index range of Token.String_Value
      tempstr: STRING(1..I-Str'first) := Str(Str'first..I - 1);
    begin
      Token := TokenRecord'(kind => name,
                length => I - Str'first,
                String_value => tempStr);
    end;

end GetNameToken;


procedure GetToken(   --| get the lexical token beginning at position
                  --| Index in STRING Str
    Str: in STRING;
    Index: in out Natural;
    Token: in out TokenRecord
    )
is
    I : Natural := Index;
    Last : Natural := Str'last;

begin
    while I <= Last and then (Str(I) = ' ' or str(i) = ascii.ht) loop
    -- skip blanks and tabs
    I := I + 1;
    end loop;
    Index := I;
    if I > Last then
    -- no more in Str
    Token := EOSToken;
    return;
    end if;
    case Str(I) is
      when '(' =>
    Token := LParenToken;
    Index := I + 1;
      when ')' =>
    Token := RParenToken;
    Index := I + 1;
      when '.' =>
    Token := DotToken;
    Index := I + 1;
      when Digit =>
    GetNumberToken(Str(I..Last), Token);
    Index := I + Token.length;
      when LC_Char | UC_Char =>
    GetNameToken(Str(I..Last), Token);
    Index := I + Token.length;
      when others =>    -- Terminate the scan
    Token := EOSToken;
    return;
    end case;
end GetToken;

------------------------------------------------------------------------
-- Reference STRING parser
-- the main internal routines are GetName and GetDotNum. They
-- each assume that the first (lookahead) token is in GlobalToken,
-- and make the appropriate checks.

procedure GetDotNum(  --| parse a dotted number from Str beginning at Index
    Str: STRING;
    Index: in out Natural;
    DotNum: out DottedNumber
    )
is
    NumPtr : DottedNumber;
begin
    -- First check our lookahead token
    if GlobalToken.kind /= number then
    raise BadReferenceSTRING;
    else
    -- Initialize a dotted number record object
    NumPtr := new DottedNumberRecord'(length => GlobalToken.length,
      Number_String => GlobalToken.String_value, next => null);
    DotNum := NumPtr;
    end if;
    -- See if we have more in the list (separated by dots)
    GetToken(Str, Index, GlobalToken);
    if GlobalToken.kind = dot then
    -- if so, set the "next" field of the list to be the remaining
    -- dotted number list
    GetToken(Str, Index, GlobalToken);
    GetDotNum(Str, Index, NumPtr.next);
    end if;

end GetDotNum;

procedure GetName(  --| parse a name structure in Str beginning at Index
    Str: in STRING;
    Index: in out Natural;
    NmList: out NameList
    )
is
    NamePtr: NameList;
    NumPtr: DottedNumber;

begin
    If GlobalToken.kind /= name then    -- check lookahead token
    raise BadReferenceSTRING;
    end if;
    -- Initialize the name record
    NamePtr := new NameListRecord'(Length => Globaltoken.length,
                   name_String => GlobalToken.String_value,
                   version => null,
                   next => null);
    NmList := NamePtr;
    GetToken(Str, Index, GlobalToken);
    -- check for version number
    if GlobalToken.kind = lparen then
    GetToken(Str, Index, GlobalToken);
    -- fill in the version field
    GetDotNum(Str, Index, NamePtr.version);
    if GlobalToken.kind /= rparen then
        raise BadReferenceSTRING;
    else
        GetToken(Str, Index, GlobalToken);
    end if;
    end if;
    -- check for more name elements separated by a dot
    if GlobalToken.kind = dot then
    GetToken(Str, Index, GlobalToken);
    -- fill in "next" field of name list if present
    GetName(Str, Index, NamePtr.next);
    end if;
end GetName;


      -------------- ParagraphID STRINGs ----------------

function Image(
    PS : in ParagraphID_String
    ) return STRING is
begin
    if PS.next = null then
    return PS.Number_String;
    else
    return PS.Number_String & "." & Image(PS.next.all);
    end if;
end Image;

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

function Compare(    --| -1 if S1 < S2, 0 if S1 = S2, 1 if S1 > S2
    S1 : in ParagraphID_String;
    S2 : in ParagraphID_String
    ) return INTEGER
is
    S1V, S2V: integer;

begin
    if S1.Number_String /= "" then
    S1V := integer'value(S1.Number_String);
    else
    S1V := 0;
    end if;
    if S2.Number_String /= "" then
    S2V := integer'value(S2.Number_String);
    else
    S2V := 0;
    end if;
    if S1V < S2V then
    return -1;
    elsif S1V > S2V then
    return 1;
    elsif S1.next = null then
    -- Values were equal; compare next components
    if S2.next = null then
        return 0;
    else
        return -1;
    end if;
    elsif S2.next = null then
    return 1;
    else
    return Compare(S1.next.all, S2.next.all);
    end if;
end Compare;

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

function EQ(
    S1 : in ParagraphID_String;
    S2 : in ParagraphID_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) = 0;

end EQ;

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

function "<"(
    S1 : in ParagraphID_String;
    S2 : in ParagraphID_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) < 0;

end "<";

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

function ">"(
    S1 : in ParagraphID_String;
    S2 : in ParagraphID_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) > 0;

end ">";

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

function "<="(
    S1 : in ParagraphID_String;
    S2 : in ParagraphID_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) <= 0;

end "<=";

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

function ">="(
    S1 : in ParagraphID_String;
    S2 : in ParagraphID_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) >= 0;

end ">=";


        ---------------- DocID STRINGs ----------------

function Image(
    DS : in DocID_String
    ) return STRING is
begin
    if DS.next = null then
    if DS.version = null then
      return DS.name_String;
    else
      return DS.name_String & "("
          & Image(ParagraphID_String(DS.version.all)) & ")";
          -- needs explicit type coercion
    end if;
    else
    -- Catenate "next" list of images to first one
    if DS.version = null then
        return DS.name_String & "." & Image(DS.next.all);
    else
        return DS.name_String & "(" &
          Image(ParagraphID_String(DS.version.all)) & ")" &
          "." & Image(DS.next.all);
    end if;
    end if;
end Image;

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

function CompareNames(  --| compare the name fields (not versions)
                    --| of two DocID STRINGs
    S1 : in DocID_String;
    S2 : in DocID_String
    ) return INTEGER
is
    diff: integer := SC.Compare(S1.Name_String, S2.Name_String);

begin
    if diff = 0 then    --| STRINGs were equal: compare next component
    if S1.next = null then
      if S2.next = null then
        return 0;
      end if;
      return -1;
    elsif S2.next = null then
      return 1;
    else
      return CompareNames(S1.next.all, S2.next.all);
    end if;
    else
    return diff;
    end if;
end CompareNames;

function CompareVersions(  --| compare the versions of two DocID STRINGs
    S1 : in DocID_String;
    S2 : in DocID_String
    ) return INTEGER is
    C : INTEGER;
begin
    -- This routine is only called if the name parts of a ParagraphID_String
    -- are equal, and therefore have the same number of components. This
    -- fact is used often below, and is commented appropriately.
    if S1.version = null then
    if S2.version = null then
        if S1.next = null then
        -- we know that S2.next is also null (else CompareNames
        -- would be non-zero, and we would not have been called)
            return 0;
        else
        -- by similar reasoning, we know S2 is not null in this case
            return CompareVersions(S1.next.all, S2.next.all);
        end if;
    else
        return -1;
    end if;
    elsif S2.version = null then
    return 1;
    else
    C := Compare(ParagraphID_String(S1.version.all),
             ParagraphID_String(S2.version.all));
    -- note that this calls the paragraph_id comparison
    if C /= 0 or else S1.next = null then
        return C;
    else
        -- again, they are both non-null
        return CompareVersions(S1.next.all, S2.next.all);
    end if;
    end if;
end CompareVersions;

function Compare(    --| -1 if S1 < S2, 0 if S1 = S2, 1 if S1 > S2
    S1 : in DocID_String;
    S2 : in DocID_String
    ) return INTEGER
is
    C : INTEGER := CompareNames(S1, S2);

begin
    if C /= 0 then
    return C;
    else
    return CompareVersions(S1, S2);
    end if;

end Compare;

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

function EQ(
    S1 : in DocID_String;
    S2 : in DocID_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) = 0;

end EQ;

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

function "<"(
    S1 : in DocID_String;
    S2 : in DocID_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) < 0;

end "<";

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

function ">"(
    S1 : in DocID_String;
    S2 : in DocID_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) > 0;

end ">";

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

function "<="(
    S1 : in DocID_String;
    S2 : in DocID_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) <= 0;

end "<=";

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

function ">="(
    S1 : in DocID_String;
    S2 : in DocID_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) >= 0;

end ">=";


      ---------------- Reference STRINGs ----------------

procedure Scan(
    S     : in     STRING;
    Index : in out natural;
    RS    : in out Reference_String
    )
is
    IndexSave : Natural := Index;  --| in case of a misformed Reference_String

begin
    -- First get the lookahead token prepared
    begin
    GetToken(S, Index, GlobalToken);
    if GlobalToken.Kind /= Name then
      Index := IndexSave;
      raise Invalid_DocID_String;
    end if;
    GetName(S, Index, RS.doc_id);
    exception
      when BadReferenceSTRING =>
    Index := IndexSave;
    raise Invalid_DocID_String;
    end;
    begin
    GetDotNum(S, Index, RS.par_id);
    exception
      when BadReferenceSTRING =>
    Index := IndexSave;
    raise Invalid_ParagraphID_String;
    end;
    -- Gets here if scan is successful. Back up from the lookahead token.
    Index := Index - GlobalToken.length;

end Scan;

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

function Image(
    RS : in Reference_String
    ) return STRING is
begin
    return Image(RS.doc_id.all) & ' ' & Image(RS.par_id.all);
end Image;

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

procedure Split(
    RS : in     Reference_String;
    DS : in out DocID_String;
    PS : in out ParagraphID_String
    ) is
begin
    DS := RS.doc_id.all;
    PS := RS.par_id.all;
end Split;

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

procedure Join(
    RS : in out Reference_String;
    DS : in     DocID_String;
    PS : in     ParagraphID_String
    ) is
begin
    RS.doc_id := new DocID_String'(DS);
    RS.par_id := new ParagraphID_String'(PS);
end Join;

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

function Compare(
    S1 : in Reference_String;
    S2 : in Reference_String
    ) return INTEGER is
    C1 : INTEGER := Compare(S1.doc_id.all, S2.doc_id.all);
begin
    if C1 /= 0 then
    return C1;
    else
    return Compare(S1.par_id.all, S2.par_id.all);
    end if;
end Compare;

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

function EQ(
    S1 : in Reference_String;
    S2 : in Reference_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) = 0;
end EQ;

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

function "<"(
    S1 : in Reference_String;
    S2 : in Reference_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) < 0;
end "<";

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

function ">"(
    S1 : in Reference_String;
    S2 : in Reference_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) > 0;
end ">";

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

function "<="(
    S1 : in Reference_String;
    S2 : in Reference_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) <= 0;
end "<=";

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

function ">="(
    S1 : in Reference_String;
    S2 : in Reference_String
    ) return BOOLEAN is
begin
    return Compare(S1, S2) >= 0;
end ">=";

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

end Document_Ref;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--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
--|       set_comparison_option
--|       get_comparison_option
--|        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)).
      --| 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 1..length(s1) + 1.
      --| 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)).
      --| 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 1..length(s1) + 1.
      --| 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..s1'last).
      --| 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'first..s'last + 1.
      --| 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).


    type comparison_option is (case_sensitive, case_insensitive);

    --| Used for equal, "<" and "<=" functions.  If the comparison_option
    --| is case_sensitive, then a straightforward comparison of values
    --| is performed.  If the option is case_insensitive, then comparison
    --| between the arguments is performed after first normalizing them to
    --| lower case.

    procedure set_comparison_option(choice: comparison_option);

    --| Effects:
    --| Set the comparison option for equal, "<" and "<="  (as described
    --| above) to the given choice.  The initial setting is case_sensitive.

    function get_comparison_option
    return comparison_option;

    --| Effects:
    --| Return the current comparison_option setting.

    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).
      --| (If the comparison_option is currently case_insensitive, then
      --| lower(s1) and lower(s2) are used instead.)
      --|
      --| Notes:
      --| The "=" operation is carried over from the representation.
      --| It allows one to distinguish among the heap addresses of
      --| string_type values.  Even "equal" values under case_sensitive
      --| comparison 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, s2: string_type)
        return boolean;

      --| Effects:
      --| Lexicographic comparison according to the current comparison_option;
      --| return value(s1) < value(s2).

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

      --| Effects:
      --| Lexicographic comparison according to the current comparison_option;
      --| return value(s1) < s2.

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

      --| Effects:
      --| Lexicographic comparison according to the current comparison_option;
      --| return s1 < value(s2).

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

      --| Effects:
      --| Lexicographic comparison according to the current comparison_option;
      --| return value(s1) <= value(s2).

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

      --| Effects:
      --| Lexicographic comparison according to the current comparison_option;
      --| return value(s1) <= s2.

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

      --| Effects:
      --| Lexicographic comparison according to the current comparison_option;
      --| return s1 <= value(s2).

    function match_c(s: string_type; c: character; start: positive := 1)
        return natural;

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

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

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

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

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

      --| 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;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--SLISTS.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with String_Pkg;
with Lists;

package String_Lists is new Lists(
        ItemType => String_Pkg.String_Type,
        Equal    => String_Pkg.Equal);

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--FILEMGR.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with String_Lists;

--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--
--         * * * * * * * * * *  WARNING  * * * * * * * * * *               --
--    THE BODY OF THIS PACKAGE IS HOST DEPENDENT THEREFORE NOT PORTABLE    --
--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--

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, Errors
                                                                    pragma page;
            -- Packages --

package SL renames String_Lists;

             -- Types --

type Mode_Type is(
    FULL,            --| Full path name
    NO_VERSION,        --| Path name without version number
    NO_DIRECTORY,        --| File and version number
    FILE_ONLY,        --| File
    NAME_ONLY,        --| File name (without extention)
    TYPE_ONLY);        --| File type (eg. .ADA)

            -- 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
Date_Error: exception;        --| raised on error when getting file date
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 on error during rename operation
Create_Error: exception;    --| raised when directory creation failed
                                                                    pragma page;

            -- Operations --

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

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 to the file
    );

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

--| Effects: If possible, the file specified by Old_File is renamed to the
--| name specified by New_File.  The content of the file is not changed.
--| If any error occurs, the appropriate exception is raised.

--| N/A: Errors, Requires, Modifies
                                                                    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

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

--| N/A: Errors, Modifies, Requires
                                                                    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

--| Effects:
--| Copies Input_File to Output_File.  The contents of the output file
--| are identical to the contents of the Input_File.

--| N/A: Errors, Requires, Modifies
                                                                    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: 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

--| Effects:  The contents of Append_File is appended to Input_File.
--| Append_File is not changed by this operation.

--| N/A: Errors, Raises, Modifies
                                                                    pragma page;
----------------------------------------------------------------

function creation_Date(    --| Return the creation date of a file
    File: in STRING    --| Name of a file
    ) return STRING; --| Raises: File_Not_Found

--| Effects: Return a string containing the date and time that File
--| was created in the form "mm/dd/yy hh:mm:ss.cc".

--| N/A: Modifies, Requires

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

function modification_Date(    --| Return the modification date of a file
    File: in STRING        --| Name of a file
    ) return STRING; --| Raises: File_Not_Found

--| Effects: Return a string containing the date and time that File
--| was last modified in the form "mm/dd/yy hh:mm:ss.cc".

--| N/A: Modifies, Requires


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

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 SL.List;

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

--| Effects: Expands a string into a list of filenames matching all wild
--| card characters that occur in File.  In the event that no files match,
--| a null list is returned.

--| N/A: Errors, Modifies, Requires
                                                                    pragma page;
----------------------------------------------------------------

procedure Destroy(
    Name_List: in out SL.List
    );


--| Effects: All storage associated with the given list is released.
--| This function is provided for reclaiming any storage allocated to lists
--| of file names created by other functions in this package.

--| N/A: Errors, Modifies, Requires, Raises
                                                                    pragma page;
----------------------------------------------------------------

function Strip_Dir(
    Long_Name: in STRING
    ) return STRING;

--| Raises:

--| Effects: Strips the device and directory name off of Long_Name

--| N/A: Errors, Modifies, Requires
                                                                    pragma page;
----------------------------------------------------------------

function Parse_Filename(    --| parse a filename
    Name: in STRING;        --| filename to be parsed
    Mode: in Mode_Type := FULL    --| filename parsing mode
    ) return STRING;

--| Effects: Parse Name and return file specification according to Mode

--| N/A: Raises, Errors, Requires, Modifies
                                                                    pragma page;
----------------------------------------------------------------

function Path_Name(        --| Find path name for a file
    Directory: in STRING;        --| Device/directory specification
    File: in STRING;            --| File name
    Absolute: in BOOLEAN := FALSE    --| Absolute or relative path name
    ) return STRING;

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

--| Effects: Returns the system dependent path name
--| Useful hint: Path_Name with directory as a null directory ([] in VMS)
--|              and file as a null string "" and Absoulte = TRUE will
--|              return the current dirctory name
--|

--| N/A: Errors, Requires, Modifies
                                                                    pragma page;
----------------------------------------------------------------

procedure Create_Directory(    --| Create a new directory
    Directory: in STRING    --| Name of directory to be created
    );

--| Raises: Create_Error

--| Effects: Creates a new directory.  If an error occurs, the exception
--| Create_Error is raised.

--| N/A: Errors, Modifies, Requires
                                                                    pragma page;
----------------------------------------------------------------

function Is_Directory(        --| Return TRUE iff Directory exists
    Directory: in STRING
    ) return BOOLEAN;

--| Raises: Device_Not_Ready, Device_Write_Locked, Parse_Error

--| Effects: Returns TRUE if the named directory exists, FALSE otherwise.

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

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


end  File_Manager;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--FILEMGR.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with System;            use System;     -- for =
with Starlet;
with Condition_Handling;
with System;
with String_Pkg;

--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--
--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--
--         * * * * * * * * * *  WARNING  * * * * * * * * * *               --
--           DEPENDS ON VAX/VMS SYSTEM INTERFACE PACKAGES                  --
--        WILL NOT PORT TO OTHER SYSTEMS WITHOUT MODIFICATIONS             --
--         * * * * * * * * * *  WARNING  * * * * * * * * * *               --
--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--
--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--=--

package body File_Manager is

package SP renames String_Pkg;
package CH  renames Condition_Handling;
package SYS renames System;
package STR renames Starlet;

subtype File_String is STRING (1 .. 255);
                                                                    pragma page;
-----------------------------------------------------------------------------

procedure Raise_Error (
    STS : SYS.Unsigned_Longword
    ) is

begin

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

end Raise_Error;
                                                                    pragma page;
-----------------------------------------------------------------------------

procedure Set_FAB_NAM (
    File  : in     STRING;
    FAB   : in out STR.FAB_Type;
    NAM   : in out STR.NAM_Type;
    ES    : in out File_String
    ) is

    Status : CH.Cond_Value_Type;
    From   : INTEGER;
    To     : INTEGER;

begin

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

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

    STR.Parse(Status, FAB);
    if CH.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    : STR.FAB_Type;
    NAM1    : STR.NAM_Type;
    RAB1    : STR.RAB_Type;
    ES1     : File_String;
    FAB2    : STR.FAB_Type;
    NAM2    : STR.NAM_Type;
    RAB2    : STR.RAB_Type;
    ES2     : File_String;
    Buffer  : STRING (1 .. 1024);
    Status  : CH.Cond_Value_Type;

begin

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

    RAB1     := STR.RAB_Type_Init;
    RAB1.FAB := FAB1'address;
    RAB1.MBF := 2;
    RAB1.ROP.RAH := TRUE;
    STR.Connect(Status, RAB1);
    if not CH.Success(Status) then
    raise Input_File_Error;
    end if;
    RAB1.UBF := Buffer'address;
    RAB1.USZ := SYS.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;
    STR.Create(Status, FAB2);
    if not CH.Success(Status) then
    Raise_Error(FAB2.STS);
    raise Output_File_Error;
    end if;
    RAB2 := STR.RAB_Type_Init;
    RAB2.FAB := FAB2'address;
    RAB2.MBF := 2;
    RAB2.ROP.EOF := CIF;
    RAB2.ROP.WBH := TRUE;
    STR.Connect(Status, RAB2);
    if not CH.Success(Status) then
    raise Output_File_Error;
    end if;

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

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

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

end Copy_Append;
                                                                    pragma page;
-----------------------------------------------------------------------------
            -- Visible Operations --
-----------------------------------------------------------------------------

procedure Rename (
    Old_File : in STRING;
    New_File : in STRING
    ) is

    Old_FAB : STR.FAB_Type;
    Old_NAM : STR.NAM_Type;
    Old_ES  : File_String;
    Old_RS  : File_String;
    New_FAB : STR.FAB_Type;
    New_NAM : STR.NAM_Type;
    New_ES  : File_String;
    New_RS  : File_String;
    Status  : CH.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 := SYS.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 := SYS.Unsigned_Byte(New_RS'length);

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

    Raise_Error(Old_FAB.STS);
    raise Rename_Error;

end Rename;
                                                                    pragma page;
-----------------------------------------------------------------------------

procedure Delete (
    File : in STRING
    ) is

    FAB    : STR.FAB_Type;
    NAM    : STR.NAM_Type;
    ES     : File_String;
    RS     : File_String;
    FABX   : STR.FAB_Type;
    NAMX   : STR.NAM_Type;
    ESX    : File_String;
    Status : CH.Cond_Value_Type;
    Error  : BOOLEAN := FALSE;

begin

    Set_FAB_NAM(File => File, FAB => FAB, NAM => NAM, ES => ES);
    FAB.IFI := STR.FAB_IFI_Type_Init;
    NAM.RSA := RS'address;
    NAM.RSS := Unsigned_Byte(RS'length);

    loop
    STR.Search(Status, FAB);
    if CH.Success(Status) then
        Set_FAB_NAM(File => RS(1 .. NATURAL(NAM.RSL)),
            FAB  => FABX,
            NAM  => NAMX,
            ES => ESX);
        STR.Erase(Status, FAB);
        if not CH.Success(Status) then
        Error := TRUE;
        end if;
    else
        if FAB.STS = STR.RMS_FNF then
        raise File_Not_Found;
        elsif FAB.STS = STR.RMS_NMF then
        exit;
        end if;
        Error := TRUE;
    end if;
    end loop;
    if Error then
    raise Delete_Error;
    end if;

end Delete;
                                                                    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;
    Append_File : in STRING
    ) is

begin

    Copy_Append(File1 => Input_File,
        File2 => Append_File,
        CIF   => TRUE);

end Append;
                                                                    pragma page;
-----------------------------------------------------------------------------

function Parse_Line (
    Line : in STRING;
    Mode : in Mode_Type:= FULL
    ) return STRING is

    Index1 : INTEGER;
    Index2 : INTEGER;

begin

    case Mode is
    when NO_DIRECTORY | FILE_ONLY | NAME_ONLY | TYPE_ONLY =>
        for i in Line'range loop
        if Line(i) = ']' then
            Index1 := i + 1;
            exit;
        end if;
        end loop;
        if Mode = TYPE_ONLY then
        for i in Index1 .. Line'last loop
            if Line(i) = '.' then
            Index1 := i + 1;
            exit;
            end if;
        end loop;
        end if;
    when others =>
        Index1 := Line'first;
    end case;
    case Mode is
    when NO_VERSION | FILE_ONLY | NAME_ONLY | TYPE_ONLY =>
        for i in reverse Line'range loop
        if Line(i) = ';' then
            Index2 := i - 1;
            exit;
        end if;
        end loop;
        if Mode = NAME_ONLY then
        for i in reverse 1 .. Index2 loop
            if Line(i) = '.' then
            Index2 := i - 1;
            exit;
            end if;
        end loop;
        end if;
    when others =>
        Index2 := Line'last;
    end case;
    return Line(Index1 .. Index2);

end Parse_Line;

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

function creation_Date(    --| Return the creation date of a file
    File: in STRING    --| Name of a file
    ) return STRING --| Raises: File_Not_Found

is
    use Starlet;
    fab: fab_type := fab_type_init;         -- file access block
    xab: xab_type(xab_c_dat) := xabdat_init;    -- date xab
    status: condition_handling.cond_value_type;
    date_time_buffer: String(1..64);
    date_time_length: system.unsigned_word;

begin
    -- initialize fab fields
    fab.fna := file'address;
    fab.fns := file'length;
    fab.xab := xab'address;
    -- open file to fill access blocks
    open(status, fab);
    if not condition_handling.success(status) then
        -- you could condition_handling.signal(status);
        raise File_Not_Found;
    end if;

    -- convert time quadword
    -- xab.cdt = creation date
    -- xab.dat_rdt = revision date
    --
    asctim(status, date_time_length, date_time_buffer, xab.cdt);
    if not condition_handling.success(status) then
        -- you could condition_handling.signal(status);
        close(status, fab);
        raise Date_Error;
    end if;
    close(status, fab); -- check status if you want
    return date_time_buffer(1..integer(date_time_length));
end creation_Date;


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

function modification_Date(    --| Return the modification date of a file
    File: in STRING        --| Name of a file
    ) return STRING --| Raises: File_Not_Found

--| Effects: Return a string containing the date and time that File
--| was last modified in the form "mm/dd/yy hh:mm:ss.cc".
is
    use Starlet;
    fab: fab_type := fab_type_init;         -- file access block
    xab: xab_type(xab_c_dat) := xabdat_init;    -- date xab
    status: condition_handling.cond_value_type;
    date_time_buffer: String(1..64);
    date_time_length: system.unsigned_word;

begin
    -- initialize fab fields
    fab.fna := file'address;
    fab.fns := file'length;
    fab.xab := xab'address;
    -- open file to fill access blocks
    open(status, fab);
    if not condition_handling.success(status) then
        -- you could condition_handling.signal(status);
        raise File_Not_Found;
    end if;

    -- convert time quadword
    -- xab.cdt = creation date
    -- xab.dat_rdt = revision date
    --
    asctim(status, date_time_length, date_time_buffer, xab.dat_rdt);
    if not condition_handling.success(status) then
        -- you could condition_handling.signal(status);
        close(status, fab);
        raise Date_Error;
    end if;
    close(status, fab); -- check status if you want
    return date_time_buffer(1..integer(date_time_length));

end modification_Date;


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

function Expand (
    File : in STRING;
    Mode : in Mode_Type := FULL
    ) return SL.List is

    FAB      : STR.FAB_Type;
    NAM      : STR.NAM_Type;
    ES       : File_String;
    RS       : File_String;
    Status   : CH.Cond_Value_Type;
    Files    : SL.List;
    New_List : BOOLEAN := TRUE;

begin

    Set_FAB_NAM(File => File, FAB => FAB, NAM => NAM, ES => ES);
    FAB.IFI := STR.FAB_IFI_Type_Init;
    NAM.RSA := RS'address;
    NAM.RSS := SYS.Unsigned_Byte(RS'length);

    SP.Mark;
    loop
    STR.Search(Status, FAB);
    if CH.Success(Status) then
        if New_List then
        Files := SL.Create;
        New_List := FALSE;
        end if;
        SL.Attach(Files, SP.Make_Persistent(Parse_Line(RS(1 .. INTEGER(NAM.RSL)), Mode)));
    else
        if FAB.STS = STR.RMS_NMF then
        return Files;
        end if;
        Raise_Error(FAB.STS);
        raise Expand_Error;
    end if;
    end loop;
    SP.Release;

end Expand;
                                                                    pragma page;
-----------------------------------------------------------------------------

procedure Destroy (
    Name_List : in out SL.List
    ) is

    Iterator : SL.ListIter;
    Name     : SP.String_Type;

begin

    Iterator := SL.MakeListIter(Name_List);
    while (SL.More(Iterator)) loop
    SL.Next(Iterator, Name);
    SP.Flush(Name);
    end loop;
    SL.Destroy(Name_List);

end Destroy;
                                                                    pragma page;
-----------------------------------------------------------------------------

function Strip_Dir (
    Long_Name : in STRING
    ) return STRING is

begin

    for N in Long_Name'First..Long_Name'Last loop
    if Long_Name(N) = ']' then
        declare
        R: constant string(1..Long_Name'Last - N)
            := Long_Name(N+1..Long_Name'Last);
        begin
        return R;
        end;
    end if;
    end loop;
    return Long_Name;

end Strip_Dir;
                                                                    pragma page;
-----------------------------------------------------------------------------

function Parse_Filename (
    Name : in STRING;
    Mode : in Mode_Type := FULL
    ) return STRING is

    FAB    : STR.FAB_Type;
    NAM    : STR.NAM_Type;
    ES     : File_String;

begin

    Set_FAB_NAM(File => Name, FAB => FAB, NAM => NAM, ES => ES);
    return Parse_Line(ES(1 .. INTEGER(NAM.ESL)), Mode);

end Parse_Filename;
                                                                    pragma page;
-----------------------------------------------------------------------------

procedure Check_Directory_Format(
    Directory : in STRING
    ) is

begin

    if Directory'Length < 2 then
    raise Parse_Error;
    end if;
    if Directory(Directory'last) /= ']' then
    raise Parse_Error;
    end if;
    for i in Directory'range loop
    if Directory(i) = '[' then
        return;
    end if;
    end loop;
    raise Parse_Error;

end Check_Directory_Format;

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

function Path_Name(
    Directory : in STRING;
    File      : in STRING;
    Absolute  : in BOOLEAN := FALSE
    ) return STRING is

    FAB      : STR.FAB_Type;
    NAM      : STR.NAM_Type;
    ES       : File_String;
    RS       : File_String;
    Relative : BOOLEAN := FALSE;
    CD       : SP.String_Type;

begin

    Check_Directory_Format(Directory);

    if not Absolute then
    return Directory & File;
    end if;

    for i in Directory'range loop
    if Directory(i) = '[' then
        if Directory(i+1) = '.' then
        Relative := TRUE;
        end if;
        exit;
    end if;
    end loop;

    begin
    if File = "" then
        if Relative and Absolute then
        Set_FAB_NAM(File => "[].;", FAB => FAB, NAM => NAM, ES => ES);
        return ES(1 .. INTEGER(NAM.ESL)-3) &
               Directory(2 .. Directory'length);
        else
        Set_FAB_NAM(File => Directory & ".;", FAB => FAB, NAM => NAM, ES => ES);
        return ES(1 .. INTEGER(NAM.ESL)-2);
        end if;
    else
        if Relative and Absolute then
        Set_FAB_NAM(File => "[].;", FAB => FAB, NAM => NAM, ES => ES);
        return ES(1 .. INTEGER(NAM.ESL)-3) &
               Directory(2 .. Directory'length) & File;
        else
        Set_FAB_NAM(File => Directory & File, FAB => FAB, NAM => NAM, ES => ES);
        return ES(1 .. INTEGER(NAM.ESL));
        end if;
    end if;

    exception
    when others =>
        return Directory & File;
    end;

end Path_Name;
                                                                    pragma page;
-----------------------------------------------------------------------------

procedure Create_Dir(
    Status :    out INTEGER;
    Dir    : in     STRING);

    pragma Interface(VAXRTL, Create_Dir);
    pragma Import_Valued_Procedure(Internal        => Create_Dir,
                   External        => "LIB$CREATE_DIR",
                   Parameter_Types => (INTEGER, STRING),
                   Mechanism       => (Value, Descriptor(S)));

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

procedure Create_Directory(
    Directory : in STRING
    ) is

    Stat  : INTEGER;

begin

    Create_Dir(Stat, Directory);
    if Stat rem 2 = 0 then
    raise Create_Error;
    end if;

end Create_Directory;
                                                                    pragma page;
-----------------------------------------------------------------------------

function Is_Directory(
    Directory : in STRING
    ) return BOOLEAN is

    FAB : STR.FAB_Type;
    NAM : STR.NAM_Type;
    ES  : File_String;
    RS  : File_String;

begin

    Check_Directory_Format(Directory);
    begin
    Set_FAB_NAM(File => Directory & ".;", FAB => FAB, NAM => NAM, ES => ES);
    exception
    when File_Not_Found
       | File_Already_Exists
       | File_Locked
       | Privilege_Violation =>
        return TRUE;
    when Directory_Not_Found =>
        return FALSE;
    when others =>
        raise;
    end;
    return TRUE;

end Is_Directory;

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

end  File_Manager;
                                                                    pragma page;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--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;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--SUTILS.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with String_Pkg;
with Stack_Pkg;
with String_Lists;

package String_Utilities 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
--| Make_Scanner*    Given a string returns a 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 Generic_String_Type in Scanner
--| Get_Remainder*    Return Generic_String_Type in Scanner from current Index
--| Get_Segment*    Return Generic_String_Type in Scanner as specified
--| Mark        Mark the current Index for Restore
--| Unmark        Remove the previous mark from the Scanner
--| Restore        Restore the previously marked Index
--| Position        Return the current position of the Scanner
--| Destroy_Scanner    Free storage used by 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*    Return sequence of decimal digits
--| Scan_Number        Return integer number
--| Is_Signed_Number    Return TRUE iff Scanner is at a digit or sign
--| Scan_Signed_Number*    Return sequence of decimal digits with optional sign (+/-)
--| Scan_Signed_Number  Return integer number
--| 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 a possible Ada id
--| Scan_Ada_Id*    Scan up to the character which are valid 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
--| Is_Sequence*    Return TRUE iff Scanner is at some character in sequence
--| Scan_Sequenc* (2)    Scan user specified sequence of chars
--| Is_Not_Sequence    Return TRUE iff Scanner is not at the characters in sequence
--| Is_Not_Sequence*    Return TRUE iff Scanner is not at the characters in sequence
--| Scan_Not_Sequence* (2)
--|            Scan string up to but not including a given sequence of chars
--| Is_Literal            Return TRUE iff Scanner is at literal
--| Is_Literal*            Return TRUE iff Scanner is at literal
--| Scan_Literal* (2)    Scan user specified literal
--| Is_Not_Literal    Return TRUE iff Scanner is not a given literal
--| Is_Not_Literal*    Return TRUE iff Scanner is not a given literal
--| Scan_Not_Literal* (2)
--|            Scan string up to but not including a given literal
--| Strip_Leading    Strip leading characters from a given string
--| Strip_Leading* (3)    Strip leading characters from a given string
--| Strip_Trailing    Strip trailing characters from a given string
--| Strip_Trailing* (3)    Strip trailing characters from a given string
--| Strip        Strip both leading and trailing characters
--| Strip* (3)        Strip both leading and trailing characters
--| Left_Justify    Left justify a given string
--| Left_Justify* (3)    Left justify a given string
--| Right_Justify    Right justify a given string
--| Right_Justify* (3)    Right justify a given string
--| Center        Center a given string
--| Center* (3)        Center a given string
--| Expand        Fill and justify a given string
--| Expand* (3)        Fill and justify a given string
--| Format        Format a given string
--| Format*        Format a given string
--| Image        Convert an integer to a string
--| Image*        Convert an integer to a string
--| Value        Convert a string to an integer
--| Value*        Convert a string to an integer
--| Match        Return TRUE if a string matches another
--| Match* (3)        Return TRUE if a string matches another
--|
--|     nb : Operations followed by an asterisk (*) are generic operations
--|+
                                                                    pragma page;
----------------------------------------------------------------

White_Space   : constant STRING := " " & ASCII.HT;
Number        : constant STRING := "0123456789";
Alphabetic    : constant STRING := "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
Alphameric    : constant STRING := Alphabetic & Number;

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

package SL renames String_Lists;

package SP renames String_Pkg;

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

type Scanner is private;    --| Scanner type

type Justification_Mode is (NONE, LEFT, RIGHT, CENTER, EXPAND);

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

Out_Of_Bounds      : exception;    --| Raised when a operation is attempted on a
                --| Scanner that has passed the end
Scanner_Not_Marked : exception;    --| Raised when a Unmark or Restore is attemped
                --| on a Scanner that has not been marked
Non_Numeric_String : exception; --| Raised when an attempt is made to take the
                --| value of a string that is not a number
Number_Too_Large   : exception; --| Raised when an attempt is made to scan a
                --| number outside the implemented range
                                                                    pragma page;
----------------------------------------------------------------

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

--| Effects: Construct a Scanner from S.
--| 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
                                                                    pragma page;
----------------------------------------------------------------

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

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

procedure Mark(
    T : in Scanner
    );

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

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

procedure Unmark(
    T : in Scanner
    );

--| Raises: Scanner_Not_Marked
--| Effects: removes previous mark from the scanner without change to the index
--| N/A: Modifies, Errors

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

procedure Restore(
    T : in Scanner
    );

--| Raises: Scanner_Not_Marked
--| Effects: Restore the index to the previously marked value
--| N/A: 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
                                                                    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 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.
--| N/A: Raises, Modifies, Errors

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

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 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 => <digits>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| 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

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

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.
--| N/A: 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).
--| N/A: Raises, Modifies, Errors

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

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.
--| N/A: Raises, Modifies, Errors

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

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" ...).
--| N/A: Raises, Modifies, Errors

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

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] ...).
--| N/A: Raises, Modifies, Errors
                                                                    pragma page;
----------------------------------------------------------------

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.
--| N/A: 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.
--| N/A: 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.
--| N/A: Raises, Modifies, Errors

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

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
--| N/A: Raises, Modifies, Errors
                                                                pragma page;
----------------------------------------------------------------

function Strip_Leading(        --| Strip leading characters from a given string
    Text : in STRING;        --| Input string
    Char : in STRING := " " & ASCII.HT
                --| Character(s) to be stripped
    ) return STRING;        --| Result string

--| Effects: The specified leading characters are stripped from the input text
--| N/A: Modifies, Raises, Errors

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

function Strip_Trailing(    --| Strip trailing characters from a given string
    Text : in STRING;        --| Input string
    Char : in STRING := " " & ASCII.HT
                --| Character(s) to be stripped
    ) return STRING;        --| Result string

--| Effects: The given trailing characters are stripped from the input text
--| N/A: Modifies, Raises, Errors

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

function Strip(         --| Strip both leading and trailing characters
                --| from a given string
    Text : in STRING;        --| Input string
    Char : in STRING := " " & ASCII.HT
                --| Character(s) to be stripped
    ) return STRING;        --| Result string

--| Effects: The specified characters are stripped from the input text in both
--| leading and trailing positions
--| N/A: Modifies, Raises, Errors
                                                                pragma page;
----------------------------------------------------------------

function Left_Justify(        --| Left justify a given string
    Text : in STRING;        --| Input string
    Len  : in POSITIVE;        --| Output string length
    Char : in CHARACTER := ' '    --| Fill character
    ) return STRING;        --| Result string

--| Effects: The specified input string is placed left justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors

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

function Right_Justify(        --| Right justify a given string
    Text : in STRING;        --| Input string
    Len  : in POSITIVE;        --| Output string length
    Char : in CHARACTER := ' '    --| Fill character
    ) return STRING;        --| Result string

--| Effects: The specified input string is placed right justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors

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

function Center(        --| Center a given string
    Text : in STRING;        --| Input string
    Len  : in POSITIVE;        --| Output string length
    Char : in CHARACTER := ' '    --| Fill character
    ) return STRING;        --| Result string

--| Effects: The specified input string is placed centered and padded if needed
--| with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors

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

function Expand(        --| Expand a given string to Len
    Text : in STRING;        --| Input string
    Len  : in POSITIVE        --| Output string length
    ) return STRING;        --| Result string

--| Effects: The specified input string is expanded to Len with blanks.
--| (eg. "Expand this string to 40 chars" when Len equals 40 will be
--| "Expand   this   string   to   40   chars")
--| N/A: Modifies, Raises, Errors
                                                                pragma page;
----------------------------------------------------------------

function Format(        --| Format a given string
    Text    : in STRING;    --| Input string
    Len     : in POSITIVE;    --| Length of each folded line
    Del     : in CHARACTER := ' ';
                --| Delimiting character
    Justify : in Justification_Mode := NONE
                --| Justification mode
    ) return SL.List;

--| Effects: The specified string is folded into as many lines of Len as needed.
--| The character Del indicated an element of the input string where the
--| line may be "broken".  Returned list consists of persistent string types
--| thus must be flushed (or DestroyDeep with Flush).
--| N/A: Modifies, Raises, Errors

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

function Image(            --| Convert an integer to a string
    Num  : in INTEGER;        --| Input number
    Len  : in NATURAL   := 0;    --| Length of the output string
    Fill : in CHARACTER := ' '    --| Fill character
    ) return STRING;

--| Effects: The specified integer is converted into a string of length Len.
--| Len of 0 implies that the converted integer fills the string.
--| If Len (other thatn 0) is too small to contain the converted string
--| the number is truncated.
--| N/A: Modifies, Raises, Errors

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

function Value(            --| Convert a string to an integer
    Text : in STRING        --| String to be converted
    ) return INTEGER;

--| Raises: Non_Numeric_String, Number_Too_Large
--| Effects: The specified string is converted into an equivalent integer.
--| The string must have the syntax of an Ada INTEGER (LRM 2.4.1)
--| N/A: Modifies, Errors

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

function Match(            --| Match two strings
    Pattern    : in STRING;    --| String to match
    Target     : in STRING;    --| String to be searched
    Wildcard   : in CHARACTER := '*';
                --| Wildcard character
    Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
                --| Case sensitivity in comparison
    ) return BOOLEAN;

--| Effects: The specified Pattern containing Wildcard character(s) are
--| searched on Target.  If Target satisfies the condition in Pattern
--| returns TRUE.
--| (eg. Match("A*B*", "AzzzBzzz") will return TRUE
--|      Match("A*B*", "zzzABzzz") will return FALSE)
--| N/A: Raises, Modifies, Errors

----------------------------------------------------------------
                                                                pragma page;
generic

    type Generic_String_Type is private;
    with function To_Generic (X : in STRING) return Generic_String_Type;
    with function From_Generic (X : in Generic_String_Type) return STRING;

package Generic_String_Utilities is

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

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

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

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

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

--| Effects: Return a Generic_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 Generic_String_Type;

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

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

function Get_Segment(            --| Return contents of Scanner
    T    : in Scanner;            --| Scanner
    From : in POSITIVE;            --| Starting position
    To   : in POSITIVE            --| Ending position
    ) return Generic_String_Type;

--| Effects: Return a Generic_String_Type corresponding to the contents
--| of the Scanner starting at From and end at but NOT including To.
--| (eg. Given a scanner T that contains : $123.45
--|  Get_Segment(T, 2, 5) will return a Generic_String_Type containing 123
--| 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 Generic_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;
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 Generic_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.
--| 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 Generic_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.
--| N/A: 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 Generic_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.
--| N/A: Raises, Modifies, Errors
                                                                pragma page;
----------------------------------------------------------------

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 Generic_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.
--| N/A: 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 Generic_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.
--| N/A: 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 Generic_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.
--| N/A: Raises, Modifies, Errors
                                                                pragma page;
----------------------------------------------------------------

function Is_Sequence(            --| Check if T is at some sequence characters
    Chars : in Generic_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.
--| N/A: Raises, Modifies, Errors

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

procedure Scan_Sequence(        --| Scan arbitrary sequence of characters
    Chars  : in     Generic_String_Type;--| Characters that should be scanned
    T      : in     Scanner;        --| String to be scanned
    Found  :    out BOOLEAN;        --| TRUE iff a sequence found
    Result :    out Generic_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.
--| N/A: Raises, Modifies, Errors

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

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 Generic_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.
--| N/A: Raises, Modifies, Errors
                                                                pragma page;
----------------------------------------------------------------

function Is_Not_Sequence(        --| Check if T is not at some seuqnce of character
    Chars : in Generic_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.
--| N/A: Raises, Modifies, Errors

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

procedure Scan_Not_Sequence(        --| Scan arbitrary sequence of characters
    Chars  : in     Generic_String_Type;--| Characters that should be scanned
    T      : in     Scanner;        --| String to be scanned
    Found  :    out BOOLEAN;        --| TRUE iff a sequence found
    Result :    out Generic_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.
--| N/A: 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 Generic_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.
--| N/A: Raises, Modifies, Errors
                                                                pragma page;
----------------------------------------------------------------

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

--| Effects: Return TRUE iff T is at literal Chars.
--| N/A: 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
--| N/A: Raises, Modifies, Errors

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

procedure Scan_Literal(            --| Scan arbitrary literal
    Chars  : in     Generic_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
--| N/A: Raises, Modifies, Errors
                                                                pragma page;
----------------------------------------------------------------

function Is_Not_Literal(        --| Check if T is not at literal Chars
    Chars : in Generic_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
--| N/A: 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 Generic_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
--| N/A: Raises, Modifies, Errors

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

procedure Scan_Not_Literal(        --| Scan arbitrary literal
    Chars  : in     Generic_String_Type;--| Literal that should be scanned
    T      : in     Scanner;        --| String to be scanned
    Found  :    out BOOLEAN;        --| TRUE iff a sequence found
    Result :    out Generic_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
--| N/A: Raises, Modifies, Errors

                                                                pragma page;
----------------------------------------------------------------

function Strip_Leading(            --| Strip leading characters from a given string
    Text : in Generic_String_Type;    --| Input string
    Char : in STRING := " " & ASCII.HT    --| Character(s) to be stripped
    ) return STRING;            --| Result string

--| Effects: The specified leading characters are stripped from the input text.
--| N/A: Modifies, Raises, Errors

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

function Strip_Leading(            --| Strip leading characters from a given string
    Text : in STRING;            --| Input string
    Char : in STRING := " " & ASCII.HT    --| Character(s) to be stripped
    ) return Generic_String_Type;    --| Result string

--| Effects: The specified leading characters are stripped from the input text.
--| N/A: Modifies, Raises, Errors

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

function Strip_Leading(            --| Strip leading characters from a given string
    Text : in Generic_String_Type;    --| Input string
    Char : in STRING := " " & ASCII.HT    --| Character(s) to be stripped
    ) return Generic_String_Type;    --| Result string

--| Effects: The specified leading characters are stripped from the input text.
--| N/A: Modifies, Raises, Errors
                                                                pragma page;
----------------------------------------------------------------

function Strip_Trailing(        --| Strip trailing characters from a given string
    Text : in Generic_String_Type;    --| Input string
    Char : in STRING := " " & ASCII.HT    --| Character(s) to be stripped
    ) return STRING;            --| Result string

--| Effects: The specified trailing characters are stripped from the input text.
--| N/A: Modifies, Raises, Errors

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

function Strip_Trailing(        --| Strip trailing characters from a given string
    Text : in STRING;            --| Input string
    Char : in STRING := " " & ASCII.HT    --| Character(s) to be stripped
    ) return Generic_String_Type;    --| Result string

--| Effects: The specified trailing characters are stripped from the input text.
--| N/A: Modifies, Raises, Errors

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

function Strip_Trailing(        --| Strip trailing characters from a given string
    Text : in Generic_String_Type;    --| Input string
    Char : in STRING := " " & ASCII.HT    --| Character(s) to be stripped
    ) return Generic_String_Type;    --| Result string

--| Effects: The specified trailing characters are stripped from the input text.
--| N/A: Modifies, Raises, Errors
                                                                pragma page;
----------------------------------------------------------------

function Strip(             --| Strip both leading and trailing
                    --| characters from a given string
    Text : in Generic_String_Type;    --| Input string
    Char : in STRING := " " & ASCII.HT    --| Character(s) to be stripped
    ) return STRING;            --| Result string

--| Effects: The specified characters if any are stripped from the input text
--| in both leading and trailing positions.
--| N/A: Modifies, Raises, Errors

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

function Strip(             --| Strip both leading and trailing
                    --| characters from a given string
    Text : in STRING;            --| Input string
    Char : in STRING := " " & ASCII.HT    --| Character(s) to be stripped
    ) return Generic_String_Type;    --| Result string

--| Effects: The specified characters if any are stripped from the input text
--| in both leading and trailing positions.
--| N/A: Modifies, Raises, Errors

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

function Strip(                --| Strip both leading and trailing
                    --| characters from a given string
    Text : in Generic_String_Type;    --| Input string
    Char : in STRING := " " & ASCII.HT    --| Character(s) to be stripped
    ) return Generic_String_Type;    --| Result string

--| Effects: The specified characters if any are stripped from the input text
--| in both leading and trailing positions.
--| N/A: Modifies, Raises, Errors
                                                                pragma page;
----------------------------------------------------------------

function Left_Justify(            --| Left justify a given string
    Text : in Generic_String_Type;    --| Input string
    Len  : in POSITIVE;            --| Output string length
    Char : in CHARACTER := ' '        --| Fill character
    ) return STRING;            --| Result string

--| Effects: The specified input string is placed left justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors

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

function Left_Justify(            --| Left justify a given string
    Text : in STRING;            --| Input string
    Len  : in POSITIVE;            --| Output string length
    Char : in CHARACTER := ' '        --| Fill character
    ) return Generic_String_Type;    --| Result string

--| Effects: The specified input string is placed left justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors

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

function Left_Justify(            --| Left justify a given string
    Text : in Generic_String_Type;    --| Input string
    Len  : in POSITIVE;            --| Output string length
    Char : in CHARACTER := ' '        --| Fill character
    ) return Generic_String_Type;    --| Result string

--| Effects: The specified input string is placed left justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
                                                                pragma page;
----------------------------------------------------------------

function Right_Justify(            --| Right justify a given string
    Text : in Generic_String_Type;    --| Input string
    Len  : in POSITIVE;            --| Output string length
    Char : in CHARACTER := ' '        --| Fill character
    ) return STRING;            --| Result string

--| Effects: The specified input string is placed right justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors

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

function Right_Justify(            --| Right justify a given string
    Text : in STRING;            --| Input string
    Len  : in POSITIVE;            --| Output string length
    Char : in CHARACTER := ' '        --| Fill character
    ) return Generic_String_Type;    --| Result string

--| Effects: The specified input string is placed left justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors

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

function Right_Justify(            --| Right justify a given string
    Text : in Generic_String_Type;    --| Input string
    Len  : in POSITIVE;            --| Output string length
    Char : in CHARACTER := ' '        --| Fill character
    ) return Generic_String_Type;    --| Result string

--| Effects: The specified input string is placed left justified and padded if
--| needed with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
                                                                pragma page;
----------------------------------------------------------------

function Center(            --| Center a given string
    Text : in Generic_String_Type;    --| Input string
    Len  : in POSITIVE;            --| Output string length
    Char : in CHARACTER := ' '        --| Fill character
    ) return STRING;            --| Result string

--| Effects: The specified input string is placed centered and padded if needed
--| with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors

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

function Center(            --| Center a given string
    Text : in STRING;            --| Input string
    Len  : in POSITIVE;            --| Output string length
    Char : in CHARACTER := ' '        --| Fill character
    ) return Generic_String_Type;    --| Result string

--| Effects: The specified input string is placed centered and padded if needed
--| with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors

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

function Center(            --| Center a given string
    Text : in Generic_String_Type;    --| Input string
    Len  : in POSITIVE;            --| Output string length
    Char : in CHARACTER := ' '        --| Fill character
    ) return Generic_String_Type;    --| Result string

--| Effects: The specified input string is placed centered and padded if needed
--| with the fill character.
--| The Len specifies the result string length.
--| N/A: Modifies, Raises, Errors
                                                                pragma page;
----------------------------------------------------------------

function Expand(            --| Expand a given string to Len
    Text : in Generic_String_Type;    --| Input string
    Len  : in POSITIVE            --| Output string length
    ) return STRING;            --| Result string

--| Effects: The specified input string is expanded to Len with blanks.
--| (eg. "Expand this string to 40 chars" when Len equals 40 will be
--| "Expand   this   string   to   40   chars")
--| N/A: Modifies, Raises, Errors

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

function Expand(            --| Expand a given string to Len
    Text : in STRING;            --| Input string
    Len  : in POSITIVE            --| Output string length
    ) return Generic_String_Type;    --| Result string

--| Effects: The specified input string is expanded to Len with blanks.
--| (eg. "Expand this string to 40 chars" when Len equals 40 will be
--| "Expand   this   string   to   40   chars")
--| N/A: Modifies, Raises, Errors

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

function Expand(            --| Expand a given string to Len
    Text : in Generic_String_Type;    --| Input string
    Len  : in POSITIVE            --| Output string length
    ) return Generic_String_Type;    --| Result string

--| Effects: The specified input string is expanded to Len with blanks.
--| (eg. "Expand this string to 40 chars" when Len equals 40 will be
--| "Expand   this   string   to   40   chars")
--| N/A: Modifies, Raises, Errors
                                                                pragma page;
----------------------------------------------------------------

function Format(            --| Format a given string
    Text    : in Generic_String_Type;    --| Input string
    Len     : in POSITIVE;        --| Length of each folded line
    Del     : in CHARACTER := ' ';    --| Delimiting character
    Justify : in Justification_Mode := NONE
                    --| Justification mode
    ) return SL.List;

--| Effects: The specified string is folded into as many lines of Len as needed.
--| The character Del indicated an element of the input string where the
--| line may be "broken".  Returned list consists of persistent string types
--| thus must be flushed (or DestroyDeep with Flush).
--| N/A: Modifies, Raises, Errors

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

function Image(                --| Convert an integer to a string
    Num  : in INTEGER;            --| Input number
    Len  : in NATURAL   := 0;        --| Length of the output string
    Fill : in CHARACTER := ' '        --| Fill character
    ) return Generic_String_Type;

--| Effects: The specified integer is converted into a string of length Len.
--| Len of 0 implies that the converted integer fills the string.
--| If Len (other thatn 0) is too small to contain the converted string
--| the number is truncated.
--| N/A: Modifies, Raises, Errors

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

function Value(                --| Convert a string to an integer
    Text : in Generic_String_Type    --| Input string
    ) return INTEGER;

--| Raises: Non_Numeric_String, Number_Too_Large
--| Effects: The specified string is converted into an equivalent integer.
--| The string must have the syntax of an Ada INTEGER (LRM 2.4.1)
--| N/A: Modifies, Errors

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

function Match(            --| Match two strings
    Pattern    : in Generic_String_Type;
                --| String to match
    Target     : in STRING;    --| String to be searched
    Wildcard   : in CHARACTER := '*';
                --| Wildcard character
    Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
                --| Case sensitivity in comparison
    ) return BOOLEAN;

--| Effects: The specified Pattern containing Wildcard character(s) are
--| searched on Target.  If Target satisfies the condition in Pattern
--| returns TRUE.
--| N/A: Raises, Modifies, Errors

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

function Match(            --| Match two strings
    Pattern    : in STRING;    --| String to match
    Target     : in Generic_String_Type;
                --| String to be searched
    Wildcard   : in CHARACTER := '*';
                --| Wildcard character
    Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
                --| Case sensitivity in comparison
    ) return BOOLEAN;

--| Effects: The specified Pattern containing Wildcard character(s) are
--| searched on Target.  If Target satisfies the condition in Pattern
--| returns TRUE.
--| N/A: Raises, Modifies, Errors

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

function Match(            --| Match two strings
    Pattern    : in Generic_String_Type;
                --| String to match
    Target     : in Generic_String_Type;
                --| String to be searched
    Wildcard   : in CHARACTER := '*';
                --| Wildcard character
    Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
                --| Case sensitivity in comparison
    ) return BOOLEAN;

--| Effects: The specified Pattern containing Wildcard character(s) are
--| searched on Target.  If Target satisfies the condition in Pattern
--| returns TRUE.
--| N/A: Raises, Modifies, Errors

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

end Generic_String_Utilities;


private
                                                                    pragma List(off);
    package ST is new Stack_Pkg(POSITIVE);

    type Scan_Record is
    record
        text  : SP.String_Type;    --| Copy of string being scanned
        index : POSITIVE := 1;    --| Current position of Scanner
        mark  : ST.Stack := ST.Create;
                    --| Marks
    end record;

    type Scanner is access Scan_Record;
                                                                    pragma List(on);
end String_Utilities;
                                                                    pragma page;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--SUTILS.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with Unchecked_Deallocation;

package body String_Utilities is

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

procedure Free_Scanner is
    new Unchecked_Deallocation(Scan_Record, Scanner);

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

function Is_Valid(
    T : in Scanner
    ) return BOOLEAN is

begin

    return T /= null;

end Is_Valid;

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

function Make_Scanner(
    S : in STRING
    ) return Scanner is

    T : Scanner := new Scan_Record;

begin

    T.text := SP.Make_Persistent(S);
    return T;

end Make_Scanner;

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

procedure Destroy_Scanner(
    T : in out Scanner
    ) is

begin

    if Is_Valid(T) then
    SP.Flush(T.text);
    ST.Destroy(T.mark);
    Free_Scanner(T);
    end if;

end Destroy_Scanner;

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

function More(
    T : in Scanner
    ) return BOOLEAN is

begin

    if Is_Valid(T) and then T.index <= SP.Length(T.text) then
    return TRUE;
    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 SP.Fetch(T.text, T.index);

end Get;

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

procedure Forward(
    T : in Scanner
    ) is

begin

    if Is_Valid(T) then
    if SP.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);
    T.index := T.index + 1;

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;

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

procedure Mark(
    T : in Scanner
    ) is

begin

    if Is_Valid(T) then
    ST.Push(T.mark, T.index);
    end if;

end Mark;

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

procedure Unmark(
    T : in Scanner
    ) is

    Num : POSITIVE;

begin

    if Is_Valid(T) and then not ST.Is_Empty(T.mark) then
        ST.Pop(T.mark, Num);
    else
    raise Scanner_Not_Marked;
    end if;

end Unmark;

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

procedure Restore(
    T : in Scanner
    ) is

begin

    if Is_Valid(T) and then not ST.Is_Empty(T.mark) then
    ST.Pop(T.mark, T.index);
    else
    raise Scanner_Not_Marked;
    end if;

end Restore;

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

function Is_Any(
    T : in Scanner;
    Q : in STRING
    ) return BOOLEAN is

    N     : NATURAL;

begin

    if not More(T) then
    return FALSE;
    end if;
    SP.Mark;
    N := SP.Match_Any(T.text, Q, T.index);
    if N /= T.index then
    N := 0;
    end if;
    SP.Release;
    return N /= 0;

end Is_Any;

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

procedure Scan_Any(
    T      : in     Scanner;
    Q      : in     STRING;
    Found  :    out BOOLEAN;
    Result : in out SP.String_Type
    ) is

    S_Str : SP.String_Type;
    N     : NATURAL;

begin

    if Is_Any(T, Q) then
    N := SP.Match_None(T.text, Q, T.index);
    if N = 0 then
        N := SP.Length(T.text) + 1;
    end if;
    Result  := SP."&"(Result, SP.Substr(T.text, T.index, N - T.index));
    T.index := N;
    Found   := TRUE;
    else
    Found := FALSE;
    end if;

end Scan_Any;

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

function Quoted_String(
    T : in Scanner
    ) return INTEGER is

    Count : INTEGER := 0;
    I     : POSITIVE;
    N     : NATURAL;

begin

    if not More(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;
    SP.Mark;
    N := SP.Match_Any(T.text, """", T.index);
    SP.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;

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

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;
    T.index := T.index + 1;
    while Depth /= 0 loop
    if not More(T) then
        T.index := I;
        return 0;
    end if;
    SP.Mark;
    Inx_B   := SP.Match_Any(T.text, B & "", T.index);
    Inx_E   := SP.Match_Any(T.text, E & "", T.index);
    SP.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;

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

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;

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

function Is_Number(
    T : in Scanner
    ) return BOOLEAN is

begin

    return Is_Any(T, Number);

end Is_Number;

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

function Get_Number(
    T      : in     Scanner
    ) return STRING is

    C     : CHARACTER;
    F     : BOOLEAN;
    S_Str : SP.String_Type;

begin

    SP.Mark;
    while Is_Number(T) loop
    Scan_Any(T, Number, F, S_Str);
    if More(T) then
        C := Get(T);
        if C = '_' then
        T.index := T.index + 1;
        if Is_Number(T) then
            S_Str := SP."&"(S_Str, "_");
        else
            T.index := T.index - 1;
        end if;
        end if;
    end if;
    end loop;
    declare
    S : STRING (1 .. SP.Length(S_Str));
    begin
    S := SP.Value(S_Str);
    SP.Release;
    return S;
    end;

end Get_Number;

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

procedure Scan_Number(
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out INTEGER;
    Skip   : in     BOOLEAN := FALSE
    ) is

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Number(T) then
    begin
        Mark(T);
        Result := INTEGER'Value(Get_Number(T));
        Unmark(T);
    exception
        when CONSTRAINT_ERROR =>
        Restore(T);
        raise Number_Too_Large;
    end;
    Found := TRUE;
    else
    Found := FALSE;
    end if;

end Scan_Number;

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

function Is_Signed_Number(
    T : in Scanner
    ) return BOOLEAN is

    I : POSITIVE;
    C : CHARACTER;
    F : BOOLEAN;

begin

    if not More(T) then
    return FALSE;
    end if;
    I := T.index;
    C := Get(T);
    if C = '+' or C = '-' then
    T.index := T.index + 1;
    end if;
    F := Is_Any(T, Number);
    T.index := I;
    return F;

end Is_Signed_Number;

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

function Get_Signed_Number(
    T      : in     Scanner
    ) return STRING is

    C     : CHARACTER;

begin

    C := Get(T);
    if C = '+' or C = '-' then
    T.index := T.index + 1;
    return C & Get_Number(T);
    else
    return Get_Number(T);
    end if;

end Get_Signed_Number;

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

procedure Scan_Signed_Number(
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out INTEGER;
    Skip   : in     BOOLEAN := FALSE
    ) is

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Signed_Number(T) then
    begin
        Mark(T);
        Result := INTEGER'Value(Get_Signed_Number(T));
        Unmark(T);
    exception
        when CONSTRAINT_ERROR =>
        Restore(T);
        raise Number_Too_Large;
    end;
    Found := TRUE;
    else
    Found := FALSE;
    end if;

end Scan_Signed_Number;

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

function Is_Space(
    T : in Scanner
    ) return BOOLEAN is

begin

    return Is_Any(T, White_Space);

end Is_Space;

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

procedure Skip_Space(
    T : in Scanner
    ) is

    S_Str : SP.String_Type;
    Found : BOOLEAN;

begin

    SP.Mark;
    Scan_Any(T, White_Space, Found, S_Str);
    SP.Release;

end Skip_Space;

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

function Is_Ada_Id(
    T : in Scanner
    ) return BOOLEAN is

begin

    return Is_Any(T, Alphabetic);

end Is_Ada_Id;

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

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;

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

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;

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

function Is_Sequence(
    Chars  : in STRING;
    T      : in Scanner
    ) return BOOLEAN is

begin

    return Is_Any(T, Chars);

end Is_Sequence;

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

function Is_Not_Sequence(
    Chars  : in STRING;
    T      : in Scanner
    ) return BOOLEAN is

    N : NATURAL;

begin

    if not More(T) then
    return FALSE;
    end if;
    SP.Mark;
    N := SP.Match_Any(T.text, Chars, T.index);
    if N = T.index then
    N := 0;
    end if;
    SP.Release;
    return N /= 0;

end Is_Not_Sequence;

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

function Is_Literal(
    Chars  : in STRING;
    T      : in Scanner
    ) return BOOLEAN is

    N : NATURAL;

begin

    if not More(T) then
    return FALSE;
    end if;
    N := SP.Match_S(T.text, Chars, T.index);
    if N /= T.index then
    N := 0;
    end if;
    return N /= 0;

end Is_Literal;

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

function Is_Not_Literal(
    Chars : in STRING;
    T     : in Scanner
    ) return BOOLEAN is

    N     : NATURAL;

begin

    if not More(T) then
    return FALSE;
    end if;
    SP.Mark;
    N := SP.Match_S(T.text, Chars, T.index);
    if N = T.index then
    N := 0;
    end if;
    SP.Release;
    return N /= 0;

end Is_Not_Literal;

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

function Match_Character(
    T    : in CHARACTER;
    Char : in STRING
    ) return BOOLEAN is

begin

    for j in Char'range loop
    if T = Char(j) then
        return TRUE;
    end if;
    end loop;
    return FALSE;

end Match_Character;

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

function Strip_Leading(
    Text : in STRING;
    Char : in STRING := " " & ASCII.HT
    ) return STRING is

begin

    for i in Text'range loop
    if not Match_Character(Text(i), Char) then
        return Text(i .. Text'last);
    end if;
    end loop;
    return "";

end Strip_Leading;

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

function Strip_Trailing(
    Text : in STRING;
    Char : in STRING := " " & ASCII.HT
    ) return STRING is

begin

    for i in reverse Text'range loop
    if not Match_Character(Text(i), Char) then
        return Text(Text'first .. i);
    end if;
    end loop;
    return "";

end Strip_Trailing;

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

function Strip(
    Text : in STRING;
    Char : in STRING := " " & ASCII.HT
    ) return STRING is

begin

    return Strip_Leading(STRING'(Strip_Trailing(Text, Char)), Char);

end Strip;

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

function Justify_String(
    Text : in STRING;
    Len  : in POSITIVE;
    Char : in CHARACTER;
    Mode : in Justification_Mode
    ) return STRING is

    Out_String  : STRING (1 .. Len) := (others => Char);
    Temp_String : SP.String_Type;
    Index       : INTEGER;

begin

    SP.Mark;
    Temp_String := SP.Create(Out_String & Text & Out_String);
    case Mode is
    when LEFT =>
        Index := Len + 1;
    when RIGHT =>
        Index := SP.Length(Temp_String) - Len*2 + 1;
    when CENTER =>
        Index := (SP.Length(Temp_String) - Len)/2 + 2;
    when others =>
        Index := Len + 1;
    end case;
    Out_String := SP.Value(SP.Substr(Temp_String, Index, Len));
    SP.Release;
    return Out_String;

end Justify_String;

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

function Left_Justify(
    Text : in STRING;
    Len  : in POSITIVE;
    Char : in CHARACTER := ' '
    ) return STRING is

begin

    return Justify_String(Text, Len, Char, LEFT);

end Left_Justify;

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

function Right_Justify(
    Text : in STRING;
    Len  : in POSITIVE;
    Char : in CHARACTER := ' '
    ) return STRING is

begin

    return Justify_String(Text, Len, Char, RIGHT);

end Right_Justify;

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

function Center(
    Text : in STRING;
    Len  : in POSITIVE;
    Char : in CHARACTER := ' '
    ) return STRING is

begin

    return Justify_String(Text, Len, Char, CENTER);

end Center;

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

function Expand(
    Text : in STRING;
    Len  : in POSITIVE
    ) return STRING is

    Out_String : STRING (1 .. Len);
    Count      : INTEGER := 0;
    Size       : INTEGER;
    Inx1, Inx2 : INTEGER;
    S_Str      : SP.String_Type;

begin

    if Len <= Text'length then
    return Justify_String(Text, Len, ' ', LEFT);
    end if;
    for i in Text'range loop
    if Text(i) = ' ' then
        Count := Count + 1;
    end if;
    end loop;
    if Count = 0 then
    return Justify_String(Text, Len, ' ', LEFT);
    end if;
    SP.Mark;
    S_Str := SP.Create(Text);
    Size := (Len - Text'length)/ Count;
    Inx1 := Count/2 - ((Len - Text'length) rem Count)/2 + 1;
    Inx2 := Inx1 + ((Len - Text'length) rem Count) - 1;
    declare
    Fill : STRING(1 .. Size) := (others => ' ');
    begin
    for i in reverse 1 .. SP.Length(S_Str) loop
        if SP.Fetch(S_Str, i) = ' ' then
        S_Str := SP.Insert(S_Str, Fill, i);
        if Inx1 <= Count and Count <= Inx2 then
            S_Str := SP.Insert(S_Str, " ", i);
        end if;
        Count := Count - 1;
        end if;
    end loop;
    end;
    Out_String := SP.Value(S_Str);
    SP.Release;
    return Out_String;

end Expand;

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

function Format(
    Text    : in STRING;
    Len     : in POSITIVE;
    Del     : in CHARACTER := ' ';
    Justify : in Justification_Mode := NONE
    ) return SL.List is

    Out_String  : STRING(1 .. Len);
    Temp_String : SP.String_Type;
    S_Str       : SP.String_Type;
    Out_List    : SL.List := SL.Create;
    Index1      : INTEGER;
    Index2      : INTEGER;

begin

    SP.Mark;
    Temp_String := SP.Create(Text);
    while SP.Length(Temp_String) > 0 loop
    if SP.Length(Temp_String) > Len then
        Index1 := Len;
        Index2 := Index1;
        if Del /= ASCII.NUL then
        for i in reverse 2 .. Index1 + 1 loop
            if SP.Fetch(Temp_String, i) = Del then
            Index1 := i - 1;
            Index2 := i;
            exit;
            end if;
        end loop;
        end if;
    else
        Index1 := SP.Length(Temp_String);
        Index2 := Index1;
    end if;
    S_Str := SP.Substr(Temp_String, 1, Index1);
    Temp_String := SP.Substr(Temp_String, Index2 + 1, SP.Length(Temp_String) - Index2);
    case Justify is
        when LEFT | NONE =>
        SL.Attach(Out_List, SP.Make_Persistent(
            STRING'(Justify_String(SP.Value(S_Str), Len, ' ', LEFT))));
        when RIGHT =>
        SL.Attach(Out_List, SP.Make_Persistent(
            STRING'(Justify_String(SP.Value(S_Str), Len, ' ', RIGHT))));
        when CENTER =>
        SL.Attach(Out_List, SP.Make_Persistent(
            STRING'(Justify_String(SP.Value(S_Str), Len, ' ', CENTER))));
        when EXPAND =>
        if SP.Length(Temp_String) > 0 then
            SL.Attach(Out_List, SP.Make_Persistent(
            STRING'(Expand(SP.Value(S_Str), Len))));
        else
            SL.Attach(Out_List, SP.Make_Persistent(
            STRING'(Justify_String(SP.Value(S_Str), Len, ' ', LEFT))));
        end if;
    end case;
    end loop;
    SP.Release;
    return Out_List;

end Format;

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

function Image(
    Num  : in INTEGER;
    Len  : in NATURAL   := 0;
    Fill : in CHARACTER := ' '
    ) return STRING is

    S_Str  : SP.String_Type;
    Places : INTEGER := Len;
    Size   : INTEGER;

begin

    SP.Mark;
    S_Str := SP.Create(INTEGER'image(Num));
    if SP.Fetch(S_Str, 1) = ' ' then
    S_Str := SP.Substr(S_Str, 2, SP.Length(S_Str) - 1);
    end if;
    Size   := SP.Length(S_Str);
    if Len = 0 then
    Places := Size;
    end if;
    declare
    Temp_Text : STRING (1 .. Places);
    begin
    for i in 1 .. Places - Size loop
        Temp_Text(i) := Fill;
    end loop;
    Temp_Text(Places - Size + 1 .. Temp_Text'last) := SP.Value(S_Str);
    SP.Release;
    return Temp_Text;
    end;
    return "";

end Image;

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

function Value(
    Text : in STRING
    ) return INTEGER is

    Found      : BOOLEAN;
    Underscore : BOOLEAN := TRUE;

begin

    return INTEGER'Value(Text);

exception
    when CONSTRAINT_ERROR =>
    for i in Text'range loop
        Found := FALSE;
        for j in Number'range loop
        if Text(i) = Number(j) then
            Underscore := FALSE;
            Found := TRUE;
            exit;
        end if;
        end loop;
        if not Found then
        if Text(i) /= '_' then
            raise Non_Numeric_String;
        elsif Underscore then
            raise Non_Numeric_String;
        else
            Underscore := TRUE;
        end if;
        end if;
    end loop;
    raise Number_Too_Large;

end Value;

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

function Match(
    Pattern    : in STRING;
    Target     : in STRING;
    Wildcard   : in CHARACTER := '*';
    Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
    ) return BOOLEAN is

    type State_Type is (NONE, TEXT, WILD);

    List     : SL.List := SL.Create;
    Iterator : SL.ListIter;
    Inx      : INTEGER;
    R_Str    : SP.String_Type;
    S_Str    : SP.String_Type;
    Found    : BOOLEAN;
    Previous : State_Type;
    Current  : State_Type;
    Old_Opt  : SP.Comparison_Option;

begin

    Inx := Pattern'first;
    SP.Mark;
    for i in Pattern'range loop
    if Pattern(i) = Wildcard then
        if i > Inx then
        SL.Attach(List, SP.Create(Pattern(Inx .. i - 1)));
        end if;
        SL.Attach(List, SP.Create("" & Wildcard));
        Inx := i + 1;
    end if;
    end loop;
    if Inx <= Pattern'last then
    SL.Attach(List, SP.Create(Pattern(Inx .. Pattern'last)));
    end if;

    Iterator := SL.MakeListIter(List);
    Found := SL.More(Iterator);
    Current := NONE;
    Inx := Target'first;
    Old_Opt := SP.Get_Comparison_Option;
    SP.Set_Comparison_Option(Comparison);
    while SL.More(Iterator) loop
    SL.Next(Iterator, S_Str);
    Previous := Current;
    if SP.Equal(S_Str, "" & Wildcard) then
        Current := WILD;
    else
        Current := TEXT;
    end if;
    if Current = TEXT then
        Found := FALSE;
        SP.Mark;
        if Previous = NONE and then
           Target'length >= Inx + SP.Length(S_Str) - 1 and then
           SP.Equal(S_Str, SP.Create(Target(Inx .. Inx + SP.Length(S_Str) - 1))) then
        Inx   := Inx + SP.Length(S_Str);
        Found := TRUE;
        elsif Previous = WILD then
        for i in Inx .. Target'last - SP.Length(S_Str) + 1 loop
            SP.Mark;
            if SP.Equal(S_Str, SP.Create(Target(i .. i + SP.Length(S_Str) - 1))) then
            Inx   := i + SP.Length(S_Str);
            Found := TRUE;
            end if;
            SP.Release;
        end loop;
        end if;
        SP.Release;
    end if;
    exit when not Found;
    end loop;
    if Current = TEXT then
    Found := Inx >= Target'length;
    end if;
    SP.Release;
    SL.Destroy(List);
    SP.Set_Comparison_Option(Old_Opt);
    return Found;

end Match;

----------------------------------------------------------------
                                                                    pragma page;
package body Generic_String_Utilities is

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

function Make_Scanner(
    S : in Generic_String_Type
    ) return Scanner is

begin

    return Make_Scanner(From_Generic(S));

end Make_Scanner;

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

function Get_String(
    T    : in Scanner
    ) return Generic_String_Type is

begin

    if Is_Valid(T) then
    return To_Generic(SP.Value(T.text));
    else
    return To_Generic("");
    end if;

end Get_String;

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

function Get_Remainder(
    T : in Scanner
    ) return Generic_String_Type is

    S_Str : SP.String_Type;
    G_Str : Generic_String_Type;

begin

    if More(T) then
    SP.Mark;
    S_Str := SP.Substr(T.text, T.index, SP.Length(T.text) - T.index + 1);
    declare
        S : STRING (1 .. SP.Length(S_Str));
    begin
        S := SP.Value(S_Str);
        SP.Release;
        return To_Generic(S);
    end;
    else
    return To_Generic("");
    end if;

end Get_Remainder;

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

function Get_Segment(
    T    : in Scanner;
    From : in POSITIVE;
    To   : in POSITIVE
    ) return Generic_String_Type is

begin

    if Is_Valid(T) and then
       From < To and then
       To <= SP.Length(T.text) then
    return To_Generic(SP.Value(T.text)(From .. To - 1));
    else
    return To_Generic("");
    end if;


end Get_Segment;

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

procedure Scan_Word(
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out Generic_String_Type;
    Skip   : in     BOOLEAN := FALSE
    ) is

    S_Str : SP.String_Type;
    N     : NATURAL;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Word(T) then
    Found   := TRUE;
    SP.Mark;
    N := SP.Match_Any(T.text, White_Space, T.index);
    if N = 0 then
        N := SP.Length(T.text) + 1;
    end if;
    S_Str := SP.Substr(T.text, T.index, N - T.index);
    T.index := N;
    declare
        S : STRING (1 .. SP.Length(S_Str));
    begin
        S := SP.Value(S_Str);
        SP.Release;
        Result  := To_Generic(S);
    end;
    else
    Found   := FALSE;
    end if;

end Scan_Word;

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

procedure Scan_Number(
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out Generic_String_Type;
    Skip   : in     BOOLEAN := FALSE
    ) is

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Number(T) then
    Found := TRUE;
    Result := To_Generic(Get_Number(T));
    else
    Found := FALSE;
    end if;

end Scan_Number;

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

procedure Scan_Signed_Number(
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out Generic_String_Type;
    Skip   : in     BOOLEAN := FALSE
    ) is

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Signed_Number(T) then
    Found := TRUE;
    Result := To_Generic(Get_Signed_Number(T));
    else
    Found := FALSE;
    end if;

end Scan_Signed_Number;

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

procedure Scan_Space(
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out Generic_String_Type
    ) is

    S_Str : SP.String_Type;

begin

    if Is_Any(T, White_Space) then
    SP.Mark;
    Scan_Any(T, White_Space, Found, S_Str);
    declare
        S : STRING (1 .. SP.Length(S_Str));
    begin
        S := SP.Value(S_Str);
        SP.Release;
        Result := To_Generic(S);
    end;
    else
    Found := FALSE;
    end if;

end Scan_Space;

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

procedure Scan_Ada_Id(
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out Generic_String_Type;
    Skip   : in     BOOLEAN := FALSE
    ) is

    S_Str : SP.String_Type;
    Num   : NATURAL;
    Mark  : POSITIVE;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Ada_Id(T) then
    SP.Mark;
    Mark := T.index;
    Scan_Any(T, Alphabetic & Number & '_', Found, S_Str);
    Num := SP.Match_S(S_Str, "__");
    if Num /= 0 then
        S_Str := SP.Substr(S_Str, 1, Num -1);
        Mark := Mark + Num - 1;
    else
        Num := SP.Length(S_Str);
        if SP.Fetch(S_Str, Num) = '_' then
        S_Str := SP.Substr(S_Str, 1, Num - 1);
        Mark := Mark + Num - 1;
        else
        Mark := Mark + Num;
        end if;
    end if;
    T.index := Mark;
    declare
        S : STRING (1 .. SP.Length(S_Str));
    begin
        S := SP.Value(S_Str);
        SP.Release;
        Result := To_Generic(S);
    end;
    else
    Found := FALSE;
    end if;

end Scan_Ada_Id;

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

procedure Scan_Quoted(
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out Generic_String_Type;
    Skip   : in     BOOLEAN := FALSE
    ) is

    S_Str : SP.String_Type;
    Count : INTEGER;

begin

    if Skip then
    Skip_Space(T);
    end if;
    Count := Quoted_String(T);
    if Count /= 0 then
    Found := TRUE;
    Count := Count - 2;
    T.index := T.index + 1;
    if Count /= 0 then
        SP.Mark;
        S_Str := SP.Substr(T.text, T.index, POSITIVE(Count));
        declare
        S : STRING (1 .. SP.Length(S_Str));
        begin
        S := SP.Value(S_Str);
        SP.Release;
        Result := To_Generic(S);
        end;
    else
        Result := To_Generic("");
    end if;
    T.index := T.index + Count + 1;
    else
    Found := FALSE;
    end if;

end Scan_Quoted;

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

procedure Scan_Enclosed(
    B      : in     CHARACTER;
    E      : in     CHARACTER;
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out Generic_String_Type;
    Skip   : in     BOOLEAN := FALSE
    ) is

    S_Str : SP.String_Type;
    Count : NATURAL;

begin

    if Skip then
    Skip_Space(T);
    end if;
    Count := Enclosed_String(B, E, T);
    if Count /= 0 then
    Found := TRUE;
    Count := Count - 2;
    T.index := T.index + 1;
    if Count /= 0 then
        SP.Mark;
        S_Str := SP.Substr(T.text, T.index, POSITIVE(Count));
        declare
        S : STRING (1 .. SP.Length(S_Str));
        begin
        S := SP.Value(S_Str);
        SP.Release;
        Result := To_Generic(S);
        end;
    else
        Result := To_Generic("");
    end if;
    T.index := T.index + Count + 1;
    else
    Found := FALSE;
    end if;

end Scan_Enclosed;

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

function Is_Sequence(
    Chars  : in Generic_String_Type;
    T      : in Scanner
    ) return BOOLEAN is

begin

    return Is_Any(T, From_Generic(Chars));

end Is_Sequence;

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

procedure Scan_Sequence(
    Chars  : in     Generic_String_Type;
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out Generic_String_Type;
    Skip   : in     BOOLEAN := FALSE
    ) is

begin

    Scan_Sequence(From_Generic(Chars), T, Found, Result, Skip);

end Scan_Sequence;

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

procedure Scan_Sequence(
    Chars  : in     STRING;
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out Generic_String_Type;
    Skip   : in     BOOLEAN := FALSE
    ) is

    I     : POSITIVE;
    Count : INTEGER := 0;
    S_Str : SP.String_Type;

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, Chars) loop
    T.index := T.index + 1;
    Count := Count + 1;
    end loop;
    if Count /= 0 then
    Found  := TRUE;
    SP.Mark;
    S_Str := SP.Substr(T.text, I, POSITIVE(Count));
    declare
        S : STRING (1 .. SP.Length(S_Str));
    begin
        S := SP.Value(S_Str);
        SP.Release;
        Result := To_Generic(S);
    end;
    else
    Found := FALSE;
    end if;

end Scan_Sequence;

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

function Is_Not_Sequence(
    Chars  : in Generic_String_Type;
    T      : in Scanner
    ) return BOOLEAN is

begin

    return Is_Not_Sequence(From_Generic(Chars), T);

end Is_Not_Sequence;

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

procedure Scan_Not_Sequence(
    Chars  : in     STRING;
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out Generic_String_Type;
    Skip   : in     BOOLEAN := FALSE
    ) is

    S_Str : SP.String_Type;
    N     : NATURAL;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Not_Sequence(Chars, T) then
    Found   := TRUE;
    SP.Mark;
    N := SP.Match_Any(T.text, Chars, T.index);
    S_Str := SP.Substr(T.text, T.index, N - T.index);
    T.index := N;
    declare
        S : STRING (1 .. SP.Length(S_Str));
    begin
        S := SP.Value(S_Str);
        SP.Release;
        Result := To_Generic(S);
    end;
    else
    Found := FALSE;
    end if;

end Scan_Not_Sequence;

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

procedure Scan_Not_Sequence(
    Chars  : in     Generic_String_Type;
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out Generic_String_Type;
    Skip   : in     BOOLEAN := FALSE
    ) is

begin

    Scan_Not_Sequence(From_Generic(Chars), T, Found, Result, Skip);

end Scan_Not_Sequence;

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

function Is_Literal(
    Chars  : in Generic_String_Type;
    T      : in Scanner
    ) return BOOLEAN is

begin

    return Is_Literal(From_Generic(Chars), T);

end Is_Literal;

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

procedure Scan_Literal(
    Chars  : in     STRING;
    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 + Chars'length;
    Found   := TRUE;
    else
    Found   := FALSE;
    end if;

end Scan_Literal;

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

procedure Scan_Literal(
    Chars  : in     Generic_String_Type;
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Skip   : in     BOOLEAN := FALSE
    ) is

    F : BOOLEAN;

begin

    Scan_Literal(From_Generic(Chars), T, Found, Skip);

end Scan_Literal;

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

function Is_Not_Literal(
    Chars : in Generic_String_Type;
    T     : in Scanner
    ) return BOOLEAN is

begin

    return Is_Not_Literal(From_Generic(Chars), T);

end Is_Not_Literal;

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

procedure Scan_Not_Literal(
    Chars  : in     STRING;
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out Generic_String_Type;
    Skip   : in     BOOLEAN := FALSE
    ) is

    S_Str : SP.String_Type;
    N     : NATURAL;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Not_Literal(Chars, T) then
    Found   := TRUE;
    SP.Mark;
    N := SP.Match_S(T.text, Chars, T.index);
    S_Str := SP.Substr(T.text, T.index, N - T.index);
    T.index := N;
    declare
        S : STRING (1 .. SP.Length(S_Str));
    begin
        S := SP.Value(S_Str);
        SP.Release;
        Result := To_Generic(S);
    end;
    else
    Found := FALSE;
    end if;

end Scan_Not_Literal;

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

procedure Scan_Not_Literal(
    Chars  : in     Generic_String_Type;
    T      : in     Scanner;
    Found  :    out BOOLEAN;
    Result :    out Generic_String_Type;
    Skip   : in     BOOLEAN := FALSE
    ) is

begin

    Scan_Not_Literal(From_Generic(Chars), T, Found, Result, Skip);

end Scan_Not_Literal;

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

function Strip_Leading(
    Text : in Generic_String_Type;
    Char : in STRING := " " & ASCII.HT
    ) return STRING is

begin

    return Strip_Leading(From_Generic(Text), Char);

end Strip_Leading;

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

function Strip_Leading(
    Text : in STRING;
    Char : in STRING := " " & ASCII.HT
    ) return Generic_String_Type is

begin

    return To_Generic(STRING'(Strip_Leading(Text, Char)));

end Strip_Leading;

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

function Strip_Leading(
    Text : in Generic_String_Type;
    Char : in STRING := " " & ASCII.HT
    ) return Generic_String_Type is

    G_Str : Generic_String_Type;

begin

    return To_Generic(STRING'(Strip_Leading(From_Generic(Text), Char)));

end Strip_Leading;

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

function Strip_Trailing(
    Text : in Generic_String_Type;
    Char : in STRING := " " & ASCII.HT
    ) return STRING is

begin

    return Strip_Trailing(From_Generic(Text), Char);

end Strip_Trailing;

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

function Strip_Trailing(
    Text : in STRING;
    Char : in STRING := " " & ASCII.HT
    ) return Generic_String_Type is

begin

    return To_Generic(STRING'(Strip_Trailing(Text, Char)));

end Strip_Trailing;

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

function Strip_Trailing(
    Text : in Generic_String_Type;
    Char : in STRING := " " & ASCII.HT
    ) return Generic_String_Type is

begin

    return To_Generic(STRING'(Strip_Trailing(From_Generic(Text), Char)));

end Strip_Trailing;

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

function Strip(
    Text : in Generic_String_Type;
    Char : in STRING := " " & ASCII.HT
    ) return STRING is

begin

    return Strip_Leading(STRING'(Strip_Trailing(From_Generic(Text), Char)), Char);

end Strip;

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

function Strip(
    Text : in STRING;
    Char : in STRING := " " & ASCII.HT
    ) return Generic_String_Type is

begin

    return To_Generic(STRING'(Strip_Leading(STRING'(Strip_Trailing(Text, Char)), Char)));

end Strip;

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

function Strip(
    Text : in Generic_String_Type;
    Char : in STRING := " " & ASCII.HT
    ) return Generic_String_Type is

begin

    return To_Generic(STRING'(Strip_Leading(STRING'(Strip_Trailing(From_Generic(Text), Char)), Char)));

end Strip;

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

function Left_Justify(
    Text : in Generic_String_Type;
    Len  : in POSITIVE;
    Char : in CHARACTER := ' '
    ) return STRING is

begin

    return Justify_String(From_Generic(Text), Len, Char, LEFT);

end Left_Justify;

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

function Left_Justify(
    Text : in STRING;
    Len  : in POSITIVE;
    Char : in CHARACTER := ' '
    ) return Generic_String_Type is

begin

    return To_Generic(Justify_String(Text, Len, Char, LEFT));

end Left_Justify;

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

function Left_Justify(
    Text : in Generic_String_Type;
    Len  : in POSITIVE;
    Char : in CHARACTER := ' '
    ) return Generic_String_Type is

begin

    return To_Generic(Justify_String(From_Generic(Text), Len, Char, LEFT));

end Left_Justify;

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

function Right_Justify(
    Text : in Generic_String_Type;
    Len  : in POSITIVE;
    Char : in CHARACTER := ' '
    ) return STRING is

begin

    return Justify_String(From_Generic(Text), Len, Char, RIGHT);

end Right_Justify;

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

function Right_Justify(
    Text : in STRING;
    Len  : in POSITIVE;
    Char : in CHARACTER := ' '
    ) return Generic_String_Type is

begin

    return To_Generic(Justify_String(Text, Len, Char, RIGHT));

end Right_Justify;

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

function Right_Justify(
    Text : in Generic_String_Type;
    Len  : in POSITIVE;
    Char : in CHARACTER := ' '
    ) return Generic_String_Type is

begin

    return To_Generic(Justify_String(From_Generic(Text), Len, Char, RIGHT));

end Right_Justify;

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

function Center(
    Text : in Generic_String_Type;
    Len  : in POSITIVE;
    Char : in CHARACTER := ' '
    ) return STRING is

begin

    return Justify_String(From_Generic(Text), Len, Char, CENTER);

end Center;

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

function Center(
    Text : in STRING;
    Len  : in POSITIVE;
    Char : in CHARACTER := ' '
    ) return Generic_String_Type is

begin

    return To_Generic(Justify_String(Text, Len, Char, CENTER));

end Center;

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

function Center(
    Text : in Generic_String_Type;
    Len  : in POSITIVE;
    Char : in CHARACTER := ' '
    ) return Generic_String_Type is

begin

    return To_Generic(Justify_String(From_Generic(Text), Len, Char, CENTER));

end Center;

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

function Expand(
    Text : in Generic_String_Type;
    Len  : in POSITIVE
    ) return STRING is

begin

    return Expand(From_Generic(Text), Len);

end Expand;

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

function Expand(
    Text : in STRING;
    Len  : in POSITIVE
    ) return Generic_String_Type is

begin

    return To_Generic(Expand(Text, Len));

end Expand;

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

function Expand(
    Text : in Generic_String_Type;
    Len  : in POSITIVE
    ) return Generic_String_Type is

begin

    return To_Generic(Expand(From_Generic(Text), Len));

end Expand;

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

function Format(
    Text    : in Generic_String_Type;
    Len     : in POSITIVE;
    Del     : in CHARACTER := ' ';
    Justify : in Justification_Mode := NONE
    ) return SL.List is

begin

    return Format(From_Generic(Text), Len, Del, Justify);

end Format;

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

function Image(
    Num  : in INTEGER;
    Len  : in NATURAL   := 0;
    Fill : in CHARACTER := ' '
    ) return Generic_String_Type is

begin

    return To_Generic(STRING'(Image(Num, Len, Fill)));

end Image;

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

function Value(
    Text : in Generic_String_Type
    ) return INTEGER is

begin

    return Value(STRING'(From_Generic(Text)));

end Value;

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

function Match(
    Pattern    : in Generic_String_Type;
    Target     : in STRING;
    Wildcard   : in CHARACTER := '*';
    Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
    ) return BOOLEAN is

begin

    return Match(From_Generic(Pattern),
         Target,
         Wildcard,
         Comparison);

end Match;

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

function Match(
    Pattern    : in STRING;
    Target     : in Generic_String_Type;
    Wildcard   : in CHARACTER := '*';
    Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
    ) return BOOLEAN is

begin

    return Match(Pattern,
         From_Generic(Target),
         Wildcard,
         Comparison);

end Match;

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

function Match(
    Pattern    : in Generic_String_Type;
    Target     : in Generic_String_Type;
    Wildcard   : in CHARACTER := '*';
    Comparison : in SP.Comparison_Option := SP.CASE_SENSITIVE
    ) return BOOLEAN is

begin

    return Match(From_Generic(Pattern),
         From_Generic(Target),
         Wildcard,
         Comparison);

end Match;

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


end Generic_String_Utilities;

end String_Utilities;
                                                                    pragma page;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--HOSTLIB.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

package Host_Lib is

--| Host dependent subprograms

--| Overview
--| This package provides a common interface to the user for functions whose
--| implementations are host dependent.
--|-
--| Set_Error              Directs default output to appropriate error output
--| Reset_Error            Resets above
--| Put_Error              Writes an error message to appropriate error output
--| Return_Code            Sets return code
--| Invoke                 Runs a program
--| Get_Item               Returns specified item from the system
--| Read_No_Echo           Returns keyboard without echoing
--| Protection             Returns protection setting string
--| Get_Time               Obtains current date/time
--| Date                   Returns current date (MM/DD/YY)
--| Calendar_Date          Returns current date (eg. March 15, 1985)
--| Time                   Returns current time (HH:MM:SS)
--| Get_Terminal_Type      Returns attached terminal type
--| Enable_Interrupt_Trap  Enables trapping of interrupt from the keyboard
--| Disable_Interrupt_Trap Disables interrupt trapping
--| Ignore_Interrupts      Ignore interrupts from the keyboard
--| Interrupts_Ignored     Returns TRUE iff interrupt was ignored
--| Set_Interrupt_State    Sets the interrupt trapping state
--| Get_Interrupt_State    Returns the interrupt trapping state
--|+

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

Uninitialized_Time_Value : exception;    --| Raised when time value not set
Terminal_Not_Attached    : exception;    --| Raised when no terminal attached
Unknown_Terminal_Type    : exception;    --| Raised when terminal unknown
Interrupt_Encountered    : exception;   --| Raised when Trap_Interrupts has
                                        --| been called and an interrupt was
                                        --| encountered.

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

type Severity_Code is (            --| Systen independent error indication
    SUCCESS, INFORMATION, WARNING, ERROR, SEVERE
    );

type Item_Type is (            --| Items to be obtained from system
    ARGUMENTS, USER_NAME, ACCOUNT, PROGRAM_NAME, PROCESS_MODE,
    PROCESS_ID, TERMINAL_ADDRESS, DEVICE_TYPE
    );

type Time_Value is limited private;    --| Current date/time marker

type Format is (RAW, EDIT);        --| Return value format

type Permission is (YES, NO);        --| Protection status

type Protection_Category is (READ, WRITE, EXECUTE, DELETE);

type Protection_Specification is array (Protection_Category) of Permission;

type Terminal_Type is (            --| Known terminal types
    VT05,
    VK100,
    VT173,
    TQ_BTS,
    TEK401X,
    FOREIGN_TERMINAL_1,
    FOREIGN_TERMINAL_2,
    FOREIGN_TERMINAL_3,
    FOREIGN_TERMINAL_4,
    FOREIGN_TERMINAL_5,
    FOREIGN_TERMINAL_6,
    FOREIGN_TERMINAL_7,
    FOREIGN_TERMINAL_8,
    LA36,
    LA120,
    LA34,
    LA38,
    LA12,
    LA24,
    LQP02,
    LA84,
    VT52,
    VT55,
    DZ11,
    DZ32,
    DZ730,
    DMZ32,
    DHV,
    DHU,
    VT100,
    VT101,
    VT102,
    VT105,
    VT125,
    VT131,
    VT132,
    VT200_SERIES,
    PRO_SERIES,
        WORKSTATION,        -- Workstations
    VS100,
    VS125,
    VS300,
    VIRTUAL_DEVICE);

type Interrupt_State is (ENABLED, DISABLED, IGNORED);

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

Max_Arg_Length : constant POSITIVE := 255;
                    --| Maximum chars per line

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

procedure Set_Error;            --| Direct error output

--| Effects: Set the default output to an error output stream so that all
--| subsequent outputs without file_type specification is directed to the
--| error output.
--| N/A: Raises, Modifies, Errors

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

procedure Reset_Error;            --| Resets the defualt output

--| Effects: Reset the default output to standard output.  (Used in conjunction
--| with Set_Error.
--| N/A: Raises, Modifies, Errors

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

procedure Put_Error(            --| Write a error message
    Message : in STRING            --| Message to be written
    );

--| Effects: Writes the error message to the error output.  The message is
--| prepended with an appropriate error message indication.
--| N/A: Raises, Modifies, Errors

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

function Return_Code(            --| Set return code
    Severity : in Severity_Code        --| Return code to be set
    ) return INTEGER;

--| Effects: Sets a system dependent return value based on the given return
--| indication.
--| N/A: Raises, Modifies, Errors

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

procedure Invoke(            --| Invoke a program
    Process  : in     STRING;        --| Name and arugment(s) of the program
    Severity :    out Severity_Code    --| Systen independent error indication
    );

--| Effects: Runs the specified program with the given arguments.
--| N/A: Raises, Modifies, Errors

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

function Get_Item(            --| Get specified item from system
    Item : in Item_Type;        --| Item to be obtained
    Form : in Format := EDIT        --| Format the result
    ) return STRING;

--| Raises : Terminal_Not_Attached, Unknown_Terminal_Type
--| Effects: Obtains the specified item from the system.
--| N/A: Modifies, Errors

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

function Read_No_Echo(            --| Read a string from keyboard
    Address : in STRING := Get_Item(TERMINAL_ADDRESS)
                    --| Terminal address
    ) return STRING;

--| Effects: Reads characters entered from the keyboard without echoing.
--| N/A: Raises, Modifies, Errors

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

function Protection(            --| Read a string from keyboard
    System : in Protection_Specification :=
        (Read=>YES, Write=>YES, Execute=>YES, Delete=>YES);
                    --| Protection for system
    Owner  : in Protection_Specification :=
        (Read=>YES, Write=>YES, Execute=>YES, Delete=>YES);
                    --| Protection for owner
    Group  : in Protection_Specification :=
        (Read=>YES, Write=>YES, Execute=>YES, Delete=>YES);
                    --| Protection for group
    World  : in Protection_Specification :=
        (Read=>YES, Write=>YES, Execute=>YES, Delete=>YES)
                    --| Protection for world
    ) return STRING;

--| Effects: Returns a string to be used in the FORM arugment of standard
--| I/O package Open/Create subprograms.
--| N/A: Raises, Modifies, Errors

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

procedure Get_Time(            --| Get date/time
    Value : out Time_Value        --| Time value to be returned
    );

--| Effects: Obaints current date/time.
--| N/A: Raises, Modifies, Errors

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

function "="(                --| Compare two date/time
    Left  : in Time_Value;
    Right : in Time_Value
    ) return BOOLEAN;

--| Raises : Uninitialized_Time_Value
--| Effects: TRUE if two date/times are equal; FALSE otherwise.
--| N/A: Modifies, Errors

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

function "<"(                --| Compare two date/time
    Left  : in Time_Value;
    Right : in Time_Value
    ) return BOOLEAN;

--| Raises : Uninitialized_Time_Value
--| Effects: TRUE if Left is less than Right; FALSE otherwise.
--| N/A: Modifies, Errors

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

function ">"(                --| Compare two date/time
    Left  : in Time_Value;
    Right : in Time_Value
    ) return BOOLEAN;

--| Raises : Uninitialized_Time_Value
--| Effects: TRUE if Left is greater than Right; FALSE otherwise.
--| N/A: Modifies, Errors

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

function "<="(                --| Compare two date/time
    Left  : in Time_Value;
    Right : in Time_Value
    ) return BOOLEAN;

--| Raises : Uninitialized_Time_Value
--| Effects: TRUE if Left is less than or equal to Right; FALSE otherwise.
--| N/A: Modifies, Errors

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

function ">="(                --| Compare two date/time
    Left  : in Time_Value;
    Right : in Time_Value
    ) return BOOLEAN;

--| Raises : Uninitialized_Time_Value
--| Effects: TRUE if Left is greater than or equal to Right; FALSE otherwise.
--| N/A: Modifies, Errors

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

function Date(                --| Returns date
    Value : in Time_Value        --| Time value
    ) return STRING;

--| Raises : Uninitialized_Time_Value
--| Effects: Extract the date portion from Time_Value in MM/DD/YY format
--| N/A: Modifies, Errors

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

function Calendar_Date(            --| Returns calendar date
    Value : in Time_Value        --| Time value
    ) return STRING;

--| Raises : Uninitialized_Time_Value
--| Effects: Extract the date portion from Time_Value in Month DD, Year format
--| (eg. March 15, 1985)
--| N/A: Modifies, Errors

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

function Time(                --| Returns time
    Value : in Time_Value        --| Time value
    ) return STRING;

--| Raises : Uninitialized_Time_Value
--| Effects: Extract the time portion from Time_Value in HH:MM:SS format
--| N/A: Modifies, Errors

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

function Get_Terminal_Type        --| Get terminal type
    return Terminal_Type;

--| Raises : Terminal_Not_Attached, Unknown_Terminal_Type
--| Effects: Obtains attached terminal type.
--| N/A: Modifies, Errors

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

procedure Enable_Interrupt_Trap;    --| Traps interrupt from the keyboard

--| Raises : Interrupt_Encountered
--| Effects: Enables trapping of an interrupt encountered from the keyboard.
--| On an interrupt from the keyboard, this procedure will :
--|  1. Set state such that all further interrupts from the keyboard are ignored
--|  2. Raise Interrupt_Encountered exception
--| It is the user's responsibility to handle the ignore state after the
--| exception is raised (eg. disable the interrupt trapping to allow the
--| system to handle subsequent interrupts).
--|-
--|    begin
--|         (Process not requiring interrupt trap)
--|      Enable_Interrupt_Trap;
--|         (Process requiring interrupt trap)
--|      Ignore_Interrupts;
--|         (Post process [eg. clean up])
--|     exception
--|      when Interrupt_Encountered =>
--|         (Post process [eg. clean up])
--|    end;
--|    Disable_Interrupt_Trap
--|+
--| N/A: Modifies, Errors

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

procedure Disable_Interrupt_Trap;    --| Disables interrupt trapping

--| Effects: Disables trapping of interrupts encountered from the keyboard.
--| N/A: Raises, Modifies, Errors

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

procedure Ignore_Interrupts;        --| Ignore interrupts

--| Effects: Interrupts encountered from the keyboard are ignored.
--| The trap must subsequently be disabled (Disable_Interrupt_Trap).
--| N/A: Raises, Modifies, Errors

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

function Interrupts_Ignored        --| Returns TRUE if any interrupts from
                    --| the keyboard were ignored
    return BOOLEAN;

--| Effects: Returns TRUE if any interrupts were encountered since the mode
--| was set to ignore interrupts.
--| N/A: Raises, Modifies, Errors

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

procedure Set_Interrupt_State(        --| Set interrupt state
    State : in Interrupt_State
    );

--| Effects: Set interrupt state
--| N/A: Raises, Modifies, Errors

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

function Get_Interrupt_State        --| Get interrupt state
    return Interrupt_State;

--| Effects: Returns interrupt state
--| N/A: Raises, Modifies, Errors

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

private
                                                                    pragma list(off);
    type Time_Value is
    record
        year  : INTEGER;
        month : INTEGER := 0;
        day   : INTEGER;
        time  : INTEGER;
    end record;
                                                                    pragma list(on);
end Host_Lib;
                                                                    pragma page;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--HOSTLIB.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with System;                    use System;
with Starlet;
with Condition_Handling;
with Text_IO;
with Calendar;
with String_Pkg;
with String_Utilities;

package body Host_Lib is

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

    package SU  renames String_Utilities;
    package CAL renames Calendar;
    package SP  renames String_Pkg;
    package CD  renames Condition_Handling;
    package TIO renames Text_IO;
    package STL renames Starlet;

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

    Month_Name     : constant STRING :=
            "JanuarayFebruarnyMarchAprilMayJune" &
            "JulyAugustSeptemberOctoberNovemberDecember";
    Index_Array    : constant array (1..13) of INTEGER :=
            (1, 9, 18, 23, 28, 31, 35, 39, 45, 54, 61, 69, 77);
    Item_Array     : constant array (1..7) of INTEGER :=
            (STL.JPI_USERNAME,
             STL.JPI_ACCOUNT,
             STL.JPI_IMAGNAME,
             STL.JPI_MODE,
             STL.JPI_PID,
             STL.JPI_TERMINAL,
             STL.DVI_DEVTYPE);

    Terminal_Array : constant array (Terminal_Type) of INTEGER := (
            VT05            =>   1,
            VK100            =>   2,
            VT173            =>   3,
            TQ_BTS            =>   4,
            TEK401X            =>  10,
            FOREIGN_TERMINAL_1    =>  16,
            FOREIGN_TERMINAL_2    =>  17,
            FOREIGN_TERMINAL_3    =>  18,
            FOREIGN_TERMINAL_4    =>  19,
            FOREIGN_TERMINAL_5    =>  20,
            FOREIGN_TERMINAL_6    =>  21,
            FOREIGN_TERMINAL_7    =>  22,
            FOREIGN_TERMINAL_8    =>  23,
            LA36            =>  32,
            LA120            =>  33,
            LA34            =>  34,
            LA38            =>  35,
            LA12            =>  36,
            LA24            =>  37,
            LQP02            =>  38,
            LA84            =>  39,
            VT52            =>  64,
            VT55            =>  65,
            DZ11            =>  66,
            DZ32            =>  67,
            DZ730            =>  68,
            DMZ32            =>  69,
            DHV            =>  70,
            DHU            =>  71,
            VT100            =>  96,
            VT101            =>  97,
            VT102            =>  98,
            VT105            =>  99,
            VT125            => 100,
            VT131            => 101,
            VT132            => 102,
            VT200_SERIES        => 110,
            PRO_SERIES        => 111,
            WORKSTATION        =>   0,
            VS100            =>   1,
            VS125            =>   2,
            VS300            =>   3,
            VIRTUAL_DEVICE        =>   4);

    Control_Y       : constant UNSIGNED_LONGWORD := 2**CHARACTER'POS(ASCII.EM);

    TT_Name         : constant STRING := "TT:";

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

    Error_File_Type : TIO.FILE_TYPE;
    Error_Switch    : NATURAL;
    TT_Channel      : STL.Channel_Type;
    Condition       : CD.Cond_Value_Type;
    Status          : INTEGER;
    IOSB            : STL.IOSB_Type;
    Mask            : UNSIGNED_LONGWORD;
    Save_Mask       : UNSIGNED_LONGWORD;
    State           : Interrupt_State;
    Ignored_State   : BOOLEAN;

----------------------- Local procedure ------------------------

    procedure Spawn(
    Status  :    out INTEGER;
    Process : in     STRING
    );

    pragma Interface(VAXRTL, Spawn);
    pragma Import_Valued_Procedure(
            Internal        => Spawn,
            External        => "Lib$Spawn",
            Parameter_Types => (INTEGER,
                        STRING),
            Mechanism       => (Value,
                        Descriptor(S)));

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

    procedure Get_Foreign(
    Arguments : out STRING
    );

    pragma Interface(External, Get_Foreign);
    pragma Import_Valued_Procedure(Get_Foreign,
                       "Lib$Get_Foreign",
                       (STRING),
                       (Descriptor(S)));

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

    procedure Get_JPI(
    Status     :    out INTEGER;
    Item_Code  : in     INTEGER;
    Proc_Id    : in     ADDRESS := ADDRESS_ZERO;
    Proc_Name  : in     STRING  := STRING'NULL_PARAMETER;
    Out_Value  : in     ADDRESS := ADDRESS_ZERO;
    Out_String :    out STRING;
    Out_Len    :    out SHORT_INTEGER);

    pragma Interface(VAXRTL, Get_JPI);
    pragma Import_Valued_Procedure(
            Internal        => Get_JPI,
            External        => "LIB$GETJPI",
            Parameter_Types => (INTEGER,
                        INTEGER,
                        ADDRESS,
                        STRING,
                        ADDRESS,
                        STRING,
                        SHORT_INTEGER),
            Mechanism       => (Value,
                        Reference,
                        Value,
                        Descriptor(S),
                        Value,
                        Descriptor(S),
                        Reference));

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

    procedure Get_DVI(
    Status     :    out INTEGER;
    Item_Code  : in     INTEGER;
    Channel    : in     SHORT_INTEGER  := 0;
    Dev_Name   : in     STRING;
    Out_Value  : in     INTEGER := 0;
    Out_String :    out STRING;
    Out_Len    :    out SHORT_INTEGER);

    pragma Interface(VAXRTL, Get_DVI);
    pragma Import_Valued_Procedure(
            Internal        => Get_DVI,
            External        => "LIB$GETDVI",
            Parameter_Types => (INTEGER,
                        INTEGER,
                        SHORT_INTEGER,
                        STRING,
                        INTEGER,
                        STRING,
                        SHORT_INTEGER),
            Mechanism       => (Value,
                        Reference,
                        Reference,
                        Descriptor(S),
                        Reference,
                        Descriptor(S),
                        Reference));

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

    function Get_Protection_String(
    Name : in STRING;
    Prot : in Protection_Specification
    ) return SP.String_Type is

    Str : SP.String_Type := SP.Create("");

    begin

    if Prot(Read) = YES then
        Str := SP."&"(Str, "R");
    end if;
    if Prot(Write) = YES then
        Str := SP."&"(Str, "W");
    end if;
    if Prot(Execute) = YES then
        Str := SP."&"(Str, "E");
    end if;
    if Prot(Delete) = YES then
        Str := SP."&"(Str, "D");
    end if;
    if SP.Length(Str) /= 0 then
        Str := SP."&"(Name & ':', Str);
        Str := SP."&"(Str, ",");
    end if;
    return Str;

    end Get_Protection_String;

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

    procedure Check_Time_Value(
    Value : Time_Value
    ) is

    begin

    if Value.month = 0 then
        raise Uninitialized_Time_Value;
    end if;

    end Check_Time_Value;

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

    function Compare(
    Left  : Time_Value;
    Right : Time_Value
    ) return INTEGER is

    Diff : INTEGER;

    begin

    Check_Time_Value(Left);
    Check_Time_Value(Right);
    Diff := Left.year - Right.year;
    if Diff /= 0 then
        return Diff;
    end if;
    Diff := Left.month - Right.month;
    if Diff /= 0 then
        return Diff;
    end if;
    Diff := Left.day - Right.day;
    if Diff /= 0 then
        return Diff;
    end if;
    return Left.time - Right.time;

    end Compare;

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

    procedure Signal(Status : in CD.Cond_Value_Type);

    pragma Interface(VAXRTL, Signal);
    pragma Import_Procedure(Signal, "LIB$Signal", Mechanism =>(Value));

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

    procedure Control_Character_Handler is

    begin

    Ignore_Interrupts;

    raise Interrupt_Encountered;

    end Control_Character_Handler;

    pragma Export_Procedure(Control_Character_Handler,
                "Ada$Control_Character_Handler");

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

    procedure Control_Character_Ignore is

    begin

    Ignore_Interrupts;

    Ignored_State := TRUE;

    end Control_Character_Ignore;

    pragma Export_Procedure(Control_Character_Ignore,
                "Ada$Control_Character_Ignore");

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

    procedure Disable_Control(
    Status   :    out INTEGER;
    Mask     : in     UNSIGNED_LONGWORD;
    Old_Mask :    out UNSIGNED_LONGWORD
    );

    pragma Interface(VAXRTL, Disable_Control);
    pragma Import_Valued_Procedure(
            Internal        => Disable_Control,
            External        => "Lib$Disable_Ctrl",
            Parameter_Types => (INTEGER,
                        UNSIGNED_LONGWORD,
                        UNSIGNED_LONGWORD),
            Mechanism       => (Value,
                        Reference,
                        Reference));

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

    procedure Enable_Control(
    Status   :    out INTEGER;
    Mask     : in     UNSIGNED_LONGWORD;
    Old_Mask :    out UNSIGNED_LONGWORD
    );

    pragma Interface(VAXRTL, Enable_Control);
    pragma Import_Valued_Procedure(
            Internal        => Enable_Control,
            External        => "Lib$Enable_Ctrl",
            Parameter_Types => (INTEGER,
                        UNSIGNED_LONGWORD,
                        UNSIGNED_LONGWORD),
            Mechanism       => (Value,
                        Reference,
                        Reference));
                                                        pragma page;
--------------------- Visible Subprograms ----------------------

    procedure Set_Error is

    begin

    if Error_Switch = 0 then
        TIO.SET_OUTPUT(File => Error_File_Type);
    end if;
    Error_Switch := Error_Switch + 1;

    end Set_Error;

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

    procedure Reset_Error is

    begin

    if Error_Switch < 1 then
        return;
    end if;
    Error_Switch := Error_Switch - 1;
    if Error_Switch = 0 then
        TIO.SET_OUTPUT(File => TIO.STANDARD_OUTPUT);
    end if;

    end Reset_Error;

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

    procedure Put_Error(
    Message : in STRING
    ) is

    begin

    TIO.PUT_LINE(Error_File_Type, "Error : " & Message);

    end Put_Error;

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

    function Return_Code(
    Severity : in Severity_Code
    ) return integer is

    begin

    case Severity is
        when WARNING =>
        return STL.STS_K_WARNING;
        when SUCCESS =>
        return STL.STS_K_SUCCESS;
        when ERROR =>
        return STL.STS_K_ERROR;
        when INFORMATION =>
        return STL.STS_K_INFO;
        when SEVERE =>
        return STL.STS_K_SEVERE;
    end case;

    end Return_Code;

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

    procedure Invoke(
    Process  : in     STRING;
    Severity :    out Severity_Code
    ) is

    Stat  : INTEGER;
    Found : BOOLEAN := FALSE;

    begin

    for i in Process'range loop
        if Process(i) /= ' ' and Process(i) /= ASCII.HT then
        Found := TRUE;
        exit;
        end if;
    end loop;
    if not Found then
        Severity := SUCCESS;
        return;
    end if;
    Spawn(Stat, Process);
    case Stat is
        when STL.STS_K_WARNING =>
        Severity := WARNING;
        when STL.STS_K_SUCCESS =>
        Severity := SUCCESS;
        when STL.STS_K_ERROR =>
        Severity := ERROR;
        when STL.STS_K_INFO =>
        Severity := INFORMATION;
        when STL.STS_K_SEVERE =>
        Severity := SEVERE;
        when others =>
        Severity := SEVERE;
    end case;

    end Invoke;

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

    function Get_Item(
    Item : in Item_Type;
     Form : in Format := EDIT
    ) return STRING is

    Line      : STRING(1..Max_Arg_Length);
    Len       : INTEGER;
    Stat      : INTEGER;
    Inx1      : INTEGER;
    Inx2      : INTEGER;
    Dev_Class : INTEGER;

    begin
    case Item is
        when ARGUMENTS =>
        Get_Foreign(Line);
        if Form = EDIT then
            return SU.Strip(Line);
        else
            return Line;
        end if;
        when USER_NAME | ACCOUNT | PROGRAM_NAME | PROCESS_MODE |
         PROCESS_ID | TERMINAL_ADDRESS =>
        Get_JPI(Item_Code  => Item_Array(Item_Type'pos(Item)),
            Out_String => Line,
            Out_Len    => SHORT_INTEGER(Len),
            Status     => Stat);
        if Item = PROGRAM_NAME then
            if Form = EDIT then
            Inx1 := 0;
            Inx2 := 0;
            for i in 1 .. Len loop
                if Line(i) = ']' then
                Inx1 := i + 1;
                for j in Inx1 .. Len loop
                    if Line(j) = '.' then
                    Inx2 := j - 1;
                    exit;
                    end if;
                end loop;
                exit;
                end if;
            end loop;
            return Line(Inx1..Inx2);
            else
            return Line(1..Len);
            end if;
        else
            while Len > 0 and then Line(Len) = ' ' loop
            Len := Len - 1;
            end loop;
            return Line(1..Len);
        end if;
        when DEVICE_TYPE =>
        return Terminal_Type'image(Get_Terminal_Type);
        when others =>
        return "";
    end case;

    end Get_Item;

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

    function Read_No_Echo(
    Address : in STRING := Get_Item(TERMINAL_ADDRESS)
    ) return STRING is

    Line               : STRING(1 .. 255);
    Len                : INTEGER;
    Keyboard_File_Type : TIO.FILE_TYPE;
    TT                 : SP.String_Type;

    begin

    SP.Mark;
    if Address = "" then
        TT := SP.Create("TT:");
    else
        TT := SP.Create(Address);
    end if;

    begin
        TIO.OPEN(File => Keyboard_File_Type,
             Mode => TIO.IN_FILE,
             Name => SP.Value(TT),
             Form => "CONNECT;TT_READ_NOECHO YES");
    exception
        when TIO.STATUS_ERROR =>
        null;
        when others =>
        SP.Release;
        raise;
    end;
    SP.Release;
    TIO.GET_LINE(Keyboard_File_Type, Line, Len);
    TIO.NEW_LINE(1);
    return Line(1 .. Len);

    end Read_No_Echo;

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

    function Protection(
    System : in Protection_Specification :=
        (Read=>YES, Write=>YES, Execute=>YES, Delete=>YES);
    Owner  : in Protection_Specification :=
        (Read=>YES, Write=>YES, Execute=>YES, Delete=>YES);
    Group  : in Protection_Specification :=
        (Read=>YES, Write=>YES, Execute=>YES, Delete=>YES);
    World  : in Protection_Specification :=
        (Read=>YES, Write=>YES, Execute=>YES, Delete=>YES)
    ) return STRING is

    Str : SP.String_Type;

    begin

    SP.Mark;
    Str := SP.Create("");
    Str := SP."&"(Str, Get_Protection_String("SYSTEM", System));
    Str := SP."&"(Str, Get_Protection_String("OWNER", Owner));
    Str := SP."&"(Str, Get_Protection_String("GROUP", Group));
    Str := SP."&"(Str, Get_Protection_String("WORLD", World));
    if SP.Length(Str) /= 0 then
        Str := SP."&"("FILE;PROTECTION (",
              SP.Substr(Str, 1, SP.Length(Str) - 1));
        Str := SP."&"(Str, ")");
    end if;
    declare
        Protection_String : STRING (1 .. SP.Length(Str));
    begin
        Protection_String := SP.Value(Str);
        SP.Release;
        return Protection_String;
    end;

    end Protection;

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

    procedure Get_Time(
    Value : out Time_Value
    ) is

    Clock_Value : CAL.Time;
    Year        : CAL.Year_Number;
    Month       : CAL.Month_Number;
    Day         : CAL.Day_Number;
    Duration    : CAL.Day_Duration;

    begin

    Clock_Value := CAL.Clock;
    CAL.Split(Clock_Value, Year, Month, Day, Duration);
    Value.year  := INTEGER(Year);
    Value.month := INTEGER(Month);
    Value.day   := INTEGER(Day);
    Value.time  := INTEGER(Duration);

    end Get_Time;

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

    function "="(
    Left  : in Time_Value;
    Right : in Time_Value
    ) return BOOLEAN is

    begin

    return Compare(Left, Right) = 0;

    end "=";

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

    function "<"(
    Left  : in Time_Value;
    Right : in Time_Value
    ) return BOOLEAN is

    begin

    return Compare(Left, Right) < 0;

    end "<";

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

    function ">"(
    Left  : in Time_Value;
    Right : in Time_Value
    ) return BOOLEAN is

    begin

    return Compare(Left, Right) > 0;

    end ">";

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

    function "<="(
    Left  : in Time_Value;
    Right : in Time_Value
    ) return BOOLEAN is

    begin

    return Compare(Left, Right) <= 0;

    end "<=";

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

    function ">="(
    Left  : in Time_Value;
    Right : in Time_Value
    ) return BOOLEAN is

    begin

    return Compare(Left, Right) >= 0;

    end ">=";

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

    function Date(
    Value : in Time_Value
    ) return STRING is

    begin

    Check_Time_Value(Value);
    return     SU.Image(Value.month, 2, '0')
           & '/'
           & SU.Image(Value.day, 2, '0')
           & '/'
           & SU.Image((Value.year mod 100), 2, '0');

    end Date;

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

    function Calendar_Date(
    Value : in Time_Value
    ) return STRING is

    Index : INTEGER;

    begin

    Check_Time_Value(Value);
    Index := Value.month;
    return    Month_Name(Index_Array(Index) .. Index_Array(Index + 1) - 1)
        & INTEGER'image(Value.day)
        & ','
        & INTEGER'image(Value.year);

    end Calendar_Date;

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

    function Time(
    Value : in Time_Value
    ) return STRING is

    begin

    Check_Time_Value(Value);
    return     SU.Image(Value.time / (60 * 60), 2, '0')
           & ':'
           & SU.Image((Value.time mod (60 * 60)) / 60, 2, '0')
           & ':'
           & SU.Image(Value.time mod 60, 2, '0');

    end Time;

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

    function Get_Terminal_Type
    return Terminal_Type is

    Line      : STRING(1..Max_Arg_Length);
    Len       : INTEGER;
    Stat      : INTEGER;
    Dev_Class : INTEGER;

    begin

    if Get_Item(TERMINAL_ADDRESS) = "" then
        raise Terminal_Not_Attached;
    end if;
    Get_DVI(Item_Code  => STL.DVI_DEVCLASS,
        Dev_Name   => Get_Item(TERMINAL_ADDRESS),
        Out_Value  => Len,
        Out_String => Line,
        Out_Len    => SHORT_INTEGER(Len),
        Status     => Stat);
    begin
        Dev_Class := INTEGER'value(Line(1 .. Len));
    exception
        when CONSTRAINT_ERROR =>
        raise Unknown_Terminal_Type;
    end;
    if Dev_Class = STL.DC_TERM or
       Dev_Class = STL.DC_WORKSTATION then
        Get_DVI(Item_Code  => Item_Array(Item_Type'pos(DEVICE_TYPE)),
            Dev_Name   => Get_Item(TERMINAL_ADDRESS),
            Out_Value  => Len,
            Out_String => Line,
            Out_Len    => SHORT_INTEGER(Len),
            Status     => Stat);
        begin
        if Dev_Class = STL.DC_TERM then
            for i in Terminal_Type'first ..
                 Terminal_Type'val(Terminal_Type'pos(WORKSTATION) - 1)
            loop
            if INTEGER'value(Line(1 .. Len)) = Terminal_Array(i) then
                return i;
            end if;
            end loop;
        else
            for i in Terminal_Type'val(Terminal_Type'pos(WORKSTATION) + 1) ..
                 Terminal_Type'last
            loop
            if INTEGER'value(Line(1 .. Len)) = Terminal_Array(i) then
                return i;
            end if;
            end loop;
        end if;
        exception
        when CONSTRAINT_ERROR =>
            raise Unknown_Terminal_Type;
        end;
    end if;
    raise Unknown_Terminal_Type;

    end Get_Terminal_Type;

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

    procedure Enable_Interrupt_Trap is

    begin

    case State is

        when ENABLED =>
        return;

        when DISABLED =>

        Disable_Control(Status   => Status,
                Mask     => Control_Y,
                Old_Mask => Save_Mask);
        if not CD.Success(CD.Cond_Value_Type(Status)) then
            Signal(CD.Cond_Value_Type(Status));
        end if;

        if INTEGER(Save_Mask and Control_Y) = 0 then
            Enable_Control(Status   => Status,
                   Mask     => Save_Mask,
                    Old_Mask => Mask);
            if not CD.Success(CD.Cond_Value_Type(Status)) then
            Signal(CD.Cond_Value_Type(Status));
            end if;
            return;
        end if;

        when IGNORED =>

        STL.Cancel(
            Status => Condition,
            Chan   => TT_Channel);
        if not CD.Success(Condition) then
            Signal(Condition);
        end if;

        STL.Dassgn(
            Status => Condition,
            Chan   => TT_Channel);
        if not CD.Success(Condition) then
            Signal(Condition);
        end if;

    end case;

    STL.Assign(
        Status => Condition,
        Devnam => TT_Name,
        Chan   => TT_Channel);
    if not CD.Success(Condition) then
        Enable_Control(Status   => Status,
               Mask     => Save_Mask,
               Old_Mask => Mask);
        if not CD.Success(CD.Cond_Value_Type(Status)) then
        Signal(CD.Cond_Value_Type(Status));
        end if;
    end if;

    STL.QIOW(
        Status  => Condition,
        Chan    => TT_Channel,
        FUNC    => STL.IO_SETMODE
            or STL.IO_M_CtrlCAst
            or STL.IO_M_CtrlYAst,
        IOSB    => IOSB,
        P1      => TO_UNSIGNED_LONGWORD(Control_Character_Handler'Address));
    if not CD.Success(Condition) then
        STL.Dassgn(Status => Condition,
               Chan   => TT_Channel);
        Enable_Control(Status   => Status,
               Mask     => Save_Mask,
               Old_Mask => Mask);
        Signal(Condition);
    end if;

    State := ENABLED;

    end Enable_Interrupt_Trap;

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

    procedure Disable_Interrupt_Trap is

    begin

    case State is

        when DISABLED =>
        return;

        when others =>

        STL.Cancel(
            Status => Condition,
            Chan   => TT_Channel);
        if not CD.Success(Condition) then
            Signal(Condition);
        end if;

        STL.Dassgn(
            Status => Condition,
            Chan   => TT_Channel);
        if not CD.Success(Condition) then
            Signal(Condition);
        end if;

        Enable_Control(Status   => Status,
                   Mask     => Save_Mask,
                   Old_Mask => Mask);
        if not CD.Success(CD.Cond_Value_Type(Status)) then
            Signal(CD.Cond_Value_Type(Status));
        end if;

        State := DISABLED;

    end case;

    end Disable_Interrupt_Trap;

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

    procedure Ignore_Interrupts is

    begin

    case State is

        when IGNORED =>
        return;

        when DISABLED =>

        Disable_Control(Status   => Status,
                Mask     => Control_Y,
                Old_Mask => Save_Mask);
        if not CD.Success(CD.Cond_Value_Type(Status)) then
            Signal(CD.Cond_Value_Type(Status));
        end if;

        if INTEGER(Save_Mask and Control_Y) = 0 then
            Enable_Control(Status   => Status,
                   Mask     => Save_Mask,
                    Old_Mask => Mask);
            if not CD.Success(CD.Cond_Value_Type(Status)) then
            Signal(CD.Cond_Value_Type(Status));
            end if;
            return;
        end if;

        when ENABLED =>

        STL.Cancel(
            Status => Condition,
            Chan   => TT_Channel);
        if not CD.Success(Condition) then
            Signal(Condition);
        end if;

        STL.Dassgn(
            Status => Condition,
            Chan   => TT_Channel);
        if not CD.Success(Condition) then
            Signal(Condition);
        end if;

    end case;

    STL.Assign(Status => Condition,
           Devnam => TT_Name,
           Chan   => TT_Channel);
    if not CD.Success(Condition) then
        Signal(Condition);
    end if;

    STL.QIOW(
        Status  => Condition,
        Chan    => TT_Channel,
        FUNC    => STL.IO_SETMODE
            or STL.IO_M_CtrlCAst
            or STL.IO_M_CtrlYAst,
        IOSB    => IOSB,
        P1      => TO_UNSIGNED_LONGWORD(Control_Character_Ignore'Address));
    if not CD.Success(Condition) then
        Signal(Condition);
    end if;
    State := IGNORED;
    Ignored_State := FALSE;

    end Ignore_Interrupts;

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

    function Interrupts_Ignored
    return BOOLEAN is

    begin

    return Get_Interrupt_State = IGNORED and Ignored_State;

    end Interrupts_Ignored;

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

    procedure Set_Interrupt_State(
    State : in Interrupt_State
    ) is

    begin

    if State = Get_Interrupt_State then
        return;
    end if;
    case State is
        when ENABLED =>
        Enable_Interrupt_Trap;
        when DISABLED =>
        Disable_Interrupt_Trap;
        when IGNORED =>
        Ignore_Interrupts;
    end case;

    end Set_Interrupt_State;

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

    function Get_Interrupt_State
    return Interrupt_State is

    begin

    return State;

    end Get_Interrupt_State;

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

begin

    State := DISABLED;
    Ignored_State := FALSE;
    Error_Switch := 0;
    TIO.OPEN(File => Error_File_Type,
         Mode => TIO.OUT_FILE,
         Name => "SYS$ERROR",
         Form => "CONNECT;END_OF_FILE YES");
exception
    when TIO.NAME_ERROR =>
    TIO.CREATE(File => Error_File_Type,
           Mode => TIO.OUT_FILE,
           Name => "SYS$ERROR",
           Form => "CONNECT;END_OF_FILE YES");
    when TIO.STATUS_ERROR =>
    null;

end Host_Lib;
                                                        pragma page;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--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;


--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--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.  Associated with each member
--| of the set is a count of the number of times it appears in the set.  In
--| addition, there is an ordering associated with the members.  This allows
--| fast insertion, and makes it possible to iterate over the set in order.
--|-
--| Operations:
--|
--| Cardinality        Return number of members in a set.
--| Create        Creates an empty set.
--| Destroy        Destroys a set and returns the space it occupies.
--| GetCount        Returns the number of times some member appears in
--|            a set.
--| Insert        Insert a member into a set.
--| MakeSetIter        Return a SetIter which will begin an iteration.
--| More        Test for more elements during iteration
--| Next        Return the next element during iteration and
--|            bump the iterator.


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


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

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(    --| Return the count of member given by an iterator
    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(    --| Return an iterator over the set S
    S:in Set        --| Set being iterate over.
    ) return SetIter;

function More(        --| Return True iff iterator I is not empty
    I:in SetIter    --| The iterator.
    ) return boolean;

procedure Next(
--| Return the current member in the iteration and increment 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;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--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. An escape
--| sequence ~X(Ann) may be used to insert texts in the header/footer texts.
--| The escape character X may be:
--|-
--|     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)
--|+
--| The optional alignment character A may be:
--|-
--|    L    left align the text
--|    R    right allign the text
--|    C    center the text
--|+
--| nn following the alignment character specifies the number of spaces the
--| text will displace in the header/footer texts.
--|
--| 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.
                                                    pragma Page;
              -- Packages --

    package TIO renames Text_IO;

    package SP  renames String_Pkg;

               -- Types --

subtype Date_String is STRING (1 .. 8);
                --| Date string
subtype Time_String is STRING (1 .. 8);
                --| Time string
type Variable_String_Array is    --| Array of variable length strings
    array (POSITIVE range <>) of SP.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 (STD, CUR);
                --| Paginated output mode
                                                    pragma Page;
            -- Operations --

procedure Create_Paginated_File(--| Create a paginated output file
                --| and return the file handle.
    File_Name   : in     STRING                := "";
                --| 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     NATURAL               := 66;
                --| The number of lines per page
    Header_Size : in     NATURAL               := 6;
                --| The number of header text lines
    Footer_Size : in     NATURAL               := 6;
                --| The number of footer text lines
    Output_Mode : in     Paginated_Output_Mode := STD
                --| 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 STRING;    --| The name of the file to be set.
    Page_Size   : in NATURAL;    --| The number of lines per page
    Header_Size : in NATURAL;    --| The number of header text lines
    Footer_Size : in NATURAL    --| 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 NATURAL;    --| The number of lines per page
    Header_Size : in NATURAL;    --| The number of header text lines
    Footer_Size : in NATURAL    --| 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


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 NATURAL;    --| The number of lines per page
    Header_Size : in NATURAL;    --| The number of header text lines
    Footer_Size : in NATURAL    --| 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


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_File_Name(    --| Set arbitrary file name for ~f substitute
    File_Handle : in Paginated_File_Handle;
                --| The paginated file handle
    File_Name   : in STRING    --| The name of the file to be set.
    );

--| Raises:
--| Invalid_File

--| Requires:
--| File_Handle is a file handle to a paginated file
--| File_Name is any name of the file to be saved for ~f substitution

--| Effects:
--| Sets the name of the ~f substitution file to File_Name

--| Errors:
--| If the file handel is invalid Invalid_File is raise.

--| N/A: Modifies


procedure Reset_File_Name(    --| Reset file name to default
    File_Handle : in Paginated_File_Handle
    );


procedure Set_File_Name(    --| Set arbitrary file name for ~f substitute
    File_Name   : in STRING    --| The name of the file to be set.
    );

--| Raises:
--| Invalid_File

--| Requires:
--| File_Name is any name of the file to be saved for ~f substitution
--| for paginated standard output

--| Effects:
--| Sets the name of the ~f substitution file to File_Name

--| N/A: Modifies


procedure Reset_File_Name;    --| Reset file name to default
                                                    pragma Page;
procedure Set_Date(        --| Set arbitrary string for ~d date substitute
    File_Handle : in Paginated_File_Handle;
                --| The paginated file handle
    Date        : in Date_String--| The date string
    );

--| Raises:
--| Invalid_File

--| Requires:
--| File_Handle is a file handle to a paginated file
--| Date is any string to be saved for ~d substitution

--| Effects:
--| Sets the string of the ~d substitution to date

--| Errors:
--| If the file handel is invalid Invalid_File is raise.

--| N/A: Modifies


procedure Reset_Date(        --| Reset date to current date
    File_Handle : in Paginated_File_Handle
    );


procedure Set_Date(        --| Set arbitrary string for ~d date substitute
    Date : in Date_String    --| The date string
    );

--| Requires:
--| Date is any string to be saved for ~d substitution

--| Effects:
--| Sets the string of the ~d substitution to date

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


procedure Reset_Date;        --| Reset date to current date
                                                    pragma Page;
procedure Set_Calendar(        --| Set arbitrary string for ~c date substitute
    File_Handle : in Paginated_File_Handle;
                --| The paginated file handle
    Calendar        : in STRING    --| The date string
    );

--| Raises:
--| Invalid_File

--| Requires:
--| File_Handle is a file handle to a paginated file
--| Date is any string to be saved for ~c substitution

--| Effects:
--| Sets the string of the ~c substitution to date

--| Errors:
--| If the file handel is invalid Invalid_File is raise.

--| N/A: Modifies


procedure Reset_Calendar(    --| Reset date to current calendar date
    File_Handle : in Paginated_File_Handle
    );


procedure Set_Calendar(        --| Set arbitrary string for ~c date substitute
    Calendar : in STRING    --| The date string
    );

--| Requires:
--| Date is any string to be saved for ~c substitution

--| Effects:
--| Sets the string of the ~c substitution to date

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


procedure Reset_Calendar;    --| Reset date to current calendar date
                                                    pragma Page;
procedure Set_Time(        --| Set arbitrary string for ~t time substitute
    File_Handle : in Paginated_File_Handle;
                --| The paginated file handle
    Time        : in Time_String--| The time string
    );

--| Raises:
--| Invalid_File

--| Requires:
--| File_Handle is a file handle to a paginated file
--| Time is any string to be saved for ~t substitution

--| Effects:
--| Sets the string of the ~t substitution to time

--| Errors:
--| If the file handel is invalid Invalid_File is raise.

--| N/A: Modifies


procedure Reset_Time(        --| Reset time to current time
    File_Handle : in Paginated_File_Handle
    );


procedure Set_Time(        --| Set arbitrary string for ~t time substitute
    Time : in Time_String    --| The time string
    );

--| Requires:
--| Time is any string to be saved for ~t substitution

--| Effects:
--| Sets the string of the ~t substitution to time

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


procedure Reset_Time;        --| Reset time to current time
                                                    pragma Page;
procedure Set_Page(        --| Set arbitrary string for ~p page substitute
    File_Handle : in Paginated_File_Handle;
                --| The paginated file handle
    Page        : in POSITIVE    --| The page number
    );

--| Raises:
--| Invalid_File

--| Requires:
--| File_Handle is a file handle to a paginated file
--| page is any string to be saved for ~p substitution

--| Effects:
--| Sets the page number for ~p substitution

--| Errors:
--| If the file handel is invalid Invalid_File is raise.

--| N/A: Modifies


procedure Reset_Page(        --| Reset page to 1
    File_Handle : in Paginated_File_Handle
    );


procedure Set_Page(        --| Set arbitrary string for ~p page substitute
    Page : in POSITIVE        --| The page number
    );

--| Requires:
--| page is any string to be saved for ~p substitution

--| Effects:
--| Sets the page number for ~p substitution

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


procedure Reset_Page;        --| Rest page to 1
                                                    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


procedure Set_Header(
    Header_Line : in POSITIVE;
    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 POSITIVE;    --| Line number of header to be replaced
    Header_Text : in STRING    --| Header line to replace
    );

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

--| N/A: Modifies


procedure Set_Header(
    Header_Line : in POSITIVE;
    Header_Text : in SP.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 POSITIVE;    --| Line number of header to be replaced
    Header_Text : in SP.String_Type
                --| Header line to replace
    );

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

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


procedure Set_Odd_Header(
    Header_Line : in POSITIVE;
    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 POSITIVE;    --| Line number of header to be replaced
    Header_Text : in STRING    --| Header line to replace
    );

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

--| N/A: Modifies


procedure Set_Odd_Header(
    Header_Line : in POSITIVE;
    Header_Text : in SP.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 POSITIVE;    --| Line number of header to be replaced
    Header_Text : in SP.String_Type
                --| Header line to replace
    );

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

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


procedure Set_Even_Header(
    Header_Line : in POSITIVE;
    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 POSITIVE;    --| Line number of header to be replaced
    Header_Text : in STRING    --| Header line to replace
    );

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

--| N/A: Modifies


procedure Set_Even_Header(
    Header_Line : in POSITIVE;
    Header_Text : in SP.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 POSITIVE;    --| Line number of header to be replaced
    Header_Text : in SP.String_Type
                --| Header line to replace
    );

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

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

--| N/A: Modifies


procedure Set_Footer(
    Footer_Line : in POSITIVE;
    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 POSITIVE;    --| Line number of footer to be replaced
    Footer_Text : in STRING    --| Footer line to replace
    );

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

--| N/A: Modifies


procedure Set_Footer(
    Footer_Line : in POSITIVE;
    Footer_Text : in SP.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 POSITIVE;    --| Line number of footer to be replaced
    Footer_Text : in SP.String_Type
                --| Footer line to replace
    );

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

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


procedure Set_Odd_Footer(
    Footer_Line : in POSITIVE;
    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 POSITIVE;    --| Line number of footer to be replaced
    Footer_Text : in STRING    --| Footer line to replace
    );

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

--| N/A: Modifies


procedure Set_Odd_Footer(
    Footer_Line : in POSITIVE;
    Footer_Text : in SP.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 POSITIVE;    --| Line number of footer to be replaced
    Footer_Text : in SP.String_Type
                --| Footer line to replace
    );

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

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


procedure Set_Even_Footer(
    Footer_Line : in POSITIVE;
    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 POSITIVE;    --| Line number of footer to be replaced
    Footer_Text : in STRING    --| Footer line to replace
    );

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

--| N/A: Modifies


procedure Set_Even_Footer(
    Footer_Line : in POSITIVE;
    Footer_Text : in SP.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 POSITIVE;    --| Line number of footer to be replaced
    Footer_Text : in SP.String_Type
                --| Footer line to replace
    );

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

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


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


procedure Put(
    Text        : in SP.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 SP.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


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


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 NATURAL
    );


procedure Space(        --| Output a specified number of spaces
    File_Handle : in Paginated_File_Handle;
                --| The paginated file to output the line
    Count       : in NATURAL    --| 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


procedure Put_Line(
    Text_Line   : in SP.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 SP.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


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 NATURAL := 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 NATURAL := 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 NATURAL := 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 NATURAL := 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 NATURAL := 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 NATURAL := 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 NATURAL;

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

--| 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 NATURAL
    );


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 NATURAL    --| 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(off);
    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     : NATURAL;
                --| 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
        file_spec        : SP.String_Type;
                --| External file name
        file_name        : SP.String_Type;
                --| External file name for ~f substitute
        file_reference   : TIO.File_Type;
                --| External file reference
        output_mode      : Paginated_Output_Mode := STD;
                --| Output mode (STD or CUR)
        page_size        : NATURAL;
                --| The number of lines per page
        maximum_line     : NATURAL;
                --| The maximum number of text lines
        current_calendar : SP.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     : NATURAL := 0;
                --| The number of lines per page
        current_line     : NATURAL := 0;
                --| The number of lines used
        header_size      : NATURAL;
                --| 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      : NATURAL;
                --| 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 Calendar;
with Unchecked_Deallocation;
with String_Utilities;


package body Paginated_Output is

    package IIO is new TIO.Integer_IO(INTEGER);
    package CAL renames Calendar;
    package SU  renames String_Utilities;
    package SS  is new SU.Generic_String_Utilities(SP.String_Type,
                           SP.Make_Persistent,
                           SP.Value);

    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;

    type DCT is (DATE, CALENDAR_DATE, TIME);

    type Date_Calendar_Time is array (DCT) of BOOLEAN;

    Max_Filename_Size : constant POSITIVE := 60;

    Max_Calendar_Size : constant POSITIVE := 18;

    Max_Page_Size     : constant POSITIVE :=  3;

    Month_Name : constant Variable_String_Array(1 .. 12) :=
    ( 1 => SP.Create("January"),
      2 => SP.Create("February"),
      3 => SP.Create("March"),
      4 => SP.Create("April"),
      5 => SP.Create("May"),
      6 => SP.Create("June"),
      7 => SP.Create("July"),
      8 => SP.Create("August"),
      9 => SP.Create("September"),
     10 => SP.Create("October"),
     11 => SP.Create("November"),
     12 => SP.Create("December") );

    Paginated_Standard_Output : Paginated_File_Handle;
                                                                    pragma page;
    procedure Reset_Date_Calendar_Time(
    File_Handle : in Paginated_File_Handle;
    Reset       : in Date_Calendar_Time
    ) 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 : CAL.Time;
    Year        : CAL.Year_Number;
    Month       : CAL.Month_Number;
    Day         : CAL.Day_Number;
    Duration    : CAL.Day_Duration;

    begin

    Clock_Value := CAL.Clock;
    CAL.Split(Clock_Value, Year, Month, Day, Duration);

    if Reset(Date) then
        File_Handle.current_date := SU.Image(INTEGER(Month), 2, '0') & "/"
                      & SU.Image(INTEGER(Day), 2, '0') & "/"
                      & SU.Image(INTEGER(Year mod 100), 2, '0');
    end if;

    if Reset(Time) then
        File_Handle.current_time := SU.Image(INTEGER(Duration) / (60 * 60), 2, '0') & ":"
                      & SU.Image((INTEGER(Duration) mod (60 * 60)) / 60, 2, '0') & ":"
                      & SU.Image(INTEGER(Duration) mod 60, 2, '0');
    end if;

    if Reset(Calendar_Date) then
        SP.Mark;
        if not SP.Equal(File_Handle.current_calendar, "") then
        SP.Flush(File_Handle.current_calendar);
        end if;
        File_Handle.current_calendar := SP.Make_Persistent(
                        SP.Value(Month_Name(INTEGER(Month))) &
                        INTEGER'image(Day) &
                        "," &
                        INTEGER'image(Year));
        SP.Release;
    end if;

    return;

    end Reset_Date_Calendar_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
        SP.Flush(Text_Handle(i));
        end loop;
    end if;
    return;

    end Clear_Text;


    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) := SP.Make_Persistent(Text_String(i));
        Text_Index := Text_Index + 1;
        end loop;
        Handle := Handle.forward_link;
    end loop;
    return;

    end Set_Text;
                                                                    pragma page;
    procedure Substitute(
    In_String  : in     SP.String_Type;
    Index      : in out INTEGER;
    Sub_String : in     STRING;
    Out_String :    out SP.String_Type
    ) is

    Scanner : SU.Scanner;
    S_Str   : SP.String_Type;
    Found   : BOOLEAN;
    Num     : INTEGER;
    Letter  : CHARACTER;
    Inx     : INTEGER;

    begin

    Out_String := SP.Create(Sub_String);
    Scanner := SS.Make_Scanner(
            SP.Substr(In_String, Index, SP.Length(In_String) - Index + 1)
            );
    SS.Scan_Enclosed('(', ')', Scanner, Found, S_Str);
    SU.Destroy_Scanner(Scanner);
    if Found then
        Scanner := SS.Make_Scanner(S_Str);
        Inx := SP.Length(S_Str);
        SP.Flush(S_Str);
        if SU.More(Scanner) then
        SU.Next(Scanner, Letter);
        if SU.More(Scanner) then
            SU.Scan_Number(Scanner, Found, Num);
            if Found and then Num > 0 then
            if not SU.More(Scanner) then
                if Letter = 'r' or Letter = 'R' or
                   Letter = 'l' or Letter = 'L' or
                   Letter = 'c' or Letter = 'C' then
                case Letter is
                when 'R' | 'r' =>
                    Out_String := SS.Right_Justify(Sub_String, Num);
                when 'L' | 'l' =>
                    Out_String := SS.Left_Justify(Sub_String, Num);
                when 'C' | 'c' =>
                    Out_String := SS.Center(Sub_String, Num);
                when others    =>
                    null;
                end case;
                Index := Index + Inx + 2;
                end if;
            end if;
            end if;
        end if;
        end if;
        SU.Destroy_Scanner(Scanner);
    end if;

    end Substitute;
                                                                    pragma page;
    function Tilde_Substitute(
    File_Handle : in Paginated_File_Handle;
    Input_Text : in SP.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  : SP.String_Type;
    R_Str, S_Str : SP.String_Type;
    Letter       : CHARACTER;
    Index        : NATURAL;

    begin

    S_Str := Input_Text;
    loop
        Index := SP.Match_C(S_Str, '~');
        if Index = 0 then
        Output_Text := SP."&"(Output_Text, S_Str);
        exit;
        end if;
        if Index > 1 then
        Output_Text := SP."&"(Output_Text, SP.Substr(S_Str, 1, Index - 1));
        end if;
        if Index < SP.Length(S_Str) then
        Letter := SP.Fetch(S_Str, Index + 1);
        else
        exit;
        end if;
        Index := Index + 2;
        case Letter is
        when 'f' | 'F' =>
            Substitute(S_Str, Index, SP.Value(File_Handle.file_name), R_Str);
            Output_Text := SP."&"(Output_Text, R_Str);
        when 'c' | 'C' =>
            Substitute(S_Str, Index, SP.Value(File_Handle.current_calendar), R_Str);
            Output_Text := SP."&"(Output_Text, R_Str);
        when 'd' | 'D' =>
            Substitute(S_Str, Index, File_Handle.current_date, R_Str);
            Output_Text := SP."&"(Output_Text, R_Str);
        when 't' | 'T' =>
            Substitute(S_Str, Index, File_Handle.current_time, R_Str);
            Output_Text := SP."&"(Output_Text, R_Str);
        when 'p' | 'P' =>
            Substitute(S_Str, Index, STRING'(SU.Image(File_Handle.current_page, 0)), R_Str);
            Output_Text := SP."&"(Output_Text, R_Str);
        when others    =>
            Output_Text := SP."&"(Output_Text, ("" & Letter));
        end case;
        if Index > SP.Length(S_Str) then
        exit;
        end if;
        S_Str := SP.Substr(S_Str, Index, SP.Length(S_Str) - Index + 1);
    end loop;

    return SP.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 SP.Equal(File_Handle.file_spec, "") then
        if File_Handle.output_mode = STD then
            TIO.New_Line(TIO.Standard_Output,
                 TIO.POSITIVE_Count(Text_Size));
        else
            TIO.New_Line(TIO.Current_Output,
                 TIO.POSITIVE_Count(Text_Size));
        end if;
        else
        TIO.New_Line(File_Handle.file_reference,
                 TIO.POSITIVE_Count(Text_Size));
        end if;
        return;
    end if;
    for i in 1 .. Text_Size loop
        SP.Mark;
        if SP.Is_Empty(Text_Handle(i)) then
            if SP.Equal(File_Handle.file_spec, "") then
            if File_Handle.output_mode = STD then
            TIO.New_Line(TIO.Standard_Output, 1);
            else
            TIO.New_Line(TIO.Current_Output, 1);
            end if;
        else
            TIO.New_Line(File_Handle.file_reference, 1);
        end if;
        else
            if SP.Equal(File_Handle.file_spec, "") then
            if File_Handle.output_mode = STD then
            TIO.Put_Line(TIO.Standard_Output,
                     Tilde_Substitute(File_Handle, Text_Handle(i)));
            else
            TIO.Put_Line(TIO.Current_Output,
                     Tilde_Substitute(File_Handle, Text_Handle(i)));
            end if;
        else
            TIO.Put_Line(File_Handle.file_reference,
                 Tilde_Substitute(File_Handle, Text_Handle(i)));
        end if;
        end if;
        SP.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);
    SP.Flush(File_Handle.current_calendar);
    SP.Flush(File_Handle.file_name);
    if not SP.Equal(File_Handle.file_spec, "") then
        SP.Flush(File_Handle.file_spec);
        TIO.Close(File_Handle.file_reference);
    end if;
    Free_Structure(File_Handle);
    return;

    exception

    when TIO.Status_error =>
        Free_Structure(File_Handle);

    end Abort_Paginated_Output;
                                                                    pragma page;
    function Footer_Exist(
    File_Handle : in Paginated_File_Handle
    ) return BOOLEAN is

    Text_Handle : Variable_String_Array_Handle;
    Text_Size   : INTEGER;

    begin

    Text_Size := File_Handle.footer_size;
    if Text_Size <= 0 then
        return FALSE;
    end if;
    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;
    if Text_Handle = null then
        return FALSE;
    end if;
    for i in 1 .. Text_Size loop
        SP.Mark;
        if not SP.Is_Empty(Text_Handle(i)) then
        return TRUE;
        end if;
        SP.Release;
    end loop;
    return FALSE;

    end Footer_Exist;
                                                                    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 SP.Equal(File_Handle.file_spec, "") then
        if File_Handle.output_mode = STD then
            TIO.Put(TIO.Standard_Output, ASCII.FF);
        else
            TIO.Put(TIO.Current_Output, ASCII.FF);
        end if;
        else
        TIO.Put(File_Handle.file_reference, ASCII.FF);
        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 Footer_Exist(File_Handle) then
        if SP.Equal(File_Handle.file_spec, "") then
            if File_Handle.output_mode = STD then
            TIO.New_Line(TIO.Standard_Output,
                     TIO.POSITIVE_Count(Skip_Count));
            else
            TIO.New_Line(TIO.Current_Output,
                     TIO.POSITIVE_Count(Skip_Count));
            end if;
        else
            TIO.New_Line(File_Handle.file_reference,
                 TIO.POSITIVE_Count(Skip_Count));
        end if;
        Text_Kind.text := footer;
        Put_Text(File_Handle, Text_Kind);
        else
        if SP.Equal(File_Handle.file_spec, "") then
            if File_Handle.output_mode = STD then
            TIO.New_Line(TIO.Standard_Output, 1);
            else
            TIO.New_Line(TIO.Current_Output, 1);
            end if;
        else
            TIO.New_Line(File_Handle.file_reference, 1);
        end if;
        end if;
        Skip_Count := Count - Skip_Count;
        File_Handle.current_line := 0;
        if Skip_Count /= 0 then
        Line_Feed(File_Handle, Skip_Count);
        end if;
    else
        if SP.Equal(File_Handle.file_spec, "") then
        if File_Handle.output_mode = STD then
            TIO.New_Line(TIO.Standard_Output,
                 TIO.POSITIVE_Count(Count));
        else
            TIO.New_Line(TIO.Current_Output,
                 TIO.POSITIVE_Count(Count));
        end if;
        else
        TIO.New_Line(File_Handle.file_reference,
                 TIO.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 POSITIVE := 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) := SP.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 SP.Equal(Handle.file_spec, "") then
        if Handle.output_mode = STD then
            TIO.Put(TIO.Standard_Output, Text_Line);
        else
            TIO.Put(TIO.Current_Output, Text_Line);
        end if;
        else
        TIO.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 STRING                     := "";
    File_Handle : in out Paginated_File_Handle;
    Page_Size   : in NATURAL                    := 66;
    Header_Size : in NATURAL                    := 6;
    Footer_Size : in NATURAL                    := 6;
    Output_mode : in Paginated_output_mode      := STD
    ) 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_spec := SP.Make_Persistent(File_Name);
        TIO.Create(File => File_Handle.file_reference,
               Name => File_Name);
    end if;
    Reset_File_Name(File_Handle);
    Set_Page_Layout(File_Handle, Page_Size, Header_Size, Footer_Size);
    Reset_Date_Calendar_Time(File_Handle, (Date=>TRUE, Calendar_Date=>TRUE, Time=>TRUE));
    File_Handle.output_mode := output_mode;
    File_Handle.access_count := 1;
    return;

    exception

    when TIO.Status_error =>
        Abort_Paginated_Output(File_Handle);
        raise File_Already_Open;
    when TIO.Name_error | TIO.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 STRING;
    Page_Size   : in NATURAL;
    Header_Size : in NATURAL;
    Footer_Size : in NATURAL
    ) is

    begin

    Create_Paginated_File(File_Name,
                  Paginated_Standard_Output,
                  Page_Size,
                  Header_Size,
                  Footer_Size);

    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 NATURAL;
    Header_Size : in NATURAL;
    Footer_Size : in NATURAL
    ) is

    begin

    Set_Page_Layout(Paginated_Standard_Output,
            Page_Size,
            Header_Size,
            Footer_Size);

    end Set_Page_Layout;


    procedure Set_Page_Layout(
    File_Handle : in Paginated_File_Handle;
    Page_Size   : in NATURAL;
    Header_Size : in NATURAL;
    Footer_Size : in NATURAL
    ) 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;


    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_File_Name(
    File_Handle : in Paginated_File_Handle;
    File_Name   : in STRING
    ) is

    begin

    Check_Valid(File_Handle);
    File_Handle.file_name := SP.Make_Persistent(File_Name);

    end Set_File_Name;


    procedure Set_File_Name(
    File_Name   : in STRING
    ) is

    begin

    Set_File_Name(Paginated_Standard_Output, File_Name);

    end Set_File_Name;


    procedure Reset_File_Name(
    File_Handle : in Paginated_File_Handle
    ) is

    begin

    Check_Valid(File_Handle);
    if not SP.Equal(File_Handle.file_name, "") then
        SP.Flush(File_Handle.file_name);
    end if;
    if SP.Equal(File_Handle.file_spec, "") then
        File_Handle.file_name := SP.Make_Persistent("STANDARD OUTPUT");
    else
        File_Handle.file_name := SP.Make_Persistent(File_Handle.file_spec);
    end if;

    end Reset_File_Name;


    procedure Reset_File_Name
    is

    begin

    Reset_File_Name(Paginated_Standard_Output);

    end Reset_File_Name;
                                                                    pragma page;
    procedure Set_Date(
    File_Handle : in Paginated_File_Handle;
    Date : in Date_String
    ) is

    S_Str : SP.String_Type;

    begin

    Check_Valid(File_Handle);
    File_Handle.current_date := Date;

    end Set_Date;


    procedure Set_Date(
    Date : in Date_String
    ) is

    begin

    Set_Date(Paginated_Standard_Output, Date);

    end Set_Date;


    procedure Reset_Date(
    File_Handle : in Paginated_File_Handle
    ) is

    begin

    Check_Valid(File_Handle);
    Reset_Date_Calendar_Time(File_Handle, (Date=>TRUE, Calendar_Date=> FALSE, Time=>FALSE));

    end Reset_Date;


    procedure Reset_Date
    is

    begin

    Reset_Date(Paginated_Standard_Output);

    end Reset_Date;
                                                                    pragma page;
    procedure Set_Calendar(
    File_Handle : in Paginated_File_Handle;
    Calendar : in STRING
    ) is

    begin

    Check_Valid(File_Handle);
    File_Handle.current_Calendar := SP.Make_Persistent(Calendar);

    end Set_Calendar;


    procedure Set_Calendar(
    Calendar : in STRING
    ) is

    begin

    Set_Calendar(Paginated_Standard_Output, Calendar);

    end Set_Calendar;


    procedure Reset_Calendar(
    File_Handle : in Paginated_File_Handle
    ) is

    begin

    Check_Valid(File_Handle);
    Reset_Date_Calendar_Time(File_Handle, (Date=>FALSE, Calendar_Date=> TRUE, Time=>FALSE));

    end Reset_Calendar;


    procedure Reset_Calendar
    is

    begin

    Reset_Calendar(Paginated_Standard_Output);

    end Reset_Calendar;
                                                                    pragma page;
    procedure Set_Time(
    File_Handle : in Paginated_File_Handle;
    Time        : in Time_String
    ) is

    begin

    Check_Valid(File_Handle);
    File_Handle.current_time := Time;

    end Set_Time;


    procedure Set_Time(
    Time : in Time_String
    ) is

    begin

    Set_Time(Paginated_Standard_Output, Time);

    end Set_Time;


    procedure Reset_Time(
    File_Handle : in Paginated_File_Handle
    ) is

    begin

    Check_Valid(File_Handle);
    Reset_Date_Calendar_Time(File_Handle, (Date=>FALSE, Calendar_Date=> FALSE, Time=>TRUE));

    end Reset_Time;


    procedure Reset_Time
    is

    begin

    Reset_Time(Paginated_Standard_Output);

    end Reset_Time;
                                                                    pragma page;
    procedure Set_Page(
    File_Handle : in Paginated_File_Handle;
    Page        : in POSITIVE
    ) is

    begin

    Check_Valid(File_Handle);
    File_Handle.current_page := Page - 1;

    end Set_Page;


    procedure Set_Page(
    Page : in POSITIVE
    ) is

    begin

    Set_Page(Paginated_Standard_Output, Page);

    end Set_Page;


    procedure Reset_Page(
    File_Handle : in Paginated_File_Handle
    ) is

    begin

    Check_Valid(File_Handle);
    File_Handle.current_page := 0;

    end Reset_Page;


    procedure Reset_Page
    is

    begin

    Reset_Page(Paginated_Standard_Output);

    end Reset_Page;
                                                                    pragma page;
    procedure Set_Header(
    Header_Text : in Variable_String_Array
    ) is

    begin
    Set_Header(Paginated_Standard_Output,
           Header_Text);

    end Set_Header;


    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;


    procedure Set_Header(
    Header_Line : in POSITIVE;
    Header_Text : in SP.String_Type
    ) is

    begin

    Set_Header(Paginated_Standard_Output,
           Header_Line,
           Header_Text);

    end Set_Header;


    procedure Set_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Line : in POSITIVE;
    Header_Text : in SP.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;


    procedure Set_Header(
    Header_Line : in POSITIVE;
    Header_Text : in STRING
    ) is

    begin

    Set_Header(Paginated_Standard_Output,
           Header_Line,
           Header_Text);

    end Set_Header;


    procedure Set_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Line : in POSITIVE;
    Header_Text : in STRING
    ) is

--|-Algorithm:
--| Create a variable string
--| Set odd page header
--| Set even page header
--| Exit
--|+

    Text : SP.String_Type;

    begin

    Text :=    SP.Make_Persistent(Header_Text);
    Set_Odd_Header(File_Handle, Header_Line, Text);
    Set_Even_Header(File_Handle, Header_Line, Text);
    SP.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;


    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;


    procedure Set_Odd_Header(
    Header_Line : in POSITIVE;
    Header_Text : in SP.String_Type
    ) is

    begin

    Set_Odd_Header(Paginated_Standard_Output,
               Header_Line,
               Header_Text);

    end Set_Odd_Header;


    procedure Set_Odd_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Line : in POSITIVE;
    Header_Text : in SP.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 > File_Handle.header_size then
        raise Text_Overflow;
    end if;
    File_Handle.odd_page_header(Header_Line) := SP.Make_Persistent(Header_Text);
    return;

    end Set_Odd_Header;


    procedure Set_Odd_Header(
    Header_Line : in POSITIVE;
    Header_Text : in STRING
    ) is

    begin

    Set_Odd_Header(Paginated_Standard_Output,
               Header_Line,
               Header_Text);

    end Set_Odd_Header;


    procedure Set_Odd_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Line : in POSITIVE;
    Header_Text : in STRING
    ) is

--|-Algorithm:
--| Create a variable string
--| Set odd page header
--| Exit
--|+

    Text : SP.String_Type;

    begin

    Text := SP.Make_Persistent(Header_Text);
    Set_Odd_Header(File_Handle, Header_Line, Text);
    SP.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;


    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;


    procedure Set_Even_Header(
    Header_Line : in POSITIVE;
    Header_Text : in SP.String_Type
    ) is

    begin

    Set_Even_Header(Paginated_Standard_Output,
            Header_Line,
            Header_Text);

    end Set_Even_Header;


    procedure Set_Even_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Line : in POSITIVE;
    Header_Text : in SP.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 > File_Handle.header_size then
        raise Text_Overflow;
    end if;
    SP.Flush(File_Handle.even_page_header(Header_Line));
    File_Handle.even_page_header(Header_Line) := SP.Make_Persistent(Header_Text);
    return;

    end Set_Even_Header;


    procedure Set_Even_Header(
    Header_Line : in POSITIVE;
    Header_Text : in STRING
    ) is

    begin

    Set_Even_Header(Paginated_Standard_Output,
            Header_Line,
            Header_Text);

    end Set_Even_Header;


    procedure Set_Even_Header(
    File_Handle : in Paginated_File_Handle;
    Header_Line : in POSITIVE;
    Header_Text : in STRING
    ) is

--|-Algorithm:
--| Create a variable string
--| Set even page header
--| Exit
--|+

    Text : SP.String_Type;

    begin

    Text :=    SP.Make_Persistent(Header_Text);
    Set_Even_Header(File_Handle, Header_Line, Text);
    SP.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;


    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;


    procedure Set_Footer(
    Footer_Line : in POSITIVE;
    Footer_Text : in SP.String_Type
    ) is

    begin

    Set_Footer(Paginated_Standard_Output,
           Footer_Line,
           Footer_Text);

    end Set_Footer;


    procedure Set_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Line : in POSITIVE;
    Footer_Text : in SP.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;


    procedure Set_Footer(
    Footer_Line : in POSITIVE;
    Footer_Text : in STRING
    ) is

    begin

    Set_Footer(Paginated_Standard_Output,
           Footer_Line,
           Footer_Text);

    end Set_Footer;


    procedure Set_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Line : in POSITIVE;
    Footer_Text : in STRING
    ) is

--|-Algorithm:
--| Create a variable string
--| Set odd page footer
--| Set even page footer
--| Exit
--|+

    Text : SP.String_Type;

    begin

    Text := SP.Make_Persistent(Footer_Text);
    Set_Odd_Footer(File_Handle, Footer_Line, Text);
    Set_Even_Footer(File_Handle, Footer_Line, Text);
    SP.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;


    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;


    procedure Set_Odd_Footer(
    Footer_Line : in POSITIVE;
    Footer_Text : in SP.String_Type
    ) is

    begin

    Set_Odd_Footer(Paginated_Standard_Output,
               Footer_Line,
               Footer_Text);

    end Set_Odd_Footer;


    procedure Set_Odd_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Line : in POSITIVE;
    Footer_Text : in SP.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 > File_Handle.footer_size then
        raise Text_Overflow;
    end if;
    SP.Flush(File_Handle.odd_page_footer(Footer_Line));
    File_Handle.odd_page_footer(Footer_Line) := SP.Make_Persistent(Footer_Text);
    return;

    end Set_Odd_Footer;


    procedure Set_Odd_Footer(
    Footer_Line : in POSITIVE;
    Footer_Text : in STRING
    ) is

    begin

    Set_Odd_Footer(Paginated_Standard_Output,
               Footer_Line,
               Footer_Text);

    end Set_Odd_Footer;


    procedure Set_Odd_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Line : in POSITIVE;
    Footer_Text : in STRING
    ) is

    Text : SP.String_Type;

    begin

    Text := SP.Make_Persistent(Footer_Text);
    Set_Odd_Footer(File_Handle, Footer_Line, Text);
    SP.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;


    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;


    procedure Set_Even_Footer(
    Footer_Line : in POSITIVE;
    Footer_Text : in SP.String_Type
    ) is

    begin

    Set_Even_Footer(Paginated_Standard_Output,
            Footer_Line,
            Footer_Text);

    end Set_Even_Footer;


    procedure Set_Even_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Line : in POSITIVE;
    Footer_Text : in SP.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 > File_Handle.footer_size then
        raise Text_Overflow;
    end if;
    SP.Flush(File_Handle.even_page_footer(Footer_Line));
    File_Handle.even_page_footer(Footer_Line) := SP.Make_Persistent(Footer_Text);
    return;

    end Set_Even_Footer;


    procedure Set_Even_Footer(
    Footer_Line : in POSITIVE;
    Footer_Text : in STRING
    ) is

    begin

    Set_Even_Footer(Paginated_Standard_Output,
            Footer_Line,
            Footer_Text);

    end Set_Even_Footer;


    procedure Set_Even_Footer(
    File_Handle : in Paginated_File_Handle;
    Footer_Line : in POSITIVE;
    Footer_Text : in STRING
    ) is

--|-Algorithm:
--| Create a variable string
--| Set even page footer
--| Exit
--|+
    Text : SP.String_Type;

    begin

    Text := SP.Make_Persistent(Footer_Text);
    Set_Even_Footer(File_Handle, Footer_Line, Text);
    SP.Flush(Text);
    return;

    end Set_Even_Footer;
                                                                    pragma page;
    procedure Clear_Header
    is

    begin

    Clear_Header(Paginated_Standard_Output);

    end Clear_Header;


    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;


    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;


    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;


    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;


    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;


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

    end Close_Paginated_File;


    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;


    procedure Put(
    File_Handle : in Paginated_File_Handle;
    Text        : in CHARACTER
    ) is

    begin

    Write(File_Handle, "" & Text, FALSE);

    end Put;


    procedure Put(
    Text        : in STRING
    ) is

    begin

    Write(Paginated_Standard_Output, Text, FALSE);

    end Put;


    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;


    procedure Put(
    Text        : in SP.String_Type
    ) is

    begin

    Put(Paginated_Standard_Output,
        SP.Value(Text));

    end Put;


    procedure Put(
    File_Handle : in Paginated_File_Handle;
    Text        : in SP.String_Type
    ) is

--|-Algorithm:
--| Create a fixed length string
--| Output the line
--| Exit
--|+

    begin

    Put(File_Handle, SP.Value(Text));
    return;

    end Put;


    procedure Put(
    Text        : in Variable_String_Array
    ) is

    begin

    for i in Text'range loop
        Put(Paginated_Standard_Output, SP.Value(Text(i)));
    end loop;
    return;

    end Put;


    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, SP.Value(Text(i)));
    end loop;
    return;

    end Put;
                                                                    pragma page;
    procedure Space(
    Count       : in NATURAL
    ) is

    begin

    Space(Paginated_Standard_Output,
          Count);

    end Space;


    procedure Space(
    File_Handle : in Paginated_File_Handle;
    Count       : in NATURAL
    ) 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;


    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;


    procedure Put_Line(
    Text_Line   : in SP.String_Type
    ) is

    begin

    Put_Line(Paginated_Standard_Output,
         SP.Value(Text_Line));
    return;

    end Put_Line;


    procedure Put_Line(
    File_Handle : in Paginated_File_Handle;
    Text_Line   : in SP.String_Type
    ) is

--|-Algorithm:
--| Create a fixed length string
--| Output the line
--| Exit
--|+

    begin

    Put_Line(File_Handle, SP.Value(Text_Line));
    return;

    end Put_Line;


    procedure Put_Line(
    Text_Line   : in Variable_String_Array
    ) is

    begin

    for i in Text_Line'range loop
        Put_Line(Paginated_Standard_Output,
             SP.Value(Text_Line(i)));
    end loop;
    return;

    end Put_Line;


    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, SP.Value(Text_Line(i)));
    end loop;
    return;

    end Put_Line;
                                                                    pragma page;
    procedure Space_Line(
    Count       : in NATURAL := 1
    ) is

    begin

    Space_Line(Paginated_Standard_Output,
           Count);

    end Space_Line;


    procedure Space_Line(
    File_Handle : in Paginated_File_Handle;
    Count       : in NATURAL := 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);
    if Count = 0 then
        return;
    end if;
    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 NATURAL := 1
    ) is

    begin

    Skip_Line(Paginated_Standard_Output,
          Count);

    end Skip_Line;


    procedure Skip_Line(
    File_Handle : in Paginated_File_Handle;
    Count       : in NATURAL := 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);
    if Count = 0 then
        return;
    end if;
    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 NATURAL := 1
    ) is

    begin

    Put_Page(Paginated_Standard_Output,
         Count);

    end Put_Page;


    procedure Put_Page(
    File_Handle : in Paginated_File_Handle;
    Count       : in NATURAL := 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);
    if Count = 0 then
        return;
    end if;
    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 NATURAL is

    begin

    return Available_Lines(Paginated_Standard_Output);

    end Available_Lines;


    function Available_Lines(
    File_Handle : in Paginated_File_Handle
    ) return NATURAL 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 0;
    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 NATURAL
    ) is

    begin

    Reserve_Lines(Paginated_Standard_Output,
              Count);

    end Reserve_Lines;


    procedure Reserve_Lines(
    File_Handle : in Paginated_File_Handle;
    Count       : in NATURAL
    ) 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 Count = 0 or 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);

end Paginated_Output;
                                                                    pragma page;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--SCANNERS.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package scanners is    --| Scan tokens from strings

--| Overview
--| This package is used to break strings into tokens in a very simple
--| but efficient manner.  For maximum efficiency, the scanner type
--| is not private so that it can be used directly.  The following
--| conventions are adopted to allow the Ada string handling primitives
--| to be used to maximum advantage:
--|-
--|  1. Strings are never copied.  The scanner type contains First and
--|     Last components so that slices may be used to obtain the desired
--|     tokens (substrings).
--|
--|  2. The scanner type does not include a copy of the string being
--|     scanned, also to avoid copying strings.
--|
--|  3. The Length component of a scanner is always set to the length of the
--|     item scanned.  If it is zero it means that no such item was found,
--|     either because it wasn't there or because the scanner is exhausted.
--|     The is_Empty operation may be used to determint if a scanner is
--|     exhausted (usually before attempting to scan something).
--|
--|  4. All operations have well defined behavior for any consistent input.
--|     There are no exceptions declared in this package or raised directly
--|     by the operations in the package.
--|+

                  -- Types --

type scanner_type is
  record
    Index: natural;    --| Index of next character to be scanned
    Max_Index: natural;    --| Index of last scannable character
    First: natural;    --| Index of first character of the result of a scan
    Last: Natural;    --| Index of last character of the result of a scan
    Length: Natural;    --| Length of the item scanned.
  end record;

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

procedure start_Scanner(        --| Initialize a scanner
    Scanner: in out Scanner_Type;    --| Scanner to be initialized
    S: in string;            --| String to be scanned
    Last: in natural            --| Last scannable character in S.
    );

--| Effects:  Initialize Scanner for scanning S.  S and Last are
--| typically obtained by calling text_io.Get_Line.  The first character
--| scanned will be S'First and the last character scanned will be Last,
--| which will generally be different from S'Last.

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

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

function is_Empty(    --| Return False if Scanner can scan more characters
    Scanner: in Scanner_Type
    ) return boolean;
pragma inline(is_Empty);

--| Effects: Return True iff Scanner.Index > Scanner.Max_Index.
--| N/A: Requires, Modifies, Raises

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

function is_Alpha(    --| Check for alphabetic character
    Scanner: in scanner_Type;
    S: in string
    ) return boolean;
pragma inline(is_Alpha);

--| Effects: Return True iff S(Scanner.Index) is an alphabetic character.
--| Requires: Scanner must have been created on S using start start_Scanner
--| prior to calling this routine.

--| N/A: Modifies, Raises

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

function is_Digit(    --| Check for start of  unsigned number
    Scanner: in scanner_Type;
    S: in string
    ) return boolean;
pragma inline(is_Digit);

--| Effects: Return True iff S(Scanner.Index) is a decimal digit.
--| Requires: Scanner must have been created on S using start start_Scanner
--| prior to calling this routine.

--| N/A: Modifies, Raises

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

function is_Sign(    --| Check for '+' or '-'
    Scanner: in scanner_Type;
    S: in string
    ) return boolean;
pragma inline(is_Sign);

--| Effects: Return True iff S(Scanner.Index) is '+' or '-'
--| Requires: Scanner must have been created on S using start start_Scanner
--| prior to calling this routine.

--| N/A: Modifies, Raises

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

function is_Digit_or_Sign(    --| Check for start of optionally signed number
    Scanner: in scanner_Type;
    S: in string
    ) return boolean;
pragma inline(is_Digit_or_Sign);

--| Effects: Return True iff S(Scanner.Index) is '+', '-', or a decimal digit.
--| Requires: Scanner must have been created on S using start start_Scanner
--| prior to calling this routine.
--| N/A: Modifies, Raises

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

procedure skip_Blanks(    --| Skip leading blanks and tabs in S
    Scanner: in out Scanner_Type;    --| Scanner to be updated
    S: in string            --| String being scanned
    );

--| Effects: Increment Scanner.Index until S(Scanner.Index) is neither a
--| blank nor a tab character, or until it is greater than Scanner.Max_Index.

--| Requires: Scanner must have been created on S using start start_Scanner
--| prior to calling this routine.

--| N/A: Modifies, Raises

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

procedure trim_blanks(
    Scanner: in out Scanner_Type;
    S: in string
    );

--| Effects: Adjust Scanner.First and Scanner.Last such that
--| S(Scanner.First..Scanner.Last) contains neither leading nor trailing
--| blanks or tabs.  Scanner.Length is adjusted accordingly.  This is
--| useful to remove blanks after a call to scan_Delimited, Scan_Quoted,
--| scan_Until, etc.

--| Requires: Scanner must have been created on S using start start_Scanner
--| prior to calling this routine.

--| N/A: Modifies, Raises

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

procedure scan_Until(    --| Scan up to but not including character C
    Scanner: in out Scanner_Type;
    S: in string;
    C: in character
    );

--| Effects: Scan in string S starting at Scanner.Index until the character
--| C is encountered or the string ends.  On return, if Scanner.Length > 0
--| then S(Scanner.First..Scanner.Last) contains the characters that
--| appeared before C and Scanner(Index) = C.  If C was not found, then
--| the scanner is not affected except to set Scanner.Length to 0.

--| Requires: Scanner must have been created on S using start start_Scanner
--| prior to calling this routine.

--| N/A: Modifies, Raises

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

procedure scan_Word(    --| Scan past a sequence of non-blank characters
    Scanner: in out Scanner_Type;
    S: in string
    );

--| Effects: Scan in string S for a sequence of non-blank characters,
--| starting at Scanner.Index.  On return, if Scanner.Length > 0
--| then S(Scanner.First..Scanner.Last) is a word and Scanner.Index is
--| just past the end of the word (Scanner.Last+1), ready to scan the next
--| item.

--| Requires: Scanner must have been created on S using start start_Scanner
--| prior to calling this routine.  The scanner must be at a non blank
--| character (the beginning of a word) or nothing will be scanned.

--| N/A: Modifies, Raises

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

procedure scan_Number(
    Scanner: in out scanner_Type;
    S: in string
    );

--| Effects: Scan in string S for a sequence of numeric characters,
--| optionally preceeded by a sign (+/-), starting at Scanner.Index.  On
--| return, if Scanner.Length > 0 then S(Scanner.First..Scanner.Last) is a
--| number and Scanner.Index is just past the end of the number
--| (Scanner.Last+1), ready to scan the next item.

--| Requires: Scanner must have been created on S using start start_Scanner
--| prior to calling this routine.  Scanner must be positioned at a digit
--| or sign (+/-) when this routine is called or nothing will be scanned.

--| N/A: Modifies, Raises

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

procedure scan_Delimited(    --| Scan string delimited by a single character
    Scanner: in out scanner_Type;
    S: in string
    );

--| Effects: The character S(Scanner.Index) is considered a "quote".
--| Scanner.First is set to the Scanner.Index+1, and Scanner.Index is
--| incremented until another "quote" is encountered or the end of the
--| string is reached.  On return, Scanner.Last is the index of the closing
--| "quote" or the last character in S if no closing "quote" was found.

--| Requires: Scanner must have been created on S using start start_Scanner
--| prior to calling this routine.
--| N/A: Modifies, Raises

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

procedure scan_Quoted(    --| Scan quoted string
    Scanner: in out scanner_Type;
    S: in out string
    );

--| Effects: The character S(Scanner.Index) is considered a "quote".
--| The string S is scanned for a closing "quote".  During the scan,
--| two quotes in a row are replaced by a single quote.  On return,
--| Scanner.First is the first character of the quoted string, and
--| Scanner.Last is the last character.  (The outermost quotes are
--| not included.)  Scanner.Index is the first character after the
--| closing quote, Scanner.Length is the number of characters in the
--| quoted string.  Note that the string being scanned (S) is modified
--| by this routine (to remove the extra quotes, if any).

--| Requires: Scanner must have been created on S using start start_Scanner
--| prior to calling this routine.

--| N/A: Modifies, Raises

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

end scanners;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--SCANNERS.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package body scanners is    --| Scan tokens from strings

----------------------------------------------------------------------------
-- Local function specs:

function is_Space(C: Character) return boolean;
--| Return True iff C is a space or tab.
pragma inline(is_Space);

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

procedure start_Scanner(    --| Initialize a scanner
    Scanner: in out Scanner_Type;    --| Scanner to be initialized
    S: in string;            --| String to be scanned
    Last: in natural            --| Last scannable character in S.
    )
is

begin
    Scanner.Index := S'First;
    Scanner.Max_Index := Last;
    Scanner.First := 1;
    Scanner.Last := 0;
    Scanner.Length := 0;

end start_Scanner;

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

function is_Empty(    --| Return False if Scanner can scan more characters
    Scanner: in Scanner_Type
    ) return boolean is

begin
    return Scanner.Index > Scanner.Max_Index;

end is_Empty;

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

function is_Alpha(    --| Check for alphabetic character
    Scanner: in scanner_Type;
    S: in string
    ) return boolean is

begin
    return Scanner.Index <= scanner.Max_Index and then
       (S(Scanner.Index) in 'a'..'z' or else
       S(Scanner.Index) in 'A'..'Z');

end is_Alpha;

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

function is_Digit(    --| Check for start of  unsigned number
    Scanner: in scanner_Type;
    S: in string
    ) return boolean is

begin
    return Scanner.Index <= scanner.Max_Index and then
           S(Scanner.Index) in '0'..'9';

end is_Digit;

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

function is_Sign(    --| Check for '+' or '-'
    Scanner: in scanner_Type;
    S: in string
    ) return boolean is

begin
    return Scanner.Index <= scanner.Max_Index and then
       (S(Scanner.Index) = '+' or else S(Scanner.Index) = '-');

end is_Sign;

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

function is_Digit_or_Sign(    --| Check for start of optionally signed number
    Scanner: in scanner_Type;
    S: in string
    ) return boolean is

begin
    return Scanner.Index <= scanner.Max_Index and then
       (S(Scanner.Index) in '0'..'9'
       or else S(Scanner.Index) = '+' or else S(Scanner.Index) = '-');

end is_Digit_or_Sign;


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

procedure skip_Blanks(    --| Skip leading blanks in S
    Scanner: in out Scanner_Type;    --| Scanner to be updated
    S: in string            --| String being scanned
    ) is

begin
    Scanner.First := Scanner.Index;
    Scanner.Length := 0;
    if Scanner.Index <= Scanner.Max_Index then
      while is_Space(S(Scanner.Index)) loop
    Scanner.Index := Scanner.Index + 1;
    exit when Scanner.Index > Scanner.Max_Index;
      end loop;
      Scanner.Length := Scanner.Index - Scanner.First;
    end if;

end skip_Blanks;

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

procedure trim_blanks(
    Scanner: in out Scanner_Type;
    S: in string
    ) is
begin
    while Scanner.First < Scanner.Last and then is_Space(S(Scanner.First)) loop
    Scanner.First := Scanner.First + 1;
    end loop;
    while Scanner.Last >= Scanner.First and then is_Space(S(Scanner.Last)) loop
    Scanner.Last := Scanner.Last - 1;
    end loop;
    Scanner.Length := Scanner.Last - Scanner.First + 1;

end trim_Blanks;

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

procedure scan_Until(    --| Scan until C is found
    Scanner: in out Scanner_Type;
    S: in string;
    C: in character
    )
is
    Index: natural := Scanner.Index;

begin
    Scanner.Length := 0;
    if Index <= Scanner.Max_Index then
      while S(Index) /= C loop
    Index := Index + 1;
    if Index > Scanner.Max_Index then    -- Didn't find C
      return;
    end if;
      end loop;
      Scanner.First := Scanner.Index;    -- First character scanned
      Scanner.Length := Index - Scanner.First;
      Scanner.Last := Index - 1;
      Scanner.Index := Index;
    end if;

end scan_Until;

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

procedure scan_Word(    --| Scan past a sequence of non-blank characters
    Scanner: in out Scanner_Type;
    S: in string
    ) is

begin
    Scanner.First := Scanner.Index;
    Scanner.Last := Scanner.First - 1;
    Scanner.Length := 0;
    if Scanner.Index <= Scanner.Max_Index then
      while not is_Space(S(Scanner.Index)) loop
    Scanner.Index := Scanner.Index + 1;
    exit when Scanner.Index > Scanner.Max_Index;
      end loop;
      Scanner.Length := Scanner.Index - Scanner.First;
      Scanner.Last := Scanner.Index - 1;
    end if;

end scan_Word;

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

procedure scan_Number(
    Scanner: in out scanner_Type;
    S: in string
    ) is

begin
    Scanner.First := Scanner.Index;
    if Scanner.Index <= Scanner.Max_Index then
      if S(Scanner.Index) = '-' or else S(Scanner.Index) = '+' then
    Scanner.Index := Scanner.Index + 1;
      end if;
      while Scanner.Index <= Scanner.Max_Index
        and then S(Scanner.Index) in '0'..'9'
      loop
    Scanner.Index := Scanner.Index + 1;
      end loop;
    end if;
    Scanner.Length := Scanner.Index - Scanner.First;
    Scanner.Last := Scanner.Index - 1;

end scan_Number;

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

procedure scan_Delimited(    --| Scan string delimited by a single character
    Scanner: in out scanner_Type;
    S: in string
    )
is
    quote: character;

begin
    Scanner.First := Scanner.Index;
    if Scanner.Index <= Scanner.Max_Index then
    quote := S(Scanner.Index);
    Scanner.Index := Scanner.Index + 1;
    Scanner.First := Scanner.Index;
    while Scanner.Index <= Scanner.Max_Index
          and then S(Scanner.Index) /= quote
    loop
      Scanner.Index := Scanner.Index + 1;
    end loop;
    end if;
    Scanner.Length := Scanner.Index - Scanner.First;
    Scanner.Last := Scanner.Index - 1;
    if Scanner.Index <= Scanner.Max_Index
    and then S(Scanner.Index) = quote then    -- Null string?
    Scanner.Index := Scanner.Index + 1;
    end if;

end scan_Delimited;

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

procedure scan_Quoted(    --| Scan quoted string
    Scanner: in out scanner_Type;
    S: in out string
    )
is
    quote: character;
    di: natural;

begin
    Scanner.First := Scanner.Index;
    di := Scanner.Index;
    if Scanner.Index <= Scanner.Max_Index then
    quote := S(Scanner.Index);
    Scanner.Index := Scanner.Index + 1;
    Scanner.First := Scanner.Index;
    di := scanner.Index;
    while Scanner.Index <= Scanner.Max_Index loop
       if S(Scanner.Index) = quote then    -- Closing quote?
        if Scanner.Index < Scanner.Max_Index
        and then S(Scanner.Index + 1) = quote then    -- Doubled quote?
        Scanner.Index := Scanner.Index + 1;    -- skip it
        else
        exit;    -- Found closing quote at Scanner.Index
        end if;
      end if;
      S(di) := S(Scanner.Index);
      Scanner.Index := Scanner.Index + 1;
      di := di + 1;
    end loop;
    end if;
    Scanner.Length := di - Scanner.First;
    Scanner.Last := di - 1;
    Scanner.Index := Scanner.Index + 1;    -- Skip closing quote

end scan_Quoted;

----------------------------------------------------------------------------
-- Local function bodies:

function is_Space(C: Character) return boolean is
--| Return True iff C is a space or tab.
begin
    return C = ' ' or else C = ASCII.HT;

end is_Space;

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

end scanners;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--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;
with case_insensitive_string_comparison;

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 CISC renames case_insensitive_string_comparison;

    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.

    current_comparison_option: comparison_option := case_sensitive;

    -- 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 string_lower(s: string)
    return string;

      --| Effects:
      --| Return a string with the same bounds and contents as s, with the
      --| exception that all upper case characters are replaced with their
      --| lower case counterparts.

    function string_upper(s: string)
    return string;

      --| Effects:
      --| Return a string with the same bounds and contents as s, with the
      --| exception that all lower case characters are replaced with their
      --| upper case counterparts.

    function string_equal(s1, s2: string)
    return boolean;

      --| Effects:
      --| If current_comparison_option = case_sensitive, then return
      --| (s1 = s2); otherwise, return string_lower(s1) = string_lower(s2).

    function string_less(s1, s2: string)
    return boolean;

      --| Effects:
      --| If current_comparison_option = case_sensitive, then return
      --| (s1 < s2); otherwise, return string_lower(s1) < string_lower(s2).

    function string_less_or_equal(s1, s2: string)
    return boolean;

      --| Effects:
      --| If current_comparison_option = case_sensitive, then return
      --| (s1 <= s2); otherwise, return string_lower(s1) <= string_lower(s2).

    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));
    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) + 1 then raise bounds; end if;

    if s1 = null then return create(value(s2)); end if;
    if s2 = null 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) + 1 then raise bounds; end if;
    if s1 = null then return create(s2); 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 i not in s1'first..s1'last + 1 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
    begin
    return create(string_lower(s));
    end lower;

    function lower(s: string_type)
    return string_type is
    begin
    if s = null then return null; end if;
    return create(string_lower(s.all));
    end lower;

    function upper(s: string)
    return string_type is
    begin
    return create(string_upper(s));
    end upper;

    function upper(s: string_type)
    return string_type is
    begin
    if s = null then return null; end if;
    return create(string_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);
        dec_s: constr_str := s;
    begin
    if dec_s = "" then return null;
        else return new constr_str'(dec_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 (i not in s'range) then raise bounds; end if;
        return s(i);
    end fetch;

    procedure set_comparison_option(choice: comparison_option) is
    begin
    current_comparison_option := choice;
    end set_comparison_option;

    function get_comparison_option
    return comparison_option is
    begin
    return current_comparison_option;
    end get_comparison_option;

    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 string_equal(s1.all, s2.all);
    end equal;

    function equal(s1: string_type; s2: string)
        return boolean is
    begin
    if s1 = null then return s2 = ""; end if;
        return string_equal(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 string_equal(s1, s2.all);
    end equal;

    function "<"(s1, s2: string_type)
        return boolean is
    begin
        if is_empty(s1) then
        return (not is_empty(s2));
    else
        return (s1.all < s2);
    end if;
    end "<";

    function "<"(s1: string_type; s2: string)
        return boolean is
    begin
    if s1 = null then return s2 /= ""; end if;
        return string_less(s1.all, s2);
    end "<";

    function "<"(s1: string; s2: string_type)
        return boolean is
    begin
    if s2 = null then return false; end if;
        return string_less(s1, s2.all);
    end "<";

    function "<="(s1, s2: string_type)
        return boolean is
    begin
    if is_empty(s1) then return true; end if;
    return (s1.all <= s2);
    end "<=";

    function "<="(s1: string_type; s2: string)
        return boolean is
    begin
    if s1 = null then return true; end if;
        return string_less_or_equal(s1.all, s2);
    end "<=";

    function "<="(s1: string; s2: string_type)
        return boolean is
    begin
    if s2 = null then return s1 = ""; end if;
        return string_less_or_equal(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 string_lower(s: string)
    return string is

    begin
    return CISC.downCase(S);

    end string_lower;

    function string_upper(s: string)
    return string is

    begin
    return CISC.upCase(S);

    end string_upper;

    function string_equal(s1, s2: string)
    return boolean is
    begin
    if current_comparison_option = case_sensitive then
        return s1 = s2;
    else
        return CISC.equal(S1, S2);
    end if;

    end string_equal;

    function string_less(s1, s2: string)
    return boolean is
    begin
    if current_comparison_option = case_sensitive then
        return s1 < s2;
    else
        return CISC.less(S1, S2);
    end if;

    end string_less;

    function string_less_or_equal(s1, s2: string)
    return boolean is
    begin
    if current_comparison_option = case_sensitive then
        return s1 <= s2;
    else
        return CISC.less_or_equal(S1, S2);
    end if;

    end string_less_or_equal;

    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;


--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--TERMIO.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-------------------------------------------------------------------------------
with HOST_LIB;

package Terminal_IO is
--| Video terminal input/output for various kinds of terminals

--| Overview
--| This package provides a set of functions for interacting with
--| a video terminal.  The terminal type is specified in a call to
--| Initialize.  All output is to the file STANDARD_OUTPUT.  All input
--| is from the file STANDARD_INPUT.
--|
--|-For output, three functions are provided:
--|
--|   clear_line()    Clears from the cursor to the end of line
--|   clear_screen()    Clears from the cursor to the end of screen
--|   set_cursor(R, C)     Place cursor at row R, column C
--|
--| For input, two functions are provided:
--|
--|   read()        Reads a line from the terminal, with echo
--|   blind_read()    Reads a line from the terminal without echo
--|
--| The following queries are provided:
--|
--|   max_row()        Returns the number of rows on the screen
--|   max_column()    Returns the number of columns on the screen

--|-Notes

--| 1. This package is designed to be as simple as possible.  Functionality
--|    is limited to the "lowest common denominator".
--|
--| 2. Since TEXT_IO is used for output of data, this package cannot
--|    track the cursor position at all times.  Since many terminals cannot
--|    report the current cursor position, no query for the current cursor
--|    position is provided.  Users should position the cursor immediately
--|    before reading from or writing to the terminal.

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

Unsupported_Terminal : exception;
--| Raised if initialize called with an unsupported terminal type.

End_of_File_Error    : exception;
--| Raised if End_Error is raised while reading from the terminal.

subtype Terminal_Type is host_lib.Terminal_Type;

---------------------------------------------------------------------------
-- Initialization (and finalization?) --
---------------------------------------------------------------------------

procedure Initialize(    --| Initialize the terminal
    Terminal: in Terminal_Type
    ); --| Raises: Unsupported_Terminal.


--| Effects: Sets the terminal type for subsequent operations to terminal
--| type.  If Terminal denotes a terminal for which the remaining functions
--| in this package cannot be or are not supported, the exception
--| Unsupported_Terminal is raised.

---------------------------------------------------------------------------
-- Output primitives --
---------------------------------------------------------------------------

procedure Clear_Line;
--| Clear from the cursor to the end of the current line, inclusive.

--| Effects: Clears from the cursor to the end of the current line,
--| inclusive.

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

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

procedure Clear_Screen;
--| Clear the screen from current cursor position.

--| Effects: Clears the screen starting at the current cursor
--| position to the end of the screen, inclusive.

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

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

procedure Set_Cursor(  --| Move the cursor
    Row: in positive;
    Column: in positive
    );

--| Effects:  Positions the cursor at the line and column specified
--| by (Row, Column).  (1, 1) is the upper left corner of the screen.
--| If Row or Column is beyond the edge of the screen, the cursor is
--| placed at the last row and/or column.

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

---------------------------------------------------------------------------
-- Input Primitives --
---------------------------------------------------------------------------

function read        --| Read a line from the terminal
    return STRING;
    --| Raises: End_of_File_Error

--| Effects: A line of text is read from the file STANDARD_INPUT.
--| Characters are echoed as they are typed, and any line-editing
--| functions supported by the host OS (eg. backspace) may be used.
--| End_of_File_Error is raised if End_Error is raised while reading.

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


function blind_read    --| Read a line from the terminal with no echo
    return STRING;
    --| Raises: End_of_File_Error

--| Effects: A line of text is read from the file STANDARD_INPUT.
--| Characters are NOT echoed as they are typed, but any line-editing
--| functions supported by the host OS (eg. backspace) may be used.
--| End_of_File_Error is raised if End_Error is raised while reading.

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

---------------------------------------------------------------------------
-- Queries --
---------------------------------------------------------------------------

function max_row    --| Return the number of rows on the screen
    return positive;

--| Effects: Return the number of lines available on the current terminal.
--| N/A: Raises, Requires, Modifies, Errors

function max_column    --| Return the number of columns on the screen
    return positive;

--| Effects: Return the number of columns available on the current terminal.
--| N/A: Raises, Requires, Modifies, Errors

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

end Terminal_IO;

---------------------------------------------------------------------------
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--TERMIO.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-------------------------------------------------------------------------------

with string_pkg; use string_pkg;
with TEXT_IO; use TEXT_IO;

package body Terminal_IO is
--| Video terminal input/output for various kinds of terminals

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

use ASCII;
use host_Lib;

type Internal_Terminal_Type is (VT100_like, VT52_like, UNSUPPORTED);
--| All terminals this package knows about internally

subtype supported_Terminals is Internal_Terminal_Type
    range VT100_like .. VT52_like;

type Terminal_Type_Array is array (Terminal_Type) of Internal_Terminal_Type;

terminal_Equivalance_array: Terminal_Type_Array := Terminal_Type_Array'(
  VT52 => VT52_like,
  VT100 | VT101 | VT102 | VT105 | VT125 | VT131 | VT132 | VT200_SERIES
    => VT100_like,
  others => UNSUPPORTED
  );

type terminal_descriptor is record
    max_rows: positive;        --| Number of rows on screen
    max_cols: positive;        --| Number of columns on screen
    clear_line: string_type;    --| Code sequence to clear to end of line
    clear_screen: string_type;    --| Code sequence to clear to end of string
    motion_prefix: string_type;    --| Initial code sequence for moving cursor
    -- Cursor positioning depends on both terminal type and (R, C) and is
    -- difficult to encode.
end record;

subtype input_string_range is positive range 1..256;

terminal_descriptions:
  array (Supported_Terminals) of terminal_descriptor := (
    VT100_Like => (
    max_rows => 24,
    max_cols => 80,
    clear_line => Create(esc & "[K"),
    clear_screen => Create(esc & "[J"),
    motion_prefix => Create(esc & "[")
    ),
    VT52_Like => (
    max_rows => 24,
    max_cols => 80,
    clear_line => Create(esc & "K"),
    clear_screen => Create(esc & "J"),
    motion_prefix => Create(esc & "Y")
    )
    );

current_terminal: internal_terminal_type := VT100_Like;
--| Current terminal type

---------------------------------------------------------------------------
-- Local subprograms --
---------------------------------------------------------------------------

procedure Send(S: string_type) is
--| Send a string to the terminal

begin
  PUT(value(S));
end Send;

procedure Send(S: string) is
--| Send a string to the terminal

begin
  PUT(S);
end Send;

procedure Send(C: character) is
--| Send a single character to the terminal

begin
  PUT(C);
end Send;

---------------------------------------------------------------------------
-- Initialization (and finalization?) --
---------------------------------------------------------------------------

procedure Initialize(Terminal: in Terminal_Type) is
--| Sets terminal to terminal type

begin

  if terminal_Equivalance_array(Terminal) = UNSUPPORTED then
    raise Unsupported_Terminal;
  end if;
  current_terminal :=  terminal_Equivalance_array(Terminal);

end Initialize;

---------------------------------------------------------------------------
-- Output primitives --
---------------------------------------------------------------------------

procedure Clear_Line is
--| Clears from the cursor to the end of the current line, inclusive.
--| N/A: Raises, Requires, Modifies, Errors

begin

  send(terminal_descriptions(current_terminal).clear_line);

end clear_line;

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

procedure Clear_Screen is
--| Clears the screen from current cursor position.
--| N/A: Raises, Requires, Modifies, Errors

begin

  send(terminal_descriptions(current_terminal).clear_screen);

end clear_screen;

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

procedure Set_Cursor(  --| Move the cursor
    Row: in positive;
    Column: in positive
    ) is

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


begin

  send(terminal_descriptions(current_terminal).motion_prefix);
  case current_terminal is
    when VT100_Like =>
    send(positive'image(Row)(2..positive'image(Row)'last));
    send(';');
    send(positive'image(Column)(2..positive'image(Column)'last));
    send(";f");
    when VT52_Like =>
    send(character'val(character'pos(' ') - 1 + Row));
    send(character'val(character'pos(' ') - 1 + Column));
    when others =>
        null;
  end case;

end set_cursor;

---------------------------------------------------------------------------
-- Input Primitives --
---------------------------------------------------------------------------

function read        --| Read a line from the terminal
    return STRING is
    --| Raises: End_of_File_Error

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

  S: string(input_string_range);
  L: natural;

begin

  get_line(S, L);
  return S(S'First..L);

exception

  when End_Error =>
    raise End_of_File_Error;
  when Use_Error =>
    return "";

end read;

function blind_read    --| Read a line from the terminal with no echo
    return STRING is
    --| Raises: End_of_File_Error

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

begin

  return HOST_LIB.Read_No_Echo;

exception

    when End_Error =>
      raise End_of_File_Error;
    when Use_Error =>
      return "";

end blind_read;

---------------------------------------------------------------------------
-- Queries --
---------------------------------------------------------------------------

function max_row    --| Return the number of rows on the screen
    return positive is
--| N/A: Raises, Requires, Modifies, Errors

begin

  return terminal_descriptions(current_terminal).max_rows;

end max_row;

function max_column    --| Return the number of columns on the screen
    return positive is
--| N/A: Raises, Requires, Modifies, Errors

begin

  return terminal_descriptions(current_terminal).max_cols;

end max_column;

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

end Terminal_IO;

---------------------------------------------------------------------------
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--ILISTS.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with Lists;

package Integer_Lists is new Lists(
        ItemType => INTEGER);

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--SINTF.SPC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with String_Pkg;
with String_Lists;
with Integer_Lists;
with Lists;
with Paginated_Output;

package Standard_Interface is        --| Standard interface package

--| Overview
--| This package is used to:
--|-
--|   1. parse a line of arguments expressed in Ada (valid Ada is accepted but
--|      may not be required depending on the set of switches defined below)
--|   2. create a paginated output file with a standardized header and/or footer
--|      text(s) and page size
--|+
--| Given a specification of the arguments to be parsed, the subprogram
--| Parse_Line parses a given line.  If there were errors, they are reported*
--| on the current output and a description* of valid input is given and
--| Abort_Process exception is raised.  If there are no errors, the process
--| and argument(s) are echoed* to current output using named parameter
--| associations, showing the values of every parameter, even those that were
--| defaulted.  A prompt* is given to continue with the process or to abort by
--| raising Abort_Process exception.
--|-
--|    * : These operations are controlled by switches
--|+
--| If Parse_Line is successful (returns TRUE), a subprogram Get_Argument may
--| be called to obtain the value of an argument by its named association.
--| Six types of arguments are supported :
--| integer, string, enumeration, list of integers, list of strings, and list
--| of enumeration values.
--|
--| Generic package Command_Line is provided for parsing an enumerated set
--| of commands and their corresponding arguments.
--|
--| Generic packages Enumerated_Argument, Emunerated_List_Argument,
--| Integer_Argument, Integer_List_Argument, and String_List_Argument
--| are provided for arguments which are enumeration type, list of enumeration
--| type, integer subtype (ie. range), list of integer subtype, and list of
--| string type, respectively.  These package must be instantiated with proper
--| types to obtain the appropriate subprograms for a given type.
--|
--| The subprogram Define_Output returns a paginated file handle to be used for
--| subsequent output operations, or will create a paginated output file and
--| set the current paginated output file to be the specified file.
--|
--|
--| The syntax of a process is specified by providing the following information:
--|-
--|   1. Name of the process
--|   2. General help pertaining to this process (optional)
--|   3. For each argument
--|      a. Name - a string
--|      b. Help - a string (optional)
--|      c. Default value - type of argument being defined (optional)
--|   4. Any other text to appear in the help message (optional)
--|+
                                                                    pragma page;
--| Notes:
--|-
--|      The format of the standard header is :
--|
--|           +------------------------- // -------------------------+
--|           |            (intentionally left blank)                |
--|           +------------------------- // -------------------------+
--|           | Standard Header (ie. Name, Date, Time, Page)         |
--|           +------------------------- // -------------------------+
--|           | User Defined Non-standard Header 1                   |
--|           +------------------------- // -------------------------+
--|           |                                                      |
--|           -                                                      -
--|           |                                                      |
--|           +------------------------- // -------------------------+
--|           | User Defined Non-standard Header n                   |
--|           +------------------------- // -------------------------+
--|           |            (intentionally left blank)                |
--|           +------------------------- // -------------------------+
--|           | (First line of text)                                 |
--|           |                                                      |
--|
--|                 where n may be 0 to 9
--|+
--| Goals
--|- 1. It should be easy to write the definition of a command line
--|  2. It should be easy for the user to type commands
--|  3. It should accept valid Ada (but not require it)
--|  4. Handle ALL aspects of parsing, reporting errors, etc.
--|  5. Use not limited to command line parsing
--|+
                                                                    pragma page;
----------------------------------------------------------------

package SL renames String_Lists;

package SP renames String_Pkg;

package IL renames Integer_Lists;

package PO renames Paginated_Output;

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

type Process_Handle is limited private;
            --| Holds all command and parameter information
subtype Size is INTEGER range 0 .. 9;
            --| Non standard header size
subtype Number is INTEGER range 1 .. Size'last;
            --| Non standard header number
type Switch is (ON, OFF);
            --| Switch (boolean) variable

type Parsing_Checks is (    --| Parsing switches
    Ending_Delimiter,
    Argument_Enclosure,
    Quote_Enclosure );

type Action_Checks is (        --| Action switches
    Show_Help,
    Show_Error,
    Show_Help_on_Error,
    Echo_Command,
    Prompt_for_Reply );

type Command_Checks is (    --| Command action switches
    Show_Help,
    Show_Error,
    Show_Help_on_Null,
    Show_Help_on_Error);

-----------------------   Parsing Switches   -----------------------------------

Parsing_Switches : array (Parsing_Checks) of Switch :=

    --| The elements of the Parsing_Switches may be changed to control
    --| parsing actions.  Setting these switches OFF will relax parsing
    --| stipulations but may result in ambiguities.

    (Ending_Delimiter   => ON,    --| Check for ending delimiter
     Argument_Enclosure => ON,    --| Check for enclosing charactrers
     Quote_Enclosure    => ON);    --| Check strings enclosing quotes

-----------------------   Action Switches   ------------------------------------

Action_Switches  : array (Action_Checks) of Switch :=

    --| The elements of the Action_Switches may be changed to control
    --| actions taken by the standard interface.

    (Show_Help          => ON,    --| Display help message if no argument(s)
     Show_Error         => ON,    --| Display message on detecting error(s)
     Show_Help_on_Error => ON,    --| Display Help message on error(s)
     Echo_Command       => ON,    --| Echo arguments
     Prompt_for_Reply   => OFF);    --| Prompt to continue/abort

-----------------------   Command Switches   -----------------------------------

Command_Switches  : array (Command_Checks) of Switch :=

    --| The elements of the Command_Switches may be changed to control
    --| actions taken by the standard interface command parser.

    (Show_Help          => ON,    --| Display command help message
     Show_Error         => ON,    --| Display message on detecting error(s)
     Show_Help_on_Null  => OFF,    --| Display help when no command is entered
     Show_Help_on_Error => OFF);    --| Display help message on command error

-----------------------   Parsing Strings   ------------------------------------

Delimiter : SP.String_Type :=        --| Argument seperator
    SP.Make_Persistent(",");

--| Delimiter string defines a set of characters that are recognized as
--| argument delimiters.
--| To change the delimiter characters
--|     SP.Flush(Delimiter);                    -- free storage
--|     Delimiter := SP.Make_Persistent("|/");  -- | and / as a delimiters
--| The default delimiter character is ","

Assignment : SP.String_Type :=        --| Assignment string
    SP.Make_Persistent("=>");

--| Assignment string defines a string that is recognized as an assigment
--| indicator.  To change the assigment string follow procedures shown
--| for changing delimiter characters.
--| The default assignment string is "=>"

Left_Enclosure  : CHARACTER := '(';    --| Argument/list left enclosure

Right_Enclosure : CHARACTER := ')';    --| Argument/list right enclosure

End_Delimiter   : CHARACTER := ';';    --| Ending delimiter

--| Left_Enclosure, Right_Enclosure, and End_Delimiter may be changed by
--| simple character assigment.  The defaults are "(", ")", and ";" respectively

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

Duplicate_Name    : exception;    --| Raised if an attempt is made to define
                --| an existing argument
Invalid_Name      : exception;    --| Raised if the specified name (prcoess or
                --| argument) is not an Ada identifier
Undefined_Name    : exception;    --| Raised if attempt is made to obtain the
                --| value of an argument that was not defined
Uninitialized     : exception;    --| Raised if operation is attempted with an
                --| uninitialized handle
Already_Exists    : exception;    --| Raised if a handle to be assigned is
                --| already initialized
Invalid_Kind      : exception;    --| Raised if information sought is not
                --| pertinent to the named argument
Not_Yet_Parsed    : exception;    --| Raised if information is sought before
                --| (command) line is parsed
Already_Parsed    : exception;    --| Raised if attempt is made to define an
                --| object after (command) line is parsed
Invalid_Type      : exception;    --| Raised if the integer subtype instantiation
                --| is invalid
Abort_Process     : exception;    --| Raised if error(s) is detected or abort is
                --| requested (via reply to a prompt)
Process_Help      : exception;    --| Raised if the Help message is printed
                --| (by other than error conditions)
No_Default        : exception;    --| Raised if a request is made for a default
                --| value where non was defined
Abort_Command     : exception;    --| Raised if command error(s) is detected

Command_Help      : exception;    --| Raised if the predefined HELP command is
                --| entered
Command_Exit      : exception;    --| Raised if the predefined EXIT command is
                --| entered
No_Command        : exception;    --| Raised if no command is entered

Identifier_Error  : exception;    --| Tool identifier has not been set or
                --| set more than once
Internal_Error    : exception;    --| Raised for internal errors
                                                                    pragma page;
----------------------------------------------------------------

procedure Set_Tool_Identifier(        --| Set identifier
    Identifier : in STRING        --| Identifier string
    );
    --| Raises: Identifier_Error

--| Effects:
--| Sets the tool identifier to be displayed in the help message.

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

function Get_Tool_Identifier        --| Get identifier
    return STRING;
    --| Raises: Identifier_Error

--| Effects:
--| Gets the tool identifier.

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

procedure Define_Process(        --| Define a process
    Name    : in     STRING;        --| Process name
    Help    : in     STRING;        --| Explanation of process
    Proc    : in out Process_Handle    --| Process handle
    );
    --| Raises: Already_Exists, Invalid_Name, Already_Parsed, Identifier_Error

--| Effects:
--| Defines the name of the process for use in displaying help or echoing
--| the actual parameters.  Return value is the internal representation
--| of the process definition.

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

procedure Redefine_Process(        --| Redefine a process
    Proc : in Process_Handle        --| Process handle
    );
    --| Raises: Uninitialized

--| Effects:
--| Re-defines the process after parsing so that another line may be parsed
--| using the same process handle

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

procedure Undefine_Process(        --| Delete process structure
    Proc : in out Process_Handle    --| Process handle
    );

--| Effects:
--| Deletes the process and its associated argument definitions and frees
--| storage used.

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

procedure Define_Process_Name(        --| Provide general help
    Proc    : in Process_Handle;    --| Process being defined
    Name    : in STRING            --| Process name
    );
    --| Raises: Uninitialized, Invalid_Name, Already_Parsed

--| Effects:
--| Override current process name in the internal process representatio

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

procedure Define_Process_Help(        --| Provide general help
    Proc : in Process_Handle;        --| Process being defined
    Help : in STRING
    );
    --| Raises: Uninitialized, Already_Parsed

--| Effects:
--| Define Help message internally stored for output if errors are
--| detected.

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

procedure Append_Process_Help(        --| Provide general help
    Proc : in Process_Handle;        --| Process being defined
    Help : in STRING
    );
    --| Raises: Uninitialized, Already_Parsed

--| Effects:
--| Appends to the Help message internally stored

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

procedure Define_Help(            --| Provide general help
    Proc : in Process_Handle;        --| Process being defined
    Help : in STRING
    );
    --| Raises: Uninitialized, Already_Parsed

--| Effects:
--| Define general Help message for output in the help message

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

procedure Append_Help(            --| Provide general help
    Proc : in Process_Handle;        --| Process being defined
    Help : in STRING
    );
    --| Raises: Uninitialized, Already_Parsed

--| Effects:
--| Appends to the general Help message internally stored.

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

procedure Parse_Line(            --| Parse the command line arguments
    Proc : in Process_Handle        --| Porcess defined
    );
    --| Raises: Uninitialized, Already_Parsed, Abort_Process, Process_Help

--| Effects:
--| Parse the commmand line according the process specification given by the
--| process handle.
--| Error message, help message, echoing, and/or prompt depends on the switches.
--| If any errors are detected (regardless of the above switches) Abort_Process
--| exception will be raised.
--|
--| Errors
--| The following errors are detected:
--|-
--|  1. Invalid command line syntax (eg. missing semicolon)
--|  2. Wrong type of argument supplied
--|  3. Required argument missing
--|  3. Value not in range (for integer and enumeration types)
--|+

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

procedure Parse_Line(            --| Parse the line arguments
    Proc : in Process_Handle;        --| Process being defined
    Line : in STRING            --| Parameters to be parsed
    );
    --| Raises: Uninitialized, Already_Parsed, Abort_Process, Process_Help

--| Effects:
--| Parse the given line according the process specification given by the
--| process handle.
--| Error message, help message, echoing, and/or prompt depends on the switches.
--| If any errors are detected (regardless of the above switches) Abort_Process
--| exception will be raised.
--|
--| Errors
--| The following errors are detected:
--|-
--|  1. Invalid line syntax (eg. missing semicolon)
--|  2. Wrong type of argument supplied
--|  3. Required argument missing
--|  3. Value not in range (for integer and enumeration types)
--|+

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

procedure Show_Help(
    Proc : in Process_Handle
    );
    --| Raises: Uninitialized

--| Effects:
--| Outputs the general Help message.

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

procedure Echo_Process(
    Proc : in Process_Handle
    );

    --| Raises: Uninitialized, Not_Yet_Parsed

--| Effects:
--| Outputs the "echo" of the process arguments.

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

function Continue(
    Proc : in Process_Handle
    ) return BOOLEAN;

    --| Raises: Uninitialized, Not_Yet_Parsed

--| Effects:
--| Prompts for a reply to continue or abort.
--| Returns TRUE if the reply was to continue, FALSE otherwise.

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

procedure Define_Output(        --| Define paginated output
    Proc        : in Process_Handle;    --| Process handle
    File_Name   : in STRING;        --| File name
    Header_Size : in Size := 0;        --| Size of the user defined header
    Paginate    : in BOOLEAN := TRUE    --| Pagination switch
    );
    --| Raises: Paginated_Output.File_Already_Open, Paginated_Output.File_Error,
    --|         Paginated_Output.Page_Layout_Error;

--| Effects:
--| Create a paginated output file with File_Name and set paginated standard
--| output to this file

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

procedure Define_Output(        --| Define paginated output
    Proc        : in     Process_Handle;--| Process handle
    File_Name   : in     STRING;    --| File name
    Header_Size : in     Size := 0;    --| Size of the user defined header
    File_Handle : in out PO.Paginated_File_Handle;
                    --| Handle to paginated file
    Paginate    : in     BOOLEAN := TRUE--| Pagination switch
    );
    --| Raises: Paginated_Output.File_Already_Open, Paginated_Output.File_Error,
    --|         Paginated_Output.Page_Layout_Error;

--| Effects:
--| Create a paginated output file with File_Name and return a handle

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

procedure Define_Header(        --| Define non standard header
    Line : in Number;            --| Line number of the header
    Text : in STRING            --| Header text
    );
    --| Raises: Paginated_Output.Invalid_File, Paginated_Output.Text_Overflow,

--| Effects:
--| Defines the Line'th line of the non standard header.

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

procedure Define_Header(        --| Define non standard header
    File_Handle : in PO.Paginated_File_Handle;
                    --| Handle to paginated file
    Line        : in Number;        --| Line number of the header
    Text        : in STRING        --| Header text
    );
    --| Raises: Paginated_Output.Invalid_File, Paginated_Output.Text_Overflow,

--| Effects:
--| Defines the Line'th line of the non standard header.

----------------------------------------------------------------
                                                                    pragma page;
generic

    type Enum_Type is (<>);
    Enum_Type_Name : STRING;

package Enumerated_Argument is

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

    procedure Define_Argument(        --| Define an input argument
    Proc    : in Process_Handle;    --| Process being defined
    Name    : in STRING;        --| Name of the argument
    Help    : in STRING        --| Explanation of the argument
    );
    --| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Each time this procedure is called, it defines a new
    --| process argument; the first call defines the first argument,
    --| the second the second argument, etc.  Exceptions are raised if
    --| a duplicate name is defined.

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

    procedure Define_Argument(        --| Define an input argument
    Proc    : in Process_Handle;    --| Process being defined
    Name    : in STRING;        --| Name of the argument
    Default : in Enum_Type;        --| Default value
    Help    : in STRING        --| Explanation of the argument
    );
    --| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Each time this procedure is called, it defines a new
    --| process argument; the first call defines the first argument,
    --| the second the second argument, etc.  Exceptions are raised if
    --| a duplicate name is defined.

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

    procedure Define_Argument_Help(    --| Provide general help
    Proc : in Process_Handle;    --| Process handle
    Name : in STRING;        --| Argument being defined
    Help : in STRING        --| Help string
    );
    --| Raises: Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Store Help message for the argument

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

    procedure Append_Argument_Help(    --| Provide general help
    Proc : in Process_Handle;    --| Process handle
    Name : in STRING;        --| Argument being defined
    Help : in STRING        --| Help string
    );
    --| Raises: Uninitialized, Undefined_Name, Already_Parsed

    --| Effects:
    --| Append to the Help message associated with the argument.

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

    function Get_Argument(        --| Return the specified argument
    Proc : in Process_Handle;    --| Definition of the process
    Name : in STRING        --| Name of the desired argument
    ) return Enum_Type;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind

    --| Effects:
    --| Return an argument value from the argument called Name on the command
    --| line (or the default value if no value was supplied).

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

    function Get_Default(        --| Return the default for specified
                    --| argument if one exists
    Proc : in Process_Handle;    --| Definition of the process
    Name : in STRING        --| Name of the desired argument
    ) return Enum_Type;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind,
    --|        No_Default

    --| Effects:
    --| Return the default value from the argument called Name
    --| An exception is raised if no default was defined for the argument.

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

    function Defaulted(            --| Return defaulted/specified status
    Proc : in     Process_Handle;    --| Definition of the process
    Name : in     STRING        --| Name of the desired argument
    ) return BOOLEAN;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed

    --| Effects:
    --| Return a boolean indication TRUE if the value is defaulted
    --| FALSE if specified

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

end Enumerated_Argument;
                                                                    pragma page;
generic

    type Enum_Type is (<>);
    Enum_Type_Name : STRING;
    Enum_Type_List : STRING;

package Enumerated_List_Argument is

    package Enumerated_Lists is new Lists(Enum_Type);
    package EL renames Enumerated_Lists;

    type Enum_Type_Array is array (POSITIVE range <>) of Enum_Type;

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

    procedure Define_Argument(        --| Define an input argument
    Proc    : in Process_Handle;    --| Process being defined
    Name    : in STRING;        --| Name of the argument
    Help    : in STRING        --| Explanation of the argument
    );
    --| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Each time this procedure is called, it defines a new
    --| process argument; the first call defines the first argument,
    --| the second the second argument, etc.  Exceptions are raised if
    --| a duplicate name is defined.

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

    procedure Define_Argument(        --| Define an input argument
    Proc    : in Process_Handle;    --| Process being defined
    Name    : in STRING;        --| Name of the argument
    Default : in Enum_Type_Array;    --| Default value
    Help    : in STRING        --| Explanation of the argument
    );
    --| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Each time this procedure is called, it defines a new
    --| process argument; the first call defines the first argument,
    --| the second the second argument, etc.  Exceptions are raised if
    --| a duplicate name is defined.

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

    procedure Define_Argument_Help(    --| Provide general help
    Proc : in Process_Handle;    --| Process handle
    Name : in STRING;        --| Argument being defined
    Help : in STRING        --| Help string
    );
    --| Raises: Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Store Help message for the argument

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

    procedure Append_Argument_Help(    --| Provide general help
    Proc : in Process_Handle;    --| Process handle
    Name : in STRING;        --| Argument being defined
    Help : in STRING        --| Help string
    );
    --| Raises: Uninitialized, Undefined_Name, Already_Parsed

    --| Effects:
    --| Append to the Help message associated with the argument.

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

    function Get_Argument(        --| Return the specified argument
    Proc : in Process_Handle;    --| Definition of the command
    Name : in STRING        --| Name of the desired argument
    ) return EL.List;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind

    --| Effects:
    --| Return an argument value from the argument called Name on the command
    --| line (or the default value if no value was supplied).

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

    function Get_Default(        --| Return the default for specified
                    --| argument if one exists
    Proc : in Process_Handle;    --| Definition of the process
    Name : in STRING        --| Name of the desired argument
    ) return EL.List;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind,
    --|        No_Default

    --| Effects:
    --| Return the default value from the argument called Name
    --| An exception is raised if no default was defined for the argument.

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

    function Defaulted(            --| Return defaulted/specified status
    Proc : in     Process_Handle;    --| Definition of the process
    Name : in     STRING        --| Name of the desired argument
    ) return BOOLEAN;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed

    --| Effects:
    --| Return a boolean indication TRUE if the value is defaulted
    --| FALSE if specified

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

end Enumerated_List_Argument;
                                                                    pragma page;
generic

    type Integer_Type is range <>;
    Integer_Type_Name : STRING;

package Integer_Argument is

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

    procedure Define_Argument(        --| Define an input argument
    Proc    : in Process_Handle;    --| Process being defined
    Name    : in STRING;        --| Name of the argument
    Help    : in STRING        --| Explanation of the argument
    );
    --| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Each time this procedure is called, it defines a new
    --| process argument; the first call defines the first argument,
    --| the second the second argument, etc.  Exceptions are raised if
    --| a duplicate name is defined.

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

    procedure Define_Argument(        --| Define an input argument
    Proc    : in Process_Handle;    --| Process being defined
    Name    : in STRING;        --| Name of the argument
    Default : in Integer_Type;    --| Default value
    Help    : in STRING        --| Explanation of the argument
    );
    --| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Each time this procedure is called, it defines a new
    --| process argument; the first call defines the first argument,
    --| the second the second argument, etc.  Exceptions are raised if
    --| a duplicate name is defined.

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

    procedure Define_Argument_Help(    --| Provide general help
    Proc : in Process_Handle;    --| Process handle
    Name : in STRING;        --| Argument being defined
    Help : in STRING        --| Help string
    );
    --| Raises: Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Store Help message for the argument

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

    procedure Append_Argument_Help(    --| Provide general help
    Proc : in Process_Handle;    --| Process handle
    Name : in STRING;        --| Argument being defined
    Help : in STRING        --| Help string
    );
    --| Raises: Uninitialized, Undefined_Name, Already_Parsed

    --| Effects:
    --| Append to the Help message associated with the argument.

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

    function Get_Argument(        --| Return the specified argument
    Proc : in Process_Handle;    --| Definition of the process
    Name : in STRING        --| Name of the desired argument
    ) return Integer_Type;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind

    --| Effects:
    --| Return an argument value from the argument called Name on the command
    --| line (or the default value if no value was supplied).

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

    function Get_Default(        --| Return the default for specified
                    --| argument if one exists
    Proc : in Process_Handle;    --| Definition of the process
    Name : in STRING        --| Name of the desired argument
    ) return Integer_Type;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind,
    --|        No_Default

    --| Effects:
    --| Return the default value from the argument called Name
    --| An exception is raised if no default was defined for the argument.

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

    function Defaulted(            --| Return defaulted/specified status
    Proc : in     Process_Handle;    --| Definition of the process
    Name : in     STRING        --| Name of the desired argument
    ) return BOOLEAN;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed

    --| Effects:
    --| Return a boolean indication TRUE if the value is defaulted
    --| FALSE if specified

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

end Integer_Argument;
                                                                    pragma page;
generic

    type Integer_Type is range <>;
    Integer_Type_Name : STRING;
    Integer_Type_List : STRING;

package Integer_List_Argument is

    type Integer_Type_Array is array (POSITIVE range <>) of Integer_Type;

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

    procedure Define_Argument(        --| Define an input argument
    Proc    : in Process_Handle;    --| Process being defined
    Name    : in STRING;        --| Name of the argument
    Help    : in STRING        --| Explanation of the argument
    );
    --| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Each time this procedure is called, it defines a new
    --| process argument; the first call defines the first argument,
    --| the second the second argument, etc.  Exceptions are raised if
    --| a duplicate name is defined.

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

    procedure Define_Argument(        --| Define an input argument
    Proc    : in Process_Handle;    --| Process being defined
    Name    : in STRING;        --| Name of the argument
    Default : in Integer_Type_Array;--| Default value
    Help    : in STRING        --| Explanation of the argument
    );
    --| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Each time this procedure is called, it defines a new
    --| process argument; the first call defines the first argument,
    --| the second the second argument, etc.  Exceptions are raised if
    --| a duplicate name is defined.

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

    procedure Define_Argument_Help(    --| Provide general help
    Proc : in Process_Handle;    --| Process handle
    Name : in STRING;        --| Argument being defined
    Help : in STRING        --| Help string
    );
    --| Raises: Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Store Help message for the argument

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

    procedure Append_Argument_Help(    --| Provide general help
    Proc : in Process_Handle;    --| Process handle
    Name : in STRING;        --| Argument being defined
    Help : in STRING        --| Help string
    );
    --| Raises: Uninitialized, Undefined_Name, Already_Parsed

    --| Effects:
    --| Append to the Help message associated with the argument.

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

    function Get_Argument(        --| Return the specified argument
    Proc : in Process_Handle;    --| Definition of the command
    Name : in STRING        --| Name of the desired argument
    ) return IL.List;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind

    --| Effects:
    --| Return an argument value from the argument called Name on the command
    --| line (or the default value if no value was supplied).

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

    function Get_Default(        --| Return the default for specified
                    --| argument if one exists
    Proc : in Process_Handle;    --| Definition of the process
    Name : in STRING        --| Name of the desired argument
    ) return IL.List;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind,
    --|        No_Default

    --| Effects:
    --| Return the default value from the argument called Name
    --| An exception is raised if no default was defined for the argument.

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

    function Defaulted(            --| Return defaulted/specified status
    Proc : in     Process_Handle;    --| Definition of the process
    Name : in     STRING        --| Name of the desired argument
    ) return BOOLEAN;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed

    --| Effects:
    --| Return a boolean indication TRUE if the value is defaulted
    --| FALSE if specified

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

end Integer_List_Argument;
                                                                    pragma page;
generic

    String_Type_Name : STRING;

package String_Argument is

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

    procedure Define_Argument(        --| Define an input argument
    Proc    : in Process_Handle;    --| Process being defined
    Name    : in STRING;        --| Name of the argument
    Help    : in STRING        --| Explanation of the argument
    );
    --| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Each time this procedure is called, it defines a new
    --| process argument; the first call defines the first argument,
    --| the second the second argument, etc.  Exceptions are raised if
    --| a duplicate name is defined.

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

    procedure Define_Argument(        --| Define an input argument
    Proc    : in Process_Handle;    --| Process being defined
    Name    : in STRING;        --| Name of the argument
    Default : in STRING;        --| Default value
    Help    : in STRING        --| Explanation of the argument
    );
    --| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Each time this procedure is called, it defines a new
    --| process argument; the first call defines the first argument,
    --| the second the second argument, etc.  Exceptions are raised if
    --| a duplicate name is defined.

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

    procedure Define_Argument_Help(    --| Provide general help
    Proc : in Process_Handle;    --| Process handle
    Name : in STRING;        --| Argument being defined
    Help : in STRING        --| Help string
    );
    --| Raises: Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Store Help message for the argument

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

    procedure Append_Argument_Help(    --| Provide general help
    Proc : in Process_Handle;    --| Process handle
    Name : in STRING;        --| Argument being defined
    Help : in STRING        --| Help string
    );
    --| Raises: Uninitialized, Undefined_Name, Already_Parsed

    --| Effects:
    --| Append to the Help message associated with the argument.

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

    function Get_Argument(        --| Return the specified argument
    Proc : in Process_Handle;    --| Definition of the process
    Name : in STRING        --| Name of the desired argument
    ) return SP.String_Type;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind

    --| Effects:
    --| Return an argument value from the argument called Name on the command
    --| line (or the default value if no value was supplied).

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

    function Get_Default(        --| Return the default for specified
                    --| argument if one exists
    Proc : in Process_Handle;    --| Definition of the process
    Name : in STRING        --| Name of the desired argument
    ) return SP.String_Type;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind,
    --|        No_Default

    --| Effects:
    --| Return the default value from the argument called Name
    --| An exception is raised if no default was defined for the argument.

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

    function Defaulted(            --| Return defaulted/specified status
    Proc : in     Process_Handle;    --| Definition of the process
    Name : in     STRING        --| Name of the desired argument
    ) return BOOLEAN;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed

    --| Effects:
    --| Return a boolean indication TRUE if the value is defaulted
    --| FALSE if specified

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

end String_Argument;
                                                                    pragma page;
generic

    String_Type_Name : STRING;
    String_Type_List : STRING;

package String_List_Argument is

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

    procedure Define_Argument(        --| Define an input argument
    Proc    : in Process_Handle;    --| Process being defined
    Name    : in STRING;        --| Name of the argument
    Help    : in STRING        --| Explanation of the argument
    );
    --| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Each time this procedure is called, it defines a new
    --| process argument; the first call defines the first argument,
    --| the second the second argument, etc.  Exceptions are raised if
    --| a duplicate name is defined.

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

    procedure Define_Argument(        --| Define an input argument
    Proc    : in Process_Handle;    --| Process being defined
    Name    : in STRING;        --| Name of the argument
    Default : in SL.List;        --| Default value
    Help    : in STRING        --| Explanation of the argument
    );
    --| Raises: Duplicate_Name, Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Each time this procedure is called, it defines a new
    --| process argument; the first call defines the first argument,
    --| the second the second argument, etc.  Exceptions are raised if
    --| a duplicate name is defined.

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

    procedure Define_Argument_Help(    --| Provide general help
    Proc : in Process_Handle;    --| Process handle
    Name : in STRING;        --| Argument being defined
    Help : in STRING        --| Help string
    );
    --| Raises: Uninitialized, Invalid_Name, Already_Parsed

    --| Effects:
    --| Store Help message for the argument

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

    procedure Append_Argument_Help(    --| Provide general help
    Proc : in Process_Handle;    --| Process handle
    Name : in STRING;        --| Argument being defined
    Help : in STRING        --| Help string
    );
    --| Raises: Uninitialized, Undefined_Name, Already_Parsed

    --| Effects:
    --| Append to the Help message associated with the argument.

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

    function Get_Argument(        --| Return the specified argument
    Proc : in Process_Handle;    --| Definition of the command
    Name : in STRING        --| Name of the desired argument
    ) return SL.List;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind

    --| Effects:
    --| Return an argument value from the argument called Name on the command
    --| line (or the default value if no value was supplied).

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

    function Get_Default(        --| Return the default for specified
                    --| argument if one exists
    Proc : in Process_Handle;    --| Definition of the process
    Name : in STRING        --| Name of the desired argument
    ) return SL.List;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed, Invalid_Kind,
    --|        No_Default

    --| Effects:
    --| Return the default value from the argument called Name
    --| An exception is raised if no default was defined for the argument.

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

    function Defaulted(            --| Return defaulted/specified status
    Proc : in     Process_Handle;    --| Definition of the process
    Name : in     STRING        --| Name of the desired argument
    ) return BOOLEAN;
    --| Raises: Undefined_Name, Uninitialized, Not_Yet_Parsed

    --| Effects:
    --| Return a boolean indication TRUE if the value is defaulted
    --| FALSE if specified

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

end String_List_Argument;
                                                                    pragma page;
generic

    type Command_Enumeration is (<>);

package Command_Line is

    type Process_Handle_Array is array (Command_Enumeration) of Process_Handle;

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

    function Parse_Command_Line(    --| Parse a line including command
    Handles : in Process_Handle_Array;
                    --| Array of process handles
    Line    : in STRING        --| Line to be parsed
    ) return Command_Enumeration;
    --| Raises: Undefined_Command, Uninitialized, Already_Parsed,
    --|         Abort_Process, Process_Help

    --| Effects:
    --| First parse the line for valid command and if found parse the arguments
    --| according to the specification given by the corresponding process
    --| handle (See Parse_Line for details of argument parsing).
    --| If parsing is successful returns an enumeration type of the command

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

end Command_Line;
                                                                    pragma page;
private
                                                                    pragma List(off);
type Argument_Kind is (INT, INT_LIST, STR, STR_LIST, ENUM, ENUM_LIST);
                    -- Kinds of argument

type Argument_Record is
    record
    name     : SP.String_Type;    -- Specifies the name of an argument
    typename : SP.String_Type;    -- Argument type name
    listname : SP.String_Type;    -- Argument list type name
    kind     : Argument_Kind;    -- Specifies the argument type
    help     : SL.List := SL.Create;-- Help message for this argument
    default  : SL.List := SL.Create;-- Specifies a default value
    value    : SL.List := SL.Create;-- Argument value
    required : BOOLEAN;        -- Required argument switch
    supplied : BOOLEAN := FALSE;    -- Argument supplied switch
    low      : INTEGER;        -- Integer type range low
    high     : INTEGER;        -- Integer type range high
    valid    : SL.List := SL.Create;-- Valid Enum_Type
    end record;

type Argument_Handle is access Argument_Record;

package AL is new Lists(Argument_Handle);

type Process_Record is
    record
    parsed      : BOOLEAN        := FALSE;
    name        : SP.String_Type := SP.Make_Persistent("");
    help        : SL.List        := SL.Create;
    args        : AL.List        := AL.Create;
    msgs        : SL.List        := SL.Create;
    maxname     : NATURAL        := 0;
    maxtypename : NATURAL        := 0;
    maxtype     : NATURAL        := 0;
    typecolumn  : POSITIVE       := 6;
    end record;

type Process_Handle is access Process_Record;
                                                                    pragma List(on);
end Standard_Interface;
                                                                    pragma page;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--SINTF.BDY
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with String_Utilities;
with Unchecked_Deallocation;
with Host_Lib;
with Text_IO;

package body Standard_Interface is

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

    package HL renames Host_Lib;

    package SU renames String_Utilities;

    package SS is new SU.Generic_String_Utilities(SP.String_Type,
                          SP.Make_Persistent,
                          SP.Value);

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

    type Token_Kind is (NAME, BIND, LIST, QUOTED, VALUE, DONE, NONE);

    type Process_Status is (CLEAN, ERROR, SEVERE);

    type Error_Types is (Missing_End_Delimiter,
             Missing_Argument_Enclosure,
             Missing_Quotes,
             Non_Ada_Name,
             Name_Not_Defined,
             Missing_Name,
             Missing_Argument,
             Missing_Required_Argument,
             Missing_Named_Value,
             Invalid_Value,
             Invalid_List,
             Too_Many_Arguments,
             Positional_After_Named,
             Invalid_Command);

    type Error_Action is (CONTINUE, STOP);

    type Error_Record is
    record
        msg  : SP.String_Type;
        flag : Error_Action;
        end record;

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

    Status     : Process_Status;
    Short_Help : BOOLEAN := FALSE;
    Set_ID     : BOOLEAN := FALSE;
    ID         : SP.String_Type;

--------------------- Error Messages ---------------------------

    -- Substitutions are made for
    --    ~A : Name of the argument as defined
    --    ~N : Name of the argument as entered
    --    ~V : Value of the argument as entered

    Errors : constant array (Error_Types) of Error_Record :=
    (Missing_End_Delimiter      =>
        (SP.Make_Persistent("Missing an ending delimiter ~A"),
         CONTINUE),
     Missing_Argument_Enclosure =>
        (SP.Make_Persistent("Arguments not enclosed in ~A"),
         CONTINUE),
     Missing_Quotes             =>
        (SP.Make_Persistent("String value ~V not enclosed in quotes"),
         CONTINUE),
     Non_Ada_Name               =>
        (SP.Make_Persistent("Specified name ~N is not a valid identifier"),
         CONTINUE),
     Name_Not_Defined           =>
        (SP.Make_Persistent("Specified name ~N is not defined"),
         CONTINUE),
     Missing_Name               =>
        (SP.Make_Persistent("Name not specified"),
         CONTINUE),
     Missing_Argument           =>
        (SP.Make_Persistent("Argument not specified"),
         CONTINUE),
     Missing_Required_Argument  =>
        (SP.Make_Persistent("Required argument ~A not specified"),
         CONTINUE),
     Missing_Named_Value        =>
        (SP.Make_Persistent("Named value ~N not specified"),
         CONTINUE),
     Invalid_Value              =>
        (SP.Make_Persistent("Specified argument ~V not valid"),
         CONTINUE),
     Invalid_List               =>
        (SP.Make_Persistent("List specification ~V not valid"),
         CONTINUE),
     Too_Many_Arguments         =>
        (SP.Make_Persistent("Too many arguments specified"),
         CONTINUE),
     Positional_After_Named     =>
        (SP.Make_Persistent("A positional association must not occur after a named association"),
         STOP),
     Invalid_Command            =>
        (SP.Make_Persistent("Command ~V not defined"),
         STOP));

-------------------- Common File Header -------------------------

    -- The header is prepended by name of the process as defined
    -- by Define_Process

    File_Header : constant SP.String_Type :=
            SP.Make_Persistent("~D  ~T   Page ~P(R3)");
                                                                    pragma Page;
---------------- Local Subprogam Specifications ----------------

procedure Free_Process_Structure is
    new Unchecked_Deallocation(Process_Record, Process_Handle);

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

procedure Free_Argument_Structure is
    new Unchecked_Deallocation(Argument_Record, Argument_Handle);

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

function Release return STRING;

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

procedure Check_ID;

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

procedure Check_Uninitialized(
    Proc : in Process_Handle
    );

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

procedure Check_Already_Exists(
    Proc : in Process_Handle
    );

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

procedure Check_Invalid_Name(
    Name : in STRING
    );

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

procedure Check_Undefined_Name(
    Proc : in Process_Handle;
    Name : in STRING
    );

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

procedure Check_Duplicate_Name(
    Proc : in Process_Handle;
    Name : in STRING
    );

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

procedure Check_Not_Yet_Parsed(
    Proc : in Process_Handle
    );

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

procedure Check_Already_Parsed(
    Proc : in Process_Handle
    );

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

procedure Check_Invalid_Kind(
    Proc : in Process_Handle;
    Name : in STRING;
    Kind : in Argument_Kind
    );

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

procedure Write(
    Text  : in STRING
    );

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

procedure New_Line(
    Count : in POSITIVE
    );

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

procedure Write_List_Vertical(
    Header  : in STRING;
    List    : in SL.List
    );

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

procedure Write_List_Horizontal(
    List    : in SL.List;
    Quoted  : in BOOLEAN := FALSE
    );

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

function Find_Match(
    Proc : in Process_Handle;
    Name : in STRING
    ) return Argument_Handle;

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

function Get_Argument_Handle(
    Proc : in Process_Handle;
    Name : in STRING
    ) return Argument_Handle;

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

procedure Destroy_String_List is new SL.DestroyDeep(Dispose => SP.Flush);

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

procedure Destroy_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING
    );

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

procedure Set_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING;
    Help : in STRING
    );

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

function Set_Argument(
    Proc     : in     Process_Handle;
    Name     : in     STRING;
    Kind     : in     Argument_Kind;
    Typename : in     STRING;
    Listname : in     STRING;
    Required : in     BOOLEAN
    ) return Argument_Handle;

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

procedure Point_Next_Token(
    Scanner : in SU.Scanner
    );

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

procedure Get_Next_Token(
    Scanner : in     SU.Scanner;
    Kind    :    out Token_Kind;
    Token   : in out SP.String_Type
    );

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

procedure Parse_Argument(
    Argument : in Argument_Handle;
    Item     : in SP.String_Type;
    Kind     : in Token_Kind
    );

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

procedure Report_Error(
    Kind     : in Error_Types;
    Argument : in STRING := "";
    Name     : in STRING := "";
    Value    : in STRING := ""
    );

----------------------------------------------------------------
                                                                    pragma Page;
---------------------- Visible Subprogams ----------------------

procedure Set_Tool_Identifier(
    Identifier : in STRING
    ) is

begin

    Check_ID;
    raise Identifier_Error;

exception
    when Identifier_Error =>
    Set_ID := TRUE;
    ID := SP.Make_Persistent(Identifier);

end Set_Tool_Identifier;

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

function Get_Tool_Identifier
    return STRING is

begin

    Check_ID;
    return Release & '-' & SP.Value(ID);

end Get_Tool_Identifier;

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

procedure Define_Process(
    Name    : in     STRING;
    Help    : in     STRING;
    Proc    : in out Process_Handle
    ) is

begin

    Check_ID;
    Check_Invalid_Name(Name);
    Check_Already_Exists(Proc);
    Proc := new Process_Record;
    Define_Process_Name(Proc, Name);
    Define_Process_Help(Proc, Help);

end Define_Process;

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

procedure Redefine_Process(
    Proc    : in Process_Handle
    ) is

    Iterator : AL.ListIter;
    Item     : Argument_Handle;

begin

    Check_Not_Yet_Parsed(Proc);
    Iterator := AL.MakeListIter(Proc.args);
    while AL.More(Iterator) loop
    AL.Next(Iterator, Item);
    if Item.supplied then
        Item.supplied := FALSE;
        Destroy_String_List(Item.value);
        Item.value := SL.Create;
    end if;
    end loop;
    Proc.parsed := FALSE;

exception

    when Not_Yet_Parsed =>
    null;

end Redefine_Process;

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

procedure Undefine_Process(
    Proc : in out Process_Handle
    ) is

    Iterator : AL.ListIter;
    Item     : Argument_Handle;

begin

    if Proc /= null then
    SP.Flush(Proc.name);
    Destroy_String_List(Proc.help);
    Iterator := AL.MakeListIter(Proc.args);
    while AL.More(Iterator) loop
        AL.Next(Iterator, Item);
        SP.Flush(Item.name);
        SP.Flush(Item.typename);
        SP.Flush(Item.listname);
        Destroy_String_List(Item.help);
        Destroy_String_List(Item.default);
        Destroy_String_List(Item.value);
        Free_Argument_Structure(Item);
    end loop;
    AL.Destroy(Proc.args);
    Destroy_String_List(Proc.msgs);
    end if;
    Free_Process_Structure(Proc);

end Undefine_Process;

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

procedure Define_Process_Name(
    Proc    : in Process_Handle;
    Name    : in STRING
    ) is

begin

    Check_Invalid_Name(Name);
    Check_Already_Parsed(Proc);
    SP.Flush(Proc.name);
    Proc.name := SP.Make_Persistent(SP.Upper(Name));

end Define_Process_Name;

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

procedure Define_Process_Help(
    Proc : in Process_Handle;
    Help : in STRING
    ) is

begin

    Check_Already_Parsed(Proc);
    Destroy_String_List(Proc.help);
    Proc.help := SL.Create;
    Append_Process_Help(Proc, Help);

end Define_Process_Help;

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

procedure Append_Process_Help(
    Proc : in Process_Handle;
    Help : in STRING
    ) is

begin

    Check_Already_Parsed(Proc);
    SL.Attach(Proc.help, SP.Make_Persistent(Help));

end Append_Process_Help;

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

procedure Define_Help(
    Proc : in Process_Handle;
    Help : in STRING
    ) is

begin

    Check_Already_Parsed(Proc);
    Destroy_String_List(Proc.msgs);
    Proc.msgs := SL.Create;
    Append_Help(Proc, Help);

end Define_Help;

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

procedure Append_Help(
    Proc : in Process_Handle;
    Help : in STRING
    ) is

begin

    Check_Already_Parsed(Proc);
    SL.Attach(Proc.msgs, SP.Make_Persistent(Help));

end Append_Help;

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

procedure Parse_Line(
    Proc : in Process_Handle;
    Line : in STRING
    ) is

    S_Str    : SP.String_Type;
    Current  : Token_Kind;
    Previous : Token_Kind := NONE;
    Name_Val : SP.String_Type;
    Named    : BOOLEAN := FALSE;
    Iterator : AL.ListIter;
    Item     : Argument_Handle;
    Scanner  : SU.Scanner;
    Found    : BOOLEAN;

begin

    Check_Already_Parsed(Proc);

    Status := CLEAN;

    SP.Mark;
    S_Str := SS.Strip(Line);
    if SP.Length(S_Str) /= 0 then
    if SP.Fetch(S_Str, SP.Length(S_Str)) = End_Delimiter then
        S_Str := SS.Strip_Trailing(SP.Substr(S_Str, 1, SP.Length(S_Str) - 1));
    elsif Parsing_Switches(Ending_Delimiter) = ON then
        Report_Error(Missing_End_Delimiter,
             Argument => "'" & End_Delimiter & "'");
    end if;
    elsif Parsing_Switches(Ending_Delimiter) = ON then
    if Action_Switches(Show_Help) = ON then
        Show_Help(Proc);
    end if;
    raise Process_Help;
    end if;

    Scanner := SS.Make_Scanner(S_Str);
    SP.Release;
    SU.Mark(Scanner);
    if SU.More(Scanner) then
    if SU.Is_Enclosed(Left_Enclosure, Right_Enclosure, Scanner) then
        SS.Scan_Enclosed(Left_Enclosure, Right_Enclosure, Scanner, Found, S_Str);
        if SU.More(Scanner) then
        SU.Restore(Scanner);
        if Parsing_Switches(Argument_Enclosure) = ON then
            Report_Error(Missing_Argument_Enclosure,
                 Argument => "'" & Left_Enclosure & "' and '" & Right_Enclosure & "'");
        end if;
        else
        SU.Destroy_Scanner(Scanner);
        Scanner := SS.Make_Scanner(S_Str);
        end if;
        SP.Flush(S_Str);
    elsif Parsing_Switches(Argument_Enclosure) = ON then
        Report_Error(Missing_Argument_Enclosure,
             Argument => "'" & Left_Enclosure & "' and '" & Right_Enclosure & "'");
    end if;
    end if;

    SU.Skip_Space(Scanner);
    S_Str := SS.Get_Remainder(Scanner);
    SU.Destroy_Scanner(Scanner);
    SP.Mark;

    S_Str := SS.Strip(S_Str);
    if SP.Length(S_Str) = 0 then
    Scanner := SS.Make_Scanner(S_Str);
    else
    Scanner := SS.Make_Scanner(SP."&"(S_Str, "" & SP.Fetch(Delimiter, 1)));
    end if;
    SP.Flush(S_Str);
    SP.Release;

    Proc.parsed := TRUE;

    Iterator := AL.MakeListIter(Proc.args);
    while AL.More(Iterator) and Previous /= DONE and Status /= SEVERE and not Named loop
    AL.Next(Iterator, Item);
    Get_Next_Token(Scanner, Current, S_Str);
    case Current is
        when NONE =>
        Report_Error(Missing_Argument);
        when DONE =>
        null;
        when NAME =>
        Named := TRUE;
        Name_Val := S_Str;
        begin
            Item := Get_Argument_Handle(Proc, SP.Value(Name_Val));
        exception
            when Invalid_Name =>
            Report_Error(Non_Ada_Name,
                     Name => SP.Value(Name_Val));
            when Undefined_Name =>
            Report_Error(Name_Not_Defined,
                     Name => SP.Value(Name_Val));
        end;
        when BIND =>
        Report_Error(Missing_Name);
        when others =>
        SP.Mark;
        Parse_Argument(Item, S_Str, Current);
        SP.Release;
    end case;
    Previous := Current;
    end loop;

    if Named then
    while Previous /= DONE and Status /= SEVERE loop
        Get_Next_Token(Scanner, Current, S_Str);
        case Previous is
        when NAME =>
            null;
        when BIND =>
            case Current is
            when NAME | NONE | DONE | BIND =>
                Report_Error(Missing_Named_Value,
                     Name => SP.Value(Item.name));
                if Current = BIND then
                Report_Error(Missing_Name);
                end if;
            when others =>
                SP.Mark;
                Parse_Argument(Item, S_Str, Current);
                SP.Release;
            end case;
        when others =>
            case Current is
            when DONE =>
                null;
            when NAME =>
                Name_Val := S_Str;
                begin
                Item := Get_Argument_Handle(Proc, SP.Value(Name_Val));
                exception
                when Invalid_Name =>
                    Report_Error(Non_Ada_Name,
                         Name => SP.Value(Name_Val));
                when Undefined_Name =>
                    Report_Error(Name_Not_Defined,
                         Name => SP.Value(Name_Val));
                end;
            when NONE =>
                Report_Error(Missing_Argument);
            when others =>
                Report_Error(Positional_After_Named);
            end case;
        end case;
        Previous := Current;
    end loop;
    else
    Get_Next_Token(Scanner, Current, S_Str);
    if Current /= DONE then
        Report_Error(Too_Many_Arguments);
    end if;
    end if;

    Iterator := AL.MakeListIter(Proc.args);
    while AL.More(Iterator) loop
    AL.Next(Iterator, Item);
    if Item.required and not Item.supplied then
        Report_Error(Missing_Required_Argument, Argument=>SP.Value(Item.name));
    end if;
    end loop;

    if Status = CLEAN then
    if Action_Switches(Echo_Command) = ON then
        Echo_Process(Proc);
    end if;
    if Action_Switches(Prompt_for_Reply) = ON then
        if not Continue(Proc) then
        Redefine_Process(Proc);
        raise Abort_Process;
        end if;
    end if;
    else
    if Action_Switches(Show_Help_on_Error) = ON then
        Show_Help(Proc);
    end if;
    Redefine_Process(Proc);
    raise Abort_Process;
    end if;

end Parse_Line;

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

procedure Parse_Line(
    Proc : in Process_Handle
    ) is

begin

    Parse_Line(Proc, HL.Get_Item(HL.ARGUMENTS, HL.EDIT));

end Parse_Line;

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

procedure Show_Help(
    Proc : in Process_Handle
    ) is

    IterA : AL.ListIter;
    IterB : AL.ListIter;
    Arg   : Argument_Handle;
    Argx  : Argument_Handle;
    First : BOOLEAN := TRUE;
    S_Str : SP.String_Type;
    Found : BOOLEAN;

begin

    Check_Uninitialized(Proc);

    SP.Mark;

    HL.Set_Error;

    if Short_Help then
    Write_List_Vertical(SP.Value(Proc.name) & " : ", Proc.help);
    SP.Release;
    HL.Reset_Error;
    return;
    end if;
    New_Line(1);
    Write_List_Vertical(SP.Value(Proc.name) & " : ", Proc.help);
    Write("-- " & Get_Tool_Identifier);
    New_line(2);

    IterA := AL.MakeListIter(Proc.args);
    if AL.More(IterA) then
    First := FALSE;
    end if;
    while AL.More(IterA) loop
    AL.Next(IterA, Arg);
    case Arg.kind is
        when ENUM =>
        Found := FALSE;
        IterB := AL.MakeListIter(Proc.args);
        while AL.More(IterB) loop
            AL.Next(IterB, Argx);
            if Arg = Argx then
            exit;
            elsif SP.Equal(Arg.typename, Argx.typename) then
            Found := TRUE;
            exit;
            end if;
        end loop;
        if not Found and
           not SP.Equal(Arg.typename, "BOOLEAN") and
           not SP.Equal(Arg.typename, "CHARACTER") then
            TEXT_IO.PUT("type");
            TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
            TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtypename));
            TEXT_IO.PUT(" is ");
            TEXT_IO.PUT(Left_Enclosure);
            Write_List_Horizontal(Arg.valid);
            TEXT_IO.PUT(Right_Enclosure);
            TEXT_IO.PUT(End_Delimiter);
            New_Line(1);
        end if;
        when ENUM_LIST =>
        Found := FALSE;
        IterB := AL.MakeListIter(Proc.args);
        while AL.More(IterB) loop
            AL.Next(IterB, Argx);
            if Arg = Argx then
            exit;
            elsif SP.Equal(Arg.typename, Argx.typename) then
            Found := TRUE;
            exit;
            end if;
        end loop;
        if not Found and
           not SP.Equal(Arg.typename, "BOOLEAN") and
           not SP.Equal(Arg.typename, "CHARACTER") then
            TEXT_IO.PUT("type");
            TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
            TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtypename));
            TEXT_IO.PUT(" is ");
            TEXT_IO.PUT(Left_Enclosure);
            Write_List_Horizontal(Arg.valid);
            TEXT_IO.PUT(Right_Enclosure);
            TEXT_IO.PUT(End_Delimiter);
            New_Line(1);
        end if;
        Found := FALSE;
        IterB := AL.MakeListIter(Proc.args);
        while AL.More(IterB) loop
            AL.Next(IterB, Argx);
            if Arg = Argx then
            exit;
            elsif SP.Equal(Arg.listname, Argx.listname) then
            Found := TRUE;
            exit;
            end if;
        end loop;
        if not Found then
            TEXT_IO.PUT("type");
            TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
            TEXT_IO.PUT(SS.Left_Justify(Arg.listname, Proc.maxtypename));
            TEXT_IO.PUT(" is array (POSITIVE range <>) of ");
            TEXT_IO.PUT(SP.Value(Arg.typename));
            TEXT_IO.PUT(End_Delimiter);
            New_Line(1);
        end if;
        when INT =>
        Found := FALSE;
        IterB := AL.MakeListIter(Proc.args);
        while AL.More(IterB) loop
            AL.Next(IterB, Argx);
            if Arg = Argx then
            exit;
            elsif SP.Equal(Arg.typename, Argx.typename) then
            Found := TRUE;
            exit;
            end if;
        end loop;
        if not Found and
           not SP.Equal(Arg.typename, "INTEGER") and
           not SP.Equal(Arg.typename, "POSITIVE") and
           not SP.Equal(Arg.typename, "NATURAL") then
            TEXT_IO.PUT("subtype");
            TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
            TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtypename));
            TEXT_IO.PUT(" is INTEGER range ");
            TEXT_IO.PUT(SU.Image(Arg.low));
            TEXT_IO.PUT(" .. ");
            TEXT_IO.PUT(SU.Image(Arg.high));
            TEXT_IO.PUT(End_Delimiter);
            New_Line(1);
        end if;
        when INT_LIST  =>
        Found := FALSE;
        IterB := AL.MakeListIter(Proc.args);
        while AL.More(IterB) loop
            AL.Next(IterB, Argx);
            if Arg = Argx then
            exit;
            elsif SP.Equal(Arg.typename, Argx.typename) then
            Found := TRUE;
            exit;
            end if;
        end loop;
        if not Found and
           not SP.Equal(Arg.typename, "INTEGER") and
           not SP.Equal(Arg.typename, "POSITIVE") and
           not SP.Equal(Arg.typename, "NATURAL") then
            TEXT_IO.PUT("subtype");
            TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
            TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtypename));
            TEXT_IO.PUT(" is INTEGER range ");
            TEXT_IO.PUT(SU.Image(Arg.low));
            TEXT_IO.PUT(" .. ");
            TEXT_IO.PUT(SU.Image(Arg.high));
            TEXT_IO.PUT(End_Delimiter);
            New_Line(1);
        end if;
        Found := FALSE;
        IterB := AL.MakeListIter(Proc.args);
        while AL.More(IterB) loop
            AL.Next(IterB, Argx);
            if Arg = Argx then
            exit;
            elsif SP.Equal(Arg.listname, Argx.listname) then
            Found := TRUE;
            exit;
            end if;
        end loop;
        if not Found then
            TEXT_IO.PUT("type");
            TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
            TEXT_IO.PUT(SS.Left_Justify(Arg.listname, Proc.maxtypename));
            TEXT_IO.PUT(" is array (POSITIVE range <>) of ");
            TEXT_IO.PUT(SP.Value(Arg.typename));
            TEXT_IO.PUT(End_Delimiter);
            New_Line(1);
        end if;
        when STR =>
        Found := FALSE;
        IterB := AL.MakeListIter(Proc.args);
        while AL.More(IterB) loop
            AL.Next(IterB, Argx);
            if Arg = Argx then
            exit;
            elsif SP.Equal(Arg.typename, Argx.typename) then
            Found := TRUE;
            exit;
            end if;
        end loop;
        if not Found and
           not SP.Equal(Arg.typename, "STRING") then
            TEXT_IO.PUT("subtype");
            TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
            TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtypename));
            TEXT_IO.PUT(" is STRING");
            TEXT_IO.PUT(End_Delimiter);
            New_Line(1);
        end if;
        when STR_LIST  =>
        Found := FALSE;
        IterB := AL.MakeListIter(Proc.args);
        while AL.More(IterB) loop
            AL.Next(IterB, Argx);
            if Arg = Argx then
            exit;
            elsif SP.Equal(Arg.typename, Argx.typename) then
            Found := TRUE;
            exit;
            end if;
        end loop;
        if not Found and
           not SP.Equal(Arg.typename, "STRING") then
            TEXT_IO.PUT("subtype");
            TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
            TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtypename));
            TEXT_IO.PUT(" is STRING");
            TEXT_IO.PUT(End_Delimiter);
            New_Line(1);
        end if;
        Found := FALSE;
        IterB := AL.MakeListIter(Proc.args);
        while AL.More(IterB) loop
            AL.Next(IterB, Argx);
            if Arg = Argx then
            exit;
            elsif SP.Equal(Arg.listname, Argx.listname) then
            Found := TRUE;
            exit;
            end if;
        end loop;
        if not Found then
            TEXT_IO.PUT("type");
            TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Proc.typecolumn));
            TEXT_IO.PUT(SS.Left_Justify(Arg.listname, Proc.maxtypename));
            TEXT_IO.PUT(" is array (POSITIVE range <>) of ");
            TEXT_IO.PUT(SP.Value(Arg.typename));
            TEXT_IO.PUT(End_Delimiter);
            New_Line(1);
        end if;
    end case;
    end loop;
    if not First then
    New_Line(1);
    end if;

    TEXT_IO.PUT("procedure ");
    TEXT_IO.PUT(SP.Value(Proc.name));
    First := TRUE;
    IterA := AL.MakeListIter(Proc.args);
    while AL.More(IterA) loop
    AL.Next(IterA, Arg);
    if not First then
        TEXT_IO.PUT(End_Delimiter);
    else
        First := FALSE;
        TEXT_IO.PUT(Left_Enclosure);
    end if;
    New_Line(1);
    TEXT_IO.SET_COL(4);
    TEXT_IO.PUT(SS.Left_Justify(Arg.name, Proc.maxname));
    TEXT_IO.PUT(" : in ");
    case Arg.kind is
        when ENUM | INT =>
        if Arg.required then
            TEXT_IO.PUT(SP.Value(Arg.typename));
        else
            TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtype));
            TEXT_IO.PUT(" := ");
            Write_List_Horizontal(Arg.default);
        end if;
        when STR =>
        if Arg.required then
            TEXT_IO.PUT(SP.Value(Arg.typename));
        else
            TEXT_IO.PUT(SS.Left_Justify(Arg.typename, Proc.maxtype));
            TEXT_IO.PUT(" := """);
            Write_List_Horizontal(Arg.default);
            TEXT_IO.PUT('"');
        end if;
        when ENUM_LIST | INT_LIST =>
        if Arg.required then
            TEXT_IO.PUT(SP.Value(Arg.listname));
        else
            TEXT_IO.PUT(SS.Left_Justify(Arg.listname, Proc.maxtype));
            TEXT_IO.PUT(" := (");
            Write_List_Horizontal(Arg.default, Quoted=>FALSE);
            TEXT_IO.PUT(Right_Enclosure);
        end if;
        when STR_LIST =>
        if Arg.required then
            TEXT_IO.PUT(SP.Value(Arg.listname));
        else
            TEXT_IO.PUT(SS.Left_Justify(Arg.listname, Proc.maxtype));
            TEXT_IO.PUT(" := (");
            Write_List_Horizontal(Arg.default, Quoted=>TRUE);
            TEXT_IO.PUT(Right_Enclosure);
        end if;
    end case;
    end loop;
    if not First then
    New_Line(1);
    TEXT_IO.SET_COL(4);
    TEXT_IO.PUT(Right_Enclosure);
    end if;
    TEXT_IO.PUT(End_Delimiter);
    New_Line(2);

    IterA := AL.MakeListIter(Proc.args);
    if AL.More(IterA) then
    while AL.More(IterA) loop
        AL.Next(IterA, Arg);
        S_Str := SP."&"(SS.Left_Justify(Arg.name, Proc.maxname), " : ");
        Write_List_Vertical(SP.Value(S_Str), Arg.help);
    end loop;
        New_Line(1);
    end if;

    if not SL.IsEmpty(Proc.msgs) then
    Write_List_Vertical("", Proc.msgs);
    New_Line(1);
    end if;

    HL.Reset_Error;

    SP.Release;

end Show_Help;

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

procedure Echo_Process(
    Proc : in Process_Handle
    ) is

    IterA : AL.ListIter;
    Arg   : Argument_Handle;
    First : BOOLEAN;
    Num   : INTEGER;

begin

    Check_Not_Yet_Parsed(Proc);

    SP.Mark;

    HL.Set_Error;

    TEXT_IO.NEW_LINE(1);

    TEXT_IO.PUT(SP.Value(Proc.name));
    First := TRUE;
    IterA := AL.MakeListIter(Proc.args);
    while AL.More(IterA) loop
    AL.Next(IterA, Arg);
    if not First then
        TEXT_IO.PUT(SP.Fetch(Delimiter, 1));
        TEXT_IO.NEW_LINE(1);
    else
        First := FALSE;
        TEXT_IO.PUT(" ( ");
        Num := SP.Length(Proc.name) + 4;
    end if;
    TEXT_IO.SET_COL(TEXT_IO.POSITIVE_COUNT(Num));
    TEXT_IO.PUT(SS.Left_Justify(Arg.name, Proc.maxname));
    TEXT_IO.PUT(' ' & SP.Value(Assignment) & ' ');
    case Arg.kind is
        when ENUM | INT =>
        if Arg.supplied then
            Write_List_Horizontal(Arg.value);
        else
            Write_List_Horizontal(Arg.default);
        end if;
        when STR =>
        if Arg.supplied then
            Write_List_Horizontal(Arg.value, Quoted=>TRUE);
        else
            Write_List_Horizontal(Arg.default, Quoted=>TRUE);
        end if;
        when ENUM_LIST | INT_LIST =>
        TEXT_IO.PUT(Left_Enclosure);
        if Arg.supplied then
            Write_List_Horizontal(Arg.value);
        else
            Write_List_Horizontal(Arg.default);
        end if;
        TEXT_IO.PUT(Right_Enclosure);
        when STR_LIST =>
        TEXT_IO.PUT(Left_Enclosure);
        if Arg.supplied then
            Write_List_Horizontal(Arg.value, Quoted=>TRUE);
        else
            Write_List_Horizontal(Arg.default, Quoted=>TRUE);
        end if;
        TEXT_IO.PUT(Right_Enclosure);
    end case;
    end loop;
    if not First then
    TEXT_IO.PUT(" )");
    end if;
    TEXT_IO.PUT(End_Delimiter);
    TEXT_IO.NEW_LINE(2);

    HL.Reset_Error;

    SP.Release;

end Echo_Process;

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

function Continue(
    Proc : in Process_Handle
    ) return BOOLEAN is

    Reply : STRING (1 .. 256);
    Len   : NATURAL;
    Str   : SP.String_Type;
    Ret   : BOOLEAN := FALSE;

begin

    Check_Not_Yet_Parsed(Proc);

    HL.Set_Error;

    TEXT_IO.PUT("Continue with procedure ");
    TEXT_IO.PUT(SP.Value(Proc.name));
    TEXT_IO.PUT(" ? (YES|NO) : ");

    HL.Reset_Error;

    TEXT_IO.GET_LINE(Reply, Len);
    if Len = 0 then
    return Continue(Proc);
    end if;
    SP.Mark;
    if SP.Match_S(SP.Create("YES"), SP.Upper(STRING'(SU.Strip(Reply(1 .. Len))))) = 0 then
    HL.Set_Error;
    TEXT_IO.PUT_LINE("Aborting");
    HL.Reset_Error;
    else
    Ret := TRUE;
    end if;
    SP.Release;
    return Ret;

end Continue;

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

procedure Define_Output(
    Proc        : in Process_Handle;
    File_Name   : in STRING;
    Header_Size : in Size := 0;
    Paginate    : in BOOLEAN := TRUE
    ) is

    S_Str : SP.String_Type;

begin

    if Paginate then
    PO.Set_Standard_Paginated_File(File_Name, 66, Header_Size + 3, 2);
    SP.Mark;
    S_Str := SP."&"((SS.Left_Justify(Proc.name, 50) & ' '), File_Header);
    PO.Set_Header(2, S_Str);
    SP.Release;
    else
    PO.Set_Standard_Paginated_File(File_Name, 0, 0, 0);
    end if;

end Define_Output;

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

procedure Define_Output(
    Proc        : in     Process_Handle;
    File_Name   : in     STRING;
    Header_Size : in     Size := 0;
    File_Handle : in out PO.Paginated_File_Handle;
    Paginate    : in     BOOLEAN := TRUE
    ) is

    S_Str : SP.String_Type;

begin

    if Paginate then
    PO.Create_Paginated_File(File_Name, File_Handle, 66, Header_Size + 3, 2);
    SP.Mark;
    S_Str := SP."&"((SS.Left_Justify(Proc.name, 50) & ' '), File_Header);
    PO.Set_Header(File_Handle, 2, S_Str);
    SP.Release;
    else
    PO.Create_Paginated_File(File_Name, File_Handle, 0, 0, 0);
    end if;

end Define_Output;

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

procedure Define_Header(
    Line : in Number;
    Text : in STRING
    ) is

begin

    PO.Set_Header(Line + 2, Text);

end Define_Header;

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

procedure Define_Header(
    File_Handle : in PO.Paginated_File_Handle;
    Line        : in Number;
    Text        : in STRING
    ) is

begin

    PO.Set_Header(File_Handle, Line + 2, Text);

end Define_Header;
                                                                    pragma Page;
package body Enumerated_Argument is

    TypeColumn : POSITIVE := 6;

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

    procedure Define_Argument(
    Proc    : in Process_Handle;
    Name    : in STRING;
    Help    : in STRING
    ) is

    Argument : Argument_Handle;

    begin

    Argument := Set_Argument(Proc, Name, ENUM, Enum_Type_Name, "", TRUE);
    if Proc.typecolumn < TypeColumn then
        Proc.typecolumn := TypeColumn;
    end if;
    for i in Enum_Type loop
        SL.Attach(Argument.valid, SP.Make_Persistent(Enum_Type'image(i)));
    end loop;
    Define_Argument_Help(Proc, Name, Help);

    end Define_Argument;

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

    procedure Define_Argument(
    Proc    : in Process_Handle;
    Name    : in STRING;
    Default : in Enum_Type;
    Help    : in STRING
    ) is

    Argument : Argument_Handle;

    begin

    Argument := Set_Argument(Proc, Name, ENUM, Enum_Type_Name, "", FALSE);
    if Proc.typecolumn < TypeColumn then
        Proc.typecolumn := TypeColumn;
    end if;
    SL.Attach(Argument.default, SP.Make_Persistent(Enum_Type'image(Default)));
    for i in Enum_Type loop
        SL.Attach(Argument.valid, SP.Make_Persistent(Enum_Type'image(i)));
    end loop;
    Define_Argument_Help(Proc, Name, Help);

    end Define_Argument;

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

    procedure Define_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING;
    Help : in STRING
    ) is

    begin

    Destroy_Argument_Help(Proc, Name);
    Set_Argument_Help(Proc, Name, Help);

    end Define_Argument_Help;

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

    procedure Append_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING;
    Help : in STRING
    ) is

    begin

    Set_Argument_Help(Proc, Name, Help);

    end Append_Argument_Help;

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

    function Get_Argument(
    Proc : in Process_Handle;
    Name : in STRING
    ) return Enum_Type is

    begin

    Check_Invalid_Kind(Proc, Name, ENUM);
    if Get_Argument_Handle(Proc, Name).supplied then
        return Enum_Type'value(SP.Value(SL.FirstValue(Get_Argument_Handle(Proc, Name).value)));
    else
        return Enum_Type'value(SP.Value(SL.FirstValue(Get_Argument_Handle(Proc, Name).default)));
    end if;

    end Get_Argument;

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

    function Get_Default(
    Proc : in Process_Handle;
    Name : in STRING
    ) return Enum_Type is

    begin

    Check_Invalid_Kind(Proc, Name, ENUM);
    if Get_Argument_Handle(Proc, Name).required then
        raise No_Default;
    else
        return Enum_Type'value(SP.Value(SL.FirstValue(Get_Argument_Handle(Proc, Name).default)));
    end if;

    end Get_Default;

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

    function Defaulted(
    Proc : in Process_Handle;
    Name : in STRING
    ) return BOOLEAN is

    begin

    Check_Invalid_Kind(Proc, Name, ENUM);
    return not Get_Argument_Handle(Proc, Name).supplied;

    end Defaulted;

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

begin

    SP.Mark;

    if SP.Equal(SP.Upper(Enum_Type_Name), "BOOLEAN") then
    if Enum_Type'pos(Enum_Type'first) /= BOOLEAN'pos(BOOLEAN'first) or
       Enum_Type'pos(Enum_Type'last) - Enum_Type'pos(Enum_Type'first) /=
        BOOLEAN'pos(BOOLEAN'last) - BOOLEAN'pos(BOOLEAN'first) then
        raise Invalid_Type;
    end if;
    if Enum_Type'image(Enum_Type'first) /= BOOLEAN'image(BOOLEAN'first) or
       Enum_Type'image(Enum_Type'last)  /= BOOLEAN'image(BOOLEAN'last) then
        raise Invalid_Type;
    end if;

    elsif SP.Equal(SP.Upper(Enum_Type_Name), "CHARACTER") then
    if Enum_Type'pos(Enum_Type'last) - Enum_Type'pos(Enum_Type'first) /=
       CHARACTER'pos(CHARACTER'last) - CHARACTER'pos(CHARACTER'first) then
        raise Invalid_Type;
    end if;
    if Enum_Type'image(Enum_Type'first) /= CHARACTER'image(CHARACTER'first) or
       Enum_Type'image(Enum_Type'last)  /= CHARACTER'image(CHARACTER'last) then
        raise Invalid_Type;
    end if;

    end if;

    SP.Release;

end Enumerated_Argument;
                                                                    pragma Page;
package body Enumerated_List_Argument is

    TypeColumn : POSITIVE := 6;

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

    procedure Define_Argument(
    Proc    : in Process_Handle;
    Name    : in STRING;
    Help    : in STRING
    ) is

    Argument : Argument_Handle;

    begin

    Argument := Set_Argument(Proc, Name, ENUM_LIST, Enum_Type_Name, Enum_Type_List, TRUE);
    if Proc.typecolumn < TypeColumn then
        Proc.typecolumn := TypeColumn;
    end if;
    for i in Enum_Type loop
        SL.Attach(Argument.valid, SP.Make_Persistent(Enum_Type'image(i)));
    end loop;
    Define_Argument_Help(Proc, Name, Help);

    end Define_Argument;

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

    procedure Define_Argument(
    Proc    : in Process_Handle;
    Name    : in STRING;
    Default : in Enum_Type_Array;
    Help    : in STRING
    ) is

    Argument : Argument_Handle;

    begin

    Argument := Set_Argument(Proc, Name, ENUM_LIST, Enum_Type_Name, Enum_Type_List, FALSE);
    if Proc.typecolumn < TypeColumn then
        Proc.typecolumn := TypeColumn;
    end if;
    for i in Default'range loop
        SL.Attach(Argument.default, SP.Make_Persistent(Enum_Type'image(Default(i))));
    end loop;
    for i in Enum_Type loop
        SL.Attach(Argument.valid, SP.Make_Persistent(Enum_Type'image(i)));
    end loop;
    Define_Argument_Help(Proc, Name, Help);

    end Define_Argument;

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

    procedure Define_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING;
    Help : in STRING
    ) is

    begin

    Destroy_Argument_Help(Proc, Name);
    Set_Argument_Help(Proc, Name, Help);

    end Define_Argument_Help;

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

    procedure Append_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING;
    Help : in STRING
    ) is

    begin

    Set_Argument_Help(Proc, Name, Help);

    end Append_Argument_Help;

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

    function Get_Argument(
    Proc : in Process_Handle;
    Name : in STRING
    ) return EL.List is

    List     : EL.List := EL.Create;
    Item     : SP.String_Type;
    Iterator : SL.ListIter;

    begin

    Check_Invalid_Kind(Proc, Name, ENUM_LIST);
    if Get_Argument_Handle(Proc, Name).supplied then
        Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).value);
    else
        Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).default);
    end if;
    while SL.More(Iterator) loop
        SL.Next(Iterator, Item);
        EL.Attach(List, Enum_Type'value(SP.Value(Item)));
    end loop;
    return List;

    end Get_Argument;

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

    function Get_Default(
    Proc : in Process_Handle;
    Name : in STRING
    ) return EL.List is

    List     : EL.List := EL.Create;
    Item     : SP.String_Type;
    Iterator : SL.ListIter;

    begin

    Check_Invalid_Kind(Proc, Name, ENUM_LIST);
    if Get_Argument_Handle(Proc, Name).required then
        raise No_Default;
    else
        Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).default);
    end if;
    while SL.More(Iterator) loop
        SL.Next(Iterator, Item);
        EL.Attach(List, Enum_Type'value(SP.Value(Item)));
    end loop;
    return List;

    end Get_Default;

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

    function Defaulted(
    Proc : in Process_Handle;
    Name : in STRING
    ) return BOOLEAN is

    begin

    Check_Invalid_Kind(Proc, Name, ENUM_LIST);
    return not Get_Argument_Handle(Proc, Name).supplied;

    end Defaulted;

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

begin

    SP.Mark;

    if SP.Equal(SP.Upper(Enum_Type_Name), "BOOLEAN") then
    if Enum_Type'pos(Enum_Type'first) /= BOOLEAN'pos(BOOLEAN'first) or
       Enum_Type'pos(Enum_Type'last) - Enum_Type'pos(Enum_Type'first) /=
        BOOLEAN'pos(BOOLEAN'last) - BOOLEAN'pos(BOOLEAN'first) then
        raise Invalid_Type;
    end if;
    if Enum_Type'image(Enum_Type'first) /= BOOLEAN'image(BOOLEAN'first) or
       Enum_Type'image(Enum_Type'last)  /= BOOLEAN'image(BOOLEAN'last) then
        raise Invalid_Type;
    end if;

    elsif SP.Equal(SP.Upper(Enum_Type_Name), "CHARACTER") then
    if Enum_Type'pos(Enum_Type'last) - Enum_Type'pos(Enum_Type'first) /=
       CHARACTER'pos(CHARACTER'last) - CHARACTER'pos(CHARACTER'first) then
        raise Invalid_Type;
    end if;
    if Enum_Type'image(Enum_Type'first) /= CHARACTER'image(CHARACTER'first) or
       Enum_Type'image(Enum_Type'last)  /= CHARACTER'image(CHARACTER'last) then
        raise Invalid_Type;
    end if;

    end if;

    SP.Release;

end Enumerated_List_Argument;
                                                                    pragma Page;
package body Integer_Argument is

    TypeColumn : POSITIVE := 6;

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

    procedure Define_Argument(
    Proc    : in Process_Handle;
    Name    : in STRING;
    Help    : in STRING
    ) is

    Argument : Argument_Handle;

    begin

    Argument := Set_Argument(Proc, Name, INT, Integer_Type_Name, "", TRUE);
    if Proc.typecolumn < TypeColumn then
        Proc.typecolumn := TypeColumn;
    end if;
    Argument.low  := Integer_Type'pos(Integer_Type'first);
    Argument.high := Integer_Type'pos(Integer_Type'last);
    Define_Argument_Help(Proc, Name, Help);

    end Define_Argument;

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

    procedure Define_Argument(
    Proc    : in Process_Handle;
    Name    : in STRING;
    Default : in Integer_Type;
    Help    : in STRING
    ) is

    Str      : SP.String_Type;
    Argument : Argument_Handle;

    begin

    Argument := Set_Argument(Proc, Name, INT, Integer_Type_Name, "", FALSE);
    if Proc.typecolumn < TypeColumn then
        Proc.typecolumn := TypeColumn;
    end if;
    SP.Mark;
    Str := SS.Image(INTEGER'value(Integer_Type'image(Default)));
    SL.Attach(Argument.default, SP.Make_Persistent(Str));
    SP.Release;
    Argument.low  := Integer_Type'pos(Integer_Type'first);
    Argument.high := Integer_Type'pos(Integer_Type'last);
    Define_Argument_Help(Proc, Name, Help);


    end Define_Argument;

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

    procedure Define_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING;
    Help : in STRING
    ) is

    begin

    Destroy_Argument_Help(Proc, Name);
    Set_Argument_Help(Proc, Name, Help);

    end Define_Argument_Help;

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

    procedure Append_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING;
    Help : in STRING
    ) is

    begin

    Set_Argument_Help(Proc, Name, Help);

    end Append_Argument_Help;

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

    function Get_Argument(
    Proc : in Process_Handle;
    Name : in STRING
    ) return Integer_Type is

    begin

    Check_Invalid_Kind(Proc, Name, INT);
    if Get_Argument_Handle(Proc, Name).supplied then
        return Integer_Type'value(SP.Value(SL.FirstValue(Get_Argument_Handle(Proc, Name).value)));
    else
        return Integer_Type'value(SP.Value(SL.FirstValue(Get_Argument_Handle(Proc, Name).default)));
    end if;

    end Get_Argument;

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

    function Get_Default(
    Proc : in Process_Handle;
    Name : in STRING
    ) return Integer_Type is

    begin

    Check_Invalid_Kind(Proc, Name, INT);
    if Get_Argument_Handle(Proc, Name).required then
        raise No_Default;
    else
        return Integer_Type'value(SP.Value(SL.FirstValue(Get_Argument_Handle(Proc, Name).default)));
    end if;

    end Get_Default;

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

    function Defaulted(
    Proc : in Process_Handle;
    Name : in STRING
    ) return BOOLEAN is

    begin

    Check_Invalid_Kind(Proc, Name, INT);
    return not Get_Argument_Handle(Proc, Name).supplied;

    end Defaulted;

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

begin

    SP.Mark;

    if SP.Equal(SP.Upper(Integer_Type_Name), "NATURAL") then
    if Integer_Type'pos(Integer_Type'first) /= NATURAL'first or
       Integer_Type'pos(Integer_Type'last)  /= NATURAL'last  then
        raise Invalid_Type;
    end if;
    TypeColumn := 9;

    elsif SP.Equal(SP.Upper(Integer_Type_Name), "POSITIVE") then
    if Integer_Type'pos(Integer_Type'first) /= POSITIVE'first or
       Integer_Type'pos(Integer_Type'last)  /= POSITIVE'last  then
        raise Invalid_Type;
    end if;
    TypeColumn := 9;

    elsif SP.Equal(SP.Upper(Integer_Type_Name), "INTEGER") then
    if Integer_Type'pos(Integer_Type'first) /= INTEGER'first or
       Integer_Type'pos(Integer_Type'last)  /= INTEGER'last  then
        raise Invalid_Type;
    end if;
    TypeColumn := 9;

    end if;

    SP.Release;

end Integer_Argument;
                                                                    pragma Page;
package body Integer_List_Argument is

    TypeColumn : POSITIVE := 6;

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

    procedure Define_Argument(
    Proc    : in Process_Handle;
    Name    : in STRING;
    Help    : in STRING
    ) is

    Argument : Argument_Handle;

    begin

    Argument := Set_Argument(Proc, Name, INT_LIST, Integer_Type_Name, Integer_Type_List, TRUE);
    if Proc.typecolumn < TypeColumn then
        Proc.typecolumn := TypeColumn;
    end if;
    Argument.low  := Integer_Type'pos(Integer_Type'first);
    Argument.high := Integer_Type'pos(Integer_Type'last);
    Define_Argument_Help(Proc, Name, Help);

    end Define_Argument;

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

    procedure Define_Argument(
    Proc    : in Process_Handle;
    Name    : in STRING;
    Default : in Integer_Type_Array;
    Help    : in STRING
    ) is

    Str      : SP.String_Type;
    Argument : Argument_Handle;

    begin

    Argument := Set_Argument(Proc, Name, INT_LIST, Integer_Type_Name, Integer_Type_List, FALSE);
    if Proc.typecolumn < TypeColumn then
        Proc.typecolumn := TypeColumn;
    end if;
    for i in Default'range loop
        SP.Mark;
        Str := SS.Image(INTEGER'value(Integer_Type'image(Default(i))));
        SL.Attach(Argument.default, SP.Make_Persistent(Str));
        SP.Release;
    end loop;
    Argument.low  := Integer_Type'pos(Integer_Type'first);
    Argument.high := Integer_Type'pos(Integer_Type'last);
    Define_Argument_Help(Proc, Name, Help);

    end Define_Argument;

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

    procedure Define_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING;
    Help : in STRING
    ) is

    begin

    Destroy_Argument_Help(Proc, Name);
    Set_Argument_Help(Proc, Name, Help);

    end Define_Argument_Help;

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

    procedure Append_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING;
    Help : in STRING
    ) is

    begin

    Set_Argument_Help(Proc, Name, Help);

    end Append_Argument_Help;

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

    function Get_Argument(
    Proc : in Process_Handle;
    Name : in STRING
    ) return IL.List is

    List     : IL.List := IL.Create;
    Item     : SP.String_Type;
    Iterator : SL.ListIter;

    begin

    Check_Invalid_Kind(Proc, Name, INT_LIST);
    if Get_Argument_Handle(Proc, Name).supplied then
        Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).value);
    else
        Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).default);
    end if;
    while SL.More(Iterator) loop
        SL.Next(Iterator, Item);
        IL.Attach(List, INTEGER'value(SP.Value(Item)));
    end loop;
    return List;

    end Get_Argument;

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

    function Get_Default(
    Proc : in Process_Handle;
    Name : in STRING
    ) return IL.List is

    List     : IL.List := IL.Create;
    Item     : SP.String_Type;
    Iterator : SL.ListIter;

    begin

    Check_Invalid_Kind(Proc, Name, INT_LIST);
    if Get_Argument_Handle(Proc, Name).required then
        raise No_Default;
    else
        Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).default);
    end if;
    while SL.More(Iterator) loop
        SL.Next(Iterator, Item);
        IL.Attach(List, INTEGER'value(SP.Value(Item)));
    end loop;
    return List;

    end Get_Default;

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

    function Defaulted(
    Proc : in Process_Handle;
    Name : in STRING
    ) return BOOLEAN is

    begin

    Check_Invalid_Kind(Proc, Name, INT_LIST);
    return not Get_Argument_Handle(Proc, Name).supplied;

    end Defaulted;

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

begin

    SP.Mark;

    if SP.Equal(SP.Upper(Integer_Type_Name), "NATURAL") then
    if Integer_Type'pos(Integer_Type'first) /= NATURAL'first or
       Integer_Type'pos(Integer_Type'last)  /= NATURAL'last  then
        raise Invalid_Type;
    end if;
    TypeColumn := 9;

    elsif SP.Equal(SP.Upper(Integer_Type_Name), "POSITIVE") then
    if Integer_Type'pos(Integer_Type'first) /= POSITIVE'first or
       Integer_Type'pos(Integer_Type'last)  /= POSITIVE'last  then
        raise Invalid_Type;
    end if;
    TypeColumn := 9;

    elsif SP.Equal(SP.Upper(Integer_Type_Name), "INTEGER") then
    if Integer_Type'pos(Integer_Type'first) /= INTEGER'first or
       Integer_Type'pos(Integer_Type'last)  /= INTEGER'last  then
        raise Invalid_Type;
    end if;
    TypeColumn := 9;

    end if;

    SP.Release;

end Integer_List_Argument;
                                                                    pragma Page;
package body String_Argument is

    TypeColumn : POSITIVE := 6;

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

    procedure Define_Argument(
    Proc    : in Process_Handle;
    Name    : in STRING;
    Help    : in STRING
    ) is

    Argument : Argument_Handle;

    begin

    Argument := Set_Argument(Proc, Name, STR, String_Type_Name, "", TRUE);
    if Proc.typecolumn < TypeColumn then
        Proc.typecolumn := TypeColumn;
    end if;
    Define_Argument_Help(Proc, Name, Help);

    end Define_Argument;

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

    procedure Define_Argument(
    Proc    : in Process_Handle;
    Name    : in STRING;
    Default : in STRING;
    Help    : in STRING
    ) is

    Argument : Argument_Handle;

    begin

    Argument := Set_Argument(Proc, Name, STR, String_Type_Name, "", FALSE);
    if Proc.typecolumn < TypeColumn then
        Proc.typecolumn := TypeColumn;
    end if;
    SL.Attach(Argument.default, SP.Make_Persistent(Default));
    Define_Argument_Help(Proc, Name, Help);

    end Define_Argument;

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

    procedure Define_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING;
    Help : in STRING
    ) is

    begin

    Destroy_Argument_Help(Proc, Name);
    Set_Argument_Help(Proc, Name, Help);

    end Define_Argument_Help;

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

    procedure Append_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING;
    Help : in STRING
    ) is

    begin

    Set_Argument_Help(Proc, Name, Help);

    end Append_Argument_Help;

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

    function Get_Argument(
    Proc : in Process_Handle;
    Name : in STRING
    ) return SP.String_Type is

    begin

    Check_Invalid_Kind(Proc, Name, STR);
    if Get_Argument_Handle(Proc, Name).supplied then
        return SP.Make_Persistent(SL.FirstValue(Get_Argument_Handle(Proc, Name).value));
    else
        return SP.Make_Persistent(SL.FirstValue(Get_Argument_Handle(Proc, Name).default));
    end if;

    end Get_Argument;

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

    function Get_Default(
    Proc : in Process_Handle;
    Name : in STRING
    ) return SP.String_Type is

    begin

    Check_Invalid_Kind(Proc, Name, STR);
    if Get_Argument_Handle(Proc, Name).required then
        raise No_Default;
    else
        return SP.Make_Persistent(SL.FirstValue(Get_Argument_Handle(Proc, Name).default));
    end if;

    end Get_Default;

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

    function Defaulted(
    Proc : in Process_Handle;
    Name : in STRING
    ) return BOOLEAN is

    begin

    Check_Invalid_Kind(Proc, Name, STR);
    return not Get_Argument_Handle(Proc, Name).supplied;

    end Defaulted;

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

begin

    SP.Mark;

    if not SP.Equal(SP.Upper(String_Type_Name), "STRING") then
    TypeColumn := 9;
    end if;

    SP.Release;

end String_Argument;
                                                                    pragma Page;
package body String_List_Argument is

    TypeColumn : POSITIVE := 6;

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

    procedure Define_Argument(
    Proc    : in Process_Handle;
    Name    : in STRING;
    Help    : in STRING
    ) is

    Argument : Argument_Handle;

    begin

    Argument := Set_Argument(Proc, Name, STR_LIST, String_Type_Name, String_Type_List, TRUE);
    if Proc.typecolumn < TypeColumn then
        Proc.typecolumn := TypeColumn;
    end if;
    Define_Argument_Help(Proc, Name, Help);

    end Define_Argument;

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

    procedure Define_Argument(
    Proc    : in Process_Handle;
    Name    : in STRING;
    Default : in SL.List;
    Help    : in STRING
    ) is

    Argument : Argument_Handle;
    Def_Iter : SL.ListIter;
    Def_Val  : SP.String_Type;

    begin

    Argument := Set_Argument(Proc, Name, STR_LIST, String_Type_Name, String_Type_List, FALSE);
    if Proc.typecolumn < TypeColumn then
        Proc.typecolumn := TypeColumn;
    end if;
    Def_Iter := SL.MakeListIter(Default);
    while SL.More(Def_Iter) loop
        SL.Next(Def_Iter, Def_Val);
        SL.Attach(Argument.default, SP.Make_Persistent(Def_Val));
    end loop;
    Define_Argument_Help(Proc, Name, Help);

    end Define_Argument;

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

    procedure Define_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING;
    Help : in STRING
    ) is

    begin

    Destroy_Argument_Help(Proc, Name);
    Set_Argument_Help(Proc, Name, Help);

    end Define_Argument_Help;

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

    procedure Append_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING;
    Help : in STRING
    ) is

    begin

    Set_Argument_Help(Proc, Name, Help);

    end Append_Argument_Help;

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

    function Get_Argument(
    Proc : in Process_Handle;
    Name : in STRING
    ) return SL.List is

    List     : SL.List := SL.Create;
    Item     : SP.String_Type;
    Iterator : SL.ListIter;

    begin

    Check_Invalid_Kind(Proc, Name, STR_LIST);
    if Get_Argument_Handle(Proc, Name).supplied then
        Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).value);
    else
        Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).default);
    end if;
    while SL.More(Iterator) loop
        SL.Next(Iterator, Item);
        SL.Attach(List, Item);
    end loop;
    return List;

    end Get_Argument;

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

    function Get_Default(
    Proc : in Process_Handle;
    Name : in STRING
    ) return SL.List is

    List     : SL.List := SL.Create;
    Item     : SP.String_Type;
    Iterator : SL.ListIter;

    begin

    Check_Invalid_Kind(Proc, Name, STR_LIST);
    if Get_Argument_Handle(Proc, Name).required then
        raise No_Default;
    else
        Iterator := SL.MakeListIter(Get_Argument_Handle(Proc, Name).default);
    end if;
    while SL.More(Iterator) loop
        SL.Next(Iterator, Item);
        SL.Attach(List, Item);
    end loop;
    return List;

    end Get_Default;

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

    function Defaulted(
    Proc : in Process_Handle;
    Name : in STRING
    ) return BOOLEAN is

    begin

    Check_Invalid_Kind(Proc, Name, STR_LIST);
    return not Get_Argument_Handle(Proc, Name).supplied;

    end Defaulted;

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

begin

    SP.Mark;

    if not SP.Equal(SP.Upper(String_Type_Name), "STRING") then
    TypeColumn := 9;
    end if;

    SP.Release;

end String_List_Argument;
                                                                    pragma Page;
package body Command_Line is

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

    procedure Show_Command_Help(
    Handles : in Process_Handle_Array
    ) is

    begin

    Short_Help := TRUE;
    New_Line(1);
    for i in Command_Enumeration loop
        Show_Help(Handles(i));
    end loop;
    New_Line(1);
    Short_Help := FALSE;

    end Show_Command_Help;

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

    function Parse_Command_Line(
    Handles : in Process_Handle_Array;
    Line    : in STRING
    ) return Command_Enumeration is

    Scanner : SU.Scanner;
    Found   : BOOLEAN;
    Cmd     : SP.String_Type;
    Arg     : SP.String_Type;
    Command : Command_Enumeration;

    begin

    if SU.Strip(Line) = "" then
        if Command_Switches(Show_Help_on_Null) = ON then
        Show_Command_Help(Handles);
        end if;
        raise No_Command;
    end if;

    SP.Mark;
    Scanner := SU.Make_Scanner(SU.Strip(Line));
    if SU.Is_Ada_Id(Scanner) then
        SS.Scan_Ada_Id(Scanner, Found, Cmd);
    else
        SS.Scan_Word(Scanner, Found, Cmd);
    end if;
    declare
        Command_String : STRING (1 .. SP.Length(Cmd)) := SP.Value(SP.Upper(Cmd));
    begin
        SP.Flush(Cmd);
        Command := Command_Enumeration'value(Command_String);
        SU.Skip_Space(Scanner);
        Arg := SS.Get_Remainder(Scanner);
        SU.Destroy_Scanner(Scanner);
        Parse_Line(Handles(Command), SP.Value(Arg));
        SP.Flush(Arg);
        SP.Release;
        return Command;
    exception
        when CONSTRAINT_ERROR =>
        SU.Destroy_Scanner(Scanner);
        if Command_String = "EXIT" then
            SP.Release;
            raise Command_Exit;
        elsif Command_String = "HELP" then
            if Command_Switches(Show_Help) = ON then
            Show_Command_Help(Handles);
            end if;
            SP.Release;
            raise Command_Help;
        else
            if Command_Switches(Show_Error) = ON then
            Report_Error(Invalid_Command, Value=>Command_String);
            end if;
            if Command_Switches(Show_Help_on_Error) = ON then
            Show_Command_Help(Handles);
            end if;
            SP.Release;
            raise Abort_Command;
        end if;
    end;
    raise Internal_Error;

    end Parse_Command_Line;

end Command_Line;
                                                                    pragma Page;
----------------------- Local Subprogams -----------------------

function Release return STRING is separate;

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

procedure Check_ID is

begin

    if not Set_ID then
    raise Identifier_Error;
    end if;

end Check_ID;

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

procedure Check_Uninitialized(
    Proc : in Process_Handle
    ) is

begin

    if Proc = null then
    Short_Help := FALSE;
    raise Uninitialized;
    end if;

end Check_Uninitialized;

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

procedure Check_Already_Exists(
    Proc : in Process_Handle
    ) is

begin

    if Proc /= null then
    raise Already_Exists;
    end if;

end Check_Already_Exists;

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

procedure Check_Invalid_Name(
    Name : in STRING
    ) is

    Scanner : SU.Scanner;
    Str     : SP.String_Type;
    Found   : BOOLEAN;

begin

    SP.Mark;
    Scanner := SS.Make_Scanner(SP.Create(Name));
    SS.Scan_Ada_Id(Scanner, Found, Str);
    SP.Release;
    if Found then
    SP.Flush(Str);
    if SU.More(Scanner) then
        Found := FALSE;
    end if;
    end if;
    if not Found then
    raise Invalid_Name;
    end if;

end Check_Invalid_Name;

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

procedure Check_Undefined_Name(
    Proc : in Process_Handle;
    Name : in STRING
    ) is

    Item : Argument_Handle;

begin

    Check_Uninitialized(Proc);
    Check_Invalid_Name(Name);
    Item := Find_Match(Proc, Name);
    if Item = null then
    raise Undefined_Name;
    end if;

end Check_Undefined_Name;

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

procedure Check_Duplicate_Name(
    Proc : in Process_Handle;
    Name : in STRING
    ) is

begin

    Check_Undefined_Name(Proc, Name);
    raise Duplicate_Name;

exception
    when Undefined_Name =>
    null;

end Check_Duplicate_Name;

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

procedure Check_Not_Yet_Parsed(
    Proc : in Process_Handle
    ) is

begin

    Check_Uninitialized(Proc);
    if not Proc.parsed then
    raise Not_Yet_Parsed;
    end if;

end Check_Not_Yet_Parsed;

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

procedure Check_Already_Parsed(
    Proc : in Process_Handle
    ) is

begin

    Check_Uninitialized(Proc);
    if Proc.parsed then
    raise Already_Parsed;
    end if;

end Check_Already_Parsed;

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

procedure Check_Invalid_Kind(
    Proc : in Process_Handle;
    Name : in STRING;
    Kind : in Argument_Kind
    ) is

begin

    Check_Undefined_Name(Proc, Name);
    Check_Not_Yet_Parsed(Proc);
    if Get_Argument_Handle(Proc, Name).kind /= Kind then
    raise Invalid_Kind;
    end if;

end Check_Invalid_Kind;

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

procedure Write(
    Text  : in STRING
    ) is

begin

    TEXT_IO.PUT_LINE(Text);

end Write;

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

procedure New_Line(
    Count : in POSITIVE
    ) is

begin

    TEXT_IO.NEW_LINE(TEXT_IO.POSITIVE_COUNT(Count));

end New_Line;

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

procedure Write_List_Vertical(
    Header  : in STRING;
    List    : in SL.List
    ) is

    B_Str : SP.String_Type;
    Iter  : SL.ListIter;
    Done  : BOOLEAN := FALSE;

begin

    TEXT_IO.PUT("-- ");
    TEXT_IO.PUT(Header);
    Iter := SL.MakeListIter(List);
    while SL.More(Iter) loop
    SP.Mark;
    SL.Next(Iter, B_Str);
    if Done then
        TEXT_IO.PUT("-- ");
        declare
        Blanks : STRING (1 .. Header'length) := (others => ' ');
        begin
        TEXT_IO.PUT(Blanks);
        end;
    else
        Done := TRUE;
    end if;
    begin
        Write(SP.Value(B_Str));
        SP.Release;
    exception
        when others =>
        SP.Release;
        raise;
    end;
    end loop;
    if not Done then
    New_Line(1);
    end if;

end Write_List_Vertical;

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

procedure Write_List_Horizontal(
    List    : in SL.List;
    Quoted  : in BOOLEAN := FALSE
    ) is

    B_Str : SP.String_Type;
    Iter  : SL.ListIter;
    First : BOOLEAN := TRUE;

begin

    Iter := SL.MakeListIter(List);
    while SL.More(Iter) loop
    if not First then
        TEXT_IO.PUT(SP.Fetch(Delimiter, 1) & " ");
    else
        First := FALSE;
    end if;
    SP.Mark;
    SL.Next(Iter, B_Str);
    if Quoted then
        B_Str := SP."&"("""", B_Str);
        B_Str := SP."&"(B_STR, """");
    end if;
    TEXT_IO.PUT(SP.Value(B_Str));
    SP.Release;
    end loop;

end Write_List_Horizontal;

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

function Find_Match(
    Proc : in Process_Handle;
    Name : in STRING
    ) return Argument_Handle is

    Iterator : AL.ListIter;
    Item     : Argument_Handle;

begin

    Iterator := AL.MakeListIter(Proc.args);
    while AL.More(Iterator) loop
    AL.Next(Iterator, Item);
    if SP.Equal(Item.name, SP.Upper(Name)) then
        return Item;
    end if;
    end loop;
    return null;

end Find_Match;

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

function Get_Argument_Handle(
    Proc : in Process_Handle;
    Name : in STRING
    ) return Argument_Handle is

    Item     : Argument_Handle;

begin

    Check_Invalid_Name(Name);
    Check_Undefined_Name(Proc, Name);
    return Find_Match(Proc, Name);

end Get_Argument_Handle;

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

procedure Destroy_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING
    ) is

    Iterator : AL.ListIter;
    Item     : Argument_Handle;

begin

    Check_Invalid_Name(Name);
    Check_Already_Parsed(Proc);
    Iterator := AL.MakeListIter(Proc.args);
    while AL.More(Iterator) loop
    AL.Next(Iterator, Item);
    if SP.Equal(Item.name, SP.Upper(Name)) then
        Destroy_String_List(Item.help);
        Item.help := SL.Create;
        return;
    end if;
    end loop;
    raise Undefined_Name;

end Destroy_Argument_Help;

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

procedure Set_Argument_Help(
    Proc : in Process_Handle;
    Name : in STRING;
    Help : in STRING
    ) is

    Iterator : AL.ListIter;
    Item     : Argument_Handle;

begin

    Check_Invalid_Name(Name);
    Check_Already_Parsed(Proc);
    Iterator := AL.MakeListIter(Proc.args);
    while AL.More(Iterator) loop
    AL.Next(Iterator, Item);
    if SP.Equal(Item.name, SP.Upper(Name)) then
        SL.Attach(Item.help, SP.Make_Persistent(Help));
        return;
    end if;
    end loop;
    raise Undefined_Name;

end Set_Argument_Help;

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

function Set_Argument(
    Proc     : in     Process_Handle;
    Name     : in     STRING;
    Kind     : in     Argument_Kind;
    Typename : in     STRING;
    Listname : in     STRING;
    Required : in     BOOLEAN
    ) return Argument_Handle is

    Argument : Argument_Handle;

begin

    Check_Duplicate_Name(Proc, Name);
    Check_Invalid_Name(Typename);
    if Listname /= "" then
    Check_Invalid_Name(Listname);
    end if;
    Check_Already_Parsed(Proc);

    Argument          := new Argument_Record;
    SP.Mark;
    Argument.name     := SP.Make_Persistent(SP.Upper(Name));
    Argument.typename := SP.Make_Persistent(SP.Upper(Typename));
    Argument.listname := SP.Make_Persistent(SP.Upper(Listname));
    Argument.required := Required;
    Argument.kind     := Kind;
    AL.Attach(Proc.args, Argument);
    SP.Release;

    if Proc.maxname < Name'length then
    Proc.maxname := Name'length;
    end if;

    if Proc.maxtypename < Typename'length then
    case Kind is
        when ENUM | ENUM_LIST =>
        if not SP.Equal(Argument.typename, "BOOLEAN") and
           not SP.Equal(Argument.typename, "CHARACTER") then
            Proc.maxtypename := Typename'length;
        end if;
        when INT  | INT_LIST =>
        if not SP.Equal(Argument.typename, "INTEGER") and
           not SP.Equal(Argument.typename, "POSITIVE") and
           not SP.Equal(Argument.typename, "NATURAL") then
            Proc.maxtypename := Typename'length;
        end if;
        when STR | STR_LIST =>
        if not SP.Equal(Argument.typename, "STRING") then
            Proc.maxtypename := Typename'length;
        end if;
    end case;
    end if;

    case Kind is
    when ENUM | INT | STR =>
        if Proc.maxtype < Typename'length then
           Proc.maxtype := Typename'length;
        end if;
    when ENUM_LIST | INT_LIST | STR_LIST =>
        if Proc.maxtype < Listname'length then
           Proc.maxtype := Listname'length;
        end if;
        if Proc.maxtypename < Listname'length then
        Proc.maxtypename := Listname'length;
        end if;
    end case;

    return Argument;

end Set_Argument;

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

procedure Point_Next_Token(
    Scanner : in SU.Scanner
    ) is

begin

    SU.Skip_Space(Scanner);
    if SU.More(Scanner) and then SS.Is_Sequence(Delimiter, Scanner) then
    SU.Forward(Scanner);
    SU.Skip_Space(Scanner);
    end if;

end Point_Next_Token;

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

procedure Get_Next_Token(
    Scanner : in     SU.Scanner;
    Kind    :    out Token_Kind;
    Token   : in out SP.String_Type
    ) is

    S_Str    : SP.String_Type;
    Scan_Arg : SU.Scanner;
    Found    : BOOLEAN;
    Inx1     : POSITIVE;
    Inx2     : POSITIVE;

begin

    if not SU.More(Scanner) then
    Kind := DONE;
    return;
    end if;

    if SU.Is_Quoted(Scanner) or SU.Is_Enclosed(Left_Enclosure, Right_Enclosure, Scanner) then
    Inx1 := SU.Position(Scanner);
    SU.Mark(Scanner);
    SS.Scan_Quoted(Scanner, Found, S_Str);
    if not Found then
        SS.Scan_Enclosed(Left_Enclosure, Right_Enclosure, Scanner, Found, S_Str);
    end if;
    if not SS.Is_Sequence(Delimiter, Scanner) and not SS.Is_Literal(Assignment, Scanner) then
        SU.Skip_Space(Scanner);
    end if;
    if not SS.Is_Sequence(Delimiter, Scanner) and not SS.Is_Literal(Assignment, Scanner) then
        while not SS.Is_Sequence(Delimiter, Scanner) and
          not SS.Is_Literal(Assignment, Scanner) loop
        SU.Forward(Scanner);
        end loop;
        SU.Unmark(Scanner);
        Inx2 := SU.Position(Scanner);
        S_Str := SS.Get_String(Scanner);
        Token := SP.Make_Persistent(SP.Substr(S_Str, Inx1, Inx2 - Inx1));
        SP.Flush(S_Str);
        if SS.Is_Literal(Assignment, Scanner) then
        Kind := NAME;
        else
        Kind := VALUE;
        end if;
        return;
    end if;
    SU.Restore(Scanner);
    end if;


    SP.Mark;
    if SU.Is_Quoted(Scanner) then
    SS.Scan_Quoted(Scanner, Found, Token);
    Kind := QUOTED;
    elsif SU.Is_Enclosed(Left_Enclosure, Right_Enclosure, Scanner) then
    SS.Scan_Enclosed(Left_Enclosure, Right_Enclosure, Scanner, Found, S_Str);
    Token := SP.Make_Persistent(STRING'(SS.Strip(S_Str)));
    Kind := LIST;
    SP.Flush(S_Str);
    elsif SS.Is_Not_Sequence(Delimiter, Scanner) then
    SU.Mark(Scanner);
    SS.Scan_Not_Sequence(Delimiter, Scanner, Found, S_Str);
    Scan_Arg := SS.Make_Scanner(S_Str);
    SP.Flush(S_Str);
    SU.Restore(Scanner);
    if SS.Is_Literal(Assignment, Scan_Arg) then
        SS.Scan_Literal(Assignment, Scanner, Found);
        Kind := BIND;
    elsif SS.Is_Not_Literal(Assignment, Scan_Arg) then
        SS.Scan_Not_Literal(Assignment, Scanner, Found, S_Str);
        Kind := NAME;
        Token := SP.Make_Persistent(STRING'(SS.Strip_Trailing(S_Str)));
        SP.Flush(S_Str);
    else
        SS.Scan_Not_Sequence(Delimiter, Scanner, Found, S_Str);
        SU.Skip_Space(Scanner);
        if SS.Is_Literal(Assignment, Scanner) then
        Kind := NAME;
        else
        Kind := VALUE;
        end if;
        Token := SP.Make_Persistent(STRING'(SS.Strip_Trailing(S_Str)));
        SP.Flush(S_Str);
    end if;
    SU.Destroy_Scanner(Scan_Arg);
    else
    Kind := NONE;
    end if;
    Point_Next_Token(Scanner);
    SP.Release;

end Get_Next_Token;

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

procedure Parse_Argument(
    Argument : in Argument_Handle;
    Item     : in SP.String_Type;
    Kind     : in Token_Kind
    ) is

    Iterator   : SL.ListIter;
    Num        : INTEGER;
    R_Str      : SP.String_Type;
    S_Str      : SP.String_Type;
    Element    : SP.String_Type;
    Scanner    : SU.Scanner;
    Found      : BOOLEAN;
    First      : BOOLEAN;
    List_Error : BOOLEAN := FALSE;

begin

    case Argument.kind is

    when ENUM =>
        if Kind = VALUE then
        Iterator := SL.MakeListIter(Argument.valid);
        while SL.More(Iterator) loop
            SL.Next(Iterator, R_Str);
            if SP.Equal(SP.Upper(Item), R_Str) then
            SL.Attach(Argument.value, SP.Make_Persistent(R_Str));
            Argument.supplied := TRUE;
            return;
            end if;
        end loop;
        end if;

    when INT =>
        if Kind = VALUE then
        begin
            Num := INTEGER'value(SP.Value(Item));
            if Argument.low <= Num and Num <= Argument.high then
            SL.Attach(Argument.value, SP.Make_Persistent(Item));
            Argument.supplied := TRUE;
            return;
            end if;
        exception
            when CONSTRAINT_ERROR =>
            null;
        end;
        end if;

    when STR =>
        if Kind = QUOTED or Parsing_Switches(Quote_Enclosure) = OFF then
        SL.Attach(Argument.value, SP.Make_Persistent(Item));
        Argument.supplied := TRUE;
        return;
        else
        Report_Error(Missing_Quotes, Value=>SP.Value(Item));
        end if;

    when ENUM_LIST =>
        if Kind = LIST or
          (Parsing_Switches(Argument_Enclosure) = OFF and Kind = VALUE) then
        Scanner := SS.Make_Scanner(SP."&"(Item, "" & SP.Fetch(Delimiter, 1)));
        First := TRUE;
        while SU.More(Scanner) loop
            SS.Scan_Not_Sequence(Delimiter, Scanner, Found, Element, Skip => TRUE);
            S_Str := SP.Upper(STRING'(SS.Strip_Trailing(Element)));
            Iterator := SL.MakeListIter(Argument.valid);
            Found := FALSE;
            while SL.More(Iterator) loop
            SL.Next(Iterator, R_Str);
            if SP.Equal(S_Str, R_Str) then
                SL.Attach(Argument.value, SP.Make_Persistent(R_Str));
                Found := TRUE;
                exit;
            end if;
            end loop;
            if not Found then
            if not First then
                if not SP.Is_Empty(S_Str) then
                Report_Error(Invalid_Value, Value=>SP.Value(S_Str));
                else
                if not List_Error then
                    Report_Error(Invalid_List,
                         Value => Left_Enclosure &
                              SP.Value(Item) &
                              Right_Enclosure);
                    List_Error := TRUE;
                end if;
                end if;
            else
                if not SP.Is_Empty(S_Str) then
                Report_Error(Invalid_Value, Value=>SP.Value(S_Str));
                else
                Argument.supplied := TRUE;
                end if;
            end if;
            else
            Argument.supplied := TRUE;
            end if;
            SP.Flush(Element);
            Point_Next_Token(Scanner);
            First := FALSE;
        end loop;
        return;
        end if;

    when INT_LIST =>
        if Kind = LIST or
          (Parsing_Switches(Argument_Enclosure) = OFF and Kind = VALUE) then
        Scanner := SS.Make_Scanner(SP."&"(Item, "" & SP.Fetch(Delimiter, 1)));
        First := TRUE;
        while SU.More(Scanner) loop
            SS.Scan_Not_Sequence(Delimiter, Scanner, Found, Element, Skip => TRUE);
            S_Str := SS.Strip_Trailing(Element);
            Found := FALSE;
            begin
            Num := INTEGER'value(SP.Value(S_Str));
            if Argument.low <= Num and Num <= Argument.high then
                SL.Attach(Argument.value, SP.Make_Persistent(S_Str));
                Found := TRUE;
            end if;
            exception
            when CONSTRAINT_ERROR =>
                null;
            end;
            if not Found then
            if not First then
                if not SP.Is_Empty(S_Str) then
                Report_Error(Invalid_Value, Value=>SP.Value(S_Str));
                else
                if not List_Error then
                    Report_Error(Invalid_List,
                         Value => Left_Enclosure &
                              SP.Value(Item) &
                              Right_Enclosure);
                    List_Error := TRUE;
                end if;
                end if;
            else
                if not SP.Is_Empty(S_Str) then
                Report_Error(Invalid_Value, Value=>SP.Value(S_Str));
                else
                Argument.supplied := TRUE;
                end if;
            end if;
            else
            Argument.supplied := TRUE;
            end if;
            SP.Flush(Element);
            Point_Next_Token(Scanner);
            First := FALSE;
        end loop;
        return;
        end if;

    when STR_LIST =>
        if Kind = LIST or
           Parsing_Switches(Argument_Enclosure) = OFF then
        Scanner := SS.Make_Scanner(SP."&"(Item, "" & SP.Fetch(Delimiter, 1)));
        First := TRUE;
        while SU.More(Scanner) loop
            if Kind = LIST then
            if SU.Is_Quoted(Scanner) then
                SS.Scan_Quoted(Scanner, Found, Element);
            else
                SS.Scan_Not_Sequence(Delimiter, Scanner, Found, Element, Skip => TRUE);
                if Parsing_Switches(Quote_Enclosure) = ON and
                   not SP.Is_Empty(SS.Strip(Element)) then
                Report_Error(Missing_Quotes, Value=>SP.Value(Element));
                end if;
            end if;
            S_Str := SS.Strip_Trailing(Element);
            else
            S_Str := SS.Get_String(Scanner);
                Element := SP.Make_Persistent(SP.Substr(S_Str, 1, SP.Length(S_Str) - 1));
                SP.Flush(S_Str);
            if Kind /= QUOTED then
                S_Str := SS.Strip(Element);
            else
                S_Str := Element;
            end if;
            SU.Backward(Scanner);
            end if;
            if SP.Is_Empty(S_Str) then
            if not First then
                if not List_Error then
                Report_Error(Invalid_List,
                         Value => Left_Enclosure &
                              SP.Value(Item) &
                              Right_Enclosure);
                List_Error := TRUE;
                end if;
            else
                Argument.supplied := TRUE;
            end if;
            else
            Argument.supplied := TRUE;
            SL.Attach(Argument.value, SP.Make_Persistent(S_Str));
            end if;
            SP.Flush(Element);
            Point_Next_Token(Scanner);
            First := FALSE;
        end loop;
        return;
        end if;
    end case;

    case Kind is
    when LIST =>
        Report_Error(Invalid_List,
             Value => Left_Enclosure &
                  SP.Value(S_Str) &
                  Right_Enclosure);
        Report_Error(Invalid_List, Value=>SP.Value(S_Str));
    when QUOTED =>
        S_Str := SP.Create('"' & SP.Value(Item) & '"');
        Report_Error(Invalid_Value, Value=>SP.Value(S_Str));
    when others =>
        Report_Error(Invalid_Value, Value=>SP.Value(Item));
    end case;

end Parse_Argument;

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

procedure Report_Error(
    Kind     : in Error_Types;
    Argument : in STRING := "";
    Name     : in STRING := "";
    Value    : in STRING := ""
    ) is

    S_Str : SP.String_Type;
    Num   : NATURAL;

begin

    if Errors(Kind).flag = CONTINUE then
    Status := ERROR;
    else
    Status := SEVERE;
    end if;
    if Action_Switches(Show_Error) = OFF then
    return;
    end if;
    SP.Mark;
    S_Str := Errors(Kind).msg;
    loop
    Num := SP.Match_S(S_Str, "~A");
    exit when Num = 0;
    S_Str := SP.Splice(S_Str, Num, 2);
    S_Str := SP.Insert(S_Str, Argument, Num);
    end loop;
    loop
    Num := SP.Match_S(S_Str, "~N");
    exit when Num = 0;
    S_Str := SP.Splice(S_Str, Num, 2);
    S_Str := SP.Insert(S_Str, Name, Num);
    end loop;
    loop
    Num := SP.Match_S(S_Str, "~V");
    exit when Num = 0;
    S_Str := SP.Splice(S_Str, Num, 2);
    S_Str := SP.Insert(S_Str, Value, Num);
    end loop;
    HL.Put_Error(SP.Value(S_Str));
    SP.Release;

end Report_Error;

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

end Standard_Interface;
                                                                    pragma Page;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--RELEASE.SUB
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

separate (Standard_Interface)

function Release return STRING is

begin

    return "3.01";

    -- The executable's header line will contain the return string
    -- as it appears above.

end Release;