Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/sql/dames.src

Text File | 1988-05-03 | 602.0 KB | 13,535 lines

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--constants.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package CONSTANTS is

--************************************************************************
--**                                                                    **
--**                               CONSTANTS                            **
--**                               ~~~~~~~~~                            **
--****   Version: 01                              Date: 25-Mar-85       **
--**     Author: JF Cabadi                                              **
--**     Modifications:                                                 **
--**                                                                    **
--**  HISTORY  ---------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**====================================================================**
--**                                                                    **
--**  DESCRIPTION                                                       **
--**  ~~~~~~~~~~~                                                       **
--**                                                                    **
--**                                                                    **
--**  It contains  the  declaration  of  constants which are usually    **
--**  limits of the interface (like the  maximum  column  number for a  **
--**  table, or the maximum character string size), and declaration of  **
--**  types  which  are  widely  used in the interface  (like  integer  **
--**  arrays and word arrays).                                          **
--**                                                                    **
--**                                                                    **
--**  LIMITS  ----------------------------------------------------------**
--**  ~~~~~~                                                            **
--**                                                                    **
--**  CONSTRAINTS  -----------------------------------------------------**
--**  ~~~~~~~~~~~                                                       **
--**                                                                    **
--**  BUGS  ------------------------------------------------------------**
--**  ~~~~                                                              **
--**                                                                    **
--************************************************************************



    NAME_LENGTH : constant := 10;
--      NAME_LENGTH defines the maximum useful length for a table name
-- and for a column name.

    COL_NO : constant := 75;
-- maximum column number for a table

    TABLE_NO : constant := 5;
-- maximum number of simultaneously locked tables

    IMAGE_SZ : constant := 40;
-- maximum character length of the images of an enumeration type

    MAX_STRING : constant := 100;
-- maximum size (in characters) of a character string type
-- (this is a DAMES feature)

    RANGE_SIZE : constant := IMAGE_SZ;
-- This is the maximum width (in characters) of the image of a
-- range constraint as stored in the ADARANGE reserved table.

    type INTEGER_ARRAY_TYPE is array (INTEGER range <>) of INTEGER;
-- array of 32 bits integer's; when used, this type is constrained with
-- an index constraint like : (1 .. n)
-- INTEGER_ARRAY_TYPE objects are used to send or receive values to and
-- from the Fortran77 DAMES access subroutines.

    type INTEGER16 is new SHORT_INTEGER;
-- 2 power 16 different values

    type INTEGER16_ARRAY_TYPE is array (INTEGER range <>) of INTEGER16;
-- array of 16 bits integer's;
-- INTEGER16_ARRAY_TYPE objects are used to manage values of a
-- not-to-be-known type, while 16 bits is the size of the packets to
-- be managed without modifications inside.

    subtype TIDD_TYPE is INTEGER_ARRAY_TYPE (1 .. 3);
-- TIDD_TYPE is used by the F77 access subroutines to define the
-- current row.

end CONSTANTS;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--llspec.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with CONSTANTS;
use CONSTANTS;

package LL_DAMES is


    X_CANT_ACCESS_DB,
    X_CANT_ACCESS_TABLE,
    X_FULL_TABLE,
    X_INTERNAL_ERROR,
    X_INVALID_COLUMN,           -- These exceptions are raised
    X_INVALID_CRITERION,        -- in the LL_DAMES subprograms
    X_INVALID_VALUE,            -- when errors occur in.
    X_NO_CURRENT_ROW,
    X_NO_MORE_ROWS,
    X_NO_OPEN_DB,
    X_NO_PREVIOUS_FIND,
    X_NO_PREVIOUS_MATCH,
    X_OPEN_DB,
    X_SHARED_MODE_LOCK,
    X_TABLE_NOT_LOCKED,
    X_TOO_SHORT_STRING : exception;

    procedure OPEN (DB_NAME : STRING);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          OPEN                                        **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**    OPEN    must be used to open a database to be accessed via the  **
--**  low  level  Ada  interface.                                       **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  DB_NAME is the name of the database to be open.                   **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_CANT_ACCESS_DB  is  raised  if the requested  database  is  **
--**  unknown, or cannot be accessed for any other reason.              **
--**                                                                    **
--**      X_OPEN_DB is raised if there  is  an  already open database.  **
--**                                                                    **
--************************************************************************

    procedure DEFINE_TABLE (TABLE_NAME  : STRING;
                            COLUMN_LIST : STRING);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          DEFINE_TABLE                                **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**  The procedure   DEFINE_TABLE allows the Ada programmer to create  **
--**  a table  ( like  using  the  'DEFINE  TABLE' command of the User  **
--**  Language); the difference  between  these  two  ways is that the  **
--**  first  one  allows  a  greater  choice in column types than  the  **
--**  second  one.   When successfully  created,  the  table  is  left  **
--**  unlocked,  and  thus  must be locked like  any other table to be  **
--**  accessed by the creating unit.                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**          * TABLE_NAME is the name of the table to be created.      **
--**                                                                    **
--**          * COLUMN_LIST   is  a  string describing the table;  the  **
--**  column descriptors are separated with semi-colons ; each  column  **
--**  descriptor is a string describing the name,  type,  and optional  **
--**  constraint  of  the  column;  the  following form is to be  used  **
--**  (B.N.F. notation) :                                               **
--**    COLUMN_LIST    := <column_descr> {; <column_descr> }            **
--**    <column_descr> := <scalar_descr> | <record_descr>               **
--**    <record_descr> := <name> <scalar_descr> {, <scalar-descr>}      **
--**    <scalar_descr> := <name> [<type>]                               **
--**    <name> is a valid column name                                   **
--**    <type>         := STRING [(1 .. n)] |                           **
--**                      FLOAT  [<constraint>] |                       **
--**                      INTEGER [<constraint>] |                      **
--**                      <enumeration_type_definition> [<constraint>]  **
--**    <constraint>   := RANGE <value> .. <value>                      **
--**    <value> is a litteral the type of which depends on the          **
--**                      associated  type                              **
--**    <enumeration_type_definition> is defined with this name in the  **
--**                      ADA  Reference  Manual ;  it  is  a  list of  **
--**                      enumeration litterals separated by commas and **
--**                      enclosed in parentheses.                      **
--**                                                                    **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_NO_OPEN_DB  is  raised  if  there  is  no  currently  open  **
--**  database.                                                         **
--**                                                                    **
--**      X_INVALID_COLUMN is raised if COLUMN_LIST  is  not  correct.  **
--**                                                                    **
--**      X_CANT_ACCESS_TABLE is raised if the requested table  cannot  **
--**  be created for any reason.                                        **
--**                                                                    **
--************************************************************************

    type ACCESS_MODE_TYPE is (SHARED, EXCLUSIVE);
    type LOCK_TYPE is
        record
            TABLE_NAME  : STRING (1 .. NAME_LENGTH);
            ACCESS_MODE : ACCESS_MODE_TYPE;
        end record;
    type LOCK_LIST_TYPE is array (INTEGER range <>) of LOCK_TYPE;
    procedure LOCK     (LOCK_LIST : LOCK_LIST_TYPE);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          LOCK                                        **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**    LOCK        removes  all  previously  set  locks (if any), and  **
--**  then sets those described in the LOCK_LIST list.                  **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  LOCK_LIST  is  an array  of  LOCK_TYPE  records,  each  of  them  **
--**  describing a single lock; the two components of a LOCK_TYPE  are  **
--**  TABLE_NAME,  which  identifies  a  table, and ACCESS_MODE, which  **
--**  describes in which mode (shared or exclusive) the table is to be  **
--**  accessed.                                                         **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_CANT_ACCESS_TABLE if one or several of the given names do not **
--**  exist in currently open database, or if they cannot all be locked.**
--**                                                                    **
--**    X_NO_OPEN_DB   if   no   database   is   currently   open.      **
--**                                                                    **
--************************************************************************

    procedure GET_INFORMATION (TABLE_NAME    : STRING;
                               COLUMN_NUMBER : out POSITIVE;
                               COLUMN_LIST   : out STRING   );
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          GET_INFORMATION                             **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**    GET_INFORMATION  returns  to  the  user the information  given  **
--**  during the creation of the named table.                           **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME is the name of the table the user wants  information   **
--**  about.                                                            **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**  COLUMN_NUMBER  is  the  number of columns  the  table  contains.  **
--**                                                                    **
--**  COLUMN_LIST is the list of the column definitions of the  table,  **
--**  in   the   same   format   as  the  DEFINE_TABLE  one.            **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_NO_OPEN_DB  is  raised  if  there  is  no  currently  open  **
--**  database.                                                         **
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**      X_TOO_SHORT_STRING is raised if COLUMN_LIST  is  not  long    **
--**  enough to be assigned the description of the table.               **
--**                                                                    **
--************************************************************************

    procedure UNLOCK;
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          UNLOCK                                      **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**    UNLOCK        removes all the previously set  locks  (if any);  **
--**  The previously locked tables must be locked again to be accessed  **
--**  again.                                                            **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_NO_OPEN_DB  is  raised  if  there  is  no  currently  open  **
--**  database.                                                         **
--**                                                                    **
--************************************************************************

    procedure CLOSE;
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          CLOSE                                       **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**    CLOSE    must be used when no more actions are to be performed  **
--**  on an open database; all locked tables are  first  unlocked, and  **
--**  the database is then closed.                                      **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_NO_OPEN_DB  is  raised  if  there  is  no  currently  open  **
--**  database.                                                         **
--**                                                                    **
--**                                                                    **
--************************************************************************

    type KEY_MATCH_TYPE is (EQUAL, NOT_EQUAL, LESS, LESS_OR_EQUAL,
                                            GREATER, GREATER_OR_EQUAL);
    generic
        type USER_COLUMN is private;
--      To use this procedure, the user must first instantiate it with
-- the type of the column to be used as key.
    procedure MATCH (TABLE_NAME   : STRING;
                     COLUMN_NAME  : STRING;
                     KEY_MATCH    : KEY_MATCH_TYPE;
                     COLUMN_VALUE : USER_COLUMN);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          MATCH                                       **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**    MATCH is the first procedure to be used to  build  a selection  **
--**  criterion; a selection criterion is a  logical  expression which  **
--**  has the  value  TRUE  or  FALSE  for  each row of a given table,  **
--**  depending  on  the values  of  columns  of  the  candidate  row.  **
--**                                                                    **
--**  This  logical  expression is  composed  of  one  or  more  basic  **
--**  expressions connected  by  OR's and AND's, each  of  these basic  **
--**  expressions being defined  by  a MATCH call for  the  first, and  **
--**  by an OR_MATCH and by an AND_MATCH call for the following,if the  **
--**  selection criterion  is  not  a  single basic expression itself.  **
--**                                                                    **
--**  A basic expression looks like  'COLUMN  match  VALUE', where the  **
--**  column to be used is defined by its name, where 'match' is '=' ,  **
--**  '/=' , '=<' , '>=' , '<' or '>' , and where VALUE is an Ada value,**
--**  the type of which is the same as the type of the associated column**
--**                                                                    **
--**  All the previous call's to   MATCH,   AND_MATCH,   OR_MATCH       **
--**  or   FIND (for the same table) are forgotten.                     **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of  the table on which the  selection  **
--**  criterion will be applied.                                        **
--**                                                                    **
--**  COLUMN_NAME is the name of the column to be used.                 **
--**                                                                    **
--**  KEY_MATCH is the match to be performed between the column of the  **
--**  candidate row and COLUMN_VALUE.                                   **
--**                                                                    **
--**  COLUMN_VALUE is the value to  be  compared  with the COLUMN_NAME  **
--**  column.                                                           **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_INVALID_VALUE is raised if  COLUMN_VALUE  is  not  correct. **
--**                                                                    **
--**      X_INVALID_COLUMN  is  raised  if   COLUMN_NAME   is  unknown, **
--**  or if it is  a  record  column  instead  of  a  scalar  column,   **
--**  or if its type does not match the USER_COLUMN type.               **
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**                                                                    **
--************************************************************************
    generic
        type USER_COLUMN is private;
--      To use this procedure, the user must first instantiate it with
-- the type of the column to be used as key.
    procedure OR_MATCH  (TABLE_NAME   : STRING;
                         COLUMN_NAME  : STRING;
                         KEY_MATCH    : KEY_MATCH_TYPE;
                         COLUMN_VALUE : USER_COLUMN);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          OR_MATCH                                    **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**    OR_MATCH is to be used  to  complete  the selection criterion   **
--**  the user started  to  define  using  the   MATCH procedure.       **
--**  A   selection   criterion   is   a   logical   expression  which  **
--**  has the  value  TRUE  or  FALSE  for  each row of a given table,  **
--**  depending  on  the values  of  columns  of  the  candidate  row.  **
--**                                                                    **
--**  This  logical  expression is  composed  of  one  or  more  basic  **
--**  expressions connected with OR's and AND's, each  of  these basic  **
--**  expressions being defined by a   MATCH call for  the  first, and  **
--**  by an OR_MATCH and or an AND_MATCH call for the following,if the  **
--**  selection criterion  is  not  a  single basic expression itself.  **
--**                                                                    **
--**  A basic expression looks like  'COLUMN  match  VALUE', where the  **
--**  column to be used is defined by its name, where 'match' is '=' ,  **
--**  '/=' , '=<' , '>=' , '<' or '>' , and where VALUE is an Ada value,**
--**  the type of which is the same as the type of the associated column**
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of  the table on which the  selection  **
--**  criterion will be applied.                                        **
--**                                                                    **
--**  COLUMN_NAME is the name of the column to be used.                 **
--**                                                                    **
--**  KEY_MATCH is the match to be performed between the column of the  **
--**  candidate row and COLUMN_VALUE.                                   **
--**                                                                    **
--**  COLUMN_VALUE is the value to  be  compared  with the COLUMN_NAME  **
--**  column.                                                           **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_INVALID_VALUE is raised if COLUMN_VALUE is not correct.     **
--**                                                                    **
--**      X_INVALID_COLUMN  is  raised  if   COLUMN_NAME   is  unknown  **
--**  or if it is  a  record  column  instead  of  a  scalar  column,   **
--**  or if its type does not match the USER_COLUMN type.               **
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**      X_NO_PREVIOUS_MATCH is raised if a previous call to MATCH is  **
--**  missing.                                                          **
--**                                                                    **
--**                                                                    **
--************************************************************************
    generic
        type USER_COLUMN is private;
--      To use this procedure, the user must first instantiate it with
-- the type of the column to be used as key.
    procedure AND_MATCH (TABLE_NAME   : STRING;
                         COLUMN_NAME  : STRING;
                         KEY_MATCH    : KEY_MATCH_TYPE;
                         COLUMN_VALUE : USER_COLUMN);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          AND_MATCH                                   **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**    AND_MATCH is to be used  to  complete  the selection criterion  **
--**  the user started  to  define  using  the   MATCH procedure.       **
--**  A   selection   criterion   is   a   logical   expression  which  **
--**  has the  value  TRUE  or  FALSE  for  each row of a given table,  **
--**  depending  on  the values  of  columns  of  the  candidate  row.  **
--**                                                                    **
--**  This  logical  expression is  composed  of  one  or  more  basic  **
--**  expressions connected with OR's and AND's, each  of  these basic  **
--**  expressions being defined by a   MATCH call for  the  first, and  **
--**  by an OR_MATCH or an AND_MATCH  call for the  following,  if the  **
--**  selection criterion  is  not  a  single basic expression itself.  **
--**                                                                    **
--**  A basic expression looks like  'COLUMN  match  VALUE', where the  **
--**  column to be used is defined by its name, where 'match' is '=' ,  **
--**  '/=' , '=<' , '>=' , '<' or '>' , and where VALUE is an Ada value,**
--**  the type of which is the same as the type of the associated column**
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of  the table on which the  selection  **
--**  criterion will be applied.                                        **
--**                                                                    **
--**  COLUMN_NAME is the name of the column to be used.                 **
--**                                                                    **
--**  KEY_MATCH is the match to be performed between the column of the  **
--**  candidate row and COLUMN_VALUE.                                   **
--**                                                                    **
--**  COLUMN_VALUE is the value to  be  compared  with the COLUMN_NAME  **
--**  column.                                                           **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_INVALID_VALUE is raised if COLUMN_VALUE is not correct.     **
--**                                                                    **
--**      X_INVALID_COLUMN  is  raised  if   COLUMN_NAME   is  unknown  **
--**  or if it is  a  record  column  instead  of  a  scalar  column,   **
--**  or if its type does not match the USER_COLUMN type.               **
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**      X_NO_PREVIOUS_MATCH is raised if a previous call to MATCH is  **
--**  missing.                                                          **
--**                                                                    **
--**                                                                    **
--************************************************************************
    procedure FIND          (TABLE_NAME      : STRING);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          FIND                                        **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**  To select a particular set of rows of  a  given  table, the user  **
--**  must first build the selection criterion  by  issuing  a call to  **
--**  the    MATCH  procedure,  and then other  calls  to    AND_MATCH  **
--**  and/or   OR_MATCH procedures to complete the  criterion  when it  **
--**  is   not   only   composed  of  a   single   basic   expression.  **
--**                                                                    **
--**  When the criterion has been built,   FIND is then used to select  **
--**  rows, which will then be accessible using the    FIND_NEXT   and  **
--**    FIND_PREVIOUS functions. The current row is left undefined, as  **
--**  the value of the temporary row.                                   **
--**                                                                    **
--**  The criterion is defined as :                                     **
--**                                                                    **
--**            COL1  KEY_MATCH1  VALUE1       where KEY_MATCH's are    **
--**   and/or   COL2  KEY_MATCH2  VALUE2       some of the following :  **
--**   and/or   COL3  KEY_MATCH3  VALUE3        =  /=  <  =<  >  >=     **
--**    ...                                                             **
--**   and/or   COLn  KEY_MATCHn  VALUEn                                **
--**                                                                    **
--**  where COL1, KEY_MATCH1, VALUE1 are arguments of   MATCH, COL2 ..  **
--**  COLn, KEY_MATCH2 .. KEY_MATCHn  and  VALUE2 ..   VALUEn  are  the **
--**  arguments of the n-1 preceding  AND_MATCH's  or  OR_MATCH's.      **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME is the name of the table to which the criterion  will  **
--**  be applied.                                                       **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_INVALID_CRITERION  is  raised  if  the  criterion  is  not  **
--**  correct,  for  instance  when  no  MATCH  has  been   previously  **
--**  performed.                                                        **
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**                                                                    **
--************************************************************************

    function FIND_NEXT     (TABLE_NAME   : STRING) return BOOLEAN;
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          FIND_NEXT                                   **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**    FIND_NEXT is used to force the current row to become the first  **
--**  selected   one   following   the   old  current  one,  if   any.  **
--**  If the old current one was the last one, FALSE is then returned;  **
--**  TRUE is otherwise returned.                                       **
--**    If there have not been any other call to NEXT or FIND_NEXT since**
--**  the last call to FIND, the first selected row is then chosen to   **
--**  be the current one.                                               **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of   the   table   to  be  processed.  **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**      X_NO_MORE_ROWS is raised if  a  previous  call to FIND_NEXT,  **
--**  FIND_PREVIOUS, NEXT or PREVIOUS  has  returned  the value FALSE.  **
--**                                                                    **
--**      X_NO_PREVIOUS_FIND  if  the  FIND  function  has  not  been   **
--**  previously called.                                                **
--**                                                                    **
--************************************************************************

    function FIND_PREVIOUS (TABLE_NAME   : STRING) return BOOLEAN;
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          FIND_PREVIOUS                               **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**    FIND_PREVIOUS is used to force the current row  to  become the  **
--**  last  selected  one  preceding the  old  current  one,  if  any.  **
--**  If the old current one was the first one, FALSE is then returned; **
--**  TRUE is otherwise returned.                                       **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of   the   table   to  be  processed.  **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**      X_NO_MORE_ROWS is raised if  a  previous  call to FIND_NEXT,  **
--**  FIND_PREVIOUS, NEXT or PREVIOUS  has  returned  the value FALSE,  **
--**  or if no NEXT nor FIND_NEXT has been called since the last LOCK   **
--**  or FIND.                                                          **
--**                                                                    **
--**      X_NO_PREVIOUS_FIND is raised if the FIND function has not been**
--**  previously called.                                                **
--**                                                                    **
--************************************************************************

    function NEXT          (TABLE_NAME   : STRING) return BOOLEAN;
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          NEXT                                        **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**    NEXT is used to force the current row to become the first  one  **
--**  following the old current one, if any.                            **
--**  If the old current one was the last one, FALSE is then returned;  **
--**  TRUE is otherwise returned.                                       **
--**    If there have not been any other call to NEXT since the last call**
--**  to LOCK, the first row of the table  is  then  chosen  to  be the **
--**  current row.                                                      **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of   the   table   to  be  processed.  **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**      X_NO_MORE_ROWS is raised if  a  previous  call to FIND_NEXT,  **
--**  FIND_PREVIOUS, NEXT or PREVIOUS  has  returned  the value FALSE.  **
--**                                                                    **
--**                                                                    **
--************************************************************************

    function PREVIOUS      (TABLE_NAME   : STRING) return BOOLEAN;
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          PREVIOUS                                    **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**    PREVIOUS is used to force the current row to  become  the last  **
--**  preceding the old current one, if any.                            **
--**  If the old current one was the first one, FALSE is then returned; **
--**  TRUE is otherwise returned.                                       **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of   the   table   to  be  processed.  **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**      X_NO_MORE_ROWS is raised if  a  previous  call to FIND_NEXT,  **
--**  FIND_PREVIOUS, NEXT or PREVIOUS  has  returned  the value FALSE,  **
--**  or if no NEXT nor FIND_NEXT has been called since the last LOCK   **
--**  or FIND.                                                          **
--**                                                                    **
--**                                                                    **
--**                                                                    **
--************************************************************************

    generic
        type USER_COLUMN is private;
--      To use this procedure the user must first instantiate its with
-- the type of the column he wants to process
    procedure GET_COLUMN (TABLE_NAME  : STRING;
                          COLUMN_NAME : STRING;
                          ITEM        : out USER_COLUMN);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          GET_COLUMN                                  **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**  GET_COLUMN is used to read a value of a column of the current row **
--**  of the table identified by TABLE_NAME.                            **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME : name of the table to be read.                        **
--**  COLUMN_NAME  :  name  of  the  column  to  be  read;  its   type  **
--**  must be USER_COLUMN.                                              **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**  ITEM  :  user  variable  where  the  value  is  to  be   copied.  **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_INVALID_VALUE is raised if the value read is not correct.   **
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**      X_INVALID_COLUMN is raised if the given column name does not  **
--**  identify any existing column of the identified table, or if its   **
--**  type does not match the USER_COLUMN type.                         **
--**                                                                    **
--**      X_NO_CURRENT_ROW is raised if the current  row  is undefined  **
--**  (after  a  LOCK or  a  FIND  has  been  performed,  or  after  a  **
--**  FIND_NEXT, a FIND_PREVIOUS, a NEXT  or  a  PREVIOUS has returned  **
--**  the value FALSE).                                                 **
--**                                                                    **
--**                                                                    **
--**                                                                    **
--************************************************************************

    generic
        type USER_ROW is private;
--      To use this procedure the user must first instantiate it with
-- the Ada type corresponding to the row structure.
    procedure GET_ROW (TABLE_NAME  : STRING;
                       ITEM        : out USER_ROW);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          GET_ROW                                     **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**   GET_ROW is used  to read the whole current  row  of  the  table  **
--**  identified by TABLE_NAME. The  USER_ROW   type  must  be defined  **
--**  as a record, each component of the record having the same scalar  **
--**  type as the matching column.                                      **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME : name of the table to be read.                        **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**  ITEM  :  user  variable  where  the  value  is  to  be   copied.  **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_INVALID_COLUMN is raised if the USER_ROW type does not match**
--**  the table definition.                                             **
--**                                                                    **
--**      X_INVALID_VALUE is raised if the value read is not correct.   **
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**      X_NO_CURRENT_ROW is raised if the current  row  is undefined  **
--**  (after  a  LOCK or  a  FIND  has  been  performed,  or  after  a  **
--**  FIND_NEXT, a FIND_PREVIOUS, a NEXT  or  a  PREVIOUS has returned  **
--**  the value FALSE).                                                 **
--**                                                                    **
--**                                                                    **
--************************************************************************
    generic
        type USER_COLUMN is private;
--      To use this procedure the user must first instantiate it with
-- the type of the column to be processed.
    procedure BUILD_COLUMN (TABLE_NAME  : STRING;
                            COLUMN_NAME : STRING;
                            ITEM        : USER_COLUMN);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          BUILD_COLUMN                                **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**    BUILD_COLUMN is used to write a value on a particular column of **
--**  the temporary row of the named table.                             **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME : name of the table to be processed.                   **
--**  COLUMN_NAME : name  of  the  column  of  the temporary row to be  **
--**  written; its type must be USER_COLUMN.                            **
--**  ITEM   :   value   to   be  copied  into  the   temporary   row.  **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**      X_INVALID_COLUMN if the given column name does not identify   **
--**  any existing column of the identified table, or if its type does  **
--**  not match the USER_COLUMN type.                                   **
--**                                                                    **
--**      X_INVALID_VALUE is raised if the  value  does  not match the  **
--**  column definition.                                                **
--**                                                                    **
--**      X_SHARED_MODE_LOCK is raised if the table has been locked in  **
--**  shared   mode;   it   should   have  been  in  exclusive   mode.  **
--**                                                                    **
--************************************************************************
    generic
        type USER_ROW is private;
--      To use this procedure the user must first instantiate it with
-- the Ada type corresponding to the row structure.
    procedure BUILD_ROW (TABLE_NAME  : STRING;
                         ITEM        : USER_ROW);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          BUILD_ROW                                   **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**   BUILD_ROW is used to update the whole temporary row of a table.  **
--**  The   USER_ROW   type   must  be a record type,  each  component  **
--**  having  the  same  scalar   type    as    the  matching  column.  **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME : name of the table to be processed.                   **
--**  ITEM   :   value   to   be  copied  into  the   temporary   row.  **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**      X_INVALID_COLUMN is raised if the USER_ROW type does not match**
--**  the table definition.                                             **
--**                                                                    **
--**      X_INVALID_VALUE is raised if the given value does not match   **
--**  the table definition.                                             **
--**                                                                    **
--**      X_SHARED_MODE_LOCK is raised if the table has been locked in  **
--**  shared   mode;   it   should   have  been  in  exclusive   mode.  **
--**                                                                    **
--**                                                                    **
--************************************************************************

    procedure UPDATE (TABLE_NAME : STRING);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          UPDATE                                      **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**    UPDATE copies the temporary row of  a  table  into its current  **
--**  row.                                                              **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of   the   table   to  be  processed.  **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**      X_NO_CURRENT_ROW is raised if the current  row  is undefined  **
--**  (after  a  LOCK or  a  FIND  has  been  performed,  or  after  a  **
--**  FIND_NEXT, a FIND_PREVIOUS, a NEXT  or  a  PREVIOUS has returned  **
--**  the value FALSE).                                                 **
--**                                                                    **
--**      X_SHARED_MODE_LOCK is raised if the table has been locked in  **
--**  shared   mode;   it   should   have  been  in  exclusive   mode.  **
--**                                                                    **
--**                                                                    **
--************************************************************************

    procedure INSERT (TABLE_NAME : STRING);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          INSERT                                      **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**    INSERT copies the temporary row of a table into a new row of    **
--**  this table; this new row is appended at the end of the table if   **
--**  the table is not sorted, and is inserted  so  that  the  table    **
--**  remains sorted, if it already was.                                **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of   the   table   to  be  processed.  **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**      X_FULL_TABLE  is  raised  if the table  cannot  be  expanded  **
--**  because already full.                                             **
--**                                                                    **
--**      X_SHARED_MODE_LOCK is raised if the table has been locked in  **
--**  shared   mode;   it   should   have  been  in  exclusive   mode.  **
--**                                                                    **
--**                                                                    **
--************************************************************************


    procedure DELETE (TABLE_NAME : STRING; NO_MORE_ROW : out BOOLEAN);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          DELETE                                      **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**    DELETE removes the current row of a table; if the removed  one  **
--**  was the only row contained in the table, NO_MORE_ROW is returned  **
--**  TRUE, else it is returned FALSE.                                  **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of   the   table   to  be  processed.  **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**  NO_MORE_ROW  is  TRUE  if  the table is left  empty,  and  FALSE  **
--**  otherwise.                                                        **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_TABLE_NOT_LOCKED is raised if the requested table does not  **
--**  exist, or exists but is not currently locked.                     **
--**                                                                    **
--**      X_NO_CURRENT_ROW is raised if the current  row  is undefined  **
--**  (after  a  LOCK or  a  FIND  has  been  performed,  or  after  a  **
--**  FIND_NEXT, a FIND_PREVIOUS, a NEXT  or  a  PREVIOUS has returned  **
--**  the value FALSE).                                                 **
--**                                                                    **
--**      X_SHARED_MODE_LOCK is raised if the table has been locked in  **
--**  shared   mode;   it   should   have  been  in  exclusive   mode.  **
--**                                                                    **
--**                                                                    **
--************************************************************************

end LL_DAMES;


--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--tabdes.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package body TABLE_DESCRIPTOR is

    type HOOK;
    type HOOK_ACCESS is access HOOK;
    type HOOK is
        record
            FREE    : BOOLEAN;
                -- when true, means that the hanging node is currently
                -- unused, and can then be chosen to be returned by the
                -- NEW_NODE function.

            OTHER   : HOOK_ACCESS;
                -- points to another hook.

            HANGING : NODE_ACCESS;
                -- pointer to a node which can be allocated by the
                -- NEW_NODE function.
        end record;

    HEAD : HOOK_ACCESS;
        -- this variable points to the first item of a list of hooks;
        -- the hanging nodes are those who can be allocated by a call
        -- to NEW_NODE.


    type CELL;
    type CELL_ACCESS is access CELL;
    type CELL is
        record
            OTHER  : CELL_ACCESS;
            OBJECT : CONSTRAINT_ACCESS;
        end record;
    HEAD_CELL : CELL_ACCESS;
    procedure FREE_NODES (TABLE_ID : INTEGER) is
        CURSOR : HOOK_ACCESS;
    begin

            -- first check that no other table than the TABLE_ID one
            -- currently needs some of the already hanging nodes; if
            -- there is one (or more), no node should be freed.
        for I in 1 .. TABLE_NO loop
            if I /= TABLE_ID and then
               TABLE (I).TABLE_STATUS.TABLE_IS_LOCKED and then
               TABLE (I).TABLE_STATUS.FIND_STATUS /= DEAD then
                 -- the Ith table currently uses hanging nodes; do not
                 -- free them
                return;
            end if;
        end loop;

            -- all hanging nodes can be freed
        CURSOR := HEAD;

        while CURSOR /= null loop
            CURSOR.all.FREE := TRUE;
            CURSOR := CURSOR.all.OTHER;
        end loop;
    end FREE_NODES;


    function NEW_NODE return NODE_ACCESS is
        CURSOR : HOOK_ACCESS;
    begin
        CURSOR := HEAD;

            -- look at the currently hanging nodes in order to find
            -- a free one
        while CURSOR /= null loop
            if CURSOR.all.FREE then
                return CURSOR.all.HANGING;
            else
                CURSOR := CURSOR.all.OTHER;
            end if;
        end loop;

            -- since no one of the currently hanging nodes is free, a
            -- new one is to be allocated, inserted at the beginning
            -- of the currently hanging nodes list, and its address
            -- then returned
        HEAD := new HOOK'(FALSE, HEAD, new NODE);
        return HEAD.all.HANGING;
    end NEW_NODE;
    procedure STORE_CONSTRAINT (CONSTRAINT : CONSTRAINT_ACCESS) is
        CURSOR : CELL_ACCESS;
    begin
        CURSOR := HEAD_CELL;
        while CURSOR /= null and then CURSOR.all.OBJECT /= null loop
            CURSOR := CURSOR.all.OTHER;
        end loop;
        if CURSOR = null then
            HEAD_CELL := new CELL'(HEAD_CELL, CONSTRAINT);
        else
            CURSOR.all.OBJECT := CONSTRAINT;
        end if;
    end STORE_CONSTRAINT;

    function NEW_CONSTRAINT return CONSTRAINT_ACCESS is
        CURSOR         : CELL_ACCESS;
        TO_BE_RETURNED : CONSTRAINT_ACCESS;
    begin
        CURSOR := HEAD_CELL;
        while CURSOR /= null and then CURSOR.all.OBJECT = null loop
            CURSOR := CURSOR.all.OTHER;
        end loop;
        if CURSOR = null then
            TO_BE_RETURNED := new STRING (1 .. 2 * RANGE_SIZE);
        else
            TO_BE_RETURNED := CURSOR.all.OBJECT;
            CURSOR.all.OBJECT := null;
        end if;
        return TO_BE_RETURNED;
    end NEW_CONSTRAINT;


end TABLE_DESCRIPTOR;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--share.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with CONSTANTS;

--************************************************************************
--**                                                                    **
--**             package           SHARE                                **
--**                               ~~~~~                                **
--****   Version: 01                              Date: 25-Mar-85       **
--**     Author: JF Cabadi                                              **
--**     Modifications:                                                 **
--**                                                                    **
--**  HISTORY  ---------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**====================================================================**
--**                                                                    **
--**  DESCRIPTION                                                       **
--**  ~~~~~~~~~~~                                                       **
--**                                                                    **
--**  The SHARE package is shared between the bodies of the DAMES  and  **
--**  LL_DAMES packages; it exists because DAMES is permitted to access **
--**  the tables of a database which  was  opened  by  LL_DAMES  and    **
--**  vice-versa.                                                       **
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**  LIMITS  ----------------------------------------------------------**
--**  ~~~~~~                                                            **
--**                                                                    **
--**  CONSTRAINTS  -----------------------------------------------------**
--**  ~~~~~~~~~~~                                                       **
--**                                                                    **
--**  BUGS  ------------------------------------------------------------**
--**  ~~~~                                                              **
--**                                                                    **
--************************************************************************

package SHARE is





    A_DATABASE_IS_OPEN : BOOLEAN := FALSE;
-- TRUE when a database is open, and FALSE when no database is open.

    OPEN_DATABASE_NAME : STRING (1 .. CONSTANTS.NAME_LENGTH);
-- When a database is open, contains the name of this database.

end SHARE;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--statuspec.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--************************************************************************
--**                                                                    **
--**           package             DAMES_STATUS                         **
--**                               ~~~~~~~~~~~~                         **
--****   Version: 01                              Date: 25-Mar-85       **
--**     Author: JF Cabadi                                              **
--**     Modifications:                                                 **
--**                                                                    **
--**  HISTORY  ---------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**====================================================================**
--**                                                                    **
--**  DESCRIPTION                                                       **
--**  ~~~~~~~~~~~                                                       **
--**                                                                    **
--**   The DAMES_STATUS package is used to keep the current status  of  **
--**   the DAMES interface :                                            **
--**        - already successfully used and not closed,             **
--**            or :                                            **
--**            - not already used or already closed.                   **
--**                                                                    **
--**                                                                    **
--**  LIMITS  ----------------------------------------------------------**
--**  ~~~~~~                                                            **
--**                                                                    **
--**  CONSTRAINTS  -----------------------------------------------------**
--**  ~~~~~~~~~~~                                                       **
--**                                                                    **
--**  BUGS  ------------------------------------------------------------**
--**  ~~~~                                                              **
--**                                                                    **
--************************************************************************

package DAMES_STATUS is


    EMBEDDED_INTERFACE_IS_IN_USE : BOOLEAN;
        -- TRUE if the EXECUTE or OPEN have been already called, and
        -- FALSE otherwise, or if CLOSE has been called.

end DAMES_STATUS;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--callspec.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with CONSTANTS;
use CONSTANTS;

package F77_CALLABLES is

        -- add another attribute definition during the creation of a table
    procedure ADA_ADDATR (RCKEY  : INTEGER;
                          ATNAM  : STRING;
                          ATYPE  : INTEGER;
                          ATLEN  : INTEGER;
                          DOMNAM : STRING;
                          RTN    : out INTEGER);

        -- close database
    procedure ADA_CLOSDB;

        -- close relation
    procedure ADA_CLOSER (DESCR : INTEGER);

        -- close relations
    procedure ADA_CLRELS;

        -- initialize a temporary row
--  procedure ADA_CREATT (DESCR : INTEGER; RTN : out INTEGER);

        -- insert the temporary row at current position
    procedure ADA_DADD   (DESCR  : INTEGER;
                          KYNAM  : STRING;
                          KYIDX  : in out INTEGER_ARRAY_TYPE;
                          KYVAL0 : STRING;
                          KYTL   : INTEGER;
                          KYTLEN : INTEGER_ARRAY_TYPE;
                          KYTYP  : INTEGER_ARRAY_TYPE;
                          ATNAM  : STRING;
                          ATIDX  : in out INTEGER_ARRAY_TYPE;
                          ATTL   : INTEGER;
                          ATLEN  : INTEGER_ARRAY_TYPE;
                          ATTYP  : INTEGER_ARRAY_TYPE;
                          TIDD   : in out TIDD_TYPE;
                          RTN    : out INTEGER);

        -- parse a User Language sentence
    procedure ADA_DAMSG  (INPLIN : STRING;
                          INPLEN : in out INTEGER;
                          MAXLEN : INTEGER;
                          RTN    : out INTEGER);

        -- delete the current row
    procedure ADA_DELETT (DESCR : INTEGER;
                          TIDD  : in out TIDD_TYPE;
                          RTN   : out INTEGER);

        -- find the first row matching a particular criterion
    procedure ADA_DFIND  (DESCR  : INTEGER;
                          KYM0   : INTEGER;
                          KYIDX  : INTEGER_ARRAY_TYPE;
                          KYVAL0 : STRING;
                          KYTL   : INTEGER;
                          TIDD   : in out TIDD_TYPE;
                          IRD    : INTEGER;
                          RTN    : out INTEGER);
        -- get information about an open relation
        -- ATNAM should be 12 * CONSTANTS.COL_NO characters long
    procedure ADA_DGINFO (DESCR : INTEGER;
                          ATNAM : in out STRING;
                          ATTL  : in out INTEGER;
                          ATIDX, ATLEN, ATTYP : out INTEGER_ARRAY_TYPE;
                          RTN  : out INTEGER);

        -- lock several tables
    procedure ADA_DLOCK (RELIST : STRING;
                         MODLIS : INTEGER_ARRAY_TYPE;
                         LENL   : INTEGER;
                         RTN    : out INTEGER);

        -- open a database
    procedure ADA_DOPENDB (DBNAME : STRING;
                           RTN    : out INTEGER);

        -- find previous row
    procedure ADA_DPREV  (DESCR : INTEGER;
                          TIDD  : in out TIDD_TYPE;
                          RTN   : out INTEGER);

        -- unlocks locked tables
    procedure ADA_DUNLK;

        -- break the embedded interface link
    procedure ADA_ENDDM;

        -- get access information about an open relation
    procedure ADA_FACSS  (DESCR : INTEGER;
                          ACSIFO: out INTEGER_ARRAY_TYPE);

        -- get an attribute value from the temporary row
    procedure ADA_GETA   (DESCR  : INTEGER;
                          ATTINX : INTEGER;
                          VALUE  : out INTEGER_ARRAY_TYPE;
                          LENR   : out INTEGER;
                          FTYP   : out INTEGER;
                          RTN    : out INTEGER);

        -- find next row
    procedure ADA_GETT   (DESCR : INTEGER;
                          TIDD  : in out TIDD_TYPE;
                          RTN   : out INTEGER);

        -- get the whole value of the temporary row
    procedure ADA_GETTB  (DESCR  : INTEGER;
                          SINK   : out INTEGER_ARRAY_TYPE;
                          SINKLN : INTEGER);

        -- append the temporary row at the end of a relation
    procedure ADA_INSRTT (DESCR : INTEGER;
                          TIDD  : in out TIDD_TYPE;
                          RTN   : out INTEGER);

        -- insert the temporary row at current position
--  procedure ADA_INSRT2 (DESCR : INTEGER;
--                        TIDD  : in out TIDD_TYPE;
--                        RTN   : out INTEGER);
        -- initialize the creation of a relation
    procedure ADA_IRELC  (RELNAM : STRING;
                          RCKEY  : out INTEGER;
                          PERM   : INTEGER);

        -- initialize the parser
    procedure ADA_LEXINT;

        -- writes a message on the screen and in the log_file
    procedure ADA_MSGTTY (MSG    : STRING;
                          MSGLEN : INTEGER);

        -- get the number of tuples of an open relation
    function  ADA_NUMTUP (DESCR  : INTEGER) return INTEGER;

        -- open a locked relation
    procedure ADA_OPENR  (RELNAM : STRING;
                          DESCR  : out INTEGER;
                          RTN    : out INTEGER);

        -- execute the User Language command previously parsed
        -- by DAMSG
    procedure ADA_PARSLP (RTN    : out INTEGER);

        -- put a value into an attribute of a temporary row
    procedure ADA_PUTA   (DESCR  : INTEGER;
                          ATTINX : INTEGER;
                          VALUE  : INTEGER_ARRAY_TYPE;
                          LENGTH : INTEGER;
                          RTN    : out INTEGER);

        -- put a value into a whole temporary row
    procedure ADA_PUTTB  (DESCR  : INTEGER;
                          SOURCE : INTEGER_ARRAY_TYPE;
                          TUPLEN : INTEGER);

        -- release the relation relation lock
    procedure ADA_RELLK (OPDB : STRING);

        -- replace the current tuple with the temporary one
    procedure ADA_REPLAT (DESCR : INTEGER;
                          TIDD  : in out TIDD_TYPE;
                          RTN   : out INTEGER);

        -- initialize the selection of rows
    procedure ADA_SETGET (DESCR      : INTEGER;
                          SETYPE     : INTEGER;
                          ARG3, ARG4 : TIDD_TYPE;
                          RTN        : out INTEGER);

        -- set the relation relation lock
    procedure ADA_SETLK (OPDB : STRING);

        -- get the index of an attribute of an open relation
    procedure ADA_SRCHA  (DESCR : INTEGER;
                          ATNAM : STRING;
                          ATIDX : out INTEGER);

        -- initialize the link through embedded interface
    procedure ADA_STARTDM;
        -- terminate a relation creation
    procedure ADA_TRELC  (RCKEY : INTEGER;
                          HOW   : INTEGER;
                          NOPGS : INTEGER;
                          PGSZ  : INTEGER;
                          RTN   : out INTEGER);
end F77_CALLABLES;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--conspec.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with LL_DAMES;
with UTILITIES;
with SYSTEM;

package body CONVERSION is

    TWO_POWER_8  : constant := 256;
    TWO_POWER_16 : constant := 65_536;
    TWO_POWER_24 : constant := 16_777_216;


    ----------------
    -- F77_STRING --
    ----------------
    function F77_STRING (ADA_STRING : STRING) return INTEGER_ARRAY_TYPE is

-- F77_STRING converts an ADA string variable into a
-- FORTRAN77 string variable.
--
-- If ADA_STRING is an ADA string variable the length of
-- which is n;
-- the INTEGER_ARRAY_TYPE returned will then be a n / 4
-- long ADA integer array.
-- Each 32 bits integer will be the catenation of
-- four 8 bits integers, which are the POSITION (ADA
-- meaning) in the ASCII table, of the four corresponding
-- characters of ADA_STRING.

        OFFSET         : constant INTEGER := -3;
        TO_BE_RETURNED : INTEGER_ARRAY_TYPE (1 .. (ADA_STRING'LENGTH + 3) / 4);
        LAST           : INTEGER := TO_BE_RETURNED'LAST;
        STRING_COPY    : STRING (1 .. 4 * LAST);
    begin
        STRING_COPY := ADA_STRING &
                       (ADA_STRING'LENGTH + 1 .. 4 * LAST => ASCII.NUL);
        -- copy ADA_STRING into STRING_COPY, the length of which
        -- is a multiple of 4

        for I in 1 .. LAST loop
            -- convert each four characters into an integer

            TO_BE_RETURNED (I) :=
              TWO_POWER_24 * CHARACTER'POS (STRING_COPY (OFFSET + 4 * I)) +
              TWO_POWER_16 *
              CHARACTER'POS (STRING_COPY (OFFSET + 4 * I + 1)) +
              TWO_POWER_8 * CHARACTER'POS (STRING_COPY (OFFSET + 4 * I + 2)) +
              CHARACTER'POS (STRING_COPY (OFFSET + 4 * I + 3));
        end loop;

        return TO_BE_RETURNED;
    end F77_STRING;


    ----------------
    -- ADA_STRING --
    ----------------
    function ADA_STRING (F77_STRING          : INTEGER_ARRAY_TYPE;
                         SKIP_TRAILING_NULLS : BOOLEAN) return STRING is

-- ADA_STRING converts a FORTRAN77 string variable into
-- an ADA string variable :
--
-- The FORTRAN77 string variable is stored in an ADA
-- 32 bits integer array (which is the F77_STRING
-- parameter); each of these integers must be interpreted
-- as the catenation of four 8 bits integers, each of
-- which being the POSITION (ADA meaning) in the ASCII
-- table, of a character. The sequence of characters
-- thus defined defines the converted string.
--
-- When SKIP_TRAILING_NULLS is set to TRUE, the
-- returned string length is chosen so that all
-- trailing null characters (ASCII.NUL) have been
-- eliminated.
-- When SKIP_TRAILING_NULLS is set to FALSE, the
-- returned string length is exactly four times the
-- number of integers of the F77_STRING array.

        LAST           : INTEGER := F77_STRING'LENGTH;
        TO_BE_RETURNED : STRING (1 .. 4 * LAST);
        STRING_COPY    : INTEGER_ARRAY_TYPE (1 .. LAST);
        POSITION       : INTEGER;
    begin
        STRING_COPY := F77_STRING;
        -- F77_STRING is copied into STRING_COPY to be modified
        -- in situ during processing

        for I in 1 .. LAST loop
            -- convert each integer into four characters

            -- compute first character
            POSITION := STRING_COPY (I) / TWO_POWER_24;
            if POSITION not in 0 .. 127 then
                POSITION := 0;
            end if;
            TO_BE_RETURNED (4 * I - 3) := CHARACTER'VAL (POSITION);

            -- compute second character
            STRING_COPY (I) := STRING_COPY (I) - POSITION * TWO_POWER_24;
            POSITION := STRING_COPY (I) / TWO_POWER_16;
            if POSITION not in 0 .. 127 then
                POSITION := 0;
            end if;
            TO_BE_RETURNED (4 * I - 2) := CHARACTER'VAL (POSITION);

            -- compute third character
            STRING_COPY (I) := STRING_COPY (I) - POSITION * TWO_POWER_16;
            POSITION := STRING_COPY (I) / TWO_POWER_8;
            if POSITION not in 0 .. 127 then
                POSITION := 0;
            end if;
            TO_BE_RETURNED (4 * I - 1) := CHARACTER'VAL (POSITION);
            -- compute fourth character
            STRING_COPY (I) := STRING_COPY (I) - POSITION * TWO_POWER_8;
            if STRING_COPY (I) not in 0 .. 127 then
                STRING_COPY (I) := 0;
            end if;
            TO_BE_RETURNED (4 * I) := CHARACTER'VAL (STRING_COPY (I));
        end loop;

        if SKIP_TRAILING_NULLS then
            -- return only non-null characters

            LAST := 4 * LAST;

            while TO_BE_RETURNED (LAST) = ASCII.NUL loop
                LAST := LAST - 1;
                exit when LAST = 0;
            end loop;

            return TO_BE_RETURNED (1 .. LAST);
        else
            -- return all characters, including null ones

            return TO_BE_RETURNED;
        end if;
    end ADA_STRING;



    --------------
    -- F77_ENUM --
    --------------
    function F77_ENUM (ADA_ENUM   : NATURAL;
                       ENUM_DESCR : ENUM_ITEM_ACCESS)
                        return INTEGER_ARRAY_TYPE is

-- F77_ENUM returns the character string matching the
-- image of the enumeration item defined by the position
-- ADA_ENUM in the ENUM_DESCR enumeration type definition.
--
-- ENUM_DESCR is a pointer to the first component of a
-- list, each component of which defining an enumeration
-- item (the image of the item is in a character string
-- of the component and the value of the item is the
-- range of the component in the list).
--
-- The returned string is returned in a FORTRAN77 format
-- which means an integer array, each integer defining
-- four characters.

        CURSOR : ENUM_ITEM_ACCESS;
        -- CURSOR is a pointer which will be moved through
        -- the ENUM_DESCR list.

    begin
        CURSOR := ENUM_DESCR;
        -- CURSOR is set to the beginning of the list
        for I in 1 .. ADA_ENUM loop
            -- CURSOR is set to the ADA_ENUMth element of the list.
            CURSOR := CURSOR.all.OTHER;
            if CURSOR = null then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when evaluating a value supposed to be");
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "of an enumeration type");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
        end loop;

        return F77_STRING (CURSOR.all.ENUM_IMAGE);
        -- the character string is returned in the FORTRAN77
        -- format

    end F77_ENUM;


    --------------
    -- ADA_ENUM --
    --------------
    function ADA_ENUM (F77_ENUM   : INTEGER_ARRAY_TYPE;
                       ENUM_DESCR : ENUM_ITEM_ACCESS) return NATURAL is

-- ADA_ENUM returns the position of an enumeration item
-- which is defined by giving its image (the F77_ENUM
-- fortran string), and the definition of the enumeration
-- type the item belongs to (the ENUM_DESCR list).

        CURSOR : ENUM_ITEM_ACCESS;
        -- CURSOR will be moved through the ENUM_DESCR list

        COUNT, LAST : NATURAL;
        -- COUNT will be used to count how many times CURSOR
        -- has been moved one step

        ENUM_IMAGE_STRING : STRING (1 .. 4 * F77_ENUM'LENGTH);
        -- ENUM_IMAGE_STRING will be used to store the item image
        -- in an ADA format, since it is given in a FORTRAN77
        -- format (F77_ENUM parameter).

    begin
        COUNT := 0;
        CURSOR := ENUM_DESCR;
        ENUM_IMAGE_STRING := ADA_STRING (F77_ENUM, FALSE);
        LAST := ENUM_IMAGE_STRING'LAST;

        -- first compute LAST, which is the last meaningful
        -- character of the string (actually the last which
        -- is not equal to ASCII.NUL)
        while ENUM_IMAGE_STRING (LAST) = ASCII.NUL loop
            LAST := LAST - 1;
            if LAST = 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when evaluating a value supposed to be");
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "of an enumeration type");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
        end loop;
        while CURSOR /= null loop
-- go through the list

            if CURSOR.all.ENUM_IMAGE (1 .. LAST) =
               ENUM_IMAGE_STRING (1 .. LAST) then
                -- searched image is found
                return COUNT;
            end if;

            COUNT := COUNT + 1;
            CURSOR := CURSOR.OTHER;
        end loop;

        -- if the loop ends while CURSOR = null, it means
        -- that the searched image has not been found.
        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
        "internal error when evaluating a value supposed to be");
        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
        "of an enumeration type");
        raise LL_DAMES.X_INTERNAL_ERROR;
    end ADA_ENUM;



    function ADA_SIZE (TABLE_ID, COMPONENT_ID : INTEGER) return INTEGER is

        -- ADA_SIZE returns the size (in 16 bits words) of the Ada type
        -- associated with the column defined by TABLE_ID and COMPONENT_ID

    begin
        case TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_TYPES (COMPONENT_ID) is

                -- INTEGER type
            when 1 =>  return 2;

                -- FLOAT type
            when 2 =>  return 2;

                -- CHARACTER SRING or ENUMERATION type
            when 5 =>
                if TABLE (TABLE_ID).TABLE_DEFINITION.ENUM_TYPES
                      (COMPONENT_ID) = null then
                        -- CHARACTER STRING type
                    return 15 +
                           TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_LENGTH
                              (COMPONENT_ID);
                else
                        -- ENUMERATION type
                    return 1;
                end if;

            when others =>
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error in a type definition evaluation");
                raise LL_DAMES.X_INTERNAL_ERROR;
        end case;
    end ADA_SIZE;
    procedure POSITION (TABLE_ID, COMPONENT_ID : INTEGER;
                        KIND                   : OBJECT_TYPE;
                        FIRST_WORD, LAST_WORD  : in out INTEGER) is

                -- POSITION returns in FIRST_WORD and LAST_WORD the numbers
                -- of the first and of the last 16 bits words of the
                -- component in the record, where record and component
                -- are defined by TABLE_ID, COMPONENT_ID and KIND.
                -- The first word of the record is number 1, and the
                -- header of the component (if any) is not included
                -- between the two returned positions.

        IC          : INTEGER;
        RECORD_NAME : STRING (1 .. NAME_LENGTH);
    begin
        FIRST_WORD := 1;

        case KIND is
          when WHOLE_TABLE =>
                --    - the record to be considered is the one matching
                --      the whole TABLE_ID table;
                --    - the component to be considered is the column
                --      number COMPONENT_ID of the table

            for I in 1 .. COMPONENT_ID - 1 loop
                FIRST_WORD := FIRST_WORD + ADA_SIZE (TABLE_ID, I);
            end loop;

            LAST_WORD := FIRST_WORD + ADA_SIZE (TABLE_ID, COMPONENT_ID) - 1;
            if TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_TYPES
                (COMPONENT_ID) = 5
                and TABLE (TABLE_ID).TABLE_DEFINITION.ENUM_TYPES
                (COMPONENT_ID) = null then
                        -- character string component

                    FIRST_WORD := FIRST_WORD + 15;
            end if;
          when RECORD_COLUMN =>
                --    - the record to be considered is the one matching
                --      the record column to which the COMPONENT_ID scalar
                --      column belongs;
                --    - the component to be considered is the column
                --      number COMPONENT_ID of the table

            IC := COMPONENT_ID - 1;

                -- store in RECORD_NAME the name of the record column
                -- to be considered
            RECORD_NAME := TABLE (TABLE_ID).TABLE_DEFINITION.IN_RECORD
                              (COMPONENT_ID);

            while IC /= 0 and then
        TABLE (TABLE_ID).TABLE_DEFINITION.IN_RECORD (IC) = RECORD_NAME loop
                        -- loop for each component of the record
                FIRST_WORD := FIRST_WORD + ADA_SIZE (TABLE_ID, IC);
                IC := IC - 1;
            end loop;
            LAST_WORD := FIRST_WORD + ADA_SIZE (TABLE_ID, COMPONENT_ID) - 1;
            if TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_TYPES
                (COMPONENT_ID) = 5
                and TABLE (TABLE_ID).TABLE_DEFINITION.ENUM_TYPES
                (COMPONENT_ID) = null then
                        -- character string component

                    FIRST_WORD := FIRST_WORD + 15;
            end if;
          when SCALAR_COLUMN =>
                --  - The record to be considered is the one matching
                --    the single scalar column defined by TABLE_ID and
                --    COLUMN_ID;
                --    - the component to be considered is the column
                --      number COMPONENT_ID of the table
            LAST_WORD := ADA_SIZE (TABLE_ID, COMPONENT_ID);
            if LAST_WORD < 3 then
                        -- INTEGER, FLOAT or ENUMERATION column
                FIRST_WORD := 1;
            else
                        -- CHARACTER STRING column
                FIRST_WORD := 16;
            end if;
        end case;
    end POSITION;

    -------------------
    -- ADD_COMPONENT --
    -------------------
    procedure ADD_COMPONENT
                 (ADA_OBJECT             : in out USER_TYPE;
                  COMPONENT16            : INTEGER16_ARRAY_TYPE;
                  TABLE_ID, COMPONENT_ID : INTEGER;
                  KIND                   : OBJECT_TYPE) is

        -- ADD_COMPONENT copies the INTEGER16 array bit map of an
        -- ADA object into a particular place of the ADA_OBJECT object.
        -- Depending on the value of KIND, ADA_OBJECT is a record
        -- encapsulating all the columns of the TABLE_ID table, or is
        -- a record corresponding to a record column of the TABLE_ID
        -- table, or is a scalar Ada object corresponding to a scalar
        -- column of the TABLE_ID table.
        -- In each of these cases, COMPONENT_ID defines the scalar column
        -- corresponding to COMPONENT16.

        INTERNAL_ADA_OBJECT   : USER_TYPE;
        FIRST_WORD, LAST_WORD : INTEGER;
        type INTEGER16_ACCESS_TYPE is access INTEGER16;
        INTEGER16_ACCESS      : INTEGER16_ACCESS_TYPE;

        function INTEGER_TO_INTEGER16_ACCESS is new UNCHECKED_CONVERSION
                (INTEGER, INTEGER16_ACCESS_TYPE);

    begin
        POSITION (TABLE_ID, COMPONENT_ID, KIND, FIRST_WORD, LAST_WORD);

                -- The following instructions cannot be used directly
                -- on the ADA_OBJECT object, since it is a formal
                -- parameter instead of a current object; these two
                -- instructions will then be used on another object
                -- (called INTERNAL_ADA_OBJECT) which has been declared
                -- in order to let these instructions work normally.
        INTERNAL_ADA_OBJECT := ADA_OBJECT;

        for I in FIRST_WORD .. LAST_WORD loop
            INTEGER16_ACCESS := INTEGER_TO_INTEGER16_ACCESS
                (INTEGER (INTERNAL_ADA_OBJECT'ADDRESS) + I - 1);
            INTEGER16_ACCESS.all := COMPONENT16 (I - FIRST_WORD + 1);
        end loop;
        ADA_OBJECT := INTERNAL_ADA_OBJECT;
    end ADD_COMPONENT;

    -------------------
    -- GET_COMPONENT --
    -------------------
    procedure GET_COMPONENT (ADA_OBJECT             : USER_TYPE;
                             COMPONENT16            : out INTEGER16_ARRAY_TYPE;
                             TABLE_ID, COMPONENT_ID : INTEGER;
                             KIND                   : OBJECT_TYPE) is

        -- GET_COMPONENT copies an INTEGER16 array bit map of a part
        -- of the ADA_OBJECT object into COMPONENT16.
        -- Depending on the value of KIND, ADA_OBJECT is a record
        -- encapsulating all the columns of the TABLE_ID table, or is
        -- a record corresponding to a record column of the TABLE_ID
        -- table, or is a scalar Ada object corresponding to a scalar
        -- column of the TABLE_ID table.
        -- In each of these cases, COMPONENT_ID defines the scalar column
        -- corresponding to COMPONENT16.

        INTERNAL_ADA_OBJECT   : USER_TYPE;
        FIRST_WORD, LAST_WORD : INTEGER;
        type INTEGER16_ACCESS_TYPE is access INTEGER16;
        INTEGER16_ACCESS      : INTEGER16_ACCESS_TYPE;

        function INTEGER_TO_INTEGER16_ACCESS is new UNCHECKED_CONVERSION
                (INTEGER, INTEGER16_ACCESS_TYPE);

    begin
        POSITION (TABLE_ID, COMPONENT_ID, KIND, FIRST_WORD, LAST_WORD);

                -- The following instructions cannot be used directly
                -- on the ADA_OBJECT object, since it is a formal
                -- parameter instead of a current object; these two
                -- instructions will then be used on another object
                -- (called INTERNAL_ADA_OBJECT) which has been declared
                -- in order to let these instructions work normally.
        INTERNAL_ADA_OBJECT := ADA_OBJECT;

        for I in FIRST_WORD .. LAST_WORD loop
            INTEGER16_ACCESS := INTEGER_TO_INTEGER16_ACCESS
                (INTEGER (INTERNAL_ADA_OBJECT'ADDRESS) + I - 1);
            COMPONENT16 (I - FIRST_WORD + 1) := INTEGER16_ACCESS.all;
        end loop;
    end GET_COMPONENT;


end CONVERSION;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--utilspec.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    with TABLE_DESCRIPTOR;
    use TABLE_DESCRIPTOR;

--************************************************************************
--**                                                                    **
--**            package            UTILITIES                            **
--**                               ~~~~~~~~~                            **
--****   Version: 01                              Date: 25-Mar-85       **
--**     Author: JF Cabadi                                              **
--**     Modifications:                                                 **
--**                                                                    **
--**  HISTORY  ---------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**====================================================================**
--**                                                                    **
--**  DESCRIPTION                                                       **
--**  ~~~~~~~~~~~                                                       **
--**                                                                    **
--**  The UTILITIES package contains functions and procedures that are  **
--**  widely  used  in  the  interface.   These   subprograms   are  :  **
--**                                                                    **
--**  NORMALIZE to standardize the names transmitted to the interface as**
--**  character string parameters, before using them (for example  for  **
--**  comparisons).                                                     **
--**                                                                    **
--**  BIT_SIZE,  RECORD_BIT_SIZE   and   TABLE_SIZE   to  compute  the  **
--**   size of the database  tables,  sets  of  columns, or  columns.   **
--**                                                                    **
--**  TABLE_ID, SCALAR_COLUMN_ID and COLUMN to search for a  specified  **
--**  identifier  in the ones currently known to the interface (i.e. in **
--**  the TABLE_DESCRIPTOR package).                                    **
--**                                                                    **
--**  SELECTION_CRITERION_IS_TRUE to compare the value of an object in  **
--**  the database to another value.                                    **
--**                                                                    **
--**  CHECK_VALUE  to  check  that a given  value  is  correct  for  a  **
--**  particular range constraint.                                      **
--**                                                                    **
--**  OUTPUT_MESSAGE to output an error message to  the  user terminal  **
--**  and to the DAMES logfile.                                         **
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**  LIMITS  ----------------------------------------------------------**
--**  ~~~~~~                                                            **
--**                                                                    **
--**  CONSTRAINTS  -----------------------------------------------------**
--**  ~~~~~~~~~~~                                                       **
--**                                                                    **
--**  BUGS  ------------------------------------------------------------**
--**  ~~~~                                                              **
--**                                                                    **
--************************************************************************
    package UTILITIES is
        function NORMALIZE (NAME : STRING) return STRING;
        -- Return a NAME_LENGTH characters long character string, which
        -- is a copy of NAME, but completed with spaces if name is not
        -- long enough, cut if NAME is too long, without spaces at the
        -- beginning, and all in uppercase letters.

        function BIT_SIZE (TABLE_ID  : INTEGER;
                           COLUMN_ID : INTEGER) return INTEGER;
        -- Return the size of the scalar column defined by the TABLE_ID
        -- and COLUMN_ID indexes to the TABLE variable.

        function RECORD_BIT_SIZE (TABLE_ID  : INTEGER;
                                  COLUMN_ID : INTEGER;
                                  IS_RECORD : BOOLEAN) return INTEGER;
        -- Return the size of the scalar column defined by the TABLE_ID
        -- and COLUMN_ID indexes to the TABLE variable, if IS_RECORD is
        -- FALSE; else return the size of the record column which contains
        -- the scalar column defined by the TABLE_ID and COLUMN_ID indexes.

        function TABLE_SIZE (TABLE_ID : INTEGER) return INTEGER;
        -- Return the size of the whole columns set of the table defined
        -- by the TABLE_ID index to the TABLE variable.

        function TABLE_ID (TABLE_NAME : STRING) return INTEGER;
        -- Return the index of the TABLE_NAME table in the TABLE variable
        -- or raise the X_TABLE_NOT_LOCKED exception if this name is not
        -- in the locked tables list of TABLE.
        -- TABLE_NAME needs not to be normalized, since it is in TABLE_ID

        function SCALAR_COLUMN_ID (TABLE_ID    : INTEGER;
                                   COLUMN_NAME : STRING) return INTEGER;
        -- return the index to the TABLE variable of the COLUMN_NAME
        -- scalar column of the TABLE_ID table, or raise X_INVALID_COLUMN
        -- if the searched column is not found.
        -- COLUMN_NAME needs not to be normalized, since it is in the
        -- COLUMN procedure itself.

        procedure COLUMN (TABLE_ID    : INTEGER;
                          COLUMN_NAME : STRING;
                          COLUMN_ID   : out INTEGER;
                          IS_RECORD   : out BOOLEAN);
        -- return in COLUMN_ID the index to the TABLE variable of the
        -- COLUMN_NAME column if this is a scalar one, or return the index
        -- of the first component of the COLUMN_NAME column if this is a
        -- record column; IS_RECORD is set according to the fact the
        -- found column is a scalar one or a record one.
        -- X_INVALID_COLUMN is raised if no scalar column, nor record
        -- column is found with the requested name.
        -- COLUMN_NAME needs not to be normalized, since it is in the
        -- COLUMN procedure itself.

        function SELECTION_CRITERION_IS_TRUE (TABLE_ID : INTEGER;
                                              CURSOR   : NODE_ACCESS)
                                               return BOOLEAN;
        -- When called with CURSOR pointing to the root of the selection
        -- criterion binary tree of the TABLE_ID table, return TRUE if
        -- the selection criterion is true for the current row, and FALSE
        -- if the selection criterion is false for the current row.
        procedure CHECK_VALUE (CHECKED, TABLE_ID, COLUMN_ID : INTEGER);
        -- CHECK_VALUE raises the X_INVALID_VALUE exception if CHECKED
        -- contains a value which is not in the range attached to the
        -- COLUMN_ID column of the TABLE_ID table.
        -- If the column is an INTEGER column, CHECKED is then used
        -- without conversion;
        -- If the column is a FLOAT column, CHECKED is then converted
        -- bit by bit to a FLOAT object;
        -- If the column is of an ENUMERATION type, CHECKED is then
        -- supposed to be the position (POS attribute) of the item
        -- in its type.

        procedure OUTPUT_MESSAGE (MESSAGE : STRING);
        -- This procedure appends a character string message to the
        -- current log file; it is used to give to the user additional
        -- information when an exception is raised.

    end UTILITIES;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--adaspec.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    package ADA_TABLES is

--************************************************************************
--**                                                                    **
--**                package         ADA_TABLES                          **
--**                                ~~~~~~~~~~                          **
--****   Version: 01                              Date: 25-Mar-85       **
--**     Author: JF Cabadi                                              **
--**     Modifications:                                                 **
--**                                                                    **
--**  HISTORY  ---------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**====================================================================**
--**                                                                    **
--**  DESCRIPTION                                                       **
--**  ~~~~~~~~~~~                                                       **
--**      The ADA_TABLES package  contains  procedures  used to access  **
--**  the three reserved tables of  the  Ada  Interface Manager; these  **
--**  tables are ignored by the Fortran77  interface  and  by the User  **
--**  Langage, and are :                                                **
--**                                                                    **
--**    - ADARANGE, which contains information about range constraints; **
--**  each row of this table defines a range constraint for a column.   **
--**  Its columns are :                                                 **
--**    TABLENAME : name of a table,                                    **
--**    COLNAME   : name of a column of this table,                     **
--**    MINVALUE  : minimum value for the above defined column,         **
--**    MAXVALUE  : maximum value for the above defined column.         **
--**                                                                    **
--**    - ADARECORD, which contains information about record  columns;  **
--**  each row of this table defines a component of  a  record  column. **
--**  Its columns are :                                                 **
--**    TABLENAME  : name of a table,                                   **
--**    RECORDNAME : name of a record column,                           **
--**    COMPONENT  : name of a scalar column which is a component of    **
--**                 the above defined record column.                   **
--**                                                                    **
--**    - ADAENUM, which contains information  about  enumeration type  **
--**  columns; each row of this table contains the position and the     **
--**  image of a particular item of an  enumeration  type  column; its  **
--**  columns are :                                                     **
--**    TABLENAME : name of a table,                                    **
--**    COLNAME   : name of a column of this table,                     **
--**    VALUE     : natural number,                                     **
--**    IMAGE     : character representation of the VALUEth object of   **
--**                the enumeration type of the above defined column.   **
--**                                                                    **
--**  The  procedures  provided  by  the  ADA_TABLES  package   are  :  **
--**                                                                    **
--**  LOCK_ADA_TABLES_IN_SHARED_MODE,                                   **
--**  LOCK_ADA_TABLES_IN_EXCLUSIVE_MODE, OPEN_ADA_TABLE,                **
--**  RESET_ADA_TABLE, for access initialization,                       **
--**                                                                    **
--**  GET_RANGE, GET_RECORD, GET_ENUM, PUT_RANGE, PUT_RECORD,           **
--**  PUT_ENUM,  for  writing  to  or  reading   from  the  reserved    **
--**  tables,                                                           **
--**                                                                    **
--**  CLOSE_ADA_TABLES,  UNLOCK_ADA_TABLES  for  terminating access to  **
--**  the reserved tables.                                              **
--**                                                                    **
--**                                                                    **
--**  LIMITS  ----------------------------------------------------------**
--**  ~~~~~~                                                            **
--**                                                                    **
--**  CONSTRAINTS  -----------------------------------------------------**
--**  ~~~~~~~~~~~                                                       **
--**                                                                    **
--**  BUGS  ------------------------------------------------------------**
--**  ~~~~                                                              **
--**                                                                    **
--************************************************************************






        procedure LOCK_ADA_TABLES_IN_SHARED_MODE;
        -- lock (in the DAMES original meaning) the three reserved tables in
        -- shared mode if they exist, and notify that they exist or not.

        procedure LOCK_ADA_TABLES_IN_EXCLUSIVE_MODE (USER_TABLE_NAME : STRING);
        -- if the reserved tables do not already exist, they are then created.
        -- In each case, they are then locked in exclusive mode, open, and
        -- ready to accept call's of the following PUT_XXXXX procedures.
        -- The USER_TABLE_NAME actual argument is recorded to be used by these
        -- further call's.



        procedure OPEN_ADA_TABLE (ADA_TABLE_NAME : STRING);
        -- open the ADA_TABLE_NAME reserved table if the ADA_TABLE_NAME table
        -- exists, else does nothing.

        procedure RESET_ADA_TABLE (USER_TABLE_NAME : STRING);
        -- preselect in the open table the rows the TABLE_NAME column of which
        -- has the value 'USER_TABLE_NAME' if the supposed open table exists,
        -- else does nothing.


        procedure GET_RANGE (COLNAME            : out STRING;
                             MINVALUE, MAXVALUE : out STRING;
                             EOF                : out BOOLEAN);
        -- if all the rows of the ADARANGE reserved table have been read,
        -- return TRUE in EOF, else FALSE, read the following row, and
        -- return in the out parameters the value of the row.
        -- If the reserved tables do not exist, EOF is always set to TRUE.

        procedure GET_RECORD (RECORD_NAME, COMPONENT : out STRING;
                              EOF                    : out BOOLEAN);
        -- if all the rows of the ADARECORD reserved table have been read,
        -- return TRUE in EOF, else FALSE, read the following row, and
        -- return in the out parameters the value of the row.
        -- If the reserved tables do not exist, EOF is always returned TRUE.

        procedure GET_ENUM (COLNAME      : out STRING;
                            VALUE        : out INTEGER;
                            IMAGE_STRING : out STRING;
                            EOF          : out BOOLEAN);
        -- if all the rows of the ADAENUM reserved table have been read,
        -- return TRUE in EOF, else FALSE, read the following row, and
        -- return in the out parameters the value of the row.
        -- If the reserved tables do not exist, EOF is always returned TRUE.
        procedure PUT_RANGE (COLNAME : STRING; MINVALUE, MAXVALUE : STRING);
        -- append a new row to the ADARANGE reserved table, this row containing
        -- the values defined in the parameters.

        procedure PUT_RECORD (RECORD_NAME, COMPONENT : STRING);
        -- append a new row to the ADARECORD reserved table, this row
        -- containing the values defined in the parameters.

        procedure PUT_ENUM (COLNAME      : STRING;
                            VALUE        : INTEGER;
                            IMAGE_STRING : STRING);
        -- append a new row to the ADAENUM reserved table, this row containing
        -- the values defined in the parameters.




        procedure CLOSE_ADA_TABLE;
        -- close the currently opened reserved table, which has been
        -- opened by using OPEN_ADA_TABLE.

        procedure UNLOCK_ADA_TABLES;
        -- unlock all locked tables.

    end ADA_TABLES;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--parsespec.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--************************************************************************
--**                                                                    **
--**             package           PARSE                                **
--**                               ~~~~~                                **
--****   Version: 01                              Date: 25-Mar-85       **
--**     Author: JF Cabadi                                              **
--**     Modifications:                                                 **
--**                                                                    **
--**  HISTORY  ---------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**====================================================================**
--**                                                                    **
--**  DESCRIPTION                                                       **
--**  ~~~~~~~~~~~                                                       **
--**                                                                    **
--**  The package PARSE  contains  two  procedures : PARSE_FIRST_LEVEL  **
--**  and  PARSE_SECOND_LEVEL;  both  contain  the same  flow  control  **
--**  structure, which is a  parser  recognizing  the table definition  **
--**  language, as defined for the DEFINE_TABLE  low  level procedure.  **
--**  The difference between these two  procedures  is  that the first  **
--**  one performs calls to the DAMES kernel itself in order to define  **
--**  a new table without the  characteristics  specific  to  the  Ada  **
--**  interface to DAMES, while the second  one  performs calls to the  **
--**  ADA_TABLES  package   to  store   the   characteristics  which    **
--**  are exclusive to the Ada interface to DAMES.                      **
--**                                                                    **
--**                                                                    **
--**                                                                    **
--**  LIMITS  ----------------------------------------------------------**
--**  ~~~~~~                                                            **
--**                                                                    **
--**  CONSTRAINTS  -----------------------------------------------------**
--**  ~~~~~~~~~~~                                                       **
--**                                                                    **
--**  BUGS  ------------------------------------------------------------**
--**  ~~~~                                                              **
--**                                                                    **
--************************************************************************


    package PARSE is
        X_SYNTAX_ERROR : exception;
        -- X_SYNTAX_ERROR is raised in PARSE_FIRST_LEVEL if a syntactic
        -- error is detected

        procedure PARSE_FIRST_LEVEL (COLUMN_LIST : STRING; RCKEY : INTEGER);
        -- PARSE_FIRST_LEVEL is to be used in order to generate the calls
        -- to F77_CALLABLES.ADA_ADDATR necessary to define each scalar
        -- column of a table being currently created


        procedure PARSE_SECOND_LEVEL (COLUMN_LIST : STRING);
        -- PARSE_SECOND_LEVEL is to be used in order to generate the calls
        -- to    ADA_TABLES.PUT_RANGE  ,     ADA_TABLES.PUT_ENUM   and
        -- ADA_TABLES.PUT_RECORD  necessary to define the enumeration types,
        -- range constraints and record columns of a table being currently
        -- created

    end PARSE;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--convert.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with LL_DAMES;
with UTILITIES;
with SYSTEM;

package body CONVERSION is

    TWO_POWER_8  : constant := 256;
    TWO_POWER_16 : constant := 65_536;
    TWO_POWER_24 : constant := 16_777_216;


    ----------------
    -- F77_STRING --
    ----------------
    function F77_STRING (ADA_STRING : STRING) return INTEGER_ARRAY_TYPE is

-- F77_STRING converts an ADA string variable into a
-- FORTRAN77 string variable.
--
-- If ADA_STRING is an ADA string variable the length of
-- which is n;
-- the INTEGER_ARRAY_TYPE returned will then be a n / 4
-- long ADA integer array.
-- Each 32 bits integer will be the catenation of
-- four 8 bits integers, which are the POSITION (ADA
-- meaning) in the ASCII table, of the four corresponding
-- characters of ADA_STRING.

        OFFSET         : constant INTEGER := -3;
        TO_BE_RETURNED : INTEGER_ARRAY_TYPE (1 .. (ADA_STRING'LENGTH + 3) / 4);
        LAST           : INTEGER := TO_BE_RETURNED'LAST;
        STRING_COPY    : STRING (1 .. 4 * LAST);
    begin
        STRING_COPY := ADA_STRING &
                       (ADA_STRING'LENGTH + 1 .. 4 * LAST => ASCII.NUL);
        -- copy ADA_STRING into STRING_COPY, the length of which
        -- is a multiple of 4

        for I in 1 .. LAST loop
            -- convert each four characters into an integer

            TO_BE_RETURNED (I) :=
              TWO_POWER_24 * CHARACTER'POS (STRING_COPY (OFFSET + 4 * I)) +
              TWO_POWER_16 *
              CHARACTER'POS (STRING_COPY (OFFSET + 4 * I + 1)) +
              TWO_POWER_8 * CHARACTER'POS (STRING_COPY (OFFSET + 4 * I + 2)) +
              CHARACTER'POS (STRING_COPY (OFFSET + 4 * I + 3));
        end loop;

        return TO_BE_RETURNED;
    end F77_STRING;


    ----------------
    -- ADA_STRING --
    ----------------
    function ADA_STRING (F77_STRING          : INTEGER_ARRAY_TYPE;
                         SKIP_TRAILING_NULLS : BOOLEAN) return STRING is

-- ADA_STRING converts a FORTRAN77 string variable into
-- an ADA string variable :
--
-- The FORTRAN77 string variable is stored in an ADA
-- 32 bits integer array (which is the F77_STRING
-- parameter); each of these integers must be interpreted
-- as the catenation of four 8 bits integers, each of
-- which being the POSITION (ADA meaning) in the ASCII
-- table, of a character. The sequence of characters
-- thus defined defines the converted string.
--
-- When SKIP_TRAILING_NULLS is set to TRUE, the
-- returned string length is chosen so that all
-- trailing null characters (ASCII.NUL) have been
-- eliminated.
-- When SKIP_TRAILING_NULLS is set to FALSE, the
-- returned string length is exactly four times the
-- number of integers of the F77_STRING array.

        LAST           : INTEGER := F77_STRING'LENGTH;
        TO_BE_RETURNED : STRING (1 .. 4 * LAST);
        STRING_COPY    : INTEGER_ARRAY_TYPE (1 .. LAST);
        POSITION       : INTEGER;
    begin
        STRING_COPY := F77_STRING;
        -- F77_STRING is copied into STRING_COPY to be modified
        -- in situ during processing

        for I in 1 .. LAST loop
            -- convert each integer into four characters

            -- compute first character
            POSITION := STRING_COPY (I) / TWO_POWER_24;
            if POSITION not in 0 .. 127 then
                POSITION := 0;
            end if;
            TO_BE_RETURNED (4 * I - 3) := CHARACTER'VAL (POSITION);

            -- compute second character
            STRING_COPY (I) := STRING_COPY (I) - POSITION * TWO_POWER_24;
            POSITION := STRING_COPY (I) / TWO_POWER_16;
            if POSITION not in 0 .. 127 then
                POSITION := 0;
            end if;
            TO_BE_RETURNED (4 * I - 2) := CHARACTER'VAL (POSITION);

            -- compute third character
            STRING_COPY (I) := STRING_COPY (I) - POSITION * TWO_POWER_16;
            POSITION := STRING_COPY (I) / TWO_POWER_8;
            if POSITION not in 0 .. 127 then
                POSITION := 0;
            end if;
            TO_BE_RETURNED (4 * I - 1) := CHARACTER'VAL (POSITION);
            -- compute fourth character
            STRING_COPY (I) := STRING_COPY (I) - POSITION * TWO_POWER_8;
            if STRING_COPY (I) not in 0 .. 127 then
                STRING_COPY (I) := 0;
            end if;
            TO_BE_RETURNED (4 * I) := CHARACTER'VAL (STRING_COPY (I));
        end loop;

        if SKIP_TRAILING_NULLS then
            -- return only non-null characters

            LAST := 4 * LAST;

            while TO_BE_RETURNED (LAST) = ASCII.NUL loop
                LAST := LAST - 1;
                exit when LAST = 0;
            end loop;

            return TO_BE_RETURNED (1 .. LAST);
        else
            -- return all characters, including null ones

            return TO_BE_RETURNED;
        end if;
    end ADA_STRING;



    --------------
    -- F77_ENUM --
    --------------
    function F77_ENUM (ADA_ENUM   : NATURAL;
                       ENUM_DESCR : ENUM_ITEM_ACCESS)
                        return INTEGER_ARRAY_TYPE is

-- F77_ENUM returns the character string matching the
-- image of the enumeration item defined by the position
-- ADA_ENUM in the ENUM_DESCR enumeration type definition.
--
-- ENUM_DESCR is a pointer to the first component of a
-- list, each component of which defining an enumeration
-- item (the image of the item is in a character string
-- of the component and the value of the item is the
-- range of the component in the list).
--
-- The returned string is returned in a FORTRAN77 format
-- which means an integer array, each integer defining
-- four characters.

        CURSOR : ENUM_ITEM_ACCESS;
        -- CURSOR is a pointer which will be moved through
        -- the ENUM_DESCR list.

    begin
        CURSOR := ENUM_DESCR;
        -- CURSOR is set to the beginning of the list
        for I in 1 .. ADA_ENUM loop
            -- CURSOR is set to the ADA_ENUMth element of the list.
            CURSOR := CURSOR.all.OTHER;
            if CURSOR = null then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when evaluating a value supposed to be");
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "of an enumeration type");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
        end loop;

        return F77_STRING (CURSOR.all.ENUM_IMAGE);
        -- the character string is returned in the FORTRAN77
        -- format

    end F77_ENUM;


    --------------
    -- ADA_ENUM --
    --------------
    function ADA_ENUM (F77_ENUM   : INTEGER_ARRAY_TYPE;
                       ENUM_DESCR : ENUM_ITEM_ACCESS) return NATURAL is

-- ADA_ENUM returns the position of an enumeration item
-- which is defined by giving its image (the F77_ENUM
-- fortran string), and the definition of the enumeration
-- type the item belongs to (the ENUM_DESCR list).

        CURSOR : ENUM_ITEM_ACCESS;
        -- CURSOR will be moved through the ENUM_DESCR list

        COUNT, LAST : NATURAL;
        -- COUNT will be used to count how many times CURSOR
        -- has been moved one step

        ENUM_IMAGE_STRING : STRING (1 .. 4 * F77_ENUM'LENGTH);
        -- ENUM_IMAGE_STRING will be used to store the item image
        -- in an ADA format, since it is given in a FORTRAN77
        -- format (F77_ENUM parameter).

    begin
        COUNT := 0;
        CURSOR := ENUM_DESCR;
        ENUM_IMAGE_STRING := ADA_STRING (F77_ENUM, FALSE);
        LAST := ENUM_IMAGE_STRING'LAST;

        -- first compute LAST, which is the last meaningful
        -- character of the string (actually the last which
        -- is not equal to ASCII.NUL)
        while ENUM_IMAGE_STRING (LAST) = ASCII.NUL loop
            LAST := LAST - 1;
            if LAST = 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when evaluating a value supposed to be");
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "of an enumeration type");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
        end loop;
        while CURSOR /= null loop
-- go through the list

            if CURSOR.all.ENUM_IMAGE (1 .. LAST) =
               ENUM_IMAGE_STRING (1 .. LAST) then
                -- searched image is found
                return COUNT;
            end if;

            COUNT := COUNT + 1;
            CURSOR := CURSOR.OTHER;
        end loop;

        -- if the loop ends while CURSOR = null, it means
        -- that the searched image has not been found.
        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
        "internal error when evaluating a value supposed to be");
        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
        "of an enumeration type");
        raise LL_DAMES.X_INTERNAL_ERROR;
    end ADA_ENUM;



    function ADA_SIZE (TABLE_ID, COMPONENT_ID : INTEGER) return INTEGER is

        -- ADA_SIZE returns the size (in 16 bits words) of the Ada type
        -- associated with the column defined by TABLE_ID and COMPONENT_ID

    begin
        case TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_TYPES (COMPONENT_ID) is

                -- INTEGER type
            when 1 =>  return 2;

                -- FLOAT type
            when 2 =>  return 2;

                -- CHARACTER SRING or ENUMERATION type
            when 5 =>
                if TABLE (TABLE_ID).TABLE_DEFINITION.ENUM_TYPES
                      (COMPONENT_ID) = null then
                        -- CHARACTER STRING type
                    return 15 +
                           TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_LENGTH
                              (COMPONENT_ID);
                else
                        -- ENUMERATION type
                    return 1;
                end if;

            when others =>
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error in a type definition evaluation");
                raise LL_DAMES.X_INTERNAL_ERROR;
        end case;
    end ADA_SIZE;
    procedure POSITION (TABLE_ID, COMPONENT_ID : INTEGER;
                        KIND                   : OBJECT_TYPE;
                        FIRST_WORD, LAST_WORD  : in out INTEGER) is

                -- POSITION returns in FIRST_WORD and LAST_WORD the numbers
                -- of the first and of the last 16 bits words of the
                -- component in the record, where record and component
                -- are defined by TABLE_ID, COMPONENT_ID and KIND.
                -- The first word of the record is number 1, and the
                -- header of the component (if any) is not included
                -- between the two returned positions.

        IC          : INTEGER;
        RECORD_NAME : STRING (1 .. NAME_LENGTH);
    begin
        FIRST_WORD := 1;

        case KIND is
          when WHOLE_TABLE =>
                --    - the record to be considered is the one matching
                --      the whole TABLE_ID table;
                --    - the component to be considered is the column
                --      number COMPONENT_ID of the table

            for I in 1 .. COMPONENT_ID - 1 loop
                FIRST_WORD := FIRST_WORD + ADA_SIZE (TABLE_ID, I);
            end loop;

            LAST_WORD := FIRST_WORD + ADA_SIZE (TABLE_ID, COMPONENT_ID) - 1;
            if TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_TYPES
                (COMPONENT_ID) = 5
                and TABLE (TABLE_ID).TABLE_DEFINITION.ENUM_TYPES
                (COMPONENT_ID) = null then
                        -- character string component

                    FIRST_WORD := FIRST_WORD + 15;
            end if;
          when RECORD_COLUMN =>
                --    - the record to be considered is the one matching
                --      the record column to which the COMPONENT_ID scalar
                --      column belongs;
                --    - the component to be considered is the column
                --      number COMPONENT_ID of the table

            IC := COMPONENT_ID - 1;

                -- store in RECORD_NAME the name of the record column
                -- to be considered
            RECORD_NAME := TABLE (TABLE_ID).TABLE_DEFINITION.IN_RECORD
                              (COMPONENT_ID);

            while IC /= 0 and then
        TABLE (TABLE_ID).TABLE_DEFINITION.IN_RECORD (IC) = RECORD_NAME loop
                        -- loop for each component of the record
                FIRST_WORD := FIRST_WORD + ADA_SIZE (TABLE_ID, IC);
                IC := IC - 1;
            end loop;
            LAST_WORD := FIRST_WORD + ADA_SIZE (TABLE_ID, COMPONENT_ID) - 1;
            if TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_TYPES
                (COMPONENT_ID) = 5
                and TABLE (TABLE_ID).TABLE_DEFINITION.ENUM_TYPES
                (COMPONENT_ID) = null then
                        -- character string component

                    FIRST_WORD := FIRST_WORD + 15;
            end if;
          when SCALAR_COLUMN =>
                --  - The record to be considered is the one matching
                --    the single scalar column defined by TABLE_ID and
                --    COLUMN_ID;
                --    - the component to be considered is the column
                --      number COMPONENT_ID of the table
            LAST_WORD := ADA_SIZE (TABLE_ID, COMPONENT_ID);
            if LAST_WORD < 3 then
                        -- INTEGER, FLOAT or ENUMERATION column
                FIRST_WORD := 1;
            else
                        -- CHARACTER STRING column
                FIRST_WORD := 16;
            end if;
        end case;
    end POSITION;

    -------------------
    -- ADD_COMPONENT --
    -------------------
    procedure ADD_COMPONENT
                 (ADA_OBJECT             : in out USER_TYPE;
                  COMPONENT16            : INTEGER16_ARRAY_TYPE;
                  TABLE_ID, COMPONENT_ID : INTEGER;
                  KIND                   : OBJECT_TYPE) is

        -- ADD_COMPONENT copies the INTEGER16 array bit map of an
        -- ADA object into a particular place of the ADA_OBJECT object.
        -- Depending on the value of KIND, ADA_OBJECT is a record
        -- encapsulating all the columns of the TABLE_ID table, or is
        -- a record corresponding to a record column of the TABLE_ID
        -- table, or is a scalar Ada object corresponding to a scalar
        -- column of the TABLE_ID table.
        -- In each of these cases, COMPONENT_ID defines the scalar column
        -- corresponding to COMPONENT16.

        INTERNAL_ADA_OBJECT   : USER_TYPE;
        FIRST_WORD, LAST_WORD : INTEGER;
        type INTEGER16_ACCESS_TYPE is access INTEGER16;
        INTEGER16_ACCESS      : INTEGER16_ACCESS_TYPE;

        function INTEGER_TO_INTEGER16_ACCESS is new UNCHECKED_CONVERSION
                (INTEGER, INTEGER16_ACCESS_TYPE);

    begin
        POSITION (TABLE_ID, COMPONENT_ID, KIND, FIRST_WORD, LAST_WORD);

                -- The following instructions cannot be used directly
                -- on the ADA_OBJECT object, since it is a formal
                -- parameter instead of a current object; these two
                -- instructions will then be used on another object
                -- (called INTERNAL_ADA_OBJECT) which has been declared
                -- in order to let these instructions work normally.
        INTERNAL_ADA_OBJECT := ADA_OBJECT;

        for I in FIRST_WORD .. LAST_WORD loop
            INTEGER16_ACCESS := INTEGER_TO_INTEGER16_ACCESS
                (INTEGER (INTERNAL_ADA_OBJECT'ADDRESS) + I - 1);
            INTEGER16_ACCESS.all := COMPONENT16 (I - FIRST_WORD + 1);
        end loop;
        ADA_OBJECT := INTERNAL_ADA_OBJECT;
    end ADD_COMPONENT;

    -------------------
    -- GET_COMPONENT --
    -------------------
    procedure GET_COMPONENT (ADA_OBJECT             : USER_TYPE;
                             COMPONENT16            : out INTEGER16_ARRAY_TYPE;
                             TABLE_ID, COMPONENT_ID : INTEGER;
                             KIND                   : OBJECT_TYPE) is

        -- GET_COMPONENT copies an INTEGER16 array bit map of a part
        -- of the ADA_OBJECT object into COMPONENT16.
        -- Depending on the value of KIND, ADA_OBJECT is a record
        -- encapsulating all the columns of the TABLE_ID table, or is
        -- a record corresponding to a record column of the TABLE_ID
        -- table, or is a scalar Ada object corresponding to a scalar
        -- column of the TABLE_ID table.
        -- In each of these cases, COMPONENT_ID defines the scalar column
        -- corresponding to COMPONENT16.

        INTERNAL_ADA_OBJECT   : USER_TYPE;
        FIRST_WORD, LAST_WORD : INTEGER;
        type INTEGER16_ACCESS_TYPE is access INTEGER16;
        INTEGER16_ACCESS      : INTEGER16_ACCESS_TYPE;

        function INTEGER_TO_INTEGER16_ACCESS is new UNCHECKED_CONVERSION
                (INTEGER, INTEGER16_ACCESS_TYPE);

    begin
        POSITION (TABLE_ID, COMPONENT_ID, KIND, FIRST_WORD, LAST_WORD);

                -- The following instructions cannot be used directly
                -- on the ADA_OBJECT object, since it is a formal
                -- parameter instead of a current object; these two
                -- instructions will then be used on another object
                -- (called INTERNAL_ADA_OBJECT) which has been declared
                -- in order to let these instructions work normally.
        INTERNAL_ADA_OBJECT := ADA_OBJECT;

        for I in FIRST_WORD .. LAST_WORD loop
            INTEGER16_ACCESS := INTEGER_TO_INTEGER16_ACCESS
                (INTEGER (INTERNAL_ADA_OBJECT'ADDRESS) + I - 1);
            COMPONENT16 (I - FIRST_WORD + 1) := INTEGER16_ACCESS.all;
        end loop;
    end GET_COMPONENT;


end CONVERSION;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--lldames.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with SHARE;
-- SHARE is a package containing a boolean variable (A_DATABASE_IS_OPEN)
-- shared by LL_DAMES and DAMES

with F77_CALLABLES;
-- F77_CALLABLES contains the FORTRAN77 subroutines used to access
-- the databases

with UNCHECKED_CONVERSION;

with TABLE_DESCRIPTOR;
use TABLE_DESCRIPTOR;
-- TABLE_DESCRIPTOR contains type declarations and a complex variable
-- declaration, this variable containing the definition and status of
-- all currently locked tables

with CONVERSION;
-- CONVERSION contains procedures and functions to be  used  mainly
-- for types conversions

with UTILITIES;
-- UTILITIES contains procedures and functions which are to be used
-- in order to access the variables of the TABLE_DESCRIPTOR package.

with ADA_TABLES;
-- ADA_TABLES is an interface to the three reserved tables of the
-- interface manager (which are called ADARANGE, ADARECORD and ADAENUM)

with PARSE;
-- PARSE contains a parser used by the DEFINE_TABLE procedure

package body LL_DAMES is

-------------------------used by UPDATE and INSERT------------------------



    procedure SORTED_INSERT (TABLE_ID : INTEGER) is

-- SORTED_INSERT is used to add a new row to a sorted table so
-- that the table remains sorted;
-- The keys of the table are first found, and the position where
-- the new row is to be inserted is then chosen by comparing the
-- keys values of the new row to those of the actual rows of the
-- table (this is performed by using the DFIND function); the
-- new row is then inserted, by using the DADD function.


-- following declarations are those of the FORTRAN77 arguments
-- to be used :
        SAVE_ROW                     : INTEGER_ARRAY_TYPE
                                                (1 .. MAX_STRING);
        ACSIFO                       : INTEGER_ARRAY_TYPE (1 .. 22);
        KEY_ID, KYIDX, KYTLEN, KYTYP : INTEGER_ARRAY_TYPE (1 .. 5);
        VALUE                        : INTEGER_ARRAY_TYPE
                                         (1 .. (3 + MAX_STRING) / 4) :=
                                       (others => 0);
        KYVAL0                       : STRING (1 .. 800) :=
                                       (others => ASCII.NUL);
        KYNAM                        : STRING (1 .. 60) := (others => ' ');
        ATNAM                        : STRING
                                         (1 .. 12 *
                                               TABLE (TABLE_ID).TABLE_DEFINITION
                                                .COLUMN_NUMBER) :=
                                       (others => ' ');
        LENR, FTYP, RTN              : INTEGER;

        function ROW_SIZE return INTEGER is

            -- ROW_SIZE computes the actual size (in bytes) of the
            -- row of the TABLE_ID table, and returns it.

            TO_BE_RETURNED : INTEGER := 0;
        begin
            for I in 1 .. TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NUMBER
                                                        loop
                if TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_TYPES (I) = 5
                                                        then
                    TO_BE_RETURNED := TO_BE_RETURNED +
                     TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_LENGTH (I);
                else
                    TO_BE_RETURNED := TO_BE_RETURNED + 4;
                end if;
            end loop;
            return TO_BE_RETURNED;
        end ROW_SIZE;
    begin
        -- save the value of the row to be added to the table
        F77_CALLABLES.ADA_GETTB (TABLE (TABLE_ID).TABLE_STATUS.DESCR,
                SAVE_ROW, 4 * MAX_STRING);

        -- read in ACSIFO which columns are the sort keys
        F77_CALLABLES.ADA_FACSS (TABLE (TABLE_ID).TABLE_STATUS.DESCR, ACSIFO);

        for I in 1 .. ACSIFO (2) loop
            -- loop one time for each key


            -- store in KEY_ID the index to TABLE of the key
            KEY_ID (I) := UTILITIES.SCALAR_COLUMN_ID
                             (TABLE_ID,
                              CONVERSION.ADA_STRING
                                 (ACSIFO (3 * I .. 3 * I + 2), FALSE));

            -- store in KYIDX the FORTRAN77 index of the key
            KYIDX (I) := TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_INDEX
                            (KEY_ID (I));

            -- store in KYNAM the name of the key
            KYNAM (12 * I - 11 .. 12 * I - 12 + NAME_LENGTH) :=
              TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NAMES (KEY_ID (I));

            -- store in KYTLEN the length of the key
            KYTLEN (I) := TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_LENGTH
                             (KEY_ID (I));

            -- store in KYTYP the type of the key
            KYTYP (I) := TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_TYPES
                            (KEY_ID (I));

            -- get into VALUE the actual value of the key of the temporary
            -- row to be inserted
            F77_CALLABLES.ADA_GETA
               (TABLE (TABLE_ID).TABLE_STATUS.DESCR, KYIDX (I), VALUE, LENR,
                FTYP, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error during insertion into a sorted table");
                raise X_INTERNAL_ERROR;
            end if;

            -- convert VALUE into the KYVAL0 character string
            KYVAL0 (160 * I - 159 .. 160 * I - 160 + MAX_STRING) :=
              CONVERSION.ADA_STRING (VALUE, FALSE);
        end loop;

        -- find the position where the new row is to be inserted
        F77_CALLABLES.ADA_DFIND
           (TABLE (TABLE_ID).TABLE_STATUS.DESCR, 0, KYIDX (1 .. ACSIFO (2)),
            KYVAL0 (1 .. ACSIFO (2) * 160), ACSIFO (2),
            TABLE (TABLE_ID).TABLE_STATUS.CURRENT_ROW, 0, RTN);

        if RTN = -2 or RTN = -3 then
            TABLE (TABLE_ID).TABLE_STATUS.CURRENT_ROW (1) := -1;
        end if;
        for I in 1 .. TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NUMBER loop
            -- convert the TABLE column names list into the ATNAM column
            -- names list
            ATNAM (12 * I - 11 .. 12 * I - 12 + NAME_LENGTH) :=
              TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NAMES (I);
        end loop;

        -- restore the value of the row to be added to the table
        F77_CALLABLES.ADA_PUTTB (TABLE (TABLE_ID).TABLE_STATUS.DESCR,
                SAVE_ROW, (ROW_SIZE + 3) / 4);

        -- actually insert the temporary row
        F77_CALLABLES.ADA_DADD
           (TABLE (TABLE_ID).TABLE_STATUS.DESCR, KYNAM (1 .. 12 * ACSIFO (2)),
            KYIDX (1 .. ACSIFO (2)), KYVAL0 (1 .. 160 * ACSIFO (2)),
            ACSIFO (2), KYTLEN (1 .. ACSIFO (2)), KYTYP (1 .. ACSIFO (2)),
            ATNAM,
            TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_INDEX
               (1 .. TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NUMBER),
            TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NUMBER,
            TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_LENGTH
               (1 .. TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NUMBER),
            TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_TYPES
               (1 .. TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NUMBER),
            TABLE (TABLE_ID).TABLE_STATUS.CURRENT_ROW, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error during insertion into a sorted table");
                raise X_INTERNAL_ERROR;
            end if;
    end SORTED_INSERT;

    procedure OPEN (DB_NAME : STRING) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          OPEN                                        **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**    if A_DATABASE_IS_OPEN then                                      **
--**        raise X_OPEN_DATABASE;                                      **
--**    end if;                                                         **
--**                                                                    **
--**    OPEN_DATABASE (DB_NAME);                                        **
--**                                                                    **
--**    if ERROR then                                                   **
--**        raise X_CANT_ACCESS_DATABASE;                               **
--**    end if;                                                         **
--**                                                                    **
--**    A_DATABASE_IS_OPEN := TRUE;                                     **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  DB_NAME is the name of the database to be open.                   **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_OPEN_DB                                                       **
--**    X_CANT_ACCESS_DB                                                **
--**                                                                    **
--************************************************************************
        RTN : INTEGER;
    begin
        if SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "No database should be already opened when trying to open one");
            raise X_OPEN_DB;
        end if;

        F77_CALLABLES.ADA_DOPENDB (UTILITIES.NORMALIZE (DB_NAME), RTN);

        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "The requested database is not on line, does not exist, or can");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "not be accessed ");
            raise X_CANT_ACCESS_DB;
        end if;

        SHARE.A_DATABASE_IS_OPEN := TRUE;
        SHARE.OPEN_DATABASE_NAME := UTILITIES.NORMALIZE (DB_NAME);
    end OPEN;

    procedure DEFINE_TABLE (TABLE_NAME : STRING; COLUMN_LIST : STRING) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          DEFINE_TABLE                                **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_NO_OPEN_DB;                                         **
--**    end if;                                                         **
--**                                                                    **
--**    INITIALIZE_TABLE_CREATION (TABLE_NAME);                         **
--**        -- this step is performed by using  the  IRELC  access      **
--**        -- procedure.                                               **
--**                                                                    **
--**    PARSE_FIRST_LEVEL (COLUMN_LIST);                                **
--**        -- this step generates a call to the ADDATR access procedure**
--**        -- for each of the DAMES column to be created.              **
--**        -- PARSE_FIRST_LEVEL can detect any  syntactic  error  of   **
--**        -- COLUMN_LIST.                                             **
--**    if ERROR then                                                   **
--**        CANCEL_TABLE_CREATION;                                      **
--**        raise X_INVALID_COLUMN;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    CONFIRM_TABLE_CREATION;                                         **
--**    if ERROR then                                                   **
--**        raise X_CANT_ACCESS_TABLE;                                  **
--**    end if;                                                         **
--**                                                                    **
--**    if ADA_INTERFACE_TABLES_DO_NOT_EXIST then                       **
--**            -- the three tables ADARANGE, ADARECORD and ADAENUM  do **
--**            -- not already exist; they have to be created.          **
--**        CREATE_ADA_INTERFACE_TABLES;                                **
--**    end if;                                                         **
--**                                                                    **
--**    PARSE_SECOND_LEVEL (COLUMN_LIST);                               **
--**        -- the information to be stored in ADARANGE, ADARECORD and  **
--**        -- ADAENUM tables of the database is the one provided by    **
--**        -- PARSE_SECOND_LEVEL for each concerned column, and is     **
--**        -- composed of : column range (if any), name of the record  **
--**        -- the column belongs to (if any), and list of values for an**
--**        -- enumeration type column.                                 **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**          * TABLE_NAME is the name of the table to be created.      **
--**                                                                    **
--**          * COLUMN_LIST   is  a  string describing the table;  the  **
--**  column descriptors are separated with semi-colons ; each  column  **
--**  descriptor is a string describing the name,  type,  and optional  **
--**  constraint  of  the  column;  the  following form is to be  used  **
--**  (B.N.F. notation) :                                               **
--**    COLUMN_LIST    := <column_descr> {; <column_descr> }            **
--**    <column_descr> := <scalar_descr> | <record_descr>               **
--**    <record_descr> := <name> <scalar_descr> {, <scalar_descr>}      **
--**    <scalar_descr> := <name> [<type>]                               **
--**    <name> is a valid column name                                   **
--**    <type>         := STRING [(1 .. n)] |                           **
--**                      FLOAT  [<constraint>] |                       **
--**                      INTEGER [<constraint>] |                      **
--**                      <enumeration_type_definition> [<constraint>]  **
--**    <constraint>   := RANGE <value> .. <value>                      **
--**    <value> is a literal the type of which depends on the           **
--**                      associated  type                              **
--**    <enumeration_type_definition> is defined with this name in the  **
--**                      ADA  Reference  Manual ;  it  is  a  list of  **
--**                      enumeration litterals separated by commas and **
--**                      enclosed in parenthesese.                     **
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_NO_OPEN_DB                                                    **
--**    X_INVALID_COLUMN                                                **
--**    X_CANT_ACCESS_TABLE                                             **
--**                                                                    **
--************************************************************************
        RTN, RCKEY  : INTEGER;
        TABLE_NAME2 : STRING (1 .. NAME_LENGTH);
    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "The database in which a table is to be created must be opened");
            raise X_NO_OPEN_DB;
        end if;

        -- lock the main DAMES reserved table
        F77_CALLABLES.ADA_SETLK (SHARE.OPEN_DATABASE_NAME);

        -- normalize the table name
        TABLE_NAME2 := UTILITIES.NORMALIZE (TABLE_NAME);

        -- initialize the table creation
        F77_CALLABLES.ADA_IRELC (TABLE_NAME2, RCKEY, 1);

        -- parse a first time the column list to define each scalar
        -- column as seen by the FORTRAN77 and User Language interfaces
        PARSE.PARSE_FIRST_LEVEL (COLUMN_LIST, RCKEY);

        -- terminate the table creation
        F77_CALLABLES.ADA_TRELC (RCKEY, 1, 0, 0, RTN);
        F77_CALLABLES.ADA_RELLK (SHARE.OPEN_DATABASE_NAME);

        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "The " & TABLE_NAME & " table can not be created");
            raise X_CANT_ACCESS_TABLE;
        end if;

        -- lock the three reserved tables in exclusive mode or create
        -- them if they do not exist
        ADA_TABLES.LOCK_ADA_TABLES_IN_EXCLUSIVE_MODE (TABLE_NAME2);

        -- add into the three reserved tables the rows defining the
        -- record columns, the enumeration type columns, or the range
        -- constraints proper to the currently created table and to
        -- the Ada Interface Manager
        PARSE.PARSE_SECOND_LEVEL (COLUMN_LIST);

        -- release the reserved tables locks
        ADA_TABLES.UNLOCK_ADA_TABLES;
    exception
        when PARSE.X_SYNTAX_ERROR =>
-- X_SYNTAX_ERROR is raised when a syntax error is detected
-- during the parsing of the COLUMN_LIST sentence; this can
-- occur during PARSE_FIRST_LEVEL only, and the table creation
-- must then be cancelled
            F77_CALLABLES.ADA_TRELC (RCKEY, 2, 0, 0, RTN);
            F77_CALLABLES.ADA_RELLK (SHARE.OPEN_DATABASE_NAME);
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "There is a syntax error in COLUMN_LIST");
            raise X_INVALID_COLUMN;
    end DEFINE_TABLE;


    procedure LOCK (LOCK_LIST : LOCK_LIST_TYPE) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          LOCK                                        **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_NO_OPEN_DB;                                         **
--**    end if;                                                         **
--**                                                                    **
--**    CLOSE_TABLES;                                                   **
--**        -- close already open tables, if any                        **
--**                                                                    **
--**    UNLOCK_TABLES;                                                  **
--**        -- unlock already locked tables, if any                     **
--**                                                                    **
--**    for TABLE_NAME in TABLE'FIRST .. TABLE'LAST loop                **
--**                                                                    **
--**            -- TABLE'FIRST .. TABLE'LAST is the list of all known   **
--**            -- tables; all have been unlocked by the previous       **
--**            -- call to UNLOCK_TABLES, and this will be noticed by   **
--**            -- setting all LOCK components of the TABLE status array**
--**            -- to 'unlocked'                                        **
--**                                                                    **
--**        UPDATE_TABLE_NAME_LOCK_STATUS;                              **
--**    end loop;                                                       **
--**                                                                    **
--**    SET_LOCKS (ADARANGE, ADAENUM, ADARECORD);                       **
--**                                                                    **
--**    GET_ADA_INTERFACE_INFORMATION_FROM_DATABASE (TABLE_NAME_LIST);  **
--**        -- TABLE_NAME_LIST is the list of the tables to be          **
--**        -- locked; it has been extracted from the LOCK_LIST         **
--**        -- argument. GET_ADA_INTERFACE_INFORMATION_FROM_DATABASE    **
--**        -- reads from reserved tables of the database some          **
--**        -- additionnal information relative to the TABLE_NAME_LIST  **
--**        -- tables and used by the Ada Interface Manager only.       **
--**        -- These reserved tables are ADARANGE, ADARECORD and ADAENUM**
--**                                                                    **
--**    UNLOCK_TABLES;                                                  **
--**        -- unlock the three reserved tables of the interface        **
--**                                                                    **
--**    SET_LOCKS (TABLE_NAME_LIST);                                    **
--**    if ERROR then                                                   **
--**        raise X_CANT_ACCESS_TABLE;                                  **
--**    end if;                                                         **
--**                                                                    **
--**    for TABLE_NAME in TABLE_NAME_LIST loop                          **
--**                                                                    **
--**            -- TABLE_NAME_LIST is the list of the tables to be      **
--**            -- locked; it has been extracted from the LOCK_LIST     **
--**            -- argument.                                            **
--**                                                                    **
--**        OPEN_TABLE (TABLE_NAME);                                    **
--**        if ERROR then                                               **
--**                                                                    **
--**            for INNER_LOOP_TABLE_NAME in TABLE_NAME_LIST'FIRST      **
--**                                      .. TABLE_NAME_LIST'LAST loop  **
--**                                                                    **
--**                RESET_INNER_LOOP_TABLE_NAME_STATUS;                 **
--**                    -- reset the LOCK component of                  **
--**                    -- INNER_LOOP_TABLE_NAME in the TABLE status    **
--**                    -- array to 'unlocked'                          **
--**            end loop;                                               **
--**                                                                    **
--**            for INNER_LOOP_TABLE_NAME in TABLE_NAME_LIST'FIRST      **
--**                                         .. TABLE_NAME'PRED loop    **
--**                                                                    **
--**                CLOSE_TABLE (INNER_LOOP_TABLE_NAME);                **
--**            end loop;                                               **
--**            UNLOCK_TABLES;                                          **
--**            raise X_CANT_ACCESS_TABLE;                              **
--**        end if;                                                     **
--**                                                                    **
--**        INITIALIZE_CURRENT_ROW;                                     **
--**            -- call the SETGET access procedure to select all rows  **
--**            -- and set the CURRENT_ROW component of TABLE_NAME in   **
--**            -- the TABLE status array to 'init'.                    **
--**                                                                    **
--**        UPDATE_TABLE (TABLE_NAME);                                  **
--**            -- set the LOCK component to 'shared' or 'exclusive',   **
--**            -- depending on the LOCK_LIST actual argument.          **
--**                                                                    **
--**        GET_DAMES_INFORMATION_FROM_DATABASE (TABLE_NAME);           **
--**            -- read from the database files and from the relation   **
--**            -- relation the description of  TABLE_NAME  as seen     **
--**            -- by the DAMES dbms without Ada interface.             **
--**            -- In particular, the DGINFO fortran subroutine will be **
--**            -- called to get the values of the index of each column **
--**            -- as the accessible Fortran routines do not use column **
--**            -- names for column identification but  use  an  index. **
--**            -- Each time a column definition is read, the additional**
--**            -- information  (if  any)  previously  read  from  Ada  **
--**            -- Interface reserved tables is linked to the basic     **
--**            -- information just read.                               **
--**                                                                    **
--**    end loop;                                                       **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  LOCK_LIST  is  an array  of  LOCK_TYPE  records,  each  of  them  **
--**  describing a single lock; the two components of a LOCK_TYPE  are  **
--**  TABLE_NAME,  which  identifies  a  table, and ACCESS_MODE, which  **
--**  describes in which mode (shared or exclusive) the table is to be  **
--**  accessed.                                                         **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    TABLE                                                           **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_CANT_ACCESS_TABLE                                             **
--**    X_NO_OPEN_DB                                                    **
--**                                                                    **
--************************************************************************

        TABLE_NUMBER                 : INTEGER := LOCK_LIST'LENGTH;
        INDEX                        : INTEGER;
        INDEX2, INDEX1               : array (1 .. TABLE_NO) of INTEGER;
        COLNAME, RECORD_NAME         : STRING (1 .. NAME_LENGTH);
        TABLE_NAME2                  : array (1 .. TABLE_NUMBER)
                                              of STRING (1 .. NAME_LENGTH);
        MINVALUE, MAXVALUE           : STRING (1 .. RANGE_SIZE);
        ACSIFO                       : INTEGER_ARRAY_TYPE (1 .. 22);
        ATTL, DESCR, RTN, ENUM_VALUE : INTEGER;
        CURSOR,PREVIOUS_CURSOR       : ENUM_ITEM_ACCESS;

        ATNAM                        : STRING (1 .. 12 * COL_NO);
        ATIDX, ATTYP, ATLEN          : INTEGER_ARRAY_TYPE (1 .. COL_NO);
        TIDD                         : TIDD_TYPE;
        IMAGE_STRING                 : STRING (1 .. IMAGE_SZ);
        EOF                          : BOOLEAN;
        RELIST                       : STRING (1 .. 12 * TABLE_NUMBER);
        MODLIS                       : INTEGER_ARRAY_TYPE (1 .. TABLE_NUMBER);

    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "The database containing the tables to be locked must previously");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "be opened");
            raise X_NO_OPEN_DB;
        end if;

        for I in 1 .. TABLE_NUMBER loop
            -- first normalize the table names of those to be locked
            TABLE_NAME2 (I) :=
              UTILITIES.NORMALIZE
                 (LOCK_LIST (LOCK_LIST'FIRST - 1 + I).TABLE_NAME);
        end loop;

        -- close all previously open tables
        F77_CALLABLES.ADA_CLRELS;

        -- release all previously set locks
        F77_CALLABLES.ADA_DUNLK;

        for I in 1 .. TABLE_NO loop
            TABLE (I).TABLE_STATUS.TABLE_IS_LOCKED := FALSE;
        end loop;

        -- lock the three reserved tables in shared mode
        ADA_TABLES.LOCK_ADA_TABLES_IN_SHARED_MODE;
-----------------------get the range constraints information--------------

        -- open the ADARANGE reserved table
        ADA_TABLES.OPEN_ADA_TABLE ("ADARANGE  ");

        for I in 1 .. TABLE_NUMBER loop
            -- for each of the tables to be locked

            -- select in ADARANGE the information relative to
            -- TABLE_NAME2(I)
            ADA_TABLES.RESET_ADA_TABLE (TABLE_NAME2 (I));

            TABLE (I).TABLE_DEFINITION.COLUMN_NAMES :=
              (others => (others => ' '));
        for J in 1 .. COL_NO loop
                if TABLE (I).TABLE_DEFINITION.CONSTRAINTS (J) /= null then
            STORE_CONSTRAINT (TABLE (I).TABLE_DEFINITION.
                            CONSTRAINTS (J));
            TABLE (I).TABLE_DEFINITION.CONSTRAINTS (J) := null;
            end if;
        end loop;
            INDEX1 (I) := 0;

            loop
                -- for each information of ADARANGE (i.e. a range
                -- constraint definition for one column)

                -- get this range constraint definition
                ADA_TABLES.GET_RANGE (COLNAME, MINVALUE, MAXVALUE, EOF);
                exit when EOF;

                -- add it in the TABLE variable
                INDEX1 (I) := INDEX1 (I) + 1;
                TABLE (I).TABLE_DEFINITION.COLUMN_NAMES (INDEX1 (I)) := COLNAME;
                TABLE (I).TABLE_DEFINITION.CONSTRAINTS (INDEX1 (I)) :=
                  NEW_CONSTRAINT;
                TABLE (I).TABLE_DEFINITION.CONSTRAINTS (INDEX1 (I)).all :=
                  MINVALUE & MAXVALUE;
            end loop;
        end loop;

        ADA_TABLES.CLOSE_ADA_TABLE;
-------------------get the record columns definitions---------------------

        -- open the ADARECORD reserved table
        ADA_TABLES.OPEN_ADA_TABLE ("ADARECORD ");

        for I in 1 .. TABLE_NUMBER loop
            -- for each of the tables to be locked

            -- select all ADARECORD rows relative to the TABLE_NAME2(I)
            -- table
            ADA_TABLES.RESET_ADA_TABLE (TABLE_NAME2 (I));

            TABLE (I).TABLE_DEFINITION.IN_RECORD := (others => (others => ' '));

            loop
                -- get each ADARECORD row information (i.e. the name of a
                -- record column with the name of one of its components)
                ADA_TABLES.GET_RECORD (RECORD_NAME, COLNAME, EOF);
                exit when EOF;

                -- look how the new information(the component of the record
                -- column) is to be inserted : as a new column definition
                -- if the COLNAME column is unknown, or as an additionnal
                -- information to that already provided about this column
                -- if it already exists
                for II in 1 .. INDEX1 (I) + 1 loop
                    INDEX2 (I) := II;
                    exit when COLNAME =
                              TABLE (I).TABLE_DEFINITION.COLUMN_NAMES (II);
                end loop;

                -- the Ith scalar column belongs to the RECORD_NAME record
                -- column
                TABLE (I).TABLE_DEFINITION.IN_RECORD (INDEX2 (I)) :=
                  RECORD_NAME;

                if INDEX2 (I) = INDEX1 (I) + 1 then
                    TABLE (I).TABLE_DEFINITION.COLUMN_NAMES (INDEX2 (I)) :=
                      COLNAME;
                    INDEX1 (I) := INDEX2 (I);
                end if;
            end loop;
        end loop;

        ADA_TABLES.CLOSE_ADA_TABLE;
------------------get the enumeration type columns definitions------------

        -- open the ADAENUM reserved table
        ADA_TABLES.OPEN_ADA_TABLE ("ADAENUM   ");

        for I in 1 .. TABLE_NUMBER loop
            -- for each of the tables to be locked

            -- select in ADAENUM all rows relative to TABLE_NAME2 (I)
            ADA_TABLES.RESET_ADA_TABLE (TABLE_NAME2 (I));

            TABLE (I).TABLE_DEFINITION.ENUM_TYPES := (others => null);

            loop
                -- for each row defining a particular value of a particular
                -- enumeration type definition

                -- get the position and image of an item, and the name
                -- of the enumeration column it belongs to
                ADA_TABLES.GET_ENUM (COLNAME, ENUM_VALUE, IMAGE_STRING, EOF);
                exit when EOF;

                -- look for the place where the new definition item is to
                -- be inserted
                for II in 1 .. INDEX1 (I) + 1 loop
                    INDEX2 (I) := II;
                    exit when COLNAME =
                              TABLE (I).TABLE_DEFINITION.COLUMN_NAMES (II);
                end loop;

                -- initialize CURSOR to the first item (if any) of the
                -- list currently built
                CURSOR := TABLE (I).TABLE_DEFINITION.ENUM_TYPES (INDEX2 (I));
        PREVIOUS_CURSOR := null;

                -- move in the list until the searched position is found
                -- (ENUM_VALUE = 0) or the list is not yet long enough
                -- (CURSOR = null)
                while ENUM_VALUE /= 0 and CURSOR /= null loop
                    ENUM_VALUE := ENUM_VALUE - 1;
            PREVIOUS_CURSOR := CURSOR;
                    CURSOR := CURSOR.all.OTHER;
                end loop;

                -- append empty items to the list until the list is long
                -- enough
                while ENUM_VALUE /= 0 loop
                    ENUM_VALUE := ENUM_VALUE - 1;
                    CURSOR := new ENUM_ITEM;
            PREVIOUS_CURSOR := CURSOR;
                    CURSOR := CURSOR.all.OTHER;
                end loop;

                if CURSOR = null then
          CURSOR := new ENUM_ITEM;
          if PREVIOUS_CURSOR = null then
            TABLE (I).TABLE_DEFINITION.ENUM_TYPES (INDEX2 (I))
            := CURSOR;
          else
                    PREVIOUS_CURSOR.all.OTHER := CURSOR;
          end if;
                end if;

                -- store the image of the item into the found element
                -- of the list
                CURSOR.all.ENUM_IMAGE := IMAGE_STRING;

                if INDEX2 (I) = INDEX1 (I) + 1 then
                    TABLE (I).TABLE_DEFINITION.COLUMN_NAMES (INDEX2 (I)) :=
                      COLNAME;
                    INDEX1 (I) := INDEX2 (I);
                end if;
            end loop;
        end loop;
        ADA_TABLES.CLOSE_ADA_TABLE;

        -- unlock the three reserved tables
        ADA_TABLES.UNLOCK_ADA_TABLES;
---------------------get the basical definitions of the tables------------

        -- actually set the requested locks
        for I in 1 .. TABLE_NUMBER loop
            RELIST (12 * I - 11 .. 12 * I) := TABLE_NAME2 (I) & "  ";
        end loop;

        for I in 1 .. TABLE_NUMBER loop
            if LOCK_LIST (LOCK_LIST'FIRST - 1 + I).ACCESS_MODE = SHARED then
                MODLIS (I) := 0;
            else
                MODLIS (I) := 1;
            end if;
        end loop;

        F77_CALLABLES.ADA_DLOCK (RELIST, MODLIS, TABLE_NUMBER, RTN);

        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "One of the tables to be locked does not exist, is not on line,");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "or can not be accessed");
            raise X_CANT_ACCESS_TABLE;
        end if;

        for I in 1 .. TABLE_NUMBER loop
            -- for each table to be locked

            -- first open it
            F77_CALLABLES.ADA_OPENR (TABLE_NAME2 (I), DESCR, RTN);

            if RTN /= 0 then
-- the table could not be opened;
-- all that have already been locked and opened must then
-- be closed and unlocked

                for II in 1 .. TABLE_NUMBER loop
                    TABLE (II).TABLE_STATUS.TABLE_IS_LOCKED := FALSE;
                end loop;

                for II in 1 .. I - 1 loop
                    F77_CALLABLES.ADA_CLOSER (TABLE (II).TABLE_STATUS.DESCR);
                end loop;

                F77_CALLABLES.ADA_DUNLK;
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "One of the tables to be locked does not exist, is not on line,");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "or can not be accessed");
                raise X_CANT_ACCESS_TABLE;
            end if;

            -- store the table name into TABLE
            TABLE (I).NAME := TABLE_NAME2 (I);
            -- initialize the table status
            TABLE (I).TABLE_STATUS :=
              (TABLE_IS_LOCKED     => TRUE,
               CURRENT_LOCK        =>
                 LOCK_LIST (LOCK_LIST'FIRST + I - 1).ACCESS_MODE,
               DESCR               => DESCR,
               FIND_STATUS         => DEAD,
               SELECTION_CRITERION => null,
               CURRENT_ROW         => (-1, 0, 0));

            -- initialize actual current row to the beginning of the table
            F77_CALLABLES.ADA_SETGET (DESCR, 3, TIDD, TIDD, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error during initializing the current row");
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "of a table to be locked");
                raise X_INTERNAL_ERROR;
            end if;

            -- get the scalar columns number, names, order, types and
            -- lengths
            ATTL := -1;
            ATNAM := (others => ' ');
            F77_CALLABLES.ADA_DGINFO
               (DESCR, ATNAM, ATTL, ATIDX, ATLEN, ATTYP, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error during reading the description of a table");
                raise X_INTERNAL_ERROR;
            end if;
            TABLE (I).TABLE_DEFINITION.COLUMN_NUMBER := ATTL;

            -- get the sort information
            F77_CALLABLES.ADA_FACSS (DESCR, ACSIFO);
            -- store it into TABLE
            if ACSIFO (1) = 1 then
                TABLE (I).TABLE_DEFINITION.SORTED := FALSE;
            else
                TABLE (I).TABLE_DEFINITION.SORTED := TRUE;
            end if;

            for II in 1 .. ATTL loop
                -- for each scalar column

                -- store the column names into the COLNAME variable
                COLNAME := UTILITIES.NORMALIZE
                        (ATNAM (1 + (II - 1) * 12 .. II * 12 - 2));

                -- look for COLNAME among already defined columns
                for III in II .. II + INDEX1 (I) loop
                    INDEX := III;
                    exit when III = COL_NO + 1;
                    exit when TABLE (I).TABLE_DEFINITION.COLUMN_NAMES (III) =
                              COLNAME;
                end loop;

                if TABLE (I).TABLE_DEFINITION.COLUMN_NAMES (INDEX) =
                   COLNAME then
                    -- this column has already been defined
                    if II /= INDEX then
                        TABLE (I).TABLE_DEFINITION.CONSTRAINTS (II) :=
                          TABLE (I).TABLE_DEFINITION.CONSTRAINTS (INDEX);
                        TABLE (I).TABLE_DEFINITION.IN_RECORD (II) :=
                          TABLE (I).TABLE_DEFINITION.IN_RECORD (INDEX);
                        TABLE (I).TABLE_DEFINITION.ENUM_TYPES (II) :=
                          TABLE (I).TABLE_DEFINITION.ENUM_TYPES (INDEX);

                        TABLE (I).TABLE_DEFINITION.COLUMN_NAMES (INDEX) :=
                          (1 .. NAME_LENGTH => ' ');
                        TABLE (I).TABLE_DEFINITION.CONSTRAINTS (INDEX) :=
                            null;
                        TABLE (I).TABLE_DEFINITION.IN_RECORD (INDEX) :=
                            (1 .. NAME_LENGTH => ' ');
                        TABLE (I).TABLE_DEFINITION.ENUM_TYPES (INDEX) :=
                            null;
                    end if;

                else
-- this column has not yet been defined

-- look at the first free place
                    for III in II + 1 .. II + INDEX1 (I) + 1 loop
                        INDEX := III;
                        exit when TABLE (I).TABLE_DEFINITION.COLUMN_NAMES
                                     (III) = (1 .. NAME_LENGTH => ' ');
                    end loop;

                    -- save into this free place the row definition
                    -- which was previously where the new row definition
                    -- is to be inserted
                    if II /= INDEX then
                        TABLE (I).TABLE_DEFINITION.COLUMN_NAMES (INDEX) :=
                          TABLE (I).TABLE_DEFINITION.COLUMN_NAMES (II);
                        TABLE (I).TABLE_DEFINITION.CONSTRAINTS (INDEX) :=
                          TABLE (I).TABLE_DEFINITION.CONSTRAINTS (II);
                        TABLE (I).TABLE_DEFINITION.IN_RECORD (INDEX) :=
                          TABLE (I).TABLE_DEFINITION.IN_RECORD (II);
                        TABLE (I).TABLE_DEFINITION.ENUM_TYPES (INDEX) :=
                          TABLE (I).TABLE_DEFINITION.ENUM_TYPES (II);

                        TABLE (I).TABLE_DEFINITION.CONSTRAINTS (II) :=
                            null;
                        TABLE (I).TABLE_DEFINITION.IN_RECORD (II) :=
                            (1 .. NAME_LENGTH => ' ');
                        TABLE (I).TABLE_DEFINITION.ENUM_TYPES (II) :=
                            null;
                    end if;
                end if;

                -- store the column name into TABLE
                TABLE (I).TABLE_DEFINITION.COLUMN_NAMES (II) := COLNAME;
            end loop;

            -- store the index, type and length of the column into TABLE
            TABLE (I).TABLE_DEFINITION.COLUMN_INDEX := ATIDX;
            TABLE (I).TABLE_DEFINITION.COLUMN_TYPES := ATTYP;
            TABLE (I).TABLE_DEFINITION.COLUMN_LENGTH := ATLEN;
        end loop;
    end LOCK;

    procedure GET_INFORMATION (TABLE_NAME    : STRING;
                               COLUMN_NUMBER : out POSITIVE;
                               COLUMN_LIST   : out STRING) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          GET_INFORMATION                             **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_NO_OPEN_DB;                                         **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- this information can be read  in the LOCK attribute  **
--**            -- of the TABLE array of the STATUS package             **
--**                                                                    **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    TRANSLATE_INFORMATION_INTO_THE_OUTPUT_FORMAT;                   **
--**        -- generates from the information got from the database  a  **
--**        -- sentence of the language recognized by the DEFINE_TABLE  **
--**        -- procedure.                                               **
--**                                                                    **
--**    if COLUMN_LIST_IS_TOO_SHORT then                                **
--**        raise X_TOO_SHORT_STRING;                                   **
--**    end if;                                                         **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME is the name of the table the user wants  information   **
--**  about.                                                            **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**  COLUMN_NUMBER  is  the  number of columns  the  table  contains.  **
--**                                                                    **
--**  COLUMN_LIST is the list of the column definitions of the  table,  **
--**  in   the   same   format    as   in  the  DEFINE_TABLE   format.  **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_NO_OPEN_DB                                                    **
--**    X_TABLE_NOT_LOCKED                                              **
--**    X_TOO_SHORT_STRING                                              **
--**                                                                    **
--************************************************************************
        IC, IT, INDEX : INTEGER;
        STRING_SIZE   : INTEGER := COLUMN_LIST'LENGTH;

        procedure ASSIGN_TO_COLUMN_LIST (S : STRING) is

                -- ASSIGN_TO_COLUMN_LIST appends S to COLUMN_LIST at the
                -- current position defined by INDEX, and updates INDEX, or
                -- raises X_TOO_SHORT_STRING if COLUMN_LIST is not long enough

            S_LENGTH : INTEGER := S'LENGTH;
        begin
            if INDEX + S_LENGTH - 1 > STRING_SIZE then
                raise X_TOO_SHORT_STRING;
            else
                COLUMN_LIST (INDEX .. INDEX + S_LENGTH - 1) := S;
                INDEX := INDEX + S_LENGTH;
            end if;
        end ASSIGN_TO_COLUMN_LIST;

        function ENUM_IMAGE (CURRENT_IMAGE : ENUM_ITEM_ACCESS)
                              return ENUM_ITEM_ACCESS is

                -- write into COLUMN_LIST the image of the enumeration
                -- item defined by CURRENT_IMAGE, and return a pointer
                -- to the following item

            MEANINGFUL : INTEGER;
        begin
                -- MEANINGFUL will be set to the number of the last
                -- non-blank character of the enumeration item
            MEANINGFUL := IMAGE_SZ;

            while CURRENT_IMAGE.ENUM_IMAGE (MEANINGFUL) = ' ' loop
                MEANINGFUL := MEANINGFUL - 1;
            end loop;

                -- copy the image into COLUMN_LIST
            ASSIGN_TO_COLUMN_LIST (CURRENT_IMAGE.ENUM_IMAGE (1 .. MEANINGFUL));

                -- and return the pointer to the next item
            return CURRENT_IMAGE.OTHER;
        end ENUM_IMAGE;

        procedure CONSTRAINT is

                -- write into COLUMN_LIST a range constraint declaration

            MEANINGFUL : INTEGER;
        begin
                -- first check if there is one
            if TABLE (IT).TABLE_DEFINITION.CONSTRAINTS (IC) /= null then
                    -- there is one

                        -- write " range"
                ASSIGN_TO_COLUMN_LIST (" range ");

                        -- copy the minimum value
                MEANINGFUL := RANGE_SIZE;
                while TABLE (IT).TABLE_DEFINITION.CONSTRAINTS (IC).all
                         (MEANINGFUL) = ' ' loop
                    MEANINGFUL := MEANINGFUL - 1;
                end loop;
                ASSIGN_TO_COLUMN_LIST (TABLE (IT).TABLE_DEFINITION.CONSTRAINTS
                    (IC).all (1 .. MEANINGFUL) & " .. ");

                        -- copy the maximum value
                MEANINGFUL := 2 * RANGE_SIZE;
                while TABLE (IT).TABLE_DEFINITION.CONSTRAINTS (IC).all
                         (MEANINGFUL) = ' ' loop
                    MEANINGFUL := MEANINGFUL - 1;
                end loop;
                ASSIGN_TO_COLUMN_LIST (TABLE(IT).TABLE_DEFINITION.CONSTRAINTS
                    (IC).all (RANGE_SIZE + 1 .. MEANINGFUL));
            end if;
        end CONSTRAINT;

        procedure SCALAR_DESCR is

                -- write into COLUMN_LIST a scalar column declaration
                -- (i.e. type, length, constraint)

            INTEGER_IMAGE        : STRING (1 .. 10);
            INTEGER_IMAGE_LENGTH : INTEGER;
            NEXT_IMAGE           : ENUM_ITEM_ACCESS;
        begin
            if TABLE (IT).TABLE_DEFINITION.COLUMN_TYPES (IC) = 1 then
                        -- INTEGER type column

                ASSIGN_TO_COLUMN_LIST ("integer");
                CONSTRAINT;

            elsif TABLE (IT).TABLE_DEFINITION.COLUMN_TYPES (IC) = 2 then
                        -- FLOAT type column

                ASSIGN_TO_COLUMN_LIST ("float");
                CONSTRAINT;

            elsif TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC) /= null then
                        -- ENUMERATION type column

                ASSIGN_TO_COLUMN_LIST ("(");
                NEXT_IMAGE := ENUM_IMAGE
                                 (TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC));

                while NEXT_IMAGE /= null loop
                    ASSIGN_TO_COLUMN_LIST (",");
                    NEXT_IMAGE := ENUM_IMAGE (NEXT_IMAGE);
                end loop;

                ASSIGN_TO_COLUMN_LIST (")");
                INDEX := INDEX + 1;
                CONSTRAINT;

            else
                        -- STRING type column

                ASSIGN_TO_COLUMN_LIST ("string(1..");
                INTEGER_IMAGE_LENGTH :=
                  INTEGER'IMAGE (TABLE (IT).TABLE_DEFINITION.COLUMN_LENGTH (IC))
                   'LENGTH;
                INTEGER_IMAGE (1 .. INTEGER_IMAGE_LENGTH) :=
                  INTEGER'IMAGE
                    (TABLE (IT).TABLE_DEFINITION.COLUMN_LENGTH (IC));
                ASSIGN_TO_COLUMN_LIST
                    (INTEGER_IMAGE (1 .. INTEGER_IMAGE_LENGTH) & ")");
            end if;
        end SCALAR_DESCR;

        procedure COLUMN_DESCR is

                -- write into COLUMN_LIST a column declaration; such
                -- a column can either be a record column or a scalar
                -- column, but not only a component column of an
                -- encapsulating record one.

            RECORD_NAME : STRING (1 .. NAME_LENGTH);
        begin
            RECORD_NAME := TABLE (IT).TABLE_DEFINITION.IN_RECORD (IC);

            if RECORD_NAME = (1 .. NAME_LENGTH => ' ') then
                        -- the current column is a scalar column

                ASSIGN_TO_COLUMN_LIST
                 (TABLE (IT).TABLE_DEFINITION.COLUMN_NAMES (IC) & " ");
                SCALAR_DESCR;
                IC := IC + 1;
            else
                        -- the current column is a record column

                        -- first write the declaration of the first
                        -- component
                ASSIGN_TO_COLUMN_LIST (RECORD_NAME & " ");
                ASSIGN_TO_COLUMN_LIST
                    (TABLE (IT).TABLE_DEFINITION.COLUMN_NAMES (IC) & " ");
                SCALAR_DESCR;
                IC := IC + 1;

                        -- then write the declaration of the following
                        -- components, if any
                while TABLE (IT).TABLE_DEFINITION.IN_RECORD (IC) =
                      RECORD_NAME loop
                    ASSIGN_TO_COLUMN_LIST
                     ("," & TABLE (IT).TABLE_DEFINITION.COLUMN_NAMES (IC));
                    SCALAR_DESCR;
                    IC := IC + 1;
                end loop;
            end if;
        end COLUMN_DESCR;

    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened before trying to get the description");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "of an included table");
            raise X_NO_OPEN_DB;
        end if;

                -- store in IT the identifier of the TABLE_NAME table,
                -- or raise X_TABLE_NOT_LOCKED if this name is unknown
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

                -- return COLUMN_NUMBER
        COLUMN_NUMBER := TABLE (IT).TABLE_DEFINITION.COLUMN_NUMBER;

                -- INDEX will be an index to the next character to be
                -- written into COLUMN_LIST
        INDEX := 1;
                -- IC will be the identifier of the currently processed
                -- scalar column
        IC := 1;

                -- first write the first column declaration
        COLUMN_DESCR;

        while IC /= TABLE (IT).TABLE_DEFINITION.COLUMN_NUMBER + 1 loop
                -- loop for each column declaration

            ASSIGN_TO_COLUMN_LIST (";");
            COLUMN_DESCR;
        end loop;

        COLUMN_LIST (INDEX .. STRING_SIZE) := (INDEX .. STRING_SIZE => ' ');
    end GET_INFORMATION;


    procedure UNLOCK is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          UNLOCK                                      **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_NO_OPEN_DB;                                         **
--**    end if;                                                         **
--**                                                                    **
--**    for TABLE_NAME in TABLE'FIRST .. TABLE'LAST loop                **
--**                                                                    **
--**            -- for each known table, look for its current lock      **
--**            -- (unlocked, shared, or exclusive)                     **
--**                                                                    **
--**        if TABLE_NAME_IS_LOCKED then                                **
--**                                                                    **
--**                -- the LOCK component of TABLE_NAME in the TABLE    **
--**                -- status array is 'shared' or 'exclusive' but not  **
--**                -- 'unlocked'                                       **
--**                                                                    **
--**            CLOSE_TABLE (TABLE_NAME);                               **
--**            TABLE(TABLE_NAME).LOCK := UNLOCKED;                     **
--**        end if;                                                     **
--**    end loop;                                                       **
--**                                                                    **
--**    UNLOCK_TABLES;                                                  **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    TABLE.LOCK                                                      **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_NO_OPEN_DB                                                    **
--**                                                                    **
--************************************************************************
    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "UNLOCK is available with an open database only");
            raise X_NO_OPEN_DB;
        end if;

        for I in 1 .. TABLE_NO loop
            if TABLE (I).TABLE_STATUS.TABLE_IS_LOCKED then
                F77_CALLABLES.ADA_CLOSER (TABLE (I).TABLE_STATUS.DESCR);
                TABLE (I).TABLE_STATUS.TABLE_IS_LOCKED := FALSE;
            end if;
        end loop;

        F77_CALLABLES.ADA_DUNLK;
    end UNLOCK;

    procedure CLOSE is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          CLOSE                                       **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**    LL_DAMES.UNLOCK;                                                **
--**        -- unlock locked tables, if any                             **
--**                                                                    **
--**    CLOSE_DATABASE;                                                 **
--**        -- close the database;                                      **
--**                                                                    **
--**    A_DATABASE_IS_OPEN := FALSE;                                    **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_NO_OPEN_DB                                                    **
--**                                                                    **
--************************************************************************
    begin
        UNLOCK;
        F77_CALLABLES.ADA_CLOSDB;
        SHARE.A_DATABASE_IS_OPEN := FALSE;
    end CLOSE;


    procedure MATCH (TABLE_NAME   : STRING;
                     COLUMN_NAME  : STRING;
                     KEY_MATCH    : KEY_MATCH_TYPE;
                     COLUMN_VALUE : USER_COLUMN) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          MATCH                                       **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- i.e. the LOCK component of TABLE_NAME in the TABLE   **
--**            -- status array is 'unlocked'                           **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_NAME_DOES_NOT_EXIST then                              **
--**            -- COLUMN_NAME is not the name of one of the columns    **
--**            -- of the TABLE_NAME table, or is a record column.      **
--**        raise X_INVALID_COLUMN;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_TYPE_DOES_NOT_MATCH_INSTANTIATION_TYPE then           **
--**            -- information known by DAMES about the type of the     **
--**            -- COLUMN_NAME column does not match the USER_COLUMN    **
--**            -- type, which is defined when instantiating the        **
--**            -- generic DAMES_FIND package                           **
--**        raise X_INVALID_COLUMN;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_TYPE_DOES_NOT_MATCH_COLUMN_VALUE then                 **
--**            -- the type USER_COLUMN is then correct, but the value  **
--**            -- of the COLUMN_VALUE actual argument is not valid for **
--**            -- the COLUMN_NAME column type                          **
--**        raise X_INVALID_VALUE;                                      **
--**    end if;                                                         **
--**                                                                    **
--**    INITIALIZE_SELECTION_CRITERION (COLUMN_NAME,                    **
--**                                    KEY_MATCH,                      **
--**                                    COLUMN_VALUE);                  **
--**        -- build a new selection criterion, the first basic         **
--**        -- expression of which being :                              **
--**        --         'COLUMN_NAME KEY_MATCH COLUMN_VALUE'             **
--**        -- This criterion is specific to the TABLE_NAME table       **
--**                                                                    **
--**    UPDATE_FIND_STATUS;                                             **
--**        -- set  to  'CRITERION'  the  FIND_STATUS  component  of    **
--**        -- TABLE_NAME in the TABLE status array                     **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of  the table on which the  selection  **
--**  criterion will be applied.                                        **
--**                                                                    **
--**  COLUMN_NAME is the name of the column to be used.                 **
--**                                                                    **
--**  KEY_MATCH is the match to be performed between the column of the  **
--**  candidate row and COLUMN_VALUE.                                   **
--**                                                                    **
--**  COLUMN_VALUE is the value to  be  compared  with the COLUMN_NAME  **
--**  column.                                                           **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    TABLE.FIND_STATUS                                               **
--**    TABLE.SELECTION_CRITERION                                       **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_INVALID_VALUE                                                 **
--**    X_INVALID_COLUMN                                                **
--**    X_TABLE_NOT_LOCKED                                              **
--**                                                                    **
--************************************************************************
        IT, IC     : INTEGER;
        MEANINGFUL : NATURAL;
        TRANSLATE  : INTEGER_ARRAY_TYPE (1 .. (MAX_STRING + 3) / 4) :=
                                (others => 0);
        subtype NULL_STRING  is STRING (2 .. 1);
        subtype TRANSIT_TYPE is STRING
                                  (1 .. (USER_COLUMN'SIZE -
                                         NULL_STRING'SIZE) / CHARACTER'SIZE);

        TRANSIT : TRANSIT_TYPE;

        function USER_COLUMN_TO_INTEGER is new UNCHECKED_CONVERSION
                   (USER_COLUMN, INTEGER);
        function USER_COLUMN_TO_INTEGER16 is new UNCHECKED_CONVERSION
                   (USER_COLUMN, INTEGER16);
        function USER_COLUMN_TO_TRANSIT is new UNCHECKED_CONVERSION
                   (USER_COLUMN, TRANSIT_TYPE);
    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened and a table locked to use MATCH");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the table index or raise X_TABLE_NOT_LOCKED if this one
        -- does not exist
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        -- get the column index or raise X_INVALID_COLUMN if this one
        -- does not exist
        IC := UTILITIES.SCALAR_COLUMN_ID (IT, COLUMN_NAME);

        -- check the user-defined type size
        if COLUMN_VALUE'SIZE /= UTILITIES.BIT_SIZE (IT, IC) then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "The size of the Ada type used to instantiate MATCH");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "does not correspond to the size of the " & COLUMN_NAME &
            " column");
            raise X_INVALID_COLUMN;
        end if;

        -- store into TRANSLATE the value to be compared with actual
        -- values of the candidate rows, and store into MEANINGFUL
        -- the number of meaningful components of TRANSLATE
        case TABLE (IT).TABLE_DEFINITION.COLUMN_TYPES (IC) is
            when 1 | 2 =>
                -- INTEGER or FLOAT type

                TRANSLATE (1) := USER_COLUMN_TO_INTEGER (COLUMN_VALUE);
                MEANINGFUL := 1;

            when 5 =>
                if TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC) /= null then
                    -- enumeration type

                    TRANSLATE (1) := INTEGER (USER_COLUMN_TO_INTEGER16
                                                        (COLUMN_VALUE));
                    MEANINGFUL := 1;
                else

                    -- STRING type
                    TRANSIT := USER_COLUMN_TO_TRANSIT (COLUMN_VALUE);
                    MEANINGFUL := (TRANSIT'LENGTH + 3) / 4;
                    TRANSLATE (1 .. MEANINGFUL) :=
                      CONVERSION.F77_STRING (TRANSIT);
                end if;

            when others =>
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when identifying the column type in MATCH");
                raise X_INTERNAL_ERROR;
        end case;

        if TABLE (IT).TABLE_DEFINITION.CONSTRAINTS (IC) /= null then
                -- a range constraint applies to the column;the
                -- value must be checked not to violate this range.
            UTILITIES.CHECK_VALUE (TRANSLATE (1), IT, IC);
        end if;

        -- free all nodes of the already allocated ones
        TABLE_DESCRIPTOR.FREE_NODES (IT);

        -- add a new node to the selection criterion
        TABLE (IT).TABLE_STATUS.SELECTION_CRITERION :=
                TABLE_DESCRIPTOR.NEW_NODE;
        TABLE (IT).TABLE_STATUS.SELECTION_CRITERION.all :=
                   (COLUMN_ID                        => IC,
                    KEY_MATCH                        => KEY_MATCH,
                    COLUMN_VALUE                     => TRANSLATE,
                    MEANINGFUL                       => MEANINGFUL,
                    USER_OPERATOR | TREE_OPERATOR     => OR_OPERATOR,
                    FIRST_CHILD | SECOND_CHILD | OTHER => null);

        -- set the find-status to 'CRITERION'
        TABLE (IT).TABLE_STATUS.FIND_STATUS := CRITERION;
    end MATCH;

    procedure OR_MATCH (TABLE_NAME   : STRING;
                        COLUMN_NAME  : STRING;
                        KEY_MATCH    : KEY_MATCH_TYPE;
                        COLUMN_VALUE : USER_COLUMN) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          OR_MATCH                                    **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- i.e. the LOCK component of TABLE_NAME in the TABLE   **
--**            -- status array is 'unlocked'                           **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if FIND_STATUS_IS_NOT_CRITERION then                            **
--**            -- the FIND_STATUS component of TABLE_NAME in the TABLE **
--**            -- status array is not 'criterion'                      **
--**        raise X_NO_PREVIOUS_MATCH;                                  **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_NAME_DOES_NOT_EXIST then                              **
--**            -- COLUMN_NAME is not the name of one of the columns    **
--**            -- of the TABLE_NAME table, or is a record column.      **
--**        raise X_INVALID_COLUMN;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_TYPE_DOES_NOT_MATCH_INSTANTIATION_TYPE then           **
--**            -- information known by DAMES about the type of the     **
--**            -- COLUMN_NAME column does not match the USER_COLUMN    **
--**            -- type, which is defined when instantiating the        **
--**            -- generic OR_MATCH procedure.                          **
--**        raise X_INVALID_COLUMN;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_TYPE_DOES_NOT_MATCH_COLUMN_VALUE then                 **
--**            -- the type USER_COLUMN is then correct, but the value  **
--**            -- of the COLUMN_VALUE actual argument is not valid for **
--**            -- the COLUMN_NAME column type                          **
--**        raise X_INVALID_VALUE;                                      **
--**    end if;                                                         **
--**                                                                    **
--**    APPEND_TO_SELECTION_CRITERION ( OR,                             **
--**                                    COLUMN_NAME,                    **
--**                                    KEY_MATCH,                      **
--**                                    COLUMN_VALUE);                  **
--**        -- add to the current selection criterion another basic     **
--**        -- expression, which is :                                   **
--**        --         'COLUMN_NAME KEY_MATCH COLUMN_VALUE'             **
--**        -- This new basic expression is connected to the already    **
--**        -- defined ones with the OR logical operator.               **
--**        -- This criterion is specific to the TABLE_NAME table       **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of  the table on which the  selection  **
--**  criterion will be applied.                                        **
--**                                                                    **
--**  COLUMN_NAME is the name of the column to be used.                 **
--**                                                                    **
--**  KEY_MATCH is the match to be performed between the column of the  **
--**  candidate row and COLUMN_VALUE.                                   **
--**                                                                    **
--**  COLUMN_VALUE is the value to  be  compared  with the COLUMN_NAME  **
--**  column.                                                           **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**    TABLE.FIND_STATUS                                               **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    TABLE.SELECTION_CRITERION                                       **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_INVALID_VALUE                                                 **
--**    X_INVALID_COLUMN                                                **
--**    X_TABLE_NOT_LOCKED                                              **
--**    X_NO_PREVIOUS_MATCH                                             **
--**                                                                    **
--************************************************************************
        IT, IC     : INTEGER;
        MEANINGFUL : NATURAL;
        TRANSLATE  : INTEGER_ARRAY_TYPE (1 .. (MAX_STRING + 3) / 4);
        LAST_NODE  : NODE_ACCESS;

        subtype NULL_STRING  is STRING (2 .. 1);
        subtype TRANSIT_TYPE is STRING
                                  (1 .. (USER_COLUMN'SIZE -
                                         NULL_STRING'SIZE) / CHARACTER'SIZE);

        TRANSIT : TRANSIT_TYPE;

        function USER_COLUMN_TO_TRANSIT is new UNCHECKED_CONVERSION
                   (USER_COLUMN, TRANSIT_TYPE);
        function USER_COLUMN_TO_INTEGER is new UNCHECKED_CONVERSION
                   (USER_COLUMN, INTEGER);
        function USER_COLUMN_TO_INTEGER16 is new UNCHECKED_CONVERSION
                   (USER_COLUMN, INTEGER16);

    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened and a table locked to use OR_MATCH");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the table index or raise X_TABLE_NOT_LOCKED
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        if TABLE (IT).TABLE_STATUS.FIND_STATUS /= CRITERION then
            -- the find-status is not 'criterion'; it means that the
            -- MATCH procedure has not been previously called, or has been
            -- followed by a FIND call
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "MATCH must be called before calling OR_MATCH");
            raise X_NO_PREVIOUS_MATCH;
        end if;

        -- get the index corresponding to COLUMN_NAME, assuming that
        -- this is the name of a scalar column, otherwise raise
        -- X_INVALID_COLUMN
        IC := UTILITIES.SCALAR_COLUMN_ID (IT, COLUMN_NAME);

        if COLUMN_VALUE'SIZE /= UTILITIES.BIT_SIZE (IT, IC) then
            -- the actual parameter size does not match the required size
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "The size of the Ada type used to instantiate OR_MATCH");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "does not correspond to the size of the " & COLUMN_NAME &
            " column");
            raise  X_INVALID_COLUMN;
        end if;

        case TABLE (IT).TABLE_DEFINITION.COLUMN_TYPES (IC) is
            when 1 | 2 =>
-- integer or float column
                TRANSLATE (1) := USER_COLUMN_TO_INTEGER (COLUMN_VALUE);
                MEANINGFUL := 1;
            when 5 =>
                if TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC) /= null then
                    -- enumeration column
                    TRANSLATE (1) := INTEGER (USER_COLUMN_TO_INTEGER16
                                                        (COLUMN_VALUE));
                    MEANINGFUL := 1;
                else
                    -- character string column
                    TRANSIT := USER_COLUMN_TO_TRANSIT (COLUMN_VALUE);
                    MEANINGFUL := (TRANSIT'LENGTH + 3) / 4;
                    TRANSLATE (1 .. MEANINGFUL) :=
                      CONVERSION.F77_STRING (TRANSIT);
                end if;

            when others =>
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when identifying the column type in OR_MATCH");
                raise X_INTERNAL_ERROR;
        end case;

        if TABLE (IT).TABLE_DEFINITION.CONSTRAINTS (IC) /= null then
                -- a range constraint applies to the column;the
                -- value must be checked not to violate this range.
            UTILITIES.CHECK_VALUE (TRANSLATE (1), IT, IC);
        end if;

        LAST_NODE := TABLE (IT).TABLE_STATUS.SELECTION_CRITERION;

        while LAST_NODE.all.OTHER /= null loop
            -- loop until the last component of the list is found
            LAST_NODE := LAST_NODE.all.OTHER;
        end loop;

        -- append a new node to the list
        LAST_NODE.all.OTHER := TABLE_DESCRIPTOR.NEW_NODE;
        LAST_NODE.all.OTHER.all :=
                   (COLUMN_ID                        => IC,
                    KEY_MATCH                        => KEY_MATCH,
                    COLUMN_VALUE                     => TRANSLATE,
                    MEANINGFUL                       => MEANINGFUL,
                    USER_OPERATOR | TREE_OPERATOR     => OR_OPERATOR,
                    FIRST_CHILD | SECOND_CHILD | OTHER => null);
    end OR_MATCH;

    procedure AND_MATCH (TABLE_NAME   : STRING;
                         COLUMN_NAME  : STRING;
                         KEY_MATCH    : KEY_MATCH_TYPE;
                         COLUMN_VALUE : USER_COLUMN) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          AND_MATCH                                   **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- i.e. the LOCK component of TABLE_NAME in the TABLE   **
--**            -- status array is 'unlocked'                           **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if FIND_STATUS_IS_NOT_CRITERION then                            **
--**            -- the FIND_STATUS component of TABLE_NAME in the TABLE **
--**            -- status array is not 'criterion'.                     **
--**        raise X_NO_PREVIOUS_MATCH;                                  **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_NAME_DOES_NOT_EXIST then                              **
--**            -- COLUMN_NAME is not the name of one of the columns    **
--**            -- of the TABLE_NAME table, or is a record column.      **
--**        raise X_INVALID_COLUMN;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_TYPE_DOES_NOT_MATCH_INSTANTIATION_TYPE then           **
--**            -- information known by DAMES about the type of the     **
--**            -- COLUMN_NAME column does not match the USER_COLUMN    **
--**            -- type, which is defined when instantiating the        **
--**            -- generic AND_MATCH procedure.                         **
--**        raise X_INVALID_COLUMN;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_TYPE_DOES_NOT_MATCH_COLUMN_VALUE then                 **
--**            -- the type USER_COLUMN is then correct, but the value  **
--**            -- of the COLUMN_VALUE actual argument is not valid for **
--**            -- the COLUMN_NAME column type                          **
--**        raise X_INVALID_VALUE;                                      **
--**    end if;                                                         **
--**                                                                    **
--**    APPEND_TO_SELECTION_CRITERION ( AND,                            **
--**                                    COLUMN_NAME,                    **
--**                                    KEY_MATCH,                      **
--**                                    COLUMN_VALUE);                  **
--**        -- add to the current selection criterion another basic     **
--**        -- expression, which is :                                   **
--**        --         'COLUMN_NAME KEY_MATCH COLUMN_VALUE'             **
--**        -- This new basic expression is connected to the already    **
--**        -- defined ones with the AND logical operator.              **
--**        -- This criterion is specific to the TABLE_NAME table       **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of  the table on which the  selection  **
--**  criterion will be applied.                                        **
--**                                                                    **
--**  COLUMN_NAME is the name of the column to be used.                 **
--**                                                                    **
--**  KEY_MATCH is the match to be performed between the column of the  **
--**  candidate row and COLUMN_VALUE.                                   **
--**                                                                    **
--**  COLUMN_VALUE is the value to  be  compared  with the COLUMN_NAME  **
--**  column.                                                           **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**    TABLE.FIND_STATUS                                               **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    TABLE.SELECTION_CRITERION                                       **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_INVALID_VALUE                                                 **
--**    X_INVALID_COLUMN                                                **
--**    X_TABLE_NOT_LOCKED                                              **
--**    X_NO_PREVIOUS_MATCH                                             **
--**                                                                    **
--************************************************************************
        IT, IC     : INTEGER;
        MEANINGFUL : NATURAL;
        TRANSLATE  : INTEGER_ARRAY_TYPE (1 .. (MAX_STRING + 3) / 4);
        LAST_NODE  : NODE_ACCESS;

        subtype NULL_STRING  is STRING (2 .. 1);
        subtype TRANSIT_TYPE is STRING
                                  (1 .. (USER_COLUMN'SIZE -
                                         NULL_STRING'SIZE) / CHARACTER'SIZE);

        TRANSIT : TRANSIT_TYPE;

        function USER_COLUMN_TO_TRANSIT is new UNCHECKED_CONVERSION
                   (USER_COLUMN, TRANSIT_TYPE);
        function USER_COLUMN_TO_INTEGER is new UNCHECKED_CONVERSION
                   (USER_COLUMN, INTEGER);
        function USER_COLUMN_TO_INTEGER16 is new UNCHECKED_CONVERSION
                   (USER_COLUMN, INTEGER16);

    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened and a table locked to use AND_MATCH");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the table index or raise X_TABLE_NOT_LOCKED
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        if TABLE (IT).TABLE_STATUS.FIND_STATUS /= CRITERION then
            -- the find-status is not 'criterion'; it means that the
            -- MATCH procedure has not been previously called, or has been
            -- followed by a FIND call
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "MATCH must be called before calling AND_MATCH");
            raise X_NO_PREVIOUS_MATCH;
        end if;

        -- get the index corresponding to COLUMN_NAME, assuming that
        -- this is the name of a scalar column, otherwise raise
        -- X_INVALID_COLUMN
        IC := UTILITIES.SCALAR_COLUMN_ID (IT, COLUMN_NAME);

        if COLUMN_VALUE'SIZE /= UTILITIES.BIT_SIZE (IT, IC) then
            -- the actual parameter size does not match the required size
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "The size of the Ada type used to instantiate AND_MATCH");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "does not correspond to the size of the " & COLUMN_NAME &
            " column");
            raise X_INVALID_COLUMN;
        end if;

        case TABLE (IT).TABLE_DEFINITION.COLUMN_TYPES (IC) is
            when 1 | 2 =>
-- integer or float column
                TRANSLATE (1) := USER_COLUMN_TO_INTEGER (COLUMN_VALUE);
                MEANINGFUL := 1;
            when 5 =>
                if TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC) /= null then
                    -- enumeration column
                    TRANSLATE (1) := INTEGER (USER_COLUMN_TO_INTEGER16
                                                        (COLUMN_VALUE));
                    MEANINGFUL := 1;
                else
                    -- character string column
                    TRANSIT := USER_COLUMN_TO_TRANSIT (COLUMN_VALUE);
                    MEANINGFUL := (TRANSIT'LENGTH + 3) / 4;
                    TRANSLATE (1 .. MEANINGFUL) :=
                      CONVERSION.F77_STRING (TRANSIT);
                end if;

            when others =>  null;
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
               "internal error when identifying the column type in AND_MATCH");
                raise X_INTERNAL_ERROR;
        end case;

        if TABLE (IT).TABLE_DEFINITION.CONSTRAINTS (IC) /= null then
                -- a range constraint applies to the column;the
                -- value must be checked not to violate this range.
            UTILITIES.CHECK_VALUE (TRANSLATE (1), IT, IC);
        end if;

        LAST_NODE := TABLE (IT).TABLE_STATUS.SELECTION_CRITERION;

        while LAST_NODE.all.OTHER /= null loop
            -- loop until the last component of the list is found
            LAST_NODE := LAST_NODE.all.OTHER;
        end loop;

        -- append a new node to the list
        LAST_NODE.all.OTHER := TABLE_DESCRIPTOR.NEW_NODE;
        LAST_NODE.all.OTHER.all :=
                   (COLUMN_ID                        => IC,
                    KEY_MATCH                        => KEY_MATCH,
                    COLUMN_VALUE                     => TRANSLATE,
                    MEANINGFUL                       => MEANINGFUL,
                    USER_OPERATOR | TREE_OPERATOR     => AND_OPERATOR,
                    FIRST_CHILD | SECOND_CHILD | OTHER => null);
    end AND_MATCH;

    procedure FIND (TABLE_NAME : STRING) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          FIND                                        **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'unlocked'                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if FIND_STATUS_IS_NOT_CRITERION then                            **
--**            -- the FIND_STATUS component of TABLE_NAME in the TABLE **
--**            -- status array is not 'criterion' (and so is either    **
--**            -- 'dead' or 'find').                                   **
--**        raise X_INVALID_CRITERION;                                  **
--**    end if;                                                         **
--**                                                                    **
--**    END_SELECTION_CRITERION;                                        **
--**        -- convert all information stored in SELECTION_CRITERION    **
--**        -- into a more suitable form for applying the criterion to  **
--**        -- each candidate row (a binary tree is in fact created).   **
--**                                                                    **
--**    INITIALIZE_CURRENT_ROW;                                         **
--**        -- set the CURRENT_ROW component of TABLE_NAME in the TABLE **
--**        -- status array to 'init', after calling the SETGET access  **
--**        -- procedure with appropriate arguments in order to select  **
--**        -- the first row matching the criterion.                    **
--**        -- The algorithm  to  be  used  to  find  this  first  row  **
--**        -- can depend on whether the table is sorted or not.        **
--**                                                                    **
--**    UPDATE_FIND_STATUS;                                             **
--**        -- set the FIND_STATUS component of TABLE_NAME in the TABLE **
--**        -- status array to 'find'                                   **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME is the name of the table to which the criterion  will  **
--**  be applied.                                                       **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**    TABLE.FIND_STATUS                                               **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    TABLE.FIND_STATUS                                               **
--**    TABLE.CURRENT_ROW                                               **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_INVALID_CRITERION                                             **
--**    X_TABLE_NOT_LOCKED                                              **
--**                                                                    **
--************************************************************************
        RTN, IT                 : INTEGER;
        SAVE_FIRST_CHILD        : NODE_ACCESS;
        CURSOR, PREVIOUS_CURSOR : NODE_ACCESS;
        TIDD                    : TIDD_TYPE := (-1, 0, 0);

    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened and a table locked to use FIND");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the table index or raise X_TABLE_NOT_LOCKED
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        if TABLE (IT).TABLE_STATUS.FIND_STATUS /= CRITERION then
            -- the find-status is not 'criterion'; it means that the
            -- MATCH procedure has not been previously called, or the
            -- call has been followed by a call to FIND
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "MATCH must be called before calling FIND");
            raise X_INVALID_CRITERION;
        end if;

        -- set PREVIOUS_CURSOR to the first item of the SELECTION_CRITERION
        -- list, and set CURSOR to the following one (or to null if there
        -- is only one item in the list)
        PREVIOUS_CURSOR := TABLE (IT).TABLE_STATUS.SELECTION_CRITERION;
        CURSOR := PREVIOUS_CURSOR.all.OTHER;

        while CURSOR /= null loop
-- loop until the end of the list is found

            if CURSOR.all.USER_OPERATOR = AND_OPERATOR then
                -- the currently found item has been written by the
                -- AND_MATCH procedure; the current item and the preceding
                -- one must be joined to form a tree with a AND root, the
                -- too first branches being the current and preceding
                -- items, and this tree being inserted in the SELECTION_
                -- CRITERION list where the current and preceding were;
                -- for example, if the SELECTION_CRITERION list was :
                --
                --  C1 , or_C2  ,  or_and  ,  and_C5  ,  or_C6
                --                   / \
                --                  /   \
                --                C3     C4
                --
                -- where the current item is the fourth one, the list would
                -- then be changed to the following one :
                --
                --  C1 , or_C2  ,  or_and  ,  or_C6
                --                    / \
                --                   /   \
                --                and     C5
                --                / \
                --               /   \
                --             C3     C4
                --
                -- and the current item is left being the fourth one.
                PREVIOUS_CURSOR.all.TREE_OPERATOR := AND_OPERATOR;
                SAVE_FIRST_CHILD := PREVIOUS_CURSOR.all.FIRST_CHILD;
                PREVIOUS_CURSOR.all.FIRST_CHILD :=
                        TABLE_DESCRIPTOR.NEW_NODE;
                PREVIOUS_CURSOR.all.FIRST_CHILD.all :=
                           (COLUMN_ID     => PREVIOUS_CURSOR.all.COLUMN_ID,
                            KEY_MATCH     => PREVIOUS_CURSOR.all.KEY_MATCH,
                            COLUMN_VALUE  => PREVIOUS_CURSOR.all.COLUMN_VALUE,
                            MEANINGFUL    => PREVIOUS_CURSOR.all.MEANINGFUL,
                            USER_OPERATOR => OR_OPERATOR,
                            TREE_OPERATOR => PREVIOUS_CURSOR.all.TREE_OPERATOR,
                            FIRST_CHILD   => SAVE_FIRST_CHILD,
                            SECOND_CHILD  => PREVIOUS_CURSOR.all.SECOND_CHILD,
                            OTHER         => null);
                PREVIOUS_CURSOR.all.SECOND_CHILD := CURSOR;
                PREVIOUS_CURSOR.all.OTHER := CURSOR.all.OTHER;
                CURSOR.all.OTHER := null;
                CURSOR := PREVIOUS_CURSOR.all.OTHER;
            else
                -- if the current item has not been generated by a
                -- AND_MATCH call, advance to the next one
                PREVIOUS_CURSOR := CURSOR;
                CURSOR := CURSOR.all.OTHER;
            end if;
        end loop;


        -- let's do exactly the same thing but with the items which
        -- have been written by a OR_MATCH call; this order implies
        -- the precedence order between AND and OR operators.

        -- Only one item will remain in the list, which will be the
        -- root of the binary tree to be used for selection criterion;
        -- the list is then entirely changed into a tree.


        PREVIOUS_CURSOR := TABLE (IT).TABLE_STATUS.SELECTION_CRITERION;
        CURSOR := PREVIOUS_CURSOR.all.OTHER;

        while CURSOR /= null loop
            -- There is in fact no need to test the USER_OPERATOR since
            -- all remaining items(except the first one) have been written
            -- by using the OR_MATCH procedure

            PREVIOUS_CURSOR.all.TREE_OPERATOR := OR_OPERATOR;
            SAVE_FIRST_CHILD := PREVIOUS_CURSOR.all.FIRST_CHILD;
            PREVIOUS_CURSOR.all.FIRST_CHILD := TABLE_DESCRIPTOR.NEW_NODE;
            PREVIOUS_CURSOR.all.FIRST_CHILD.all :=
                       (COLUMN_ID     => PREVIOUS_CURSOR.all.COLUMN_ID,
                        KEY_MATCH     => PREVIOUS_CURSOR.all.KEY_MATCH,
                        COLUMN_VALUE  => PREVIOUS_CURSOR.all.COLUMN_VALUE,
                        MEANINGFUL    => PREVIOUS_CURSOR.all.MEANINGFUL,
                        USER_OPERATOR => OR_OPERATOR,
                        TREE_OPERATOR => PREVIOUS_CURSOR.all.TREE_OPERATOR,
                        FIRST_CHILD   => SAVE_FIRST_CHILD,
                        SECOND_CHILD  => PREVIOUS_CURSOR.all.SECOND_CHILD,
                        OTHER         => null);
            PREVIOUS_CURSOR.all.SECOND_CHILD := CURSOR;
            PREVIOUS_CURSOR.all.OTHER := CURSOR.all.OTHER;
            CURSOR.all.OTHER := null;
            CURSOR := PREVIOUS_CURSOR.all.OTHER;
        end loop;
        -- the first component of CURRENT_ROW set to -1 means that no
        -- row has been yet selected (this value is meaningful for
        -- the fortran access procedures and for the interface itself
        -- too)
        TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) := -1;

        -- preselect all rows of the table
        F77_CALLABLES.ADA_SETGET
           (TABLE (IT).TABLE_STATUS.DESCR, 3, TIDD, TIDD, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error in FIND");
            raise X_INTERNAL_ERROR;
        end if;

        -- set the find-status of the table to 'find'
        TABLE (IT).TABLE_STATUS.FIND_STATUS := FIND;
    end FIND;


    function FIND_NEXT (TABLE_NAME : STRING) return BOOLEAN is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          FIND_NEXT                                   **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'unlocked'                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if FIND_STATUS_IS_NOT_FIND then                                 **
--**            -- the FIND_STATUS component of TABLE_NAME in the TABLE **
--**            -- status array is not 'find' (and  so  is either       **
--**            -- 'dead' or 'criterion').                              **
--**        raise X_NO_PREVIOUS_FIND;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if LAST_ROW_WAS_ALREADY_FOUND then                              **
--**            -- this occurs when the CURRENT_ROW component of        **
--**            -- TABLE_NAME in the TABLE status array is 'end'        **
--**        raise X_NO_MORE_ROWS;                                       **
--**    end if;                                                         **
--**                                                                    **
--**    REPLACE_CURRENT_ROW_BY_THE_FOLLOWING_ONE;                 **
--**    if NO_MORE_ROWS then                                            **
--**            -- no more rows match the selection criterion           **
--**                                                                    **
--**        SET_CURRENT_ROW_TO_END (TABLE_NAME);                        **
--**            -- the CURRENT_ROW component of TABLE_NAME in the TABLE **
--**            -- status array is set to 'end'                         **
--**                                                                    **
--**        return FALSE;                                               **
--**    end if;                                                         **
--**                                                                    **
--**    while SELECTION_CRITERION_IS_FALSE_FOR_THE_CURRENT_ROW loop     **
--**            -- loop as long as the criterion selection remains FALSE**
--**                                                                    **
--**        REPLACE_CURRENT_ROW_BY_THE_FOLLOWING_ONE;                   **
--**        if NO_MORE_ROWS then                                        **
--**                -- no more rows match the selection criterion       **
--**                                                                    **
--**            SET_CURRENT_ROW_TO_END (TABLE_NAME);                    **
--**                -- the CURRENT_ROW component of TABLE_NAME in the   **
--**                -- TABLE status array is set to 'end'               **
--**                                                                    **
--**            return FALSE;                                           **
--**        end if;                                                     **
--**                                                                    **
--**    end loop;                                                       **
--**                                                                    **
--**        -- at least one row remains matching the selection criterion**
--**    return TRUE;                                                    **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of   the   table   to  be  processed.  **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**    TABLE.FIND_STATUS                                               **
--**    TABLE.SELECTION_CRITERION                                       **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    TABLE.CURRENT_ROW                                               **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_TABLE_NOT_LOCKED                                              **
--**    X_NO_MORE_ROWS                                                  **
--**    X_NO_PREVIOUS_FIND                                              **
--**                                                                    **
--************************************************************************
        IT, RTN : INTEGER;
    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened and a table locked to use FIND_NEXT");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the index of the table or raise X_TABLE_NOT_LOCKED
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        if TABLE (IT).TABLE_STATUS.FIND_STATUS /= FIND then
            -- the find-status is not 'find'; it means the FIND procedure
            -- has not been previously called
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "FIND must be called before using FIND_NEXT");
            raise X_NO_PREVIOUS_FIND;
        end if;

        if TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = 0 then
            -- the value zero means the end of the table has been already
            -- reached
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "FIND_NEXT must not be called again when the end of the table");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "has already been reached");
            raise X_NO_MORE_ROWS;
        end if;

        -- get the following row into the temporary row
        F77_CALLABLES.ADA_GETT
           (TABLE (IT).TABLE_STATUS.DESCR,
            TABLE (IT).TABLE_STATUS.CURRENT_ROW, RTN);      ------------------
                                                            --
        if TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = 0 then
            -- ou bien RTN = 1
            -- the current row was the last one         --
            return FALSE;                                   ------------------
        end if;

        while not UTILITIES.SELECTION_CRITERION_IS_TRUE
                     (IT, TABLE (IT).TABLE_STATUS.SELECTION_CRITERION) loop
            -- loop until the selection criterion is true

            -- get the following row into the temporary row
            F77_CALLABLES.ADA_GETT
               (TABLE (IT).TABLE_STATUS.DESCR,
                TABLE (IT).TABLE_STATUS.CURRENT_ROW, RTN);

            -- the current row was the last one             -------------
            if TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = 0 then
                -- ou bien
                return FALSE;                                   -- RTN = 1
            end if;
            -------------
        end loop;

        -- a row for which the selection criterion is true has been
        -- found
        return TRUE;
    end FIND_NEXT;
    function FIND_PREVIOUS (TABLE_NAME : STRING) return BOOLEAN is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          FIND_PREVIOUS                               **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'unlocked'                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if FIND_STATUS_IS_NOT_FIND then                                 **
--**            -- the FIND_STATUS component of TABLE_NAME in the TABLE **
--**            -- status array is not 'find' (and  so  is either       **
--**            -- 'dead' or 'criterion').                              **
--**        raise X_NO_PREVIOUS_FIND;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if LAST_ROW_WAS_ALREADY_FOUND then                              **
--**            -- this occurs when the CURRENT_ROW component of        **
--**            -- TABLE_NAME in the TABLE status array is 'end'        **
--**            -- or 'init'                                            **
--**        raise X_NO_MORE_ROWS;                                       **
--**    end if;                                                         **
--**                                                                    **
--**    REPLACE_CURRENT_ROW_BY_THE_PRECEDING_ONE;                       **
--**    if NO_MORE_ROWS then                                            **
--**            -- no more rows match the selection criterion           **
--**        SET_CURRENT_ROW_TO_END (TABLE_NAME);                        **
--**            -- the CURRENT_ROW component of TABLE_NAME in the TABLE **
--**            -- status array is set to 'end'                         **
--**                                                                    **
--**        return FALSE;                                               **
--**    end if;                                                         **
--**                                                                    **
--**    while SELECTION_CRITERION_IS_FALSE_FOR_THE_CURRENT_ROW loop     **
--**            -- loop as long as the criterion selection remains FALSE**
--**                                                                    **
--**        REPLACE_CURRENT_ROW_BY_THE_PRECEDING_ONE;                   **
--**        if NO_MORE_ROWS then                                        **
--**                -- no more rows match the selection criterion       **
--**            SET_CURRENT_ROW_TO_END (TABLE_NAME);                    **
--**                -- the CURRENT_ROW component of TABLE_NAME in the   **
--**                -- TABLE status array is set to 'end'               **
--**                                                                    **
--**            return FALSE;                                           **
--**        end if;                                                     **
--**                                                                    **
--**    end loop;                                                       **
--**                                                                    **
--**        -- at least one row remains matching the selection criterion**
--**    return TRUE;                                                    **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of   the   table   to  be  processed.  **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**    TABLE.FIND_STATUS                                               **
--**    TABLE.SELECTION_CRITERION                                       **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    TABLE.CURRENT_ROW                                               **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_TABLE_NOT_LOCKED                                              **
--**    X_NO_MORE_ROWS                                                  **
--**    X_NO_PREVIOUS_FIND                                              **
--**                                                                    **
--************************************************************************
        IT, RTN : INTEGER;
    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened to use FIND_PREVIOUS");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the index of the table or raise X_TABLE_NOT_LOCKED
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        if TABLE (IT).TABLE_STATUS.FIND_STATUS /= FIND then
            -- the find-status is not 'find'; it means the FIND procedure
            -- has not been previously called
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "FIND must be called before using FIND_PREVIOUS");
            raise X_NO_PREVIOUS_FIND;
        end if;

        if TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = -1 or
           TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = 0 then
            -- the value zero means the end of the table has been already
            -- reached, and the value -1 means that the first row has not
            -- been yet selected
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "FIND_PREVIOUS must not be called again when the beginning of");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "the table has already been reached");
            raise X_NO_MORE_ROWS;
        end if;

        -- get the preceding row into the temporary row
        F77_CALLABLES.ADA_DPREV
           (TABLE (IT).TABLE_STATUS.DESCR,
            TABLE (IT).TABLE_STATUS.CURRENT_ROW, RTN);

        if RTN /= 0 then
            -- the current row was the first one
            TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) := 0;
            return FALSE;
        end if;

        while not UTILITIES.SELECTION_CRITERION_IS_TRUE
                     (IT, TABLE (IT).TABLE_STATUS.SELECTION_CRITERION) loop
            -- loop until the selection criterion is true

            -- get the preceding row into the temporary row
            F77_CALLABLES.ADA_DPREV
               (TABLE (IT).TABLE_STATUS.DESCR,
                TABLE (IT).TABLE_STATUS.CURRENT_ROW, RTN);

            if RTN /= 0 then
                -- the current row was the first one
                TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) := 0;
                return FALSE;
            end if;
        end loop;

        -- a row for which the selection criterion is true has been
        -- found
        return TRUE;
    end FIND_PREVIOUS;

    function NEXT (TABLE_NAME : STRING) return BOOLEAN is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          NEXT                                        **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'unlocked'                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if LAST_ROW_WAS_ALREADY_FOUND then                              **
--**            -- this occurs when the CURRENT_ROW component of        **
--**            -- TABLE_NAME in the TABLE status array is 'end'        **
--**        raise X_NO_MORE_ROWS;                                       **
--**    end if;                                                         **
--**                                                                    **
--**    REPLACE_CURRENT_ROW_BY_THE_FOLLOWING_ONE;                       **
--**    if NO_MORE_ROWS then                                            **
--**            -- no more rows in the table                            **
--**        SET_CURRENT_ROW_TO_END (TABLE_NAME);                        **
--**            -- the CURRENT_ROW component of TABLE_NAME in the TABLE **
--**            -- status array is set to 'end'                         **
--**                                                                    **
--**        return FALSE;                                               **
--**    else                                                            **
--**            -- at least one row remains in the table                **
--**        return TRUE;                                                **
--**    end if;                                                         **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of   the   table   to  be  processed.  **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_USED                                              **
--**    TABLE.LOCK                                                      **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    TABLE.CURRENT_ROW                                               **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_TABLE_NOT_LOCKED                                              **
--**    X_NO_MORE_ROWS                                                  **
--**                                                                    **
--**                                                                    **
--************************************************************************
        IT, RTN : INTEGER;
    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened and a table locked to use NEXT");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the table index or raise X_TABLE_NOT_LOCKED
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        if TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = 0 then
            -- a null first component for CURRENT_ROW means the end of
            -- the table has already been reached
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "NEXT must not be called again when the end of the table");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "has already been reached");
            raise X_NO_MORE_ROWS;
        end if;

        -- get the following row, if any
        F77_CALLABLES.ADA_GETT
           (TABLE (IT).TABLE_STATUS.DESCR,
            TABLE (IT).TABLE_STATUS.CURRENT_ROW, RTN);      ------------------
                                                            --
        if TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = 0 then
            -- ou bien RTN = 1
            -- the current row was the last one         --
            return FALSE;                                   ------------------
        else
            -- the current row is now the one which follows the
            -- ancient current row
            return TRUE;
        end if;
    end NEXT;

    function PREVIOUS (TABLE_NAME : STRING) return BOOLEAN is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          PREVIOUS                                    **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'unlocked'                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if LAST_ROW_WAS_ALREADY_FOUND then                              **
--**            -- this occurs when the CURRENT_ROW component of        **
--**            -- TABLE_NAME in the TABLE status array is 'end' or     **
--**            -- 'init'                                               **
--**        raise X_NO_MORE_ROWS;                                       **
--**    end if;                                                         **
--**                                                                    **
--**    REPLACE_CURRENT_ROW_BY_THE_PRECEDING_ONE;                       **
--**    if NO_MORE_ROWS then                                            **
--**            -- no more rows in the table                            **
--**        SET_CURRENT_ROW_TO_END (TABLE_NAME);                        **
--**            -- the CURRENT_ROW component of TABLE_NAME in the TABLE **
--**            -- status array is set to 'end'                         **
--**                                                                    **
--**        return FALSE;                                               **
--**    else                                                            **
--**            -- at least one row remains in the table                **
--**        return TRUE;                                                **
--**    end if;                                                         **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of   the   table   to  be  processed.  **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    TABLE.CURRENT_ROW                                               **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_TABLE_NOT_LOCKED                                              **
--**    X_NO_MORE_ROWS                                                  **
--**                                                                    **
--************************************************************************
        IT, RTN : INTEGER;
    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened and a table locked to use PREVIOUS");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the table index or raise X_TABLE_NOT_LOCKED
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        if TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = -1 or
           TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = 0 then
            -- the first component of CURRENT_ROW set to -1 means that
            -- the first row has not been selected yet; 0 means there
            -- is no current row.
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "PREVIOUS must not be called again when the beginning of the");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "table has already been reached");
            raise X_NO_MORE_ROWS;
        end if;

        -- select the previous row
        F77_CALLABLES.ADA_DPREV
           (TALE_STATUS.DESCR,
            TABLE (IT).TABLE_STATUS.CURRENT_ROW, RTN);

        if RTN /= 0 then
            -- the current row was the first one, and thus no preceding
            -- row has been found
            TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) := 0;
            return FALSE;
        else
            -- the current row isnow the row which preceded the ancient
            -- current row
            return TRUE;
        end if;
    end PREVIOUS;

    procedure GET_COLUMN (TABLE_NAME  : STRING;
                          COLUMN_NAME : STRING;
                          ITEM        : out USER_COLUMN) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          GET_COLUMN                                  **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'unlocked'                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if THERE_IS_NO_CURRENT_ROW then                                 **
--**            -- the CURRENT_ROW component of TABLE_NAME in the TABLE **
--**            -- status array is 'init' or 'end'                      **
--**        raise X_NO_CURRENT_ROW;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_NAME_DOES_NOT_EXIST then                              **
--**            -- COLUMN_NAME is not the name of one of the columns    **
--**            -- of the TABLE_NAME table                              **
--**        raise X_INVALID_COLUMN;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_TYPE_DOES_NOT_MATCH_INSTANTIATION_TYPE then           **
--**            -- information known by DAMES about the type of the     **
--**            -- COLUMN_NAME column does not match the USER_COLUMN    **
--**            -- type, which is defined when instantiating the        **
--**            -- generic GET_COLUMN procedure.                        **
--**        raise X_INVALID_COLUMN;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_TYPE_IS_RECORD then                                   **
--**                                                                    **
--**        for COMPONENT in COLUMN_COMPONENTS loop                     **
--**                                                                    **
--**            GET_VALUE_FROM_DATABASE (COMPONENT);                    **
--**                -- the value is read in a fortran77 format and is   **
--**                -- contained in an array of 32-bit integers.        **
--**                                                                    **
--**            TRANSLATE_FROM_FORTRAN77_TO_ADA;                        **
--**                -- the value is translated from fortran77 format    **
--**                -- to ada format, and is stored in an array of      **
--**                -- 16-bit integers.                                 **
--**                                                                    **
--**            if COLUMN_TYPE_DOES_NOT_MATCH_COLUMN_VALUE then         **
--**                -- the type USER_COLUMN is then correct, but the    **
--**                -- value read from the table is not valid for the   **
--**                -- COMPONENT column type as described in the        **
--**                -- database                                         **
--**                                                                    **
--**            INSERT_VALUE_INTO_ITEM (COMPONENT);                     **
--**        end loop;                                                   **
--**    else    -- the COLUMN_NAME column is of a scalar type           **
--**                                                                    **
--**        GET_VALUE_FROM_DATABASE (COLUMN_NAME);                      **
--**            -- the value is read in a fortran77 format and is       **
--**            -- contained in an array of 32-bit integers.            **
--**                                                                    **
--**        TRANSLATE_FROM_FORTRAN77_TO_ADA;                            **
--**            -- the value is translated from fortran77 format        **
--**            -- to ada format, and is stored in an array of          **
--**            -- 16-bit integers.                                     **
--**                                                                    **
--**        if COLUMN_TYPE_DOES_NOT_MATCH_COLUMN_VALUE then             **
--**            -- the type USER_COLUMN is then correct, but the        **
--**            -- value read from the table is not valid for the       **
--**            -- COLUMN_NAME column type as described in the          **
--**            -- database                                             **
--**                                                                    **
--**        COPY_VALUE_INTO_ITEM (COLUMN_NAME);                         **
--**    end if;                                                         **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME : name of the table to be read.                        **
--**  COLUMN_NAME  :  name  of  the  column  to  be  read;  its   type  **
--**  must be USER_COLUMN.                                              **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**  ITEM  :  is the contents  of  the  column  COLUMN_NAME  of  the   **
--**           current row.                                             **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_TABLE_NOT_LOCKED                                              **
--**    X_INVALID_VALUE                                                 **
--**    X_INVALID_COLUMN                                                **
--**    X_NO_CURRENT_ROW                                                **
--**                                                                    **
--**                                                                    **
--************************************************************************
        USEFUL, IT, IC  : INTEGER;
        IS_RECORD       : BOOLEAN;
        LENR, FTYP, RTN : INTEGER;
        CHECKED         : INTEGER;
        RECORD_NAME     : STRING (1 .. NAME_LENGTH);
        STRING_ITEM : STRING (1 .. MAX_STRING);
        COMPONENT16 : INTEGER16_ARRAY_TYPE (1 .. MAX_STRING);
        COMPONENT   : INTEGER_ARRAY_TYPE (1 .. (3 + MAX_STRING) / 4);
        ITEM_COPY   : USER_COLUMN;
        TEMP        : CONVERSION.TWO_WORDS;

        procedure ADD_COMPONENT_TO_USER_COLUMN is new
                CONVERSION.ADD_COMPONENT (USER_COLUMN);

    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened and a table locked to use GET_COLUMN");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the table index or raise X_TABLE_NOT_LOCKED
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        if TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = -1 or
           TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = 0 then
            -- there is no current row
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A row must be selected by successfully using NEXT, PREVIOUS,");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "FIND_NEXT or FIND_PREVIOUS before using GET_COLUMN");
            raise X_NO_CURRENT_ROW;
        end if;

        -- get in IC the index of the COLUMN_NAME column, and in
        -- IS_RECORD, put 'false' if COLUMN_NAME is a scalar column
        -- and 'true' otherwise; X_INVALID_COLUMN is raised if no
        -- scalar nor record column is found with this name
        UTILITIES.COLUMN (IT, COLUMN_NAME, IC, IS_RECORD);

        if USER_COLUMN'SIZE /=
           UTILITIES.RECORD_BIT_SIZE (IT, IC, IS_RECORD) then
            -- the size of the actual parameter USER_COLUMN is not
            -- this requested
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "The size of the Ada type used to instantiate GET_COLUMN");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "does not correspond to the size of the " & COLUMN_NAME &
            " column");
            raise X_INVALID_COLUMN;
        end if;

        if IS_RECORD then
            -- the column to be read is a record column

            -- get the name of its column
            RECORD_NAME := TABLE (IT).TABLE_DEFINITION.IN_RECORD (IC);

            while TABLE (IT).TABLE_DEFINITION.IN_RECORD (IC) = RECORD_NAME loop
                -- loop for each of the components of the record column
                COMPONENT := (others => 0);

                -- get into COMPONENT the actual value of the ICth column
                F77_CALLABLES.ADA_GETA
                   (TABLE (IT).TABLE_STATUS.DESCR,
                    TABLE (IT).TABLE_DEFINITION.COLUMN_INDEX (IC), COMPONENT,
                    LENR, FTYP, RTN);
                if RTN /= 0 then
                    UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                    "internal error in GET_COLUMN");
                    raise X_INTERNAL_ERROR;
                end if;

                if TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC) /= null then
                    -- IC is of an enumeration type

                  begin
                    CHECKED := CONVERSION.ADA_ENUM (COMPONENT (1 ..
                          (TABLE(IT).TABLE_DEFINITION.COLUMN_LENGTH(IC) + 3)/4)
                             ,TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC));
                  exception
                    when X_INTERNAL_ERROR =>
                        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                        "The value read from the database does not match "
                        & COLUMN_NAME & " type");
                        raise X_INVALID_VALUE;
                  end;

                    COMPONENT16 (1) := INTEGER16 (CHECKED);

                elsif TABLE (IT).TABLE_DEFINITION.COLUMN_TYPES (IC) = 5 then
                    -- column of a character string type
                    USEFUL := (TABLE (IT).TABLE_DEFINITION.COLUMN_LENGTH (IC) +
                           3) / 4;
                    STRING_ITEM (1 .. 4 * USEFUL) :=
                      CONVERSION.ADA_STRING (COMPONENT (1 .. USEFUL), FALSE);
                    for I in 1 .. 4 * USEFUL loop
                        COMPONENT16 (I) := CHARACTER'POS (STRING_ITEM (I));
                    end loop;
                else
                    -- INTEGER or FLOAT type
                    TEMP := CONVERSION.INTEGER_TO_TWO_WORDS (COMPONENT (1));
                    COMPONENT16 (1) := TEMP.WORD_1;
                    COMPONENT16 (2) := TEMP.WORD_2;
                    CHECKED := COMPONENT (1);
                end if;

                if TABLE (IT).TABLE_DEFINITION.CONSTRAINTS (IC) /= null then
                        -- a range constraint applies to the column;the
                        -- value must be checked not to violate this range.
                    UTILITIES.CHECK_VALUE (CHECKED, IT, IC);
                end if;

                -- write the value of COMPONENT16 into ITEM_COPY
                ADD_COMPONENT_TO_USER_COLUMN (ITEM_COPY, COMPONENT16, IT, IC,
                                                    CONVERSION.RECORD_COLUMN);

                -- jump to the next column
                exit when IC = TABLE (IT).TABLE_DEFINITION.COLUMN_NUMBER;
                IC := IC + 1;
            end loop;
        else
            -- the column to be read is a scalar column

            -- first get into COMPONENT the actual value
            COMPONENT := (others => 0);
            F77_CALLABLES.ADA_GETA
               (TABLE (IT).TABLE_STATUS.DESCR,
                TABLE (IT).TABLE_DEFINITION.COLUMN_INDEX (IC), COMPONENT,
                LENR, FTYP, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error in GET_COLUMN");
                raise X_INTERNAL_ERROR;
            end if;

            if TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC) /= null then
                -- IC is of an enumeration type

              begin
                CHECKED := CONVERSION.ADA_ENUM (COMPONENT (1 ..
                      (TABLE(IT).TABLE_DEFINITION.COLUMN_LENGTH(IC) + 3)/4)
                         ,TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC));
              exception
                    when X_INTERNAL_ERROR =>
                        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                        "The value read from the database does not match "
                        & COLUMN_NAME & " type");
                        raise X_INVALID_VALUE;
              end;

                COMPONENT16 (1) := INTEGER16 (CHECKED);

            elsif TABLE (IT).TABLE_DEFINITION.COLUMN_TYPES (IC) = 5 then
                -- column of a character string type
                USEFUL := (TABLE (IT).TABLE_DEFINITION.COLUMN_LENGTH (IC) +
                       3) / 4;
                STRING_ITEM (1 .. 4 * USEFUL) :=
                      CONVERSION.ADA_STRING (COMPONENT (1 .. USEFUL), FALSE);
                for I in 1 .. 4 * USEFUL loop
                    COMPONENT16 (I) := CHARACTER'POS (STRING_ITEM (I));
                end loop;
            else
                -- INTEGER or FLOAT type
                TEMP := CONVERSION.INTEGER_TO_TWO_WORDS (COMPONENT (1));
                COMPONENT16 (1) := TEMP.WORD_1;
                COMPONENT16 (2) := TEMP.WORD_2;
                CHECKED := COMPONENT (1);
            end if;

            if TABLE (IT).TABLE_DEFINITION.CONSTRAINTS (IC) /= null then
                    -- a range constraint applies to the column;the
                    -- value must be checked not to violate this range.
                UTILITIES.CHECK_VALUE (CHECKED, IT, IC);
            end if;

            -- write the value of COMPONENT16 into ITEM_COPY
            ADD_COMPONENT_TO_USER_COLUMN (ITEM_COPY, COMPONENT16, IT, IC,
                                                CONVERSION.SCALAR_COLUMN);

        end if;

        ITEM := ITEM_COPY;
    exception
        when CONSTRAINT_ERROR =>
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "The value read from the database does not match " & COLUMN_NAME
            & " type");
            raise X_INVALID_VALUE;
        -- CONSTRAINT_ERROR is raised in UNCHECKED_CONVERSION if the
        -- value of a column does not match its type

    end GET_COLUMN;

    procedure GET_ROW (TABLE_NAME : STRING; ITEM : out USER_ROW) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          GET_ROW                                     **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'unlocked'                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if THERE_IS_NO_CURRENT_ROW then                                 **
--**            -- the CURRENT_ROW component of TABLE_NAME in the TABLE **
--**            -- status array is 'init' or 'end'                      **
--**        raise X_NO_CURRENT_ROW;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_TYPE_DOES_NOT_MATCH_INSTANTIATION_TYPE then           **
--**            -- information known by DAMES about the type of the     **
--**            -- columns of the table does not match the USER_ROW     **
--**            -- type, which is defined when instantiating the        **
--**            -- generic GET_ROW procedure.                           **
--**        raise X_INVALID_COLUMN;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    for COMPONENT in ROW_COMPONENTS loop                            **
--**                                                                    **
--**        GET_VALUE_FROM_DATABASE (COMPONENT);                        **
--**            -- the value is read in a fortran77 format and is       **
--**            -- contained in an array of 32-bit integers.            **
--**                                                                    **
--**        TRANSLATE_FROM_FORTRAN77_TO_ADA;                            **
--**            -- the value is translated from fortran77 format        **
--**            -- to ada format, and is stored  in  an  array  of      **
--**            -- 16-bit integers.                                     **
--**                                                                    **
--**        if COLUMN_TYPE_DOES_NOT_MATCH_COLUMN_VALUE then             **
--**            -- the type USER_ROW is then correct, but the           **
--**            -- value read from the table is not valid for the       **
--**            -- COMPONENT column type as described in the            **
--**            -- database                                             **
--**                                                                    **
--**        INSERT_VALUE_INTO_ITEM (COMPONENT);                         **
--**    end loop;                                                       **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME : name of the table to be read.                        **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**  ITEM  :  is the contents of the current row.                      **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_INVALID_VALUE                                                 **
--**    X_INVALID_COLUMN                                                **
--**    X_TABLE_NOT_LOCKED                                              **
--**    X_NO_CURRENT_ROW                                                **
--**                                                                    **
--************************************************************************
        USEFUL, IT, IC  : INTEGER;
        LENR, FTYP, RTN : INTEGER;
        CHECKED         : INTEGER;
        ITEM_COPY       : USER_ROW;
        STRING_ITEM : STRING (1 .. MAX_STRING);
        COMPONENT16 : INTEGER16_ARRAY_TYPE (1 .. MAX_STRING);
        COMPONENT   : INTEGER_ARRAY_TYPE (1 .. (3 + MAX_STRING) / 4);
        TEMP        : CONVERSION.TWO_WORDS;

        procedure ADD_COMPONENT_TO_USER_ROW is new
                CONVERSION.ADD_COMPONENT (USER_ROW);
    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened and a table locked to use GET_ROW");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the index of the table or raise X_TABLE_NOT_LOCKED
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        if TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = -1 or
           TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = 0 then
            -- there is no currently selected row
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A row must be selected by successfully using NEXT, PREVIOUS,");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "FIND_NEXT or FIND_PREVIOUS before using GET_ROW");
            raise X_NO_CURRENT_ROW;
        end if;

        if USER_ROW'SIZE /= UTILITIES.TABLE_SIZE (IT) then
            -- the size of USER_ROW does not match the requested size
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "The size of the Ada type used to instantiate GET_ROW");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "does not correspond to the size of the " & TABLE_NAME &
            " columns");
            raise X_INVALID_COLUMN;
        end if;

        IC := 1;

        while IC <= TABLE (IT).TABLE_DEFINITION.COLUMN_NUMBER loop
            -- loop for each column of the table

            COMPONENT := (others => 0);

            -- get the actual value of the ICth column into COMPONENT
            F77_CALLABLES.ADA_GETA
               (TABLE (IT).TABLE_STATUS.DESCR,
                TABLE (IT).TABLE_DEFINITION.COLUMN_INDEX (IC), COMPONENT,
                LENR, FTYP, RTN);
                if RTN /= 0 then
                    UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                    "internal error in GET_ROW");
                    raise X_INTERNAL_ERROR;
                end if;
            if TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC) /= null then
                -- column of an enumeration type

              begin
                CHECKED := CONVERSION.ADA_ENUM (COMPONENT (1 ..
                          (TABLE(IT).TABLE_DEFINITION.COLUMN_LENGTH(IC) + 3)/4)
                             ,TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC));
              exception
                  when X_INTERNAL_ERROR =>
                        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                        "The value read from the database does not match the table type");
                        raise X_INVALID_VALUE;
              end;

                COMPONENT16 (1) := INTEGER16 (CHECKED);

            elsif TABLE (IT).TABLE_DEFINITION.COLUMN_TYPES (IC) = 5 then
                -- column of a character string type
                USEFUL := (TABLE (IT).TABLE_DEFINITION.COLUMN_LENGTH (IC) +
                           3) / 4;
                STRING_ITEM (1 .. 4 * USEFUL) :=
                  CONVERSION.ADA_STRING (COMPONENT (1 .. USEFUL), FALSE);
                for I in 1 .. 4 * USEFUL loop
                    COMPONENT16 (I) := CHARACTER'POS (STRING_ITEM (I));
                end loop;
            else
                -- INTEGER or FLOAT type
                TEMP := CONVERSION.INTEGER_TO_TWO_WORDS (COMPONENT (1));
                COMPONENT16 (1) := TEMP.WORD_1;
                COMPONENT16 (2) := TEMP.WORD_2;
                CHECKED := COMPONENT (1);
            end if;

            if TABLE (IT).TABLE_DEFINITION.CONSTRAINTS (IC) /= null then
                    -- a range constraint applies to the column;the
                    -- value must be checked not to violate this range.
                UTILITIES.CHECK_VALUE (CHECKED, IT, IC);
            end if;

            -- write bit by bit COMPONENT16 into a part of ITEM_COPY
            ADD_COMPONENT_TO_USER_ROW (ITEM_COPY, COMPONENT16, IT, IC,
                                                CONVERSION.WHOLE_TABLE);
            IC := IC + 1;
        end loop;

        ITEM := ITEM_COPY;

    exception
        when CONSTRAINT_ERROR =>
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "The values read from the database do not match " & TABLE_NAME
            & " columns types");
            raise X_INVALID_VALUE;
        -- CONSTRAINT_ERROR is raised in UNCHECKED_CONVERSION if the
        -- value of a column does not match its type

    end GET_ROW;
    procedure BUILD_COLUMN (TABLE_NAME  : STRING;
                            COLUMN_NAME : STRING;
                            ITEM        : USER_COLUMN) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          BUILD_COLUMN                                **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'unlocked'                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_LOCKED_IN_SHARED_MODE then                     **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'shared'                                    **
--**        raise X_SHARED_MODE_LOCK;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_NAME_DOES_NOT_EXIST then                              **
--**            -- COLUMN_NAME is not the name of one of the columns    **
--**            -- of the TABLE_NAME table                              **
--**        raise X_INVALID_COLUMN;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_TYPE_DOES_NOT_MATCH_INSTANTIATION_TYPE then           **
--**            -- information known by DAMES about the type of the     **
--**            -- COLUMN_NAME column does not match the USER_COLUMN    **
--**            -- type, which is defined when instantiating the        **
--**            -- generic BUILD_COLUMN procedure.                      **
--**        raise X_INVALID_COLUMN;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_TYPE_IS_RECORD then                                   **
--**                                                                    **
--**        for COMPONENT in COLUMN_COMPONENTS loop                     **
--**                                                                    **
--**            EXTRACT_VALUE_FROM_ITEM (COMPONENT);                    **
--**                -- the extracted value is stored  in  an  array  of **
--**                -- 16-bit integers.                                 **
--**                                                                    **
--**            TRANSLATE_FROM_ADA_TO_FORTRAN77_FORMAT;                 **
--**                -- the value is translated from ada  format  to     **
--**                -- fortran77 format, and is stored  in  an array of **
--**                -- 32-bit integers.                                 **
--**                                                                    **
--**            if COLUMN_TYPE_DOES_NOT_MATCH_COLUMN_VALUE then         **
--**                -- the type USER_COLUMN  is  correct, but the value **
--**                -- to be written into the table is not valid for the**
--**                -- COMPONENT column type as described in the        **
--**                -- database                                         **
--**                                                                    **
--**            PUT_VALUE_INTO_DATABASE (COMPONENT);                    **
--**        end loop;                                                   **
--**    else    -- the COLUMN_NAME column is of a scalar type           **
--**                                                                    **
--**        COPY_VALUE_FROM_ITEM (COLUMN_NAME);                         **
--**            -- the value of ITEM is copied into an array of         **
--**            -- 16-bit integers.                                     **
--**                                                                    **
--**        TRANSLATE_FROM_ADA_TO_FORTRAN77;                            **
--**            -- the  value  is  translated  from  ada  format  to    **
--**            -- fortran77 format, and is stored in an array of       **
--**            -- 32-bit integers.                                     **
--**                                                                    **
--**        if COLUMN_TYPE_DOES_NOT_MATCH_COLUMN_VALUE then             **
--**            -- the type USER_COLUMN is then correct, but the value  **
--**            -- to be written into the table is not valid for the    **
--**            -- COLUMN_NAME column type as described in the          **
--**            -- database                                             **
--**                                                                    **
--**        PUT_VALUE_INTO_DATABASE (COLUMN_NAME);                      **
--**                                                                    **
--**    end if;                                                         **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME : name of the table to be processed.                   **
--**  COLUMN_NAME : name  of  the  column  in  the temporary which will **
--**  be written; its type must be USER_COLUMN.                         **
--**  ITEM   :   value   to   be  copied  into  the   temporary   row.  **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_TABLE_NOT_LOCKED                                              **
--**    X_INVALID_COLUMN                                                **
--**    X_INVALID_VALUE                                                 **
--**    X_SHARED_MODE_LOCK                                              **
--**                                                                    **
--************************************************************************
        USEFUL, IT, IC : INTEGER;
        RTN            : INTEGER;
        CHECKED        : INTEGER;
        IS_RECORD      : BOOLEAN;
        RECORD_NAME    : STRING (1 .. NAME_LENGTH);
        STRING_ITEM : STRING (1 .. MAX_STRING);
        COMPONENT   : INTEGER_ARRAY_TYPE (1 .. (3 + MAX_STRING) / 4);
        COMPONENT16 : INTEGER16_ARRAY_TYPE (1 .. MAX_STRING);
        TEMP        : CONVERSION.TWO_WORDS;

        procedure GET_COMPONENT_FROM_USER_COLUMN is new
                            CONVERSION.GET_COMPONENT (USER_COLUMN);
    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened to use BUILD_COLUMN");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the index of the table or raise X_TABLE_NOT_LOCKED
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        if TABLE (IT).TABLE_STATUS.CURRENT_LOCK = SHARED then
            -- the table should be locked in exclusive mode
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "BUILD_COLUMN cannot be applied to a table locked in shared");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "mode; it must be in exclusive mode");
            raise X_SHARED_MODE_LOCK;
        end if;

        -- get the index of COLUMN_NAME into IC and set IS_RECORD to
        -- 'false' if a scalar column has been found, and 'true' if this
        -- is only a record column.
        -- X_INVALID_COLUMN is raised if no column has been found with the
        -- name COLUMN_NAME
        UTILITIES.COLUMN (IT, COLUMN_NAME, IC, IS_RECORD);

        if USER_COLUMN'SIZE /=
           UTILITIES.RECORD_BIT_SIZE (IT, IC, IS_RECORD) then
            -- the size of USER_COLUMN does not match the requested size
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "The size of the Ada type used to instantiate BUILD_COLUMN");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "does not correspond to the size of the " & COLUMN_NAME &
            " column");
            raise X_INVALID_COLUMN;
        end if;

        if IS_RECORD then
            -- COLUMN_NAME is a record column
            RECORD_NAME := TABLE (IT).TABLE_DEFINITION.IN_RECORD (IC);

            while TABLE (IT).TABLE_DEFINITION.IN_RECORD (IC) = RECORD_NAME loop
                -- loop for each component of the record column

                COMPONENT := (others => 0);
                -- get the actual value of the ICth component of ITEM
                -- into COMPONENT16
                GET_COMPONENT_FROM_USER_COLUMN (ITEM, COMPONENT16, IT, IC,
                                                   CONVERSION.RECORD_COLUMN);

                if TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC) /= null then
                        -- the ICth column is of an enumeration type
                    COMPONENT (1 .. (3 + IMAGE_SZ) / 4) :=
                      CONVERSION.F77_ENUM
                         (INTEGER (COMPONENT16 (1)),
                        TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC));
                    CHECKED := INTEGER (COMPONENT16 (1));

                elsif TABLE (IT).TABLE_DEFINITION.COLUMN_TYPES (IC) = 5 then
                        -- the ICth column is of a character string
                    USEFUL := TABLE (IT).TABLE_DEFINITION.COLUMN_LENGTH(IC);
                    for I in 1 .. USEFUL loop
                        STRING_ITEM (I) := CHARACTER'VAL (COMPONENT16 (I));
                    end loop;
                    COMPONENT (1 .. (3 + USEFUL) / 4) :=
                      CONVERSION.F77_STRING (STRING_ITEM (1 .. USEFUL));
                else
                        -- the ICth column is of an INTEGER or of a FLOAT type
                    TEMP.WORD_1 := COMPONENT16 (1);
                    TEMP.WORD_2 := COMPONENT16 (2);
                    COMPONENT (1) := CONVERSION.TWO_WORDS_TO_INTEGER (TEMP);
                    CHECKED := COMPONENT (1);
                end if;

                if TABLE (IT).TABLE_DEFINITION.CONSTRAINTS (IC) /= null then
                        -- a range constraint applies to the column;the
                        -- value must be checked not to violate this range.
                    UTILITIES.CHECK_VALUE (CHECKED, IT, IC);
                end if;

                -- write COMPONENT into the table
                F77_CALLABLES.ADA_PUTA
                   (TABLE (IT).TABLE_STATUS.DESCR,
                    TABLE (IT).TABLE_DEFINITION.COLUMN_INDEX (IC), COMPONENT,
                    -1, RTN);
                if RTN /= 0 then
                    UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                    "internal error in BUILD_COLUMN");
                    raise X_INTERNAL_ERROR;
                end if;

                exit when IC = TABLE (IT).TABLE_DEFINITION.COLUMN_NUMBER;
                IC := IC + 1;
            end loop;
        else
                -- the column to be written is a scalar one

                COMPONENT := (others => 0);

                -- copy the actual value of ITEM into COMPONENT16
                GET_COMPONENT_FROM_USER_COLUMN (ITEM, COMPONENT16, IT, IC,
                                                   CONVERSION.SCALAR_COLUMN);
            if TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC) /= null then
                    -- the ICth column is of an enumeration type
                COMPONENT (1 .. (3 + IMAGE_SZ) / 4) :=
                  CONVERSION.F77_ENUM
                     (INTEGER (COMPONENT16 (1)),
                TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC));
                CHECKED := INTEGER (COMPONENT16 (1));

            elsif TABLE (IT).TABLE_DEFINITION.COLUMN_TYPES (IC) = 5 then
                    -- the ICth column is of a character string
                USEFUL := TABLE (IT).TABLE_DEFINITION.COLUMN_LENGTH(IC);
                for I in 1 .. USEFUL loop
                    STRING_ITEM (I) := CHARACTER'VAL (COMPONENT16 (I));
                end loop;
                COMPONENT (1 .. (3 + USEFUL) / 4) :=
                  CONVERSION.F77_STRING (STRING_ITEM (1 .. USEFUL));
            else
                    -- the ICth column is of an INTEGER or of a FLOAT type
                TEMP.WORD_1 := COMPONENT16 (1);
                TEMP.WORD_2 := COMPONENT16 (2);
                COMPONENT (1) := CONVERSION.TWO_WORDS_TO_INTEGER (TEMP);
                CHECKED := COMPONENT (1);
            end if;

            if TABLE (IT).TABLE_DEFINITION.CONSTRAINTS (IC) /= null then
                    -- a range constraint applies to the column;the
                    -- value must be checked not to violate this range.
                UTILITIES.CHECK_VALUE (CHECKED, IT, IC);
            end if;

            -- put COMPONENT into the table
            F77_CALLABLES.ADA_PUTA
               (TABLE (IT).TABLE_STATUS.DESCR,
                TABLE (IT).TABLE_DEFINITION.COLUMN_INDEX (IC), COMPONENT, -1,
                RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error in BUILD_COLUMN");
                raise X_INTERNAL_ERROR;
            end if;
        end if;

    end BUILD_COLUMN;
    procedure BUILD_ROW (TABLE_NAME : STRING; ITEM : USER_ROW) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          BUILD_ROW                                   **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'unlocked'                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_LOCKED_IN_SHARED_MODE then                     **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'shared'                                    **
--**        raise X_SHARED_MODE_LOCK;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if COLUMN_TYPE_DOES_NOT_MATCH_INSTANTIATION_TYPE then           **
--**            -- information known by DAMES about the types of the    **
--**            -- columns of the table does not match the USER_ROW     **
--**            -- type, which is defined when instantiating the        **
--**            -- generic BUILD_ROW procedure.                         **
--**        raise X_INVALID_COLUMN;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    for COMPONENT in ROW_COMPONENTS loop                            **
--**                                                                    **
--**        EXTRACT_VALUE_FROM_ITEM (COMPONENT);                        **
--**            -- the extracted value is stored in an array of 16-bit  **
--**            -- integers.                                            **
--**                                                                    **
--**        TRANSLATE_FROM_ADA_TO_FORTRAN77;                            **
--**            -- the value  is  translated  from  ada  format  to     **
--**            -- fortran77 format, and is stored  in  an  array of    **
--**            -- 32-bit integers.                                     **
--**                                                                    **
--**        if COLUMN_TYPE_DOES_NOT_MATCH_COLUMN_VALUE then             **
--**            -- the type USER_ROW is then correct, but the           **
--**            -- value read from the table is not valid for the       **
--**            -- COMPONENT column type as described in the            **
--**            -- database                                             **
--**                                                                    **
--**        PUT_VALUE_INTO_DATABASE (COMPONENT);                        **
--**                                                                    **
--**    end loop;                                                       **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME : name of the table to be processed.                   **
--**  ITEM   :   value   to   be  copied  into  the   temporary   row.  **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_TABLE_NOT_LOCKED                                              **
--**    X_INVALID_VALUE                                                 **
--**    X_INVALID_COLUMN                                                **
--**    X_SHARED_MODE_LOCK                                              **
--**                                                                    **
--************************************************************************
        USEFUL, IT, IC : INTEGER;
        RTN            : INTEGER;
        CHECKED        : INTEGER;
        STRING_ITEM : STRING (1 .. MAX_STRING);
        COMPONENT   : INTEGER_ARRAY_TYPE (1 .. (3 + MAX_STRING) / 4);
        COMPONENT16 : INTEGER16_ARRAY_TYPE (1 .. MAX_STRING);
        TEMP        : CONVERSION.TWO_WORDS;

        procedure GET_COMPONENT_FROM_USER_ROW is new
                            CONVERSION.GET_COMPONENT (USER_ROW);
    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened and a table locked to use BUILD_ROW");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the index of TABLE_NAME or raise X_TABLE_NOT_LOCKED
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        if TABLE (IT).TABLE_STATUS.CURRENT_LOCK = SHARED then
            -- the table should have been locked in exclusive mode
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "BUILD_ROW cannot be applied to a table locked in shared");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "mode; it must be in exclusive mode");
            raise X_SHARED_MODE_LOCK;
        end if;

        if USER_ROW'SIZE /= UTILITIES.TABLE_SIZE (IT) then
            -- the USER_ROW size does not match the requested size
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "The size of the Ada type used to instantiate BUILD_ROW");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "does not correspond to the size of the " & TABLE_NAME &
            " columns");
            raise X_INVALID_COLUMN;
        end if;

        IC := 1;

        while IC <= TABLE (IT).TABLE_DEFINITION.COLUMN_NUMBER loop
            -- loop for each column of the table

            COMPONENT := (others => 0);

            -- get into COMPONENT16 the ICth component of the ITEM
            -- record value
            GET_COMPONENT_FROM_USER_ROW (ITEM, COMPONENT16, IT, IC,
                                                CONVERSION.WHOLE_TABLE);

            if TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC) /= null then
                -- the ICth column is of an enumeration type
                COMPONENT (1 .. (3 + IMAGE_SZ) / 4) :=
                  CONVERSION.F77_ENUM
                     (INTEGER (COMPONENT16 (1)),
                      TABLE (IT).TABLE_DEFINITION.ENUM_TYPES (IC));
                CHECKED := INTEGER (COMPONENT16 (1));
            elsif TABLE (IT).TABLE_DEFINITION.COLUMN_TYPES (IC) = 5 then
                -- the ICth column is of a character string
                USEFUL := TABLE (IT).TABLE_DEFINITION.COLUMN_LENGTH (IC);
                for I in 1 .. USEFUL loop
                    STRING_ITEM (I) := CHARACTER'VAL (COMPONENT16 (I));
                end loop;
                COMPONENT (1 .. (3 + USEFUL) / 4) :=
                  CONVERSION.F77_STRING (STRING_ITEM (1 .. USEFUL));
            else
                -- the ICth column is of an INTEGER or of a FLOAT type
                TEMP.WORD_1 := COMPONENT16 (1);
                TEMP.WORD_2 := COMPONENT16 (2);
                COMPONENT (1) := CONVERSION.TWO_WORDS_TO_INTEGER (TEMP);
                CHECKED := COMPONENT (1);
            end if;

            if TABLE (IT).TABLE_DEFINITION.CONSTRAINTS (IC) /= null then
                    -- a range constraint applies to the column;the
                    -- value must be checked not to violate this range.
                UTILITIES.CHECK_VALUE (CHECKED, IT, IC);
            end if;

            -- put COMPONENT into the corresponding place in the current
            -- row
            F77_CALLABLES.ADA_PUTA
               (TABLE (IT).TABLE_STATUS.DESCR,
                TABLE (IT).TABLE_DEFINITION.COLUMN_INDEX (IC), COMPONENT, -1,
                RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error in BUILD_ROW");
                raise X_INTERNAL_ERROR;
            end if;

            IC := IC + 1;
        end loop;
    end BUILD_ROW;


    procedure UPDATE (TABLE_NAME : STRING) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          UPDATE                                      **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'unlocked'                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_LOCKED_IN_SHARED_MODE then                     **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'shared'                                    **
--**        raise X_SHARED_MODE_LOCK;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if THERE_IS_NO_CURRENT_ROW then                                 **
--**            -- the CURRENT_ROW component of TABLE_NAME in the TABLE **
--**            -- status array is 'init' or 'end'                      **
--**        raise X_NO_CURRENT_ROW;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_IS_SORTED then                                         **
--**                                                                    **
--**            -- i.e. when the table is  sorted, and would be         **
--**            -- disordered by replacing the current row with         **
--**            -- the temporary one                                    **
--**        DELETE_CURRENT_ROW;                                         **
--**        INSERT_TEMPORARY_ROW_SO_THAT_TABLE_REMAINS_SORTED;          **
--**                                                                    **
--**    else                                                            **
--**            -- i.e. when the table is not sorted                    **
--**        REPLACE_CURRENT_ROW_WITH_TEMPORARY_ROW;                     **
--**    end if;                                                         **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of   the   table   to  be  processed.  **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_TABLE_NOT_LOCKED                                              **
--**    X_NO_CURRENT_ROW                                                **
--**    X_SHARED_MODE_LOCK                                              **
--**                                                                    **
--************************************************************************

        IT, RTN : INTEGER;
    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened and a table locked to use UPDATE");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the index of the table or raise X_TABLE_NOT_LOCKED
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        if TABLE (IT).TABLE_STATUS.CURRENT_LOCK = SHARED then
            -- the table should have been locked in exclusive mode
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "UPDATE cannot be applied to a table locked in shared");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "mode; it must be in exclusive mode");
            raise X_SHARED_MODE_LOCK;
        end if;

        if TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = 0 or
           TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = -1 then
            -- no row is currently selected
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A row must be selected by successfully using NEXT, PREVIOUS,");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "FIND_NEXT or FIND_PREVIOUS before using UPDATE");
            raise X_NO_CURRENT_ROW;
        end if;

        if TABLE (IT).TABLE_DEFINITION.SORTED then
            -- the table is sorted

            -- first delete the current row
            F77_CALLABLES.ADA_DELETT
               (TABLE (IT).TABLE_STATUS.DESCR,
                TABLE (IT).TABLE_STATUS.CURRENT_ROW, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when deleting the old row in UPDATE");
                raise X_INTERNAL_ERROR;
            end if;

            -- ... and then insert the temporary row so that the table
            -- remains sorted
            SORTED_INSERT (IT);
        else
            -- the table is not sorted

            -- replace the current row with the temporary one
            F77_CALLABLES.ADA_REPLAT
               (TABLE (IT).TABLE_STATUS.DESCR,
                TABLE (IT).TABLE_STATUS.CURRENT_ROW, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when updating the old row in UPDATE");
                raise X_INTERNAL_ERROR;
            end if;
        end if;
    end UPDATE;

    procedure INSERT (TABLE_NAME : STRING) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          INSERT                                      **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'unlocked'                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_LOCKED_IN_SHARED_MODE then                     **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'shared'                                    **
--**        raise X_SHARED_MODE_LOCK;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_IS_SORTED then                                         **
--**        INSERT_TEMPORARY_ROW_SO_THAT_TABLE_REMAINS_SORTED;          **
--**                                                                    **
--**    else                                                            **
--**        APPEND_TEMPORARY_ROW;                                       **
--**    end if;                                                         **
--**                                                                    **
--**    if ERROR then                                                   **
--**        raise X_FULL_TABLE;                                         **
--**    end if;                                                         **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of   the   table   to  be  processed.  **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_TABLE_NOT_LOCKED                                              **
--**    X_FULL_TABLE                                                    **
--**    X_SHARED_MODE_LOCK                                              **
--**                                                                    **
--************************************************************************
        IT, RTN : INTEGER;
    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened and a table locked to use INSERT");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the index of the table or raise X_TABLE_NOT_LOCKED
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        if TABLE (IT).TABLE_STATUS.CURRENT_LOCK = SHARED then
            -- the table should have been locked in exclusive mode
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "INSERT cannot be applied to a table locked in shared");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "mode; it must be in exclusive mode");
            raise X_SHARED_MODE_LOCK;
        end if;

        if TABLE (IT).TABLE_DEFINITION.SORTED then
            -- the table is sorted

            -- insert the temporary row sothat the table remains sorted
            SORTED_INSERT (IT);
            RTN := 0;
        else
            -- the table is not sorted

            -- insert the temporary row at the current position
            F77_CALLABLES.ADA_INSRTT
               (TABLE (IT).TABLE_STATUS.DESCR,
                TABLE (IT).TABLE_STATUS.CURRENT_ROW, RTN);
        end if;

        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "No other row can be added to the " & TABLE_NAME &
            " table; it is full");
            raise X_FULL_TABLE;
        end if;
    end INSERT;

    procedure DELETE (TABLE_NAME : STRING; NO_MORE_ROW : out BOOLEAN) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :          DELETE                                      **
--**   ~~~~~~~~~~~                                                      **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**    if not A_DATABASE_IS_OPEN then                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_UNLOCKED then                                  **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'unlocked'                                  **
--**        raise X_TABLE_NOT_LOCKED;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if TABLE_NAME_IS_LOCKED_IN_SHARED_MODE then                     **
--**            -- the LOCK component of TABLE_NAME in the TABLE status **
--**            -- array is 'shared'                                    **
--**        raise X_SHARED_MODE_LOCK;                                   **
--**    end if;                                                         **
--**                                                                    **
--**    if THERE_IS_NO_CURRENT_ROW then                                 **
--**            -- the CURRENT_ROW component of TABLE_NAME in the TABLE **
--**            -- status array is 'init' or 'end'                      **
--**        raise X_NO_CURRENT_ROW;                                     **
--**    end if;                                                         **
--**                                                                    **
--**    DELETE_CURRENT_ROW;                                             **
--**    UPDATE_CURRENT_ROW_STATUS;                                      **
--**                                                                    **
--**    if TABLE_IS_EMPTY then                                          **
--**        NO_MORE_ROW := TRUE;                                        **
--**    else                                                            **
--**        NO_MORE_ROW := FALSE;                                       **
--**    end if;                                                         **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  TABLE_NAME  is  the  name  of   the   table   to  be  processed.  **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**    TABLE.LOCK                                                      **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--**  NO_MORE_ROW  is  TRUE  if  the table is left  empty,  and  FALSE  **
--**  otherwise.                                                        **
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_TABLE_NOT_LOCKED                                              **
--**    X_NO_CURRENT_ROW                                                **
--**    X_SHARED_MODE_LOCK                                              **
--**                                                                    **
--************************************************************************

        IT, RTN : INTEGER;
    begin
        if not SHARE.A_DATABASE_IS_OPEN then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A database must be opened and a table locked to use DELETE");
            raise X_TABLE_NOT_LOCKED;
        end if;

        -- get the table index or raise X_TABLE_NOT_LOCKED
        IT := UTILITIES.TABLE_ID (TABLE_NAME);

        if TABLE (IT).TABLE_STATUS.CURRENT_LOCK = SHARED then
            -- the table should have been locked in exclusive mode
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "DELETE cannot be applied to a table locked in shared");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "mode; it must be in exclusive mode");
            raise X_SHARED_MODE_LOCK;
        end if;

        if TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = 0 or
           TABLE (IT).TABLE_STATUS.CURRENT_ROW (1) = -1 then
            -- no one row is currently selected
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "A row must be selected by successfully using NEXT, PREVIOUS,");
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "FIND_NEXT or FIND_PREVIOUS before using DELETE");
            raise X_NO_CURRENT_ROW;
        end if;

        -- discard the current row from the table
        F77_CALLABLES.ADA_DELETT
           (TABLE (IT).TABLE_STATUS.DESCR,
            TABLE (IT).TABLE_STATUS.CURRENT_ROW, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when deleting the old row in DELETE");
            raise X_INTERNAL_ERROR;
        end if;

        if F77_CALLABLES.ADA_NUMTUP (TABLE (IT).TABLE_STATUS.DESCR) = 0 then
            -- table is empty

            NO_MORE_ROW := TRUE;
        else
            -- table is not empty

            NO_MORE_ROW := FALSE;
        end if;

    end DELETE;

end LL_DAMES;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--tabdes.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package body TABLE_DESCRIPTOR is

    type HOOK;
    type HOOK_ACCESS is access HOOK;
    type HOOK is
        record
            FREE    : BOOLEAN;
                -- when true, means that the hanging node is currently
                -- unused, and can then be chosen to be returned by the
                -- NEW_NODE function.

            OTHER   : HOOK_ACCESS;
                -- points to another hook.

            HANGING : NODE_ACCESS;
                -- pointer to a node which can be allocated by the
                -- NEW_NODE function.
        end record;

    HEAD : HOOK_ACCESS;
        -- this variable points to the first item of a list of hooks;
        -- the hanging nodes are those who can be allocated by a call
        -- to NEW_NODE.


    type CELL;
    type CELL_ACCESS is access CELL;
    type CELL is
        record
            OTHER  : CELL_ACCESS;
            OBJECT : CONSTRAINT_ACCESS;
        end record;
    HEAD_CELL : CELL_ACCESS;
    procedure FREE_NODES (TABLE_ID : INTEGER) is
        CURSOR : HOOK_ACCESS;
    begin

            -- first check that no other table than the TABLE_ID one
            -- currently needs some of the already hanging nodes; if
            -- there is one (or more), no node should be freed.
        for I in 1 .. TABLE_NO loop
            if I /= TABLE_ID and then
               TABLE (I).TABLE_STATUS.TABLE_IS_LOCKED and then
               TABLE (I).TABLE_STATUS.FIND_STATUS /= DEAD then
                 -- the Ith table currently uses hanging nodes; do not
                 -- free them
                return;
            end if;
        end loop;

            -- all hanging nodes can be freed
        CURSOR := HEAD;

        while CURSOR /= null loop
            CURSOR.all.FREE := TRUE;
            CURSOR := CURSOR.all.OTHER;
        end loop;
    end FREE_NODES;


    function NEW_NODE return NODE_ACCESS is
        CURSOR : HOOK_ACCESS;
    begin
        CURSOR := HEAD;

            -- look at the currently hanging nodes in order to find
            -- a free one
        while CURSOR /= null loop
            if CURSOR.all.FREE then
                return CURSOR.all.HANGING;
            else
                CURSOR := CURSOR.all.OTHER;
            end if;
        end loop;

            -- since no one of the currently hanging nodes is free, a
            -- new one is to be allocated, inserted at the beginning
            -- of the currently hanging nodes list, and its address
            -- then returned
        HEAD := new HOOK'(FALSE, HEAD, new NODE);
        return HEAD.all.HANGING;
    end NEW_NODE;
    procedure STORE_CONSTRAINT (CONSTRAINT : CONSTRAINT_ACCESS) is
        CURSOR : CELL_ACCESS;
    begin
        CURSOR := HEAD_CELL;
        while CURSOR /= null and then CURSOR.all.OBJECT /= null loop
            CURSOR := CURSOR.all.OTHER;
        end loop;
        if CURSOR = null then
            HEAD_CELL := new CELL'(HEAD_CELL, CONSTRAINT);
        else
            CURSOR.all.OBJECT := CONSTRAINT;
        end if;
    end STORE_CONSTRAINT;

    function NEW_CONSTRAINT return CONSTRAINT_ACCESS is
        CURSOR         : CELL_ACCESS;
        TO_BE_RETURNED : CONSTRAINT_ACCESS;
    begin
        CURSOR := HEAD_CELL;
        while CURSOR /= null and then CURSOR.all.OBJECT = null loop
            CURSOR := CURSOR.all.OTHER;
        end loop;
        if CURSOR = null then
            TO_BE_RETURNED := new STRING (1 .. 2 * RANGE_SIZE);
        else
            TO_BE_RETURNED := CURSOR.all.OBJECT;
            CURSOR.all.OBJECT := null;
        end if;
        return TO_BE_RETURNED;
    end NEW_CONSTRAINT;


end TABLE_DESCRIPTOR;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--util.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with CONSTANTS;
use CONSTANTS;

with LL_DAMES;
use LL_DAMES;

with F77_CALLABLES;

with UNCHECKED_CONVERSION;

with TEXT_IO;

with CONVERSION;

package body UTILITIES is

    VALUE           : INTEGER_ARRAY_TYPE (1 .. (MAX_STRING + 3) / 4) :=
                      (others => 0);
    LENR, FTYP, RTN : INTEGER;


                          ---------------
                          -- NORMALIZE --
                          ---------------
    function NORMALIZE (NAME : STRING) return STRING is

            -- NORMALIZE return a ten characters long character string in
            -- which the NAME in parameter has been copied after it was
            -- 'normalized' , i.e. :
            --      cut if too long,
            --      completed to blank if too short,
            --      skip beginning blanks,
            --      uppercased

        TO_BE_RETURNED : STRING (1 .. NAME_LENGTH);
    begin
        if NAME'LENGTH > NAME_LENGTH then
                -- NAME is too long and must be cut

            TO_BE_RETURNED := NAME (NAME'FIRST .. NAME'FIRST + NAME_LENGTH - 1);
        else
                -- NAME is too short and must be completed with blanks
            TO_BE_RETURNED := NAME & (NAME'LENGTH + 1 .. NAME_LENGTH => ' ');
        end if;

        if TO_BE_RETURNED /= (1 .. NAME_LENGTH => ' ') then
            while TO_BE_RETURNED (1) = ' ' loop
                    -- discard the first character if blank
                TO_BE_RETURNED := TO_BE_RETURNED (2 .. NAME_LENGTH) & ' ';
            end loop;
        end if;

        for I in 1 .. NAME_LENGTH loop
                -- loop for each character

            if TO_BE_RETURNED (I) >= 'a' then
                    -- the character is a lower-case letter which will be
                    -- converted to its upper-case equivalent

                TO_BE_RETURNED (I) :=
                  CHARACTER'VAL (CHARACTER'POS (TO_BE_RETURNED (I)) - 32);
            end if;
        end loop;
        return TO_BE_RETURNED;
    end NORMALIZE;


                          --------------
                          -- BIT_SIZE --
                          --------------
    function BIT_SIZE (TABLE_ID  : INTEGER;
                       COLUMN_ID : INTEGER) return INTEGER is

        -- return the size (in bits) of the Ada type associated to a
        -- scalar column.

    begin
        case TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_TYPES (COLUMN_ID) is
                -- INTEGER type
            when 1 =>  return INTEGER'SIZE;

                -- FLOAT type
            when 2 =>  return FLOAT'SIZE;

                -- ENUMERATION or STRING type
            when 5 =>
                if TABLE (TABLE_ID).TABLE_DEFINITION.ENUM_TYPES (COLUMN_ID)
                  = null then
                        -- STRING type
                    declare
                        S : STRING
                              (1 .. TABLE (TABLE_ID).TABLE_DEFINITION
                                     .COLUMN_LENGTH (COLUMN_ID));
                    begin
                        return S'SIZE;
                    end;
                else
                        -- ENUMERATION type
                    return BOOLEAN'SIZE;
                end if;

            when others =>
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when evaluating a type definition");
                raise X_INTERNAL_ERROR;
        end case;
    end BIT_SIZE;


                       ---------------------
                       -- RECORD_BIT_SIZE --
                       ---------------------
    function RECORD_BIT_SIZE (TABLE_ID  : INTEGER;
                              COLUMN_ID : INTEGER;
                              IS_RECORD : BOOLEAN) return INTEGER is

            -- return the size of a column of a table; this column can either
            -- be a scalar or a record column, depending on IS_RECORD

        IC, ACTUAL_SIZE : INTEGER;
        RECORD_NAME     : STRING (1 .. NAME_LENGTH);    begin
        if IS_RECORD then
                -- the column is a record column

            ACTUAL_SIZE := 0;
            IC := COLUMN_ID;
            RECORD_NAME := TABLE (TABLE_ID).TABLE_DEFINITION.IN_RECORD (IC);
                -- the name of the record column is stored in RECORD_NAME

            while TABLE (TABLE_ID).TABLE_DEFINITION.IN_RECORD (IC) =
                  RECORD_NAME loop
                    -- loop while the ICth scalar column is a component of
                    -- the RECORD_NAME record column

                ACTUAL_SIZE := ACTUAL_SIZE + BIT_SIZE (TABLE_ID, IC);
                exit when IC = TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NUMBER;
                IC := IC + 1;
            end loop;

            return ACTUAL_SIZE;
        else
                -- the column is a scalar column
            return BIT_SIZE (TABLE_ID, COLUMN_ID);
        end if;
    end RECORD_BIT_SIZE;


                         ----------------
                         -- TABLE_SIZE --
                         ----------------
    function TABLE_SIZE (TABLE_ID : INTEGER) return INTEGER is

            -- TABLE_SIZE returns the size (in bits) of the record type
            -- which corresponds to a row of this table

        ACTUAL_SIZE : INTEGER;
    begin
        ACTUAL_SIZE := 0;

        for I in 1 .. TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NUMBER loop
            ACTUAL_SIZE := ACTUAL_SIZE + BIT_SIZE (TABLE_ID, I);
        end loop;

        return ACTUAL_SIZE;
    end TABLE_SIZE;


                          --------------
                          -- TABLE_ID --
                          --------------
    function TABLE_ID (TABLE_NAME : STRING) return INTEGER is

            -- TABLE_ID returns the index in TABLE_DESCRIPTOR of the locked
            -- table  the  name  of  which  is  TABLE_NAME ,  or  raise
            -- X_TABLE_NOT_LOCKED if this name is unknown

        TABLE_NAME2 : STRING (1 .. NAME_LENGTH);
        IT          : INTEGER;    begin
            -- first normalize the name to compare it to those already known
        TABLE_NAME2 := NORMALIZE (TABLE_NAME);
        IT := 1;

        loop
            if TABLE_NAME2 = TABLE (IT).NAME then
                    -- the searched name is found
                if TABLE (IT).TABLE_STATUS.TABLE_IS_LOCKED = TRUE then
                        -- the table is locked
                    exit;
                else
                        -- the table is unlocked
                    UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                    "unknown table among locked ones");
                    raise X_TABLE_NOT_LOCKED;
                end if;
            end if;

            IT := IT + 1;

            if IT = TABLE_NO + 1 then
                    -- the last possible value for IT is reached but the
                    -- searched name is not found : it means the table is
                    -- unlocked
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "unknown table among locked ones");
                raise X_TABLE_NOT_LOCKED;
            end if;
        end loop;

        return IT;
    end TABLE_ID;


                      ----------------------
                      -- SCALAR_COLUMN_ID --
                      ----------------------
    function SCALAR_COLUMN_ID (TABLE_ID    : INTEGER;
                               COLUMN_NAME : STRING) return INTEGER is

            -- return the index of a scalar column or raise X_INVALID_COLUMN
            -- if this one can not be found

        COLUMN_NAME2 : STRING (1 .. NAME_LENGTH);
        IC           : INTEGER;
    begin
            -- first normalize the name of the column to enable comparisons
        COLUMN_NAME2 := NORMALIZE (COLUMN_NAME);
        IC := 1;

        loop
            exit when COLUMN_NAME2 =
                      TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NAMES (IC);
                -- exit from the loop when the searched name is found

            IC := IC + 1;
            if IC = TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NUMBER + 1 then
                    -- the searched name has been compared to all the names
                    -- of the table without equality
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "unknown column name among all scalar ones");
                raise X_INVALID_COLUMN;
            end if;
        end loop;

        return IC;
    end SCALAR_COLUMN_ID;


                           ------------
                           -- COLUMN --
                           ------------
    procedure COLUMN (TABLE_ID    : INTEGER;
                      COLUMN_NAME : STRING;
                      COLUMN_ID   : out INTEGER;
                      IS_RECORD   : out BOOLEAN) is

            -- COLUMN returns in COLUMN_ID the index of the COLTUMN_NAME column
            -- or raise X_INVALID_COLUMN if this one is unknown; IS_RECORD is
            -- returned 'false' if the column is a scalar one, and 'true' if it
            -- is a record one and not a scalar one.

        COLUMN_NAME2 : STRING (1 .. NAME_LENGTH);
        IC           : INTEGER;
    begin
            -- first normalize the name to compare it to other names
        COLUMN_NAME2 := NORMALIZE (COLUMN_NAME);
        IC := 1;
        IS_RECORD := FALSE;

        OUTER_LOOP:
        loop
            exit when COLUMN_NAME2 =
                      TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NAMES (IC);
                -- exit from the loop when the searched column is found as
                -- a scalar one

            IC := IC + 1;

            if IC = TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NUMBER + 1 then
                    -- none of the scalar columns is the one searched

                IS_RECORD := TRUE;
                IC := 1;

                loop
                    exit OUTER_LOOP when COLUMN_NAME2 =
                                         TABLE (TABLE_ID).TABLE_DEFINITION
                                          .IN_RECORD (IC);
                        -- exit from loop when the searched column is found as
                        -- a record one

                    IC := IC + 1;
                    if IC =
                       TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_NUMBER + 1 then
                        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                        "unknown column among all scalar and record ones");
                        raise X_INVALID_COLUMN;
                    end if;
                end loop;
            end if;
        end loop OUTER_LOOP;

        COLUMN_ID := IC;
    end COLUMN;



                 ---------------------------------
                 -- SELECTION_CRITERION_IS_TRUE --
                 ---------------------------------
    function SELECTION_CRITERION_IS_TRUE (TABLE_ID : INTEGER;
                                          CURSOR   : NODE_ACCESS)
                                           return BOOLEAN is

        -- SELECTION_CRITERION_IS_TRUE returns TRUE if the selection criterion
        -- defined by CURSOR (CURSOR is the root of a tree which is supposed to
        -- be the selection criterion) is true for the current row of the table
        -- TABLE_ID, and FALSE if the criterion is false.
        -- Since the selection criterion is a tree, each subtree can be used by
        -- chosing for CURSOR a node which is not the root.

    begin
        if CURSOR.all.FIRST_CHILD = null then
                -- CURSOR is a leave of the binary tree; a test must be done

                -- first get the value of the current row to be tested
            VALUE := (1 .. VALUE'LENGTH => 0);
            F77_CALLABLES.ADA_GETA
               (TABLE (TABLE_ID).TABLE_STATUS.DESCR,
                TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_INDEX
                   (CURSOR.all.COLUMN_ID), VALUE, LENR, FTYP, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when reading a value to be used");
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "in a selection criterion");
                raise X_INTERNAL_ERROR;
            end if;

            if TABLE (TABLE_ID).TABLE_DEFINITION.ENUM_TYPES
                  (CURSOR.all.COLUMN_ID) /= null then
                        -- the value is of an enumeration type and the string
                        -- we got in value must be converted to its position
                        -- while the order on enumeration item is by position
                        -- and not by lexicographic order on images

                VALUE (1) := CONVERSION.ADA_ENUM
                                (VALUE,
                                 TABLE (TABLE_ID).TABLE_DEFINITION.ENUM_TYPES
                                    (CURSOR.all.COLUMN_ID));
            end if;
            case CURSOR.all.KEY_MATCH is



                when EQUAL            =>  return VALUE (1 .. CURSOR.all
                                                              .MEANINGFUL) =
                                                 CURSOR.all.COLUMN_VALUE
                                                    (1 .. CURSOR.all
                                                           .MEANINGFUL);



                when NOT_EQUAL        =>  return VALUE (1 .. CURSOR.all
                                                              .MEANINGFUL) /=
                                                 CURSOR.all.COLUMN_VALUE
                                                    (1 .. CURSOR.all
                                                           .MEANINGFUL);



                when LESS             =>  return VALUE (1 .. CURSOR.all
                                                              .MEANINGFUL) <
                                                 CURSOR.all.COLUMN_VALUE
                                                    (1 .. CURSOR.all
                                                           .MEANINGFUL);



                when LESS_OR_EQUAL    =>  return VALUE (1 .. CURSOR.all
                                                              .MEANINGFUL) <=
                                                 CURSOR.all.COLUMN_VALUE
                                                    (1 .. CURSOR.all
                                                           .MEANINGFUL);



                when GREATER          =>  return VALUE (1 .. CURSOR.all
                                                              .MEANINGFUL) >
                                                 CURSOR.all.COLUMN_VALUE
                                                    (1 .. CURSOR.all
                                                           .MEANINGFUL);



                when GREATER_OR_EQUAL =>  return VALUE (1 .. CURSOR.all
                                                              .MEANINGFUL) >=
                                                 CURSOR.all.COLUMN_VALUE
                                                    (1 .. CURSOR.all
                                                           .MEANINGFUL);
            end case;

        elsif CURSOR.all.TREE_OPERATOR = AND_OPERATOR then
                -- CURSOR is not a leave of the binary tree;
                -- SELECTION_CRITERION_IS_TRUE must be called again for
                -- the two subtree of CURSOR and a AND will be performed
                -- on the two results

            return SELECTION_CRITERION_IS_TRUE
                      (TABLE_ID, CURSOR.all.FIRST_CHILD) and
                   SELECTION_CRITERION_IS_TRUE
                      (TABLE_ID, CURSOR.all.SECOND_CHILD);        else
                -- CURSOR is not a leave of the binary tree;
                -- SELECTION_CRITERION_IS_TRUE must be called again for
                -- the two subtree of CURSOR and a OR will be performed
                -- on the two results

            return SELECTION_CRITERION_IS_TRUE
                      (TABLE_ID, CURSOR.all.FIRST_CHILD) or
                   SELECTION_CRITERION_IS_TRUE
                      (TABLE_ID, CURSOR.all.SECOND_CHILD);
        end if;
    end SELECTION_CRITERION_IS_TRUE;


    function INTEGER_TO_FLOAT is new UNCHECKED_CONVERSION (INTEGER, FLOAT);

    package PURE_FLOAT_IO is new TEXT_IO.FLOAT_IO (FLOAT);


                         -----------------
                         -- CHECK_VALUE --
                         -----------------
    procedure CHECK_VALUE (CHECKED, TABLE_ID, COLUMN_ID : INTEGER) is

                -- This procedure checks that the value contained in
                -- CHECKED is in the range associated to the column
                -- defined by TABLE_ID and COLUMN_ID; this column is
                -- supposed to have actually a range constraint, otherwise
                -- CHECK_VALUE will fail.
                -- If the check is successful, nothing is done, but if
                -- the check fails, X_INVALID_VALUE is raised.

        LAST : POSITIVE;
        MIN_FLOAT, MAX_FLOAT, FLOAT_OBJECT : FLOAT;
        CONSTRAINT : STRING renames
          TABLE (TABLE_ID).TABLE_DEFINITION.CONSTRAINTS (COLUMN_ID).all;
    begin
        case TABLE (TABLE_ID).TABLE_DEFINITION.COLUMN_TYPES (COLUMN_ID) is

            when 1 =>
                        -- INTEGER type
                if CHECKED < INTEGER'VALUE (CONSTRAINT (1 .. RANGE_SIZE))
                or CHECKED > INTEGER'VALUE (CONSTRAINT
                  (RANGE_SIZE + 1 .. 2 * RANGE_SIZE)) then
                    UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                    "an integer range constraint has been violated");
                    raise X_INVALID_VALUE;
                end if;

            when 2 =>
                        -- FLOAT type
                FLOAT_OBJECT := INTEGER_TO_FLOAT (CHECKED);
                PURE_FLOAT_IO.GET (CONSTRAINT (1 .. RANGE_SIZE),
                  MIN_FLOAT, LAST);
                PURE_FLOAT_IO.GET (CONSTRAINT
                  (RANGE_SIZE + 1 .. 2 * RANGE_SIZE), MAX_FLOAT, LAST);
                if FLOAT_OBJECT < MIN_FLOAT or FLOAT_OBJECT > MAX_FLOAT then
                    UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                    "a float range constraint has been violated");
                    raise X_INVALID_VALUE;
                end if;
                    when 5 =>
                        -- ENUMERATION type or STRING type
                if TABLE (TABLE_ID).TABLE_DEFINITION.ENUM_TYPES (COLUMN_ID)
                  /= null then
                        -- enumeration type
                    if CHECKED < CONVERSION.ADA_ENUM
                        (CONVERSION.F77_STRING
                          (CONSTRAINT (1 .. RANGE_SIZE)),
                TABLE (TABLE_ID).TABLE_DEFINITION.ENUM_TYPES (COLUMN_ID))
                      or CHECKED > CONVERSION.ADA_ENUM
                        (CONVERSION.F77_STRING
                          (CONSTRAINT (RANGE_SIZE + 1 .. 2 * RANGE_SIZE)),
                TABLE (TABLE_ID).TABLE_DEFINITION.ENUM_TYPES (COLUMN_ID))
                      then
                        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                        "an enumeration range constraint has been violated");
                        raise X_INVALID_VALUE;
                    end if;
                end if;
            when others =>
                null;
        end case;
    end CHECK_VALUE;


    procedure OUTPUT_MESSAGE (MESSAGE : STRING) is
    begin
            -- The message can be outputed either by using the MESSAGE
            -- command of the User Language through the DAMES.EXECUTE
            -- procedure, or by using a dedicated Fortran subroutine.
        F77_CALLABLES.ADA_MSGTTY (MESSAGE, MESSAGE'LENGTH);
    end OUTPUT_MESSAGE;

end UTILITIES;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--adatab.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with CONSTANTS;
use CONSTANTS;

with F77_CALLABLES;
use F77_CALLABLES;

with LL_DAMES;

with UTILITIES;

with CONVERSION;

package body ADA_TABLES is

    TABLES_EXIST                                 : BOOLEAN;
        -- TRUE when the three reserved tables exist in the currently
        -- open database, and FALSE otherwise (when they do not exist,
        -- they are considered as existing, but empty)

    ACTUAL_USER_TABLE_NAME                       : STRING (1 .. NAME_LENGTH);
        -- name of a table to be used as key for the TABLE_NAME column
        -- of the reserved tables

    RANGE_TIDD, RECORD_TIDD, ENUM_TIDD, TIDD     : TIDD_TYPE;
        -- used to keep the current rows of the reserved tables
        -- during updating or scanning

    DESCR, RANGE_DESCR, RECORD_DESCR, ENUM_DESCR : INTEGER;
        -- used to keep the identifiers of the tables usd by the
        -- fortran access procedures



               ------------------------------------
               -- LOCK_ADA_TABLES_IN_SHARED_MODE --
               ------------------------------------
    procedure LOCK_ADA_TABLES_IN_SHARED_MODE is
        RTN : INTEGER;
    begin
        -- set the three shared locks
        ADA_DLOCK ("ADARANGE    ADARECORD   ADAENUM     ",
                (1 .. 3 => 0), 3, RTN);
        if RTN /= 0 then
            TABLES_EXIST := FALSE;
        else
            TABLES_EXIST := TRUE;
        end if;
    end LOCK_ADA_TABLES_IN_SHARED_MODE;


              ---------------------------------------
              -- LOCK_ADA_TABLES_IN_EXCLUSIVE_MODE --
              ---------------------------------------
    procedure LOCK_ADA_TABLES_IN_EXCLUSIVE_MODE (USER_TABLE_NAME : STRING) is
        DOMAIN_NAME : constant STRING (1 .. 12) :=
                      (1 .. 4 => ASCII.NUL, 5 .. 12 => ' ');
        RCKEY, RTN  : INTEGER;

    begin
                -- set the three exclusive locks
        ADA_DLOCK ("ADARANGE    ADARECORD   ADAENUM     ",
                (1 .. 3 => 1), 3, RTN);
        if RTN /= 0 then
            ADA_IRELC ("ADARANGE  ", RCKEY, 1);
                -- initialize the creation of the ADARANGE table

            ADA_ADDATR (RCKEY, "TABLENAME ", 5, NAME_LENGTH, DOMAIN_NAME, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when creating the ADARANGE internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
            ADA_ADDATR (RCKEY, "COLNAME   ", 5, NAME_LENGTH, DOMAIN_NAME, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when creating the ADARANGE internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
            ADA_ADDATR (RCKEY, "MINVALUE  ", 5, RANGE_SIZE, DOMAIN_NAME, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when creating the ADARANGE internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
            ADA_ADDATR (RCKEY, "MAXVALUE  ", 5, RANGE_SIZE, DOMAIN_NAME, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when creating the ADARANGE internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
                -- define its four attributes

            ADA_TRELC (RCKEY, 1, 0, 0, RTN);
                -- terminate the table creation
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when creating the ADARANGE internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;


            ADA_IRELC ("ADARECORD ", RCKEY, 1);
                -- initialize the creation of the ADARECORD table
            ADA_ADDATR (RCKEY, "TABLENAME ", 5, NAME_LENGTH, DOMAIN_NAME, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when creating the ADARECORD internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
            ADA_ADDATR (RCKEY, "RECORDNAME", 5, NAME_LENGTH, DOMAIN_NAME, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when creating the ADARECORD internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
            ADA_ADDATR (RCKEY, "COMPONENT ", 5, NAME_LENGTH, DOMAIN_NAME, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when creating the ADARECORD internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
                -- define its three attributes

            ADA_TRELC (RCKEY, 1, 0, 0, RTN);
                -- terminate the table creation
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when creating the ADARECORD internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;


            ADA_IRELC ("ADAENUM   ", RCKEY, 1);
                -- initialize the creation of the ADAENUM table

            ADA_ADDATR (RCKEY, "TABLENAME ", 5, NAME_LENGTH, DOMAIN_NAME, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when creating the ADAENUM internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
            ADA_ADDATR (RCKEY, "COLNAME   ", 5, NAME_LENGTH, DOMAIN_NAME, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when creating the ADAENUM internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
            ADA_ADDATR (RCKEY, "VALUE     ", 1, 4, DOMAIN_NAME, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when creating the ADAENUM internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
            ADA_ADDATR (RCKEY, "IMAGE     ", 5, IMAGE_SZ, DOMAIN_NAME, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when creating the ADAENUM internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
                -- define its four attributes
            ADA_TRELC (RCKEY, 1, 0, 0, RTN);
                -- terminate the table creation
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when creating the ADAENUM internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;

                -- set the three exclusive locks
            ADA_DLOCK ("ADARANGE    ADARECORD   ADAENUM     ",
                (1 .. 3 => 1), 3, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when locking the three reserved tables");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
        end if;

        ADA_OPENR ("ADARANGE  ", RANGE_DESCR, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when opening the ADARANGE internal table");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;
        ADA_OPENR ("ADARECORD ", RECORD_DESCR, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when opening the ADARECORD internal table");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;
        ADA_OPENR ("ADAENUM   ", ENUM_DESCR, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when opening the ADAENUM internal table");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;
                -- open the three reserved tables

        RANGE_TIDD (1) := -1;
        RECORD_TIDD (1) := -1;
        ENUM_TIDD (1) := -1;
                -- initialize the current row to the beginning of the
                -- tables

        ACTUAL_USER_TABLE_NAME := USER_TABLE_NAME;
    end LOCK_ADA_TABLES_IN_EXCLUSIVE_MODE;


                       --------------------
                       -- OPEN_ADA_TABLE --
                       --------------------
    procedure OPEN_ADA_TABLE (ADA_TABLE_NAME : STRING) is
        RTN : INTEGER;
    begin
        if TABLES_EXIST then
            ADA_OPENR (ADA_TABLE_NAME, DESCR, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when opening the " & ADA_TABLE_NAME
                & " internal table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
        end if;
    end OPEN_ADA_TABLE;



                       ---------------------
                       -- RESET_ADA_TABLE --
                       ---------------------
    procedure RESET_ADA_TABLE (USER_TABLE_NAME : STRING) is
        RTN : INTEGER;
    begin
        if TABLES_EXIST then
            ADA_SETGET (DESCR, 3, TIDD, TIDD, RTN);
            if RTN /= 0 then
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "internal error when initializing the current row ");
                UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                "of a reserved table");
                raise LL_DAMES.X_INTERNAL_ERROR;
            end if;
            TIDD (1) := -1;
                -- reset the current row to the first one of the table

            ACTUAL_USER_TABLE_NAME := USER_TABLE_NAME;
        end if;
    end RESET_ADA_TABLE;




                          ---------------
                          -- GET_RANGE --
                          ---------------
    procedure GET_RANGE (COLNAME            : out STRING;
                         MINVALUE, MAXVALUE : out STRING;
                         EOF                : out BOOLEAN) is
        FTYP, LENR, ATIDX, RTN : INTEGER;
        VALUE                  : INTEGER_ARRAY_TYPE (1 .. 3);
        VALUE2                 : INTEGER_ARRAY_TYPE
                                        (1 .. (RANGE_SIZE + 3) / 4);
    begin
        if TABLES_EXIST then
            ADA_GETT (DESCR, TIDD, RTN);
                -- fetch next row

            ADA_SRCHA (DESCR, "TABLENAME ", ATIDX);
                -- read the index neccessary to access the table
            while RTN = 0 loop
                -- last row not already found

                ADA_GETA (DESCR, ATIDX, VALUE, LENR, FTYP, RTN);
                        -- get into VALUE the attribute defined by ATIDX
                if RTN /= 0 then
                    UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                    "internal error when reading TABLENAME from ADARANGE");
                    raise LL_DAMES.X_INTERNAL_ERROR;
                end if;

                if CONVERSION.ADA_STRING (VALUE, FALSE) (1 .. NAME_LENGTH)
                                    = ACTUAL_USER_TABLE_NAME then
                        -- keep this tuple

                        -- get the name of the concerned column
                    ADA_SRCHA (DESCR, "COLNAME   ", ATIDX);
                    ADA_GETA (DESCR, ATIDX, VALUE, LENR, FTYP, RTN);
                    if RTN /= 0 then
                        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                        "internal error when reading COLNAME from ADARANGE");
                        raise LL_DAMES.X_INTERNAL_ERROR;
                    end if;
                    COLNAME := CONVERSION.ADA_STRING (VALUE, FALSE)
                                                (1 .. NAME_LENGTH);

                        -- get the range minimum value
                    ADA_SRCHA (DESCR, "MINVALUE  ", ATIDX);
                    ADA_GETA (DESCR, ATIDX, VALUE2, LENR, FTYP, RTN);
                    if RTN /= 0 then
                        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                        "internal error when reading MINVALUE from ADARANGE");
                        raise LL_DAMES.X_INTERNAL_ERROR;
                    end if;
                    MINVALUE:= CONVERSION.ADA_STRING (VALUE2, FALSE)
                                                (1 .. RANGE_SIZE);

                        -- get the range maximum value
                    ADA_SRCHA (DESCR, "MAXVALUE  ", ATIDX);
                    ADA_GETA (DESCR, ATIDX, VALUE2, LENR, FTYP, RTN);
                    if RTN /= 0 then
                        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                        "internal error when reading MAXVALUE from ADARANGE");
                        raise LL_DAMES.X_INTERNAL_ERROR;
                    end if;
                    MAXVALUE:= CONVERSION.ADA_STRING (VALUE2, FALSE)
                                                (1 .. RANGE_SIZE);

                    EOF := FALSE;
                    return;
                end if;

                ADA_GETT (DESCR, TIDD, RTN);
                        -- look for another row

            end loop;
        end if;
        EOF := TRUE;
    end GET_RANGE;

                         ----------------
                         -- GET_RECORD --
                         ----------------
    procedure GET_RECORD (RECORD_NAME, COMPONENT : out STRING;
                          EOF                    : out BOOLEAN) is
        FTYP, LENR, ATIDX, RTN : INTEGER;
        VALUE                  : INTEGER_ARRAY_TYPE (1 .. 3);
    begin
        if TABLES_EXIST then
            ADA_GETT (DESCR, TIDD, RTN);
            ADA_SRCHA (DESCR, "TABLENAME ", ATIDX);

            while RTN = 0 loop
                ADA_GETA (DESCR, ATIDX, VALUE, LENR, FTYP, RTN);
                if RTN /= 0 then
                    UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                    "internal error when reading TABLENAME from ADARECORD");
                    raise LL_DAMES.X_INTERNAL_ERROR;
                end if;
                if CONVERSION.ADA_STRING (VALUE, FALSE) (1 .. NAME_LENGTH)
                                    = ACTUAL_USER_TABLE_NAME then
                        -- get the name of the encapsulating record
                    ADA_SRCHA (DESCR, "RECORDNAME", ATIDX);
                    ADA_GETA (DESCR, ATIDX, VALUE, LENR, FTYP, RTN);
                    if RTN /= 0 then
                        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                    "internal error when reading RECORDNAME from ADARECORD");
                        raise LL_DAMES.X_INTERNAL_ERROR;
                    end if;
                    RECORD_NAME:= CONVERSION.ADA_STRING (VALUE, FALSE)
                                                (1 .. NAME_LENGTH);

                        -- get the name of the concerned component
                    ADA_SRCHA (DESCR, "COMPONENT ", ATIDX);
                    ADA_GETA (DESCR, ATIDX, VALUE, LENR, FTYP, RTN);
                    if RTN /= 0 then
                        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                    "internal error when reading COMPONENT from ADARECORD");
                        raise LL_DAMES.X_INTERNAL_ERROR;
                    end if;
                    COMPONENT:= CONVERSION.ADA_STRING (VALUE, FALSE)
                                                (1 .. NAME_LENGTH);

                    EOF := FALSE;
                    return;
                end if;

                ADA_GETT (DESCR, TIDD, RTN);
            end loop;
        end if;
        EOF := TRUE;
    end GET_RECORD;


                          --------------
                          -- GET_ENUM --
                          --------------
    procedure GET_ENUM (COLNAME      : out STRING;
                        VALUE        : out INTEGER;
                        IMAGE_STRING : out STRING;
                        EOF          : out BOOLEAN) is
        FTYP, LENR, ATIDX, RTN : INTEGER;
        VALUE2                 : INTEGER_ARRAY_TYPE (1 .. (IMAGE_SZ + 3)/4);
    begin
        if TABLES_EXIST then
            ADA_GETT (DESCR, TIDD, RTN);
            ADA_SRCHA (DESCR, "TABLENAME ", ATIDX);

            while RTN = 0 loop
                ADA_GETA (DESCR, ATIDX, VALUE2 (1 .. 3), LENR, FTYP, RTN);
                if RTN /= 0 then
                    UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                    "internal error when reading TABLENAME from ADAENUM");
                    raise LL_DAMES.X_INTERNAL_ERROR;
                end if;

                if CONVERSION.ADA_STRING (VALUE2(1 .. 3), FALSE) (1 .. NAME_LENGTH)
                                    = ACTUAL_USER_TABLE_NAME then

                        -- get the name of the concerned column
                    ADA_SRCHA (DESCR, "COLNAME   ", ATIDX);
                    ADA_GETA (DESCR, ATIDX, VALUE2(1 .. 3), LENR, FTYP, RTN);
                    if RTN /= 0 then
                        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                        "internal error when reading COLNAME from ADAENUM");
                        raise LL_DAMES.X_INTERNAL_ERROR;
                    end if;
                    COLNAME:= CONVERSION.ADA_STRING (VALUE2(1..3), FALSE)
                                                (1 .. NAME_LENGTH);

                        -- get the value of the considered item
                    ADA_SRCHA (DESCR, "VALUE     ", ATIDX);
                    ADA_GETA (DESCR, ATIDX, VALUE2(1 .. 1), LENR, FTYP, RTN);
                    if RTN /= 0 then
                        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                        "internal error when reading VALUE from ADAENUM");
                        raise LL_DAMES.X_INTERNAL_ERROR;
                    end if;
                    VALUE := VALUE2 (1);

                        -- get the image of the considered item
                    VALUE2 := (others => 0);
                    ADA_SRCHA (DESCR, "IMAGE     ", ATIDX);
                    ADA_GETA (DESCR, ATIDX, VALUE2, LENR, FTYP, RTN);
                    if RTN /= 0 then
                        UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
                        "internal error when reading IMAGE from ADAENUM");
                        raise LL_DAMES.X_INTERNAL_ERROR;
                    end if;
                    IMAGE_STRING := CONVERSION.ADA_STRING (VALUE2, FALSE)
                                                (1 .. IMAGE_SZ);
                    EOF := FALSE;
                    return;
                end if;

                ADA_GETT (DESCR, TIDD, RTN);
            end loop;
        end if;
        EOF := TRUE;
    end GET_ENUM;

                          ---------------
                          -- PUT_RANGE --
                          ---------------
    procedure PUT_RANGE (COLNAME : STRING; MINVALUE, MAXVALUE : STRING) is
        ATTINX, RTN : INTEGER;
    begin

                -- build the temporary row
        ADA_SRCHA (RANGE_DESCR, "TABLENAME ", ATTINX);
        ADA_PUTA (RANGE_DESCR, ATTINX,
                CONVERSION.F77_STRING (ACTUAL_USER_TABLE_NAME), -1, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when writting TABLENAME into ADARANGE");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;

        ADA_SRCHA (RANGE_DESCR, "COLNAME   ", ATTINX);
        ADA_PUTA (RANGE_DESCR, ATTINX,
                CONVERSION.F77_STRING (COLNAME), -1, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when writting COLNAME into ADARANGE");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;

        ADA_SRCHA (RANGE_DESCR, "MINVALUE  ", ATTINX);
        ADA_PUTA (RANGE_DESCR, ATTINX,
                CONVERSION.F77_STRING (MINVALUE), -1, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when writting MINVALUE into ADARANGE");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;

        ADA_SRCHA (RANGE_DESCR, "MAXVALUE  ", ATTINX);
        ADA_PUTA (RANGE_DESCR, ATTINX,
                CONVERSION.F77_STRING (MAXVALUE), -1, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when writting MAXVALUE into ADARANGE");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;


        ADA_INSRTT (RANGE_DESCR, RANGE_TIDD, RTN);
                -- add it to the table
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when adding a row to ADARANGE");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;

    end PUT_RANGE;


                         ----------------
                         -- PUT_RECORD --
                         ----------------
    procedure PUT_RECORD (RECORD_NAME, COMPONENT : STRING) is
        ATTINX, RTN : INTEGER;    begin

                -- build the temporary row
        ADA_SRCHA (RECORD_DESCR, "TABLENAME ", ATTINX);
        ADA_PUTA (RECORD_DESCR, ATTINX,
                CONVERSION.F77_STRING (ACTUAL_USER_TABLE_NAME), -1, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when writting TABLENAME into ADARECORD");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;

        ADA_SRCHA (RECORD_DESCR, "RECORDNAME", ATTINX);
        ADA_PUTA (RECORD_DESCR, ATTINX,
                CONVERSION.F77_STRING (RECORD_NAME), -1, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when writting RECORDNAME into ADARECORD");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;

        ADA_SRCHA (RECORD_DESCR, "COMPONENT ", ATTINX);
        ADA_PUTA (RECORD_DESCR, ATTINX,
                CONVERSION.F77_STRING (COMPONENT), -1, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when writting COMPONENT into ADARECORD");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;

        ADA_INSRTT (RECORD_DESCR, RECORD_TIDD, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when adding a row to ADARECORD");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;
    end PUT_RECORD;


                          --------------
                          -- PUT_ENUM --
                          --------------
    procedure PUT_ENUM (COLNAME      : STRING;
                        VALUE        : INTEGER;
                        IMAGE_STRING : STRING) is
        ATTINX, RTN : INTEGER;
        VALUE2 : INTEGER_ARRAY_TYPE (1 .. 1);
    begin

                -- build the temporary row
        ADA_SRCHA (ENUM_DESCR, "TABLENAME ", ATTINX);
        ADA_PUTA (ENUM_DESCR, ATTINX,
                CONVERSION.F77_STRING (ACTUAL_USER_TABLE_NAME), -1, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when writting TABLENAME into ADAENUM");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;
        ADA_SRCHA (ENUM_DESCR, "COLNAME   ", ATTINX);
        ADA_PUTA (ENUM_DESCR, ATTINX,
                CONVERSION.F77_STRING (COLNAME), -1, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when writting COLNAME into ADAENUM");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;

        VALUE2 (1) := VALUE;
        ADA_SRCHA (ENUM_DESCR, "VALUE     ", ATTINX);
        ADA_PUTA (ENUM_DESCR, ATTINX,
                VALUE2, -1, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when writting VALUE into ADAENUM");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;

        ADA_SRCHA (ENUM_DESCR, "IMAGE     ", ATTINX);
        ADA_PUTA (ENUM_DESCR, ATTINX,
                CONVERSION.F77_STRING (IMAGE_STRING), -1, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when writting IMAGE into ADAENUM");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;

        ADA_INSRTT (ENUM_DESCR, ENUM_TIDD, RTN);
        if RTN /= 0 then
            UTILITIES.OUTPUT_MESSAGE ("Ada interface : " &
            "internal error when adding a row to ADAENUM");
            raise LL_DAMES.X_INTERNAL_ERROR;
        end if;
    end PUT_ENUM;



                       ---------------------
                       -- CLOSE_ADA_TABLE --
                       ---------------------
    procedure CLOSE_ADA_TABLE is
        RTN : INTEGER;
    begin
      if TABLES_EXIST then
        ADA_CLOSER (DESCR);
      end if;
    end CLOSE_ADA_TABLE;



                      -----------------------
                      -- UNLOCK_ADA_TABLES --
                      -----------------------
    procedure UNLOCK_ADA_TABLES is
    begin
        ADA_CLRELS;
        ADA_DUNLK;
    end UNLOCK_ADA_TABLES;

end ADA_TABLES;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--parse.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with CONSTANTS;
use CONSTANTS;

with F77_CALLABLES;

with ADA_TABLES;

package body PARSE is

    CURRENT : POSITIVE;
        -- this index will be used as a pointer to the character
        -- being currently analysed


                            -----------
                            -- ERROR --
                            -----------
    procedure ERROR is
        -- ERROR is called when a syntax error is found

    begin
        raise X_SYNTAX_ERROR;
    end ERROR;


                         ----------------
                         -- UPPER_CASE --
                         ----------------
    procedure UPPER_CASE (TEXT : in out STRING) is
        -- UPPER_CASE is used to change in situ all lower_case letters
        -- of TEXT into their upper_case equivalent
    begin
        for I in 1 .. TEXT'LENGTH loop
            if TEXT (I) >= 'a' then
                TEXT (I) := CHARACTER'VAL (CHARACTER'POS (TEXT (I)) - 32);
            end if;
        end loop;
    end UPPER_CASE;


                      -----------------------
                      -- PARSE_FIRST_LEVEL --
                      -----------------------
    procedure PARSE_FIRST_LEVEL (COLUMN_LIST : STRING; RCKEY : INTEGER) is

        COLUMN_NAME : STRING (1 .. 12);
        COLUMN_TYPE : INTEGER;
        COLUMN_LENGTH : INTEGER;
        DOMAIN_NAME : constant STRING :=
                         (1 .. 4 => ASCII.NUL, 5 .. 12 => ' ');
        RTN : INTEGER;
            -- these five items and RCKEY are the arguments of the
            -- ADDATR access procedure; they are filled during the
            -- parsing of COLUMN_LIST.

        COLUMN_LIST_COPY : STRING (1 .. COLUMN_LIST'LENGTH + 8);
            -- a significantly longer string than COLUMN_LIST is needed
            -- in order to analyse COLUMN_LIST without risk for
            -- constraint_error due to the index, and in order too to
            -- append a particular symbol (here a '$') at the end of the
            -- sentence to be analysed.

                          --------------
                          -- IS_RANGE --
                          --------------
        function IS_RANGE return BOOLEAN is
            -- return TRUE if the current token is the keyword RANGE,
            -- and FALSE otherwise.

        begin
            if COLUMN_LIST_COPY (CURRENT .. CURRENT + 4) = "RANGE" then
                return TRUE;
            else
                return FALSE;
            end if;
        end IS_RANGE;


                          ---------------
                          -- IS_STRING --
                          ---------------
        function IS_STRING return BOOLEAN is
            -- return TRUE if the current token is the keyword STRING,
            -- and FALSE otherwise.

        begin
            if COLUMN_LIST_COPY (CURRENT .. CURRENT + 5) = "STRING" and
               COLUMN_LIST_COPY (CURRENT + 6) /= '.' and
               COLUMN_LIST_COPY (CURRENT + 6) /= '=' and
               COLUMN_LIST_COPY (CURRENT + 6) /= '_' and
               (COLUMN_LIST_COPY (CURRENT + 6) < 'A' or
                COLUMN_LIST_COPY (CURRENT + 6) > 'Z') and
               (COLUMN_LIST_COPY (CURRENT + 6) < '0' or
                COLUMN_LIST_COPY (CURRENT + 6) > '9') then
                return TRUE;
            else
                return FALSE;
            end if;
        end IS_STRING;


                          --------------
                          -- IS_FLOAT --
                          --------------
        function IS_FLOAT return BOOLEAN is
            -- return TRUE if the current token is the keyword FLOAT,
            -- and FALSE otherwise.

        begin
            if COLUMN_LIST_COPY (CURRENT .. CURRENT + 4) = "FLOAT" and
               COLUMN_LIST_COPY (CURRENT + 5) /= '.' and
               COLUMN_LIST_COPY (CURRENT + 5) /= '=' and
               COLUMN_LIST_COPY (CURRENT + 5) /= '_' and
               (COLUMN_LIST_COPY (CURRENT + 5) < 'A' or
                COLUMN_LIST_COPY (CURRENT + 5) > 'Z') and
               (COLUMN_LIST_COPY (CURRENT + 5) < '0' or
                COLUMN_LIST_COPY (CURRENT + 5) > '9') then
                return TRUE;
            else
                return FALSE;
            end if;
        end IS_FLOAT;

                         ----------------
                         -- IS_INTEGER --
                         ----------------
        function IS_INTEGER return BOOLEAN is
            -- return TRUE if the current token is the keyword INTEGER,
            -- and FALSE otherwise.

        begin
            if COLUMN_LIST_COPY (CURRENT .. CURRENT + 6) = "INTEGER" and
               COLUMN_LIST_COPY (CURRENT + 7) /= '.' and
               COLUMN_LIST_COPY (CURRENT + 7) /= '=' and
               COLUMN_LIST_COPY (CURRENT + 7) /= '_' and
               (COLUMN_LIST_COPY (CURRENT + 7) < 'A' or
                COLUMN_LIST_COPY (CURRENT + 7) > 'Z') and
               (COLUMN_LIST_COPY (CURRENT + 7) < '0' or
                COLUMN_LIST_COPY (CURRENT + 7) > '9') then
                return TRUE;
            else
                return FALSE;
            end if;
        end IS_INTEGER;


                     -----------------------
                     -- IS_NATURAL_NUMBER --
                     -----------------------
        function IS_NATURAL_NUMBER return BOOLEAN is
            -- return TRUE if the current token is a natural number,
            -- and FALSE otherwise.

        begin
            if COLUMN_LIST_COPY (CURRENT) >= '0' and
               COLUMN_LIST_COPY (CURRENT) <= '9' then
                return TRUE;
            else
                return FALSE;
            end if;
        end IS_NATURAL_NUMBER;



                          --------------
                          -- GO_AHEAD --
                          --------------
        procedure GO_AHEAD is
            -- jump to the following token.

        begin
            CURRENT := CURRENT + 1;

            while COLUMN_LIST_COPY (CURRENT) /= ' ' and
                  COLUMN_LIST_COPY (CURRENT) /= ';' and
                  COLUMN_LIST_COPY (CURRENT) /= '$' and
                  COLUMN_LIST_COPY (CURRENT) /= ',' and
                  COLUMN_LIST_COPY (CURRENT) /= '(' and
                  COLUMN_LIST_COPY (CURRENT) /= ')' and
                  COLUMN_LIST_COPY (CURRENT .. CURRENT + 1) /= ".." loop
                CURRENT := CURRENT + 1;
            end loop;
            while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                CURRENT := CURRENT + 1;
            end loop;
        end GO_AHEAD;


                            -----------
                            -- VALUE --
                            -----------
        procedure VALUE is
            -- VALUE recognizes a value of a range constraint.

        begin
            GO_AHEAD;
        end VALUE;


                         -----------------
                         -- TWO_PERIODS --
                         -----------------
        procedure TWO_PERIODS is
            -- TWO_PERIODS recognizes the two periods between the two
            -- values of a range constraint.

        begin
            if COLUMN_LIST_COPY (CURRENT .. CURRENT + 1) = ".." then
                CURRENT := CURRENT + 2;
                while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                    CURRENT := CURRENT + 1;
                end loop;

            else
                ERROR;
            end if;
        end TWO_PERIODS;


                         ----------------
                         -- CONSTRAINT --
                         ----------------
        procedure CONSTRAINT is
            -- CONSTRAINT recognizes a range constraint.

        begin
            if IS_RANGE then
                GO_AHEAD;
                VALUE;
                TWO_PERIODS;
                VALUE;
            end if;
        end CONSTRAINT;

                 --------------------------------
                 -- INDEX_CONSTRAINT_BEGINNING --
                 --------------------------------
        procedure INDEX_CONSTRAINT_BEGINNING is
            -- INDEX_CONSTRAINT_BEGINNING recognizes the beginning of a
            -- size specification for a character string, i.e. the
            -- following items :
            --          (1..
            -- which are normally followed by a positive number and a
            -- right parenthesis, such as :
            --          (1..n)

        begin
            CURRENT := CURRENT + 1;

            while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                CURRENT := CURRENT + 1;
            end loop;

            if COLUMN_LIST_COPY (CURRENT) = '1' then
                CURRENT := CURRENT + 1;
            else
                ERROR;
            end if;

            while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                CURRENT := CURRENT + 1;
            end loop;

            if COLUMN_LIST_COPY (CURRENT .. CURRENT + 1) = ".." then
                CURRENT := CURRENT + 2;
            else
                ERROR;
            end if;

            while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                CURRENT := CURRENT + 1;
            end loop;
        end INDEX_CONSTRAINT_BEGINNING;



                      -----------------------
                      -- RIGHT_PARENTHESIS --
                      -----------------------
        procedure RIGHT_PARENTHESIS is
            -- recognize a right parenthesis

        begin
            if COLUMN_LIST_COPY (CURRENT) = ')' then
                GO_AHEAD;
            else
                ERROR;
            end if;
        end RIGHT_PARENTHESIS;

                         ----------------
                         -- ENUM_IMAGE --
                         ----------------
        procedure ENUM_IMAGE is
            -- ENUM_IMAGE recognizes an item of an enumeration list;
            -- in fact, it accepts any word composed of letters, digits
            -- and underscores, without taking care of their order (for
            -- instance, a word beginning with an underscore or a digit
            -- will be accepted, another containing two consecutive
            -- underscores will be accepted too).

            SAVE_CURRENT : POSITIVE;

        begin
            SAVE_CURRENT := CURRENT;

            while COLUMN_LIST_COPY (CURRENT) = '_' or
                  (COLUMN_LIST_COPY (CURRENT) >= '0' and
                   COLUMN_LIST_COPY (CURRENT) <= '9') or
                  (COLUMN_LIST_COPY (CURRENT) >= 'A' and
                   COLUMN_LIST_COPY (CURRENT) <= 'Z') loop
                CURRENT := CURRENT + 1;
            end loop;

            if CURRENT - SAVE_CURRENT > IMAGE_SZ then
                    -- more than IMAGE_SZ characters long image

                COLUMN_LENGTH := IMAGE_SZ;
            else
                    -- one to IMAGE_SZ characters long image

                if CURRENT - SAVE_CURRENT > COLUMN_LENGTH then
                        -- the currently recognized image is the longest
                        -- of those which have been recognized before.

                    COLUMN_LENGTH := CURRENT - SAVE_CURRENT;
                end if;
            end if;

            while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                CURRENT := CURRENT + 1;
            end loop;
        end ENUM_IMAGE;


                        ------------------
                        -- SCALAR_DESCR --
                        ------------------
        procedure SCALAR_DESCR is
            -- SCALAR_DESCR recognizes a scalar type, i.e. :
            --  STRING (1 .. 10) by default;
            --  STRING (1 .. n);
            --  FLOAT;
            --  INTEGER (n bytes wide, n being specified, or being
            --          chosen to 4 by default);
            --  an enumeration type, defined by items enclosed in
            --          parentheses.
            -- Each of these types can have a range constraint, which
            -- is recognized by the above defined CONSTRAINT procedure,
            -- except the STRING type.
            RECOGNIZED_NUMBER : INTEGER;
                -- RECOGNIZED_NUMBER is a number recognized by
                -- NATURAL_NUMBER and used as string or integer length


                       --------------------
                       -- NATURAL_NUMBER --
                       --------------------
            procedure NATURAL_NUMBER is
                -- recognize a natural number

                SAVE_CURRENT : POSITIVE;

            begin
                SAVE_CURRENT := CURRENT;

                while COLUMN_LIST_COPY (CURRENT) >= '0' and
                      COLUMN_LIST_COPY (CURRENT) <= '9' loop
                    CURRENT := CURRENT + 1;
                end loop;

                        -- store the recognized number in RECOGNIZED_NUMBER
                RECOGNIZED_NUMBER := INTEGER'VALUE
                        (COLUMN_LIST_COPY (SAVE_CURRENT .. CURRENT - 1));

                while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                    CURRENT := CURRENT + 1;
                end loop;
            end NATURAL_NUMBER;

        begin
            if IS_STRING then
                        -- the type is a STRING type

                GO_AHEAD;

                        -- store 5 in COLUMN_TYPE to denote a STRING
                COLUMN_TYPE := 5;

                if COLUMN_LIST_COPY (CURRENT) = '(' then
                        -- this string type has an index constraint

                    INDEX_CONSTRAINT_BEGINNING;
                    NATURAL_NUMBER;
                    RIGHT_PARENTHESIS;

                        -- store the number recognized by NATURAL_NUMBER
                        -- in COLUMN_LENGTH
                    COLUMN_LENGTH := RECOGNIZED_NUMBER;

                else
                        -- store the default length in COLUMN_LENGTH
                    COLUMN_LENGTH := 10;

                end if;
            elsif IS_FLOAT then
                        -- the type is a FLOAT type

                GO_AHEAD;

                        -- store 2 in COLUMN_TYPE to denote FLOAT
                COLUMN_TYPE := 2;

                        -- store the float length in COLUMN_LENGTH
                COLUMN_LENGTH := 4;

                CONSTRAINT;

            elsif IS_INTEGER then
                        -- the type is an INTEGER type

                GO_AHEAD;

                        -- store 1 in COLUMN_TYPE to denote an INTEGER
                COLUMN_TYPE := 1;

                COLUMN_LENGTH := 4;

--------------------------------------------------------------------------
--
--      Following comments must be executed if the byte length of
-- INTEGER type can be chosen; otherwise, 32 bits is chosen for
-- default length.
--
--if IS_NATURAL_NUMBER then
--      -- this INTEGER type has a size specification
--
--    NATURAL_NUMBER;
--
--      -- store in COLUMN_LENGTH the size (in bytes)
--      -- recognized by NATURAL_NUMBER (size in bytes)
--    COLUMN_LENGTH := RECOGNIZED_NUMBER;
--
--else
--      -- store in COLUMN_LENGTH the default size
--    COLUMN_LENGTH := 4;
--end if;
--
--------------------------------------------------------------------------

                CONSTRAINT;

            elsif COLUMN_LIST_COPY (CURRENT) = '(' then
                        -- the type is an enumeration type

                CURRENT := CURRENT + 1;

                while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                    CURRENT := CURRENT + 1;
                end loop;

                COLUMN_LENGTH := 1;
                        -- the COLUMN_LENGTH variable will be updated
                        -- by the ENUM_IMAGE call's up to the greater
                        -- length of all images of the enumeration type
                        -- currently recognized.
                ENUM_IMAGE;
                        -- recognize the first item

                while COLUMN_LIST_COPY (CURRENT) = ',' loop
                        -- than recognize each of the following items

                    CURRENT := CURRENT + 1;

                    while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                        CURRENT := CURRENT + 1;
                    end loop;

                    ENUM_IMAGE;
                end loop;

                if COLUMN_LIST_COPY (CURRENT) = ')' then
                        -- check that the enumeration list ends with a
                        -- right parenthesis.

                    CURRENT := CURRENT + 1;

                    while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                        CURRENT := CURRENT + 1;
                    end loop;
                else
                        -- the enumeration list does not end with a
                        -- right parenthesis.

                    ERROR;
                end if;

                        -- store 5 in COLUMN_TYPE to denote a STRING
                COLUMN_TYPE := 5;
                        -- the length has been stored in COLUMN_LENGTH
                        -- by the previous calls to ENUM_IMAGE

                CONSTRAINT;
            else
                    -- the type is a character string 10 characters long

                COLUMN_TYPE := 5;
                COLUMN_LENGTH := 10;
            end if;

                -- let's add the recognized attribute to the table being
                -- created :
            F77_CALLABLES.ADA_ADDATR (RCKEY,
                                      COLUMN_NAME,
                                      COLUMN_TYPE,
                                      COLUMN_LENGTH,
                                      DOMAIN_NAME,
                                      RTN);
            if RTN /= 0 then
                ERROR;
            end if;

        end SCALAR_DESCR;

                            ----------
                            -- NAME --
                            ----------
        procedure NAME is
                -- NAME recognizes a column name (either an Ada or a
                -- DAMES column, since Ada record columns are composed
                -- of several DAMES columns, one for each component).
                -- Such an identifier must begin with a letter, which
                -- is followed by other letters, digits, periods,
                -- equal signs, or underscores.

            SAVE_CURRENT : POSITIVE;

        begin
            if COLUMN_LIST_COPY (CURRENT) >= 'A' and
               COLUMN_LIST_COPY (CURRENT) <= 'Z' then

                SAVE_CURRENT := CURRENT;
                CURRENT := CURRENT + 1;

                while (COLUMN_LIST_COPY (CURRENT) >= 'A' and
                       COLUMN_LIST_COPY (CURRENT) <= 'Z') or
                      (COLUMN_LIST_COPY (CURRENT) >= '0' and
                       COLUMN_LIST_COPY (CURRENT) <= '9') or
                      COLUMN_LIST_COPY (CURRENT) = '_' or
                      COLUMN_LIST_COPY (CURRENT) = '.' or
                      COLUMN_LIST_COPY (CURRENT) = '=' loop
                    CURRENT := CURRENT + 1;
                end loop;

                        -- store now in COLUMN_NAME the recognized name
                if CURRENT - SAVE_CURRENT < 11 then
                        -- one to ten characters long name
                    COLUMN_NAME :=
                        COLUMN_LIST_COPY (SAVE_CURRENT .. CURRENT - 1)
                        &      (CURRENT - SAVE_CURRENT + 1 .. 12 => ' ');
                else
                        -- more than ten characters long name
                    COLUMN_NAME := COLUMN_LIST_COPY
                        (SAVE_CURRENT .. SAVE_CURRENT + 9) & "  ";
                end if;

                while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                    CURRENT := CURRENT + 1;
                end loop;
            else
                    -- the current token does not begin with a letter

                ERROR;
            end if;
        end NAME;


                       ---------------------
                       -- IS_SCALAR_DESCR --
                       ---------------------
        function IS_SCALAR_DESCR return BOOLEAN is
                -- IS_SCALAR_DESCR returns TRUE if the current token is
                -- the beginning of a type specification, and returns
                -- FALSE otherwise (if the sentence is syntactically
                -- correct, it means the token is a column name).
        begin
            if COLUMN_LIST_COPY (CURRENT) = ',' or
               COLUMN_LIST_COPY (CURRENT) = ';' or
               COLUMN_LIST_COPY (CURRENT) = '$' or
               IS_STRING or
               IS_FLOAT or IS_INTEGER or COLUMN_LIST_COPY (CURRENT) = '(' then
                return TRUE;
            else
                return FALSE;
            end if;
        end IS_SCALAR_DESCR;



                        ------------------
                        -- COLUMN_DESCR --
                        ------------------
        procedure COLUMN_DESCR is
                -- COLUMN_DESCR recognizes a column descriptor, which
                -- is a column name followed by a scalar descriptor
                -- or a record descriptor.

        begin
            NAME;

            if IS_SCALAR_DESCR then
                SCALAR_DESCR;
            else
                NAME;
                SCALAR_DESCR;

                while COLUMN_LIST_COPY (CURRENT) = ',' loop
                    CURRENT := CURRENT + 1;

                    while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                        CURRENT := CURRENT + 1;
                    end loop;

                    NAME;
                    SCALAR_DESCR;
                end loop;
            end if;
        end COLUMN_DESCR;    begin
        COLUMN_LIST_COPY := COLUMN_LIST & "$       ";
        UPPER_CASE (COLUMN_LIST_COPY);
        CURRENT := 1;

        while COLUMN_LIST_COPY (CURRENT) = ' ' loop
            CURRENT := CURRENT + 1;
        end loop;

        COLUMN_DESCR;

        while COLUMN_LIST_COPY (CURRENT) = ';' loop
            CURRENT := CURRENT + 1;

            while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                CURRENT := CURRENT + 1;
            end loop;

            COLUMN_DESCR;
        end loop;

        if COLUMN_LIST_COPY (CURRENT) /= '$' then
            ERROR;
        end if;

    end PARSE_FIRST_LEVEL;



                     ------------------------
                     -- PARSE_SECOND_LEVEL --
                     ------------------------
    procedure PARSE_SECOND_LEVEL (COLUMN_LIST : STRING) is

        COLUMN_NAME : STRING (1 .. 12);
        RECORD_NAME : STRING (1 .. 12) := (others => ' ');
        MINVALUE, MAXVALUE : STRING (1 .. RANGE_SIZE);
        ENUM_VALUE : INTEGER;
        ENUM_LITERAL : STRING (1 .. IMAGE_SZ);
            -- these six items are the arguments of the ADA_TABLES
            -- package procedures; they are used to update the three
            -- reserved tables : ADARANGE, ADARECORD and ADAENUM.
            -- They are filled during the parsing of COLUMN_LIST.

        COLUMN_LIST_COPY : STRING (1 .. COLUMN_LIST'LENGTH + 8);
            -- a significantly longer string than COLUMN_LIST is needed
            -- in order to analyse COLUMN_LIST without risk for
            -- constraint_error due to the index, and in order too to
            -- append a particular symbol (here a '$') at the end of the
            -- sentence to be analysed.


                          --------------
                          -- IS_RANGE --
                          --------------
        function IS_RANGE return BOOLEAN is
            -- return TRUE if the current token is the keyword RANGE,
            -- and FALSE otherwise.

        begin
            if COLUMN_LIST_COPY (CURRENT .. CURRENT + 4) = "RANGE" then
                return TRUE;
            else
                return FALSE;
            end if;
        end IS_RANGE;


                          ---------------
                          -- IS_STRING --
                          ---------------
        function IS_STRING return BOOLEAN is
            -- return TRUE if the current token is the keyword STRING,
            -- and FALSE otherwise.

        begin
            if COLUMN_LIST_COPY (CURRENT .. CURRENT + 5) = "STRING" and
               COLUMN_LIST_COPY (CURRENT + 6) /= '.' and
               COLUMN_LIST_COPY (CURRENT + 6) /= '=' and
               COLUMN_LIST_COPY (CURRENT + 6) /= '_' and
               (COLUMN_LIST_COPY (CURRENT + 6) < 'A' or
                COLUMN_LIST_COPY (CURRENT + 6) > 'Z') and
               (COLUMN_LIST_COPY (CURRENT + 6) < '0' or
                COLUMN_LIST_COPY (CURRENT + 6) > '9') then
                return TRUE;
            else
                return FALSE;
            end if;
        end IS_STRING;

                          --------------
                          -- IS_FLOAT --
                          --------------
        function IS_FLOAT return BOOLEAN is
            -- return TRUE if the current token is the keyword FLOAT,
            -- and FALSE otherwise.

        begin
            if COLUMN_LIST_COPY (CURRENT .. CURRENT + 4) = "FLOAT" and
               COLUMN_LIST_COPY (CURRENT + 5) /= '.' and
               COLUMN_LIST_COPY (CURRENT + 5) /= '=' and
               COLUMN_LIST_COPY (CURRENT + 5) /= '_' and
               (COLUMN_LIST_COPY (CURRENT + 5) < 'A' or
                COLUMN_LIST_COPY (CURRENT + 5) > 'Z') and
               (COLUMN_LIST_COPY (CURRENT + 5) < '0' or
                COLUMN_LIST_COPY (CURRENT + 5) > '9') then
                return TRUE;
            else
                return FALSE;
            end if;
        end IS_FLOAT;


                         ----------------
                         -- IS_INTEGER --
                         ----------------
        function IS_INTEGER return BOOLEAN is
            -- return TRUE if the current token is the keyword INTEGER,
            -- and FALSE otherwise.

        begin
            if COLUMN_LIST_COPY (CURRENT .. CURRENT + 6) = "INTEGER" and
               COLUMN_LIST_COPY (CURRENT + 7) /= '.' and
               COLUMN_LIST_COPY (CURRENT + 7) /= '=' and
               COLUMN_LIST_COPY (CURRENT + 7) /= '_' and
               (COLUMN_LIST_COPY (CURRENT + 7) < 'A' or
                COLUMN_LIST_COPY (CURRENT + 7) > 'Z') and
               (COLUMN_LIST_COPY (CURRENT + 7) < '0' or
                COLUMN_LIST_COPY (CURRENT + 7) > '9') then
                return TRUE;
            else
                return FALSE;
            end if;
        end IS_INTEGER;


                     -----------------------
                     -- IS_NATURAL_NUMBER --
                     -----------------------
        function IS_NATURAL_NUMBER return BOOLEAN is
            -- return TRUE if the current token is a natural number,
            -- and FALSE otherwise.

        begin
            if COLUMN_LIST_COPY (CURRENT) >= '0' and
               COLUMN_LIST_COPY (CURRENT) <= '9' then
                return TRUE;
            else
                return FALSE;
            end if;
        end IS_NATURAL_NUMBER;

                          --------------
                          -- GO_AHEAD --
                          --------------
        procedure GO_AHEAD is
            -- jump to the following token.

        begin
            CURRENT := CURRENT + 1;

            while COLUMN_LIST_COPY (CURRENT) /= ' ' and
                  COLUMN_LIST_COPY (CURRENT) /= ';' and
                  COLUMN_LIST_COPY (CURRENT) /= '$' and
                  COLUMN_LIST_COPY (CURRENT) /= ',' and
                  COLUMN_LIST_COPY (CURRENT) /= '(' and
                  COLUMN_LIST_COPY (CURRENT) /= ')' and
                  COLUMN_LIST_COPY (CURRENT .. CURRENT + 1) /= ".." loop
                CURRENT := CURRENT + 1;
            end loop;

            while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                CURRENT := CURRENT + 1;
            end loop;
        end GO_AHEAD;


                            ---------------
                            -- VALUE_MIN --
                            ---------------
        procedure VALUE_MIN is
            -- VALUE_MIN recognizes the first value of a range constraint.

        SAVE_CURRENT : POSITIVE;

        begin
            SAVE_CURRENT := CURRENT;
            CURRENT := CURRENT + 1;

            while COLUMN_LIST_COPY (CURRENT) /= ' ' and
                  COLUMN_LIST_COPY (CURRENT) /= ';' and
                  COLUMN_LIST_COPY (CURRENT) /= '$' and
                  COLUMN_LIST_COPY (CURRENT) /= ',' and
                  COLUMN_LIST_COPY (CURRENT) /= '(' and
                  COLUMN_LIST_COPY (CURRENT) /= ')' and
                  COLUMN_LIST_COPY (CURRENT .. CURRENT + 1) /= ".." loop
                CURRENT := CURRENT + 1;
            end loop;

                -- store now in MINVALUE the recognized value.
            if CURRENT - SAVE_CURRENT < RANGE_SIZE + 1 then
                    -- one to RANGE_SIZE characters long value.
                MINVALUE :=
                     COLUMN_LIST_COPY (SAVE_CURRENT .. CURRENT - 1)
                  &  (CURRENT - SAVE_CURRENT + 1 .. RANGE_SIZE=> ' ');
            else
                    -- more than RANGE_SIZE characters long image
                MINVALUE := COLUMN_LIST_COPY
                        (SAVE_CURRENT .. SAVE_CURRENT + RANGE_SIZE - 1);
            end if;
            while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                CURRENT := CURRENT + 1;
            end loop;
        end VALUE_MIN;


                            ---------------
                            -- VALUE_MAX --
                            ---------------
        procedure VALUE_MAX is
            -- VALUE_MAX recognizes the second value of a range constraint.

        SAVE_CURRENT : POSITIVE;

        begin
            SAVE_CURRENT := CURRENT;
            CURRENT := CURRENT + 1;

            while COLUMN_LIST_COPY (CURRENT) /= ' ' and
                  COLUMN_LIST_COPY (CURRENT) /= ';' and
                  COLUMN_LIST_COPY (CURRENT) /= '$' and
                  COLUMN_LIST_COPY (CURRENT) /= ',' and
                  COLUMN_LIST_COPY (CURRENT) /= '(' and
                  COLUMN_LIST_COPY (CURRENT) /= ')' and
                  COLUMN_LIST_COPY (CURRENT .. CURRENT + 1) /= ".." loop
                CURRENT := CURRENT + 1;
            end loop;

                -- store now in MAXVALUE the recognized value.
            if CURRENT - SAVE_CURRENT < RANGE_SIZE + 1 then
                    -- one to RANGE_SIZE characters long value.
                MAXVALUE :=
                     COLUMN_LIST_COPY (SAVE_CURRENT .. CURRENT - 1)
                  &  (CURRENT - SAVE_CURRENT + 1 .. RANGE_SIZE => ' ');
            else
                    -- more than RANGE_SIZE characters long image
                MAXVALUE := COLUMN_LIST_COPY
                        (SAVE_CURRENT .. SAVE_CURRENT + RANGE_SIZE - 1);
            end if;

            while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                CURRENT := CURRENT + 1;
            end loop;
        end VALUE_MAX;

                         -----------------
                         -- TWO_PERIODS --
                         -----------------
        procedure TWO_PERIODS is
            -- TWO_PERIODS recognizes the two periods between the two
            -- values of a range constraint.

        begin
            if COLUMN_LIST_COPY (CURRENT .. CURRENT + 1) = ".." then
                CURRENT := CURRENT + 2;
                while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                    CURRENT := CURRENT + 1;
                end loop;

            else
                ERROR;
            end if;
        end TWO_PERIODS;

                         ----------------
                         -- CONSTRAINT --
                         ----------------
        procedure CONSTRAINT is
            -- CONSTRAINT recognizes a range constraint.

        begin
            if IS_RANGE then
                GO_AHEAD;
                VALUE_MIN;
                TWO_PERIODS;
                VALUE_MAX;

                        -- store now in the ADARANGE reserved table
                        -- the above defined range constraint.
                ADA_TABLES.PUT_RANGE (COLUMN_NAME, MINVALUE, MAXVALUE);
            end if;
        end CONSTRAINT;


                 --------------------------------
                 -- INDEX_CONSTRAINT_BEGINNING --
                 --------------------------------
        procedure INDEX_CONSTRAINT_BEGINNING is
            -- INDEX_CONSTRAINT_BEGINNING recognizes the beginning of a
            -- size specification for a character string, i.e. the
            -- following items :
            --          (1..
            -- which are normally followed by a positive number and a
            -- right parenthesis, such as :
            --          (1..n)

        begin
            CURRENT := CURRENT + 1;

            while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                CURRENT := CURRENT + 1;
            end loop;

            if COLUMN_LIST_COPY (CURRENT) = '1' then
                CURRENT := CURRENT + 1;
            else
                ERROR;
            end if;

            while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                CURRENT := CURRENT + 1;
            end loop;

            if COLUMN_LIST_COPY (CURRENT .. CURRENT + 1) = ".." then
                CURRENT := CURRENT + 2;
            else
                ERROR;
            end if;

            while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                CURRENT := CURRENT + 1;
            end loop;
        end INDEX_CONSTRAINT_BEGINNING;

                      -----------------------
                      -- RIGHT_PARENTHESIS --
                      -----------------------
        procedure RIGHT_PARENTHESIS is
            -- recognize a right parenthesis

        begin
            if COLUMN_LIST_COPY (CURRENT) = ')' then
                GO_AHEAD;
            else
                ERROR;
            end if;
        end RIGHT_PARENTHESIS;


                         ----------------
                         -- ENUM_IMAGE --
                         ----------------
        procedure ENUM_IMAGE is
            -- ENUM_IMAGE recognizes an item of an enumeration list;
            -- in fact, it accepts any word composed of letters, digits
            -- and underscores, without taking care of their order (for
            -- instance, a word beginning with an underscore or a digit
            -- will be accepted, another containing two consecutive
            -- underscores will be accepted too).

        SAVE_CURRENT : POSITIVE;

        begin
            SAVE_CURRENT := CURRENT;

            while COLUMN_LIST_COPY (CURRENT) = '_' or
                  (COLUMN_LIST_COPY (CURRENT) >= '0' and
                   COLUMN_LIST_COPY (CURRENT) <= '9') or
                  (COLUMN_LIST_COPY (CURRENT) >= 'A' and
                   COLUMN_LIST_COPY (CURRENT) <= 'Z') loop
                CURRENT := CURRENT + 1;
            end loop;

                -- store now in ENUM_LITERAL the recognized image.
            if CURRENT - SAVE_CURRENT < IMAGE_SZ + 1 then
                    -- one to IMAGE_SZ characters long image
                ENUM_LITERAL :=
                     COLUMN_LIST_COPY (SAVE_CURRENT .. CURRENT - 1)
                  &  (CURRENT - SAVE_CURRENT + 1 .. IMAGE_SZ => ' ');
            else
                    -- more than IMAGE_SZ characters long image
                ENUM_LITERAL := COLUMN_LIST_COPY
                        (SAVE_CURRENT .. SAVE_CURRENT + IMAGE_SZ - 1);
            end if;

                -- store now in the ADAENUM reserved table the item
                -- just above recognized.
            ADA_TABLES.PUT_ENUM (COLUMN_NAME, ENUM_VALUE, ENUM_LITERAL);

            while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                CURRENT := CURRENT + 1;
            end loop;
        end ENUM_IMAGE;

                        ------------------
                        -- SCALAR_DESCR --
                        ------------------
        procedure SCALAR_DESCR is
            -- SCALAR_DESCR recognizes a scalar type, i.e. :
            --  STRING (1 .. 10) by default;
            --  STRING (1 .. n);
            --  FLOAT;
            --  INTEGER (n bytes wide, n being specified, or being
            --          chosen to 4 by default);
            --  an enumeration type, defined by items enclosed in
            --          parentheses.
            -- Each of these types can have a range constraint, which
            -- is recognized by the above defined CONSTRAINT procedure,
            -- except the STRING type.


                       --------------------
                       -- NATURAL_NUMBER --
                       --------------------
            procedure NATURAL_NUMBER is
                -- recognize a natural number

            begin

                while COLUMN_LIST_COPY (CURRENT) >= '0' and
                      COLUMN_LIST_COPY (CURRENT) <= '9' loop
                    CURRENT := CURRENT + 1;
                end loop;

                while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                    CURRENT := CURRENT + 1;
                end loop;
            end NATURAL_NUMBER;

        begin
            if IS_STRING then
                        -- the type is a STRING type

                GO_AHEAD;

                if COLUMN_LIST_COPY (CURRENT) = '(' then
                        -- this string type has an index constraint

                    INDEX_CONSTRAINT_BEGINNING;
                    NATURAL_NUMBER;
                    RIGHT_PARENTHESIS;

                end if;

            elsif IS_FLOAT then
                        -- the type is a FLOAT type

                GO_AHEAD;

                CONSTRAINT;

            elsif IS_INTEGER then
                        -- the type is an INTEGER type

                GO_AHEAD;
--------------------------------------------------------------------------
--
--      Following comments must be executed if the byte length of
-- INTEGER type can be chosen; otherwise, 32 bits is chosen for
-- default length.
--
--              if IS_NATURAL_NUMBER then
--                      -- this INTEGER type has a size specification
--
--                  NATURAL_NUMBER;
--
--              end if;
--
--------------------------------------------------------------------------

                CONSTRAINT;

            elsif COLUMN_LIST_COPY (CURRENT) = '(' then
                        -- the type is an enumeration type

                CURRENT := CURRENT + 1;

                while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                    CURRENT := CURRENT + 1;
                end loop;

                ENUM_VALUE := 0;
                ENUM_IMAGE;
                        -- recognize the first item

                while COLUMN_LIST_COPY (CURRENT) = ',' loop
                        -- than recognize each of the following items

                    CURRENT := CURRENT + 1;

                    while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                        CURRENT := CURRENT + 1;
                    end loop;

                    ENUM_VALUE := ENUM_VALUE + 1;
                    ENUM_IMAGE;
                end loop;

                if COLUMN_LIST_COPY (CURRENT) = ')' then
                        -- check that the enumeration list ends with a
                        -- right parenthesis.

                    CURRENT := CURRENT + 1;

                    while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                        CURRENT := CURRENT + 1;
                    end loop;
                else
                        -- the enumeration list does not end with a
                        -- right parenthesis.

                    ERROR;
                end if;

                CONSTRAINT;
            end if;

        end SCALAR_DESCR;

                            ----------
                            -- NAME --
                            ----------
        procedure NAME is
                -- NAME recognizes a column name (either an Ada or a
                -- DAMES column, since Ada record columns are composed
                -- of several DAMES columns, one for each component).
                -- Such an identifier must begin with a letter, which
                -- is followed by other letters, digits, periods,
                -- equal signs, or underscores.

            SAVE_CURRENT : POSITIVE;

        begin
            if COLUMN_LIST_COPY (CURRENT) >= 'A' and
               COLUMN_LIST_COPY (CURRENT) <= 'Z' then

                SAVE_CURRENT := CURRENT;
                CURRENT := CURRENT + 1;

                while (COLUMN_LIST_COPY (CURRENT) >= 'A' and
                       COLUMN_LIST_COPY (CURRENT) <= 'Z') or
                      (COLUMN_LIST_COPY (CURRENT) >= '0' and
                       COLUMN_LIST_COPY (CURRENT) <= '9') or
                      COLUMN_LIST_COPY (CURRENT) = '_' or
                      COLUMN_LIST_COPY (CURRENT) = '.' or
                      COLUMN_LIST_COPY (CURRENT) = '=' loop
                    CURRENT := CURRENT + 1;
                end loop;

                        -- store now in COLUMN_NAME the recognized name
                if CURRENT - SAVE_CURRENT < 11 then
                        -- one to ten characters long name
                    COLUMN_NAME :=
                        COLUMN_LIST_COPY (SAVE_CURRENT .. CURRENT - 1)
                        &      (CURRENT - SAVE_CURRENT + 1 .. 12 => ' ');
                else
                        -- more than ten characters long name
                    COLUMN_NAME := COLUMN_LIST_COPY
                        (SAVE_CURRENT .. SAVE_CURRENT + 9) & "  ";
                end if;

                while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                    CURRENT := CURRENT + 1;
                end loop;
            else
                    -- the current token does not begin with a letter

                ERROR;
            end if;
        end NAME;


                       ---------------------
                       -- IS_SCALAR_DESCR --
                       ---------------------
        function IS_SCALAR_DESCR return BOOLEAN is
                -- IS_SCALAR_DESCR returns TRUE if the current token is
                -- the beginning of a type specification, and returns
                -- FALSE otherwise (if the sentence is syntactically
                -- correct, it means the token is a column name).
        begin
            if COLUMN_LIST_COPY (CURRENT) = ',' or
               COLUMN_LIST_COPY (CURRENT) = ';' or
               COLUMN_LIST_COPY (CURRENT) = '$' or
               IS_STRING or
               IS_FLOAT or IS_INTEGER or COLUMN_LIST_COPY (CURRENT) = '(' then
                return TRUE;
            else
                return FALSE;
            end if;
        end IS_SCALAR_DESCR;



                        ------------------
                        -- COLUMN_DESCR --
                        ------------------
        procedure COLUMN_DESCR is
                -- COLUMN_DESCR recognizes a column descriptor, which
                -- is a column name followed by a scalar descriptor
                -- or a record descriptor.

        begin
            NAME;

            if IS_SCALAR_DESCR then
                SCALAR_DESCR;
            else
                RECORD_NAME := COLUMN_NAME;
                        -- The variable COLUMN_NAME, which in fact is
                        -- the  name  of  a  record  column  has  been
                        -- previously recognized by the NAME procedure.

                NAME;
                SCALAR_DESCR;

                        -- since the current column is a record column
                        -- (i.e. several DAMES columns linked together),
                        -- it is to be recorded in the ADARANGE reserved
                        -- table for each of the component column.
                ADA_TABLES.PUT_RECORD (RECORD_NAME, COLUMN_NAME);

                while COLUMN_LIST_COPY (CURRENT) = ',' loop
                    CURRENT := CURRENT + 1;

                    while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                        CURRENT := CURRENT + 1;
                    end loop;

                    NAME;
                    SCALAR_DESCR;
                    ADA_TABLES.PUT_RECORD (RECORD_NAME, COLUMN_NAME);
                end loop;
            end if;
        end COLUMN_DESCR;    begin
        COLUMN_LIST_COPY := COLUMN_LIST & "$       ";
        UPPER_CASE (COLUMN_LIST_COPY);
        CURRENT := 1;

        while COLUMN_LIST_COPY (CURRENT) = ' ' loop
            CURRENT := CURRENT + 1;
        end loop;

        COLUMN_DESCR;

        while COLUMN_LIST_COPY (CURRENT) = ';' loop
            CURRENT := CURRENT + 1;

            while COLUMN_LIST_COPY (CURRENT) = ' ' loop
                CURRENT := CURRENT + 1;
            end loop;

            COLUMN_DESCR;
        end loop;

        if COLUMN_LIST_COPY (CURRENT) /= '$' then
            ERROR;
        end if;

    end PARSE_SECOND_LEVEL;

end PARSE;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--damespec.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package DAMES is

    X_DAMES_ERROR : exception;


    procedure EXECUTE            (COMMAND : STRING);
--************************************************************************
--**                                                                    **
--**      UNIT NAME :                EXECUTE                            **
--**      ~~~~~~~~~~~                                                   **
--**                                                                    **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**  This procedure executes the DAMES command written in the COMMAND  **
--**  string (See the 'User Language manual' for the  syntax  of DAMES  **
--**  commands).                                                        **
--**  The database  processed  by  the  command  must first be open by  **
--**  using the following Ada instruction :                             **
--**  'DAMES.EXECUTE ("open DATABASE_NAME ;");'                         **
--**  where DATABASE_NAME is the name of the database to be processed,  **
--**  or  by  using  the  equivalent  Ada  instruction  :               **
--**  'DAMES.OPEN ("DATABASE_NAME");'                                   **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  COMMAND is a character string in which a command to be executed   **
--**  has previously been written; this character string  has  a  max   **
--**  size which depends on the generation of DAMES.                    **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**  X_DAMES_ERROR is raised if an error occurs during the parsing or  **
--**  execution of the COMMAND string.                                  **
--**                                                                    **
--************************************************************************

    procedure CLOSE;
--************************************************************************
--**                                                                    **
--**   UNIT NAME :               CLOSE                                  **
--**   ~~~~~~~~~~~                                                      **
--**                                                                    **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**  This procedure must be called after OPEN or EXECUTE have been used**
--**  one or several times in an Ada program.                           **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--************************************************************************

    procedure OPEN  (DB_NAME : STRING);
--************************************************************************
--**                                                                    **
--**   UNIT NAME :               OPEN                                   **
--**   ~~~~~~~~~~~                                                      **
--**                                                                    **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**  This procedure must be used to open a database to be accessed via **
--**  the embedded interface.                                           **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  DB_NAME is the name of the database to be open.                   **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**    X_DAMES_ERROR is raised if the named database cannot be opened  **
--**                                                                    **
--************************************************************************

end DAMES;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--dames.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with CONSTANTS;
        -- CONSTANTS contains the declarations of some useful constants

with F77_CALLABLES;
        -- F77_CALLABLES is the gate to be used to access the underlying
        -- Fortran77 DAMES subroutines.

with SHARE;
        -- SHARE contains two variables shared between DAMES and LL_DAMES

with DAMES_STATUS;
        -- DAMES_STATUS contains a variable which keeps in memory the
        -- current status of the DAMES embedded interface.


package body DAMES is


    procedure EXECUTE (COMMAND : STRING) is
--************************************************************************
--**                                                                    **
--**      UNIT NAME :                EXECUTE                            **
--**      ~~~~~~~~~~~                                                   **
--**                                                                    **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**                                                                    **
--**  if not EMBEDDED_INTERFACE_IS_IN_USE then                          **
--**                                                                    **
--**        -- this is the first call to EXECUTE                        **
--**                                                                    **
--**    INITIALIZE_EMBEDDED_INTERFACE;                                  **
--**  end if;                                                           **
--**                                                                    **
--**  PARSE_AND_EXECUTE (COMMAND);                                      **
--**                                                                    **
--**  if ERROR then                                                     **
--**                                                                    **
--**        -- an error occured during parsing or execution of COMMAND  **
--**                                                                    **
--**      raise X_DAMES_ERROR;                                          **
--**  end if;                                                           **
--**                                                                    **
--**  if USER_LANGUAGE_COMMAND = OPEN then                              **
--**                                                                    **
--**        -- if COMMAND is an OPEN DATABASE command, then the status  **
--**        -- must be updated                                          **
--**                                                                    **
--**    A_DATABASE_IS_OPEN := TRUE;                                     **
--**  end if;                                                           **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  COMMAND is a character string in which a command to be executed   **
--**  has previously been written; this character string  has  a  max   **
--**  size which depends on the generation of DAMES.                    **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    EMBEDDED_INTERFACE_IS_IN_USE                                    **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    EMBEDDED_INTERFACE_IS_IN_USE                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**  X_DAMES_ERROR is raised if an error occurs during the parsing or  **
--**  execution of the COMMAND string.                                  **
--**                                                                    **
--************************************************************************        INPLEN, RTN : INTEGER;
        DB_NAME : STRING (1 .. CONSTANTS.NAME_LENGTH)
                                        := (others => ' ');
        function COMMAND_IS_OPEN return BOOLEAN is

                -- COMMAND_IS_OPEN returns 'true' if the User Language sentence
                -- contained in the COMMAND character string contains the OPEN
                -- command, and returns 'false' otherwise

            CLAST    : INTEGER := COMMAND'LENGTH;
            COMMAND2 : STRING (1 .. CLAST);
            INDEX, SAVE_INDEX : INTEGER;
        begin
                -- copy COMMAND into COMMAND2 to enable its standardization
            COMMAND2 := COMMAND;
            INDEX := 1;

                -- skip all blanks
            for I in 1 .. CLAST loop
                if COMMAND2 (INDEX) = ' ' then
                    COMMAND2 (INDEX .. CLAST) :=
                      COMMAND2 (INDEX + 1 .. CLAST) & " ";
                else
                    INDEX := INDEX + 1;
                end if;
            end loop;

                -- replace all lower-case characters with their upper-case
                -- equivalent
            for I in 1 .. CLAST loop
                if COMMAND2 (I) >= 'a' then
                    COMMAND2 (I) :=
                      CHARACTER'VAL (CHARACTER'POS (COMMAND2 (I)) - 32);
                end if;
            end loop;

            INDEX := 1;

            while COMMAND2 (INDEX .. CLAST) /= (INDEX .. CLAST => ' ') loop
                    -- the User Language sentence can be composed of several
                    -- atomic commands separed with semicolons; each of these
                    -- commands is to be compared to "OPEN" until  equality
                    -- is reached.
                    -- This loop is performed one time for each atomic command

                if COMMAND2 (INDEX .. INDEX + 3) = "OPEN" then
                    INDEX := INDEX + 4;
                    SAVE_INDEX := INDEX;
                    while COMMAND2 (INDEX) /= ';' loop
                        INDEX := INDEX + 1;
                    end loop;
                    DB_NAME (1 .. INDEX - SAVE_INDEX)
                        := COMMAND2 (SAVE_INDEX .. INDEX - 1);
                    return TRUE;
                else
                        -- look now for the next semicolon (except those
                        -- included in character string literals)
                    loop
                        while COMMAND2 (INDEX) /= '"' and
                              COMMAND2 (INDEX) /= ';' loop
                            INDEX := INDEX + 1;
                        end loop;
                        INDEX := INDEX + 1;
                        exit when COMMAND2 (INDEX - 1) = ';';

                        while COMMAND2 (INDEX) /= '"' loop
                            INDEX := INDEX + 1;
                        end loop;

                        INDEX := INDEX + 1;
                    end loop;
                end if;
            end loop;

            return FALSE;
        end COMMAND_IS_OPEN;
    begin
        if not DAMES_STATUS.EMBEDDED_INTERFACE_IS_IN_USE then
            if not SHARE.A_DATABASE_IS_OPEN then
                F77_CALLABLES.ADA_STARTDM;
            end if;
            F77_CALLABLES.ADA_LEXINT;
            DAMES_STATUS.EMBEDDED_INTERFACE_IS_IN_USE := TRUE;
        end if;

        INPLEN := COMMAND'LENGTH;
        RTN := 0;
        F77_CALLABLES.ADA_DAMSG (COMMAND, INPLEN, 10_000, RTN);
        if RTN < 0 then
            raise X_DAMES_ERROR;
        end if;

        if RTN = 0 then
            F77_CALLABLES.ADA_PARSLP (RTN);
            if RTN /= 0 then
                raise X_DAMES_ERROR;
            end if;
        end if;

        if COMMAND_IS_OPEN then
            SHARE.A_DATABASE_IS_OPEN := TRUE;
            SHARE.OPEN_DATABASE_NAME := DB_NAME;
        end if;
    end EXECUTE;    procedure CLOSE is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :               CLOSE                                  **
--**   ~~~~~~~~~~~                                                      **
--**                                                                    **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**    if EMBEDDED_INTERFACE_IS_IN_USE then                            **
--**        CLOSE_EMBEDDED_INTERFACE;                                   **
--**        EMBEDDED_INTERFACE_IS_IN_USE := FALSE;                      **
--**        A_DATABASE_IS_OPEN := FALSE;                                **
--**    end if;                                                         **
--**                                                                    **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    EMBEDDED_INTERFACE_IS_IN_USE                                    **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    EMBEDDED_INTERFACE_IS_IN_USE                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--************************************************************************
    begin
        if DAMES_STATUS.EMBEDDED_INTERFACE_IS_IN_USE then
            F77_CALLABLES.ADA_ENDDM;
            DAMES_STATUS.EMBEDDED_INTERFACE_IS_IN_USE := FALSE;
            SHARE.A_DATABASE_IS_OPEN := FALSE;
        end if;
    end CLOSE;

    procedure OPEN (DB_NAME : STRING) is
--************************************************************************
--**                                                                    **
--**   UNIT NAME :               OPEN                                   **
--**   ~~~~~~~~~~~                                                      **
--**                                                                    **
--** DESCRIPTION--------------------------------------------------------**
--**                                                                    **
--**    EXECUTE ("open " & DB_NAME & ";");                              **
--**                                                                    **
--** INPUT--------------------------------------------------------------**
--**                                                                    **
--**  DB_NAME is the name of the database to be open.                   **
--**                                                                    **
--** STATUS VARIABLES USED----------------------------------------------**
--**                                                                    **
--**    EMBEDDED_INTERFACE_IS_IN_USE                                    **
--**                                                                    **
--** OUTPUT-------------------------------------------------------------**
--**                                                                    **
--** STATUS VARIABLES UPDATED-------------------------------------------**
--**                                                                    **
--**    EMBEDDED_INTERFACE_IS_IN_USE                                    **
--**    A_DATABASE_IS_OPEN                                              **
--**                                                                    **
--** EXCEPTIONS---------------------------------------------------------**
--**                                                                    **
--**      X_DAMES_ERROR  is  raised  if  the given database cannot  be  **
--**  opened, or if it does not exist.                                  **
--**                                                                    **
--************************************************************************
    begin
        EXECUTE ("OPEN " & DB_NAME & ";");
    end OPEN;


end DAMES;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--both.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with TEXT_IO;
use TEXT_IO;

package BOTH_VARIABLES is

    type INTERFACE_PROCEDURE_NAME is
     (DAMES_OPEN,           DAMES_EXECUTE,        DAMES_CLOSE,
      LL_D_OPEN,            LL_D_DEFINE_TABLE,    LL_D_LOCK,
      LL_D_GET_INFORMATION, LL_D_UNLOCK,          LL_D_CLOSE,
      LL_D_E_MATCH,         LL_D_F_MATCH,         LL_D_I_MATCH,
      LL_D_R_MATCH,         LL_D_S_MATCH,         LL_D_E_OR_MATCH,
      LL_D_F_OR_MATCH,      LL_D_I_OR_MATCH,      LL_D_R_OR_MATCH,
      LL_D_S_OR_MATCH,      LL_D_E_AND_MATCH,     LL_D_F_AND_MATCH,
      LL_D_I_AND_MATCH,     LL_D_R_AND_MATCH,     LL_D_S_AND_MATCH,
      LL_D_FIND,            LL_D_FIND_NEXT,       LL_D_FIND_PREVIOUS,
      LL_D_NEXT,            LL_D_PREVIOUS,        LL_D_E_GET_COLUMN,
      LL_D_F_GET_COLUMN,    LL_D_I_GET_COLUMN,    LL_D_R_GET_COLUMN,
      LL_D_S_GET_COLUMN,    LL_D_E_GET_ROW,       LL_D_F_GET_ROW,
      LL_D_I_GET_ROW,       LL_D_R_GET_ROW,       LL_D_S_GET_ROW,
      LL_D_E_BUILD_COLUMN,  LL_D_F_BUILD_COLUMN,  LL_D_I_BUILD_COLUMN,
      LL_D_R_BUILD_COLUMN,  LL_D_S_BUILD_COLUMN,  LL_D_E_BUILD_ROW,
      LL_D_F_BUILD_ROW,     LL_D_I_BUILD_ROW,     LL_D_R_BUILD_ROW,
      LL_D_S_BUILD_ROW,     LL_D_UPDATE,          LL_D_INSERT,
      LL_D_DELETE);


    type ACCESS_PROCEDURE_NAME is
     (ADA_ADDATR,  ADA_CLOSDB,  ADA_CLOSER,  ADA_CLRELS,  ADA_DADD,
      ADA_DAMSG,   ADA_DELETT,  ADA_DFIND,   ADA_DGINFO,  ADA_DLOCK,
      ADA_DOPENDB, ADA_DPREV,   ADA_DUNLK,   ADA_ENDDM,   ADA_FACSS,
      ADA_GETA,    ADA_GETT,    ADA_INSRTT,  ADA_IRELC,   ADA_LEXINT,
      ADA_NUMTUP,  ADA_OPENR,   ADA_PARSLP,  ADA_PUTA,    ADA_RELLK,
      ADA_REPLAT,  ADA_SETGET,  ADA_SETLK,   ADA_SRCHA,   ADA_STARTDM,
      ADA_TRELC,   ADA_MSGTTY);


    type PARAMETER_TYPE is (IN_PARAMETERS, OUT_PARAMETERS, TABLE_DESCRIPTORS);

    type TEST_BED_FUNCTION is (CREATE, DELETE, EXECUTE, MODIFY);

    subtype INTERFACE_NUMBER is NATURAL
                  range 0 .. INTERFACE_PROCEDURE_NAME'POS
                           (INTERFACE_PROCEDURE_NAME'LAST);

    subtype TEST_CASE_NUMBER is NATURAL range 1 .. 80;
    subtype ACC_LIST_NUMBER  is NATURAL range 0 .. 10;

    subtype ACCESS_NUMBER is NATURAL
                   range 0 .. ACCESS_PROCEDURE_NAME'POS
                        (ACCESS_PROCEDURE_NAME'LAST);

    type ACCESS_LIST is array (INTERFACE_NUMBER, ACC_LIST_NUMBER) of NATURAL;

    type IN_PARAMETER_IS_OPEN_TYPE is array (INTERFACE_NUMBER) of BOOLEAN;

--***************************************************************************--
--                               variables                                   --
--***************************************************************************--


    ACCESS_NB            : ACCESS_NUMBER := 0;
    ACC_LI_NB            : ACC_LIST_NUMBER := 0;
    ACCESS_PR_NAME       : ACCESS_PROCEDURE_NAME;
    AUTOMATIC_VERSION    : BOOLEAN := FALSE;
    INTERFACE_NB         : INTERFACE_NUMBER := 0;
    INTERFACE_PR_NAME    : INTERFACE_PROCEDURE_NAME;
    IN_PARAMETER_IS_OPEN : IN_PARAMETER_IS_OPEN_TYPE :=
               (2 | 7 | 8                    => FALSE,
                0 | 1                       => TRUE,
                3 .. 6                     => TRUE,
                9 .. INTERFACE_NUMBER'LAST => TRUE);
    LOG_FILE             : FILE_TYPE;
    PARAMETER            : PARAMETER_TYPE;
    TEST_CASE_NB         : TEST_CASE_NUMBER := 1;
    T_B_FUNCTION         : TEST_BED_FUNCTION;
    ACC_LIST : ACCESS_LIST :=
           (00 => (05, 22, others => 99),
        01 => (05, 22, others => 99),
        02 => (others => 99),
        03 => (10, others => 99),
        04 => (18, 30, 00, 09, 21, 23, 17, others => 99),
        05 => (09, 21, 26, 08, 14, 16, 15, 28, others => 99),
        06 => (others => 99),
        07 => (others => 99),
        08 => (others => 99),
        09 => (others => 99),
        10 => (others => 99),
        11 => (others => 99),
        12 => (others => 99),
        13 => (others => 99),
        14 => (others => 99),
        15 => (others => 99),
        16 => (others => 99),
        17 => (others => 99),
        18 => (others => 99),
        19 => (others => 99),
        20 => (others => 99),
        21 => (others => 99),
        22 => (others => 99),
        23 => (others => 99),
        24 => (26, others => 99),
        25 => (16, 15, others => 99),
        26 => (15, 11, others => 99),
        27 => (16, others => 99),
        28 => (11, others => 99),
        29 => (15, others => 99),
        30 => (15, others => 99),
        31 => (15, others => 99),
        32 => (15, others => 99),
        33 => (15, others => 99),
        34 => (15, others => 99),
        35 => (15, others => 99),
        36 => (15, others => 99),
        37 => (15, others => 99),
        38 => (15, others => 99),
        39 => (23, others => 99),
        40 => (23, others => 99),
        41 => (23, others => 99),
        42 => (23, others => 99),
        43 => (23, others => 99),
        44 => (23, others => 99),
        45 => (23, others => 99),
        46 => (23, others => 99),
        47 => (23, others => 99),
        48 => (23, others => 99),
        49 => (06, 25, 14, 15, 07, 04, others => 99),
        50 => (17, 14, 15, 07, 04, others => 99),
        51 => (06, 20, others => 99));

end BOTH_VARIABLES;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--instan.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with TEXT_IO;
use TEXT_IO;
with LL_DAMES;
pragma ELABORATE (LL_DAMES);

package INSTANTIATED is

    subtype STR_10 is STRING (1 .. 10);

    type ENUM is (FIRST, SECOND, THIRD);

    type RECD is
    record
        INT : INTEGER := 0;
        FLO : FLOAT := 1.0;
        STR : STR_10 := "string....";
        ENU : ENUM := FIRST;
    end record;


    procedure I_MATCH is new LL_DAMES.MATCH (INTEGER);
    procedure F_MATCH is new LL_DAMES.MATCH (FLOAT);
    procedure S_MATCH is new LL_DAMES.MATCH (STR_10);
    procedure E_MATCH is new LL_DAMES.MATCH (ENUM);
    procedure R_MATCH is new LL_DAMES.MATCH (RECD);


    procedure I_OR_MATCH is new LL_DAMES.OR_MATCH (INTEGER);
    procedure F_OR_MATCH is new LL_DAMES.OR_MATCH (FLOAT);
    procedure S_OR_MATCH is new LL_DAMES.OR_MATCH (STR_10);
    procedure E_OR_MATCH is new LL_DAMES.OR_MATCH (ENUM);
    procedure R_OR_MATCH is new LL_DAMES.OR_MATCH (RECD);


    procedure I_AND_MATCH is new LL_DAMES.AND_MATCH (INTEGER);
    procedure F_AND_MATCH is new LL_DAMES.AND_MATCH (FLOAT);
    procedure S_AND_MATCH is new LL_DAMES.AND_MATCH (STR_10);
    procedure E_AND_MATCH is new LL_DAMES.AND_MATCH (ENUM);
    procedure R_AND_MATCH is new LL_DAMES.AND_MATCH (RECD);


    procedure I_GET_COLUMN is new LL_DAMES.GET_COLUMN (INTEGER);
    procedure F_GET_COLUMN is new LL_DAMES.GET_COLUMN (FLOAT);
    procedure S_GET_COLUMN is new LL_DAMES.GET_COLUMN (STR_10);
    procedure E_GET_COLUMN is new LL_DAMES.GET_COLUMN (ENUM);
    procedure R_GET_COLUMN is new LL_DAMES.GET_COLUMN (RECD);


    procedure I_GET_ROW is new LL_DAMES.GET_ROW (INTEGER);
    procedure F_GET_ROW is new LL_DAMES.GET_ROW (FLOAT);
    procedure S_GET_ROW is new LL_DAMES.GET_ROW (STR_10);
    procedure E_GET_ROW is new LL_DAMES.GET_ROW (ENUM);
    procedure R_GET_ROW is new LL_DAMES.GET_ROW (RECD);


    procedure I_BUILD_COLUMN is new LL_DAMES.BUILD_COLUMN (INTEGER);
    procedure F_BUILD_COLUMN is new LL_DAMES.BUILD_COLUMN (FLOAT);
    procedure S_BUILD_COLUMN is new LL_DAMES.BUILD_COLUMN (STR_10);
    procedure E_BUILD_COLUMN is new LL_DAMES.BUILD_COLUMN (ENUM);
    procedure R_BUILD_COLUMN is new LL_DAMES.BUILD_COLUMN (RECD);

    procedure I_BUILD_ROW is new LL_DAMES.BUILD_ROW (INTEGER);
    procedure F_BUILD_ROW is new LL_DAMES.BUILD_ROW (FLOAT);
    procedure S_BUILD_ROW is new LL_DAMES.BUILD_ROW (STR_10);
    procedure E_BUILD_ROW is new LL_DAMES.BUILD_ROW (ENUM);
    procedure R_BUILD_ROW is new LL_DAMES.BUILD_ROW (RECD);

    package I is new INTEGER_IO (INTEGER);
    package F is new FLOAT_IO (FLOAT);

end INSTANTIATED;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--dispec.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with TEXT_IO;
use TEXT_IO;

package DISPLAY is

--***************************************************************************--
--                           types                                           --
--***************************************************************************--

    type CHOICE_SWITCH is (R_O_W, C_O_L);
    type DISPLAY_SWITCH_TYPE is (READ, MODIFY, LIST);

    subtype COLUMN_TYPE is INTEGER range 0 .. 79;
    subtype ROW_TYPE    is INTEGER range 0 .. 23;


--***************************************************************************--
--                              variables                                    --
--***************************************************************************--

    A              : CHARACTER;
    B              : STRING (1 .. 2);
    COLUMN         : COLUMN_TYPE;
    DISPLAY_SWITCH : DISPLAY_SWITCH_TYPE := MODIFY;
    LAST           : NATURAL;
    ROW            : ROW_TYPE;
--***************************************************************************--
--                           procedures                                      --
--***************************************************************************--

    procedure NEWPAGE;

    procedure DISP (LINE : POSITIVE_COUNT; TEXT : STRING);

    procedure DISPL (COLUMN : COLUMN_TYPE; ROW : ROW_TYPE; TEXT : STRING);

    procedure STOP;

    procedure PRINT (S : STRING);

    procedure CHOICE (ROWCOL_SWITCH : CHOICE_SWITCH;
              LAST_ROWCOL   : COLUMN_TYPE;
              ROW           : in out ROW_TYPE;
              COLUMN        : in out COLUMN_TYPE);

    procedure SCREEN_POS (COLUMN : COLUMN_TYPE; ROW : ROW_TYPE);
-- move the cursor to the requested location

    function MODIFY return BOOLEAN;
-- ask the user if he wants to modify the currently displayed screen and return
-- TRUE if he wants and FALSE if he does not.

    procedure INITIALIZE_STATUS;
-- initialize the TABLE_DESCRIPTOR package to meaningful values

    procedure UPDATE_STATUS;
-- display and update the TABLE_DESCRIPTOR package content.

end DISPLAY;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--display.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with TTY_IO;
with CONSTANTS;
use CONSTANTS;
with SHARE;
use SHARE;
with DAMES_STATUS;
use DAMES_STATUS;
with TABLE_DESCRIPTOR;
use TABLE_DESCRIPTOR;
with LL_DAMES;
use LL_DAMES;
with BOTH_VARIABLES;
use BOTH_VARIABLES;

package body DISPLAY is

-------------------------------------------------------------------------------
--                        procedure NEWPAGE                                  --
-------------------------------------------------------------------------------
    procedure NEWPAGE is

    begin
    case DISPLAY_SWITCH is
        when MODIFY | READ =>
        SET_OUTPUT (STANDARD_OUTPUT);
        NEW_PAGE;
        PUT (TEST_BED_FUNCTION'IMAGE (T_B_FUNCTION) &
             " interface procedure " &
             INTERFACE_PROCEDURE_NAME'IMAGE (INTERFACE_PR_NAME) & " ");
        case PARAMETER is
            when IN_PARAMETERS | TABLE_DESCRIPTORS =>
            PUT (PARAMETER_TYPE'IMAGE (PARAMETER));
            when OUT_PARAMETERS =>
            NEW_LINE;
            PUT ("access procedure " &
                 ACCESS_PROCEDURE_NAME'IMAGE (ACCESS_PR_NAME) &
                 " " & PARAMETER_TYPE'IMAGE (PARAMETER));
        end case;
        when LIST =>
        SET_OUTPUT (LOG_FILE);
    end case;
    if PARAMETER /= OUT_PARAMETERS then
        NEW_LINE (3);
    end if;
    end NEWPAGE;

-------------------------------------------------------------------------------
--                        procedure DISP                                     --
-------------------------------------------------------------------------------
    procedure DISP (LINE : POSITIVE_COUNT; TEXT : STRING) is
    begin
    SET_LINE (LINE);
    PUT (TEXT);
    end DISP;

-------------------------------------------------------------------------------
--                        procedure DISPL                                    --
-------------------------------------------------------------------------------
    procedure DISPL (COLUMN : COLUMN_TYPE; ROW : ROW_TYPE; TEXT : STRING) is
    begin
    TTY_IO.PUT (ASCII.DLE & CHARACTER'VAL (COLUMN) & CHARACTER'VAL (ROW));
    PUT (TEXT);
    end DISPL;

-------------------------------------------------------------------------------
--                        procedure STOP                                     --
-------------------------------------------------------------------------------
    procedure STOP is
    begin
    if not AUTOMATIC_VERSION then
        DISPL (0, 22, "Press ""NEW LINE"" to continue                    ");
        DISPL (0, 23, "                                                  ");
        SCREEN_POS (0, 22);
        GET_LINE (B, LAST);
    end if;
    end STOP;

-------------------------------------------------------------------------------
--                           procedure PRINT                                 --
-------------------------------------------------------------------------------
    procedure PRINT (S : STRING) is

    begin
    PARAMETER := OUT_PARAMETERS;
    if not AUTOMATIC_VERSION then
        SET_OUTPUT (STANDARD_OUTPUT);
        NEW_PAGE;
        PUT (TEST_BED_FUNCTION'IMAGE (T_B_FUNCTION) &
         " interface procedure " &
         INTERFACE_PROCEDURE_NAME'IMAGE (INTERFACE_PR_NAME) & " " &
         PARAMETER_TYPE'IMAGE (PARAMETER));
        DISPL (0, 4, S);
        STOP;
    end if;
    SET_OUTPUT (LOG_FILE);
    NEW_LINE (3);
    PUT ("--------------- INTERFACE PROCEDURE OUT_PARAMETERS -----------");
    NEW_LINE (2);
    PUT (S);
    SET_OUTPUT (STANDARD_OUTPUT);
    PARAMETER := IN_PARAMETERS;
    end PRINT;
-------------------------------------------------------------------------------
--                        procedure CHOICE                                   --
-------------------------------------------------------------------------------
    procedure CHOICE (ROWCOL_SWITCH : CHOICE_SWITCH;
              LAST_ROWCOL   : COLUMN_TYPE;
              ROW           : in out ROW_TYPE;
              COLUMN        : in out COLUMN_TYPE) is

    begin
    TTY_IO.ECHO_OFF;
    loop
        TTY_IO.PUT (ASCII.DLE & CHARACTER'VAL (COLUMN) &
            CHARACTER'VAL (ROW));
        TTY_IO.GET (A);
        case A is
        when ASCII.CR =>  exit;
        when ASCII.LF =>
            if ROWCOL_SWITCH = R_O_W then
            ROW := ROW + 1;
            exit when ROW = LAST_ROWCOL + 1;
            else
            COLUMN := COLUMN + 1;
            exit when COLUMN = LAST_ROWCOL + 1;
            end if;
        when others =>  null;
        end case;
    end loop;
    TTY_IO.ECHO_ON;
    end CHOICE;

-------------------------------------------------------------------------------
--                        procedure SCREEN_POS                               --
-------------------------------------------------------------------------------
    procedure SCREEN_POS (COLUMN : COLUMN_TYPE; ROW : ROW_TYPE) is
    begin
    if DISPLAY_SWITCH = LIST then
        SET_COL (POSITIVE_COUNT (COLUMN + 1));
    else
        TTY_IO.PUT (ASCII.DLE & CHARACTER'VAL (COLUMN) &
            CHARACTER'VAL (ROW));
    end if;
    end SCREEN_POS;

-------------------------------------------------------------------------------
--                        function  MODIFY                                   --
-------------------------------------------------------------------------------
    function MODIFY return BOOLEAN is
    ANSWER : CHARACTER;
    begin
    case DISPLAY_SWITCH is
        when MODIFY =>
        SCREEN_POS (0, 23);
        PUT ("Do you want to modify these values ? (y/n) ");
        GET (ANSWER);

        if ANSWER = 'y' or ANSWER = 'Y' then
            return TRUE;
        else
            return FALSE;
        end if;
        when READ =>
        STOP;
        return FALSE;
        when LIST =>  return FALSE;
    end case;

    end MODIFY;

-------------------------------------------------------------------------------
--                        procedure INITIALIZE_STATUS                        --
-------------------------------------------------------------------------------
    procedure INITIALIZE_STATUS is
    begin
    for I in 1 .. TABLE_NO loop
        TABLE (I).NAME := "          ";
        TABLE (I).TABLE_STATUS.TABLE_IS_LOCKED := FALSE;
        TABLE (I).TABLE_DEFINITION.COLUMN_NUMBER := 0;
        TABLE (I).TABLE_DEFINITION.COLUMN_NAMES :=
          (1 .. COL_NO => "          ");
        TABLE (I).TABLE_DEFINITION.IN_RECORD :=
          (1 .. COL_NO => "          ");
    end loop;
    end INITIALIZE_STATUS;
-------------------------------------------------------------------------------
--                        procedure UPDATE_STATUS                            --
-------------------------------------------------------------------------------
    procedure UPDATE_STATUS is

-- UPDATE_STATUS displays the values contained in the SHARE and
-- TABLE_DESCRIPTOR packages, and updates them according to the
-- user's inputs.
-- The displayed values are organized in three kinds of screens
-- called screen 1, screen 2 and screen 3.
-- Screen 1 is the main descriptor and appears one time for
-- the whole package description;
-- Screen 2 appears one time for each column of each locked
-- table;
-- Screen 3 appears one time for each locked table and describes
-- the current status of the table.

    GOT                     : STRING (1 .. 40);
    LAST, K                 : INTEGER;
    ENUM_ITEM_ACCESS_OBJECT : ENUM_ITEM_ACCESS;
    begin

--------------------verify EMBEDDED_INTERFACE_IS_IN_USE-------------------

    PARAMETER := TABLE_DESCRIPTORS;
    NEWPAGE;
    SCREEN_POS (0, 15);
    PUT_LINE (" DAMES_STATUS.EMBEDDED_INTERFACE_IS_IN_USE : " &
          BOOLEAN'IMAGE (EMBEDDED_INTERFACE_IS_IN_USE));
    if MODIFY then
        SCREEN_POS (45, 15);
        GET_LINE (GOT, LAST);
        if LAST /= 0 then
        EMBEDDED_INTERFACE_IS_IN_USE := BOOLEAN'VALUE (GOT (1 .. LAST));
        end if;
    end if;


----------------------display SCREEN 1------------------------------------


    NEWPAGE;
    SCREEN_POS (0, 4);
    PUT_LINE ("     TABLE     NAME      COLUMN_NUMBER        SORTED");
    NEW_LINE (5);

    for I in 1 .. TABLE_NO loop
        PUT ("     " & INTEGER'IMAGE (I));
        SET_COL (14);
        PUT (TABLE (I).NAME & "    " &
         INTEGER'IMAGE (TABLE (I).TABLE_DEFINITION.COLUMN_NUMBER));
        SET_COL (49);
        PUT_LINE (BOOLEAN'IMAGE (TABLE (I).TABLE_DEFINITION.SORTED));
        NEW_LINE;
    end loop;

    SCREEN_POS (0, 19);
    PUT_LINE ("  SHARE.A_DATABASE_IS_OPEN : " &
          BOOLEAN'IMAGE (A_DATABASE_IS_OPEN));
    PUT_LINE ("  SHARE.OPEN_DATABASE_NAME : " & OPEN_DATABASE_NAME);

-------------------------modify SCREEN 1----------------------------------

    if MODIFY then
        for I in 1 .. TABLE_NO loop
        SCREEN_POS (13, 8 + 2 * I);
        GOT := (others => ' ');
        GET_LINE (GOT (1 .. 10), LAST);

        if LAST /= 0 then
            TABLE (I).NAME := GOT (1 .. 10);
        end if;

        SCREEN_POS (28, 8 + 2 * I);
        GOT := (others => ' ');
        GET_LINE (GOT (1 .. 5), LAST);

        if LAST /= 0 then
            TABLE (I).TABLE_DEFINITION.COLUMN_NUMBER :=
              INTEGER'VALUE (GOT (1 .. 5));
        end if;

        SCREEN_POS (48, 8 + 2 * I);
        GOT := (others => ' ');
        GET_LINE (GOT (1 .. 6), LAST);

        if LAST /= 0 then
            TABLE (I).TABLE_DEFINITION.SORTED :=
              BOOLEAN'VALUE (GOT (1 .. 6));
        end if;

        end loop;

        SCREEN_POS (29, 19);
        GET_LINE (GOT, LAST);
        if LAST /= 0 then
        A_DATABASE_IS_OPEN := BOOLEAN'VALUE (GOT (1 .. LAST));
        end if;
        SCREEN_POS (29, 20);
        GET_LINE (GOT, LAST);
        if LAST /= 0 then
        OPEN_DATABASE_NAME := GOT (1 .. LAST) & (LAST + 1 .. 10 => ' ');
        end if;
    end if;

------------------------display SCREEN 2----------------------------------


    for I in 1 .. TABLE_NO loop
        for J in 1 .. TABLE (I).TABLE_DEFINITION.COLUMN_NUMBER loop
        NEWPAGE;
        SCREEN_POS (0, 4);
        PUT_LINE ("          TABLE " & INTEGER'IMAGE (I) &
              "          COLUMN " & INTEGER'IMAGE (J));
        NEW_LINE;
        PUT ("NAME : " & TABLE (I).TABLE_DEFINITION.COLUMN_NAMES (J) &
             "      INDEX : " &
             INTEGER'IMAGE
               (TABLE (I).TABLE_DEFINITION.COLUMN_INDEX (J)));
        SET_COL (44);
        PUT ("TYPE : " &
             INTEGER'IMAGE
               (TABLE (I).TABLE_DEFINITION.COLUMN_TYPES (J)));
        SET_COL (62);
        PUT_LINE ("LENGTH : " &
              INTEGER'IMAGE
                (TABLE (I).TABLE_DEFINITION.COLUMN_LENGTH (J)));

        if TABLE (I).TABLE_DEFINITION.CONSTRAINTS (J) = null then
            PUT_LINE ("CONSTRAINT (null / new) : null     ACCESSED CONSTRAINT :");
        else
            PUT_LINE ("CONSTRAINT (null / new) : new      ACCESSED CONSTRAINT : " &
                  TABLE (I).TABLE_DEFINITION.CONSTRAINTS (J).all
                 (1 .. 10) &
                  TABLE (I).TABLE_DEFINITION.CONSTRAINTS (J).all
                 (RANGE_SIZE + 1 .. RANGE_SIZE + 10));
        end if;

        PUT_LINE ("IN_RECORD : " &
              TABLE (I).TABLE_DEFINITION.IN_RECORD (J));
        ENUM_ITEM_ACCESS_OBJECT :=
          TABLE (I).TABLE_DEFINITION.ENUM_TYPES (J);
        NEW_LINE;

        if ENUM_ITEM_ACCESS_OBJECT = null then
            PUT_LINE ("ENUMERATION DEFINITION (null / new) : null");
            PUT_LINE ("              ENUM_IMAGE                      OTHER (null / new)");
        else
            PUT_LINE ("ENUMERATION DEFINITION (null / new) : new");
            PUT_LINE ("              ENUM_IMAGE                      OTHER (null / new)");
            PUT (ENUM_ITEM_ACCESS_OBJECT.ENUM_IMAGE);
            ENUM_ITEM_ACCESS_OBJECT :=
              ENUM_ITEM_ACCESS_OBJECT.all.OTHER;

            while ENUM_ITEM_ACCESS_OBJECT /= null loop
            PUT_LINE ("          new");
            PUT (ENUM_ITEM_ACCESS_OBJECT.ENUM_IMAGE);
            ENUM_ITEM_ACCESS_OBJECT :=
              ENUM_ITEM_ACCESS_OBJECT.all.OTHER;
            end loop;

            PUT_LINE ("          null");

        end if;
---------------------modify SCREEN 2--------------------------------------


        if MODIFY then
            SCREEN_POS (7, 6);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 10), LAST);

            if LAST /= 0 then
            TABLE (I).TABLE_DEFINITION.COLUMN_NAMES (J) :=
              GOT (1 .. 10);
            end if;

            SCREEN_POS (32, 6);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if LAST /= 0 then
            TABLE (I).TABLE_DEFINITION.COLUMN_INDEX (J) :=
              INTEGER'VALUE (GOT (1 .. 5));
            end if;

            SCREEN_POS (51, 6);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if LAST /= 0 then
            TABLE (I).TABLE_DEFINITION.COLUMN_TYPES (J) :=
              INTEGER'VALUE (GOT (1 .. 5));
            end if;

            SCREEN_POS (71, 6);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if LAST /= 0 then
            TABLE (I).TABLE_DEFINITION.COLUMN_LENGTH (J) :=
              INTEGER'VALUE (GOT (1 .. 5));
            end if;

            SCREEN_POS (26, 7);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if GOT (1 .. 4) = "null" then
            TABLE (I).TABLE_DEFINITION.CONSTRAINTS (J) := null;

            elsif GOT (1 .. 3) = "new" then
            TABLE (I).TABLE_DEFINITION.CONSTRAINTS (J) :=
              new STRING (1 .. 2 * RANGE_SIZE);
            SCREEN_POS (57, 7);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 20), LAST);

            if LAST /= 0 then
                TABLE (I).TABLE_DEFINITION.CONSTRAINTS (J).all :=
                  GOT (1 .. 10) & (11 .. RANGE_SIZE => ' ') &
                  GOT (11 .. 20) &
                  (RANGE_SIZE + 11 .. 2 * RANGE_SIZE => ' ');
            end if;
            else
            if TABLE (I).TABLE_DEFINITION.CONSTRAINTS (J) /=
               null then
                SCREEN_POS (57, 7);
                GOT := (others => ' ');
                GET_LINE (GOT (1 .. 20), LAST);

                if LAST /= 0 then
                TABLE (I).TABLE_DEFINITION.CONSTRAINTS
                   (J).all :=
                  GOT (1 .. 10) & (11 .. RANGE_SIZE => ' ') &
                  GOT (11 .. 20) &
                  (RANGE_SIZE + 11 .. 2 * RANGE_SIZE => ' ');
                end if;
            end if;
            end if;

            SCREEN_POS (12, 8);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 10), LAST);

            if LAST /= 0 then
            TABLE (I).TABLE_DEFINITION.IN_RECORD (J) :=
              GOT (1 .. 10);
            end if;

            SCREEN_POS (38, 10);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if GOT (1 .. 4) = "null" then
            TABLE (I).TABLE_DEFINITION.ENUM_TYPES (J) := null;

            elsif GOT (1 .. 3) = "new" then
            TABLE (I).TABLE_DEFINITION.ENUM_TYPES (J) :=
              new ENUM_ITEM;
            end if;

            if TABLE (I).TABLE_DEFINITION.ENUM_TYPES (J) /= null then
            SCREEN_POS (0, 12);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 40), LAST);

            if LAST /= 0 then
                TABLE (I).TABLE_DEFINITION.ENUM_TYPES (J).all
                 .ENUM_IMAGE := GOT (1 .. IMAGE_SZ);
            end if;

            ENUM_ITEM_ACCESS_OBJECT :=
              TABLE (I).TABLE_DEFINITION.ENUM_TYPES (J);
            K := 12;

            loop
                SCREEN_POS (50, K);
                GOT := (others => ' ');
                GET_LINE (GOT (1 .. 5), LAST);

                if GOT (1 .. 4) = "null" then
                ENUM_ITEM_ACCESS_OBJECT.all.OTHER := null;
                exit;

                elsif GOT (1 .. 3) = "new" then
                ENUM_ITEM_ACCESS_OBJECT.all.OTHER :=
                  new ENUM_ITEM;

                elsif ENUM_ITEM_ACCESS_OBJECT.all.OTHER = null then
                exit;
                else
                null;
                end if;

                K := K + 1;
                ENUM_ITEM_ACCESS_OBJECT :=
                  ENUM_ITEM_ACCESS_OBJECT.all.OTHER;
                SCREEN_POS (0, K);
                GOT := (others => ' ');
                GET_LINE (GOT (1 .. 40), LAST);

                if LAST /= 0 then
                ENUM_ITEM_ACCESS_OBJECT.all.ENUM_IMAGE :=
                  GOT (1 .. IMAGE_SZ);
                end if;
            end loop;

            end if;
        end if;
        end loop;
    end loop;

---------------------------display SCREEN 3-------------------------------



    for I in 1 .. TABLE_NO loop
        if TABLE (I).NAME /= "          " then
        NEWPAGE;
        SCREEN_POS (30, 4);
        PUT_LINE ("TABLE " & TABLE (I).NAME);
        SCREEN_POS (0, 6);
        PUT ("     TABLE_IS_LOCKED : " &
             BOOLEAN'IMAGE (TABLE (I).TABLE_STATUS.TABLE_IS_LOCKED));
        SCREEN_POS (50, 6);
        PUT_LINE ("CURRENT_LOCK : " &
              ACCESS_MODE_TYPE'IMAGE
                (TABLE (I).TABLE_STATUS.CURRENT_LOCK));
        PUT ("     DESCR :" &
             INTEGER'IMAGE (TABLE (I).TABLE_STATUS.DESCR));
        SCREEN_POS (40, 7);
        PUT_LINE ("FIND_STATUS : " &
              FIND_STATUS_TYPE'IMAGE
                (TABLE (I).TABLE_STATUS.FIND_STATUS));
        PUT ("     CURRENT_ROW :" &
             INTEGER'IMAGE (TABLE (I).TABLE_STATUS.CURRENT_ROW (1)));
        SET_COL (29);
        PUT (INTEGER'IMAGE (TABLE (I).TABLE_STATUS.CURRENT_ROW (2)));
        SET_COL (39);
        PUT_LINE (INTEGER'IMAGE
                (TABLE (I).TABLE_STATUS.CURRENT_ROW (3)));

        if TABLE (I).TABLE_STATUS.SELECTION_CRITERION = null then
            PUT_LINE ("          SELECTION_CRITERION (null / new) : null");
            PUT_LINE ("                   COLUMN_ID    : ");
            PUT_LINE ("                   KEY_MATCH    : ");
            PUT_LINE ("                   COLUMN_VALUE : ");
            NEW_LINE (4);
            PUT_LINE ("                   MEANINGFUL   : ");
            PUT_LINE ("                   USER_OPERATOR: ");
            PUT_LINE ("                   TREE_OPERATOR: ");
            PUT_LINE ("                   FIRST_CHILD  : ");
            PUT_LINE ("                   SECOND_CHILD : ");
            PUT_LINE ("                   OTHER        : ");
        else
            PUT_LINE ("          SELECTION_CRITERION (null / new) : new ");
            PUT_LINE ("                   COLUMN_ID    :" &
                  INTEGER'IMAGE
                (TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                  .COLUMN_ID));
            PUT_LINE ("                   KEY_MATCH    : " &
                  KEY_MATCH_TYPE'IMAGE
                (TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                  .KEY_MATCH));
            PUT ("                   COLUMN_VALUE : ");

            for II in 1 .. 4 loop
            for JJ in 1 .. 3 loop
                SET_COL (POSITIVE_COUNT (31 + 15 * JJ));
                PUT (INTEGER'IMAGE
                   (TABLE (I).TABLE_STATUS
                     .SELECTION_CRITERION.all.COLUMN_VALUE
                       (6 * II + JJ - 6)));
            end loop;

            NEW_LINE;

            for JJ in 1 .. 3 loop
                SET_COL (POSITIVE_COUNT (15 * JJ - 14));
                PUT (INTEGER'IMAGE
                   (TABLE (I).TABLE_STATUS
                     .SELECTION_CRITERION.all.COLUMN_VALUE
                       (6 * II + JJ - 3)));
            end loop;
            end loop;

            SET_COL (46);
            PUT_LINE (INTEGER'IMAGE
                (TABLE (I).TABLE_STATUS.SELECTION_CRITERION
                  .COLUMN_VALUE (25)));
            PUT_LINE ("                   MEANINGFUL   :" &
                  INTEGER'IMAGE
                (TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                  .MEANINGFUL));
            PUT_LINE ("                   USER_OPERATOR: " &
                  OPERATOR_TYPE'IMAGE
                (TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                  .USER_OPERATOR));
            PUT_LINE ("                   TREE_OPERATOR: " &
                  OPERATOR_TYPE'IMAGE
                (TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                  .TREE_OPERATOR));

            if TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
            .FIRST_CHILD = null then
            PUT_LINE ("                   FIRST_CHILD  : null");
            else
            PUT_LINE ("                   FIRST_CHILD  : new ");
            end if;

            if TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
            .SECOND_CHILD = null then
            PUT_LINE ("                   SECOND_CHILD : null");
            else
            PUT_LINE ("                   SECOND_CHILD : new ");
            end if;

            if TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all.OTHER =
               null then
            PUT_LINE ("                   OTHER        : null");
            else
            PUT_LINE ("                   OTHER        : new ");
            end if;
        end if;

--------------------------------modify SCREEN 3---------------------------

        if MODIFY then
            SCREEN_POS (23, 6);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 6), LAST);

            if LAST /= 0 then
            TABLE (I).TABLE_STATUS.TABLE_IS_LOCKED :=
              BOOLEAN'VALUE (GOT (1 .. 6));
            end if;

            SCREEN_POS (65, 6);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 10), LAST);

            if LAST /= 0 then
            TABLE (I).TABLE_STATUS.CURRENT_LOCK :=
              ACCESS_MODE_TYPE'VALUE (GOT (1 .. 10));
            end if;

            SCREEN_POS (13, 7);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if LAST /= 0 then
            TABLE (I).TABLE_STATUS.DESCR :=
              INTEGER'VALUE (GOT (1 .. 5));
            end if;

            SCREEN_POS (54, 7);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 10), LAST);

            if LAST /= 0 then
            TABLE (I).TABLE_STATUS.FIND_STATUS :=
              FIND_STATUS_TYPE'VALUE (GOT (1 .. 10));
            end if;

            SCREEN_POS (19, 8);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if LAST /= 0 then
            TABLE (I).TABLE_STATUS.CURRENT_ROW (1) :=
              INTEGER'VALUE (GOT (1 .. 5));
            end if;

            SCREEN_POS (29, 8);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if LAST /= 0 then
            TABLE (I).TABLE_STATUS.CURRENT_ROW (2) :=
              INTEGER'VALUE (GOT (1 .. 5));
            end if;

            SCREEN_POS (39, 8);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if LAST /= 0 then
            TABLE (I).TABLE_STATUS.CURRENT_ROW (3) :=
              INTEGER'VALUE (GOT (1 .. 5));
            end if;

            SCREEN_POS (45, 9);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if GOT (1 .. 4) = "null" then
            TABLE (I).TABLE_STATUS.SELECTION_CRITERION := null;

            elsif GOT (1 .. 3) = "new" then
            TABLE (I).TABLE_STATUS.SELECTION_CRITERION := new NODE;
            end if;

            if TABLE (I).TABLE_STATUS.SELECTION_CRITERION /= null then
            SCREEN_POS (34, 10);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if LAST /= 0 then
                TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                 .COLUMN_ID := INTEGER'VALUE (GOT (1 .. 5));
            end if;

            SCREEN_POS (34, 11);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 20), LAST);

            if LAST /= 0 then
                TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                 .KEY_MATCH := KEY_MATCH_TYPE'VALUE (GOT (1 .. 20));
            end if;

            for II in 1 .. 4 loop

                for JJ in 1 .. 3 loop

                SCREEN_POS (31 + 15 * JJ, 11 + II);
                GOT := (others => ' ');
                GET_LINE (GOT (1 .. 10), LAST);

                if LAST /= 0 then
                    TABLE (I).TABLE_STATUS
                     .SELECTION_CRITERION.all.COLUMN_VALUE
                       (6 * II + JJ - 6) :=
                      INTEGER'VALUE (GOT (1 .. 10));
                end if;

                end loop;
                -- jj

                for JJ in 1 .. 3 loop

                SCREEN_POS (15 * JJ - 14, 12 + II);
                GOT := (others => ' ');
                GET_LINE (GOT (1 .. 10), LAST);

                if LAST /= 0 then
                    TABLE (I).TABLE_STATUS
                     .SELECTION_CRITERION.all.COLUMN_VALUE
                       (6 * II + JJ - 3) :=
                      INTEGER'VALUE (GOT (1 .. 10));
                end if;

                end loop;
                -- jj

            end loop;
            -- ii

            SCREEN_POS (46, 16);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 10), LAST);

            if LAST /= 0 then
                TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                 .COLUMN_VALUE (25) :=
                  INTEGER'VALUE (GOT (1 .. 10));
            end if;

            SCREEN_POS (34, 17);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if LAST /= 0 then
                TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                 .MEANINGFUL := INTEGER'VALUE (GOT (1 .. 5));
            end if;

            SCREEN_POS (34, 18);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 13), LAST);

            if LAST /= 0 then
                TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                 .USER_OPERATOR :=
                  OPERATOR_TYPE'VALUE (GOT (1 .. 13));
            end if;

            SCREEN_POS (34, 19);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 13), LAST);

            if LAST /= 0 then
                TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                 .TREE_OPERATOR :=
                  OPERATOR_TYPE'VALUE (GOT (1 .. 13));
            end if;

            SCREEN_POS (34, 20);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if LAST /= 0 then
                if GOT (1 .. 4) = "null" then
                TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                 .FIRST_CHILD := null;

                elsif GOT (1 .. 3) = "new" then
                TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                 .FIRST_CHILD := new NODE;
                end if;
            end if;

            SCREEN_POS (34, 21);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if LAST /= 0 then
                if GOT (1 .. 4) = "null" then
                TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                 .SECOND_CHILD := null;

                elsif GOT (1 .. 3) = "new" then
                TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                 .SECOND_CHILD := new NODE;
                end if;
            end if;

            SCREEN_POS (34, 22);
            GOT := (others => ' ');
            GET_LINE (GOT (1 .. 5), LAST);

            if LAST /= 0 then
                if GOT (1 .. 4) = "null" then
                TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                 .OTHER := null;

                elsif GOT (1 .. 3) = "new" then
                TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all
                 .OTHER := new NODE;
                end if;
            end if;

            end if;
        end if;
        end if;
    end loop;
    PARAMETER := IN_PARAMETERS;
    end UPDATE_STATUS;
end DISPLAY;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--toolspec.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with CONSTANTS;
use CONSTANTS;
with SHARE;
with TABLE_DESCRIPTOR;
use TABLE_DESCRIPTOR;
with BOTH_VARIABLES;
use BOTH_VARIABLES;
with LL_DAMES;
use LL_DAMES;
with INSTANTIATED;
use INSTANTIATED;

package TOOLS is

--***************************************************************************--
--                                  types                                    --
--***************************************************************************--

    type TEST is
    record
        NAME    : STRING (1 .. 5);
        IS_OPEN : BOOLEAN;
    end record;

    type ARR is array (TEST_CASE_NUMBER) of TEST;

    type POINTER_TABLE is
    record
        IS_EMPTY  : BOOLEAN;
        IS_FULL   : BOOLEAN;
        TEST_CASE : ARR;
    end record;

    type LOST_SWITCH_TYPE is (LOAD, STORE);

--***************************************************************************--
--                                 variables                                 --
--***************************************************************************--

    PT_TABLE : POINTER_TABLE;
    procedure RDWR_POINTER_TABLE (LOST_SWITCH : LOST_SWITCH_TYPE);

--************************************************************************
--**                                                                    **
--**   UNIT NAME :               RDWR_POINTER_TABLE                     **
--**   ~~~~~~~~~~~                                                      **
--**                                                                    **
--** DESCRIPTION ------------------------------------------------------ **
--**                                                                    **
--**   This procedure reads or writes the pointer table.                **
--**                                                                    **
--** INPUT ------------------------------------------------------------ **
--**                                                                    **
--**   LOST_SWITCH if lost_switch = load the procedure read the pointer **
--**                                table.                              **
--**               if lost_switch = store the procedure write the       **
--**                                pointer table.                      **
--**                                                                    **
--** OUTPUT ----------------------------------------------------------- **
--**                                                                    **
--** EXCEPTIONS ------------------------------------------------------- **
--**                                                                    **
--************************************************************************
    subtype LOCK_LIST_LENGTH is POSITIVE range 1 .. 3;
    LENGTH_1 : constant := 10;

    type IN_PARAMETER (NUMBER : INTERFACE_NUMBER) is
    record
        case NUMBER is
        when 0 | 3 =>
            DB_NAME : STRING (1 .. LENGTH_1) := "string....";
        when 1 =>
            COMMAND : STRING (1 .. LENGTH_1) := "string....";
        when 2 | 7 | 8 =>
            null;
        when 5 =>
            LLL       : LOCK_LIST_LENGTH := 3;
            LOCK_LIST : LOCK_LIST_TYPE (1 .. 3) :=
                (others =>
                   (TABLE_NAME  => "string....",
                    ACCESS_MODE => EXCLUSIVE));
        when others =>
            TABLE_NAME : STRING (1 .. LENGTH_1) := "string....";
            case NUMBER is
            when 4 =>
                COLUMN_LIST : STRING (1 .. 200) :=
                      ('s', 't', 'r', 'i', 'n', 'g',
                       others => '.');
            when 20 =>
                ITM : RECD;
            when 09 | 10 | 11 | 17 | 19 =>
                COLUMN_NAME : STRING (1 .. LENGTH_1) :=
                      "string....";
                case NUMBER is
                when 09 | 10 | 11 =>
                    KEY_MATCH    : KEY_MATCH_TYPE :=
                           GREATER_OR_EQUAL;
                    COLUMN_VALUE : RECD;
                when 19 =>
                    ITEM : RECD;
                when others =>
                    null;
                end case;
            when others =>
                null;
            end case;
        end case;
    end record;

    subtype IN_PARAMETER_00 is IN_PARAMETER (00);
    subtype IN_PARAMETER_01 is IN_PARAMETER (01);
    subtype IN_PARAMETER_04 is IN_PARAMETER (04);
    subtype IN_PARAMETER_05 is IN_PARAMETER (05);
    subtype IN_PARAMETER_06 is IN_PARAMETER (06);
    subtype IN_PARAMETER_09 is IN_PARAMETER (09);
    subtype IN_PARAMETER_17 is IN_PARAMETER (17);
    subtype IN_PARAMETER_19 is IN_PARAMETER (19);
    subtype IN_PARAMETER_20 is IN_PARAMETER (20);
    generic
    type IN_PARAMETERS is private;
    procedure RDWR_IN_PARAMETERS (LOST_SWITCH : LOST_SWITCH_TYPE;
                  ITEM_1      : in out IN_PARAMETERS);

--************************************************************************
--**                                                                    **
--**   UNIT NAME :               RDWR_IN_PARAMETERS                     **
--**   ~~~~~~~~~~~                                                      **
--**                                                                    **
--** DESCRIPTION ------------------------------------------------------ **
--**                                                                    **
--**   This procedure reads or writes the interface procedure           **
--**   in_parameters.                                                   **
--**                                                                    **
--** INPUT ------------------------------------------------------------ **
--**                                                                    **
--**   LOST_SWITCH if lost_switch = load the procedure read the         **
--**                                interface procedure in_parameters.  **
--**               if lost_switch = store the procedure write the       **
--**                                interface procedure in_parameters.  **
--**                                                                    **
--**   ITEM_1 this is the structure of the interface procedure          **
--**          in_parameters.                                            **
--**                                                                    **
--** OUTPUT ----------------------------------------------------------- **
--**                                                                    **
--** EXCEPTIONS ------------------------------------------------------- **
--**                                                                    **
--************************************************************************
    type OUT_PARAMETER (NUMBER : ACCESS_NUMBER) is
    record
        case NUMBER is
        when 0 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 15 | 16 | 17 | 18 |
             20 | 21 | 22 | 23 | 25 | 26 | 28 | 30 =>
            A : INTEGER := 0;
            case NUMBER is
            when 4 | 6 | 7 | 11 | 16 | 17 | 25 =>
                B : TIDD_TYPE := (others => 1);
                case NUMBER is
                when 4 =>
                    C : INTEGER_ARRAY_TYPE (1 .. 60) :=
                    (others => 1);
                    D : INTEGER_ARRAY_TYPE (1 .. 60) :=
                    (others => 1);
                when others =>
                    null;
                end case;
            when 5 | 8 | 15 | 21 =>
                E : INTEGER := 0;
                case NUMBER is
                when 8 | 15 =>
                    F : INTEGER_ARRAY_TYPE (1 .. 60) :=
                    (others => 1);
                    case NUMBER is
                    when 8 =>
                        G : STRING (1 .. 720) :=
                        (others => '.');
                        H : INTEGER_ARRAY_TYPE (1 .. 60) :=
                        (others => 1);
                        I : INTEGER_ARRAY_TYPE (1 .. 60) :=
                        (others => 1);
                    when others =>
                        J : INTEGER := 0;
                    end case;
                when others =>
                    null;
                end case;
            when others =>
                null;
            end case;
        when 14 =>
            K : INTEGER_ARRAY_TYPE (1 .. 60) := (others => 1);
        when 1 | 2 | 3 | 12 | 13 | 19 | 24 | 27 | 29 | 31 =>
            null;
        end case;
    end record;

    subtype OUT_PARAMETER_00 is OUT_PARAMETER (00);
    subtype OUT_PARAMETER_04 is OUT_PARAMETER (04);
    subtype OUT_PARAMETER_05 is OUT_PARAMETER (05);
    subtype OUT_PARAMETER_06 is OUT_PARAMETER (06);
    subtype OUT_PARAMETER_08 is OUT_PARAMETER (08);
    subtype OUT_PARAMETER_14 is OUT_PARAMETER (14);
    subtype OUT_PARAMETER_15 is OUT_PARAMETER (15);
    OUT_PARAMETERS_00 : OUT_PARAMETER_00;
    OUT_PARAMETERS_04 : OUT_PARAMETER_04;
    OUT_PARAMETERS_05 : OUT_PARAMETER_05;
    OUT_PARAMETERS_06 : OUT_PARAMETER_06;
    OUT_PARAMETERS_08 : OUT_PARAMETER_08;
    OUT_PARAMETERS_14 : OUT_PARAMETER_14;
    OUT_PARAMETERS_15 : OUT_PARAMETER_15;

    generic
    type OUT_PARAMETERS is private;
    procedure RDWR_OUT_PARAMETERS (LOST_SWITCH : LOST_SWITCH_TYPE;
                   ITEM_1      : in out OUT_PARAMETERS);

--************************************************************************
--**                                                                    **
--**   UNIT NAME :               RDWR_OUT_PARAMETERS                     **
--**   ~~~~~~~~~~~                                                      **
--**                                                                    **
--** DESCRIPTION ------------------------------------------------------ **
--**                                                                    **
--**   This procedure reads or writes the access procedure              **
--**   out_parameters.                                                  **
--**                                                                    **
--** INPUT ------------------------------------------------------------ **
--**                                                                    **
--**   LOST_SWITCH if lost_switch = load the procedure read the         **
--**                                access procedure out_parameters.    **
--**               if lost_switch = store the procedure write the       **
--**                                access procedure out_parameters.    **
--**                                                                    **
--**   ITEM_1 this is the structure of the access procedure             **
--**          out_parameters.                                           **
--**                                                                    **
--** OUTPUT ----------------------------------------------------------- **
--**                                                                    **
--** EXCEPTIONS ------------------------------------------------------- **
--**                                                                    **
--************************************************************************
    MAX_ENUM : constant := 3;
    -- MAX_ENUM defines the max number of enumeration items to
    -- be stored in the file for a given enumeration type; this
    -- limit does not exist in TABLE_DESCRIPTOR.

    type SELECTION_CRITERION_TEST_TYPE is array (1 .. TABLE_NO) of NODE;
    type CONSTRAINTS_TEST_TYPE         is array (1 .. TABLE_NO, 1 .. COL_NO)
                         of STRING
                              (1 .. 2 * RANGE_SIZE);
    type ENUM_TYPES_TEST_TYPE          is array (1 .. TABLE_NO, 1 .. COL_NO,
                         1 .. MAX_ENUM)
                         of STRING (1 .. IMAGE_SZ);
    -- the TABLE_DESCRIPTORS type is to be used for instantiating
    -- DIRECT_IO in order to manage a file which will store the
    -- values of TABLE_DESCRIPTOR and SHARE.
    type TABLE_DESCRIPTORX is
    record
        MAIN                         : TABLE_TYPE;
        SELECTION_CRITERION          : SELECTION_CRITERION_TEST_TYPE;
        CONSTRAINTS                  : CONSTRAINTS_TEST_TYPE;
        ENUM_TYPES                   : ENUM_TYPES_TEST_TYPE :=
                       (others =>
                          (others =>
                         (others => (others => ' '))));
        A_DATABASE_IS_OPEN           : BOOLEAN;
        OPEN_DATABASE_NAME           : STRING (1 .. NAME_LENGTH);
        EMBEDDED_INTERFACE_IS_IN_USE : BOOLEAN;
    end record;



    procedure RDWR_TABLE_DESCRIPTORS (LOST_SWITCH : LOST_SWITCH_TYPE);

--************************************************************************
--**                                                                    **
--**   UNIT NAME :               RDWR_TABLE_DESCRIPTORS                 **
--**   ~~~~~~~~~~~                                                      **
--**                                                                    **
--** DESCRIPTION ------------------------------------------------------ **
--**                                                                    **
--**   This procedure reads or writes the table descriptors.            **
--**                                                                    **
--** INPUT ------------------------------------------------------------ **
--**                                                                    **
--**   LOST_SWITCH if lost_switch = load the procedure read the         **
--**                                table descriptors.                  **
--**               if lost_switch = store the procedure write the       **
--**                                table descriptors.                  **
--**                                                                    **
--** OUTPUT ----------------------------------------------------------- **
--**                                                                    **
--** EXCEPTIONS ------------------------------------------------------- **
--**                                                                    **
--************************************************************************
    procedure EXECUTE_ONE_TEST_CASE;

--************************************************************************
--**                                                                    **
--**   UNIT NAME :               EXECUTE_ONE_TEST_CASE                  **
--**   ~~~~~~~~~~~                                                      **
--**                                                                    **
--** DESCRIPTION ------------------------------------------------------ **
--**                                                                    **
--**   This procedure tests the chosen interface procedure with the     **
--**   chosen test_case.The result of this test_case is recorded in the **
--**   log_file.                                                        **
--**                                                                    **
--** INPUT ------------------------------------------------------------ **
--**                                                                    **
--** OUTPUT ----------------------------------------------------------- **
--**                                                                    **
--** EXCEPTIONS ------------------------------------------------------- **
--**                                                                    **
--************************************************************************
    type RPGW_SWITCH_TYPE is (READ, PUT, GET, WRITE);

    procedure IN_PARAMETERS (RPGW_SWITCH : RPGW_SWITCH_TYPE);

--************************************************************************
--**                                                                    **
--**   UNIT NAME :               IN_PARAMETERS                          **
--**   ~~~~~~~~~~~                                                      **
--**                                                                    **
--** DESCRIPTION ------------------------------------------------------ **
--**                                                                    **
--**   This procedure reads or displays or acquires or writes the       **
--**   interface procedure in_parameters.                               **
--**                                                                    **
--** INPUT ------------------------------------------------------------ **
--**                                                                    **
--**   RPGW_SWITCH if rpgw_switch = read then the procedure reads the   **
--**                                interface procedure in_parameters.  **
--**               if rpgw_switch = put then the procedure displays the **
--**                                interface procedure in_parameters.  **
--**               if rpgw_switch = get then the procedure acquires the **
--**                                interface procedure in_parameters.  **
--**               if rpgw_switch = write the the procedure writes the  **
--**                                interface procedure in_parameters.  **
--**                                                                    **
--** OUTPUT ----------------------------------------------------------- **
--**                                                                    **
--** EXCEPTIONS ------------------------------------------------------- **
--**                                                                    **
--************************************************************************
    procedure OUT_PARAMETERS (RPGW_SWITCH : RPGW_SWITCH_TYPE);

--************************************************************************
--**                                                                    **
--**   UNIT NAME :               OUT_PARAMETERS                         **
--**   ~~~~~~~~~~~                                                      **
--**                                                                    **
--**   This procedure reads or displays or acquires or writes the       **
--**   access procedure out_parameters.                                 **
--**                                                                    **
--** INPUT ------------------------------------------------------------ **
--**                                                                    **
--**   RPGW_SWITCH if rpgw_switch = read then the procedure reads the   **
--**                                access procedure out_parameters.    **
--**               if rpgw_switch = put then the procedure displays the **
--**                                access procedure out_parameters.    **
--**               if rpgw_switch = get then the procedure acquires the **
--**                                access procedure out_parameters.    **
--**               if rpgw_switch = write the the procedure writes the  **
--**                                access procedure out_parameters.    **
--**                                                                    **
--** OUTPUT ----------------------------------------------------------- **
--**                                                                    **
--** EXCEPTIONS ------------------------------------------------------- **
--**                                                                    **
--************************************************************************

end TOOLS;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--tools.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with TEXT_IO;
use TEXT_IO;
with DIRECT_IO;
with DAMES_STATUS;
use DAMES_STATUS;
with DAMES;
use DAMES;
with DISPLAY;
use DISPLAY;
with CALENDAR;
use CALENDAR;

package body TOOLS is

--***************************************************************************--
--                  internal variables              --
--***************************************************************************--

    IN_PARAMETERS_00     : IN_PARAMETER_00;
    IN_PARAMETERS_01     : IN_PARAMETER_01;
    IN_PARAMETERS_04     : IN_PARAMETER_04;
    IN_PARAMETERS_05     : IN_PARAMETER_05;
    IN_PARAMETERS_06     : IN_PARAMETER_06;
    IN_PARAMETERS_09     : IN_PARAMETER_09;
    IN_PARAMETERS_17     : IN_PARAMETER_17;
    IN_PARAMETERS_19     : IN_PARAMETER_19;
    IN_PARAMETERS_20     : IN_PARAMETER_20;

    COLUMN_NUMBER        : POSITIVE;
    COLUMN_LIST          : STRING (1 .. 200);
    ENUM_STRING          : STRING (1 .. 20);
    ITEM                 : RECD;
    NO_MORE_ROW          : BOOLEAN;
    FIND_NEXT_RETURN     : BOOLEAN;
    FIND_PREVIOUS_RETURN : BOOLEAN;
    NEXT_RETURN          : BOOLEAN;
    PREVIOUS_RETURN      : BOOLEAN;

--***************************************************************************--
--                          internal           --
--***************************************************************************--

-------------------------------------------------------------------------------
--          dure GET                                 -------------------------------------------------------------------------------
    procedure GET (S : in out STRING) is

    GOT  : STRING (1 .. 720);
    LAST : NATURAL;
    begin
    GET_LINE (GOT, LAST);
    if LAST /= 0 then
        S := GOT (1 .. LAST) & (LAST + 1 .. S'LENGTH => ' ');
    end if;
    end GET;

-------------------------------------------------------------------------------
--                           procedure I_GET                                 --
-------------------------------------------------------------------------------
    procedure I_GET (I : in out INTEGER) is

    GOT  : STRING (1 .. 12);
    LAST : NATURAL;
    begin
    GET_LINE (GOT, LAST);
    if LAST /= 0 then
        I := INTEGER'VALUE (GOT (1 .. LAST));
    end if;
    end I_GET;

-------------------------------------------------------------------------------
--                           procedure F_GET                                 --
-------------------------------------------------------------------------------
    procedure F_GET (FL : in out FLOAT) is

    GOT    : STRING (1 .. 10);
    LAST_1 : NATURAL;
    LAST_2 : POSITIVE;
    begin
    GET_LINE (GOT, LAST_1);
    if LAST_1 /= 0 then
        F.GET (GOT (1 .. LAST_1), FL, LAST_2);
    end if;
    end F_GET;

    procedure RDWR_POINTER_TABLE (LOST_SWITCH : LOST_SWITCH_TYPE) is

--************************************************************************
--**                                                                    **
--**   UNIT NAME :               RDWR_POINTER_TABLE                     **
--**   ~~~~~~~~~~~                                                      **
--**                                                                    **
--************************************************************************

    package D_IO is new DIRECT_IO (POINTER_TABLE);
    use D_IO;

    FILE_1 : D_IO.FILE_TYPE;

    begin
    OPEN (FILE => FILE_1,
          MODE => D_IO.INOUT_FILE,
          NAME => "t_bed_pointer_table");

    case LOST_SWITCH is

        when LOAD =>
        READ (FILE_1, PT_TABLE, D_IO.POSITIVE_COUNT (INTERFACE_NB + 1));

        when STORE =>
        WRITE (FILE_1, PT_TABLE,
               D_IO.POSITIVE_COUNT (INTERFACE_NB + 1));
    end case;

    CLOSE (FILE_1);

    end RDWR_POINTER_TABLE;

    procedure RDWR_IN_PARAMETERS (LOST_SWITCH : LOST_SWITCH_TYPE;
                  ITEM_1      : in out IN_PARAMETERS) is

--************************************************************************
--**                                                                    **
--**   UNIT NAME :               RDWR_IN_PARAMETERS                     **
--**   ~~~~~~~~~~~                                                      **
--**                                                                    **
--************************************************************************

    package D_IO is new DIRECT_IO (IN_PARAMETERS);
    use D_IO;

    FILE_1 : D_IO.FILE_TYPE;

    begin

    D_IO.OPEN (FILE => FILE_1,
           MODE => D_IO.INOUT_FILE,
           NAME => "t_bed_in_p_" &
               INTERFACE_PROCEDURE_NAME'IMAGE
                 (INTERFACE_PROCEDURE_NAME'VAL (INTERFACE_NB)));

    case LOST_SWITCH is

        when LOAD =>
        READ (FILE_1, ITEM_1, D_IO.POSITIVE_COUNT (TEST_CASE_NB));

        when STORE =>
        WRITE (FILE_1, ITEM_1, D_IO.POSITIVE_COUNT (TEST_CASE_NB));

    end case;

    CLOSE (FILE_1);

    end RDWR_IN_PARAMETERS;
    procedure RDWR_OUT_PARAMETERS (LOST_SWITCH : LOST_SWITCH_TYPE;
                   ITEM_1      : in out OUT_PARAMETERS) is

--************************************************************************
--**                                                                    **
--**   UNIT NAME :               RDWR_OUT_PARAMETERS                    **
--**   ~~~~~~~~~~~                                                      **
--**                                                                    **
--************************************************************************

    package D_IO is new DIRECT_IO (OUT_PARAMETERS);
    use D_IO;

    FILE_1                 : D_IO.FILE_TYPE;
    OUT_PARAMETERS_ADDRESS : D_IO.POSITIVE_COUNT;

    begin

    D_IO.OPEN (FILE => FILE_1,
           MODE => D_IO.INOUT_FILE,
           NAME => "t_bed_out_p_" &
               ACCESS_PROCEDURE_NAME'IMAGE
                 (ACCESS_PROCEDURE_NAME'VAL (ACCESS_NB)));

    OUT_PARAMETERS_ADDRESS :=
      D_IO.POSITIVE_COUNT (ARR'LENGTH * INTERFACE_NB + TEST_CASE_NB);

    case LOST_SWITCH is

        when LOAD =>
        READ (FILE_1, ITEM_1, OUT_PARAMETERS_ADDRESS);

        when STORE =>
        WRITE (FILE_1, ITEM_1, OUT_PARAMETERS_ADDRESS);

    end case;

    CLOSE (FILE_1);

    end RDWR_OUT_PARAMETERS;
    procedure RDWR_TABLE_DESCRIPTORS (LOST_SWITCH : LOST_SWITCH_TYPE) is

--************************************************************************
--**                                                                    **
--**   UNIT NAME :               RDWR_TABLE_DESCRIPTORS                 **
--**   ~~~~~~~~~~~                                                      **
--************************************************************************

    package D_IO is new DIRECT_IO (TABLE_DESCRIPTORX);
    use D_IO;

    FILE_1                    : D_IO.FILE_TYPE;
    TABLE_DESCRIPTORS_ADDRESS : D_IO.POSITIVE_COUNT;
    CURRENT                   : ENUM_ITEM_ACCESS;
    K                         : INTEGER;
    TB_DESCRIPTORS            : TABLE_DESCRIPTORX;

    begin
    OPEN (FILE => FILE_1,
          MODE => D_IO.INOUT_FILE,
          NAME => "t_bed_table_descriptors");

    TABLE_DESCRIPTORS_ADDRESS :=
      D_IO.POSITIVE_COUNT (ARR'LENGTH * INTERFACE_NB + TEST_CASE_NB);

    case LOST_SWITCH is

        when LOAD =>
        READ (FILE_1, TB_DESCRIPTORS, TABLE_DESCRIPTORS_ADDRESS);

        -- GET_DESCRIPTOR must be used in order to fill the
        -- TABLE_DESCRIPTOR package when a TABLE_DESCRIPTORS
        -- record has been read from the corresponding file.

        SHARE.A_DATABASE_IS_OPEN := TB_DESCRIPTORS.A_DATABASE_IS_OPEN;
        SHARE.OPEN_DATABASE_NAME := TB_DESCRIPTORS.OPEN_DATABASE_NAME;

        DAMES_STATUS.EMBEDDED_INTERFACE_IS_IN_USE :=
          TB_DESCRIPTORS.EMBEDDED_INTERFACE_IS_IN_USE;

        TABLE := TB_DESCRIPTORS.MAIN;

        for I in 1 .. TABLE_NO loop
            if TABLE (I).TABLE_STATUS.SELECTION_CRITERION /= null then
            TABLE (I).TABLE_STATUS.SELECTION_CRITERION := new NODE;
            TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all :=
              TB_DESCRIPTORS.SELECTION_CRITERION (I);
            end if;
        end loop;

        for I in 1 .. TABLE_NO loop
            for J in 1 .. COL_NO loop
            if TABLE (I).TABLE_DEFINITION.CONSTRAINTS (J) /=
               null then
                TABLE (I).TABLE_DEFINITION.CONSTRAINTS (J) :=
                  new STRING (1 .. 2 * RANGE_SIZE);
                TABLE (I).TABLE_DEFINITION.CONSTRAINTS (J).all :=
                  TB_DESCRIPTORS.CONSTRAINTS (I, J);
            end if;
            end loop;
        end loop;
        for I in 1 .. TABLE_NO loop
            for J in 1 .. COL_NO loop
            TABLE (I).TABLE_DEFINITION.ENUM_TYPES (J) := null;

            for K in 1 .. MAX_ENUM loop
                exit when TB_DESCRIPTORS.ENUM_TYPES (I, J, K) =
                      (1 .. IMAGE_SZ => ' ');
                if K = 1 then
                CURRENT := new ENUM_ITEM;
                TABLE (I).TABLE_DEFINITION.ENUM_TYPES (J) :=
                  CURRENT;
                else
                CURRENT.all.OTHER := new ENUM_ITEM;
                CURRENT := CURRENT.all.OTHER;
                end if;
                CURRENT.all.ENUM_IMAGE :=
                  TB_DESCRIPTORS.ENUM_TYPES (I, J, K);
            end loop;
            end loop;
        end loop;

        when STORE =>

-- PUT_DESCRIPTOR must be used in order to fill a
-- TABLE_DESCRIPTORS record to be written into the
-- associated file.

        TB_DESCRIPTORS.A_DATABASE_IS_OPEN := SHARE.A_DATABASE_IS_OPEN;
        TB_DESCRIPTORS.OPEN_DATABASE_NAME := SHARE.OPEN_DATABASE_NAME;

        TB_DESCRIPTORS.EMBEDDED_INTERFACE_IS_IN_USE :=
          DAMES_STATUS.EMBEDDED_INTERFACE_IS_IN_USE;

        TB_DESCRIPTORS.MAIN := TABLE;

        for I in 1 .. TABLE_NO loop
            if TABLE (I).TABLE_STATUS.SELECTION_CRITERION /= null then
            TB_DESCRIPTORS.SELECTION_CRITERION (I) :=
              TABLE (I).TABLE_STATUS.SELECTION_CRITERION.all;
            end if;
        end loop;

        for I in 1 .. TABLE_NO loop
            for J in 1 .. COL_NO loop
            if TABLE (I).TABLE_DEFINITION.CONSTRAINTS (J) /=
               null then
                TB_DESCRIPTORS.CONSTRAINTS (I, J) :=
                  TABLE (I).TABLE_DEFINITION.CONSTRAINTS (J).all;
            end if;
            end loop;
        end loop;

        for I in 1 .. TABLE_NO loop
            for J in 1 .. COL_NO loop
            CURRENT := TABLE (I).TABLE_DEFINITION.ENUM_TYPES (J);
            K := 1;

            while CURRENT /= null loop
                TB_DESCRIPTORS.ENUM_TYPES (I, J, K) :=
                  CURRENT.all.ENUM_IMAGE;
                K := K + 1;
                CURRENT := CURRENT.all.OTHER;
                exit when K = MAX_ENUM + 1;
            end loop;
            end loop;
        end loop;

        WRITE (FILE_1, TB_DESCRIPTORS, TABLE_DESCRIPTORS_ADDRESS);
    end case;

    CLOSE (FILE_1);

    end RDWR_TABLE_DESCRIPTORS;
    procedure EXECUTE_ONE_TEST_CASE is

--************************************************************************
--**                                                                    **
--**   UNIT NAME :               EXECUTE_ONE_TEST_CASE                  **
--**   ~~~~~~~~~~~                                                      **
--************************************************************************

    FLOAT_STR : STRING (1 .. 15);

    begin
    IN_PARAMETERS (READ);
    RDWR_TABLE_DESCRIPTORS (LOAD);

    if not AUTOMATIC_VERSION then
        if IN_PARAMETER_IS_OPEN (INTERFACE_NB) then
        IN_PARAMETERS (PUT);
        if MODIFY then
            IN_PARAMETERS (GET);
        end if;
        end if;
        UPDATE_STATUS;
        NEW_PAGE;
    end if;

    SET_OUTPUT (LOG_FILE);
    NEW_PAGE;
    PUT ("***********************************************************************");
    NEW_LINE;
    PUT ("DATE :");
    PUT (INTEGER'IMAGE (YEAR (CLOCK)) & "/" &
         INTEGER'IMAGE (MONTH (CLOCK)) & "/" & INTEGER'IMAGE (DAY (CLOCK)));
    PUT ("  interface procedure " &
         INTERFACE_PROCEDURE_NAME'IMAGE (INTERFACE_PR_NAME));
    PUT ("  test case " & PT_TABLE.TEST_CASE (TEST_CASE_NB).NAME);
    NEW_LINE;
    PUT ("***********************************************************************");
    NEW_LINE (4);
    PUT ("------------ INTERFACE PROCEDURE IN_PARAMETERS ---------------");
    DISPLAY_SWITCH := LIST;
    IN_PARAMETERS (PUT);
    NEW_LINE (4);
    PUT ("------------ TABLE DESCRIPTORS -------------------------------");
    UPDATE_STATUS;
    DISPLAY_SWITCH := MODIFY;
    SET_OUTPUT (STANDARD_OUTPUT);

-------------------------------------------------------------------------------
--  Execute the interface procedure.
-------------------------------------------------------------------------------
    declare
        OH : constant STRING := "Exception raised : ";
    begin

        case INTERFACE_NB is

        when 00 =>  DAMES.OPEN (IN_PARAMETERS_00.DB_NAME);

        when 01 =>  DAMES.EXECUTE (IN_PARAMETERS_01.COMMAND);

        when 02 =>  DAMES.CLOSE;

        when 03 =>  LL_DAMES.OPEN (IN_PARAMETERS_00.DB_NAME);

        when 04 =>  LL_DAMES.DEFINE_TABLE
                   (IN_PARAMETERS_04.TABLE_NAME,
                IN_PARAMETERS_04.COLUMN_LIST);

        when 05 =>  LL_DAMES.LOCK
                   (IN_PARAMETERS_05.LOCK_LIST
                   (1 .. IN_PARAMETERS_05.LLL));

        when 06 =>
            LL_DAMES.GET_INFORMATION
               (IN_PARAMETERS_06.TABLE_NAME, COLUMN_NUMBER,
            COLUMN_LIST);
            PRINT ("COLUMN_NUMBER := " &
               POSITIVE'IMAGE (COLUMN_NUMBER) & ASCII.LF &
               "COLUMN_LIST   := " & COLUMN_LIST);

        when 07 =>  LL_DAMES.UNLOCK;

        when 08 =>  LL_DAMES.CLOSE;

        when 09 =>
            E_MATCH (IN_PARAMETERS_09.TABLE_NAME,
                 IN_PARAMETERS_09.COLUMN_NAME,
                 IN_PARAMETERS_09.KEY_MATCH,
                 IN_PARAMETERS_09.COLUMN_VALUE.ENU);

        when 10 =>
            F_MATCH (IN_PARAMETERS_09.TABLE_NAME,
                 IN_PARAMETERS_09.COLUMN_NAME,
                 IN_PARAMETERS_09.KEY_MATCH,
                 IN_PARAMETERS_09.COLUMN_VALUE.FLO);

        when 11 =>
            I_MATCH (IN_PARAMETERS_09.TABLE_NAME,
                 IN_PARAMETERS_09.COLUMN_NAME,
                 IN_PARAMETERS_09.KEY_MATCH,
                 IN_PARAMETERS_09.COLUMN_VALUE.INT);

        when 12 =>
            R_MATCH (IN_PARAMETERS_09.TABLE_NAME,
                 IN_PARAMETERS_09.COLUMN_NAME,
                 IN_PARAMETERS_09.KEY_MATCH,
                 IN_PARAMETERS_09.COLUMN_VALUE);
        when 13 =>
            S_MATCH (IN_PARAMETERS_09.TABLE_NAME,
                 IN_PARAMETERS_09.COLUMN_NAME,
                 IN_PARAMETERS_09.KEY_MATCH,
                 IN_PARAMETERS_09.COLUMN_VALUE.STR);

        when 14 =>
            E_OR_MATCH
               (IN_PARAMETERS_09.TABLE_NAME,
            IN_PARAMETERS_09.COLUMN_NAME,
            IN_PARAMETERS_09.KEY_MATCH,
            IN_PARAMETERS_09.COLUMN_VALUE.ENU);

        when 15 =>
            F_OR_MATCH
               (IN_PARAMETERS_09.TABLE_NAME,
            IN_PARAMETERS_09.COLUMN_NAME,
            IN_PARAMETERS_09.KEY_MATCH,
            IN_PARAMETERS_09.COLUMN_VALUE.FLO);

        when 16 =>
            I_OR_MATCH
               (IN_PARAMETERS_09.TABLE_NAME,
            IN_PARAMETERS_09.COLUMN_NAME,
            IN_PARAMETERS_09.KEY_MATCH,
            IN_PARAMETERS_09.COLUMN_VALUE.INT);

        when 17 =>
            R_OR_MATCH
               (IN_PARAMETERS_09.TABLE_NAME,
            IN_PARAMETERS_09.COLUMN_NAME,
            IN_PARAMETERS_09.KEY_MATCH,
            IN_PARAMETERS_09.COLUMN_VALUE);

        when 18 =>
            S_OR_MATCH
               (IN_PARAMETERS_09.TABLE_NAME,
            IN_PARAMETERS_09.COLUMN_NAME,
            IN_PARAMETERS_09.KEY_MATCH,
            IN_PARAMETERS_09.COLUMN_VALUE.STR);

        when 19 =>
            E_AND_MATCH
               (IN_PARAMETERS_09.TABLE_NAME,
            IN_PARAMETERS_09.COLUMN_NAME,
            IN_PARAMETERS_09.KEY_MATCH,
            IN_PARAMETERS_09.COLUMN_VALUE.ENU);

        when 20 =>
            F_AND_MATCH
               (IN_PARAMETERS_09.TABLE_NAME,
            IN_PARAMETERS_09.COLUMN_NAME,
            IN_PARAMETERS_09.KEY_MATCH,
            IN_PARAMETERS_09.COLUMN_VALUE.FLO);
        when 21 =>
            I_AND_MATCH
               (IN_PARAMETERS_09.TABLE_NAME,
            IN_PARAMETERS_09.COLUMN_NAME,
            IN_PARAMETERS_09.KEY_MATCH,
            IN_PARAMETERS_09.COLUMN_VALUE.INT);

        when 22 =>
            R_AND_MATCH
               (IN_PARAMETERS_09.TABLE_NAME,
            IN_PARAMETERS_09.COLUMN_NAME,
            IN_PARAMETERS_09.KEY_MATCH,
            IN_PARAMETERS_09.COLUMN_VALUE);

        when 23 =>
            S_AND_MATCH
               (IN_PARAMETERS_09.TABLE_NAME,
            IN_PARAMETERS_09.COLUMN_NAME,
            IN_PARAMETERS_09.KEY_MATCH,
            IN_PARAMETERS_09.COLUMN_VALUE.STR);

        when 24 =>  LL_DAMES.FIND (IN_PARAMETERS_06.TABLE_NAME);

        when 25 =>
            FIND_NEXT_RETURN :=
              LL_DAMES.FIND_NEXT (IN_PARAMETERS_06.TABLE_NAME);
            PRINT ("FIND_NEXT_RETURN := " &
               BOOLEAN'IMAGE (FIND_NEXT_RETURN));

        when 26 =>
            FIND_PREVIOUS_RETURN :=
              LL_DAMES.FIND_PREVIOUS (IN_PARAMETERS_06.TABLE_NAME);
            PRINT ("FIND_PREVIOUS_RETURN := " &
               BOOLEAN'IMAGE (FIND_PREVIOUS_RETURN));

        when 27 =>
            NEXT_RETURN := LL_DAMES.NEXT (IN_PARAMETERS_06.TABLE_NAME);
            PRINT ("NEXT_RETURN := " & BOOLEAN'IMAGE (NEXT_RETURN));

        when 28 =>
            PREVIOUS_RETURN :=
              LL_DAMES.PREVIOUS (IN_PARAMETERS_06.TABLE_NAME);
            PRINT ("PREVIOUS_RETURN := " &
               BOOLEAN'IMAGE (PREVIOUS_RETURN));

        when 29 =>
            E_GET_COLUMN
               (IN_PARAMETERS_17.TABLE_NAME,
            IN_PARAMETERS_17.COLUMN_NAME, ITEM.ENU);
            PRINT ("ITEM.ENU := " & ENUM'IMAGE (ITEM.ENU));

        when 30 =>
            F_GET_COLUMN
               (IN_PARAMETERS_17.TABLE_NAME,
            IN_PARAMETERS_17.COLUMN_NAME, ITEM.FLO);
            F.PUT (FLOAT_STR, ITEM.FLO);
            PRINT ("ITEM.FLO := " & FLOAT_STR);
        when 31 =>
            I_GET_COLUMN
               (IN_PARAMETERS_17.TABLE_NAME,
            IN_PARAMETERS_17.COLUMN_NAME, ITEM.INT);
            PRINT ("ITEM.INT := " & INTEGER'IMAGE (ITEM.INT));

        when 32 =>
            R_GET_COLUMN
               (IN_PARAMETERS_17.TABLE_NAME,
            IN_PARAMETERS_17.COLUMN_NAME, ITEM);
            F.PUT (FLOAT_STR, ITEM.FLO);
            PRINT ("ITEM.ENU := " & ENUM'IMAGE (ITEM.ENU) & ASCII.LF &
               "ITEM.INT := " & INTEGER'IMAGE (ITEM.INT) &
               ASCII.LF & "ITEM.STR := " & ITEM.STR & ASCII.LF &
               "ITEM.FLO := " & FLOAT_STR);

        when 33 =>
            S_GET_COLUMN
               (IN_PARAMETERS_17.TABLE_NAME,
            IN_PARAMETERS_17.COLUMN_NAME, ITEM.STR);
            PRINT ("ITEM.STR := " & ITEM.STR);

        when 34 =>
            E_GET_ROW (IN_PARAMETERS_06.TABLE_NAME, ITEM.ENU);
            PRINT ("ITEM.ENU := " & ENUM'IMAGE (ITEM.ENU));

        when 35 =>
            F_GET_ROW (IN_PARAMETERS_06.TABLE_NAME, ITEM.FLO);
            F.PUT (FLOAT_STR, ITEM.FLO);
            PRINT ("ITEM.FLO := " & FLOAT_STR);

        when 36 =>
            I_GET_ROW (IN_PARAMETERS_06.TABLE_NAME, ITEM.INT);
            PRINT ("ITEM.INT := " & INTEGER'IMAGE (ITEM.INT));

        when 37 =>
            R_GET_ROW (IN_PARAMETERS_06.TABLE_NAME, ITEM);
            F.PUT (FLOAT_STR, ITEM.FLO);
            PRINT ("ITEM.ENU := " & ENUM'IMAGE (ITEM.ENU) & ASCII.LF &
               "ITEM.INT := " & INTEGER'IMAGE (ITEM.INT) &
               ASCII.LF & "ITEM.STR := " & ITEM.STR & ASCII.LF &
               "ITEM.FLO := " & FLOAT_STR);

        when 38 =>
            S_GET_ROW (IN_PARAMETERS_06.TABLE_NAME, ITEM.STR);
            PRINT ("ITEM.STR := " & ITEM.STR);

        when 39 =>
            E_BUILD_COLUMN
               (IN_PARAMETERS_19.TABLE_NAME,
            IN_PARAMETERS_19.COLUMN_NAME,
            IN_PARAMETERS_19.ITEM.ENU);

        when 40 =>
            F_BUILD_COLUMN
               (IN_PARAMETERS_19.TABLE_NAME,
            IN_PARAMETERS_19.COLUMN_NAME,
            IN_PARAMETERS_19.ITEM.FLO);
        when 41 =>
            I_BUILD_COLUMN
               (IN_PARAMETERS_19.TABLE_NAME,
            IN_PARAMETERS_19.COLUMN_NAME,
            IN_PARAMETERS_19.ITEM.INT);

        when 42 =>
            R_BUILD_COLUMN
               (IN_PARAMETERS_19.TABLE_NAME,
            IN_PARAMETERS_19.COLUMN_NAME, IN_PARAMETERS_19.ITEM);

        when 43 =>
            S_BUILD_COLUMN
               (IN_PARAMETERS_19.TABLE_NAME,
            IN_PARAMETERS_19.COLUMN_NAME,
            IN_PARAMETERS_19.ITEM.STR);

        when 44 =>
            E_BUILD_ROW
               (IN_PARAMETERS_20.TABLE_NAME, IN_PARAMETERS_20.ITM.ENU);

        when 45 =>
            F_BUILD_ROW
               (IN_PARAMETERS_20.TABLE_NAME, IN_PARAMETERS_20.ITM.FLO);

        when 46 =>
            I_BUILD_ROW
               (IN_PARAMETERS_20.TABLE_NAME, IN_PARAMETERS_20.ITM.INT);

        when 47 =>
            R_BUILD_ROW
               (IN_PARAMETERS_20.TABLE_NAME, IN_PARAMETERS_20.ITM);

        when 48 =>
            S_BUILD_ROW
               (IN_PARAMETERS_20.TABLE_NAME, IN_PARAMETERS_20.ITM.STR);

        when 49 =>  LL_DAMES.UPDATE (IN_PARAMETERS_06.TABLE_NAME);

        when 50 =>  LL_DAMES.INSERT (IN_PARAMETERS_06.TABLE_NAME);

        when 51 =>
            LL_DAMES.DELETE (IN_PARAMETERS_06.TABLE_NAME, NO_MORE_ROW);
            PRINT ("NO_MORE_ROW :=" & BOOLEAN'IMAGE (NO_MORE_ROW));

        when others =>  null;
        end case;
-------------------------------------------------------------------------------
--  Store the raised exceptions  of the interface procedure                  --
-------------------------------------------------------------------------------
    exception

-- This exceptions is raised in DAMES subprograms when errors occur in.

        when X_DAMES_ERROR =>  PRINT (OH & " X_DAMES_ERROR ");

-- These exceptions are raised in the LL_DAMES subprograms
-- when errors occur in.

        when X_CANT_ACCESS_DB =>  PRINT (OH & " X_CANT_ACCESS_DB ");
        when X_CANT_ACCESS_TABLE =>  PRINT (OH & " X_CANT_ACCESS_TABLE ");
        when X_FULL_TABLE =>  PRINT (OH & " X_FULL_TABLE ");
        when X_INTERNAL_ERROR =>  PRINT (OH & " X_INTERNAL_ERROR ");
        when X_INVALID_COLUMN =>  PRINT (OH & " X_INVALID_COLUMN ");
        when X_INVALID_CRITERION =>  PRINT (OH & " X_INVALID_CRITERION ");
        when X_INVALID_VALUE =>  PRINT (OH & " X_INVALID_VALUE ");
        when X_NO_CURRENT_ROW =>  PRINT (OH & " X_NO_CURRENT_ROW ");
        when X_NO_MORE_ROWS =>  PRINT (OH & " X_NO_MORE_ROWS ");
        when X_NO_OPEN_DB =>  PRINT (OH & " X_NO_OPEN_DB ");
        when X_NO_PREVIOUS_FIND =>  PRINT (OH & " X_NO_PREVIOUS_FIND ");
        when X_NO_PREVIOUS_MATCH =>  PRINT (OH & " X_NO_PREVIOUS_MATCH ");
        when X_OPEN_DB =>  PRINT (OH & " X_OPEN_DB ");
        when X_SHARED_MODE_LOCK =>  PRINT (OH & " X_SHARED_MODE_LOCK ");
        when X_TABLE_NOT_LOCKED =>  PRINT (OH & " X_TABLE_NOT_LOCKED ");
        when X_TOO_SHORT_STRING =>  PRINT (OH & " X_TOO_SHORT_STRING ");

-- these are the predefined exceptions.

        when CONSTRAINT_ERROR =>  PRINT (OH & " CONSTRAINT_ERROR ");
        when NUMERIC_ERROR =>  PRINT (OH & " NUMERIC_ERROR ");
        when PROGRAM_ERROR =>  PRINT (OH & " PROGRAM_ERROR ");
        when STORAGE_ERROR =>  PRINT (OH & " STORAGE_ERROR ");
        when TASKING_ERROR =>  PRINT (OH & " TASKING_ERROR ");
        when others =>  PRINT (OH & " OTHERS ");
    end;
    if not AUTOMATIC_VERSION then
        SET_OUTPUT (STANDARD_OUTPUT);
        NEW_PAGE;
        PUT (TEST_BED_FUNCTION'IMAGE (T_B_FUNCTION) &
         " interface procedure " &
         INTERFACE_PROCEDURE_NAME'IMAGE (INTERFACE_PR_NAME));
        NEW_LINE (8);
        PUT ("TEST CASE " & PT_TABLE.TEST_CASE (TEST_CASE_NB).NAME &
         " terminated ");
        DISPL (0, 23, "Do you want to read the table_descriptors (y/n) ? ");
        loop
        SCREEN_POS (50, 23);  GET (A);
        exit when A = 'y' or A = 'n';
        end loop;
        if A = 'y' then
        DISPLAY_SWITCH := READ;
        UPDATE_STATUS;
        DISPLAY_SWITCH := MODIFY;
        end if;
    end if;

    SET_OUTPUT (LOG_FILE);
    NEW_LINE (4);
    PUT ("------------ TABLE DESCRIPTORS -------------------------------");
    DISPLAY_SWITCH := LIST;
    UPDATE_STATUS;
    DISPLAY_SWITCH := MODIFY;
    SET_OUTPUT (STANDARD_OUTPUT);

    end EXECUTE_ONE_TEST_CASE;
    procedure IN_PARAMETERS (RPGW_SWITCH : RPGW_SWITCH_TYPE) is

--************************************************************************
--**                                                                    **
--**   UNIT NAME :               IN_PARAMETERS                          **
--**   ~~~~~~~~~~~                                                      **
--************************************************************************

    procedure RDWR_IN_PARAMETERS_00 is new RDWR_IN_PARAMETERS
           (IN_PARAMETER_00);
    procedure RDWR_IN_PARAMETERS_01 is new RDWR_IN_PARAMETERS
           (IN_PARAMETER_01);
    procedure RDWR_IN_PARAMETERS_04 is new RDWR_IN_PARAMETERS
           (IN_PARAMETER_04);
    procedure RDWR_IN_PARAMETERS_05 is new RDWR_IN_PARAMETERS
           (IN_PARAMETER_05);
    procedure RDWR_IN_PARAMETERS_06 is new RDWR_IN_PARAMETERS
           (IN_PARAMETER_06);
    procedure RDWR_IN_PARAMETERS_09 is new RDWR_IN_PARAMETERS
           (IN_PARAMETER_09);
    procedure RDWR_IN_PARAMETERS_17 is new RDWR_IN_PARAMETERS
           (IN_PARAMETER_17);
    procedure RDWR_IN_PARAMETERS_19 is new RDWR_IN_PARAMETERS
           (IN_PARAMETER_19);
    procedure RDWR_IN_PARAMETERS_20 is new RDWR_IN_PARAMETERS
           (IN_PARAMETER_20);

    LOST_SWITCH : LOST_SWITCH_TYPE;

-------------------------------------------------------------------------------
    procedure PUT (C : COLUMN_TYPE; RCD : RECD) is
    begin
        case INTERFACE_NB is
        when 9 | 14 | 19 | 29 | 34 | 39 | 44 =>
            PUT_LINE (".ENU : " & ENUM'IMAGE (RCD.ENU));
        when 10 | 15 | 20 | 30 | 35 | 40 | 45 =>
            PUT (".FLO : ");  F.PUT (RCD.FLO);
            NEW_LINE;
        when 11 | 16 | 21 | 31 | 36 | 41 | 46 =>
            PUT_LINE (".INT : " & INTEGER'IMAGE (RCD.INT));
        when 12 | 17 | 22 | 32 | 37 | 42 | 47 =>
            PUT_LINE (".ENU : " & ENUM'IMAGE (RCD.ENU));
            SET_COL (POSITIVE_COUNT (C));
            PUT (".FLO : ");  F.PUT (RCD.FLO);
            NEW_LINE;
            SET_COL (POSITIVE_COUNT (C));
            PUT_LINE (".INT : " & INTEGER'IMAGE (RCD.INT));
            SET_COL (POSITIVE_COUNT (C));
            PUT_LINE (".STR : " & RCD.STR);
        when 13 | 18 | 23 | 33 | 38 | 43 | 48 =>
            PUT_LINE (".STR : " & RCD.STR);
        when others =>  null;
        end case;
    end PUT;
-------------------------------------------------------------------------------
    procedure GET (C : COLUMN_TYPE; R : ROW_TYPE; RCD : in out RECD) is
    begin
        SCREEN_POS (C, R);
        case INTERFACE_NB is
        when 9 | 14 | 19 | 29 | 34 | 39 | 44 =>
            GET_LINE (ENUM_STRING, LAST);
            if LAST /= 0 then
            RCD.ENU := ENUM'VALUE (ENUM_STRING (1 .. LAST));
            end if;

        when 10 | 15 | 20 | 30 | 35 | 40 | 45 =>
            F_GET (RCD.FLO);
        when 11 | 16 | 21 | 31 | 36 | 41 | 46 =>
            I_GET (RCD.INT);
        when 12 | 17 | 22 | 32 | 37 | 42 | 47 =>
            GET_LINE (ENUM_STRING, LAST);
            if LAST /= 0 then
            RCD.ENU := ENUM'VALUE (ENUM_STRING (1 .. LAST));
            end if;
            SCREEN_POS (C, R + 1);
            F_GET (RCD.FLO);
            SCREEN_POS (C, R + 2);
            I_GET (RCD.INT);
            SCREEN_POS (C, R + 3);
            GET (RCD.STR);
        when 13 | 18 | 23 | 33 | 38 | 43 | 48 =>
            GET (RCD.STR);
        when others =>  null;
        end case;
    end GET;
-------------------------------------------------------------------------------
--                            procedure body                                 --
-------------------------------------------------------------------------------
    begin
    PARAMETER := IN_PARAMETERS;

    case RPGW_SWITCH is
        when READ =>
        NEW_PAGE;
        LOST_SWITCH := LOAD;
        when WRITE =>
        NEW_PAGE;
        LOST_SWITCH := STORE;
        when PUT =>
        NEWPAGE;
        when GET =>  null;
    end case;

    case INTERFACE_NB is
        when 0 | 3 =>
        case RPGW_SWITCH is
            when PUT =>
            PUT_LINE ("DB_NAME : " & IN_PARAMETERS_00.DB_NAME);
            when GET =>
            SCREEN_POS (10, 3);
            GET (IN_PARAMETERS_00.DB_NAME);
            when others =>
            RDWR_IN_PARAMETERS_00 (LOST_SWITCH, IN_PARAMETERS_00);
        end case;

        when 1 =>
        case RPGW_SWITCH is
            when PUT =>
            PUT_LINE ("COMMAND : " & IN_PARAMETERS_01.COMMAND);
            when GET =>
            SCREEN_POS (10, 3);
            GET (IN_PARAMETERS_01.COMMAND);
            when others =>
            RDWR_IN_PARAMETERS_01 (LOST_SWITCH, IN_PARAMETERS_01);
        end case;
        when 2 | 7 | 8 =>
        null;
        when 5 =>
        case RPGW_SWITCH is
            when PUT =>
            PUT_LINE ("LLL := " &
                  INTEGER'IMAGE (IN_PARAMETERS_05.LLL));
            for I in 1 .. IN_PARAMETERS_05.LLL loop
                PUT_LINE ("LOCK_LIST (" & INTEGER'IMAGE (I) &
                      ").TABLE_NAME : " &
                      IN_PARAMETERS_05.LOCK_LIST (I)
                       .TABLE_NAME);
                PUT_LINE ("LOCK_LIST (" & INTEGER'IMAGE (I) &
                      ").ACCESS_MODE : " &
                      ACCESS_MODE_TYPE'IMAGE
                    (IN_PARAMETERS_05.LOCK_LIST (I)
                      .ACCESS_MODE));
            end loop;
            when GET =>
            SCREEN_POS (08, 3);
            I_GET (IN_PARAMETERS_05.LLL);
            for I in 1 .. IN_PARAMETERS_05.LLL loop
                SCREEN_POS (28, 2 * I + 2);
                GET (IN_PARAMETERS_05.LOCK_LIST (I).TABLE_NAME);
                SCREEN_POS (29, 2 * I + 3);
                GET_LINE (ENUM_STRING, LAST);
                if LAST /= 0 then
                IN_PARAMETERS_05.LOCK_LIST (I).ACCESS_MODE :=
                  ACCESS_MODE_TYPE'VALUE
                    (ENUM_STRING (1 .. LAST));
                end if;
            end loop;
            when others =>
            RDWR_IN_PARAMETERS_05 (LOST_SWITCH, IN_PARAMETERS_05);
        end case;

        when others =>
        case INTERFACE_NB is
            when 4 =>
            case RPGW_SWITCH is
                when PUT =>
                PUT_LINE ("TABLE_NAME : " &
                      IN_PARAMETERS_04.TABLE_NAME);
                PUT_LINE ("COLUMN_LIST : " &
                      IN_PARAMETERS_04.COLUMN_LIST);
                when GET =>
                SCREEN_POS (13, 3);
                GET (IN_PARAMETERS_04.TABLE_NAME);
                SCREEN_POS (14, 4);
                GET (IN_PARAMETERS_04.COLUMN_LIST);
                when others =>
                RDWR_IN_PARAMETERS_04
                   (LOST_SWITCH, IN_PARAMETERS_04);
            end case;
            when 44 .. 48 =>
            case RPGW_SWITCH is
                when PUT =>
                PUT_LINE ("TABLE_NAME : " &
                      IN_PARAMETERS_20.TABLE_NAME);
                PUT ("ITM");  PUT (4, IN_PARAMETERS_20.ITM);
                when GET =>
                SCREEN_POS (13, 3);
                GET (IN_PARAMETERS_20.TABLE_NAME);
                GET (9, 4, IN_PARAMETERS_20.ITM);
                when others =>
                RDWR_IN_PARAMETERS_20
                   (LOST_SWITCH, IN_PARAMETERS_20);
            end case;

            when 09 .. 23 | 29 .. 33 | 39 .. 43 =>
            case INTERFACE_NB is
                when 09 .. 23 =>
                case RPGW_SWITCH is
                    when PUT =>
                    PUT_LINE ("TABLE_NAME : " &
                          IN_PARAMETERS_09.TABLE_NAME);
                    PUT_LINE ("COLUMN_NAME : " &
                          IN_PARAMETERS_09.COLUMN_NAME);
                    PUT_LINE ("KEY_MATCH : " &
                          KEY_MATCH_TYPE'IMAGE
                            (IN_PARAMETERS_09
                              .KEY_MATCH));
                    PUT ("COLUMN_VALUE");
                    PUT (13, IN_PARAMETERS_09.COLUMN_VALUE);
                    when GET =>
                    SCREEN_POS (13, 3);
                    GET (IN_PARAMETERS_09.TABLE_NAME);
                    SCREEN_POS (14, 4);
                    GET (IN_PARAMETERS_09.COLUMN_NAME);
                    SCREEN_POS (12, 5);
                    GET_LINE (ENUM_STRING, LAST);
                    if LAST /= 0 then
                        IN_PARAMETERS_09.KEY_MATCH :=
                          KEY_MATCH_TYPE'VALUE
                        (ENUM_STRING (1 .. LAST));
                    end if;
                    GET (19, 6,
                         IN_PARAMETERS_09.COLUMN_VALUE);
                    when others =>
                    RDWR_IN_PARAMETERS_09
                       (LOST_SWITCH, IN_PARAMETERS_09);
                end case;
                when 39 .. 43 =>
                case RPGW_SWITCH is
                    when PUT =>
                    PUT_LINE ("TABLE_NAME : " &
                          IN_PARAMETERS_19.TABLE_NAME);
                    PUT_LINE ("COLUMN_NAME : " &
                          IN_PARAMETERS_19.COLUMN_NAME);
                    PUT ("ITEM");
                    PUT (5, IN_PARAMETERS_19.ITEM);
                    when GET =>
                    SCREEN_POS (13, 3);
                    GET (IN_PARAMETERS_19.TABLE_NAME);
                    SCREEN_POS (14, 4);
                    GET (IN_PARAMETERS_19.COLUMN_NAME);
                    GET (11, 5, IN_PARAMETERS_19.ITEM);
                    when others =>
                    RDWR_IN_PARAMETERS_19
                       (LOST_SWITCH, IN_PARAMETERS_19);
                end case;

                when others =>
                case RPGW_SWITCH is
                    when PUT =>
                    PUT_LINE ("TABLE_NAME : " &
                          IN_PARAMETERS_17.TABLE_NAME);
                    PUT_LINE ("COLUMN_NAME : " &
                          IN_PARAMETERS_17.COLUMN_NAME);
                    when GET =>
                    SCREEN_POS (13, 3);
                    GET (IN_PARAMETERS_17.TABLE_NAME);
                    SCREEN_POS (14, 4);
                    GET (IN_PARAMETERS_17.COLUMN_NAME);
                    when others =>
                    RDWR_IN_PARAMETERS_17
                       (LOST_SWITCH, IN_PARAMETERS_17);
                end case;
            end case;
            when others =>
            case RPGW_SWITCH is
                when PUT =>
                PUT_LINE ("TABLE_NAME : " &
                      IN_PARAMETERS_06.TABLE_NAME);
                when GET =>
                SCREEN_POS (13, 3);
                GET (IN_PARAMETERS_06.TABLE_NAME);
                when others =>
                RDWR_IN_PARAMETERS_06
                   (LOST_SWITCH, IN_PARAMETERS_06);
            end case;
        end case;
    end case;
    PARAMETER := IN_PARAMETERS;

    end IN_PARAMETERS;
    procedure OUT_PARAMETERS (RPGW_SWITCH : RPGW_SWITCH_TYPE) is

--************************************************************************
--**                                                                    **
--**   UNIT NAME :               OUT_PARAMETERS                         **
--**   ~~~~~~~~~~~                                                      **
--************************************************************************

    procedure RDWR_OUT_PARAMETERS_00 is new RDWR_OUT_PARAMETERS
           (OUT_PARAMETER_00);
    procedure RDWR_OUT_PARAMETERS_04 is new RDWR_OUT_PARAMETERS
           (OUT_PARAMETER_04);
    procedure RDWR_OUT_PARAMETERS_05 is new RDWR_OUT_PARAMETERS
           (OUT_PARAMETER_05);
    procedure RDWR_OUT_PARAMETERS_06 is new RDWR_OUT_PARAMETERS
           (OUT_PARAMETER_06);
    procedure RDWR_OUT_PARAMETERS_08 is new RDWR_OUT_PARAMETERS
           (OUT_PARAMETER_08);
    procedure RDWR_OUT_PARAMETERS_14 is new RDWR_OUT_PARAMETERS
           (OUT_PARAMETER_14);
    procedure RDWR_OUT_PARAMETERS_15 is new RDWR_OUT_PARAMETERS
           (OUT_PARAMETER_15);

    LOST_SWITCH : LOST_SWITCH_TYPE;

    begin
    PARAMETER := OUT_PARAMETERS;

    case RPGW_SWITCH is
        when READ =>
        NEW_PAGE;
        LOST_SWITCH := LOAD;
        when WRITE =>
        NEW_PAGE;
        LOST_SWITCH := STORE;
        when PUT =>
        NEWPAGE;
        SCREEN_POS (0, 3);
        when GET =>  null;
    end case;
    case ACCESS_NB is
        when 0 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 15 | 16 | 17 | 18 | 20 |
         21 | 22 | 23 | 25 | 26 | 28 | 30 =>
        case ACCESS_NB is
            when 4 | 6 | 7 | 11 | 16 | 17 | 25 =>
            case ACCESS_NB is
                when 4 =>
                case RPGW_SWITCH is
                    when PUT =>
                    PUT_LINE ("RTN    := " &
                          INTEGER'IMAGE
                            (OUT_PARAMETERS_04.A));
                    PUT ("TIDD   := ");
                    for Y in 1 .. 3 loop
                        PUT (INTEGER'IMAGE
                           (OUT_PARAMETERS_04.B (Y)) &
                         "         ");
                    end loop;
                    NEW_LINE;
                    PUT ("KYIDX  := ");
                    for Y in 1 .. 5 loop
                        PUT (INTEGER'IMAGE
                           (OUT_PARAMETERS_04.C (Y)) &
                         "         ");
                    end loop;
                    NEW_LINE;
                    PUT ("ATIDX  := ");
                    for Y in 1 .. 5 loop
                        PUT (INTEGER'IMAGE
                           (OUT_PARAMETERS_04.D (Y)) &
                         "         ");
                    end loop;
                    NEW_LINE;
                    when GET =>
                    SCREEN_POS (11, 3);
                    I_GET (OUT_PARAMETERS_04.A);
                    for Y in 1 .. 3 loop
                        SCREEN_POS (11 * (Y - 1) + 11, 04);
                        I_GET (OUT_PARAMETERS_04.B (Y));
                    end loop;
                    for Y in 1 .. 5 loop
                        SCREEN_POS (11 * (Y - 1) + 11, 05);
                        I_GET (OUT_PARAMETERS_04.C (Y));
                    end loop;
                    for Y in 1 .. 5 loop
                        SCREEN_POS (11 * (Y - 1) + 11, 06);
                        I_GET (OUT_PARAMETERS_04.D (Y));
                    end loop;
                    when others =>
                    RDWR_OUT_PARAMETERS_04
                       (LOST_SWITCH, OUT_PARAMETERS_04);
                end case;

                when others =>
                case RPGW_SWITCH is
                    when PUT =>
                    PUT_LINE ("RTN    := " &
                          INTEGER'IMAGE
                            (OUT_PARAMETERS_06.A));
                    PUT ("TIDD   := ");
                    for Y in 1 .. 3 loop
                        PUT (INTEGER'IMAGE
                           (OUT_PARAMETERS_06.B (Y)) &
                         "         ");
                    end loop;
                    NEW_LINE;
                    when GET =>
                    SCREEN_POS (11, 3);
                    I_GET (OUT_PARAMETERS_06.A);
                    for Y in 1 .. 3 loop
                        SCREEN_POS (11 * (Y - 1) + 11, 04);
                        I_GET (OUT_PARAMETERS_06.B (Y));
                    end loop;
                    when others =>
                    RDWR_OUT_PARAMETERS_06
                       (LOST_SWITCH, OUT_PARAMETERS_06);
                end case;
            end case;
            when 5 | 8 | 15 | 21 =>
            case ACCESS_NB is
                when 8 | 15 =>
                case ACCESS_NB is
                    when 8 =>
                    case RPGW_SWITCH is
                        when PUT =>
                        PUT_LINE ("RTN    := " &
                              INTEGER'IMAGE
                                (OUT_PARAMETERS_08
                                  .A));
                        PUT ("ATNAM  := " &
                             OUT_PARAMETERS_08.G);
                        NEW_LINE;
                        PUT_LINE ("ATTL   := " &
                              INTEGER'IMAGE
                                (OUT_PARAMETERS_08
                                  .E));
                        PUT ("ATIDX  := ");
                        for Y in 1 .. 5 loop
                            PUT (INTEGER'IMAGE
                               (OUT_PARAMETERS_08
                                 .F (Y)) &
                             "         ");
                        end loop;
                        NEW_LINE;
                        PUT ("ATLEN  := ");
                        for Y in 1 .. 5 loop
                            PUT (INTEGER'IMAGE
                               (OUT_PARAMETERS_08
                                 .H (Y)) &
                             "         ");
                        end loop;
                        NEW_LINE;
                        PUT ("ATTYP  := ");
                        for Y in 1 .. 5 loop
                            PUT (INTEGER'IMAGE
                               (OUT_PARAMETERS_08
                                 .I (Y)) &
                             "         ");
                        end loop;
                        NEW_LINE;
                        when GET =>
                        SCREEN_POS (11, 3);
                        I_GET (OUT_PARAMETERS_08.A);
                        SCREEN_POS (10, 04);
                        GET (OUT_PARAMETERS_08.G);
                        SCREEN_POS (11, 14);
                        I_GET (OUT_PARAMETERS_08.E);
                        for Y in 1 .. 5 loop
                            SCREEN_POS
                               (11 * (Y - 1) + 11, 15);
                            I_GET (OUT_PARAMETERS_08.F
                                  (Y));
                        end loop;
                        for Y in 1 .. 5 loop
                            SCREEN_POS
                               (11 * (Y - 1) + 11, 16);
                            I_GET (OUT_PARAMETERS_08.H
                                  (Y));
                        end loop;
                        for Y in 1 .. 5 loop
                            SCREEN_POS
                               (11 * (Y - 1) + 11, 17);
                            I_GET (OUT_PARAMETERS_08.I
                                  (Y));
                        end loop;
                        when others =>
                        RDWR_OUT_PARAMETERS_08
                           (LOST_SWITCH,
                            OUT_PARAMETERS_08);
                    end case;
                    when others =>
                    case RPGW_SWITCH is
                        when PUT =>
                        PUT_LINE ("RTN    := " &
                              INTEGER'IMAGE
                                (OUT_PARAMETERS_15
                                  .A));
                        PUT ("VALUE  := ");
                        for Y in 1 .. 5 loop
                            PUT (INTEGER'IMAGE
                               (OUT_PARAMETERS_15
                                 .F (Y)) &
                             "         ");
                        end loop;
                        NEW_LINE;
                        PUT_LINE ("LENR   := " &
                              INTEGER'IMAGE
                                (OUT_PARAMETERS_15
                                  .E));
                        PUT_LINE ("FTYP   := " &
                              INTEGER'IMAGE
                                (OUT_PARAMETERS_15
                                  .J));
                        when GET =>
                        SCREEN_POS (11, 3);
                        I_GET (OUT_PARAMETERS_15.A);
                        for Y in 1 .. 5 loop
                            SCREEN_POS
                               (11 * (Y - 1) + 11, 04);
                            I_GET (OUT_PARAMETERS_15.F
                                  (Y));
                        end loop;
                        SCREEN_POS (11, 05);
                        I_GET (OUT_PARAMETERS_15.E);
                        SCREEN_POS (11, 06);
                        I_GET (OUT_PARAMETERS_15.J);
                        when others =>
                        RDWR_OUT_PARAMETERS_15
                           (LOST_SWITCH,
                            OUT_PARAMETERS_15);
                    end case;
                end case;
                when others =>
                case RPGW_SWITCH is
                    when PUT =>
                    PUT_LINE ("RTN    := " &
                          INTEGER'IMAGE
                            (OUT_PARAMETERS_05.A));
                    if ACCESS_NB = 5 then
                        PUT ("INPLEN := ");
                    else
                        PUT ("DESCR  := ");
                    end if;
                    PUT (INTEGER'IMAGE
                           (OUT_PARAMETERS_05.E));
                    when GET =>
                    SCREEN_POS (11, 3);
                    I_GET (OUT_PARAMETERS_05.A);
                    SCREEN_POS (11, 4);
                    I_GET (OUT_PARAMETERS_05.E);
                    when others =>
                    RDWR_OUT_PARAMETERS_05
                       (LOST_SWITCH, OUT_PARAMETERS_05);
                end case;
            end case;
            when others =>
            case RPGW_SWITCH is
                when PUT =>
                case ACCESS_NB is
                    when 18 =>
                    PUT ("RCKEY  := ");
                    when 20 =>
                    PUT ("RETURN := ");
                    when 28 =>
                    PUT ("ATIDX  := ");
                    when others =>
                    PUT ("RTN    := ");
                end case;
                PUT (INTEGER'IMAGE (OUT_PARAMETERS_00.A));
                when GET =>
                SCREEN_POS (11, 3);
                I_GET (OUT_PARAMETERS_00.A);
                when others =>
                RDWR_OUT_PARAMETERS_00
                   (LOST_SWITCH, OUT_PARAMETERS_00);
            end case;
        end case;
        when 14 =>
        case RPGW_SWITCH is
            when PUT =>
            PUT ("ACSIFO := ");
            for Y in 1 .. 5 loop
                PUT (INTEGER'IMAGE (OUT_PARAMETERS_14.K (Y)) &
                 "         ");
            end loop;
            when GET =>
            for Y in 1 .. 5 loop
                SCREEN_POS (11 * (Y - 1) + 11, 03);
                I_GET (OUT_PARAMETERS_14.K (Y));
            end loop;
            when others =>
            RDWR_OUT_PARAMETERS_14 (LOST_SWITCH, OUT_PARAMETERS_14);
        end case;
        when 1 | 2 | 3 | 12 | 13 | 19 | 24 | 27 | 29 | 31 =>
        null;
    end case;
    PARAMETER := IN_PARAMETERS;

    end OUT_PARAMETERS;

end TOOLS;




--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--warespec.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package WAREHOUSE is


    procedure INITIALIZE;

--************************************************************************
--**                                    **
--**      UNIT NAME :                INITIALIZE                **
--**      ~~~~~~~~~~~                            **
--**                                    **
--** DESCRIPTION ------------------------------------------------------ **
--**                                    **
--**  This procedure initialize all the pointer tables.            **
--**                                                                **
--**  There is one pointer table for each interface procedure.        **
--**                                                                **
--**  The pointer table content is :                                       **
--**      - parameters addresses.                                       **
--**      - test case names.                                            **
--**                                                                **
--**  This procedure also initialize :                    **
--**       - the in_parameters file                                 **
--**       - the table descriptors file                             **
--**       - the out_parameters file                                **
--**                                                                **
--**                                    **
--************************************************************************

    procedure INFORM_ABOUT_RESULT;

--************************************************************************
--**                                    **
--**      UNIT NAME :                INFORM_ABOUT_RESULT        **
--**      ~~~~~~~~~~~                            **
--**                                    **
--** DESCRIPTION ------------------------------------------------------ **
--**                                    **
--**  This procedure display the log file.                      **
--**                                      **
--**  The log file content is :                        **
--**      - the date of the execution                    **
--**      - the interface procedure name                **
--**      - the test case name                        **
--**      - the interface procedure in_parameters            **
--**      - the table_descriptors                       **
--**      - for each access procedure :                    **
--**            - the name                                    **
--**            - the in_parameters                         **
--**            - the out_parameters                        **
--**      - the interface procedure out_parameters or the raised    **
--**        exceptions                                                 **
--**                                      **
--************************************************************************

    procedure EXECUTE_AUTOMATIC_VERSION;

--************************************************************************
--**                                    **
--**      UNIT NAME :                EXECUTE_AUTOMATIC_VERSION        **
--**      ~~~~~~~~~~~                            **
--**                                    **
--** DESCRIPTION ------------------------------------------------------ **
--**                                    **
--**  This procedure will automatically    test all the ADA/DAMES            **
--**  interface procedures with the previous recorded test cases.    **
--**                                    **
--**                                    **
--**                                    **
--************************************************************************



    procedure CREATE_TEST_CASE;

--************************************************************************
--**                                    **
--**      UNIT NAME :                CREATE_TEST_CASE            **
--**      ~~~~~~~~~~~                            **
--**                                    **
--** DESCRIPTION ------------------------------------------------------ **
--**                                    **
--**  This procedure create one test_case.                **
--**                                    **
--**  A test_case is a set of three kinds of parameter :        **
--**     - the ADA/DAMES interface procedure in_parameters        **
--**     - the table_descriptors                    **
--**     - the access procedure out_parameters.                **
--**                                    **
--**  Each test_case is designed to check one property of the         **
--**  interface procedure.                        **
--**                                    **
--**                                    **
--************************************************************************

    procedure EXECUTE_TEST_CASE;

--************************************************************************
--**                                    **
--**      UNIT NAME :                EXECUTE_TEST_CASE            **
--**      ~~~~~~~~~~~                            **
--**                                    **
--** DESCRIPTION ------------------------------------------------------ **
--**                                    **
--**  This procedure will execute one or more previous recorded         **
--**  test cases of the chosen interface procedure.             **
--**                                    **
--**                                    **
--************************************************************************



    procedure MODIFY_TEST_CASE;

--************************************************************************
--**                                    **
--**      UNIT NAME :                MODIFY_TEST_CASE            **
--**      ~~~~~~~~~~~                            **
--**                                    **
--** DESCRIPTION ------------------------------------------------------ **
--**                                    **
--**  This procedure will modify :                                        **
--**       or the interface procedure in_parameters               **
--**       or the table_descriptors                       **
--**       or the access procedure out_parameters.            **
--**                                    **
--**                                    **
--************************************************************************
    procedure DELETE_TEST_CASE;

--************************************************************************
--**                                    **
--**      UNIT NAME :                DELETE_TEST_CASE            **
--**      ~~~~~~~~~~~                            **
--**                                    **
--** DESCRIPTION ------------------------------------------------------ **
--**                                    **
--**  This procedure will delete one or more previous recorded          **
--**  test cases of the chosen interface procedure.                **
--**                                                                    **
--**                                                                    **
--************************************************************************


end WAREHOUSE;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--warehouse.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with TEXT_IO;
use TEXT_IO;
with DIRECT_IO;
with BOTH_VARIABLES;
use BOTH_VARIABLES;
with TOOLS;
use TOOLS;
with DISPLAY;
use DISPLAY;
with INSTANTIATED;
use INSTANTIATED;

package body WAREHOUSE is


--***************************************************************************--
--                             internal variables                            --
--***************************************************************************--

    LAST_TABLE_DESCRIPTORS : BOOLEAN;
    GOT                    : STRING (1 .. 20) := (others => ' ');
--***************************************************************************--
--                             internal procedure                           --
--***************************************************************************--

-------------------------------------------------------------------------------
--                      CHOOSE_TEST_CASE_NAME                                --
-------------------------------------------------------------------------------
    procedure CHOOSE_TEST_CASE_NAME (LAST_TABLE_DESCRIPTORS : out BOOLEAN) is

    TEST_CASE_NAME : STRING (1 .. 5) := (others => ' ');

    begin
    NEW_PAGE;
    PUT (TEST_BED_FUNCTION'IMAGE (T_B_FUNCTION) &
         " interface procedure " &
         INTERFACE_PROCEDURE_NAME'IMAGE (INTERFACE_PR_NAME) & " ");

    case T_B_FUNCTION is
        when CREATE =>
        case PARAMETER is
            when IN_PARAMETERS =>
            PUT (PARAMETER_TYPE'IMAGE (PARAMETER));
            when TABLE_DESCRIPTORS =>
            PUT (PARAMETER_TYPE'IMAGE (PARAMETER));
            DISPL (0, 6, "last_table_descriptors");
            when OUT_PARAMETERS =>
            NEW_LINE;
            PUT ("access procedure " &
                 PARAMETER_TYPE'IMAGE (PARAMETER));
        end case;
        when others =>  null;
    end case;

    SCREEN_POS (0, 7);

    for I in PT_TABLE.TEST_CASE'RANGE loop
        if PT_TABLE.TEST_CASE (I).IS_OPEN then
        PUT (PT_TABLE.TEST_CASE (I).NAME);
        PUT ("     ");
        end if;
    end loop;

    case T_B_FUNCTION is
        when CREATE =>
        DISPL (0, 21,
               "choose the test case name which you want to look like.");
        when DELETE =>
        DISPL (0, 21,
               "choose the test case name which you want to delete.");
        when EXECUTE =>
        DISPL (0, 21,
               "choose the test case name which you want to execute.");
        when MODIFY =>
        DISPL (0, 21,
               "choose the test case name which you want to modify.");
    end case;
    DISPL (0, 22, " test case name : ");
    TEST_CASE_NAME_QUEST:
    loop
        loop
        SCREEN_POS (18, 22);
        GET_LINE (GOT, LAST);
        exit when LAST in 1 .. 5;
        end loop;

        TEST_CASE_NAME := GOT (1 .. LAST) &
                  (LAST + 1 .. TEST_CASE_NAME'LENGTH => ' ');
        if TEST_CASE_NAME = "last_" then
        LAST_TABLE_DESCRIPTORS := TRUE;
        exit;
        else
        LAST_TABLE_DESCRIPTORS := FALSE;
        for I in PT_TABLE.TEST_CASE'RANGE loop
            if PT_TABLE.TEST_CASE (I).IS_OPEN and then
               PT_TABLE.TEST_CASE (I).NAME = TEST_CASE_NAME then
            TEST_CASE_NB := I;
            exit TEST_CASE_NAME_QUEST;
            end if;
        end loop;
        end if;
    end loop TEST_CASE_NAME_QUEST;
    NEW_PAGE;
    end CHOOSE_TEST_CASE_NAME;


    procedure INITIALIZE is

--************************************************************************
--**                                                                    **
--**      UNIT NAME :                INITIALIZE                         **
--**      ~~~~~~~~~~~                                                   **
--************************************************************************

    package D_IO_1 is new DIRECT_IO (POINTER_TABLE);
    package D_IO_2 is new DIRECT_IO (IN_PARAMETER_00);
    package D_IO_3 is new DIRECT_IO (TABLE_DESCRIPTORX);
    package D_IO_4 is new DIRECT_IO (OUT_PARAMETER_00);

    FILE_1   : D_IO_1.FILE_TYPE;
    FILE_2   : D_IO_2.FILE_TYPE;
    FILE_3   : D_IO_3.FILE_TYPE;
    FILE_4   : D_IO_4.FILE_TYPE;
    PT_TABLE : POINTER_TABLE;

    begin

    PT_TABLE.IS_EMPTY := TRUE;
    PT_TABLE.IS_FULL := FALSE;

    for I in PT_TABLE.TEST_CASE'RANGE loop
        PT_TABLE.TEST_CASE (I).IS_OPEN := FALSE;
    end loop;

    D_IO_1.CREATE (FILE => FILE_1, NAME => "t_bed_pointer_table");

    for I in INTERFACE_NUMBER loop
        D_IO_1.WRITE (FILE_1, PT_TABLE, D_IO_1.POSITIVE_COUNT (I + 1));
    end loop;

    D_IO_1.CLOSE (FILE_1);

    for I in INTERFACE_NUMBER loop
        D_IO_2.CREATE (FILE => FILE_2,
               NAME => "t_bed_in_p_" &
                   INTERFACE_PROCEDURE_NAME'IMAGE
                     (INTERFACE_PROCEDURE_NAME'VAL (I)));
        D_IO_2.CLOSE (FILE_2);
    end loop;

    D_IO_3.CREATE (FILE => FILE_3, NAME => "t_bed_table_descriptors");
    D_IO_3.CLOSE (FILE_3);

    for I in ACCESS_NUMBER loop
        D_IO_4.CREATE (FILE => FILE_4,
               NAME => "t_bed_out_p_" &
                   ACCESS_PROCEDURE_NAME'IMAGE
                     (ACCESS_PROCEDURE_NAME'VAL (I)));
        D_IO_4.CLOSE (FILE_4);
    end loop;

    end INITIALIZE;

    procedure INFORM_ABOUT_RESULT is

--************************************************************************
--**                                                                    **
--**      UNIT NAME :                INFORM_ABOUT_RESULT                **
--**      ~~~~~~~~~~~                                                   **
--************************************************************************

    LINE               : STRING (1 .. 200);
    LINE_RANGE         : NATURAL := 0;
    LINE_POSITION      : NATURAL := 0;
    LAST_LINE_POSITION : NATURAL := 0;
    begin
    CLOSE (LOG_FILE);
    OPEN (LOG_FILE, IN_FILE, "log_file");
    loop
        loop
        begin
            PUT ("line position :" & NATURAL'IMAGE (LINE_POSITION));
            PUT ("   next line position ? ");
            GET_LINE (LINE, LAST);
            LINE_POSITION := NATURAL'VALUE (LINE (1 .. LAST));
            exit;
        exception
            when CONSTRAINT_ERROR =>  null;
            when others =>  null;
        end;
        end loop;
        if LINE_POSITION < LAST_LINE_POSITION the|
        CLOSE (LOG_FILE);
        OPEN (LOG_FILE, IN_FILE, "log_file");
        LAST_LINE_POSITION := 0;
        end if;
        LINE_RANGE := LINE_POSITION - LAST_LINE_POSITION;
        LAST_LINE_POSITION := LINE_POSITION;
        for I in 0 .. LINE_RANGE loop
        GET_LINE (LOG_FILE, LINE, LAST);
        PUT_LINE (LINE (1 .. LAST));
        end loop;
    end loop;
    exception
    when END_ERROR =>
        CLOSE (LOG_FILE);
        CREATE (LOG_FILE, OUT_FILE, "log_file");
    end INFORM_ABOUT_RESULT;

    procedure EXECUTE_AUTOMATIC_VERSION is

--************************************************************************
--**                                                                    **
--**      UNIT NAME :                EXECUTE_AUTOMATIC_VERSION          **
--**      ~~~~~~~~~~~                                                   **
--**                                                                    **
--************************************************************************

    begin
    for U in INTERFACE_NUMBER loop
        INTERFACE_NB := U;
        RDWR_POINTER_TABLE (LOAD);
        INTERFACE_PR_NAME := INTERFACE_PROCEDURE_NAME'VAL (INTERFACE_NB);

        if not PT_TABLE.IS_EMPTY then
        for I in PT_TABLE.TEST_CASE'RANGE loop
            if PT_TABLE.TEST_CASE (I).IS_OPEN then
            TEST_CASE_NB := I;
            AUTOMATIC_VERSION := TRUE;
            EXECUTE_ONE_TEST_CASE;
            AUTOMATIC_VERSION := FALSE;
            end if;
        end loop;
        end if;
    end loop;
    end EXECUTE_AUTOMATIC_VERSION;


    procedure CREATE_TEST_CASE is

--************************************************************************
--**                                                                    **
--**      UNIT NAME :                CREATE_TEST_CASE                   **
--**      ~~~~~~~~~~~                                                   **
--**                                                                    **
--************************************************************************

    U   : INTEGER := 1;
    TCN : INTEGER := 1;

    begin
    T_B_FUNCTION := CREATE;

    if PT_TABLE.IS_FULL then
        NEW_PAGE;
        DISPL (20, 04, "you could only create 80 test cases !");
        DISPL (20, 05, "you would like 81 test cases !");
        DISPL (20, 06, "you are very hungry !");
        DISPL (20, 07, "delete a test case or be hungry !");
        STOP;
    else
        if PT_TABLE.IS_EMPTY then

        PT_TABLE.IS_EMPTY := FALSE;
        PT_TABLE.TEST_CASE (1).IS_OPEN := TRUE;
        TEST_CASE_NB := 1;

        if IN_PARAMETER_IS_OPEN (INTERFACE_NB) then
            IN_PARAMETERS (PUT);
            IN_PARAMETERS (GET);
        end if;

        INITIALIZE_STATUS;
        UPDATE_STATUS;

        for I in ACC_LIST_NUMBER loop
            if ACC_LIST (INTERFACE_NB, I) /= 99 then
            ACCESS_NB := ACC_LIST (INTERFACE_NB, I);
            ACCESS_PR_NAME := ACCESS_PROCEDURE_NAME'VAL (ACCESS_NB);
            OUT_PARAMETERS (PUT);
            OUT_PARAMETERS (GET);
            ACC_LI_NB := I;
            OUT_PARAMETERS (WRITE);
            else
            exit;
            end if;
        end loop;
        else
-- looking for a test case number
        while U in PT_TABLE.TEST_CASE'RANGE and then
              PT_TABLE.TEST_CASE (U).IS_OPEN loop
            U := U + 1;
        end loop;
        if IN_PARAMETER_IS_OPEN (INTERFACE_NB) then
            PARAMETER := IN_PARAMETERS;
            CHOOSE_TEST_CASE_NAME (LAST_TABLE_DESCRIPTORS);
            IN_PARAMETERS (READ);
            IN_PARAMETERS (PUT);

            if MODIFY then
            IN_PARAMETERS (GET);
            end if;
        end if;

        PARAMETER := TABLE_DESCRIPTORS;
        CHOOSE_TEST_CASE_NAME (LAST_TABLE_DESCRIPTORS);

        if not LAST_TABLE_DESCRIPTORS then
            RDWR_TABLE_DESCRIPTORS (LOAD);
        end if;

        UPDATE_STATUS;

        if ACC_LIST (INTERFACE_NB, ACC_LIST_NUMBER'FIRST) /= 99 then
            PARAMETER := OUT_PARAMETERS;
            CHOOSE_TEST_CASE_NAME (LAST_TABLE_DESCRIPTORS);
            TCN := TEST_CASE_NB;

            for I in ACC_LIST_NUMBER loop
            if ACC_LIST (INTERFACE_NB, I) /= 99 then
                ACCESS_NB := ACC_LIST (INTERFACE_NB, I);
                ACCESS_PR_NAME :=
                  ACCESS_PROCEDURE_NAME'VAL (ACCESS_NB);
                ACC_LI_NB := I;
                TEST_CASE_NB := TCN;
                OUT_PARAMETERS (READ);
                OUT_PARAMETERS (PUT);

                if MODIFY then
                OUT_PARAMETERS (GET);
                end if;

                TEST_CASE_NB := U;
                OUT_PARAMETERS (WRITE);
            else
                exit;
            end if;
            end loop;
        end if;

        PT_TABLE.TEST_CASE (U).IS_OPEN := TRUE;
        TEST_CASE_NB := U;

        if U = PT_TABLE.TEST_CASE'LAST then
            PT_TABLE.IS_FULL := TRUE;
        end if;
        end if;
        SCREEN_POS (0, 22);
        PUT ("what name for the new test case ? Test case name : .....");
        NEW_LINE;
        PUT ((1 .. 79 => ' '));

        loop
        SCREEN_POS (51, 22);
        GET_LINE (GOT, LAST);
        exit when LAST in 1 .. 5;
        end loop;

        PT_TABLE.TEST_CASE (TEST_CASE_NB).NAME :=
          GOT (1 .. LAST) &
          (LAST + 1 .. PT_TABLE.TEST_CASE (TEST_CASE_NB).NAME'LENGTH =>
         ' ');

        IN_PARAMETERS (WRITE);
        RDWR_TABLE_DESCRIPTORS (STORE);
        RDWR_POINTER_TABLE (STORE);
    end if;

    end CREATE_TEST_CASE;
    procedure EXECUTE_TEST_CASE is

--************************************************************************
--**                                                                    **
--**      UNIT NAME :                EXECUTE_TEST_CASE                  **
--**      ~~~~~~~~~~~                                                   **
--**                                                                    **
--************************************************************************

    begin
    T_B_FUNCTION := EXECUTE;
    if PT_TABLE.IS_EMPTY then
        NEW_LINE (4);
        PUT ("no created test case !");
        STOP;
        NEW_PAGE;
    else
        MENU_1_LOOP:
        loop
        NEW_PAGE;
        PUT (TEST_BED_FUNCTION'IMAGE (T_B_FUNCTION) &
             " interface procedure " &
             INTERFACE_PROCEDURE_NAME'IMAGE (INTERFACE_PR_NAME));

        DISPL (00, 07, "       - Menu_3                              ");
        DISPL (00, 08, "       - All the test cases will be executed ");
        DISPL (00, 09, "       - One test case will be executed      ");
        loop
            ROW := 7;
            COLUMN := 7;
            CHOICE (R_O_W, 9, ROW, COLUMN);
            if ROW <= 9 then  exit;  end if;
        end loop;

        NEW_PAGE;
        case ROW is
            when 7 =>  exit;
            when 8 =>
            for I in PT_TABLE.TEST_CASE'RANGE loop
                if PT_TABLE.TEST_CASE (I).IS_OPEN then
                TEST_CASE_NB := I;
                AUTOMATIC_VERSION := TRUE;
                EXECUTE_ONE_TEST_CASE;
                AUTOMATIC_VERSION := FALSE;
                end if;
            end loop;
            when 9 =>
            CHOOSE_TEST_CASE_NAME (LAST_TABLE_DESCRIPTORS);
            AUTOMATIC_VERSION := FALSE;
            EXECUTE_ONE_TEST_CASE;
            when others =>  null;
        end case;
        end loop MENU_1_LOOP;
    end if;
    end EXECUTE_TEST_CASE;

    procedure DELETE_TEST_CASE is
--************************************************************************
--**                                                                    **
--**      UNIT NAME :                DELETE_TEST_CASE                   **
--**      ~~~~~~~~~~~                                                   **
--************************************************************************
    begin
    T_B_FUNCTION := DELETE;

    if PT_TABLE.IS_EMPTY then
        NEW_LINE (4);
        PUT ("no created test case !");
        STOP;
        NEW_PAGE;
    else
        MENU_1_LOOP:
        loop
        NEW_PAGE;
        PUT (TEST_BED_FUNCTION'IMAGE (T_B_FUNCTION) &
             " interface procedure " &
             INTERFACE_PROCEDURE_NAME'IMAGE (INTERFACE_PR_NAME));

        DISPL (00, 07, "       - Menu_3                            ");
        DISPL (00, 08, "       - All the test cases will be deleted");
        DISPL (00, 09, "       - One test case will be deleted     ");
        loop
            ROW := 7;
            COLUMN := 7;
            CHOICE (R_O_W, 9, ROW, COLUMN);
            if ROW <= 9 then  exit;  end if;
        end loop;

        NEW_PAGE;
        case ROW is
            when 7 =>  exit;
            when 8 =>
            PT_TABLE.IS_EMPTY := TRUE;
            PT_TABLE.IS_FULL := FALSE;

            for I in PT_TABLE.TEST_CASE'RANGE loop
                PT_TABLE.TEST_CASE (I).IS_OPEN := FALSE;
            end loop;
            when 9 =>
            CHOOSE_TEST_CASE_NAME (LAST_TABLE_DESCRIPTORS);
            PT_TABLE.TEST_CASE (TEST_CASE_NB).IS_OPEN := FALSE;
            if PT_TABLE.IS_FULL then
                PT_TABLE.IS_FULL := FALSE;
            else
                for I in PT_TABLE.TEST_CASE'RANGE loop
                exit when PT_TABLE.TEST_CASE (I).IS_OPEN;
                if I = PT_TABLE.TEST_CASE'LAST then
                    PT_TABLE.IS_EMPTY := TRUE;
                end if;
                end loop;
            end if;
            when others =>  null;
        end case;
        end loop MENU_1_LOOP;
        RDWR_POINTER_TABLE (STORE);
    end if;
    end DELETE_TEST_CASE;


    procedure MODIFY_TEST_CASE is

--************************************************************************
--**                                                                    **
--**      UNIT NAME :                MODIFY_TEST_CASE                   **
--**      ~~~~~~~~~~~                                                   **
--**                                                                    **
--************************************************************************

    begin
    T_B_FUNCTION := MODIFY;

    if PT_TABLE.IS_EMPTY then
        NEW_LINE (4);
        PUT ("no created test case !");
        STOP;
    else
        CHOOSE_TEST_CASE_NAME (LAST_TABLE_DESCRIPTORS);

        if IN_PARAMETER_IS_OPEN (INTERFACE_NB) then
        IN_PARAMETERS (READ);
        IN_PARAMETERS (PUT);
        if MODIFY then
            IN_PARAMETERS (GET);
            IN_PARAMETERS (WRITE);
        end if;
        end if;

        RDWR_TABLE_DESCRIPTORS (LOAD);
        UPDATE_STATUS;
        RDWR_TABLE_DESCRIPTORS (STORE);

        for I in ACC_LIST_NUMBER loop
        if ACC_LIST (INTERFACE_NB, I) /= 99 then
            ACCESS_NB := ACC_LIST (INTERFACE_NB, I);
            ACCESS_PR_NAME := ACCESS_PROCEDURE_NAME'VAL (ACCESS_NB);
            ACC_LI_NB := I;
            OUT_PARAMETERS (READ);
            OUT_PARAMETERS (PUT);

            if MODIFY then
            OUT_PARAMETERS (GET);
            OUT_PARAMETERS (WRITE);
            end if;
        else
            exit;
        end if;
        end loop;
    end if;
    NEW_PAGE;

    end MODIFY_TEST_CASE;

end WAREHOUSE;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--f77call.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with F77_ACCESS;
with ADA_FORTRAN;
with CONVERSION;

package body F77_CALLABLES is

    L : constant := 10;
        -- all db, table, and column names are supposed to be exactly  L
        -- characters  long,  and  some  of  them  must  be  translated
        -- into a three integers array to be send to the Fortran, while they
        -- are declared this way in the underlying subroutines.

    procedure ADA_ADDATR (RCKEY  : INTEGER;
                          ATNAM  : STRING;
                          ATYPE  : INTEGER;
                          ATLEN  : INTEGER;
                          DOMNAM : STRING;
                          RTN    : out INTEGER) is
        INTER1 : F77_ACCESS.INTER_TYPE (N => 3);
        INTER2 : F77_ACCESS.INTER_TYPE (N => 3);
    begin
        INTER1.INTEGER_ARRAY := CONVERSION.F77_STRING (ATNAM (1 .. 10) & "  ");
        INTER2.INTEGER_ARRAY := CONVERSION.F77_STRING (DOMNAM (1 .. 10)& "  ");

        F77_ACCESS.AADDATR (RCKEY, INTER1, ATYPE, ATLEN, INTER2, RTN);
    end ADA_ADDATR;


    procedure ADA_CLOSDB is
    begin
        F77_ACCESS.ACLOSDB;
    end ADA_CLOSDB;


    procedure ADA_CLOSER (DESCR : INTEGER) is
    begin
        F77_ACCESS.ACLOSER (DESCR);
    end ADA_CLOSER;


    procedure ADA_CLRELS is
    begin
        F77_ACCESS.ACLRELS;
    end ADA_CLRELS;


--  procedure ADA_CREATT (DESCR : INTEGER; RTN : out INTEGER) is
--  begin
--      F77_ACCESS.ACREATT (DESCR, RTN);
--  end ADA_CREATT;
    procedure ADA_DADD (DESCR  : INTEGER;
                        KYNAM  : STRING;
                        KYIDX  : in out INTEGER_ARRAY_TYPE;
                        KYVAL0 : STRING;
                        KYTL   : INTEGER;
                        KYTLEN : INTEGER_ARRAY_TYPE;
                        KYTYP  : INTEGER_ARRAY_TYPE;
                        ATNAM  : STRING;
                        ATIDX  : in out INTEGER_ARRAY_TYPE;
                        ATTL   : INTEGER;
                        ATLEN  : INTEGER_ARRAY_TYPE;
                        ATTYP  : INTEGER_ARRAY_TYPE;
                        TIDD   : in out TIDD_TYPE;
                        RTN    : out INTEGER) is

        INTER1 : F77_ACCESS.INTER_TYPE (N => KYNAM'LENGTH);
        INTER2 : F77_ACCESS.INTER_TYPE (N => KYIDX'LENGTH);
        INTER3 : F77_ACCESS.INTER_TYPE (N => KYVAL0'LENGTH);
        INTER4 : F77_ACCESS.INTER_TYPE (N => KYTLEN'LENGTH);
        INTER5 : F77_ACCESS.INTER_TYPE (N => KYTYP'LENGTH);
        INTER6 : F77_ACCESS.INTER_TYPE (N => ATNAM'LENGTH);
        INTER7 : F77_ACCESS.INTER_TYPE (N => ATIDX'LENGTH);
        INTER8 : F77_ACCESS.INTER_TYPE (N => ATLEN'LENGTH);
        INTER9 : F77_ACCESS.INTER_TYPE (N => ATTYP'LENGTH);
        INTER0 : F77_ACCESS.INTER_TYPE (N => 3);
    begin
        INTER2.INTEGER_ARRAY := KYIDX;
        INTER4.INTEGER_ARRAY := KYTLEN;
        INTER5.INTEGER_ARRAY := KYTYP;
        INTER7.INTEGER_ARRAY := ATIDX;
        INTER8.INTEGER_ARRAY := ATLEN;
        INTER9.INTEGER_ARRAY := ATTYP;
        INTER0.INTEGER_ARRAY := TIDD;

        for I in 1 .. INTER1.N loop
            INTER1.INTEGER_ARRAY (I) := CHARACTER'POS (KYNAM (I));
        end loop;

        for I in 1 .. INTER3.N loop
            INTER3.INTEGER_ARRAY (I) := CHARACTER'POS (KYVAL0 (I));
        end loop;

        for I in 1 .. INTER6.N loop
            INTER6.INTEGER_ARRAY (I) := CHARACTER'POS (ATNAM (I));
        end loop;

        F77_ACCESS.ADADD
           (DESCR, INTER1, INTER2, INTER3, KYTL, INTER4, INTER5, INTER6,
            INTER7, ATTL, INTER8, INTER9, INTER0, RTN);
        KYIDX := INTER2.INTEGER_ARRAY;
        ATIDX := INTER7.INTEGER_ARRAY;
        TIDD := INTER0.INTEGER_ARRAY;
    end ADA_DADD;

    procedure ADA_DAMSG  (INPLIN : STRING;
                          INPLEN : in out INTEGER;
                          MAXLEN : INTEGER;
                          RTN    : out INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => (3 + INPLIN'LENGTH)/4);
    begin
        INTER.INTEGER_ARRAY := CONVERSION.F77_STRING (INPLIN);
        F77_ACCESS.ADAMSG (INTER, INPLEN, MAXLEN, RTN);
    end ADA_DAMSG;
    procedure ADA_DELETT (DESCR : INTEGER;
                          TIDD  : in out TIDD_TYPE;
                          RTN   : out INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => 3);
    begin
        INTER.INTEGER_ARRAY := TIDD;
        F77_ACCESS.ADELETT (DESCR, INTER, RTN);
        TIDD := INTER.INTEGER_ARRAY;
    end ADA_DELETT;

    procedure ADA_DFIND (DESCR  : INTEGER;
                         KYM0   : INTEGER;
                         KYIDX  : INTEGER_ARRAY_TYPE;
                         KYVAL0 : STRING;
                         KYTL   : INTEGER;
                         TIDD   : in out TIDD_TYPE;
                         IRD    : INTEGER;
                         RTN    : out INTEGER) is
        INTER1 : F77_ACCESS.INTER_TYPE (N => KYIDX'LENGTH);
        INTER2 : F77_ACCESS.INTER_TYPE (N => KYVAL0'LENGTH);
        INTER3 : F77_ACCESS.INTER_TYPE (N => 3);
    begin
        INTER1.INTEGER_ARRAY := KYIDX;
        INTER3.INTEGER_ARRAY := TIDD;

        for I in 1 .. INTER2.N loop
            INTER2.INTEGER_ARRAY (I) := CHARACTER'POS (KYVAL0 (I));
        end loop;

        F77_ACCESS.ADFIND (DESCR, KYM0, INTER1, INTER2, KYTL, INTER3, IRD, RTN);
        TIDD := INTER3.INTEGER_ARRAY;
    end ADA_DFIND;

    procedure ADA_DGINFO (DESCR               : INTEGER;
                          ATNAM               : in out STRING;
                          ATTL                : in out INTEGER;
                          ATIDX, ATLEN, ATTYP : out INTEGER_ARRAY_TYPE;
                          RTN                : out INTEGER) is
        INTER1 : F77_ACCESS.INTER_TYPE (N => ATNAM'LAST);
        INTER2 : F77_ACCESS.INTER_TYPE (N => ATIDX'LAST);
        INTER3 : F77_ACCESS.INTER_TYPE (N => ATLEN'LAST);
        INTER4 : F77_ACCESS.INTER_TYPE (N => ATTYP'LAST);
    begin
        for I in 1 .. INTER1.N loop
            INTER1.INTEGER_ARRAY (I) := CHARACTER'POS (ATNAM (I));
        end loop;

        F77_ACCESS.ADGINFO (DESCR, INTER1, ATTL, INTER2, INTER3, INTER4, RTN);

        for I in 1 .. INTER1.N loop
            ATNAM (I) := CHARACTER'VAL (INTER1.INTEGER_ARRAY (I));
        end loop;

        ATIDX := INTER2.INTEGER_ARRAY;
        ATLEN := INTER3.INTEGER_ARRAY;
        ATTYP := INTER4.INTEGER_ARRAY;
    end ADA_DGINFO;
    procedure ADA_DLOCK (RELIST : STRING;
                         MODLIS : INTEGER_ARRAY_TYPE;
                         LENL   : INTEGER;
                         RTN    : out INTEGER) is
        INTER1 : F77_ACCESS.INTER_TYPE (N => RELIST'LENGTH);
        INTER2 : F77_ACCESS.INTER_TYPE (N => MODLIS'LENGTH);
    begin
        for I in 1 .. INTER1.N loop
            INTER1.INTEGER_ARRAY (I) := CHARACTER'POS (RELIST (I));
        end loop;
        INTER2.INTEGER_ARRAY := MODLIS;

        F77_ACCESS.ADLOCK (INTER1, INTER2, LENL, RTN);
    end ADA_DLOCK;

    procedure ADA_DOPENDB (DBNAME : STRING; RTN : out INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => DBNAME'LENGTH);
    begin
        for I in 1 .. INTER.N loop
            INTER.INTEGER_ARRAY (I) := CHARACTER'POS (DBNAME (I));
        end loop;

        F77_ACCESS.ADOPENDB (INTER, RTN);
    end ADA_DOPENDB;

    procedure ADA_DPREV (DESCR : INTEGER;
                         TIDD  : in out TIDD_TYPE;
                         RTN   : out INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => 3);
    begin
        INTER.INTEGER_ARRAY := TIDD;
        F77_ACCESS.ADPREV (DESCR, INTER, RTN);
        TIDD := INTER.INTEGER_ARRAY;
    end ADA_DPREV;

    procedure ADA_DUNLK is
    begin
        F77_ACCESS.ADUNLK;
    end ADA_DUNLK;

    procedure ADA_ENDDM is
    begin
        F77_ACCESS.AENDDM;
    end ADA_ENDDM;

    procedure ADA_FACSS (DESCR : INTEGER; ACSIFO : out INTEGER_ARRAY_TYPE) is
        INTER : F77_ACCESS.INTER_TYPE (N => ACSIFO'LENGTH);
    begin
        F77_ACCESS.AFACSS (DESCR, INTER);
        ACSIFO := INTER.INTEGER_ARRAY;
    end ADA_FACSS;
    procedure ADA_GETA (DESCR  : INTEGER;
                        ATTINX : INTEGER;
                        VALUE  : out INTEGER_ARRAY_TYPE;
                        LENR   : out INTEGER;
                        FTYP   : out INTEGER;
                        RTN    : out INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => VALUE'LAST);
    begin
        F77_ACCESS.AGETA (DESCR, ATTINX, INTER, LENR, FTYP, RTN);

        VALUE := INTER.INTEGER_ARRAY;
    end ADA_GETA;

    procedure ADA_GETT (DESCR : INTEGER;
                        TIDD  : in out TIDD_TYPE;
                        RTN   : out INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => 3);
    begin
        INTER.INTEGER_ARRAY := TIDD;
        F77_ACCESS.AGETT (DESCR, INTER, RTN);
        TIDD := INTER.INTEGER_ARRAY;
    end ADA_GETT;

    procedure ADA_GETTB (DESCR  : INTEGER;
                         SINK   : out INTEGER_ARRAY_TYPE;
                         SINKLN : INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => SINK'LAST);
    begin
        F77_ACCESS.AGETTB (DESCR, INTER, SINKLN);

        SINK := INTER.INTEGER_ARRAY;
    end ADA_GETTB;


    procedure ADA_INSRTT (DESCR : INTEGER;
                          TIDD  : in out TIDD_TYPE;
                          RTN   : out INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => 3);
    begin
        INTER.INTEGER_ARRAY := TIDD;
        F77_ACCESS.AINSRTT (DESCR, INTER, RTN);
        TIDD := INTER.INTEGER_ARRAY;
    end ADA_INSRTT;

--  procedure ADA_INSRT2 (DESCR : INTEGER;
--                        TIDD  : in out TIDD_TYPE;
--                        RTN   : out INTEGER) is
--      INTER : F77_ACCESS.INTER_TYPE (N => 3);
--  begin
--      INTER.INTEGER_ARRAY := TIDD;
--      F77_ACCESS.AINSRT2 (DESCR, INTER, RTN);
--      TIDD := INTER.INTEGER_ARRAY;
--  end ADA_INSRT2;


    procedure ADA_IRELC (RELNAM : STRING;
                         RCKEY  : out INTEGER;
                         PERM   : INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => 3);
    begin
        INTER.INTEGER_ARRAY := CONVERSION.F77_STRING(RELNAM (1 .. 10)&"  ");
        F77_ACCESS.AIRELC (INTER, RCKEY, PERM);
    end ADA_IRELC;
    procedure ADA_LEXINT is
    begin
        F77_ACCESS.ALEXINT;
    end ADA_LEXINT;

    procedure ADA_MSGTTY (MSG    : STRING;
                          MSGLEN : INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => (MSG'LENGTH + 3) / 4);
    begin
        INTER.INTEGER_ARRAY := CONVERSION.F77_STRING(MSG);
        F77_ACCESS.AMSGTTY (INTER, MSGLEN);
    end ADA_MSGTTY;

    function ADA_NUMTUP (DESCR : INTEGER) return INTEGER is
        RESULT : INTEGER;
    begin
        F77_ACCESS.ANUMTUP (DESCR, RESULT);
        return RESULT;
    end ADA_NUMTUP;

    procedure ADA_OPENR (RELNAM : STRING;
                         DESCR  : out INTEGER;
                         RTN    : out INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => 3);
    begin
        INTER.INTEGER_ARRAY := CONVERSION.F77_STRING(RELNAM (1 .. 10)&"  ");
        F77_ACCESS.AOPENR (INTER, DESCR, RTN);
    end ADA_OPENR;

    procedure ADA_PARSLP  (RTN : out INTEGER) is
    begin
        F77_ACCESS.APARSLP (RTN);
    end ADA_PARSLP;

    procedure ADA_PUTA (DESCR  : INTEGER;
                        ATTINX : INTEGER;
                        VALUE  : INTEGER_ARRAY_TYPE;
                        LENGTH : INTEGER;
                        RTN    : out INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => VALUE'LAST);
    begin
        INTER.INTEGER_ARRAY := VALUE;

        F77_ACCESS.APUTA (DESCR, ATTINX, INTER, LENGTH, RTN);
    end ADA_PUTA;


    procedure ADA_PUTTB (DESCR  : INTEGER;
                         SOURCE : INTEGER_ARRAY_TYPE;
                         TUPLEN : INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => SOURCE'LAST);
    begin
        INTER.INTEGER_ARRAY := SOURCE;

        F77_ACCESS.APUTTB (DESCR, INTER, TUPLEN);
    end ADA_PUTTB;
    procedure ADA_RELLK (OPDB : STRING) is
        INTER : F77_ACCESS.INTER_TYPE (N => 3);
    begin
        INTER.INTEGER_ARRAY := CONVERSION.F77_STRING(OPDB (1 .. 10)&"  ");
        F77_ACCESS.ARELLK (INTER);
    end ADA_RELLK;

    procedure ADA_REPLAT (DESCR : INTEGER;
                          TIDD  : in out TIDD_TYPE;
                          RTN   : out INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => 3);
    begin
        INTER.INTEGER_ARRAY := TIDD;
        F77_ACCESS.AREPLAT (DESCR, INTER, RTN);
        TIDD := INTER.INTEGER_ARRAY;
    end ADA_REPLAT;

    procedure ADA_SETGET (DESCR      : INTEGER;
                          SETYPE     : INTEGER;
                          ARG3, ARG4 : TIDD_TYPE;
                          RTN        : out INTEGER) is
        INTER1 : F77_ACCESS.INTER_TYPE (N => 3);
        INTER2 : F77_ACCESS.INTER_TYPE (N => 3);
    begin
        INTER1.INTEGER_ARRAY := ARG3;
        INTER2.INTEGER_ARRAY := ARG4;
        F77_ACCESS.ASETGET (DESCR, SETYPE, INTER1, INTER2, RTN);
    end ADA_SETGET;

    procedure ADA_SETLK (OPDB : STRING) is
        INTER : F77_ACCESS.INTER_TYPE (N => 3);
    begin
        INTER.INTEGER_ARRAY := CONVERSION.F77_STRING(OPDB (1 .. 10)&"  ");
        F77_ACCESS.ASETLK (INTER);
    end ADA_SETLK;

    procedure ADA_SRCHA (DESCR : INTEGER;
                         ATNAM : STRING;
                         ATIDX : out INTEGER) is
        INTER : F77_ACCESS.INTER_TYPE (N => 3);
    begin
        INTER.INTEGER_ARRAY := CONVERSION.F77_STRING(ATNAM (1 .. 10)&"  ");
        F77_ACCESS.ASRCHA (DESCR, INTER, ATIDX);
    end ADA_SRCHA;

    procedure ADA_STARTDM is
    begin
        F77_ACCESS.ASTARTDM;
    end ADA_STARTDM;

    procedure ADA_TRELC (RCKEY : INTEGER;
                         HOW   : INTEGER;
                         NOPGS : INTEGER;
                         PGSZ  : INTEGER;
                         RTN   : out INTEGER) is
    begin
        F77_ACCESS.ATRELC (RCKEY, HOW, NOPGS, PGSZ, RTN);
    end ADA_TRELC;
end F77_CALLABLES;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--damestest.txt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with TEXT_IO;
use TEXT_IO;
with TOOLS;
use TOOLS;
with WAREHOUSE;
use WAREHOUSE;
with DISPLAY;
use DISPLAY;
with BOTH_VARIABLES;
use BOTH_VARIABLES;
with TTY_IO;

procedure DAMES_TEST is

--***************************************************************************--
--                          INTERNAL PROCEDURES                              --
--***************************************************************************--


-------------------------------------------------------------------------------
--                          procedure MENU_1                                 --
-------------------------------------------------------------------------------
    procedure MENU_1 is
    begin
    NEW_PAGE;
    DISPL (20, 04, "          MENU_1                                 ");
    DISPL (20, 07, "- End                                            ");
    DISPL (20, 08, "- Test all the procedures                        ");
    DISPL (20, 09, "- Test one procedure                             ");
    DISPL (20, 10, "- Log file display                               ");
    DISPL (20, 11, "- Files initialization                           ");
    DISPL (10, 14, "Put the cursor on your choice with ""NEW LINE"" ");
    DISPL (10, 15, "and then validate with ""CR"" ");
    end MENU_1;
-------------------------------------------------------------------------------
--                          procedure MENU_2                                 --
-------------------------------------------------------------------------------
    procedure MENU_2 is
    begin
    NEW_PAGE;
    DISPL (00, 01, "              MENU_2         ");
    NEW_LINE;
    PUT_LINE (" - MENU_1                                                        ");
    PUT_LINE (" DAMES_OPEN,           DAMES_EXECUTE,        DAMES_CLOSE,        ");
    PUT_LINE (" LL_D_OPEN,            LL_D_DEFINE_TABLE,    LL_D_LOCK,          ");
    PUT_LINE (" LL_D_GET_INFORMATION, LL_D_UNLOCK,          LL_D_CLOSE,         ");
    PUT_LINE (" LL_D_E_MATCH,         LL_D_F_MATCH,         LL_D_I_MATCH,       ");
    PUT_LINE (" LL_D_R_MATCH,         LL_D_S_MATCH,         LL_D_E_OR_MATCH,    ");
    PUT_LINE (" LL_D_F_OR_MATCH,      LL_D_I_OR_MATCH,      LL_D_R_OR_MATCH,    ");
    PUT_LINE (" LL_D_S_OR_MATCH,      LL_D_E_AND_MATCH,     LL_D_F_AND_MATCH,   ");
    PUT_LINE (" LL_D_I_AND_MATCH,     LL_D_R_AND_MATCH,     LL_D_S_AND_MATCH,   ");
    PUT_LINE (" LL_D_FIND,            LL_D_FIND_NEXT,       LL_D_FIND_PREVIOUS, ");
    PUT_LINE (" LL_D_NEXT,            LL_D_PREVIOUS,        LL_D_E_GET_COLUMN,  ");
    PUT_LINE (" LL_D_F_GET_COLUMN,    LL_D_I_GET_COLUMN,    LL_D_R_GET_COLUMN,  ");
    PUT_LINE (" LL_D_S_GET_COLUMN,    LL_D_E_GET_ROW,       LL_D_F_GET_ROW,     ");
    PUT_LINE (" LL_D_I_GET_ROW,       LL_D_R_GET_ROW,       LL_D_S_GET_ROW,     ");
    PUT_LINE (" LL_D_E_BUILD_COLUMN,  LL_D_F_BUILD_COLUMN,  LL_D_I_BUILD_COLUMN,");
    PUT_LINE (" LL_D_R_BUILD_COLUMN,  LL_D_S_BUILD_COLUMN,  LL_D_E_BUILD_ROW,   ");
    PUT_LINE (" LL_D_F_BUILD_ROW,     LL_D_I_BUILD_ROW,     LL_D_R_BUILD_ROW,   ");
    PUT_LINE (" LL_D_S_BUILD_ROW,     LL_D_UPDATE,          LL_D_INSERT,        ");
    PUT_LINE (" LL_D_DELETE);                                                   ");
    DISPL (0, 22,
           "Put the cursor on your choice with ""NEW LINE"" and ""ESC"" ");
    DISPL (0, 23, "and then validate with ""CR"" ");
    end MENU_2;

-------------------------------------------------------------------------------
--                          procedure MENU_3                                 --
-------------------------------------------------------------------------------
    procedure MENU_3 is
    begin
    DISPL (00, 04, "          MENU_3                                 ");
    DISPL (00, 06, "        - menu_1                                 ");
    DISPL (00, 07, "        - menu_2                                 ");
    DISPL (00, 08, "        - execute                                ");
    DISPL (00, 09, "        - create                                 ");
    DISPL (00, 10, "        - modify                                 ");
    DISPL (00, 11, "        - delete                                 ");
    DISPL (00, 15, "  put the cursor on your choice with ""NEW LINE""  ");
    DISPL (00, 16, "  and then validate with ""CR""                     ");
    end MENU_3;
--***************************************************************************--
--                          procedure BODY                                   --
--***************************************************************************--

begin

-- ROLM bugs >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    ACC_LIST (49, 01) := 25;
    ACC_LIST (49, 02) := 14;
    ACC_LIST (49, 03) := 15;
-- end ROLM bugs >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    CREATE (FILE => LOG_FILE, NAME => "log_file");

    loop
    MENU_1;
    loop
        ROW := 7;
        COLUMN := 20;
        CHOICE (R_O_W, 11, ROW, COLUMN);
        if ROW <= 11 then  exit;  end if;
    end loop;

    NEW_PAGE;

    case ROW is
        when 8 =>
        EXECUTE_AUTOMATIC_VERSION;
        when 9 =>
        MENU2:
        loop
            MENU_2;
-- cursor movement >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
            TTY_IO.ECHO_OFF;
            COLUMN := 1;
            ROW := 2;
            loop
            SCREEN_POS (COLUMN, ROW);
            TTY_IO.GET (A);

            case A is
                when ASCII.CR =>  exit;
                when ASCII.LF =>
                ROW := ROW + 1;
                if ROW > 20 then
                    ROW := 2;
                end if;
                when ASCII.ESC =>
                COLUMN := COLUMN + 22;
                if COLUMN > 45 then
                    COLUMN := 1;
                end if;
                when ASCII.DEL =>
                COLUMN := COLUMN - 22;
                if COLUMN < 1 then
                    COLUMN := 45;
                end if;
                when others =>  null;
            end case;
            end loop;

            TTY_IO.ECHO_ON;
-- end cursor movement >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
            NEW_PAGE;

            if ROW /= 2 then
            case COLUMN is
                when 1 =>
                INTERFACE_NB :=
                  INTERFACE_NUMBER ((ROW - 3) * 3);
                when 23 =>
                INTERFACE_NB :=
                  INTERFACE_NUMBER ((ROW - 3) * 3 + 1);
                when 45 =>
                INTERFACE_NB :=
                  INTERFACE_NUMBER ((ROW - 3) * 3 + 2);
                when others =>  null;
            end case;

            RDWR_POINTER_TABLE (LOAD);
            INTERFACE_PR_NAME :=
              INTERFACE_PROCEDURE_NAME'VAL (INTERFACE_NB);

            loop
                PUT ("interface procedure " &
                 INTERFACE_PROCEDURE_NAME'IMAGE
                   (INTERFACE_PR_NAME));

                MENU_3;
                loop
                ROW := 6;
                COLUMN := 8;
                CHOICE (R_O_W, 11, ROW, COLUMN);
                if ROW <= 11 then  exit;  end if;
                end loop;

                NEW_PAGE;

                case ROW is

                when 6      =>  exit MENU2;

                when 7      =>  exit;

                when 8      =>  EXECUTE_TEST_CASE;

                when 9      =>  CREATE_TEST_CASE;

                when 10     =>  MODIFY_TEST_CASE;

                when 11     =>  DELETE_TEST_CASE;

                when others =>  null;
                end case;
            end loop;
            else
            exit;
            end if;
        end loop MENU2;

        when 10 =>  INFORM_ABOUT_RESULT;
        when 11 =>
        DISPL (00, 3, "this is the procedure INITIALIZE.    ");
        DISPL (00, 4, "BE CARREFUL with this procedure :    ");
        DISPL (00, 5, "it initializes ALL the files.        ");
        DISPL (00, 7, "now,are you sure to go on (Y/N) ?    ");

        loop
            SCREEN_POS (34, 7);  GET (A);
            exit when A = 'Y' or A = 'N';
        end loop;

        NEW_PAGE;

        if A = 'Y' then
            DISPL (00, 1, "initialize");
            DISPL (30, 10, "WORKING , be quiet !");
            INITIALIZE;
        end if;

        when others =>  exit;

    end case;

    end loop;

    CLOSE (LOG_FILE);

end DAMES_TEST;
pragma MAIN;