Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/tools/constrct.src

Text File | 1988-05-03 | 143.7 KB | 4,149 lines

--::::::::::
--CONSTRCT.PRO
--::::::::::



-------- SIMTEL20 Ada Software Repository Prologue ------------
--                                                           -*
-- Unit name    : CONSTRUCT and CREATE_CO
-- Version      : 841201
-- Author       : Mitre Corp.
-- DDN Address  : wis_ada at mitre
-- Date created : 10 NOV 84
-- Release date : 15 DEC 84
-- Last update  : 21 JAN 85
-- Machine/System Compiled/Run on : Intellimac 7000M
--                                  UNIX
--                                  Telesoft unvalidated
--                                                           -*
---------------------------------------------------------------
--                                                           -*
-- Keywords     :  Automatic Compilation, Compilation Order,
--                 Configuration Management, Dependency Graph
--                 Scan Ada Source for withs and separates
----------------:
--
-- Abstract     :
--         The function of Construct is to perform the minimal number
--    of system commands to bring a project up to date given that
--    changes to project files have occurred.  If a project is already
--    up to date, Construct will indicate this and no commands will be
--    performed.  Construct can also be used to supply descriptive
--    information in the form of dependency graphs and name lists of
--    project files.
--
--         Create_CO reads a set of Ada source code files and creates
--    a configuration object which describes the dependencies that
--    exist among the files.  The configuration object is formatted so
--    that it may be read by Construct.  In determining dependencies,
--    Create_CO observes the filenaming conventions of the TeleSoft
--    Ada compiler (i.e., filename extensions of .text, .sym, .code)
--    and the compiler's language restriction that specifications and
--    bodies of Ada packages reside in the same file.
----------------:
--                                                           -*
------------------ Revision history ---------------------------
--                                                           -*
-- DATE      VERSION AUTHOR        HISTORY
-- 12/15/84  841201  Mitre Corp    Initial Release
-- 01/21/85  841201  Mitre Corp    Converted subfile headers
--                                 into Ada comments
--                                                           -*
------------------ Distribution and Copyright -----------------
--                                                           -*
-- This prologue must be included in all copies of this software.
--
-- This software is released to the Public Domain (note:
--   software released to the Public Domain is not subject
--   to copyright protection).
--
-- Restrictions on use or distribution:  Although there are
--      no current plans to provide maintenance for CONSTRUCT
--      or CREATE_CO, we would appreciate your reporting
--      problems and experiences to:
--
--                wis_ada at mitre (net address)
--
--      or call at:
--
--                (703)  883-7697
--                                                           -*
------------------ Disclaimer ---------------------------------
--                                                           -*
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--                                                           -*
-------------------END-PROLOGUE--------------------------------

--::::::::::::::
--arguments.text
--::::::::::::::
-- This package prompts for and validates all arguments entered by
-- the user (i.e., configuration object name, target name, and options).
with STR_PACK;  use STR_PACK;
with TEXT_IO;  use TEXT_IO;
package ARGUMENTS is

  -- The CO_FILE is used by BLD_GRAPH to build the dependency tree.
  -- This file is opened by ARGUMENTS in order to validate the CO
  -- argument but is closed by BLD_GRAPH when processing is complete.
  CO_FILE    : FILE_TYPE;

  -- TARGET_ARG is used by DISPLAY to print the graph and by CON_PROC
  -- to determine necessary commands.  A list of targets may be included
  -- in TARGET_ARG and separated by blanks.
  TARGET_ARG : STR_PACK.DYNAMIC_STRING;

  -- The set of valid options include:
  -- EXECUTE to actually execute commands, CMD_PRINT to print the required
  -- commands, TOP_DOWN_GRAPH to print a textual top-down graph, BOTTOM_UP
  -- to print a textual bottom-up graph, LIST to print lists of basic and
  -- derived names in the CO_FILE, DUMP_TREE to debug the dependency tree,
  -- and PROCESS_DUMP to debug the command processing.
  type OPTION_TYPE is
    (EXECUTE, CMD_PRINT, TOP_DOWN_GRAPH, BOTTOM_UP_GRAPH,  LIST,
     DUMP_TREE, PROCESS_DUMP);

  -- Used by other packages to determine which options were set by the user.
  function IS_SET (OPTION : OPTION_TYPE) return BOOLEAN;

  -- Called by CONSTRUCT to initiate the processing of arguments.
  procedure PROMPT;

end ARGUMENTS;



with ENVIRONS;
package body ARGUMENTS is

  -- Global data within package body:

  -- String types are needed for use with TEXT_IO (i.e., CO_STR and
  -- TARGET_STR); otherwise, dynamic strings are used.
  -- Options are manipulated as a table of boolean values.
  CO_STR                 : STRING(1..ENVIRONS.MAX_FILENAME_LENGTH);
  TARGET_STR             : STRING(1..ENVIRONS.MAX_LINE_LENGTH);
  OPTION_TABLE           : array (OPTION_TYPE) of BOOLEAN;

  -- The user is given 3 attempts to enter a correct argument
  -- or '?' for help.
  MAX_NUM_OF_ATTEMPTS    : constant POSITIVE := 3;
  HELP_CHAR              : constant CHARACTER := '?';



-- Used to fill an entire string with blanks for initialization.
-- Included because packed aggregates were not yet implemented
-- in given compiler.
procedure FILL_WITH_BLANKS(STR : in out STRING) is
begin
  for I in STR'RANGE loop
    STR(I) := ' ';
  end loop;
end FILL_WITH_BLANKS;


-- This procedure prompts for a configuration object and validates the
-- user input.  The default CO is "co_file".  Invalid entries include
-- (1) a list of COs, (2) a non-existent CO, including one which
-- exceeds the maximum allowed length for the given system, and
-- (3) an inaccessible CO, for example one without read priviledge.
-- The user is given 3 trys to enter a correct CO.  After 3 incorrect
-- trys the program aborts.
procedure ENTER_CO is

  -- Used with GET_LINE to obtain user input.
  RAW_INPUT_LINE    : STRING(1..ENVIRONS.MAX_LINE_LENGTH);
  LAST              : NATURAL;

  -- DEFAULT_CO is assumed when a null or blank string is entered by user.
  DEFAULT_CO        : constant STRING := "co_file";

  -- Used with STR_PACK routines to obtain token(s) entered by user.
  CO_TEMP, CO_TOKEN : STR_PACK.DYNAMIC_STRING;
  SEPARATOR         : CHARACTER;

  -- Flag used to determine whether successful before maximum number of
  -- user attempts exceeded.
  SUCCESSFUL_INPUT  : BOOLEAN;



  -- This procedure opens the CO_FILE unless an empty string is passed in,
  -- a string longer than the maximum filename allowed by the system is passed
  -- in, or a name_error or use_error is raised by TEXT_IO.  Help information
  -- is displayed if the HELP_CHAR is passed in.
  procedure OPEN_IF_VALID(STR : in STRING; SUCCESS : out BOOLEAN) is

  -- Displays help information to the user.
  procedure WRITE_CO_HELP is
  begin
    PUT_LINE("****************  HELP INFORMATION  ****************");
    PUT_LINE("Enter a single configuration object name or carriage");
    PUT("return for the default which is "); PUT(DEFAULT_CO);
    PUT_LINE(".  Three ");
    PUT_LINE("input attempts are given.");
    PUT_LINE("****************************************************");
  end WRITE_CO_HELP;

  begin   -- OPEN_IF_VALID
    if STR'LENGTH = 0 then
      -- There is an empty string here meaning the user entered
      -- several separators with no tokens in between and this
      -- is presumed to be a name_error.
      raise NAME_ERROR;
    elsif STR'LENGTH > ENVIRONS.MAX_FILENAME_LENGTH then
      -- There is certainly a name_error but it may not be caught
      -- by TEXT_IO if the truncated string happens to be valid.
      raise NAME_ERROR;
    -- Want to test for the HELP_CHAR but do not want to disallow a
    -- possible filename beginning with the HELP_CHAR.
    elsif STR'LENGTH = 1 and STR(STR'FIRST) = HELP_CHAR then
      WRITE_CO_HELP;
      NEW_LINE;
      SUCCESS := FALSE;
    else
      OPEN(CO_FILE, IN_FILE, STR);
      SUCCESS := TRUE;
    end if;  -- STR'LENGTH = 0 then ... elsif ... elsif ... else ...

  exception
    when NAME_ERROR =>
      PUT_LINE("*** Given CO does not exist ***");
      NEW_LINE;
      SUCCESS := FALSE;

    when USE_ERROR =>
      PUT_LINE("*** Given CO is not accessible ***");
      NEW_LINE;
      SUCCESS := FALSE;

    when others =>
      PUT_LINE("*** Unknown error while opening CO ***");
      NEW_LINE;
      SUCCESS := FALSE;
  end OPEN_IF_VALID;


begin  -- ENTER_CO
  -- Allow maximum number of trys to enter correct CO.
  for TRY in 1..MAX_NUM_OF_ATTEMPTS loop

    -- Prompt user and store input as dynamic string.
    if TRY = 1 then PUT("CONFIGURATION OBJECT => ");
    else PUT("RE-TRY => ");
    end if;
    GET_LINE(RAW_INPUT_LINE, LAST);
    STR_PACK.CONVERT_TO_DYNAMIC
      (RAW_INPUT_LINE(RAW_INPUT_LINE'FIRST..LAST), CO_TEMP);

    -- Validate user input.
    -- STR_PACK.GET_TOKEN is used to eliminate extra blanks a user may
    -- have entered (e.g., a filename with leading blanks would not be
    -- equivalent to the same filename w/out blanks and therefore may
    -- not be valid).  This presumes that token separators used in
    -- GET_TOKEN may not appear in valid entries.  This is not
    -- necessarily a desirable restriction.
    case STR_PACK.NUM_OF_TOKENS(CO_TEMP) is
      when 0 =>
        FILL_WITH_BLANKS(CO_STR);
        CO_STR(CO_STR'FIRST..DEFAULT_CO'LENGTH) := DEFAULT_CO;
        OPEN_IF_VALID(DEFAULT_CO, SUCCESSFUL_INPUT);
      when 1 =>
        STR_PACK.GET_TOKEN(CO_TEMP, CO_TOKEN, SEPARATOR);
        FILL_WITH_BLANKS(CO_STR);
        STR_PACK.CONVERT_TO_STRING(CO_TOKEN, CO_STR);
        OPEN_IF_VALID
          (CO_STR(CO_STR'FIRST..STR_PACK.LENGTH(CO_TOKEN)), SUCCESSFUL_INPUT);
      when others =>
        PUT_LINE("*** A list of COs is not allowed ***");
        NEW_LINE;
        SUCCESSFUL_INPUT := FALSE;
    end case;   -- STR_PACK.NUM_OF_TOKENS(CO_TEMP) is

    -- Exit if valid CO entered before end of loop of allowed user
    -- input attempts.
    if SUCCESSFUL_INPUT then
      if TRY > 1 then NEW_LINE;
      end if;
      exit;  -- for TRY in 1..MAX_NUM_OF_ATTEMPTS loop
    end if;

  end loop;    -- for TRY in 1..MAX_NUM_OF_ATTEMPTS

  -- Abort if valid CO never entered during loop of allowed user
  -- input attempts.
  if not SUCCESSFUL_INPUT then
    PUT_LINE("*** Number of input attempts exceeded ***");
    raise ENVIRONS.ERROR;
  end if;

end ENTER_CO;




-- This procedure prompts for the targets argument and validates the
-- user input.  The default targets list is indicated by assigning the
-- the empty string.  The only invalid entry checked for is names
-- which exceed the maximum allowed length for the given system.
-- For each target in the list, the user is given 3 trys to
-- enter a correct target.  If 3 trys are ever exceeded the program
-- aborts.
procedure ENTER_TARGETS is

  -- Used with GET_LINE to obtain user input.
  RAW_INPUT_LINE   : STRING(1..ENVIRONS.MAX_LINE_LENGTH);
  RETRY_LINE       : STRING(1..ENVIRONS.MAX_LINE_LENGTH);
  LAST             : NATURAL;

  -- Used with STR_PACK routines to obtain token(s) entered by user.
  TARGET_TEMP_1    : STR_PACK.DYNAMIC_STRING;
  TARGET_TEMP_2    : STR_PACK.DYNAMIC_STRING;
  TARGET_TOKEN     : STR_PACK.DYNAMIC_STRING;
  SEPARATOR        : CHARACTER;

  -- Flag used to determine whether successful before maximum number of
  -- user attempts exceeded.
  SUCCESSFUL_INPUT : BOOLEAN;



  -- This procedure appends another token to the list of targets
  -- if the token passed in is valid.  The only invalid target at
  -- this point is one longer than the maximum allowed filename
  -- length.  Other invalid targets (e.g., those which do not exist
  -- or are inaccessible) are identified in CON_PROC.  In this
  -- procedure, if the HELP_CHAR is passed in as the token then
  -- help information is displayed.
  procedure APPEND_IF_VALID (TOKEN   : in STR_PACK.DYNAMIC_STRING;
                             SUCCESS : out BOOLEAN) is

    -- First character of token used to check for HELP_CHAR.
    FIRST_CHAR : CHARACTER;

    -- Displays help information to the user.
    procedure WRITE_TARGET_HELP is
    begin
      PUT_LINE("****************  HELP INFORMATION  ****************");
      PUT_LINE("Enter a single target name, a list of target names, ");
      PUT_LINE("or carriage return for the default which is the ");
      PUT_LINE("first target in the specified configuration object.");
      PUT_LINE("Three input attempts per target are given.");
      PUT_LINE("****************************************************");
    end WRITE_TARGET_HELP;

  begin  -- APPEND_IF_VALID
    if STR_PACK.EMPTY(TOKEN) then
      SUCCESS := TRUE;
    else
      STR_PACK.READ(FIRST_CHAR, TOKEN);
      if FIRST_CHAR = HELP_CHAR then
        WRITE_TARGET_HELP;
        NEW_LINE;
        SUCCESS := FALSE;
      elsif STR_PACK.LENGTH(TOKEN) > ENVIRONS.MAX_FILENAME_LENGTH then
        PUT_LINE("*** Length of the target exceeds system limitations ***");
        NEW_LINE;
        SUCCESS := FALSE;
      else
        STR_PACK.APPEND(TOKEN, TARGET_ARG);
        STR_PACK.APPEND(" ", TARGET_ARG);
        SUCCESS := TRUE;
      end if; -- FIRST_CHAR = HELP_CHAR then ... elsif ... else ...
    end if;   -- STR_PACK.EMPTY(TOKEN) then ... else ...
  end APPEND_IF_VALID;


begin   -- ENTER_TARGETS
  -- Prompt user and store original input line as dynamic string.
      PUT("TARGET(S) => ");
      GET_LINE(RAW_INPUT_LINE, LAST);
      STR_PACK.CONVERT_TO_DYNAMIC
        (RAW_INPUT_LINE(RAW_INPUT_LINE'FIRST..LAST), TARGET_TEMP_1);

  -- Validate each target from original input and append to dynamic string
  -- of targets.  Note the use of STR_PACK.GET_TOKEN precludes entering
  -- targets which include the token separators in their name.
  STR_PACK.ASSIGN(TARGET_ARG, STR_PACK.EMPTY_STR);
  loop
    STR_PACK.GET_TOKEN(TARGET_TEMP_1, TARGET_TOKEN, SEPARATOR);
    APPEND_IF_VALID(TARGET_TOKEN, SUCCESSFUL_INPUT);

    -- Allow 2 retrys if not successful.  Replace only the invalid target.
    if not SUCCESSFUL_INPUT then
      for TRY in 2..MAX_NUM_OF_ATTEMPTS loop
        PUT("RE-TRY => ");
        GET_LINE(RETRY_LINE, LAST);
        STR_PACK.CONVERT_TO_DYNAMIC
          (RETRY_LINE(RETRY_LINE'FIRST..LAST), TARGET_TEMP_2);

        -- Don't want to raise END_OF_STRING from STR_PACK.GET_TOKEN here
        -- so use STR_PACK.NUM_OF_TOKENS to determine next step.
        case STR_PACK.NUM_OF_TOKENS(TARGET_TEMP_2) is
          when 0 =>
            SUCCESSFUL_INPUT := TRUE;
          when 1 =>
            STR_PACK.GET_TOKEN(TARGET_TEMP_2, TARGET_TOKEN, SEPARATOR);
            APPEND_IF_VALID(TARGET_TOKEN, SUCCESSFUL_INPUT);
          when others =>
            PUT_LINE("*** A list is not allowed on re-try ***");
            NEW_LINE;
            SUCCESSFUL_INPUT := FALSE;
        end case;   -- STR_PACK.NUM_OF_TOKENS(TARGET_TEMP_2) is

      -- Exit if valid target list entered before end of loop of allowed user
      -- input attempts.
      if SUCCESSFUL_INPUT then
        NEW_LINE;
        exit;  -- for TRY in 2..MAX_NUM_OF_ATTEMPTS loop
      end if;

      end loop;   -- for TRY in 2..MAX_NUM_OF_ATTEMPTS

      -- Abort if valid target list never entered during loop of allowed user
      -- input attempts.
      if not SUCCESSFUL_INPUT then
        PUT_LINE("*** Number of input attempts exceeded ***");
        raise ENVIRONS.ERROR;
      end if;

    end if;  -- not SUCCESSFUL_INPUT
  end loop;  -- Used to validate each token.

exception
  when STR_PACK.END_OF_STRING =>   -- Raised by GET_TOKEN when no more tokens.
    FILL_WITH_BLANKS(TARGET_STR);
    STR_PACK.CONVERT_TO_STRING(TARGET_ARG, TARGET_STR);

end ENTER_TARGETS;




-- This procedure prompts for the options and validates the user
-- input.  The default options are EXECUTE, CMD_PRINT, NO_TOP_DOWN_GRAPH,
-- NO_BOTTOM_UP_GRAPH, NO_LIST, NO_DUMP_TREE, and NO_PROCESS_DUMP.  For
-- each option entered, the user is given 3 trys to enter a correct
-- option.  After 3 incorrect trys the program aborts.
procedure ENTER_OPTIONS is

  -- Used with GET_LINE to obtain user input.
  RAW_INPUT_LINE         : STRING(1..ENVIRONS.MAX_LINE_LENGTH);
  RETRY_LINE             : STRING(1..ENVIRONS.MAX_LINE_LENGTH);
  LAST                   : NATURAL;

  -- Used with STR_PACK routines to obtain token(s) entered by user.
  OPTION_TEMP_1          : STR_PACK.DYNAMIC_STRING;
  OPTION_TEMP_2          : STR_PACK.DYNAMIC_STRING;
  OPTION_TOKEN           : STR_PACK.DYNAMIC_STRING;
  SEPARATOR              : CHARACTER;

  -- Flag used to determine whether successful before maximum number of
  -- user attempts exceeded.
  SUCCESSFUL_INPUT       : BOOLEAN;


  -- Used to convert input string to all upper case so that input options
  -- can be easily compared with valid options.
  procedure CONVERT_TO_UPPER_CASE(STR : in out STRING) is
  begin
    for I in STR'RANGE loop
      case STR(I) is
        when 'a' => STR(I) := 'A';
        when 'b' => STR(I) := 'B';
        when 'c' => STR(I) := 'C';
        when 'd' => STR(I) := 'D';
        when 'e' => STR(I) := 'E';
        when 'f' => STR(I) := 'F';
        when 'g' => STR(I) := 'G';
        when 'h' => STR(I) := 'H';
        when 'i' => STR(I) := 'I';
        when 'j' => STR(I) := 'J';
        when 'k' => STR(I) := 'K';
        when 'l' => STR(I) := 'L';
        when 'm' => STR(I) := 'M';
        when 'n' => STR(I) := 'N';
        when 'o' => STR(I) := 'O';
        when 'p' => STR(I) := 'P';
        when 'q' => STR(I) := 'Q';
        when 'r' => STR(I) := 'R';
        when 's' => STR(I) := 'S';
        when 't' => STR(I) := 'T';
        when 'u' => STR(I) := 'U';
        when 'v' => STR(I) := 'V';
        when 'w' => STR(I) := 'W';
        when 'x' => STR(I) := 'X';
        when 'y' => STR(I) := 'Y';
        when 'z' => STR(I) := 'Z';
        when others => null;
      end case;   -- STR(I) is
    end loop;     -- for I in STR'RANGE
  end CONVERT_TO_UPPER_CASE;


  -- This procedure sets the option corresponding to the token passed in;
  -- unless the first character of the token is the HELP_CHAR, then help
  -- information is displayed instead.
  procedure SET_IF_VALID(TOKEN   : in STR_PACK.DYNAMIC_STRING;
                         SUCCESS : out BOOLEAN) is

    -- Used to convert the token into an enumerated option type and a
    -- flag indicating whether or not to set that option.
    PREFIX     : BOOLEAN;
    OPTION     : OPTION_TYPE;

    -- Used to determine whether help was requested.
    FIRST_CHAR : CHARACTER;

    -- Used to check for valid option.
    INVALID_OPTION         : exception;
    MAX_OPT_LENGTH         : constant NATURAL := 15;
    OPT_LENGTH             : NATURAL;
    OPT_STR                : STRING(1..ENVIRONS.MAX_LINE_LENGTH);


  -- Used to display help information.
  procedure WRITE_OPTION_HELP is
  begin
    PUT_LINE("***************  HELP INFORMATION  *****************");
    PUT_LINE("Enter a single option, a list of options, or ");
    PUT_LINE("carriage return for the default options which ");
    PUT_LINE("are EXECUTE and CMD_PRINT.  The prefix 'NO_' turns");
    PUT_LINE("an option off.  Valid options are: ");
    PUT_LINE("  1)  EXECUTE         - execute the commands needed");
    PUT_LINE("                        to update the system.");
    PUT_LINE("  2)  CMD_PRINT       - print the commands needed to ");
    PUT_LINE("                        update the system.");
    PUT_LINE("  3)  TOP_DOWN_GRAPH  - print a textual top-down ");
    PUT_LINE("                        graph of dependencies for ");
    PUT_LINE("                        the given target.");
    PUT_LINE("  4)  BOTTOM_UP_GRAPH - print a textual bottom-up ");
    PUT_LINE("                        graph of dependencies for ");
    PUT_LINE("                        the given target.");
    PUT_LINE("  4)  LIST            - print lists of all basic and  ");
    PUT_LINE("                        derived names in the given CO.");
    PUT_LINE("Options may be entered in mixed case or abbreviated,");
    PUT_LINE("as well as entered in any order.  If conflicting ");
    PUT_LINE("options are entered, the last one entered will be ");
    PUT_LINE("used.  Three input attempts per option are given.");
    PUT_LINE("****************************************************");
  end WRITE_OPTION_HELP;


  -- Used to parse the option token and convert from a dynamic string
  -- type to an enumerated option type and a flag indicating whether the
  -- option is to be set.
  procedure CONVERT_TO_OPTION (TOKEN : in STR_PACK.DYNAMIC_STRING;
                               PREF  : out BOOLEAN;
                               OPT   : out OPTION_TYPE) is

    -- Used to split the option token into its prefix and option type.
    PREF_STR              : constant STRING := "NO_";
    FIRST_CHARS, PREF_DYN : STR_PACK.DYNAMIC_STRING;
    CHAR                  : CHARACTER;
    OPT_DYN               : STR_PACK.DYNAMIC_STRING;

    -- Used to compare input to set of valid options.
    EXEC_STR       : constant STRING(1..MAX_OPT_LENGTH) := "EXECUTE        ";
    TOP_DOWN_STR   : constant STRING(1..MAX_OPT_LENGTH) := "TOP_DOWN_GRAPH ";
    BOTTOM_UP_STR  : constant STRING(1..MAX_OPT_LENGTH) := "BOTTOM_UP_GRAPH";
    LIST_STR       : constant STRING(1..MAX_OPT_LENGTH) := "LIST           ";
    CMD_STR        : constant STRING(1..MAX_OPT_LENGTH) := "CMD_PRINT      ";
    TREE_STR       : constant STRING(1..MAX_OPT_LENGTH) := "DUMP_TREE      ";
    PROC_STR       : constant STRING(1..MAX_OPT_LENGTH) := "PROCESS_DUMP   ";

  begin   -- CONVERT_TO_OPTION
    -- Determine whether a prefix is present.
    if STR_PACK.LENGTH(TOKEN) < PREF_STR'LAST then
      PREF := FALSE;
    else
      STR_PACK.ASSIGN(FIRST_CHARS, STR_PACK.EMPTY_STR);
      for I in PREF_STR'RANGE loop
        STR_PACK.READ(CHAR, I, TOKEN);
        STR_PACK.APPEND(CHAR, FIRST_CHARS);
      end loop;
      STR_PACK.CONVERT_TO_DYNAMIC(PREF_STR, PREF_DYN);
      if FIRST_CHARS = PREF_DYN then PREF := TRUE;
      else PREF := FALSE;
      end if;
    end if;  -- STR_PACK.LENGTH(TOKEN) < PREF_STR'LAST then ... else ...

    -- Determine option type as dynamic string.
    if PREF then
      STR_PACK.ASSIGN(OPT_DYN, STR_PACK.EMPTY_STR);
      for I in PREF_STR'LENGTH + 1 .. STR_PACK.LENGTH(TOKEN) loop
        STR_PACK.READ(CHAR, I, TOKEN);
        STR_PACK.APPEND(CHAR, OPT_DYN);
      end loop;
    else STR_PACK.ASSIGN(OPT_DYN, TOKEN);
    end if;   -- PREF then ... else ...

    -- Determine option type as enumeration value.
    OPT_LENGTH := STR_PACK.LENGTH(OPT_DYN);
    STR_PACK.CONVERT_TO_STRING(OPT_DYN, OPT_STR);
    if OPT_LENGTH > MAX_OPT_LENGTH then
      raise INVALID_OPTION;
    elsif OPT_STR(1..OPT_LENGTH) = EXEC_STR(1..OPT_LENGTH) then
      OPT := EXECUTE;
    elsif OPT_STR(1..OPT_LENGTH) = TOP_DOWN_STR(1..OPT_LENGTH) then
      OPT := TOP_DOWN_GRAPH;
    elsif OPT_STR(1..OPT_LENGTH) = BOTTOM_UP_STR(1..OPT_LENGTH) then
      OPT := BOTTOM_UP_GRAPH;
    elsif OPT_STR(1..OPT_LENGTH) = LIST_STR(1..OPT_LENGTH) then
      OPT := LIST;
    elsif OPT_STR(1..OPT_LENGTH) = CMD_STR(1..OPT_LENGTH) then
      OPT := CMD_PRINT;
    elsif OPT_STR(1..OPT_LENGTH) = TREE_STR(1..OPT_LENGTH) then
      OPT := DUMP_TREE;
    elsif OPT_STR(1..OPT_LENGTH) = PROC_STR(1..OPT_LENGTH) then
      OPT := PROCESS_DUMP;
    else raise INVALID_OPTION;
    end if;  -- ... elsif ... else ...
  end CONVERT_TO_OPTION;


  begin   -- SET_IF_VALID
    if STR_PACK.EMPTY(TOKEN) then
      SUCCESS := TRUE;
    else
      STR_PACK.READ(FIRST_CHAR, TOKEN);
      if FIRST_CHAR = HELP_CHAR then
        WRITE_OPTION_HELP;
        NEW_LINE;
        SUCCESS := FALSE;
      else
        CONVERT_TO_OPTION(TOKEN, PREFIX, OPTION);  -- May raise INVALID_OPTION.
        if PREFIX then OPTION_TABLE(OPTION) := FALSE;
        else OPTION_TABLE(OPTION) := TRUE;
        end if;
        SUCCESS := TRUE;
      end if;   -- FIRST_CHAR = HELP_CHAR then ... else ...
    end if;  -- STR_PACK.EMPTY(TOKEN) then ... else ...

  exception
    when INVALID_OPTION =>
      PUT("*** ");
      STR_PACK.CONVERT_TO_STRING(TOKEN, OPT_STR);
      PUT(OPT_STR(OPT_STR'FIRST..STR_PACK.LENGTH(TOKEN)));
      PUT_LINE(" is an invalid option ***");
      NEW_LINE;
      SUCCESS := FALSE;
  end SET_IF_VALID;



begin   -- ENTER_OPTIONS
  -- Prompt user and store original input as dynamic string.
    PUT("OPTION(S) => ");
    GET_LINE(RAW_INPUT_LINE, LAST);
    CONVERT_TO_UPPER_CASE(RAW_INPUT_LINE);
    STR_PACK.CONVERT_TO_DYNAMIC
      (RAW_INPUT_LINE(RAW_INPUT_LINE'FIRST..LAST), OPTION_TEMP_1);

  -- Validate each option from original input and set option table.
  OPTION_TABLE := (TRUE,TRUE,FALSE,FALSE,FALSE,FALSE,FALSE); -- Defaults.
  loop
    STR_PACK.GET_TOKEN(OPTION_TEMP_1, OPTION_TOKEN, SEPARATOR);
    SET_IF_VALID(OPTION_TOKEN, SUCCESSFUL_INPUT);

    -- Allow 2 re-trys if invalid.  Change only the invalid option.
    if not SUCCESSFUL_INPUT then
      for TRY in 2..MAX_NUM_OF_ATTEMPTS loop
        PUT("RE-TRY => ");
        GET_LINE(RETRY_LINE, LAST);
        CONVERT_TO_UPPER_CASE(RETRY_LINE);
        STR_PACK.CONVERT_TO_DYNAMIC
          (RETRY_LINE(RETRY_LINE'FIRST..LAST), OPTION_TEMP_2);

        -- Don't want to raise END_OF_STRING from STR_PACK.GET_TOKEN here
        -- so use STR_PACK.NUM_OF_TOKENS to determine next step.
        case STR_PACK.NUM_OF_TOKENS(OPTION_TEMP_2) is
          when 0 =>
            SUCCESSFUL_INPUT := TRUE;
          when 1 =>
            STR_PACK.GET_TOKEN(OPTION_TEMP_2, OPTION_TOKEN, SEPARATOR);
            SET_IF_VALID(OPTION_TOKEN, SUCCESSFUL_INPUT);
          when others =>
            PUT_LINE("*** A list is not allowed on re-try ***");
            NEW_LINE;
            SUCCESSFUL_INPUT := FALSE;
        end case;  -- STR_PACK.NUM_OF_TOKENS(OPTION_TEMP_2) is

        -- Exit if valid option list entered before end of loop of allowed user
        -- input attempts.
        if SUCCESSFUL_INPUT then
          NEW_LINE;
          exit;  -- for TRY in 2..MAX_NUM_OF_ATTEMPTS loop
        end if;

      end loop;  -- for TRY in 2..MAX_NUM_OF_ATTEMPTS

      -- Abort if valid option list never entered during loop of allowed user
      -- input attempts.
      if not SUCCESSFUL_INPUT then
        PUT_LINE("*** Number of input attempts exceeded ***");
        raise ENVIRONS.ERROR;
      end if;

    end if;  -- not SUCCESSFUL_INPUT then ...
  end loop;  -- Used to validate each token.

  exception
    when STR_PACK.END_OF_STRING =>  -- Raised by GET_TOKEN when no more tokens.
      null;

end ENTER_OPTIONS;


-- Function to determine whether a given option is set.
function IS_SET (OPTION : OPTION_TYPE) return BOOLEAN is
begin
  return OPTION_TABLE(OPTION);
end IS_SET;


-- Procedure to prompt for all the arguments, to call the appropriate
-- procedures that enter the arguments for processing by Construct,
-- and to re-display the arguments as given by the user.
procedure PROMPT is
begin

  PUT_LINE("Enter arguments following each prompt or '?' for help.");
  NEW_LINE;
  ENTER_CO;
  ENTER_TARGETS;
  ENTER_OPTIONS;

  NEW_LINE;
  PUT("THE CO IS:          ");
  PUT_LINE(CO_STR);

  PUT("THE TARGET(S) ARE:  ");
  if STR_PACK.EMPTY(TARGET_ARG) then PUT_LINE("Default");
  else PUT_LINE(TARGET_STR(TARGET_STR'FIRST..STR_PACK.LENGTH(TARGET_ARG)));
  end if;

  PUT("THE OPTION(S) ARE:  ");
  for OPTION in EXECUTE..CMD_PRINT loop
    if IS_SET(OPTION) then
      PUT(OPTION_TYPE'IMAGE(OPTION));
      PUT("         ");
    end if;
  end loop;
  NEW_LINE;
  PUT("                    ");
  for OPTION in TOP_DOWN_GRAPH..LIST loop
    if IS_SET(OPTION) then
      PUT(OPTION_TYPE'IMAGE(OPTION));
      PUT("  ");
    end if;
  end loop;
  NEW_LINE;
  PUT("                    ");
  for OPTION in DUMP_TREE..PROCESS_DUMP loop
    if IS_SET(OPTION) then
      PUT(OPTION_TYPE'IMAGE(OPTION));
      PUT("       ");
    end if;
  end loop;

  NEW_LINE;
  NEW_LINE;

end PROMPT;


end ARGUMENTS;

--::::::::::::::
--ast_graph.text
--::::::::::::::
-- This package defins the central data structure for the CONSTRUCT program and
-- a dump routine which prints out the data structure for debugging purposes.
-- The data structure is a linked list of names, with pointers to dependent and
-- and defining rules.  The name list also contains several work-area fields
-- (TIME-STAMP, USED, TOUCHED, and EXPANSION_LINE) which are used during
-- processing of the data structure.  The rules contain lists of targets and
-- dependents which are pointers back to the name blocks.  The rules also
-- contain links to the st of commands and a source line number for the rule.
with CALENDAR;
with ENVIRONS;
with STR_PACK;  use STR_PACK;
with TEXT_IO; use TEXT_IO, INTEGER_IO;


package AST_GRAPH is

   type RULE_DESCRIPTION;
   type LINK_TO_RULE_DESCRIPTION is access RULE_DESCRIPTION;


   type LIST_OF_RULES;
   type LINK_TO_LIST_OF_RULES is access LIST_OF_RULES;

   type LIST_OF_NAMES;
   type LINK_TO_LIST_OF_NAMES is access LIST_OF_NAMES;

   type LIST_OF_COMMANDS;
   type LINK_TO_LIST_OF_COMMANDS is access LIST_OF_COMMANDS;

   type NAME_BLOCK;
   type LINK_TO_NAME_BLOCK is access NAME_BLOCK;

   type NAME_BLOCK is
      record
         PREVIOUS_NAME_BLOCK : LINK_TO_NAME_BLOCK := NULL;
         NAME_VALUE : STR_PACK.DYNAMIC_STRING ;
         DEPENDENT_RULES : LINK_TO_LIST_OF_RULES := NULL;
         NUMBER_OF_DEPENDENTS : INTEGER := 0;
         DEFINING_RULES : LINK_TO_LIST_OF_RULES := NULL;
         TIME_STAMP : CALENDAR.TIME;
         NEXT_NAME_BLOCK : LINK_TO_NAME_BLOCK := NULL;
         USED : BOOLEAN := FALSE;
         TOUCHED : BOOLEAN := FALSE;
         EXPANSION_LINE : INTEGER := 0;
      end record;

   NAME_LIST : LINK_TO_NAME_BLOCK := NULL;
   NAME_LINK : LINK_TO_NAME_BLOCK := NULL;
   NEW_RULE_DESCRIPTION : LINK_TO_RULE_DESCRIPTION;

   type RULE_DESCRIPTION is
      record
         CO_LINE_NUMBER : INTEGER := 0;
         TARGETS : LINK_TO_LIST_OF_NAMES := NULL;
         DEPENDENTS : LINK_TO_LIST_OF_NAMES := NULL;
         TOP_OF_COMMANDS : LINK_TO_LIST_OF_COMMANDS := NULL;
         COMMANDS : LINK_TO_LIST_OF_COMMANDS := NULL;
      end record;

   type LIST_OF_NAMES is
      record
         PREVIOUS_NAME : LINK_TO_LIST_OF_NAMES;
         NAME : LINK_TO_NAME_BLOCK;
         CYCLE_DETECTED : BOOLEAN := FALSE;--Used for detecting cycles in graph.
         NEXT_NAME : LINK_TO_LIST_OF_NAMES;
      end record;

   type LIST_OF_RULES is
      record
         PREVIOUS_RULE : LINK_TO_LIST_OF_RULES;
         RULE : LINK_TO_RULE_DESCRIPTION;
         NEXT_RULE : LINK_TO_LIST_OF_RULES;
      end record;

   type LIST_OF_COMMANDS is
      record
      PREVIOUS_COMMAND : LINK_TO_LIST_OF_COMMANDS;
      COMMAND : STR_PACK.DYNAMIC_STRING;
      NEXT_COMMAND : LINK_TO_LIST_OF_COMMANDS;
      end record;


   CO_LINE : STR_PACK.DYNAMIC_STRING;


   procedure DUMP_AST_GRAPH(DUMP_OUTPUT : FILE_TYPE);

end AST_GRAPH;


package body AST_GRAPH is


-- This procedure controls the dumping of AST_GRAPH as it has been built.  It
-- is not needed for normal execution of CONSTRUCT, but is available for
-- debugging.  It loops through the NAME_BLOCK list printing each name and
-- calling internal routines to print the lists of defining rules and target
-- rules.  All output is sent to DUMP_OUTPUT which must be opened by the caller.
procedure DUMP_AST_GRAPH(DUMP_OUTPUT : FILE_TYPE) is
    LOCAL_COPY_OF_NAMES : LINK_TO_LIST_OF_NAMES;
    TEMP_NAME           : STRING(1..ENVIRONS.MAX_CMD_LENGTH);
    TEMP_COMMAND        : STRING(1..ENVIRONS.MAX_CMD_LENGTH);
    SIZE                : NATURAL;


-- This procedure prints an entir list of rules.  It is used for processing of
-- both target and dependent lists.  For each rule, all target and dependent
-- names are listed as well as the associated command lines.
procedure LOOP_THRU_RULES(ARG_LINK_TO_LIST_OF_RULES:in LINK_TO_LIST_OF_RULES)is

   LOCAL_COPY_OF_NAMES : LINK_TO_LIST_OF_NAMES;
   LOCAL_COPY_OF_COMMANDS : LINK_TO_LIST_OF_COMMANDS;
   LOCAL_COPY_OF_RULES : LINK_TO_LIST_OF_RULES;

 begin
   LOCAL_COPY_OF_RULES := ARG_LINK_TO_LIST_OF_RULES;

   loop
     NEW_LINE ( DUMP_OUTPUT );
     PUT_LINE( DUMP_OUTPUT,
               "This is a CO_LINE_NUMBER of a defining or dependent rule: ");
     PUT( DUMP_OUTPUT, LOCAL_COPY_OF_RULES.RULE.CO_LINE_NUMBER);
     NEW_LINE ( DUMP_OUTPUT );
     LOCAL_COPY_OF_NAMES := LOCAL_COPY_OF_RULES.RULE.TARGETS;

     -- loop through TARGETS
     if LOCAL_COPY_OF_NAMES = NULL then
        PUT_LINE( DUMP_OUTPUT, "TARGETS is NULL.");
     else
        loop
          PUT( DUMP_OUTPUT, "TARGET: ");
          SIZE := STR_PACK.LENGTH(    LOCAL_COPY_OF_NAMES.NAME.NAME_VALUE );
          STR_PACK.CONVERT_TO_STRING( LOCAL_COPY_OF_NAMES.NAME.NAME_VALUE,
                                      TEMP_NAME(1..SIZE) );
          PUT_LINE ( DUMP_OUTPUT, TEMP_NAME(1..SIZE) );

          exit when LOCAL_COPY_OF_NAMES.PREVIOUS_NAME = NULL;
          LOCAL_COPY_OF_NAMES := LOCAL_COPY_OF_NAMES.PREVIOUS_NAME;
        end loop;
     end if;


     LOCAL_COPY_OF_NAMES := LOCAL_COPY_OF_RULES.RULE.DEPENDENTS;
     -- loop through DEPENDENTS
     if LOCAL_COPY_OF_NAMES = NULL then
        PUT_LINE( DUMP_OUTPUT,"DEPENDENTS is NULL.");
     else
        loop
          PUT( DUMP_OUTPUT, "DEPENDENT: ");
          SIZE := STR_PACK.LENGTH(    LOCAL_COPY_OF_NAMES.NAME.NAME_VALUE );
          STR_PACK.CONVERT_TO_STRING( LOCAL_COPY_OF_NAMES.NAME.NAME_VALUE,
                                      TEMP_NAME(1..SIZE) );
          PUT_LINE ( DUMP_OUTPUT, TEMP_NAME(1..SIZE) );

          exit when LOCAL_COPY_OF_NAMES.PREVIOUS_NAME = NULL;
          LOCAL_COPY_OF_NAMES := LOCAL_COPY_OF_NAMES.PREVIOUS_NAME;
        end loop;
     end if;

     LOCAL_COPY_OF_COMMANDS := LOCAL_COPY_OF_RULES.RULE.COMMANDS;

     -- loop through COMMANDS
     if LOCAL_COPY_OF_COMMANDS = NULL then
        PUT_LINE( DUMP_OUTPUT, "COMMANDS is NULL.");
     else
        loop
          PUT( DUMP_OUTPUT, "COMMAND: ");
          SIZE := STR_PACK.LENGTH( LOCAL_COPY_OF_COMMANDS.COMMAND );
          STR_PACK.CONVERT_TO_STRING(LOCAL_COPY_OF_COMMANDS.COMMAND,
                                     TEMP_COMMAND(1..SIZE) );
          PUT_LINE ( DUMP_OUTPUT, TEMP_COMMAND(1..SIZE) );

          exit when LOCAL_COPY_OF_COMMANDS.PREVIOUS_COMMAND = NULL;
          LOCAL_COPY_OF_COMMANDS := LOCAL_COPY_OF_COMMANDS.PREVIOUS_COMMAND;
        end loop;
     end if;

     exit when LOCAL_COPY_OF_RULES.PREVIOUS_RULE = NULL;
     LOCAL_COPY_OF_RULES := LOCAL_COPY_OF_RULES.PREVIOUS_RULE;
   end loop;
 end LOOP_THRU_RULES;

begin

  NEW_LINE ( DUMP_OUTPUT ); NEW_LINE ( DUMP_OUTPUT );
  PUT_LINE ( DUMP_OUTPUT,"AST GRAPH DUMP BY NAME VALUE");
  NEW_LINE ( DUMP_OUTPUT );

  loop
    NEW_LINE ( DUMP_OUTPUT );  NEW_LINE ( DUMP_OUTPUT );
    NEW_LINE ( DUMP_OUTPUT );
    PUT( DUMP_OUTPUT, "NAME_LINK.NAME_VALUE: ");
    SIZE := STR_PACK.LENGTH( NAME_LINK.NAME_VALUE );
    STR_PACK.CONVERT_TO_STRING(NAME_LINK.NAME_VALUE, TEMP_NAME(1..SIZE) );
    PUT_LINE ( DUMP_OUTPUT, TEMP_NAME(1..SIZE) );

    if NAME_LINK.DEFINING_RULES = NULL then
      PUT_LINE ( DUMP_OUTPUT, "DEFINING_RULES is NULL.");
    else
      NEW_LINE ( DUMP_OUTPUT );
      PUT_LINE( DUMP_OUTPUT,
                "These are the CO_LINE_NUMBERs, TARGETS, DEPENDENTS,");
      PUT_LINE( DUMP_OUTPUT,
                " and COMMANDS for each rule where NAME_VALUE is defined.");

      LOOP_THRU_RULES ( NAME_LINK.DEFINING_RULES );

    end if; -- if NAME_LINK.DEFINING_RULES = NULL

    if NAME_LINK.DEPENDENT_RULES = NULL then
      PUT_LINE( DUMP_OUTPUT, "DEPENDENT_RULES is NULL.");
    else
      NEW_LINE ( DUMP_OUTPUT );
      PUT_LINE( DUMP_OUTPUT,
                "These are the CO_LINE_NUMBERs, TARGETS, DEPENDENTS,");
      PUT_LINE( DUMP_OUTPUT,
                " and COMMANDS for each rule where NAME_VALUE is dependent.");

      LOOP_THRU_RULES ( NAME_LINK.DEPENDENT_RULES );

    end if;
    exit when NAME_LINK.PREVIOUS_NAME_BLOCK = NULL;
    NAME_LINK := NAME_LINK.PREVIOUS_NAME_BLOCK;

  end loop; -- On the whole NAME_LIST


end DUMP_AST_GRAPH;


end AST_GRAPH;

--::::::::::::::
--bld_graph.text
--::::::::::::::
-- This package consists of a single procedure which controls building of the
-- data structure containing the dependency graph upon which the processing
-- of CONSTRUCT is based.  The main loop reads one line from the co_file and
-- then calls routines in BLD_LST to build target, dependent, and command lists.
-- Note that BLD_LST also reads from the co_file.
package BLD_GRAPH is
   procedure BUILD;
end BLD_GRAPH;


with BLD_LST, AST_GRAPH, STR_PACK, TEXT_IO, ARGUMENTS;
use TEXT_IO;
package body BLD_GRAPH is

    procedure BUILD is

      TYPE_OF_LIST : BLD_LST.LIST_TYPE;

    begin

    -- Create a null name block for use in BLD_LST.BUILD_LIST.
    -- BLD_LST.DELETE_NULL_NAME_BLOCK will get rid of it to prepare for
    -- Construction processing.  Construction processing expects the NAME_VALUE
    -- to contain a real TOKEN and the PREVIOUS_NAME_BLOCK will
    -- be null.  However, it is easier in BLD_LST.BUILD_LIST to use
    -- a null name block where the NAME_VALUE is empty.

    AST_GRAPH.NAME_LIST := new AST_GRAPH.NAME_BLOCK;

    -- The input file, CO_FILE, is already opened in package ARGUMENTS.
    -- Must create the output file for dumping the tree.
    if ARGUMENTS.IS_SET( ARGUMENTS.DUMP_TREE ) then
       CREATE( BLD_LST.DUMP_OUTPUT, OUT_FILE, "DUMP_OUTPUT");
    end if;

    loop
       GET_LINE ( ARGUMENTS.CO_FILE, BLD_LST.CO_LINE, BLD_LST.LAST_CHAR );
       STR_PACK.CONVERT_TO_DYNAMIC
         (BLD_LST.CO_LINE(BLD_LST.CO_LINE'FIRST..BLD_LST.LAST_CHAR),
          AST_GRAPH.CO_LINE);
       BLD_LST.CO_LINE_COUNT := BLD_LST.CO_LINE_COUNT + 1;
       TYPE_OF_LIST := BLD_LST.TARGETS;
       BLD_LST.BUILD_LIST( TYPE_OF_LIST  );
       TYPE_OF_LIST := BLD_LST.DEPENDENTS;
       BLD_LST.BUILD_LIST( TYPE_OF_LIST );
       BLD_LST.BUILD_CMD_LIST;
    end loop;  --  Until END_ERROR is raised.

    exception
       when END_ERROR =>
          CLOSE ( ARGUMENTS.CO_FILE );
          BLD_LST.DELETE_NULL_NAME_BLOCK;
          if ARGUMENTS.IS_SET( ARGUMENTS.DUMP_TREE ) then
             AST_GRAPH.DUMP_AST_GRAPH(BLD_LST.DUMP_OUTPUT);
          end if;
          if IS_OPEN ( BLD_LST.DUMP_OUTPUT ) then
             CLOSE ( BLD_LST.DUMP_OUTPUT );
          end if;
   end BUILD;

end BLD_GRAPH;

--::::::::::::::
--bld_lst.text
--::::::::::::::
-- This package contains the routines which process the co_file and create the
-- linked lists of dynamic data which constitute the central data structure of
-- CONSTRUCT.  It is closely tied to BLD_GRAPH.
with AST_GRAPH, ENVIRONS;
with TEXT_IO; use TEXT_IO;
package BLD_LST is
  DUMP_OUTPUT    : FILE_TYPE;
  LAST_CHAR      : NATURAL;
  CO_LINE_COUNT  : INTEGER  := 0;
  CO_LINE        : STRING(1..ENVIRONS.MAX_LINE_LENGTH);

   type LIST_TYPE is ( TARGETS, DEPENDENTS );
   procedure BUILD_LIST( TYPE_OF_LIST : in LIST_TYPE );
   procedure BUILD_CMD_LIST;
   procedure ADD_RULE_LIST_TO_NAME_BLOCK
             ( LOCAL_LINK_TO_LIST_OF_RULES :
               in out AST_GRAPH.LINK_TO_LIST_OF_RULES );
   procedure ADD_NAME_LIST_TO_RULE_DESCRIPTION
             ( LOCAL_LINK_TO_LIST_OF_NAMES :
               in out AST_GRAPH.LINK_TO_LIST_OF_NAMES );
   procedure ADD_NAME_BLOCK( TYPE_OF_LIST : in LIST_TYPE );
   procedure DELETE_NULL_NAME_BLOCK;

end BLD_LST;



with STR_PACK, ARGUMENTS;
use STR_PACK;
package body BLD_LST is

   TOKEN : STR_PACK.DYNAMIC_STRING;
   TERMINATOR : CHARACTER;
   TERMINATOR_FOR_LIST : CHARACTER;

   -- This procedure processes a list of either target or dependent names as
   -- indicated by the input parameter.  For target lists, a new rule
   -- description is initiated.  For both types of lists, the name block is
   -- searched for a match. On matches, rule list is added in the appropriate
   -- field of the name_block.  When no match occurs, a new name block entry
   -- is created and properly linked.  Comments are ignored; new lines are read
   -- when a continuation mark is encountered; and processing halts when the
   -- terminator character ( ':' or ';') for the list is found.
   procedure BUILD_LIST ( TYPE_OF_LIST : in LIST_TYPE ) is
   begin
      AST_GRAPH.NAME_LINK := AST_GRAPH.NAME_LIST;

      if TYPE_OF_LIST = TARGETS then
         AST_GRAPH.NEW_RULE_DESCRIPTION := new AST_GRAPH.RULE_DESCRIPTION;
         AST_GRAPH.NEW_RULE_DESCRIPTION.CO_LINE_NUMBER := CO_LINE_COUNT;
         TERMINATOR_FOR_LIST := ENVIRONS.TARGET_LIST_TERMINATOR;
      else
         TERMINATOR_FOR_LIST := ENVIRONS.DEPENDENT_LIST_TERMINATOR;
      end if;

      loop
         STR_PACK.GET_TOKEN ( AST_GRAPH.CO_LINE, TOKEN, TERMINATOR );
         loop
            if STR_PACK.EMPTY( TOKEN ) then -- Occurs when the CO line starts
               exit;                        -- with a comment. That is, TOKEN
            end if;                         -- is EMPTY and TERMINATOR is '-'.

            if TOKEN = AST_GRAPH.NAME_LINK.NAME_VALUE then
               if TYPE_OF_LIST = TARGETS then
                  ADD_RULE_LIST_TO_NAME_BLOCK
                             ( AST_GRAPH.NAME_LINK.DEFINING_RULES );
                  ADD_NAME_LIST_TO_RULE_DESCRIPTION
                             ( AST_GRAPH.NEW_RULE_DESCRIPTION.TARGETS );
               else -- TYPE_OF_LIST = DEPENDENTS
                  ADD_RULE_LIST_TO_NAME_BLOCK
                             ( AST_GRAPH.NAME_LINK.DEPENDENT_RULES );
                  ADD_NAME_LIST_TO_RULE_DESCRIPTION
                             ( AST_GRAPH.NEW_RULE_DESCRIPTION.DEPENDENTS );
               end if;

               -- Reset AST_GRAPH.NAME_LINK to
               -- the end of the list of name blocks.

               AST_GRAPH.NAME_LINK := AST_GRAPH.NAME_LIST;
               exit;
            end if;

            if AST_GRAPH.NAME_LINK.PREVIOUS_NAME_BLOCK = null then
               ADD_NAME_BLOCK( TYPE_OF_LIST );
               if TYPE_OF_LIST = TARGETS then
                  ADD_NAME_LIST_TO_RULE_DESCRIPTION
                             ( AST_GRAPH.NEW_RULE_DESCRIPTION.TARGETS );
               else -- TYPE_OF_LIST = DEPENDENTS
                  ADD_NAME_LIST_TO_RULE_DESCRIPTION
                             ( AST_GRAPH.NEW_RULE_DESCRIPTION.DEPENDENTS );
               end if;

               -- Reset AST_GRAPH.NAME_LIST to the end of the
               -- list of name blocks.
               AST_GRAPH.NAME_LIST := AST_GRAPH.NAME_LINK;

               exit;
             end if;

             AST_GRAPH.NAME_LINK := AST_GRAPH.NAME_LINK.PREVIOUS_NAME_BLOCK;

          end loop;

       if TERMINATOR = ENVIRONS.COMMENT  or
          TERMINATOR = ENVIRONS.CONTINUATION then
             GET_LINE ( ARGUMENTS.CO_FILE, CO_LINE, LAST_CHAR);
             STR_PACK.CONVERT_TO_DYNAMIC
                    (CO_LINE(CO_LINE'FIRST..LAST_CHAR), AST_GRAPH.CO_LINE);
             CO_LINE_COUNT := CO_LINE_COUNT + 1;
        end if;

        exit when TERMINATOR = TERMINATOR_FOR_LIST;

      end loop;

end BUILD_LIST;


-- This procedure is called after AST_GRAPH has been built. It removes the null
-- name block entry which was created for ease of processing during creation of
-- AST_GRAPH.
procedure DELETE_NULL_NAME_BLOCK is
begin
    -- Get rid of null Name Block at top of name list
    while AST_GRAPH.NAME_LINK.PREVIOUS_NAME_BLOCK /= null loop
      AST_GRAPH.NAME_LINK := AST_GRAPH.NAME_LINK.PREVIOUS_NAME_BLOCK;
    end loop;

    AST_GRAPH.NAME_LINK := AST_GRAPH.NAME_LINK.NEXT_NAME_BLOCK;
    AST_GRAPH.NAME_LINK.PREVIOUS_NAME_BLOCK := null;
    AST_GRAPH.NAME_LINK := AST_GRAPH.NAME_LIST;

end DELETE_NULL_NAME_BLOCK;


-- This procedure copies source lines one at a time from co_file into a
-- linked list of commads pointed to by the current rule description.
-- The procedure terminates when a command list termination character
-- (nominally, a '$') is found.
procedure BUILD_CMD_LIST is
   NEW_COMMAND : AST_GRAPH.LINK_TO_LIST_OF_COMMANDS;
   CHAR        : CHARACTER;

   begin
      loop
         GET_LINE ( ARGUMENTS.CO_FILE, CO_LINE, LAST_CHAR );
         STR_PACK.CONVERT_TO_DYNAMIC
             (CO_LINE(CO_LINE'FIRST..LAST_CHAR), AST_GRAPH.CO_LINE );
         CO_LINE_COUNT := CO_LINE_COUNT + 1;
         STR_PACK.READ( CHAR, AST_GRAPH.CO_LINE );
         exit when CHAR = ENVIRONS.END_OF_COMMANDS;

         if AST_GRAPH.NEW_RULE_DESCRIPTION.COMMANDS /= null then
          NEW_COMMAND               := new AST_GRAPH.LIST_OF_COMMANDS;
          NEW_COMMAND.PREVIOUS_COMMAND :=
             AST_GRAPH.NEW_RULE_DESCRIPTION.COMMANDS;
          STR_PACK.ASSIGN(NEW_COMMAND.COMMAND, AST_GRAPH.CO_LINE);
          NEW_COMMAND.NEXT_COMMAND  := null;
          AST_GRAPH.NEW_RULE_DESCRIPTION.COMMANDS.NEXT_COMMAND := NEW_COMMAND;
          AST_GRAPH.NEW_RULE_DESCRIPTION.COMMANDS := NEW_COMMAND;
         else
          NEW_COMMAND               := new AST_GRAPH.LIST_OF_COMMANDS;
          NEW_COMMAND.PREVIOUS_COMMAND:= null;
          STR_PACK.ASSIGN(NEW_COMMAND.COMMAND, AST_GRAPH.CO_LINE);
          NEW_COMMAND.NEXT_COMMAND  := null;
          AST_GRAPH.NEW_RULE_DESCRIPTION.COMMANDS := NEW_COMMAND;
          AST_GRAPH.NEW_RULE_DESCRIPTION.TOP_OF_COMMANDS := NEW_COMMAND;
         end if;

      end loop;

   end BUILD_CMD_LIST;


-- This procedure adds a pointer to the current rule description to the list
-- of rules which is passed in.  If the list is null, the new rule is
-- properly added at the head.
procedure ADD_RULE_LIST_TO_NAME_BLOCK
          ( LOCAL_LINK_TO_LIST_OF_RULES : in out
            AST_GRAPH.LINK_TO_LIST_OF_RULES )      is

   begin
      if LOCAL_LINK_TO_LIST_OF_RULES /= null then
         LOCAL_LINK_TO_LIST_OF_RULES.NEXT_RULE :=
           new AST_GRAPH.LIST_OF_RULES'(LOCAL_LINK_TO_LIST_OF_RULES,
                                        AST_GRAPH.NEW_RULE_DESCRIPTION, null );
         LOCAL_LINK_TO_LIST_OF_RULES := LOCAL_LINK_TO_LIST_OF_RULES.NEXT_RULE;
      else
         LOCAL_LINK_TO_LIST_OF_RULES :=
           new AST_GRAPH.LIST_OF_RULES'(null,
                                        AST_GRAPH.NEW_RULE_DESCRIPTION, null);
      end if;

   end ADD_RULE_LIST_TO_NAME_BLOCK;


-- This procedure adds the current name link to a list of names within a rule
-- description.  If the list of names which is passed in is null,  the current
-- name is properly added at the head of the list.
procedure ADD_NAME_LIST_TO_RULE_DESCRIPTION
          ( LOCAL_LINK_TO_LIST_OF_NAMES :
               in out AST_GRAPH.LINK_TO_LIST_OF_NAMES ) is
   begin

      -- LOCAL_LINK_TO_LIST_OF_NAMES may be .TARGETS or .DEPENDENTS
      if LOCAL_LINK_TO_LIST_OF_NAMES /= null then
         LOCAL_LINK_TO_LIST_OF_NAMES.NEXT_NAME :=
           new AST_GRAPH.LIST_OF_NAMES;
         LOCAL_LINK_TO_LIST_OF_NAMES.NEXT_NAME.PREVIOUS_NAME :=
                 LOCAL_LINK_TO_LIST_OF_NAMES;
         LOCAL_LINK_TO_LIST_OF_NAMES.NEXT_NAME.NAME :=
                 AST_GRAPH.NAME_LINK;
         LOCAL_LINK_TO_LIST_OF_NAMES.NEXT_NAME.NEXT_NAME := null;
         LOCAL_LINK_TO_LIST_OF_NAMES := LOCAL_LINK_TO_LIST_OF_NAMES.NEXT_NAME;
      else
         LOCAL_LINK_TO_LIST_OF_NAMES :=
           new AST_GRAPH.LIST_OF_NAMES;
         LOCAL_LINK_TO_LIST_OF_NAMES.PREVIOUS_NAME := null;
         LOCAL_LINK_TO_LIST_OF_NAMES.NAME :=
                 AST_GRAPH.NAME_LINK;
         LOCAL_LINK_TO_LIST_OF_NAMES.NEXT_NAME := null;
      end if;

   end ADD_NAME_LIST_TO_RULE_DESCRIPTION;


-- This procedure adds a new name block to the list of name blocks.  The name
-- field is set and either a target or dependent rule pointer is set, depending
-- on the part of the dependency rule being processed.
procedure ADD_NAME_BLOCK ( TYPE_OF_LIST : in LIST_TYPE ) is

   begin
      AST_GRAPH.NAME_LINK := new AST_GRAPH.NAME_BLOCK;
      AST_GRAPH.NAME_LINK.PREVIOUS_NAME_BLOCK := AST_GRAPH.NAME_LIST;
      AST_GRAPH.NAME_LIST.NEXT_NAME_BLOCK := AST_GRAPH.NAME_LINK;
      STR_PACK.ASSIGN( AST_GRAPH.NAME_LINK.NAME_VALUE, TOKEN );
      if TYPE_OF_LIST = TARGETS then
         AST_GRAPH.NAME_LINK.DEFINING_RULES :=
           new AST_GRAPH.LIST_OF_RULES'
             (null, AST_GRAPH.NEW_RULE_DESCRIPTION, null);
      else -- TYPE_OF_LIST = DEPENDENTS
         AST_GRAPH.NAME_LINK.DEPENDENT_RULES :=
           new AST_GRAPH.LIST_OF_RULES'
             (null, AST_GRAPH.NEW_RULE_DESCRIPTION, null);
      end if;

      AST_GRAPH.NAME_LIST := AST_GRAPH.NAME_LINK;
   end ADD_NAME_BLOCK;


end BLD_LST;

--::::::::::::::
--calendar.text
--::::::::::::::

package CALENDAR is

    subtype TIME is  LONG_INTEGER;

end CALENDAR;

--::::::::::::::
--con_proc.text
--::::::::::::::
pragma SOURCE_INFO(ON);

package CON_PROC is

   procedure CONSTRUCTION_PROCESSING;

end CON_PROC;


-----------------------------------------------------------------
--           Package Body
-----------------------------------------------------------------

with TEXT_IO; use TEXT_IO, INTEGER_IO;
with HOST;
with AST_GRAPH;
with STR_PACK; use STR_PACK;
with CALENDAR;
with ENVIRONS;
with ARGUMENTS;

package body CON_PROC is

      NO_CYCLES : BOOLEAN := TRUE;
      VIOLATORS            : AST_GRAPH.LINK_TO_LIST_OF_NAMES;
      CYCLE_NUMBER         : INTEGER := 1;
      DUMP_IT              : STRING(1..14);


-------------------------------------------------------------------
--   Package PROCESSING_INTERNALS is an internal package, used only
--   by the procedure CONSTRUCTION_PROCESSING. The subprograms in
--   this package are isolated in a sub-package simply to avoid
--   a large number of nested subprograms inside the procedure
--   CONSTRUCTION_PROCESSING.
--
--   "Still needed":
--
--   1) The procedures in this package make heavy use of access types
--      and allocators (x := new wazoo...). There is no mechanism for
--      storage reclamation. Instead of performing an allocation each
--      time a new value is required, a list of objects should be
--      maintained, marked "free" or "used".  When a new object is
--      required, the appropriate list would first be searched, to
--      see if a free object was available. If so, it is marked
--      used, and the new values put in. The access type object that
--      "points" to this object would be given the location of this
--      object as its value.  If no free objects are available, a
--      new one is allocated and linked into the list of free and
--      used objects.
--
--   2) The use of the datat structure "NAME_BLOCK_LIST" is
--      redundant; the data structure AST_GRAPH.LIST_OF_NAMES
--      would serve equally well.

      package PROCESSING_INTERNALS is

         type RELEVANT_RULE_LIST;
         type LINK_TO_RELEVANT_RULE_LIST is access RELEVANT_RULE_LIST;
         type RELEVANT_RULE_LIST is
            record
               NEXT, PREVIOUS : LINK_TO_RELEVANT_RULE_LIST;
               RULE           : AST_GRAPH.LINK_TO_RULE_DESCRIPTION;
            end record;

         type NAME_BLOCK_LIST;
         type LINK_TO_NAME_BLOCK_LIST is access NAME_BLOCK_LIST;
         type NAME_BLOCK_LIST is    -- This will be changed, to faciliate
            record                  -- storage reclamation.
               NEXT, PREVIOUS : LINK_TO_NAME_BLOCK_LIST;
               NAME           : AST_GRAPH.LINK_TO_NAME_BLOCK;
            end record;



         procedure INITIALIZE_ALL_PROCESSING_DATA_STRUCTURES;

         procedure PLACE_ALL_TARGETS_IN_NAME_BLOCK_QUEUE;

         function NAME_BLOCK_QUEUE_IS_NOT_EMPTY return BOOLEAN;

         function NEXT_NAME_BLOCK_ON_QUEUE return
               AST_GRAPH.LINK_TO_NAME_BLOCK;

         function LIST_OF_DEFINING_RULES
               (NAME : in AST_GRAPH.LINK_TO_NAME_BLOCK)
                return AST_GRAPH.LINK_TO_LIST_OF_RULES;

         function THERE_IS_ANOTHER_RULE
               (RULE_LIST : in AST_GRAPH.LINK_TO_LIST_OF_RULES)
               return BOOLEAN;

         function RELEVANT_RULE_STACK_IS_NOT_EMPTY
               return BOOLEAN;

         function NEXT_RULE
               (RULE_LIST : in AST_GRAPH.LINK_TO_LIST_OF_RULES)
               return AST_GRAPH.LINK_TO_LIST_OF_RULES;

         function NEXT_RELEVANT_RULE_ON_QUEUE
             return AST_GRAPH.LINK_TO_RULE_DESCRIPTION;

         procedure ADD_TO_RELEVANT_RULE_STACK
               (NEW_RULE  : in AST_GRAPH.LINK_TO_RULE_DESCRIPTION);

         procedure ADD_DEPENDENTS_TO_NAME_BLOCK_QUEUE
               (RULE : in AST_GRAPH.LINK_TO_RULE_DESCRIPTION);

         function TIMESTAMPS_OUT_OF_SEQUENCE
               (RULE : in AST_GRAPH.LINK_TO_RULE_DESCRIPTION)
               return BOOLEAN ;

         procedure EXECUTE_THE_COMMAND_LIST
               (CMD_LIST : in AST_GRAPH.LINK_TO_LIST_OF_COMMANDS);

         procedure TOUCH_ALL_TARGETS
             (RULE : in AST_GRAPH.LINK_TO_RULE_DESCRIPTION);

        procedure PUT_DYNAMIC_STRING (DSTRING : in DYNAMIC_STRING);


   end PROCESSING_INTERNALS; -- end of package spec


   package body PROCESSING_INTERNALS is


      RELEVANT_RULE_STACK   : LINK_TO_RELEVANT_RULE_LIST;
      NAME_BLOCK_QUEUE      : LINK_TO_NAME_BLOCK_LIST;


      procedure PUT_DYNAMIC_STRING (DSTRING : in DYNAMIC_STRING) is
        TMP : STRING (1 .. LENGTH(DSTRING) );
      begin
        CONVERT_TO_STRING (DSTRING,TMP);
        PUT(TMP);
      end PUT_DYNAMIC_STRING;



      procedure INITIALIZE_ALL_PROCESSING_DATA_STRUCTURES is

          TMP_NAME_BLOCK  : AST_GRAPH.LINK_TO_NAME_BLOCK;

      begin

          RELEVANT_RULE_STACK  := null;
          NAME_BLOCK_QUEUE := null;

          TMP_NAME_BLOCK := AST_GRAPH.NAME_LIST;

          while TMP_NAME_BLOCK.PREVIOUS_NAME_BLOCK /= null loop
             TMP_NAME_BLOCK.TOUCHED := FALSE;
             TMP_NAME_BLOCK := TMP_NAME_BLOCK.PREVIOUS_NAME_BLOCK;
          end loop;

          TMP_NAME_BLOCK.TOUCHED := FALSE;

      end INITIALIZE_ALL_PROCESSING_DATA_STRUCTURES;



      procedure PLACE_ALL_TARGETS_IN_NAME_BLOCK_QUEUE is
          TMP_NAME_BLOCK      : AST_GRAPH.LINK_TO_NAME_BLOCK;
          TMP_TARGET_ARG, GOAL  : STR_PACK.DYNAMIC_STRING;
          SEP                 : CHARACTER;

      begin

          if STR_PACK.LENGTH (ARGUMENTS.TARGET_ARG) = 0 then -- default goal
             TMP_NAME_BLOCK := AST_GRAPH.NAME_LIST;

             while TMP_NAME_BLOCK.PREVIOUS_NAME_BLOCK /= null loop
                TMP_NAME_BLOCK := TMP_NAME_BLOCK.PREVIOUS_NAME_BLOCK;
             end loop;

             NAME_BLOCK_QUEUE := new NAME_BLOCK_LIST;
             NAME_BLOCK_QUEUE.NAME := TMP_NAME_BLOCK;

          else   -- NOT default goal, 1 or more given...

             STR_PACK.ASSIGN (TMP_TARGET_ARG,STR_PACK.EMPTY_STR);
             STR_PACK.ASSIGN (TMP_TARGET_ARG,ARGUMENTS.TARGET_ARG);

             loop   -- Until an invalid Goal or end of list...
                GET_TOKEN (TMP_TARGET_ARG, GOAL, SEP);

                TMP_NAME_BLOCK := AST_GRAPH.NAME_LIST;

                while TMP_NAME_BLOCK.PREVIOUS_NAME_BLOCK /= null loop
                   exit when TMP_NAME_BLOCK.NAME_VALUE = GOAL;
                   TMP_NAME_BLOCK := TMP_NAME_BLOCK.PREVIOUS_NAME_BLOCK;
                end loop;

                if GOAL /= TMP_NAME_BLOCK.NAME_VALUE then
                   NEW_LINE;
                   PUT("CONSTRUCT: ");
                   PUT_DYNAMIC_STRING (GOAL);
                   PUT_LINE(" is NOT a valid target in the CO.");
                   NEW_LINE;
                   raise ENVIRONS.ERROR;
                end if;

                if NAME_BLOCK_QUEUE = null then
                   NAME_BLOCK_QUEUE := new NAME_BLOCK_LIST;
                   NAME_BLOCK_QUEUE.NAME := TMP_NAME_BLOCK;
                else
                   NAME_BLOCK_QUEUE.PREVIOUS := new NAME_BLOCK_LIST;
                   NAME_BLOCK_QUEUE.PREVIOUS.NAME := TMP_NAME_BLOCK;
                   NAME_BLOCK_QUEUE.PREVIOUS.NEXT := NAME_BLOCK_QUEUE;
                   NAME_BLOCK_QUEUE := NAME_BLOCK_QUEUE.PREVIOUS;
                end if; -- NAME_BLOCK_QUEUE = null


             end loop; -- Until an invalid Goal or end of list...

          end if;  -- if STR_PACK.LENGTH (TMP_TARGET_ARG) = 0

      exception

         when STR_PACK.END_OF_STRING =>
            null; -- End of TARGET_ARG list was found
         when others =>  -- Invalid Goal or unknown trouble...
            raise;

      end PLACE_ALL_TARGETS_IN_NAME_BLOCK_QUEUE;


      function NAME_BLOCK_QUEUE_IS_NOT_EMPTY return BOOLEAN is
      begin
         return (NAME_BLOCK_QUEUE /= null);
      end NAME_BLOCK_QUEUE_IS_NOT_EMPTY ;


      function NEXT_NAME_BLOCK_ON_QUEUE return

         AST_GRAPH.LINK_TO_NAME_BLOCK is
         TMP : LINK_TO_NAME_BLOCK_LIST;

      begin

          TMP := NAME_BLOCK_QUEUE;

          while TMP.NEXT /= null loop -- Find end of queue
             TMP := TMP.NEXT;
          end loop;

          if TMP.PREVIOUS /= null then
             TMP.PREVIOUS.NEXT := null; -- Remove the last entry on the queue
          else  --last entry in queue
             NAME_BLOCK_QUEUE := null;
          end if;

          return TMP.NAME;

      end NEXT_NAME_BLOCK_ON_QUEUE;


      function LIST_OF_DEFINING_RULES
             (NAME : in AST_GRAPH.LINK_TO_NAME_BLOCK)
              return AST_GRAPH.LINK_TO_LIST_OF_RULES is

         TMP : AST_GRAPH.LINK_TO_LIST_OF_RULES;

      begin

         TMP := new AST_GRAPH.LIST_OF_RULES;
         TMP.all := NAME.DEFINING_RULES.all;
         return TMP;

      end LIST_OF_DEFINING_RULES;


      function THERE_IS_ANOTHER_RULE
            (RULE_LIST : in AST_GRAPH.LINK_TO_LIST_OF_RULES)
            return BOOLEAN is

      begin

         return (RULE_LIST /= null  and then
                 RULE_LIST.PREVIOUS_RULE /= null);

      end THERE_IS_ANOTHER_RULE;



      function RELEVANT_RULE_STACK_IS_NOT_EMPTY
            return BOOLEAN is
      begin
         return RELEVANT_RULE_STACK /= null;
      end RELEVANT_RULE_STACK_IS_NOT_EMPTY;



      function NEXT_RELEVANT_RULE_ON_QUEUE
             return AST_GRAPH.LINK_TO_RULE_DESCRIPTION is
         TMP : LINK_TO_RELEVANT_RULE_LIST;
      begin
         TMP := RELEVANT_RULE_STACK;
         if RELEVANT_RULE_STACK.NEXT = null then  -- only one on queue
            RELEVANT_RULE_STACK := null;
         else
            -- Remove this rule from queue
            RELEVANT_RULE_STACK := RELEVANT_RULE_STACK.NEXT;
            RELEVANT_RULE_STACK.PREVIOUS := null;
         end if;

         return TMP.RULE;
      end NEXT_RELEVANT_RULE_ON_QUEUE;


      function NEXT_RULE
            (RULE_LIST : in AST_GRAPH.LINK_TO_LIST_OF_RULES)
            return AST_GRAPH.LINK_TO_LIST_OF_RULES is
         TMP : AST_GRAPH.LINK_TO_LIST_OF_RULES;
      begin
         TMP := new AST_GRAPH.LIST_OF_RULES;
         TMP.all := RULE_LIST.PREVIOUS_RULE.all;  -- Change to NEXT_RULE
         return TMP;                   -- when AST_GRAPH changes
      end NEXT_RULE;


      procedure ADD_TO_RELEVANT_RULE_STACK
            (NEW_RULE  : in AST_GRAPH.LINK_TO_RULE_DESCRIPTION) is

        TMP : LINK_TO_RELEVANT_RULE_LIST;
        NEW_RULE_LIST : LINK_TO_RELEVANT_RULE_LIST;
      begin
         if RELEVANT_RULE_STACK = null then  -- First entry in list...
            RELEVANT_RULE_STACK := new RELEVANT_RULE_LIST;
            RELEVANT_RULE_STACK.RULE := new AST_GRAPH.RULE_DESCRIPTION;
            RELEVANT_RULE_STACK.RULE.all  := NEW_RULE.all;
         else
            NEW_RULE_LIST := new RELEVANT_RULE_LIST; --Insert at head of queue
            RELEVANT_RULE_STACK.PREVIOUS := NEW_RULE_LIST;
            NEW_RULE_LIST.RULE := new AST_GRAPH.RULE_DESCRIPTION;
            NEW_RULE_LIST.RULE.all  := NEW_RULE.all;
            NEW_RULE_LIST.NEXT := RELEVANT_RULE_STACK;
            RELEVANT_RULE_STACK := NEW_RULE_LIST;

            -- If this rule was already on the queue, unlink the
            -- earlier entry.
                 TMP := RELEVANT_RULE_STACK.NEXT;

                 while TMP /= null loop
                    if TMP.RULE.CO_LINE_NUMBER = NEW_RULE.CO_LINE_NUMBER then
                       TMP.PREVIOUS.NEXT := TMP.NEXT;
                       if TMP.NEXT /= null then -- If not at end of queue
                          TMP.NEXT.PREVIOUS := TMP.PREVIOUS;
                       end if;
                       exit;
                    end if;
                  TMP := TMP.NEXT;
               end loop;   -- while TMP /= null

         end if;  -- RELEVANT_RULE_STACK.RULE = null

      end ADD_TO_RELEVANT_RULE_STACK;


      procedure ADD_TO_NAME_BLOCK_QUEUE
            (NAME_BLOCK  : in AST_GRAPH.LINK_TO_NAME_BLOCK) is

         NEW_NAME_BLOCK  : LINK_TO_NAME_BLOCK_LIST;
      begin
         if NAME_BLOCK_QUEUE = null then
            NAME_BLOCK_QUEUE := new NAME_BLOCK_LIST;
            NAME_BLOCK_QUEUE.NAME := NAME_BLOCK;
         else
            NEW_NAME_BLOCK := new NAME_BLOCK_LIST;
            NAME_BLOCK_QUEUE.PREVIOUS := NEW_NAME_BLOCK;
            NEW_NAME_BLOCK.NAME := NAME_BLOCK;
            NEW_NAME_BLOCK.NEXT := NAME_BLOCK_QUEUE;
            NAME_BLOCK_QUEUE := NEW_NAME_BLOCK;
         end if;
      end ADD_TO_NAME_BLOCK_QUEUE;


      procedure ADD_DEPENDENTS_TO_NAME_BLOCK_QUEUE
            (RULE : in AST_GRAPH.LINK_TO_RULE_DESCRIPTION) is
         DEPENDENTS_LIST  : AST_GRAPH.LINK_TO_LIST_OF_NAMES;
      begin
         DEPENDENTS_LIST := new AST_GRAPH.LIST_OF_NAMES;
         DEPENDENTS_LIST.all := RULE.DEPENDENTS.all;
         while DEPENDENTS_LIST /= null loop
            ADD_TO_NAME_BLOCK_QUEUE (DEPENDENTS_LIST.NAME);
            DEPENDENTS_LIST := DEPENDENTS_LIST.PREVIOUS_NAME; -- Change to
                        --.NEXT_NAME when AST_GRAPH is changed.
            end loop;
      end ADD_DEPENDENTS_TO_NAME_BLOCK_QUEUE;

      function TIMESTAMPS_OUT_OF_SEQUENCE
            (RULE : in AST_GRAPH.LINK_TO_RULE_DESCRIPTION)
            return BOOLEAN is
         TARGET_LIST, DEPENDENT_LIST : AST_GRAPH.LINK_TO_LIST_OF_NAMES;
         OLDEST_TARGET : CALENDAR.TIME;
         OUT_OF_SEQUENCE : BOOLEAN := FALSE;
         RETURN_TRUE     : exception;

      begin

         -- Determine the "oldest" of the targets for this rule
         TARGET_LIST := new AST_GRAPH.LIST_OF_NAMES;
         TARGET_LIST.all := RULE.TARGETS.all;

         begin  -- block statement used here to trap exceptions
            OLDEST_TARGET := HOST.MODIFICATION_TIMESTAMP
                            (TARGET_LIST.NAME.NAME_VALUE);
         exception
            when HOST.ACCESSIBILITY_ERROR =>
               -- This is not an error, but the rule clearly must be "fired"
               raise RETURN_TRUE;
            when others =>
               PUT("CONSTRUCT: Error while trying to access ");
               PUT_DYNAMIC_STRING(TARGET_LIST.NAME.NAME_VALUE);
               NEW_LINE;
               raise ENVIRONS.ERROR;
         end;  -- of block statement used to trap exceptions

         TARGET_LIST := TARGET_LIST.PREVIOUS_NAME;

         while TARGET_LIST /= null loop

               begin  -- block statement used here to trap exceptions

               if HOST.MODIFICATION_TIMESTAMP (TARGET_LIST.NAME.NAME_VALUE)
                         < OLDEST_TARGET then
                  OLDEST_TARGET := HOST.MODIFICATION_TIMESTAMP
                                (TARGET_LIST.NAME.NAME_VALUE);
               end if;

               exception
                  when HOST.ACCESSIBILITY_ERROR =>
                     -- This is not an error, but the rule must be "fired"
                     raise RETURN_TRUE;
                  when others =>
                     PUT("CONSTRUCT: Error while trying to access ");
                     PUT_DYNAMIC_STRING(TARGET_LIST.NAME.NAME_VALUE);
                     NEW_LINE;
                     raise ENVIRONS.ERROR;
               end;  -- of block statement used to trap exceptions


            TARGET_LIST := TARGET_LIST.PREVIOUS_NAME;
         end loop;

         -- Now see if anything is out of sequence (or "touched").

         DEPENDENT_LIST := new AST_GRAPH.LIST_OF_NAMES;
         DEPENDENT_LIST.all := RULE.DEPENDENTS.all;

         begin  -- block statement used here to trap exceptions

            if (DEPENDENT_LIST.NAME.TOUCHED  or else
               HOST.MODIFICATION_TIMESTAMP (DEPENDENT_LIST.NAME.NAME_VALUE)
                  > OLDEST_TARGET) then
                  raise RETURN_TRUE;
            end if;

         exception
            when RETURN_TRUE => raise; --"pass it on"
            -- At this point, all dependents should exist; if one
            -- does not, it is an error.
            when others =>
               PUT("CONSTRUCT: Error while trying to access ");
               PUT_DYNAMIC_STRING(DEPENDENT_LIST.NAME.NAME_VALUE);
               NEW_LINE;
               raise ENVIRONS.ERROR;
         end;  -- of block statement used to trap exceptions


         DEPENDENT_LIST := DEPENDENT_LIST.PREVIOUS_NAME;

         while (DEPENDENT_LIST /= null )  loop

         begin  -- block statement used here to trap exceptions

            if (DEPENDENT_LIST.NAME.TOUCHED  or
               HOST.MODIFICATION_TIMESTAMP (DEPENDENT_LIST.NAME.NAME_VALUE)
                  > OLDEST_TARGET) then
                  raise RETURN_TRUE;
            end if;

         exception
            when RETURN_TRUE => raise; --"pass it on"
            -- At this point, all dependents should exist; if one
            -- does not, it is an error.
            when others =>
               PUT("CONSTRUCT: Error while trying to access ");
               PUT_DYNAMIC_STRING(DEPENDENT_LIST.NAME.NAME_VALUE);
               NEW_LINE;
               raise ENVIRONS.ERROR;
         end;  -- of block statement used to trap exceptions

            DEPENDENT_LIST := DEPENDENT_LIST.PREVIOUS_NAME;
         end loop;

         -- If control gets here, all of the timestamps are in sequence
         return (FALSE);

      exception
         when RETURN_TRUE =>
            return (TRUE);
         when others =>
            raise;
      end TIMESTAMPS_OUT_OF_SEQUENCE;



      procedure EXECUTE_A_COMMAND
            (COMMAND : in STR_PACK.DYNAMIC_STRING) is
      begin
         if ARGUMENTS.IS_SET (ARGUMENTS.CMD_PRINT) then
            PUT(">>");
            PUT_DYNAMIC_STRING (COMMAND);
            NEW_LINE;
         end if;

         begin -- Block statement to catch exceptions
            HOST.EXECUTE_CMDS (COMMAND);
         exception
            when HOST.EXECUTION_ERROR =>
               NEW_LINE;
               PUT("CONSTRUCT: Error while trying to execute: ");
               PUT_DYNAMIC_STRING (COMMAND);
               NEW_LINE;
               raise ENVIRONS.ERROR;
         end; -- of block statement

      end EXECUTE_A_COMMAND;

      procedure EXECUTE_THE_COMMAND_LIST
            (CMD_LIST : in AST_GRAPH.LINK_TO_LIST_OF_COMMANDS) is
         TMP_CMD_LIST : AST_GRAPH.LINK_TO_LIST_OF_COMMANDS;
      begin

         TMP_CMD_LIST := CMD_LIST;
         while TMP_CMD_LIST /= null loop
            EXECUTE_A_COMMAND (TMP_CMD_LIST.COMMAND);
            TMP_CMD_LIST := TMP_CMD_LIST.NEXT_COMMAND;
         end loop;


      end EXECUTE_THE_COMMAND_LIST;


      procedure TOUCH_ALL_TARGETS
             (RULE : in AST_GRAPH.LINK_TO_RULE_DESCRIPTION) is
         LIST_OF_TARGETS : AST_GRAPH.LINK_TO_LIST_OF_NAMES;
         CMDS   : AST_GRAPH.LINK_TO_LIST_OF_COMMANDS;

      begin

         if ARGUMENTS.IS_SET (ARGUMENTS.CMD_PRINT) then
            CMDS := RULE.TOP_OF_COMMANDS;
            while CMDS /= null loop
              PUT(">> ");
              PUT_DYNAMIC_STRING (CMDS.COMMAND);
              NEW_LINE;
              CMDS := CMDS.NEXT_COMMAND;
            end loop;
         end if;

         LIST_OF_TARGETS := RULE.TARGETS;
         while LIST_OF_TARGETS /= null loop
            LIST_OF_TARGETS.NAME.TOUCHED := TRUE;
            LIST_OF_TARGETS := LIST_OF_TARGETS.PREVIOUS_NAME; -- Change
                      -- to NEXT_NAME when AST_GRAPH is changed.
         end loop;
      end TOUCH_ALL_TARGETS;


   end PROCESSING_INTERNALS; -- end of package body

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

use PROCESSING_INTERNALS;

      function COUNT_OF_RELATIONS
       (PARENT    : in  AST_GRAPH.LINK_TO_NAME_BLOCK)
        return INTEGER is
       COUNT        : INTEGER;
       DEPENDENT    : AST_GRAPH.LINK_TO_LIST_OF_NAMES;
       RULE         : AST_GRAPH.LINK_TO_LIST_OF_RULES;
      begin
       COUNT := 0;
       RULE  := PARENT.DEFINING_RULES;
       while RULE /= null loop
         DEPENDENT := RULE.RULE.DEPENDENTS;

         while DEPENDENT /= null loop
           COUNT      := COUNT+1;
           DEPENDENT  := DEPENDENT.PREVIOUS_NAME;
         end loop;

         RULE := RULE.PREVIOUS_RULE;
       end loop;
       return COUNT;
      end COUNT_OF_RELATIONS;



  procedure REDUCE_COUNTS_OF_PARENTS
    (USES : in  AST_GRAPH.LINK_TO_LIST_OF_RULES) is
    PARENT   : AST_GRAPH.LINK_TO_LIST_OF_NAMES;
    USE_ONE  : AST_GRAPH.LINK_TO_LIST_OF_RULES;
  begin
    USE_ONE := USES;
    while USE_ONE /= null loop
      PARENT := USE_ONE.RULE.TARGETS;
      while PARENT /= null loop
       PARENT.NAME.NUMBER_OF_DEPENDENTS := PARENT.NAME.NUMBER_OF_DEPENDENTS-1;

       if ARGUMENTS.IS_SET(ARGUMENTS.PROCESS_DUMP) then
         PUT("REDUCE  ");
         STR_PACK.CONVERT_TO_STRING(PARENT.NAME.NAME_VALUE, DUMP_IT);
         PUT(DUMP_IT); PUT(PARENT.NAME.NUMBER_OF_DEPENDENTS); NEW_LINE;
       end if;

       PARENT                           := PARENT.PREVIOUS_NAME;
      end loop;
      USE_ONE := USE_ONE.PREVIOUS_RULE;
    end loop;
  end REDUCE_COUNTS_OF_PARENTS;


  procedure REMOVE_SAFE_NAMES is
    GRAPH            : AST_GRAPH.LINK_TO_NAME_BLOCK;
    SAFE_NAMES_EXIST : BOOLEAN := TRUE;
  begin
    --Loop through the graph removing all names that have zero
    --NUMBER_OF_DEPENDENTS.  When a name is removed reduce by one
    --the NUMBER_OF_DEPENDENTS counts for all names having this
    --name as a dependent.  The loop terminates when no names are
    --removed in any given pass.  Any names not removed are part
    --of a cycle.
    while SAFE_NAMES_EXIST loop
      SAFE_NAMES_EXIST := FALSE;
      GRAPH            := AST_GRAPH.NAME_LIST;

      while GRAPH /= null loop
       if GRAPH.NUMBER_OF_DEPENDENTS = 0 then
         SAFE_NAMES_EXIST := TRUE;

         if ARGUMENTS.IS_SET(ARGUMENTS.PROCESS_DUMP) then
           PUT("REMOVE  ");
           STR_PACK.CONVERT_TO_STRING(GRAPH.NAME_VALUE, DUMP_IT);
           PUT(DUMP_IT); PUT(GRAPH.NUMBER_OF_DEPENDENTS); NEW_LINE;
         end if;

         REDUCE_COUNTS_OF_PARENTS( GRAPH.DEPENDENT_RULES );
         GRAPH.NUMBER_OF_DEPENDENTS := -1;
       end if;
       GRAPH := GRAPH.PREVIOUS_NAME_BLOCK;
      end loop;

    end loop;
  end REMOVE_SAFE_NAMES;



  procedure ADD
    (NAME  : in     AST_GRAPH.LINK_TO_NAME_BLOCK;
     LIST  : in out AST_GRAPH.LINK_TO_LIST_OF_NAMES;
     EXISTS: out    AST_GRAPH.LINK_TO_LIST_OF_NAMES) is
    EXISTING_NAME :AST_GRAPH.LINK_TO_LIST_OF_NAMES;
  begin
    EXISTS := null;
    --Search for already existing names
    EXISTING_NAME := LIST;
    while EXISTING_NAME /= null loop
      if EXISTING_NAME.NAME = NAME then
       EXISTS := EXISTING_NAME;
       exit;
      end if;
      EXISTING_NAME := EXISTING_NAME.PREVIOUS_NAME;
    end loop;

    if EXISTS = null then
      --Add name to the list.
      EXISTING_NAME               := new AST_GRAPH.LIST_OF_NAMES;
      EXISTING_NAME.NAME          := NAME;
      EXISTING_NAME.PREVIOUS_NAME := LIST;
      LIST                        := EXISTING_NAME;
    end if;
  end Add;


  procedure GET_OFFENDING_DEPENDENT
    (RULES    : in  AST_GRAPH.LINK_TO_LIST_OF_RULES;
     OFFENDER : out AST_GRAPH.LINK_TO_LIST_OF_NAMES) is
    CURRENT     :   AST_GRAPH.LINK_TO_LIST_OF_RULES;
    DEPENDENT   :   AST_GRAPH.LINK_TO_LIST_OF_NAMES;
  begin
    OFFENDER := null;
    CURRENT  := RULES;
    RULE_SEARCH: while CURRENT /= null loop
                  DEPENDENT := CURRENT.RULE.DEPENDENTS;
      DEP_SEARCH: while DEPENDENT /= null loop
                    if DEPENDENT.NAME.NUMBER_OF_DEPENDENTS > 0 and
                       DEPENDENT.CYCLE_DETECTED = FALSE        then
                      OFFENDER := DEPENDENT;
                      exit;
                    end if;
                    DEPENDENT := DEPENDENT.PREVIOUS_NAME;
                  end loop DEP_SEARCH;

                  CURRENT := CURRENT.PREVIOUS_RULE;
                end loop RULE_SEARCH;
  end GET_OFFENDING_DEPENDENT;



  procedure PRINT_AND_REMOVE_CYCLE
    (CYCLE         : in AST_GRAPH.LINK_TO_LIST_OF_NAMES;
     OFFENDER_LIST : in AST_GRAPH.LINK_TO_LIST_OF_NAMES) is
    CURRENT   :    AST_GRAPH.LINK_TO_LIST_OF_NAMES;
    OFFENDER  : STRING(1..14);
    COLUMN    : INTEGER;
  begin
    --Break the chain at the end of the cycle and start at the top of cycle.
    if CYCLE /= null then
      CYCLE.PREVIOUS_NAME := null;
      NEW_LINE; PUT("CYCLE"); PUT(CYCLE_NUMBER, 3); PUT(":  ");
      STR_PACK.CONVERT_TO_STRING(CYCLE.NAME.NAME_VALUE, OFFENDER);
      PUT( OFFENDER(1..STR_PACK.LENGTH(CYCLE.NAME.NAME_VALUE)) );
      COLUMN       := 11 + STR_PACK.LENGTH(CYCLE.NAME.NAME_VALUE);
      CYCLE_NUMBER := CYCLE_NUMBER+1;
    end if;

    --Each name on the cycle list is part of a cycle.  Here we print the
    --cycle and reduce the appropriate dependency counts so that this
    --cycle will not be detected again.
    CURRENT             := OFFENDER_LIST;
    while CURRENT /= null loop
      if COLUMN + STR_PACK.LENGTH(CURRENT.NAME.NAME_VALUE) + 4 > 80 then
       NEW_LINE; PUT("           ");
       COLUMN := 11;
      end if;
      COLUMN := COLUMN + STR_PACK.LENGTH(CURRENT.NAME.NAME_VALUE) + 4;

      PUT( " <= " );
      STR_PACK.CONVERT_TO_STRING(CURRENT.NAME.NAME_VALUE, OFFENDER);
      PUT( OFFENDER(1..STR_PACK.LENGTH(CURRENT.NAME.NAME_VALUE)) );
      CURRENT := CURRENT.PREVIOUS_NAME;
    end loop;


    --Now we must remove each name in the cycle whose dependency count has
    --gone to zero.
      REMOVE_SAFE_NAMES;

    --Remove offenders from the violator list when their counts go to zero.
    --Since it is difficult to remove from the middle of a LIST_OF_NAMES,
    --and since GET_OFFENDING_DEPENDENT will ignore adding violators
    --whose counts are zero, it is only necessary to remove violators from
    --the top of the list.
    while VIOLATORS.NAME.NUMBER_OF_DEPENDENTS <= 0 loop
      VIOLATORS := VIOLATORS.PREVIOUS_NAME;
      if VIOLATORS = null then
       exit;
      end if;
    end loop;

  end PRINT_AND_REMOVE_CYCLE;


  procedure CYC_CHECK is
    OFFENDER_LIST  : AST_GRAPH.LINK_TO_LIST_OF_NAMES;
    CYCLE_FOUND    : AST_GRAPH.LINK_TO_LIST_OF_NAMES;
    GRAPH          : AST_GRAPH.LINK_TO_NAME_BLOCK;
    OFFENDERS_DEPENDENT: AST_GRAPH.LINK_TO_LIST_OF_NAMES;
    OFFENDER           : AST_GRAPH.LINK_TO_NAME_BLOCK;
    NO_VIOLATORS       : BOOLEAN;
  begin

    --Traverse the graph and count the number of immediate dependents
    --for each name in the name list;
    GRAPH := AST_GRAPH.NAME_LIST;
    while GRAPH /= null loop
      GRAPH.NUMBER_OF_DEPENDENTS := COUNT_OF_RELATIONS( GRAPH );

      if ARGUMENTS.IS_SET(ARGUMENTS.PROCESS_DUMP) then
       STR_PACK.CONVERT_TO_STRING(GRAPH.NAME_VALUE, DUMP_IT);
       PUT(DUMP_IT); PUT(GRAPH.NUMBER_OF_DEPENDENTS); NEW_LINE;
      end if;

      GRAPH := GRAPH.PREVIOUS_NAME_BLOCK;
    end loop;

    REMOVE_SAFE_NAMES;

    --Now check the NAME_LIST and make a list of violators.
    GRAPH := AST_GRAPH.NAME_LIST;
    while GRAPH /= null loop
      if GRAPH.NUMBER_OF_DEPENDENTS > 0 then

       if ARGUMENTS.IS_SET(ARGUMENTS.PROCESS_DUMP) then
         PUT("VIOLATE ");
         STR_PACK.CONVERT_TO_STRING(GRAPH.NAME_VALUE, DUMP_IT);
         PUT(DUMP_IT); PUT(GRAPH.NUMBER_OF_DEPENDENTS); NEW_LINE;
       end if;

       ADD(GRAPH, VIOLATORS, CYCLE_FOUND);
      end if;
      GRAPH := GRAPH.PREVIOUS_NAME_BLOCK;
    end loop;



    if VIOLATORS = null then
      NO_CYCLES := TRUE;
    else
      --Violators exist.  So find each cycle and print it.
      NO_CYCLES := FALSE;
      while VIOLATORS /= null loop

       if ARGUMENTS.IS_SET(ARGUMENTS.PROCESS_DUMP) then
         OFFENDER_LIST := VIOLATORS;
         while OFFENDER_LIST /= null loop
           STR_PACK.DUMP("VIOLATE ", OFFENDER_LIST.NAME.NAME_VALUE);
           PUT(OFFENDER_LIST.NAME.NUMBER_OF_DEPENDENTS, 3);
           OFFENDER_LIST := OFFENDER_LIST.PREVIOUS_NAME;
         end loop;
       end if;

       OFFENDER := VIOLATORS.NAME;
       ADD(OFFENDER, OFFENDER_LIST, CYCLE_FOUND);
       loop
         GET_OFFENDING_DEPENDENT(OFFENDER.DEFINING_RULES, OFFENDERS_DEPENDENT);

         if OFFENDERS_DEPENDENT = null then
           --This occurs only when an object's dependency count is non-zero
           --but all dependencies in its defining rules have been flagged as
           --having been detected in a cycle(this is caused by multiple
           --targets in the same rule).  In this case we remove this object
           --by setting its dependency count to zero and calling PRINT_AND_
           --REMOVE_CYCLE with null OFFENDER_LIST and CYCLE.
           OFFENDER.NUMBER_OF_DEPENDENTS := 0;
           OFFENDER_LIST := null;
           PRINT_AND_REMOVE_CYCLE(null, null);
           exit;
         end if;

         ADD(OFFENDERS_DEPENDENT.NAME, OFFENDER_LIST, CYCLE_FOUND);
         if CYCLE_FOUND /= null then
           OFFENDERS_DEPENDENT.CYCLE_DETECTED := TRUE;
           OFFENDER.NUMBER_OF_DEPENDENTS := OFFENDER.NUMBER_OF_DEPENDENTS-1;
           PRINT_AND_REMOVE_CYCLE(CYCLE_FOUND,OFFENDER_LIST);
           OFFENDER_LIST := null;
           exit;
         end if;
         OFFENDER := OFFENDERS_DEPENDENT.NAME;
       end loop;
      end loop;
    end if;
  end CYC_CHECK;


      procedure CONSTRUCTION_PROCESSING is

         CURRENT_NAME_BLOCK    : AST_GRAPH.LINK_TO_NAME_BLOCK;
          CURRENT_LIST_OF_RULES : AST_GRAPH.LINK_TO_LIST_OF_RULES;
          CURRENT_RULE          : AST_GRAPH.LINK_TO_RULE_DESCRIPTION;
      ALREADY_UP_TO_DATE    : BOOLEAN;

      begin
      --First check for the existence of cycles and continue only if
      --no cycles exist.
      CYC_CHECK;
      if NO_CYCLES = FALSE then
       return;
      end if;

      CURRENT_NAME_BLOCK    := new  AST_GRAPH.NAME_BLOCK;
      CURRENT_LIST_OF_RULES := new  AST_GRAPH.LIST_OF_RULES;
      CURRENT_RULE          := new  AST_GRAPH.RULE_DESCRIPTION;


      INITIALIZE_ALL_PROCESSING_DATA_STRUCTURES;

      PLACE_ALL_TARGETS_IN_NAME_BLOCK_QUEUE;

      while NAME_BLOCK_QUEUE_IS_NOT_EMPTY loop

        CURRENT_NAME_BLOCK := NEXT_NAME_BLOCK_ON_QUEUE;

        CURRENT_LIST_OF_RULES :=
               CURRENT_NAME_BLOCK.DEFINING_RULES;
        if CURRENT_LIST_OF_RULES /= null then
           CURRENT_RULE.all := CURRENT_LIST_OF_RULES.RULE.all;
           ADD_TO_RELEVANT_RULE_STACK (CURRENT_RULE);
           ADD_DEPENDENTS_TO_NAME_BLOCK_QUEUE (CURRENT_RULE);
        end if; -- CURRENT_LIST_OF_RULES /= null

        while THERE_IS_ANOTHER_RULE (CURRENT_LIST_OF_RULES) loop
           CURRENT_LIST_OF_RULES := NEXT_RULE (CURRENT_LIST_OF_RULES);
           CURRENT_RULE.all := CURRENT_LIST_OF_RULES.RULE.all;
           ADD_TO_RELEVANT_RULE_STACK (CURRENT_RULE);
           ADD_DEPENDENTS_TO_NAME_BLOCK_QUEUE (CURRENT_RULE);
        end loop;  -- while THERE_IS_ANOTHER_RULE (CURRENT_LIST_OF_RULES)

      end loop;  -- while NAME_BLOCK_QUEUE_IS_NOT_EMPTY

      -- When execution gets here, all relevant rules have been partially
      -- ordered and placed in the RELEVANT_RULE_STACK.
      -- We now evaluate the rules on the stack.
      -- If a rule is "fired" (i.e. a condition is met that
      -- should result in the execution of the commands associated
      -- with that rule), the command list is executed and/or printed,
      -- depending on the options the user selected.


      ALREADY_UP_TO_DATE := TRUE;   -- ASSUME THERE IS NO WORK TO DO...
      while RELEVANT_RULE_STACK_IS_NOT_EMPTY loop

        CURRENT_RULE := NEXT_RELEVANT_RULE_ON_QUEUE;

        if TIMESTAMPS_OUT_OF_SEQUENCE (CURRENT_RULE) then

        ALREADY_UP_TO_DATE := FALSE;  -- THERE IS WORK TO DO...

            if ARGUMENTS.IS_SET (ARGUMENTS.CMD_PRINT) then
               NEW_LINE;
               PUT("CONSTRUCT: Processing commands for rule on CO line ");
               PUT(CURRENT_RULE.CO_LINE_NUMBER);
               NEW_LINE;
            end if;

            if ARGUMENTS.IS_SET (ARGUMENTS.EXECUTE) then
               EXECUTE_THE_COMMAND_LIST (CURRENT_RULE.TOP_OF_COMMANDS);

            else  -- Only "Touch" the targets
               TOUCH_ALL_TARGETS (CURRENT_RULE);

            end if;  --if ARGUMENTS.IS_SET (ARGUMENTS.EXECUTE)

         end if; -- if TIMESTAMPS_OUT_OF_SEQUENCE (CURRENT_RULE)

      end loop;  -- while RELEVANT_RULE_STACK_IS_NOT_EMPTY

      -- NOW THE ALL OF THE RELEVANT RULES HAVE BEEN EXAMINED, WERE
      -- ANY OF THEM OUT OF DATE?
      if  ALREADY_UP_TO_DATE then
     PUT_LINE("CONSTRUCT:  Target(s) is (are) already up to date.");
      elsif ARGUMENTS.IS_SET (ARGUMENTS.EXECUTE) then
     NEW_LINE;
     PUT_LINE("CONSTRUCT:  Target(s) is (are) now up to date.");
      end if;


   end CONSTRUCTION_PROCESSING; ----- End of the procedure body



end CON_PROC; -------- End of the package body


--::::::::::::::
--construct.text
--::::::::::::::
-- This is the main program for CONSTRUCT.  It controls a straight line flow
-- of execution.  PROMPT and AST_GRAPH are always called.  Then, depending on
-- the options selected, calls are made to any of the following: TOP_DOWN_GRAPH,-- BOTTOM_UP_GRAPH, DISPLAY, or CON_PROC.  Cycle checking is done under the
-- control of CON_PROC.  The main program handles the ERROR exception, aborting
-- the run with a generalized error to the user.  A specific error message is
-- expected from the routine at the time of raising error.
with BLD_GRAPH, TEXT_IO, DISPLAY, ARGUMENTS, CON_PROC, ENVIRONS;
use TEXT_IO;
procedure CONSTRUCT is

begin

NEW_LINE;
PUT_LINE("    THIS IS A PROTOTYPE VERSION OF CONSTRUCT:  VERSION 841201");
NEW_LINE;

ARGUMENTS.PROMPT; -- Enters the arguments checking for
                  -- user input errors.
BLD_GRAPH.BUILD;    -- Syntactically analyzes the Configuration Object
                  -- and builds a dependency graph.

if ARGUMENTS.IS_SET(ARGUMENTS.TOP_DOWN_GRAPH) then
   DISPLAY.TOP_DOWN_GRAPH;
end if;

if ARGUMENTS.IS_SET(ARGUMENTS.BOTTOM_UP_GRAPH) then
   DISPLAY.BOTTOM_UP_GRAPH;
end if;


if ARGUMENTS.IS_SET(ARGUMENTS.LIST) then
  DISPLAY.NAMES;
end if;

if ARGUMENTS.IS_SET(ARGUMENTS.EXECUTE) or
   ARGUMENTS.IS_SET(ARGUMENTS.CMD_PRINT) then
     CON_PROC.CONSTRUCTION_PROCESSING; -- Determines the minimal set of
end if;                                -- commands necessary to update a system

NEW_LINE;
PUT("Construct completed.");
NEW_LINE;

exception
  when ENVIRONS.ERROR =>
     PUT("Construct aborted due to error in execution.");
     NEW_LINE;
   when others =>
     NEW_LINE;
     PUT("Construct aborted due to unknown error.");
     NEW_LINE;
     raise;

end CONSTRUCT;


--::::::::::::::
--create_co.text
--::::::::::::::
-- THIS program reads several Ada compilation unit and builds a dependency
-- list which is readable by the tool CONSTRUCT.  A new Configuration
-- Object file is created each time the program is run.  CREATE_CO assumes
-- there are at most two compilation units per file and that these two must
-- be a specification and body pair.  CREATE_CO processes subprograms,
-- packages, subunits, and generics.
with STR_PACK, HOST, TEXT_IO, ENVIRONS;
use  STR_PACK,       TEXT_IO;
procedure CREATE_CO is

  type PGM_STATE is (START_UP      , SUBPROGRAM_SPEC, SUBPROGRAM_BODY,
                     PACKAGE_SPEC  , PACKAGE_BODY   , GENERIC_PARMS  );
  type CONTEXT_STATE is (WITH_CLAUSE, SEPARATE_CLAUSE);
  MAX_COLUMN        : CONSTANT INTEGER :=76;
  MAX_STRING        : CONSTANT INTEGER :=255;
  CURRENT_UNIT_NAME : STRING(1..MAX_STRING);
  CURRENT_UNIT_SIZE : NATURAL;
  PROGRAM_STATE : PGM_STATE;
  SOURCE_FILE   : FILE_TYPE;
  CO_FILE       : FILE_TYPE;
  D_TOKEN       : DYNAMIC_STRING;
  FILE_LIST     : DYNAMIC_STRING;
  UNIT_LIST     : DYNAMIC_STRING;
  TOKEN         : STRING(1..MAX_STRING);
  FNAME         : DYNAMIC_STRING;
  D_LINE        : DYNAMIC_STRING;
  FILENAME      : STRING(1..MAX_STRING);
  SEPARATOR     : CHARACTER;
  LINE          : STRING(1..MAX_STRING);
  LAST          : INTEGER;
  SPACE_COUNT   : INTEGER;
  FILE_LENGTH   : INTEGER;
  NAME_START    : INTEGER;
  SIZE          : NATURAL;
  IS_BODY       : BOOLEAN;
  IS_SPEC       : BOOLEAN;
  INDENT_COUNT  : INTEGER;
  BLANKS        : constant STRING(1..MAX_COLUMN) :=
"                                                                            ";


  -- This procedure checks each character of a string and changes all upper
  -- case letters to lower case.  Changes are made in place destroying the
  -- original string value.
  procedure LOWER(WORD : in out STRING) is

  begin
    for I in 1..WORD'LENGTH loop
      case WORD(I) is
        when 'A' => WORD(I) := 'a';
        when 'B' => WORD(I) := 'b';
        when 'C' => WORD(I) := 'c';
        when 'D' => WORD(I) := 'd';
        when 'E' => WORD(I) := 'e';
        when 'F' => WORD(I) := 'f';
        when 'G' => WORD(I) := 'g';
        when 'H' => WORD(I) := 'h';
        when 'I' => WORD(I) := 'i';
        when 'J' => WORD(I) := 'j';
        when 'K' => WORD(I) := 'k';
        when 'L' => WORD(I) := 'l';
        when 'M' => WORD(I) := 'm';
        when 'N' => WORD(I) := 'n';
        when 'O' => WORD(I) := 'o';
        when 'P' => WORD(I) := 'p';
        when 'Q' => WORD(I) := 'q';
        when 'R' => WORD(I) := 'r';
        when 'S' => WORD(I) := 's';
        when 'T' => WORD(I) := 't';
        when 'U' => WORD(I) := 'u';
        when 'V' => WORD(I) := 'v';
        when 'W' => WORD(I) := 'w';
        when 'X' => WORD(I) := 'x';
        when 'Y' => WORD(I) := 'y';
        when 'Z' => WORD(I) := 'z';
        when others => null;
      end case;
    end loop;
  end LOWER;


  -- This procedure gets a token and a separator from the input token
  -- stream which is associated with the source file being read.  The
  -- DYNAMIC_STRING token is converted to an Ada STRING, reduced to lower
  -- case and its length is returned in SIZE.  When an end of string is
  -- encountered, GET_LOWER_CASE_STRING automatically reads new lines
  -- until a new token is found or end of file occurs.
  procedure GET_LOWER_CASE_STRING
    (STR          : out STRING;
     SIZE         : out NATURAL;
     SEPARATOR    : out CHARACTER) is

    TOKEN         : DYNAMIC_STRING;
    NOT_SUCCESSFUL: BOOLEAN := TRUE;
  begin
    while NOT_SUCCESSFUL loop
      begin
        GET_TOKEN(TOKEN, SEPARATOR);
        NOT_SUCCESSFUL := FALSE;
        -- For comments accept token but still get new line.
        if SEPARATOR = '-' then
            GET_LINE(SOURCE_FILE, LINE, LAST);
            SET_TOKEN_STREAM( LINE(1..LAST) );
        end if;
      exception
        when END_OF_STRING =>
            GET_LINE(SOURCE_FILE, LINE, LAST);
            SET_TOKEN_STREAM( LINE(1..LAST) );
      end;
    end loop;
    CONVERT_TO_STRING(TOKEN, STR);
    SIZE := LENGTH(TOKEN);
    LOWER( STR(1..SIZE) );
  end GET_LOWER_CASE_STRING;


  -- This function merely guards against constraint errors by comparing
  -- the length of strings prior to comparing the strings themselves.
  function EQUAL
    (LEFT     : in STRING;
     RIGHT    : in STRING) return BOOLEAN is
  begin
    if LEFT'LENGTH = RIGHT'LENGTH then
      if LEFT = RIGHT then
        return TRUE;
      end if;
    end if;
    return FALSE;
  end EQUAL;



  -- This procedure skips over a matched pair of parentheses, counting
  -- but ignoring nested parantheses.  On input the separator may be a
  -- '(' indicating the pair has already been encountered. Otherwise,
  -- SKIP_PARENTHESES looks at the next separator to determine whether
  -- the parenthetical expression is even present.
  procedure SKIP_PARENTHESES
    (TOKEN     : in out STRING;
     SIZE      : in out NATURAL;
     SEPARATOR : in out CHARACTER) is
    LEVEL            : NATURAL;
    MORE_PARENTHESES : BOOLEAN := TRUE;

  begin
    if SEPARATOR = '(' then
      LEVEL := 1;
    else
      LEVEL := 0;
    end if;

    while MORE_PARENTHESES loop
      GET_LOWER_CASE_STRING(TOKEN, SIZE, SEPARATOR);
      if    SEPARATOR = '(' then
        LEVEL := LEVEL+1;
      elsif SEPARATOR = ')' then
        LEVEL := LEVEL-1;
      end if;
      if LEVEL = 0 then
        MORE_PARENTHESES := FALSE;
      end if;
    end loop;
  end SKIP_PARENTHESES;



  -- This function checks unit_simple_names against the set of predefined
  -- system units.  A true value is returned on matches.
  -->>>>>>>>>>>>>>>>>> C O M P I L E R - D E P E N D E N T<<<<<<<<<<<<<<<--
  function SYSTEM_NAME(STR : STRING) return BOOLEAN is

  begin
    if EQUAL(STR, "text_io")   or
       EQUAL(STR, "system" )   or
       EQUAL(STR, "direct_io") or
       EQUAL(STR, "unix_call") or
       EQUAL(STR, "unchecked_conversion") or
       EQUAL(STR, "host_lcd_if")          then
       return TRUE;
    else
       return FALSE;
    end if;
  end SYSTEM_NAME;


  -- This procdedure determines the relevant program state by recognizing
  -- the PACKAGE, PROCEDURE, FUNCTION, BODY, IS, and GENERIC reserved
  -- words.  The token, size, and separator parameters are checked on
  -- input and new values are returned reflecting the file position on
  -- output.  The is_body parameter is returned true when a compilation
  -- unit body is recognized.
  procedure CHECK_PROGRAM_STATE
    (TOKEN    : in out STRING;
     SIZE     : in out NATURAL;
     SEPARATOR: in out CHARACTER;
     IS_BODY  :    out BOOLEAN;
     IS_SPEC  :    out BOOLEAN) is

  begin
    case PROGRAM_STATE is
    when START_UP | GENERIC_PARMS =>
        -- For the reserved word PACKAGE, check whether this is a
        -- specification or body.
        if EQUAL(TOKEN(1..SIZE), "package") then
          GET_LOWER_CASE_STRING(TOKEN, SIZE, SEPARATOR);
          if EQUAL(TOKEN(1..SIZE), "body") then
            PROGRAM_STATE := PACKAGE_BODY;
            IS_BODY := TRUE;
          else
            PROGRAM_STATE := PACKAGE_SPEC;
            CURRENT_UNIT_NAME(1..SIZE) := TOKEN(1..SIZE);
            CURRENT_UNIT_SIZE          := SIZE;
            IS_SPEC := TRUE;
          end if;

        -- For subprograms, skip over parenthesis.  If this is a function,
        -- also skip over the RETURN and the type_mark.  If the next
        -- token is IS, mark as a subprogram body.  Otherwise, mark as a
        -- subprogram specification.
        elsif EQUAL(TOKEN(1..SIZE), "procedure") or
              EQUAL(TOKEN(1..SIZE), "function" ) then
          GET_LOWER_CASE_STRING(TOKEN, SIZE, SEPARATOR);
          CURRENT_UNIT_NAME(1..SIZE) := TOKEN(1..SIZE);
          CURRENT_UNIT_SIZE          := SIZE;
          SKIP_PARENTHESES(TOKEN, SIZE, SEPARATOR);
          --If parameters existed then SEPARATOR will be a ')' and
          --we must check the next TOKEN for 'is' or ';'.  Otherwise,
          --the current TOKEN must be checked.
          if SEPARATOR = ')' then
            GET_LOWER_CASE_STRING(TOKEN, SIZE, SEPARATOR);
          end if;

          --If this was a function call skip over the return and type
          if EQUAL(TOKEN(1..SIZE), "return") then
            GET_LOWER_CASE_STRING(TOKEN, SIZE, SEPARATOR);
          end if;


          if EQUAL(TOKEN(1..SIZE), "is") then
            PROGRAM_STATE := SUBPROGRAM_BODY;
            IS_BODY := TRUE;
          else
            PROGRAM_STATE := SUBPROGRAM_SPEC;
          end if;
        elsif EQUAL(TOKEN(1..SIZE), "generic") then
          PROGRAM_STATE := GENERIC_PARMS;
        end if;

    when PACKAGE_SPEC =>
        -- Once a package specification has been encountered, the corresponding
        -- package body is identified by keyin on the reserved words PACKAGE
        -- BODY and then comparing the next token with the name captured when
        -- the specification was encountered.
        if EQUAL(TOKEN(1..SIZE), "package") then
          GET_LOWER_CASE_STRING(TOKEN, SIZE, SEPARATOR);
          if EQUAL(TOKEN(1..SIZE), "body") then
            GET_LOWER_CASE_STRING(TOKEN, SIZE, SEPARATOR);
            if EQUAL(TOKEN(1..SIZE),CURRENT_UNIT_NAME(1..CURRENT_UNIT_SIZE))then
              PROGRAM_STATE := PACKAGE_BODY;
              IS_BODY := TRUE;
            end if;
          end if;
        end if;

    when SUBPROGRAM_SPEC =>
        -- Once a subprogram specification has been found, the corresponding
        -- body is identified by keying on the reserved words PROCEDURE and
        -- FUNCTION, then comparing the next token with the name captured when
        -- the specification was encountered.
        if EQUAL(TOKEN(1..SIZE), "procedure") or
           EQUAL(TOKEN(1..SIZE), "function" ) then
          GET_LOWER_CASE_STRING(TOKEN,SIZE,SEPARATOR);
          if EQUAL(TOKEN(1..SIZE),CURRENT_UNIT_NAME(1..CURRENT_UNIT_SIZE)) then
            PROGRAM_STATE := SUBPROGRAM_BODY;
            IS_BODY := TRUE;
          end if;
        end if;

    when others =>
        -- All other program states are ignored at this time.
        null;
    end case;
  end CHECK_PROGRAM_STATE;


  -- This procedure prompts the user for a character string and creates a file
  -- that name which will be the configuration object file name.
  procedure OPEN_CO is
    CO_NAME  : STRING(1..MAX_STRING);
  begin
    NEW_LINE;
    PUT("ENTER CO_FILE_NAME =>");
    GET_LINE(CO_NAME, LAST);
    CREATE(CO_FILE, OUT_FILE, CO_NAME(1..LAST));
  end;


  -- This procedure prompts the user for a filename search pattern,
  -- builds a command to place a list of valid filenames in a file, and
  -- then reads that file building a dynamic string of files to be
  -- scanned.  It calls the system dependent routine HOST.EXECUTE_CMDS
  -- and also builds a system dependent string wich is passed as the
  -- command to be executed.
  -->>>>>>>>>>>>>>>>>>>>>>>S Y S T E M   D E P E N D E N T<<<<<<<<<<<<<<<--
  procedure GET_LIST_OF_FILENAMES is
    CO_TEMP       : FILE_TYPE;
    COMMAND       : STRING(1..MAX_STRING);
    D_COMMAND     : DYNAMIC_STRING;
  begin
    ASSIGN(FILE_LIST, EMPTY_STR);
    PUT("ENTER NAMES OF FILES TO BE SCANNED => ");
    GET_LINE(LINE, LAST);
    COMMAND(1..3)            := "ls ";
    COMMAND(4..LAST+3)       := LINE(1..LAST);
    COMMAND(LAST+4..LAST+21) := " >> CREATE_CO.TEMP";

    begin --build file list
      CONVERT_TO_DYNAMIC(COMMAND(1..LAST+21), D_COMMAND);
      HOST.EXECUTE_CMDS(D_COMMAND);
      OPEN(CO_TEMP, IN_FILE, "CREATE_CO.TEMP");

      loop  --Until end of file
        GET_LINE(CO_TEMP, LINE, LAST);
        APPEND(" ", FILE_LIST);
        APPEND(LINE(1..LAST), FILE_LIST);
      end loop;
    exception
      when HOST.EXECUTION_ERROR =>
                                       PUT_LINE("**ERROR** NO FILES FOUND");
                                       DELETE(CO_TEMP);
      when END_ERROR =>
                        DELETE(CO_TEMP); --End of file expected.
    end;
  end GET_LIST_OF_FILENAMES;


  -- This procedure writes a dependency rule.  A .sym target is specified
  -- whenever a package specification has been recognized.  A .code target
  -- is always specified.  The target names are built from the name of the
  -- source file stripped of the .text suffix and any leading directory
  -- names.  Dependencies are then retrieved from the UNIT_LIST previously
  -- built by SAVE_DEPENDENCIES.  Each line of the dependency rule consists
  -- of five 15-character fields.
  procedure WRITE_DEPENDENCIES is
      SIZE        : NATURAL;
      UNIT_NAME   : STRING(1..MAX_STRING);
      TEMP_NAME   : STRING(1..MAX_STRING);
      ROOT_LENGTH : NATURAL;


    -- This procedure writes a string and pads with blanks to a multiple of
    -- 14. It guarantees that a blank trails and also checks for exceeding
    -- line length.
    procedure PUT_15(STR : in STRING; SEP : in CHARACTER) is
      SIZE      : INTEGER;
      PAD       : INTEGER;
    begin
      SIZE := STR'LENGTH+1;
      SPACE_COUNT := SPACE_COUNT + ( ((SIZE-1)/15+1) * 15);
      if SPACE_COUNT > MAX_COLUMN then
        PUT(CO_FILE, "\");
        NEW_LINE(CO_FILE); PUT(CO_FILE, BLANKS(1..INDENT_COUNT));
        SPACE_COUNT := INDENT_COUNT +((SIZE-1)/15+1) * 15;
      end if;

      PUT(CO_FILE, STR    (1..SIZE-1) );
      PAD := (SIZE) mod 15;
      if PAD /= 0 then
        PUT(CO_FILE, BLANKS (PAD..14)  );
      end if;
      PUT(CO_FILE, SEP);
    end PUT_15;


  begin

    -- Remove directories, if any from file name
    NAME_START := 1;
    for I in 1..FILE_LENGTH loop
      if FILENAME(I) = '/' then
        NAME_START  := I+1;
      end if;
    end loop;
    ROOT_LENGTH := (FILE_LENGTH-5) - NAME_START + 1;

    SPACE_COUNT := 0;
    TEMP_NAME(1..ROOT_LENGTH) := FILENAME(NAME_START..FILE_LENGTH-5);
    if IS_SPEC then
      TEMP_NAME(ROOT_LENGTH+1..ROOT_LENGTH+4) := ".sym";
      PUT_15(TEMP_NAME(1..ROOT_LENGTH+4), ' ');
    end if;
    TEMP_NAME(ROOT_LENGTH+1..ROOT_LENGTH+5)   := ".code";
    PUT_15(TEMP_NAME(1..ROOT_LENGTH+5), ':');
    INDENT_COUNT := SPACE_COUNT;
    TEMP_NAME(1..FILE_LENGTH-NAME_START+1) := FILENAME(NAME_START..FILE_LENGTH);
    PUT_15(TEMP_NAME(1..FILE_LENGTH-NAME_START+1), ' ');

    --Check for an empty unit list which means that the specification
    --has no dependencies and this routine may be exited
    if EMPTY(UNIT_LIST) then
      raise END_OF_STRING;
    end if;

    loop
      GET_TOKEN(UNIT_LIST, D_TOKEN, SEPARATOR);
      CONVERT_TO_STRING(D_TOKEN, UNIT_NAME(1..LENGTH(D_TOKEN)));
      PUT_15(UNIT_NAME(1..LENGTH(D_TOKEN)), ' ');
    end loop;
  exception
    when END_OF_STRING => PUT(CO_FILE, ';');
                          NEW_LINE(CO_FILE);
  end WRITE_DEPENDENCIES;



  -- This procedure is called whenever a WITH or SEPERATE clause is
  -- encountered.  Unit names are checked against the list of system
  -- supplied names, and user-defined units are added to the CO file.
  -- Termination occurs on a ';' for WITHs and on a ')' for SEPARATEs.
  procedure SAVE_DEPENDENCIES
          (UNIT_DESCRIPTOR : in CONTEXT_STATE) is
    UNIT_NAME     : STRING(1..MAX_STRING);
    SIZE          : INTEGER;
  begin
    loop
      GET_LOWER_CASE_STRING(UNIT_NAME, SIZE, SEPARATOR);
      if not SYSTEM_NAME( UNIT_NAME(1..SIZE) ) then
        if UNIT_DESCRIPTOR = WITH_CLAUSE then
          UNIT_NAME(SIZE+1..SIZE+5) := ".sym ";
        else
          UNIT_NAME(SIZE+1..SIZE+5) := ".code";
        end if;
        APPEND(" ",                 UNIT_LIST);
        APPEND(UNIT_NAME(1..SIZE+5), UNIT_LIST);
      end if;
      exit when SEPARATOR = ';' or SEPARATOR = ')';
    end loop;
  end SAVE_DEPENDENCIES;


  -- This procedure scans a line of source text.  It processes multiple
  -- statements per line looking for with or separate clauses.  It exits
  -- when a comment is encountered.
  procedure PROCESS_A_LINE is
  begin
    loop
      GET_LOWER_CASE_STRING(TOKEN, SIZE, SEPARATOR);
      if EQUAL(TOKEN(1..SIZE), "with")  and
        PROGRAM_STATE /= GENERIC_PARMS then
        SAVE_DEPENDENCIES(WITH_CLAUSE);
      elsif EQUAL(TOKEN(1..SIZE), "separate") then
        SAVE_DEPENDENCIES(SEPARATE_CLAUSE);
        raise END_ERROR; --Since only a proper body follows.
      elsif SEPARATOR = ENVIRONS.COMMENT then
        return;
      else
        --If a comment was found then this can't be a body.  Nor
        --is it necessary to look for the end of this statement.
        CHECK_PROGRAM_STATE(TOKEN, SIZE, SEPARATOR, IS_BODY, IS_SPEC);
        if IS_BODY then
          raise END_ERROR;
        end if;
        LOOK_FOR_NEXT_STATEMENT: loop
           GET_TOKEN(D_TOKEN, SEPARATOR);
           if SEPARATOR = ';' then
             exit;
           elsif SEPARATOR = '-' then
             return;
           end if;
        end loop LOOK_FOR_NEXT_STATEMENT;
      end if;
    end loop;
  exception
    when END_OF_STRING => null; --it is ok.
  end PROCESS_A_LINE;



begin

  --Prompt user for co_file name. Then get list of files to be processed
  --and added to the co_file.
  OPEN_CO;
  GET_LIST_OF_FILENAMES;
  GET_TOKEN(FILE_LIST, FNAME, SEPARATOR);

  while not EMPTY( FNAME ) loop
    CONVERT_TO_STRING(FNAME, FILENAME);
    FILE_LENGTH := LENGTH(FNAME);

    begin  -- Protect for illegal files
      OPEN( SOURCE_FILE, IN_FILE, FILENAME(1..LENGTH(FNAME)) );
      PUT_LINE( FILENAME(1..FILE_LENGTH) );
      PROGRAM_STATE := START_UP;
      IS_BODY       := FALSE;
      IS_SPEC       := FALSE;

      begin --process a file
        PROCESS_A_FILE: loop
         GET_LINE(SOURCE_FILE, LINE, LAST);
          SET_TOKEN_STREAM(LINE(1..LAST));

          PROCESS_A_LINE;

        end loop PROCESS_A_FILE;
      exception
        when END_ERROR => WRITE_DEPENDENCIES;
                          PUT(CO_FILE, "ada ");
                          PUT(CO_FILE, FILENAME(NAME_START..FILE_LENGTH-5) );
                          NEW_LINE(CO_FILE);PUT(CO_FILE, '$');NEW_LINE(CO_FILE);
                          CLOSE(SOURCE_FILE);
      end;
      GET_TOKEN(FILE_LIST, FNAME, SEPARATOR);
    exception
      when NAME_ERROR=> PUT("**ERROR** FILE:");
                        PUT(FILENAME(1..FILE_LENGTH));
                        PUT_LINE(" CAN'T BE OPENED.");
                        GET_TOKEN(FILE_LIST, FNAME, SEPARATOR);
    end;  -- Protect for illegal files
  end loop;
exception
  -- END_OF_STRING may be raised by a call to GET_TOKEN in an attempt to get
  -- another file name after the last name in the list has been read.
  when END_OF_STRING => --Dont CLOSE(CO_FILE); since that puts an end of page.
                        null;
end CREATE_CO;
--::::::::::::::
--display.text
--::::::::::::::
-- This package performs the processing for generating the top_down and bottom_
-- up graphs and for displaying the lists of basic and derived names.
package DISPLAY is

  procedure TOP_DOWN_GRAPH;
  procedure BOTTOM_UP_GRAPH;
  procedure NAMES;

end DISPLAY;


with AST_GRAPH, STR_PACK, ARGUMENTS, ENVIRONS;
with TEXT_IO; use TEXT_IO, INTEGER_IO, STR_PACK;
package body DISPLAY is

  type LIST_OF_LEVELS;
  type LINK_TO_LEVELS is access LIST_OF_LEVELS;
  type LIST_OF_LEVELS is
      record
        RELATIONS     : AST_GRAPH.LINK_TO_LIST_OF_NAMES;
        NEXT_LEVEL    : LINK_TO_LEVELS;
      end record;
  type DIRECTION is (TOP_DOWN, BOTTOM_UP);


  OBJECT           : AST_GRAPH.LINK_TO_NAME_BLOCK;
  ALREADY_EXPANDED : BOOLEAN;
  NEW_LEVEL_ADDED  : BOOLEAN;

  LINE_NO       :          NATURAL := 1;
  MAX_SIZE      :          NATURAL := 62;
  INDENT_SIZE   : constant NATURAL := 4;
  MAX_INDENT    : constant NATURAL := MAX_SIZE/INDENT_SIZE;
  INDENT_COUNT  :          NATURAL := 0;


  -- This procedure is called at the start of each graph to reinitialize values
  -- so that multiple graphs may be displayed.
  procedure RESET is
    OBJECT_NAME    : AST_GRAPH.LINK_TO_NAME_BLOCK;
  begin
    LINE_NO        := 1;
    MAX_SIZE       := 62;
    INDENT_COUNT   := 0;

    OBJECT_NAME     := AST_GRAPH.NAME_LIST;
    WHILE OBJECT_NAME /= null loop
      OBJECT_NAME.EXPANSION_LINE := 0;
      OBJECT_NAME                := OBJECT_NAME.PREVIOUS_NAME_BLOCK;
    end loop;
  end RESET;


  -- This procedure looks up the name of the object whose graph is to be
  -- drawn and creates the initial level for production of the graph.
  procedure GET_FIRST_LEVEL
     (GOAL          : STR_PACK.DYNAMIC_STRING;
      LEVEL         : out LINK_TO_LEVELS) is
     MATCH  : AST_GRAPH.LINK_TO_LIST_OF_NAMES;
     NAMES  : AST_GRAPH.LINK_TO_NAME_BLOCK;
     SEPARATOR     : CHARACTER;

  begin
    LEVEL := null;

    --Search for TARGET_ARG in NAME_LIST.
    NAMES := AST_GRAPH.NAME_LIST;
    while NAMES /= null loop
      if GOAL = NAMES.NAME_VALUE then
        --TARGET_ARG is found. Put it in a LIST OF NAMES and put that
        --list in a LIST OF LEVELS. Then exit this procedure.
        MATCH            := new AST_GRAPH.LIST_OF_NAMES;
        MATCH.NAME       := NAMES;
        LEVEL            := new LIST_OF_LEVELS;
        LEVEL.RELATIONS  := MATCH;
        exit;
      end if;

      NAMES := NAMES.PREVIOUS_NAME_BLOCK;
    end loop;
  end GET_FIRST_LEVEL;


  -- This procedure checks for a null list and retrieves a name, removing
  -- it from the list, if the list is not null.
  procedure GET_OBJECT
     (NAMES : in out AST_GRAPH.LINK_TO_LIST_OF_NAMES;
      OBJECT: out    AST_GRAPH.LINK_TO_NAME_BLOCK) is
  begin
    if NAMES = null then
      OBJECT := null;
    else
      OBJECT := NAMES.NAME;
      NAMES  := NAMES.PREVIOUS_NAME;
    end if;
  end GET_OBJECT;


  -- Given an object, this procedure creates a list of that objects relatives
  -- by searching all rules in which that object occurs. If the order is top
  -- down relatives will be chosen from the DEPENDENTS list of rules in which
  -- the object is a TARGET. Otherwise, relatives are chosen from the list of
  -- TARGETS given in rules where this object is a DEPENDENT.
  procedure GET_RELATIONS
     (OBJECT    : in  AST_GRAPH.LINK_TO_NAME_BLOCK   ;
      RELATIONS : out AST_GRAPH.LINK_TO_LIST_OF_NAMES;
      ORDER     : in  DIRECTION                      ) is
    R_LIST           : AST_GRAPH.LINK_TO_LIST_OF_RULES;


    -- This procedure appends one list of names to another.  Names are copied
    -- from the end of one list to the end of the other.  Thus order is not
    -- preserved.
    procedure ADD
       (LIST     : in out  AST_GRAPH.LINK_TO_LIST_OF_NAMES;
        ADD_ON   : in      AST_GRAPH.LINK_TO_LIST_OF_NAMES) is
       CURRENT   : AST_GRAPH.LINK_TO_LIST_OF_NAMES;
       ADDED     : AST_GRAPH.LINK_TO_LIST_OF_NAMES;
    begin
      ADDED   := ADD_ON;
      while ADDED /= null loop
        --Copy a name from the add-on list.
        CURRENT := new AST_GRAPH.LIST_OF_NAMES;
        CURRENT.NAME := ADDED.NAME;

        --Link it to top of LIST and reset LIST.
        CURRENT.PREVIOUS_NAME := LIST;
        LIST                  := CURRENT;

        --Point to the next name to be added
        ADDED := ADDED.PREVIOUS_NAME;
      end loop;
    end ADD;


  begin
    RELATIONS := null;
    if ORDER = TOP_DOWN then
      R_LIST := OBJECT.DEFINING_RULES;
    else
      R_LIST := OBJECT.DEPENDENT_RULES;
    end if;

    --Loop through the list of rules adding the appropiate list
    --of relations(either targets or dependents) to be returned.
    while R_LIST /= null loop
      if ORDER = TOP_DOWN then
        ADD(RELATIONS,R_LIST.RULE.DEPENDENTS);
      else
        ADD(RELATIONS,R_LIST.RULE.TARGETS);
      end if;
      R_LIST := R_LIST.PREVIOUS_RULE;
    end loop;

  end GET_RELATIONS;


  -- This procedure prints one line of either a top_down or bottom_up graph.
  -- It checks for previously expanded objects, inserting the referenced line
  -- number when appropriate.  It computes the proper number and contents of
  -- the indentation field.  This procedure also counts lines and issues a
  -- page eject after 55 lines.
  procedure PRINT_LINE is
    COUNT           : NATURAL;
    INDENTER        : STRING(1..MAX_SIZE) :=
      "..........................................................    ";
    NAME            : STRING(1..MAX_SIZE);
  begin
    PUT(LINE_NO, 4);  PUT(' ');
    if ALREADY_EXPANDED then
      PUT('[');  PUT(OBJECT.EXPANSION_LINE, 3);  PUT(']');
    else
      PUT("     ");
    end if;

    if INDENT_COUNT /= 0 then
      COUNT := MAX_SIZE - (  INDENT_COUNT * INDENT_SIZE  ) + 1;
      PUT(  INDENTER(COUNT..MAX_SIZE)  );
    end if;
    STR_PACK.CONVERT_TO_STRING(OBJECT.NAME_VALUE, NAME);
    PUT(  NAME(  1..STR_PACK.LENGTH(OBJECT.NAME_VALUE)  ) );
    NEW_LINE;

    LINE_NO := LINE_NO + 1;
    if LINE_NO MOD 55  =  0 then
      NEW_PAGE;  NEW_LINE; NEW_LINE;
    end if;
  end PRINT_LINE;


  -- This procedure controls the printing of a single graph. Starting with the
  -- target object, Graph obtains the list of all relatives(in either direction)
  -- This list constitutes a level.  One object from the current level is
  -- selected for printing; it is removed from the level; and its relatives are
  -- added at a new level.  The new level becomes the current level and the
  -- process iterates.  When an atttempt is made to obtain an object and the
  -- level is found to be empty, the current level pops back up one level.  When
  -- the top level is exited, the graph is complete.
  procedure GRAPH (GOAL           : STR_PACK.DYNAMIC_STRING;
                   ORDER          : DIRECTION              ) is
    CURRENT_LEVEL   : LINK_TO_LEVELS;
    NEW_RELATIONS   : AST_GRAPH.LINK_TO_LIST_OF_NAMES;
    NEW_LEVEL       : LINK_TO_LEVELS;
    NEW_LEVEL_ADDED : BOOLEAN;
    GRAPH_NAME      : STRING(1..MAX_SIZE);
  begin
    --Clean up counters and flags so that multiple graphs may be drawn.
    RESET;
    --Get the list of objects for which graphs are to be expanded,
    --and write the title line;
    GET_FIRST_LEVEL(GOAL, CURRENT_LEVEL);

    STR_PACK.CONVERT_TO_STRING(GOAL, GRAPH_NAME);
    NEW_PAGE; PUT("          CONSTRUCT GRAPH FOR ");
              PUT_LINE(GRAPH_NAME(1..STR_PACK.LENGTH(GOAL)));
              NEW_LINE;

    --Now loop through all levels looking at a name, adding a level
    --when that name has relations and is not already expanded,
    --popping back up a level when all names at level have been
    --processed.
    while CURRENT_LEVEL /= null loop

      --Remove object from active list. If it is null, move to
      --previous level. Otherwise print it and add its relations to
      --a new level if appropriate.
      NEW_LEVEL_ADDED := FALSE;
      GET_OBJECT(CURRENT_LEVEL.RELATIONS, OBJECT);
      if OBJECT = null then
        --Pop back up a level since all objects here are listed
        CURRENT_LEVEL := CURRENT_LEVEL.NEXT_LEVEL;
        if INDENT_COUNT > 0 then
          INDENT_COUNT  := INDENT_COUNT - 1;
        end if;

      else
        --Expand a level if necessary and print a line
        if OBJECT.EXPANSION_LINE /= 0 then
          --Object has already been expanded.
          ALREADY_EXPANDED := TRUE;

        else
          --GET list of relations for this object and create a new
          --level if there are any.
          ALREADY_EXPANDED := FALSE;
          GET_RELATIONS(OBJECT, NEW_RELATIONS, ORDER);
          if NEW_RELATIONS /= null then
            --Mark current object as expanded and add level to list.
            OBJECT.EXPANSION_LINE := LINE_NO;
            NEW_LEVEL             := new LIST_OF_LEVELS;
            NEW_LEVEL.NEXT_LEVEL  := CURRENT_LEVEL;
            NEW_LEVEL.RELATIONS   := NEW_RELATIONS;
            CURRENT_LEVEL         := NEW_LEVEL;
            NEW_LEVEL_ADDED       := TRUE;
          end if;
        end if;

        PRINT_LINE;
        if NEW_LEVEL_ADDED then
          INDENT_COUNT := INDENT_COUNT+1;
        end if;
      end if;
    end loop;
    NEW_LINE;
    NEW_LINE;
    PUT_LINE("END OF GRAPH");
  end GRAPH;


  -- This procedure processes the list of goals.  If the list is empty, it
  -- defaults to the first goal in the CO file.  Otherwise, it gets each
  -- goal in the list and calls GRAPH to print its graph.
  procedure PROCESS_GOAL_LIST(ORDER : DIRECTION) is
    OBJECT_NAME         : AST_GRAPH.LINK_TO_NAME_BLOCK;
    GOAL                : STR_PACK.DYNAMIC_STRING;
    LOCAL_GOAL_LIST     : STR_PACK.DYNAMIC_STRING;
    SEPARATOR           : CHARACTER;
  begin
    if STR_PACK.EMPTY(ARGUMENTS.TARGET_ARG) then
      -- Default goal to first entry in name list
      OBJECT_NAME := AST_GRAPH.NAME_LIST;
      while OBJECT_NAME.PREVIOUS_NAME_BLOCK /= null loop
        OBJECT_NAME := OBJECT_NAME.PREVIOUS_NAME_BLOCK;
        STR_PACK.ASSIGN(GOAL, OBJECT_NAME.NAME_VALUE);
      end loop;
      GRAPH(GOAL, ORDER);

    else
      -- Get each token and print its graph.
      STR_PACK.ASSIGN(LOCAL_GOAL_LIST, ARGUMENTS.TARGET_ARG);
      while not EMPTY(LOCAL_GOAL_LIST) loop
        STR_PACK.GET_TOKEN(LOCAL_GOAL_LIST, GOAL, SEPARATOR);
        GRAPH(GOAL, ORDER);
      end loop;
    end if;
  end PROCESS_GOAL_LIST;


  -- This procedure calls PROCESS_GOAL_LIST requesting that graph be displayed
  -- in a top down manner.
  procedure TOP_DOWN_GRAPH is
  begin
    PROCESS_GOAL_LIST( TOP_DOWN );
  end TOP_DOWN_GRAPH;



  -- This procedure calls PROCESS_GOAL_LIST requesting that graph be displayed
  -- in a bottom up manner.
  procedure BOTTOM_UP_GRAPH is
  begin
    PROCESS_GOAL_LIST( BOTTOM_UP );
  end BOTTOM_UP_GRAPH;



  -- This procedure prints out the basic names and the derived names
  -- from the dependency graph.
  procedure NAMES is
    STR        : STRING(1..ENVIRONS.MAX_FILENAME_LENGTH);
    STR_LENGTH : NATURAL;
    COLUMN     : POSITIVE := 1;
  begin
    -- Initialize to beginning of dependency graph.
    AST_GRAPH.NAME_LINK := AST_GRAPH.NAME_LIST;

    -- Print banner for Basic Names.
    NEW_LINE;
    NEW_LINE;
    PUT_LINE("LIST OF BASIC NAMES");
    PUT_LINE("-------------------");
    NEW_LINE;

    -- Print Basic Names, four across page.
    while AST_GRAPH.NAME_LINK /= null loop
      if AST_GRAPH.NAME_LINK.DEFINING_RULES = null then
        STR_PACK.CONVERT_TO_STRING(AST_GRAPH.NAME_LINK.NAME_VALUE, STR);
        STR_LENGTH := STR_PACK.LENGTH(AST_GRAPH.NAME_LINK.NAME_VALUE);
        PUT(STR(1..STR_LENGTH));
        -- Pad to max length and add 5 spaces.
        for I in 1..(ENVIRONS.MAX_FILENAME_LENGTH - STR_LENGTH + 5) loop
          PUT(" ");
        end loop;
        -- Start a new line if four names have been printed.
        if COLUMN = 4 then
          NEW_LINE;
          COLUMN := 1;
        else
          COLUMN := COLUMN + 1;
        end if;
      end if;
      AST_GRAPH.NAME_LINK := AST_GRAPH.NAME_LINK.PREVIOUS_NAME_BLOCK;
    end loop;

    -- Reset to beginning of graph.
    AST_GRAPH.NAME_LINK := AST_GRAPH.NAME_LIST;
    COLUMN              := 1;

    -- Print banner for Derived Names.
    NEW_LINE;
    NEW_LINE;
    NEW_LINE;
    PUT_LINE("LIST OF DERIVED NAMES");
    PUT_LINE("---------------------");
    NEW_LINE;

    -- Print Derived Names four across page.
    while AST_GRAPH.NAME_LINK /= null loop
      if AST_GRAPH.NAME_LINK.DEFINING_RULES /= null then
        STR_PACK.CONVERT_TO_STRING(AST_GRAPH.NAME_LINK.NAME_VALUE, STR);
        STR_LENGTH := STR_PACK.LENGTH(AST_GRAPH.NAME_LINK.NAME_VALUE);
        PUT(STR(1..STR_LENGTH));
        -- Pad to max length and add 5 spaces.
        for I in 1..(ENVIRONS.MAX_FILENAME_LENGTH - STR_LENGTH + 5) loop
          PUT(" ");
        end loop;
        -- Start a new line if four names have been printed.
        if COLUMN = 4 then
          NEW_LINE;
          COLUMN := 1;
        else
          COLUMN := COLUMN + 1;
        end if;
      end if;
      AST_GRAPH.NAME_LINK := AST_GRAPH.NAME_LINK.PREVIOUS_NAME_BLOCK;
    end loop;

    NEW_LINE;
    NEW_LINE;
    PUT_LINE("END OF NAMES");
  end;


end DISPLAY;
--::::::::::::::
--environs.text
--::::::::::::::
-- This package constitutes the extended environment for the CONSTRUCT program.
-- The exception ERROR is used to indicate errors which abort a process during
-- a CONSTRUCT run.  The constants are used throughout CONSTRUCT and their
-- collection here provides additional control and facilitates parameterization.
package ENVIRONS is

   ERROR : exception;

-->>>>>>>>>>>>>>>>>>>C O N S T A N T   D E C L A R A T I O N S<<<<<<<<<<<<<<<--
   CONTINUATION              : constant CHARACTER := '\';
   COMMENT                   : constant CHARACTER := '-';
   TARGET_LIST_TERMINATOR    : constant CHARACTER := ':';
   DEPENDENT_LIST_TERMINATOR : constant CHARACTER := ';';
   MAX_LINE_LENGTH           : constant INTEGER   := 80;
   MAX_CMD_LENGTH            : constant INTEGER   := 200;
   MAX_FILENAME_LENGTH       : constant INTEGER   := 14;
   END_OF_COMMANDS           : constant CHARACTER := '$';
   FIRST_CHAR_OF_ENTRY_NAME  : constant CHARACTER := '%';
-->>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<--



end ENVIRONS;
--::::::::::::::
--host.text
--::::::::::::::

with STR_PACK;
with CALENDAR;

-- This package contains the host-specific routines needed by Construct.  It is
-- the interface between Construct and the underlying Operating System.  The
-- functions provided are: retrieval of an object's time stamp, determination
-- of whether arguments were supplied on the invocation of Construct, and the
-- ability to pass a command to the operating system for execution.  Two
-- exceptions may be propogated from Host. ACCESSIBILITY_ERROR is raised when a
-- timestamp is requested for an object but is unavailable. EXECUTION_ERROR is
-- raised upon illegal command execution.
-- To provide this interface Host uses the packages SYSTEM and
-- UNCHECKED_CONVERSION, as well as the Telesoft/UNIX-specific packages
-- HOST_LCD_IF and UNIX_CALL.
package HOST is


   function MODIFICATION_TIMESTAMP
      (FOR_DBO : STR_PACK.DYNAMIC_STRING)
      return CALENDAR.TIME;

   ACCESSIBILITY_ERROR : exception;

   function ARGS_EXIST return BOOLEAN;

   procedure EXECUTE_CMDS (CMD_LIST : in STR_PACK.DYNAMIC_STRING);

   EXECUTION_ERROR : EXCEPTION;


end HOST;


with HOST_LCD_IF;
with UNIX_CALL;
with SYSTEM;
with UNCHECKED_CONVERSION;
with ENVIRONS;
package body HOST is


   -- This function retrieves the timestamp of a UNIX file.  If the file doesn't
   -- exist or is protected, it raises an ACCESSIBILITY_ERROR.  A check is made
   -- to make sure that a filename less than 14 characters in length is
   -- terminated by a NUL(this is a UNIX requirement).
   function MODIFICATION_TIMESTAMP
      (FOR_DBO : STR_PACK.DYNAMIC_STRING)
      return CALENDAR.TIME is

      GET_TIME : constant UNIX_CALL.CALL := 666;

      NAME_LENGTH : INTEGER;

      function ADDR_TO_INT is new UNCHECKED_CONVERSION
        (SYSTEM.ADDRESS, LONG_INTEGER);

      TIMESTAMP  : CALENDAR.TIME;

      RSLT : UNIX_CALL.RESULT;

      FILENAME : STRING(1 .. ENVIRONS.MAX_FILENAME_LENGTH);

   begin


      STR_PACK.CONVERT_TO_STRING (FOR_DBO, FILENAME);

      NAME_LENGTH := STR_PACK.LENGTH (FOR_DBO);
      if NAME_LENGTH < 14 then
         FILENAME (NAME_LENGTH + 1) := ASCII.NUL;
      end if;

      RSLT := UNIX_CALL.SYSCALL1 (GET_TIME, ADDR_TO_INT(FILENAME'address));

      if (RSLT = -1) then
         raise ACCESSIBILITY_ERROR;
      end if;

      TIMESTAMP := RSLT; -- This may become less trivial when CALENDAR
                         -- changes ( and Time /= Long_Integer!)

      return (TIMESTAMP);

   end MODIFICATION_TIMESTAMP;



   -- This function obtains the parameter list and the number of parameters
   -- from the Operating System(HOST_LCD_IF).  If the number of parameters is
   -- greater than 0, a true value is returned.
   function ARGS_EXIST return BOOLEAN is
      PARMS : STRING(1 .. 100);
      PARM_COUNT : INTEGER;

   begin

      HOST_LCD_IF.PARAM_STRING (PARMS, PARM_COUNT);
      return (PARM_COUNT > 0);

   end ARGS_EXIST;


   -- This procedure passes a single string to the operating system to be
   -- executed as a command.  If a non-zero execution code is returned, the
   -- exception EXECUTION_ERROR is raised.
   procedure EXECUTE_CMDS (CMD_LIST : in STR_PACK.DYNAMIC_STRING) is

      RET_CODE : UNIX_CALL.RESULT;
      INVOKE : constant UNIX_CALL.CALL := 667;
      STR_BUFFER : STRING(1 .. ENVIRONS.MAX_CMD_LENGTH);

      function ADDR_TO_INT is new UNCHECKED_CONVERSION
        (SYSTEM.ADDRESS, LONG_INTEGER);

   begin

      for I in STR_BUFFER'range loop
         STR_BUFFER(I) := ' ';
      end loop;

      STR_PACK.CONVERT_TO_STRING (CMD_LIST, STR_BUFFER);

      RET_CODE := UNIX_CALL.SYSCALL1 (INVOKE, ADDR_TO_INT(STR_BUFFER'address));

      if (RET_CODE /= 0) then
         raise EXECUTION_ERROR;
      end if;

   end EXECUTE_CMDS;


end HOST;
--::::::::::::::
--str_pack.text
--::::::::::::::
-- This package defines and maintains dynamic strings that are used
-- by the other packages and the procedure CONSTRUCT.

package STR_PACK is

  -- Each variable of this type is composed of a sequence of
  -- characters and an indication of the number of characters in the
  -- sequence (i.e., its length >= 0).  Each character in the sequence
  -- is ordered relative to its position, where the first character
  -- has position l, and the position of each character thereafter is
  -- incremented by l.  If there are no characters in the sequence,
  -- then the length is 0, else the length is the position of the
  -- last character in the sequence.  Initially, a variable of this
  -- type is an empty string (i.e., its length is zero).
  type DYNAMIC_STRING is limited private;

  -- This constant represents an empty string (i.e., its length is
  -- zero and thus contains no characters).
  -- EMPTY_STR : constant DYNAMIC_STRING;
  -- Deferred constants not yet implemented so a function is used.


  function EMPTY_STR return DYNAMIC_STRING;

  procedure ASSIGN
    (STR       : in out DYNAMIC_STRING;
     D_STRING  : in     DYNAMIC_STRING);


  procedure CONVERT_TO_DYNAMIC
    (CHAR_STRING : in STRING;
     STR         : in out DYNAMIC_STRING);


  procedure APPEND
    (CHAR : in CHARACTER;
     STR  : in out DYNAMIC_STRING);


  procedure APPEND
    (CHAR_STRING : in STRING;
     STR         : in out DYNAMIC_STRING);

  procedure APPEND
    (D_STRING : in DYNAMIC_STRING;
     STR      : in out DYNAMIC_STRING);

  procedure CONVERT_TO_STRING
     (STR    : in DYNAMIC_STRING;
      CH_STR : out STRING);

  procedure SET_TOKEN_STREAM
    (LINE  : in STRING);


  procedure GET_TOKEN
    (TOKEN       : in out DYNAMIC_STRING;
     SEPARATOR   : in out CHARACTER);

  procedure RETURN_TOKEN;


  procedure GET_TOKEN
    (STR      : in out DYNAMIC_STRING;
     TOKEN    : out    DYNAMIC_STRING;
     SEPARATOR: out    CHARACTER);

  function LENGTH
    (STR : in DYNAMIC_STRING)
     return NATURAL;


  procedure READ
    (CHAR : out CHARACTER;
     STR  : in DYNAMIC_STRING);



  procedure READ
    (CHAR : out CHARACTER;
     ITH  : in POSITIVE;
     STR  : in DYNAMIC_STRING);


  function EMPTY(STR: DYNAMIC_STRING) return BOOLEAN;

  function "="
    (LEFT  : DYNAMIC_STRING;
     RIGHT : DYNAMIC_STRING)
     return BOOLEAN;

  procedure DUMP
    (TITLE : in STRING;
     STR   : in DYNAMIC_STRING);


  function NUM_OF_TOKENS
    (DYN_STR : DYNAMIC_STRING) return NATURAL;


  END_OF_STRING : exception;


private
  -- Each dynamic string is decomposed into segments which are at
  -- most SEGMENT_SIZE characters in length.  The head and tail
  -- segments may be partial(i.e. less than SEGMENT_SIZE), but all
  -- middle segments must be a full SEGMENT_SIZE in length.

  SEGMENT_SIZE : constant INTEGER := 10;
  BLANKS       : CONSTANT STRING (1..SEGMENT_SIZE) := "          ";

  type STR_REC;

  type STR_SEGMENT is access STR_REC;

  -- This data structure defines a segment of a dynamic string as
  -- follows:
  -- (  i)  STR contains this part of the string
  -- ( ii)  NEXT_SEGMENT points to the next segment in the
  --        dynamic string.
  -- (iii)  PRIOR_SEGMENT points to the previous segment in the
  --        dynamic string.
  --======================================================================
  --Note that the procedures RESET, ASSIGN, and APPEND have been written
  --so that when a new value is assigned to a dynamic string already
  --allocated segment blocks are kept in the linked list even though they
  --are not currently in use. Depending on the storage manager, this
  --approach may need modification.  Modification will also be required if
  --new strings are created using ADD rather than APPEND.
  type STR_REC is
    record
      -- SEGMENT   : STRING (1..SEGMENT_SIZE) := (1..SEGMENT_SIZE => ' ');
      -- Packed aggregates are not yet implemented.  Array must be
      -- initialized  with string of spaces.
      SEGMENT      : STRING (1..SEGMENT_SIZE) := "          ";
      NEXT_SEGMENT : STR_SEGMENT;
      PRIOR_SEGMENT: STR_SEGMENT;
    end record;

  -- This data structure defines a dynamic string that is composed
  -- of a linked list of segments that are ordered from HEAD to TAIL.
  -- NUM_CHAR indicates the length of the dynamic string (i.e., the
  -- sum of the lengths of all segments of which it is composed).
  -- FIRST is the position within the head segment of the first
  -- character.  LAST is the position within the tail segment of the
  -- last character.
  type DYNAMIC_STRING is
    record
      HEAD     : STR_SEGMENT := null;
      TAIL     : STR_SEGMENT := null;
      NUM_CHAR : NATURAL :=0;
      FIRST    : NATURAL :=0;
      LAST     : NATURAL :=0;
    end record;

end STR_PACK;



with TEXT_IO; use TEXT_IO, INTEGER_IO;
with SYSTEM;
package body STR_PACK is

  TOKEN_STREAM        : DYNAMIC_STRING;
  PSEUDO_TOKEN_STREAM : DYNAMIC_STRING;
  OLD_TOKEN_HEAD      : STR_SEGMENT;
  OLD_TOKEN_FIRST     : NATURAL;
  OLD_TOKEN_NUM_CHAR  : NATURAL;

  -- A token stream is useful to conserve heap space when a file is being
  -- processed as a sequence of dynamic strings.  By having two pointers
  -- to the same dynamic string(aliasing) the same space may be used for
  -- the next dynamic string after breaking the first one into tokens.  A
  -- special TOKEN procedure must be used in conjunction with SET_TOKEN_STREAM.
  -- That TOKEN procedure doesn't have a dynamic string for input and thus uses.
  -- PSEUDO_TOKEN_STREAM.
  procedure SET_TOKEN_STREAM
    (LINE  : in STRING) is
  begin
    CONVERT_TO_DYNAMIC(LINE, TOKEN_STREAM);
    PSEUDO_TOKEN_STREAM  := TOKEN_STREAM;
    OLD_TOKEN_HEAD       := PSEUDO_TOKEN_STREAM.HEAD;
    OLD_TOKEN_FIRST      := PSEUDO_TOKEN_STREAM.FIRST;
    OLD_TOKEN_NUM_CHAR   := PSEUDO_TOKEN_STREAM.NUM_CHAR;
  end SET_TOKEN_STREAM;

  -- This GET_TOKEN procedure may only be used in conjunction with
  -- SET_TOKEN_STREAM.  This procedure extracts a token from the
  -- PSEUDO_TOKEN_STREAM.  It also makes an additional check to convert
  -- the standard GET_TOKEN's "end of string marker  ;  " to an 'E' so that
  -- Ada syntax may be properly analyzed.
  procedure GET_TOKEN
    (TOKEN     : in out DYNAMIC_STRING;
     SEPARATOR : in out CHARACTER) is
  begin
    OLD_TOKEN_HEAD       := PSEUDO_TOKEN_STREAM.HEAD;
    OLD_TOKEN_FIRST      := PSEUDO_TOKEN_STREAM.FIRST;
    OLD_TOKEN_NUM_CHAR   := PSEUDO_TOKEN_STREAM.NUM_CHAR;
    GET_TOKEN(PSEUDO_TOKEN_STREAM, TOKEN, SEPARATOR);
    if SEPARATOR                                     = ';' and then
       LENGTH(PSEUDO_TOKEN_STREAM)                   = 0   and then
       TOKEN_STREAM.TAIL.SEGMENT(TOKEN_STREAM.LAST) /= ';' and then
       TOKEN_STREAM.TAIL.SEGMENT(TOKEN_STREAM.LAST) /= ' ' then
         SEPARATOR := 'E';
    end if;
  end GET_TOKEN;


  -- This procedure resets the pointers to the token stream so that the most
  -- recently obtained token is reinstated at the head of the stream.
  procedure RETURN_TOKEN is
  begin
    PSEUDO_TOKEN_STREAM.HEAD     := OLD_TOKEN_HEAD;
    PSEUDO_TOKEN_STREAM.FIRST    := OLD_TOKEN_FIRST;
    PSEUDO_TOKEN_STREAM.NUM_CHAR := OLD_TOKEN_NUM_CHAR;
  end RETURN_TOKEN;



  -- The is a debugging procedure which prints out a complete dynamic string,
  -- including its header information as well as all allocated space.
  procedure DUMP
    (TITLE : in STRING;
     STR   : in DYNAMIC_STRING) is
    CURRENT : STR_SEGMENT;
    COUNT   : INTEGER;
  begin
    NEW_LINE;
    PUT(TITLE);
    PUT(STR.NUM_CHAR,5); PUT(STR.FIRST,5); PUT(STR.LAST,5);

    CURRENT := STR.HEAD;
    while CURRENT /= null loop
      PUT(CURRENT.SEGMENT);
      CURRENT := CURRENT.NEXT_SEGMENT;
      COUNT := COUNT+1;
      if COUNT = 5 then
        NEW_LINE;
        COUNT := 0;
      end if;
    end loop;
    NEW_LINE;
  end DUMP;


  -- This function returns an empty string value for the private type
  -- DYNAMIC_STRING.
  function EMPTY_STR return DYNAMIC_STRING is
    STR : DYNAMIC_STRING;
  begin
    return STR;
  end EMPTY_STR;



  -- This function returns TRUE if the number of characters in a dynamic
  -- string is zero. FALSE, otherwise.
  function EMPTY(STR: DYNAMIC_STRING) return BOOLEAN is
    begin
       return STR.NUM_CHAR = 0;
    end EMPTY;


  -- This procedure resets a DYNAMIC_STRING to the empty value.  However, the
  -- HEAD pointer is left pointing to the linked list of segments so that the
  -- space may be reused.
  procedure RESET(STR : in out DYNAMIC_STRING) is
  begin
    STR.NUM_CHAR:= 0;
    STR.FIRST   := 0;
    STR.LAST    := 0;
    STR.TAIL    := STR.HEAD;
  end RESET;


  -- This procedure returns the lead character in a dynamic string.  The
  -- character is not deleted. The END_OF_STRING exception is returned
  -- if the dynamic string is empty.
  procedure READ(CHAR : out CHARACTER;
                 STR  : in DYNAMIC_STRING) is
  begin
    if STR.NUM_CHAR = 0 then
      raise END_OF_STRING;
    else
      CHAR := STR.HEAD.SEGMENT(STR.FIRST);
    end if;
  end READ;


  -- This function returns the number of characters in a dynamic string, not
  -- the amount of allocated space.
  function LENGTH
    (STR : in DYNAMIC_STRING)
     return NATURAL is
  begin
     return STR.NUM_CHAR;
  end;


  -- This procedure assigns the value of one dynamic string to another. It
  -- does not merely copy the pointer values since thsi would result in
  -- undesirable aliasing.  Each segment is copied in its entirety without
  -- realigning characters across the segments.
  procedure ASSIGN
    (STR     : in out DYNAMIC_STRING;
     D_STRING: in DYNAMIC_STRING) is
    CURRENT_SEGMENT : STR_SEGMENT;
    OLD_SEGMENT     : STR_SEGMENT;
    NEW_SEGMENT     : STR_SEGMENT;
  begin
    --First check for the empty string.
    RESET(STR);
    if D_STRING.NUM_CHAR = 0 then
      --String is empty.  We are all done.
      return;
    end if;


    --If the string was not empty, copy its contents over to STR.
    --First, set the dynamic string fields and copy over the complete
    --contents of D_STRING.HEAD.  This way the null NEXT and PRIOR_
    --SEGMENT pointers are captured for one segment strings. Note we
    --must be carefull always to create new segments and never to
    --point to segments from D_STRING.
    STR.FIRST    := D_STRING.FIRST;
    STR.LAST     := D_STRING.LAST;
    STR.NUM_CHAR := D_STRING.NUM_CHAR;
    if STR.HEAD   = null then
      STR.HEAD     := new STR_REC;
    end if;
    STR.HEAD.SEGMENT := D_STRING.HEAD.SEGMENT;

    -- Now copy over any middle segments.
    CURRENT_SEGMENT          := STR.HEAD;
    OLD_SEGMENT              := D_STRING.HEAD;
    while OLD_SEGMENT /= D_STRING.TAIL loop
      OLD_SEGMENT      := OLD_SEGMENT.NEXT_SEGMENT;

      if CURRENT_SEGMENT.NEXT_SEGMENT = null then
        NEW_SEGMENT                  := new STR_REC;
        CURRENT_SEGMENT.NEXT_SEGMENT := NEW_SEGMENT;
        NEW_SEGMENT.PRIOR_SEGMENT    := CURRENT_SEGMENT;
      else
        NEW_SEGMENT                  := CURRENT_SEGMENT.NEXT_SEGMENT;
      end if;
      NEW_SEGMENT.SEGMENT          := OLD_SEGMENT.SEGMENT;

      CURRENT_SEGMENT  := NEW_SEGMENT;
    end loop;

    --Since the contents of tail have been copied over already, merely
    --point TAIL to the current segment.
    STR.TAIL := CURRENT_SEGMENT;
  end ASSIGN;


  -- This procedure removes the first character in a dynamic string, reducing
  -- by one thelength of the string.  When the HEAD segment is emptied the HEAD
  -- pointer is moved and the space for that segment may be returned to the
  -- heap.
  procedure DELETE_CHAR
    (STR  : in out DYNAMIC_STRING) is
  begin
    if STR.NUM_CHAR = 0 then
      raise END_OF_STRING;

    else
      --Delete the first character and see if the head segment has become
      --empty.
      STR.NUM_CHAR := STR.NUM_CHAR-1;
      if STR.FIRST < SEGMENT_SIZE then
        STR.FIRST := STR.FIRST+1;
      else
        --Remove this head segment.
        STR.HEAD := STR.HEAD.NEXT_SEGMENT;
        STR.FIRST:= 1;
      end if;

      --Now check for an empty string and clean up just in case.
      if STR.NUM_CHAR = 0 then
        STR.HEAD := null;
        STR.TAIL := null;
        STR.FIRST:= 0;
        STR.LAST := 0;
      end if;
    end if;
  end DELETE_CHAR;



  -- This procedure moves characters from the dynamic string to the output
  -- string.  The number of characters moved is the minimum of the two string
  -- lengths.  The dynamic is not modified by this procedure.
  procedure CONVERT_TO_STRING
     (STR         : in DYNAMIC_STRING;
      CH_STR      : out STRING ) is
    SIZE              : NATURAL;
    POS               : NATURAL;
    CURRENT_SEGMENT   : STR_SEGMENT;
  begin
    if CH_STR'LENGTH > STR.NUM_CHAR then
      SIZE := STR.NUM_CHAR;
    else
      SIZE := CH_STR'LENGTH;
    end if;
    if SIZE = 0 then
      return;
    elsif SIZE <= SEGMENT_SIZE-STR.FIRST+1 then
      --Requested string is completely within the head segment.
      CH_STR(1..SIZE) := STR.HEAD.SEGMENT(STR.FIRST..STR.FIRST+SIZE-1);

    else
      --Requested string is split across several segments
        --Get head segment.
        POS := SEGMENT_SIZE-STR.FIRST+1;
        CH_STR(1..POS) := STR.HEAD.SEGMENT(STR.FIRST..SEGMENT_SIZE);

        --Copy over the middle segments in their entirety.
        CURRENT_SEGMENT := STR.HEAD.NEXT_SEGMENT;
        while POS+(SEGMENT_SIZE) <= SIZE loop
          CH_STR(POS+1..POS+(SEGMENT_SIZE)) := CURRENT_SEGMENT.SEGMENT;
          CURRENT_SEGMENT := CURRENT_SEGMENT.NEXT_SEGMENT;
          POS             := POS + SEGMENT_SIZE;
        end loop;

        --Get tailing segment, if necessary.
        if POS < SIZE then
          CH_STR(POS+1..SIZE) :=
                          CURRENT_SEGMENT.SEGMENT(1..SIZE-POS);
        end if;
    end if;
  end CONVERT_TO_STRING;


  -- This function is used to check for separators which are two characters in
  -- in length.  A true value is returned only if the 1st two characters of the
  -- dynamic string match the two character parameters.  The dynamic string is
  -- not modified.
  function LOOKAHEAD(STR: DYNAMIC_STRING;
                     FIRST_CH: CHARACTER;
                     NEXT_CH : CHARACTER) return boolean is
  begin
    if STR.NUM_CHAR <= 1 then
      return FALSE;
    elsif STR.HEAD.SEGMENT(STR.FIRST) /= FIRST_CH then
      return FALSE;
    else
       if STR.FIRST /= SEGMENT_SIZE then
         return STR.HEAD.SEGMENT(STR.FIRST+1)    = NEXT_CH;
       else
         return STR.HEAD.NEXT_SEGMENT.SEGMENT(1) = NEXT_CH;
       end if;
    end if;
  end LOOKAHEAD;






  -- This procedure reads the Ith character within a dynamic string, where
  -- 0 < I <= LENGTH(string).  If I <= 0, a constraint error is raised; if
  -- I > LENGTH(string) an END_OF_STRING error is raised.  The dynamic
  -- string is unmodified.
  procedure READ
    (CHAR : out CHARACTER;
     ITH  : in POSITIVE;
     STR  : in DYNAMIC_STRING) is
    POS                : NATURAL;
    CURRENT_SEGMENT    : STR_SEGMENT;
  begin
    if ITH > STR.NUM_CHAR then
      raise END_OF_STRING;

    elsif ITH <= SEGMENT_SIZE - STR.FIRST + 1 then
      --The character is positioned within the head segment so
      --retrieval is immediate.
      CHAR := STR.HEAD.SEGMENT( STR.FIRST+ITH-1 );

    else
      --The character is positioned in a segment other than the
      --head so the correct segment must be found prior to retrieval.
      POS         := ITH - (SEGMENT_SIZE-STR.FIRST+1);
      CURRENT_SEGMENT := STR.HEAD.NEXT_SEGMENT;
      while POS > SEGMENT_SIZE loop
        POS             := POS - SEGMENT_SIZE;
        CURRENT_SEGMENT := CURRENT_SEGMENT.NEXT_SEGMENT;
      end loop;
      CHAR := CURRENT_SEGMENT.SEGMENT(POS);
    end if;
  end READ;


  -- This function compares two dynamic strings on a character by character
  -- basis.  Truth is returned only if the two string are of equal length
  -- and characters at each position are equal.
  function "="
    (LEFT  : DYNAMIC_STRING;
     RIGHT : DYNAMIC_STRING)
    return BOOLEAN is

    LEFT_CHAR  : CHARACTER;
    RIGHT_CHAR : CHARACTER;
  begin
    if LEFT.NUM_CHAR = RIGHT.NUM_CHAR then

      for I in 1..LEFT.NUM_CHAR loop
        READ(LEFT_CHAR, I,  LEFT);
        READ(RIGHT_CHAR,I,  RIGHT);
        if LEFT_CHAR /= RIGHT_CHAR then
          return FALSE;
        end if;
      end loop;
      return TRUE;

    else
      return FALSE;
    end if;
  end "=";


  -- This procedure adds a character to the end of a dynamic string, allocating
  -- a new segment when necessary.
  procedure APPEND
    (CHAR : in CHARACTER;
     STR  : in out DYNAMIC_STRING) is
     OLD_TAIL : STR_SEGMENT;
  begin
    if STR.NUM_CHAR = 0 then
      --This is a null string.  Allocate one segment and insert a
      --character.
      if STR.HEAD = null then
        STR.HEAD := new STR_REC;
      end if;
      STR.TAIL := STR.HEAD;
      STR.FIRST:= 1;
      STR.LAST := 1;
      STR.HEAD.SEGMENT    := BLANKS;
      STR.HEAD.SEGMENT(1) := CHAR;

    elsif STR.LAST = SEGMENT_SIZE then
      --A new segment must be added to hold this character.
      OLD_TAIL         := STR.TAIL;
      if STR.TAIL.NEXT_SEGMENT = null then
        STR.TAIL               := new STR_REC;
        STR.TAIL.PRIOR_SEGMENT := OLD_TAIL;
      else
        STR.TAIL               := STR.TAIL.NEXT_SEGMENT;
      end if;
      STR.TAIL.SEGMENT       := BLANKS;
      STR.TAIL.SEGMENT(1)    := CHAR;
      STR.LAST               := 1;
      OLD_TAIL.NEXT_SEGMENT  := STR.TAIL;

    else
      --There is room in this segment for the character.
      STR.LAST := STR.LAST+1;
      STR.TAIL.SEGMENT(STR.LAST) := CHAR;

    end if;

    STR.NUM_CHAR := STR.NUM_CHAR+1;
  end APPEND;



  -- This procedure uses the APPEND character procedure to add a character
  -- string to the end of a dynamic string.
  procedure APPEND
    (CHAR_STRING : in STRING;
     STR  : in out DYNAMIC_STRING) is
  begin
    for I in 1..CHAR_STRING'LENGTH loop
      APPEND(CHAR_STRING(I), STR);
    end loop;
  end APPEND;


  -- This procedure uses the APPEND charater procedure to add one dynamic
  -- string to the end of another.  Characters are appended one at a time.
  -- Only the string being appended to is modified.
  procedure APPEND
    (D_STRING : in DYNAMIC_STRING;
     STR      : in out DYNAMIC_STRING) is

    CHAR : CHARACTER;
  begin
    for I in 1..D_STRING.NUM_CHAR loop
      READ(CHAR, I, D_STRING);
      APPEND(CHAR, STR);
    end loop;
  end APPEND;


  -- This procedure transfers the value of a character string to a dynamic
  -- string, replacing the original value of the dynamic string.
  procedure CONVERT_TO_DYNAMIC
    (CHAR_STRING : in STRING;
     STR  : in out DYNAMIC_STRING) is
  begin
    RESET(STR);
    APPEND(CHAR_STRING, STR);
  end CONVERT_TO_DYNAMIC;



  -- This procedure removes a token from the front of a dynamic string and
  -- also removes the token's separator.  Both the token and the separator
  -- are returned to the caller.  The separators are "  ();:\,  ", blank, and
  -- the comment delimiter --.  Extraneous blanks are ignored.  A semicolon is
  -- returned as the separator when the token is terminated by the end of string  -- An END_OF_STRING exception is raised only when the dynamic string from
  -- which the token is being extracted is already empty whe GET_TOKEN is called
  procedure GET_TOKEN
     (STR      : in out DYNAMIC_STRING;
      TOKEN    : out    DYNAMIC_STRING;
      SEPARATOR: out CHARACTER) is
     CHAR : CHARACTER;
  begin
    RESET(TOKEN);
    if EMPTY(STR) then
      raise END_OF_STRING;
    end if;

    --Get the next token and protect against end of string.
    begin
      --First skip all leading blanks
      READ(CHAR, STR);
      while CHAR = ' ' loop
        DELETE_CHAR(STR);
        READ(CHAR, STR);
      end loop;

      --Now copy characters until a separator is found.
      while CHAR /= ' ' and CHAR /= ',' and
            CHAR /= ':' and CHAR /= '\' and
            CHAR /= ';' and CHAR /= ')' and
            CHAR /= '(' and
            not LOOKAHEAD(STR, '-', '-')       loop
        APPEND(CHAR, TOKEN);
        DELETE_CHAR(STR);
        READ(CHAR, STR);
      end loop;

      --Gobble up the separator;
      SEPARATOR := CHAR;
      DELETE_CHAR(STR);
      if SEPARATOR = '-' then
        DELETE_CHAR(STR);

      else
      --Gobble up redundant blanks
        while not EMPTY(STR) loop
          READ(CHAR, STR);
          if CHAR = ' ' then
            DELETE_CHAR(STR);
          else
            exit;
          end if;
        end loop;
        if (SEPARATOR = ' ') and
           (CHAR = ',' or CHAR = ';'  or CHAR = ')'  or
            CHAR = '\' or CHAR = '('  or CHAR = ':') then
          SEPARATOR := CHAR;
          DELETE_CHAR(STR);
        end if;
      end if;


    exception
      when END_OF_STRING => SEPARATOR := ';';  --end of string is o.k. here.
    end;

  end GET_TOKEN;

  -- This function counts the number of non-empty tokens within a dynamic
  -- string.  The string is unmodified.
  function NUM_OF_TOKENS (DYN_STR : DYNAMIC_STRING) return NATURAL is

    COUNT              : NATURAL := 0;
    TEMP_STR, TOKEN : DYNAMIC_STRING;
    SEPARATOR       : CHARACTER;

  begin
    ASSIGN(TEMP_STR, DYN_STR);
    loop
      GET_TOKEN(TEMP_STR, TOKEN, SEPARATOR); -- Raises exception at EOL.
      if not EMPTY(TOKEN) then
        COUNT := COUNT + 1;
      end if;
    end loop;

  exception
    when END_OF_STRING =>
      return (COUNT);
  end;


end STR_PACK;