p_ctl_flow.c

Go to the documentation of this file.

/*

  Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.

  This program is free software; you can redistribute it and/or modify it
  under the terms of version 2 of the GNU General Public License as
  published by the Free Software Foundation.

  This program is distributed in the hope that it would be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  

  Further, this software is distributed without any warranty that it is
  free of the rightful claim of any third person regarding infringement 
  or the like.  Any license provided herein, whether implied or 
  otherwise, applies only to this software file.  Patent licenses, if 
  any, provided herein do not apply to combinations of this program with 
  other software, or any other product whatsoever.  

  You should have received a copy of the GNU General Public License along
  with this program; if not, write the Free Software Foundation, Inc., 59
  Temple Place - Suite 330, Boston MA 02111-1307, USA.

  Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
  Mountain View, CA 94043, or:

  http://www.sgi.com

  For further information regarding this notice, see:

  http://oss.sgi.com/projects/GenInfo/NoticeExplan

*/



static char USMID[] = "\n@(#)5.0_pl/sources/p_ctl_flow.c        5.11    10/12/99 10:54:10\n";

# include "defines.h"           /* Machine dependent ifdefs */

# include "host.m"              /* Host machine dependent macros.*/
# include "host.h"              /* Host machine dependent header.*/
# include "target.m"            /* Target machine dependent macros.*/
# include "target.h"            /* Target machine dependent header.*/

# include "globals.m"
# include "tokens.m"
# include "sytb.m"
# include "p_globals.m"
# include "debug.m"

# include "globals.h"
# include "tokens.h"
# include "sytb.h"
# include "p_globals.h"


/*****************************************************************\
|* Function prototypes of static functions declared in this file *|
\*****************************************************************/

static   boolean  change_subscript (opnd_type *);
static   boolean  loop_top_is_perfectly_nested (char *);
static   int      match_blk (blk_cntxt_type, boolean);
static   boolean  parse_label_list (int);
static   void     process_blockable_dir (void);
static   void     process_interchange_dir (void);
static   void     check_mp_dir_nesting (void);
static   void     gen_if_ir(int, int, int, int);


/****************************************************\
|* Static variables declared and used in this file. *|
\****************************************************/

/* The following entities are used in DO loop processing. */

static  int     last_unlbld_loop_line = 0;
static  int     last_unlbld_loop_num;

boolean star_expected = FALSE;


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      BNF        - ALLOCATE ( allocation-list [, STAT = stat-variable] )    *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void parse_allocate_stmt (void)

{
   boolean      had_stat        = FALSE;
   int          ir_idx;
   int          list1_idx;
   int          list2_idx = 0;
   opnd_type    opnd;
   boolean      parsed_ok = TRUE;
   token_type   stat_token;


   TRACE (Func_Entry, "parse_allocate_stmt", NULL);

   if (LA_CH_VALUE != LPAREN) {
      parse_err_flush(Find_EOS, "(");
      goto EXIT;
   }

   if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
      curr_stmt_category = Executable_Stmt_Cat;
   }

   NTR_IR_TBL(ir_idx);
   SH_STMT_TYPE(curr_stmt_sh_idx) = Allocate_Stmt;
   SH_IR_IDX(curr_stmt_sh_idx)    = ir_idx;
   
   IR_OPR(ir_idx)                 = Allocate_Opr;
   IR_TYPE_IDX(ir_idx)            = TYPELESS_DEFAULT_TYPE;
   IR_COL_NUM(ir_idx)             = TOKEN_COLUMN(token);
   IR_LINE_NUM(ir_idx)            = TOKEN_LINE(token);
   IR_FLD_L(ir_idx)               = IL_Tbl_Idx;
   IR_LIST_CNT_L(ir_idx)          = 0;
   
   do {
      NEXT_LA_CH;

      if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {

         if (strcmp(TOKEN_STR(token),"STAT") == 0) {
            stat_token = token;

            if (LA_CH_VALUE == EQUAL) {
               NEXT_LA_CH;
               had_stat = TRUE;

               if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
                  /* have stat var */
                  /* do that stat stuff */

                  parsed_ok = parse_deref(&opnd, NULL_IDX) && parsed_ok; 
                  COPY_OPND(IR_OPND_R(ir_idx), opnd);

                  mark_attr_defined(&opnd);
                  continue;
               } 
               else {

                  parse_err_flush(Find_Comma_Rparen,
                                  "scalar integer STAT variable");
                  continue;
               }
            } /* if (matched_specific_token(Tok_Punct_Eq, Tok_Class_Punct)) */
         } /* if (strcmp(TOKEN_STR(token),"STAT")) */

         NTR_IR_LIST_TBL(list1_idx);

         if (list2_idx) {
            IL_NEXT_LIST_IDX(list2_idx) = list1_idx;
            IL_PREV_LIST_IDX(list1_idx) = list2_idx;
         }
         else {
            IR_IDX_L(ir_idx) = list1_idx;
         }
         list2_idx = list1_idx;

         (IR_LIST_CNT_L(ir_idx))++;
         
         /* have token */
         if (had_stat) {
            PRINTMSG(TOKEN_LINE(stat_token),203, Error,
                     TOKEN_COLUMN(stat_token), NULL);
         }

         star_expected = TRUE;
         if (parse_deref(&opnd, NULL_IDX)) {
            parsed_ok =change_subscript(&opnd) && parsed_ok; 
         }
         else {
            parsed_ok = FALSE;
         }
         star_expected = FALSE;

         COPY_OPND(IL_OPND(list1_idx), opnd);

         if (LA_CH_VALUE != COMMA && LA_CH_VALUE != RPAREN) {

            parse_err_flush(Find_Comma_Rparen,", or )");
         }

         if (LA_CH_VALUE == EOS) {
            goto EXIT;
         }

      } else {
         parse_err_flush(Find_EOS, "allocation object or STAT = ");
         goto EXIT;
      }
   }
   while (LA_CH_VALUE == COMMA);

   if (LA_CH_VALUE != RPAREN) {
      parse_err_flush(Find_EOS, ")");
   }
   else {
      NEXT_LA_CH;
   }

EXIT:
      
   if (LA_CH_VALUE != EOS) {
      parse_err_flush(Find_EOS, EOS_STR);
   } 

   matched_specific_token(Tok_EOS, Tok_Class_Punct);

   TRACE (Func_Exit, "parse_allocate_stmt", NULL);

   return;

}  /* parse_allocate_stmt */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This procedure parses the ASSIGN statement:                           *|
|*                                                                            *|
|*           ASSIGN label TO scalar-int-variable                              *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Global data changed:                                                       *|
|*      curr_stmt_category                                                    *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void    parse_assign_stmt(void)

{
   opnd_type            asg_var_opnd;
   token_type           asg_var_token;
   int                  attr_idx;
   int                  name_idx;
   int                  ir_idx;


   TRACE (Func_Entry, "parse_assign_stmt", NULL);

   if ( ! CURR_BLK_NO_EXEC  ||  ! iss_blk_stk_err() ) {
      curr_stmt_category = Executable_Stmt_Cat;
   }

   /* ASSIGN statement is obsolescent.                                        */

   PRINTMSG(stmt_start_line, 1568, Ansi, stmt_start_col, "ASSIGN");

   NTR_IR_TBL(ir_idx);
   SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
   IR_OPR(ir_idx)              = Asg_Opr;
   IR_TYPE_IDX(ir_idx)         = TYPELESS_DEFAULT_TYPE;
   IR_LINE_NUM(ir_idx)         = TOKEN_LINE(token);
   IR_COL_NUM(ir_idx)          = TOKEN_COLUMN(token);

   /* Have the keyword ASSIGN.  The next token must be a label.               */

   if (MATCHED_TOKEN_CLASS(Tok_Class_Label)) {

      if (TOKEN_ERR(token)) {
         parse_err_flush(Find_EOS, NULL);
         goto EXIT;
      }

      attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx); 
  
      if (attr_idx == NULL_IDX) {
         attr_idx                = ntr_sym_tbl(&token, name_idx);
         AT_OBJ_CLASS(attr_idx)  = Label;
         AT_REFERENCED(attr_idx) = Referenced;
         LN_DEF_LOC(name_idx)    = TRUE;
         build_fwd_ref_entry(attr_idx, Assign_Ref);
      }
      else if (! AT_DCL_ERR(attr_idx) ) {

         if (AT_DEFINED(attr_idx) ) {
                 
            /* If the ASSIGN stmt is:  "10   ASSIGN 10 TO var", need to set   */
            /* ATL_EXECUTABLE now so label_ref_semantics will work correctly. */

            if (stmt_label_idx != NULL_IDX  &&  
                ATL_DEF_STMT_IDX(attr_idx) == curr_stmt_sh_idx) {
               ATL_EXECUTABLE(attr_idx) = TRUE;
            }

            label_ref_semantics(attr_idx, Assign_Ref, NULL_IDX,
                                TOKEN_LINE(token), TOKEN_COLUMN(token));
         }
         else {
            build_fwd_ref_entry(attr_idx, Assign_Ref);
         }
      }
      else {
         SH_ERR_FLG(curr_stmt_sh_idx) = TRUE; 
      }

      ATL_IN_ASSIGN(attr_idx) = TRUE;
      AT_REFERENCED(attr_idx) = Referenced;

      IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
      IR_COL_NUM_L(ir_idx)  = TOKEN_COLUMN(token);
      IR_FLD_L(ir_idx)      = AT_Tbl_Idx;
      IR_IDX_L(ir_idx)      = attr_idx;

      if (cif_flags & XREF_RECS) {
         cif_usage_rec(attr_idx, AT_Tbl_Idx,
                       IR_LINE_NUM_L(ir_idx), IR_COL_NUM_L(ir_idx),
                       CIF_Label_Referenced_In_ASSIGN);
      }

      if (matched_specific_token(Tok_Kwd_To, Tok_Class_Keyword)) {

         if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
            asg_var_token = token;
        
            if (parse_deref(&asg_var_opnd, NULL_IDX)) {
   
               if (OPND_FLD(asg_var_opnd) == AT_Tbl_Idx) {
                  COPY_OPND(IR_OPND_R(ir_idx), asg_var_opnd);
                
                  if (AT_OBJ_CLASS(OPND_IDX(asg_var_opnd)) == Data_Obj) {
                     ATD_IN_ASSIGN(OPND_IDX(asg_var_opnd)) = TRUE;
                  }

                  mark_attr_defined(&asg_var_opnd);

                  if (LA_CH_VALUE != EOS) {
                     parse_err_flush(Find_EOS, EOS_STR);
                  }
               }
               else {
                  PRINTMSG(TOKEN_LINE(asg_var_token), 172, Error, 
                           TOKEN_COLUMN(asg_var_token));
                  parse_err_flush(Find_EOS, NULL);
                  SH_ERR_FLG(curr_stmt_sh_idx) = TRUE;  
               }
            }
            else {     /* Id found but error later in the reference.         */
               parse_err_flush(Find_EOS, NULL);
            }
        }
        else {     /* No Id found at all.                                    */
           parse_err_flush(Find_EOS, "scalar-int-variable");
        }
      }
      else {
         parse_err_flush(Find_EOS, "TO");
      }
   }
   else {
      parse_err_flush(Find_EOS, "label");
   }

EXIT:

   matched_specific_token(Tok_EOS, Tok_Class_Punct);

   TRACE (Func_Exit, "parse_assign_stmt", NULL);

   return;

}  /* parse_assign_stmt */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE                          *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void parse_call_stmt (void)

{
   boolean   amb_ref = FALSE;
   int       attr_idx;
   int       call_idx;
   int       col;
   int       host_attr_idx;
   int       host_name_idx;
   int       line;
   int       name_idx;
   opnd_type opnd;
   boolean   parsed_ok = TRUE;


   TRACE (Func_Entry, "parse_call_stmt", NULL);

   if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
      curr_stmt_category = Executable_Stmt_Cat;
   }

   if (cmd_line_flags.debug_lvl == Debug_Lvl_1) {  /* -ez  -G1 */
      gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX);
   }

   NTR_IR_TBL(call_idx);
   SH_IR_IDX(curr_stmt_sh_idx) = call_idx;

   IR_OPR(call_idx)            = Call_Opr;
   IR_TYPE_IDX(call_idx)       = TYPELESS_DEFAULT_TYPE;
   IR_COL_NUM(call_idx)        = TOKEN_COLUMN(token);
   IR_LINE_NUM(call_idx)       = TOKEN_LINE(token);

   if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
      line = TOKEN_LINE(token);
      col = TOKEN_COLUMN(token);

      attr_idx = srch_sym_tbl(TOKEN_STR(token), 
                              TOKEN_LEN(token),
                              &name_idx);

      if (attr_idx != NULL_IDX) {
         host_attr_idx = attr_idx;

         if (! LN_DEF_LOC(name_idx)) {
            amb_ref = TRUE;

            while (AT_ATTR_LINK(host_attr_idx) != NULL_IDX) {
               host_attr_idx = AT_ATTR_LINK(host_attr_idx);
            }
         }
      }
      else { /* any other reference is ambiguous */
         amb_ref = TRUE;

         /* search host sym tab */

         host_attr_idx = srch_host_sym_tbl(TOKEN_STR(token),
                                           TOKEN_LEN(token), 
                                           &host_name_idx,
                                           TRUE);

         /* if we are copying info down from the host scope */

         if (host_attr_idx != NULL_IDX) { 

            if (LA_CH_VALUE != LPAREN &&
                AT_IS_INTRIN(host_attr_idx) &&
                AT_OBJ_CLASS(host_attr_idx) == Interface &&
                (strcmp(AT_OBJ_NAME_PTR(host_attr_idx), "SYNCHRONIZE") != 0) &&
                (strcmp(AT_OBJ_NAME_PTR(host_attr_idx), "RANDOM_SEED") != 0)) {
               host_attr_idx = NULL_IDX;
            }

            /* We don't want to copy down the host attr if the host */
            /* attr is a FUNCTION attr.  We are dealing with a CALL */
            /* at this point.                                       */

            if (AT_IS_INTRIN(host_attr_idx) &&
                AT_OBJ_CLASS(host_attr_idx) == Interface &&
                ATI_INTERFACE_CLASS(host_attr_idx) == 
                                                   Generic_Function_Interface) {
               host_attr_idx = NULL_IDX;
            }
         }

         if (host_attr_idx != NULL_IDX) { /* copy the attr into the local scp */
            attr_idx = ntr_host_in_sym_tbl(&token, 
                                           name_idx,
                                           host_attr_idx, 
                                           host_name_idx, 
                                           TRUE);

            AT_ATTR_LINK(attr_idx) = host_attr_idx;

            while (AT_ATTR_LINK(host_attr_idx) != NULL_IDX) {
               host_attr_idx = AT_ATTR_LINK(host_attr_idx);
            }

            if (AT_IS_INTRIN(host_attr_idx) &&
                AT_OBJ_CLASS(host_attr_idx) == Interface) {

               if (ATI_FIRST_SPECIFIC_IDX(host_attr_idx) == NULL_IDX) {
                  complete_intrinsic_definition(host_attr_idx);
               }

               /* copy intrinsic attr to the local scope from the 0th scope */
               /* and break the link to the host scope.                     */
               COPY_ATTR_NTRY(attr_idx, host_attr_idx);
               AT_CIF_SYMBOL_ID(attr_idx)       = 0;
               AT_ATTR_LINK(attr_idx)           = NULL_IDX;
               host_attr_idx                    = NULL_IDX;
               AT_DEF_LINE(attr_idx)            = TOKEN_LINE(token);
               AT_DEF_COLUMN(attr_idx)          = TOKEN_COLUMN(token);
               attr_idx                         = srch_sym_tbl(TOKEN_STR(token),
                                                               TOKEN_LEN(token),
                                                               &name_idx);
            }
         }
      }

      if (attr_idx == NULL_IDX) {
         attr_idx                       = ntr_sym_tbl(&token, name_idx);
         AT_OBJ_CLASS(attr_idx)         = Pgm_Unit;
         ATP_PGM_UNIT(attr_idx)         = Subroutine;
         ATP_SCP_IDX(attr_idx)          = curr_scp_idx;
         MAKE_EXTERNAL_NAME(attr_idx, 
                            AT_NAME_IDX(attr_idx),
                            AT_NAME_LEN(attr_idx));
         ATP_PROC(attr_idx)             = Unknown_Proc;
      }
      else if (!amb_ref) {

         if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit &&
             !AT_NOT_VISIBLE(attr_idx) &&
             (ATP_PGM_UNIT(attr_idx) == Subroutine ||
              ATP_PGM_UNIT(attr_idx) == Pgm_Unknown)) {
             ATP_PGM_UNIT(attr_idx) = Subroutine;
         }
         else if (fnd_semantic_err(Obj_Use_Extern_Subr, 
                                   line,
                                   col,
                                   attr_idx,
                                   TRUE)) {
            parse_err_flush(Find_EOS, NULL);
            parsed_ok = FALSE;
            goto EXIT;
         }
         else if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
            chg_data_obj_to_pgm_unit(attr_idx, Subroutine, Extern_Proc);
         }
      }
      else {
         if (AT_OBJ_CLASS(attr_idx) == Interface) {
            /* do nothing if it is an interface */
         }
         else if (AT_REFERENCED(attr_idx) == Not_Referenced &&
                  AT_OBJ_CLASS(attr_idx) == Data_Obj) {

            /* assumes that if not referenced then we just put it in */

            chg_data_obj_to_pgm_unit(attr_idx, Subroutine, Extern_Proc);
         }
      }

      AT_REFERENCED(attr_idx) = Referenced;
      IR_FLD_L(call_idx)      = AT_Tbl_Idx;
      IR_IDX_L(call_idx)      = attr_idx;
      IR_LINE_NUM_L(call_idx) = line;
      IR_COL_NUM_L(call_idx)  = col;

      if (LA_CH_VALUE == LPAREN) {
         parsed_ok = parse_actual_arg_spec(&opnd, FALSE, attr_idx) && 
                     parsed_ok;
         COPY_OPND(IR_OPND_R(call_idx), opnd);
      }
      else {

         if (LA_CH_VALUE != EOS) {
            parse_err_flush(Find_EOS, "( or "EOS_STR);
            parsed_ok = FALSE;
         }
         else {
            IR_FLD_R(call_idx)      = IL_Tbl_Idx;
            IR_IDX_R(call_idx)      = NULL_IDX;
            IR_LIST_CNT_R(call_idx) = 0;
         }
      }
   }
   else {
      parse_err_flush(Find_EOS, "SUBROUTINE NAME");
      parsed_ok = FALSE;
   }

EXIT:
   
   if (LA_CH_VALUE != EOS) {
      parse_err_flush(Find_EOS, EOS_STR);
      parsed_ok = FALSE;
   }

   matched_specific_token(Tok_EOS, Tok_Class_Punct);

   SH_ERR_FLG(curr_stmt_sh_idx) = ! parsed_ok;

   TRACE (Func_Exit, "parse_call_stmt", NULL);

   return;

}  /* parse_call_stmt */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Parse a CASE statement of a SELECT CASE construct.                    *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void parse_case_stmt (void)

{
   int          blk_idx;
   int          case_ir_idx;
   int          case_lbl_idx;
   int          cont_stmt_sh_idx;
   int          expr_start_col;
   int          expr_start_line;
   boolean      fnd_colon;
   boolean      fnd_default             = FALSE;
   boolean      fnd_name                = FALSE;
   int          ir_idx;
   boolean      matched_blk             = FALSE;
   int          num_cases               = 0;
   opnd_type    opnd;
   int          range_ir_idx;
   int          save_curr_stmt_sh_idx;


   TRACE (Func_Entry, "parse_case_stmt", NULL);

   check_for_vestigial_task_blks();

   /* PDGCS wants a label to precede each CASE in a CASE construct.  If a     */
   /* case-selector contains more than one case-value-range, only one label   */
   /* is generated to precede the first CASE SH.  Insert a CONTINUE stmt      */
   /* ahead of the CASE SH to define the label needed by PDGCS.  If the CASE  */
   /* stmt is labeled, insert the CONTINUE ahead of the user label.           */

   save_curr_stmt_sh_idx = curr_stmt_sh_idx;

   if (SH_LABELED(curr_stmt_sh_idx)) {
      curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
   }

   /* Back up before the debug label, if one has been generated in p_driver. */

   if (cmd_line_flags.debug_lvl == Debug_Lvl_0 &&
       SH_IR_IDX(curr_stmt_sh_idx) != NULL_IDX &&
       IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) == Label_Opr) {  /* -ed  -G0 */

      curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
   }

   gen_sh(Before, Continue_Stmt, stmt_start_line, stmt_start_col,
          FALSE, TRUE, TRUE);

   cont_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);

   case_lbl_idx = gen_internal_lbl(stmt_start_line);

   NTR_IR_TBL(ir_idx);
   SH_IR_IDX(cont_stmt_sh_idx) = ir_idx;
   IR_OPR(ir_idx)              = Label_Opr;
   /* LRR - bhj put in short typeless as type idx */
   IR_TYPE_IDX(ir_idx)         = TYPELESS_DEFAULT_TYPE;
   IR_LINE_NUM(ir_idx)         = stmt_start_line;
   IR_COL_NUM(ir_idx)          = stmt_start_col;
   IR_LINE_NUM_L(ir_idx)       = stmt_start_line;
   IR_COL_NUM_L(ir_idx)        = stmt_start_col;
   IR_FLD_L(ir_idx)            = AT_Tbl_Idx;
   IR_IDX_L(ir_idx)            = case_lbl_idx;
     
   AT_REFERENCED(case_lbl_idx)    = Referenced;
   AT_DEFINED(case_lbl_idx)       = TRUE;
   AT_DEF_LINE(case_lbl_idx)      = stmt_start_line;
   ATL_DEF_STMT_IDX(case_lbl_idx) = cont_stmt_sh_idx;

   curr_stmt_sh_idx = save_curr_stmt_sh_idx;

   /* Generate the Case IR.  By default, set the right operand to point at    */
   /* the constant 0 to indicate that there is only a single case value for   */
   /* this case.  If a comma is encountered, the right operand will be        */
   /* switched to point to the constant 1.  PDGCS needs this flag.            */

   NTR_IR_TBL(case_ir_idx);
   SH_IR_IDX(curr_stmt_sh_idx) = case_ir_idx;
   IR_OPR(case_ir_idx)         = Case_Opr;
   /* LRR - bhj put in short typeless as type idx */
   IR_TYPE_IDX(case_ir_idx)    = TYPELESS_DEFAULT_TYPE;
   IR_LINE_NUM(case_ir_idx)    = stmt_start_line;
   IR_COL_NUM(case_ir_idx)     = stmt_start_col;
   IR_FLD_R(case_ir_idx)       = CN_Tbl_Idx;
   IR_IDX_R(case_ir_idx)       = CN_INTEGER_ZERO_IDX;
   IR_LINE_NUM_R(case_ir_idx)  = stmt_start_line;
   IR_COL_NUM_R(case_ir_idx)   = stmt_start_col;

   if (LA_CH_VALUE == LPAREN) {

      /* ATL_CASE_LABEL is to be set to TRUE only for non-DEFAULT CASE stmts. */

      ATL_CASE_LABEL(case_lbl_idx) = TRUE;


      do {
 
         /* First trip through, eat the left paren.  All subsequent trips,    */
         /* eat the comma.                                                    */

         NEXT_LA_CH;

         opnd = null_opnd;

         if (LA_CH_VALUE != COLON) {
            strcpy(parse_operand_insert, "operand or :");
         
            /* Capture the first character of the case-value expression for   */
            /* better diagnostics in the Semantics Pass.                      */

            expr_start_line = LA_CH_LINE;
            expr_start_col  = LA_CH_COLUMN;

            if (! parse_expr(&opnd)) {
               parse_err_flush(Find_Rparen, NULL);
               break;
            }

            fnd_colon = FALSE;
         }

         if (LA_CH_VALUE == COLON) {
            fnd_colon = TRUE;
            NTR_IR_TBL(range_ir_idx);
            /* LRR - bhj put in short typeless as type idx */
            IR_FLD_L(case_ir_idx)     = IR_Tbl_Idx;
            IR_IDX_L(case_ir_idx)     = range_ir_idx;
            IR_OPR(range_ir_idx)      = Case_Range_Opr;
            IR_TYPE_IDX(range_ir_idx) = TYPELESS_DEFAULT_TYPE;
            IR_LINE_NUM(range_ir_idx) = LA_CH_LINE;
            IR_COL_NUM(range_ir_idx)  = LA_CH_COLUMN;

            if (OPND_FLD(opnd) != NO_Tbl_Idx) {
               COPY_OPND(IR_OPND_L(range_ir_idx), opnd);
               IR_LINE_NUM_L(range_ir_idx) = expr_start_line;
               IR_COL_NUM_L(range_ir_idx)  = expr_start_col;
            } 

            NEXT_LA_CH;

            if (LA_CH_VALUE != COMMA  &&  LA_CH_VALUE != RPAREN) {
               strcpy(parse_operand_insert, "operand, comma, or )");

               expr_start_line = LA_CH_LINE;
               expr_start_col  = LA_CH_COLUMN;

               if (parse_expr(&opnd)) {
                  COPY_OPND(IR_OPND_R(range_ir_idx), opnd);
                  IR_LINE_NUM_R(range_ir_idx) = expr_start_line;
                  IR_COL_NUM_R(range_ir_idx)  = expr_start_col;
               }
               else {
                  parse_err_flush(Find_Rparen, NULL);
               }
            }
            else {

               if (OPND_FLD(opnd) == NO_Tbl_Idx) {
                  PRINTMSG(IR_LINE_NUM(range_ir_idx), 789, Error, 
                           IR_COL_NUM(range_ir_idx));
                  continue;
               }
          
            }
         }
         else {
            COPY_OPND(IR_OPND_L(case_ir_idx), opnd);
            IR_LINE_NUM_L(case_ir_idx) = expr_start_line;
            IR_COL_NUM_L(case_ir_idx)  = expr_start_col;
         }

         ++num_cases;

         /* Link this CASE stmt to its parent SELECT CASE stmt.  The Block    */
         /* Stack checks for complete validity are made later.  Assume we     */
         /* have correct cases for now (and if we don't, not setting          */
         /* SH_PARENT_BLK_IDX won't make any difference any how).             */
   
         if (CURR_BLK == Select_Blk) {
            SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX;
         }
         else if (CURR_BLK == Case_Blk  &&
                  BLK_TYPE(blk_stk_idx - 1) == Select_Blk) {
            SH_PARENT_BLK_IDX(curr_stmt_sh_idx) =
               BLK_FIRST_SH_IDX(blk_stk_idx - 1);
         }
    
         /* If there is another case-value, generate an SH for it.  Indicate  */
         /* that this CASE stmt has multiple case-values by setting the right */
         /* operand index to point to 1.                                      */

         if (LA_CH_VALUE == COMMA) {
            IR_IDX_R(case_ir_idx) = CN_INTEGER_ONE_IDX;

            gen_sh(After, Case_Stmt, stmt_start_line, stmt_start_col, FALSE,
                   FALSE, TRUE);

            NTR_IR_TBL(case_ir_idx);
            SH_IR_IDX(curr_stmt_sh_idx) = case_ir_idx;
            IR_OPR(case_ir_idx)         = Case_Opr;
            /* LRR - bhj put in short typeless as type idx */
            IR_TYPE_IDX(case_ir_idx)    = TYPELESS_DEFAULT_TYPE;
            IR_LINE_NUM(case_ir_idx)    = stmt_start_line;
            IR_COL_NUM(case_ir_idx)     = stmt_start_col;
            IR_FLD_R(case_ir_idx)       = CN_Tbl_Idx;
            IR_IDX_R(case_ir_idx)       = CN_INTEGER_ZERO_IDX;
            IR_LINE_NUM_R(case_ir_idx)  = stmt_start_line;
            IR_COL_NUM_R(case_ir_idx)   = stmt_start_col;
         }

      } while (LA_CH_VALUE == COMMA);

      if (LA_CH_VALUE == RPAREN) {
         NEXT_LA_CH;
      }
      else {
         parse_err_flush(Find_EOS,
                         (fnd_colon) ? "comma or )" : "comma, :, or )");
      }

      fnd_name = MATCHED_TOKEN_CLASS(Tok_Class_Id);
   }
   else if (matched_specific_token(Tok_Kwd_Default, Tok_Class_Keyword)) {
      fnd_name    = MATCHED_TOKEN_CLASS(Tok_Class_Id);
      fnd_default = TRUE;
   }
   else {
      parse_err_flush(Find_EOS, "( or DEFAULT");
   }

   if (LA_CH_VALUE != EOS) {
      parse_err_flush(Find_EOS, EOS_STR);
   }


   if (STMT_LEGAL_IN_BLK(Case_Stmt, CURR_BLK)) {

      matched_blk = (fnd_name) ? (CURR_BLK_NAME != NULL_IDX &&
                                 (compare_names(TOKEN_ID(token).words,
                                             TOKEN_LEN(token),
                                             AT_OBJ_NAME_LONG(CURR_BLK_NAME),
                                             AT_NAME_LEN(CURR_BLK_NAME)) == 0)):
                                 TRUE;
   }

   if (matched_blk) {

      if ((cif_flags & XREF_RECS) && fnd_name && matched_blk) {
         cif_usage_rec(CURR_BLK_NAME, AT_Tbl_Idx,
                       TOKEN_LINE(token), TOKEN_COLUMN(token),
                       CIF_Construct_Name_Reference);
      }
      curr_stmt_category = Executable_Stmt_Cat;
      blk_idx            = (CURR_BLK == Select_Blk) ?
                              blk_stk_idx : blk_stk_idx - 1;
   }
   else {
      blk_idx = blk_match_err(Select_Blk, fnd_name, FALSE);

      if (blk_idx == NULL_IDX) {
         goto EXIT;
      }

      if (CURR_BLK == Case_Blk) {
         blk_idx = blk_stk_idx - 1;
      }
      else if (CURR_BLK == Select_Blk) {
         blk_idx = blk_stk_idx;
      } 
      else {
         goto EXIT;
      }
   }

   BLK_NUM_CASES(blk_idx) += num_cases;

   if (fnd_default) {

      if (BLK_FND_DEFAULT(blk_idx)  &&  ! BLK_ERR(blk_idx)) {

         /* This SELECT has a default CASE already.                           */

         PRINTMSG(stmt_start_line, 159, Error, stmt_start_col,
                  BLK_DEF_LINE(blk_idx));
      }
      else {
         BLK_CASE_DEFAULT_LBL_LINE_NUM(blk_idx) = stmt_start_line;
         BLK_CASE_DEFAULT_LBL_COL_NUM(blk_idx)  = stmt_start_col;
         BLK_CASE_DEFAULT_LBL_FLD(blk_idx)      = AT_Tbl_Idx;
         BLK_CASE_DEFAULT_LBL_IDX(blk_idx)      = case_lbl_idx;
      }
 
      BLK_FND_DEFAULT(blk_idx) = TRUE;
   }

   if (CURR_BLK == Case_Blk) {

      /* Reuse the Block Stack frame.                                         */

      CURR_BLK_DEF_LINE   = stmt_start_line;
      CURR_BLK_DEF_COLUMN = stmt_start_col;

      /* Generate a GO TO at the end of the previous CASE block to branch to  */
      /* the end of the construct.                                            */

      save_curr_stmt_sh_idx = curr_stmt_sh_idx;
      curr_stmt_sh_idx      = cont_stmt_sh_idx;

      gen_sh(Before, Goto_Stmt, SH_GLB_LINE(SH_PREV_IDX(curr_stmt_sh_idx)),
             SH_COL_NUM(SH_PREV_IDX(curr_stmt_sh_idx)), FALSE, FALSE, TRUE);

      curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);

      NTR_IR_TBL(ir_idx);
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
      IR_OPR(ir_idx)              = Br_Uncond_Opr;
      /* LRR - bhj put in short typeless as type idx */
      IR_TYPE_IDX(ir_idx)         = TYPELESS_DEFAULT_TYPE;
      IR_LINE_NUM(ir_idx)         = SH_GLB_LINE(curr_stmt_sh_idx);
      IR_COL_NUM(ir_idx)          = SH_COL_NUM(curr_stmt_sh_idx);
      IR_LINE_NUM_R(ir_idx)       = IR_LINE_NUM(ir_idx); 
      IR_COL_NUM_R(ir_idx)        = IR_COL_NUM(ir_idx); 
      IR_FLD_R(ir_idx)            = AT_Tbl_Idx;
      IR_IDX_R(ir_idx)            = BLK_LABEL(blk_idx);

      curr_stmt_sh_idx = save_curr_stmt_sh_idx;
   }
   else {
      PUSH_BLK_STK(Case_Blk);
      CURR_BLK_ERR  = BLK_ERR(blk_idx);
      CURR_BLK_NAME = BLK_NAME(blk_idx);
   }

   CURR_BLK_FIRST_SH_IDX = curr_stmt_sh_idx;
   LINK_TO_PARENT_BLK;

   if (cif_flags & MISC_RECS) {
      cif_stmt_type_rec(TRUE,
                        (fnd_default) ? CIF_Case_Default_Stmt : CIF_Case_Stmt,
                        statement_number);
   }

EXIT:

   NEXT_LA_CH;
   strcpy(parse_operand_insert, "operand");

   TRACE (Func_Exit, "parse_case_stmt", NULL);

   return;

}  /* parse_case_stmt */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE                          *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void parse_continue_stmt (void)

{
   TRACE (Func_Entry, "parse_continue_stmt", NULL);

   if (LA_CH_VALUE != EOS) {
      parse_err_flush(Find_EOS, EOS_STR);
   }

   if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
      curr_stmt_category = Executable_Stmt_Cat;
   }

   NEXT_LA_CH;

   TRACE (Func_Exit, "parse_continue_stmt", NULL);

   return;

}  /* parse_continue_stmt */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Parse the CYCLE statement.  If a matching DO construct is found,      *|
|*      generate the internal cycle point label and a Br_Uncond IR to jump to *|
|*      it.                                                                   *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void parse_cycle_stmt (void)

{
   int          blk_idx;
   boolean      fnd_name        = FALSE;
   int          ir_idx;


   TRACE (Func_Entry, "parse_cycle_stmt", NULL);

   if (LA_CH_VALUE != EOS) {
      fnd_name = MATCHED_TOKEN_CLASS(Tok_Class_Id);

      if (fnd_name) {

         if (LA_CH_VALUE != EOS) {
            parse_err_flush(Find_EOS, EOS_STR);
         }

      }
      else {
         parse_err_flush(Find_EOS, "construct-name or EOS");
         goto EXIT;
      }

   }

   blk_idx = match_blk(Do_Blk, fnd_name);

   if (blk_idx != NULL_IDX) {

      if (! CURR_BLK_NO_EXEC  ||  ! iss_blk_stk_err()) {
         curr_stmt_category              = Executable_Stmt_Cat;
         SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
         BLK_CYCLE_STMT(blk_idx)         = TRUE;

         NTR_IR_TBL(ir_idx);
         SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
         IR_OPR(ir_idx)              = Br_Uncond_Opr;
         /* LRR - bhj put in short typeless as type idx */
         IR_TYPE_IDX(ir_idx)         = TYPELESS_DEFAULT_TYPE;
         IR_LINE_NUM(ir_idx)         = stmt_start_line;
         IR_COL_NUM(ir_idx)          = stmt_start_col;
         IR_LINE_NUM_R(ir_idx)       = stmt_start_line;
         IR_COL_NUM_R(ir_idx)        = stmt_start_col;
         IR_FLD_R(ir_idx)            = AT_Tbl_Idx;
         IR_IDX_R(ir_idx)            = gen_loop_lbl_name(blk_idx, Cycle_Lbl);

         if (fnd_name  &&  (cif_flags & XREF_RECS)) {
            cif_usage_rec(BLK_NAME(blk_idx), AT_Tbl_Idx, 
                          TOKEN_LINE(token), TOKEN_COLUMN(token),
                          CIF_Construct_Name_Reference);
         }
      }  

   }
   else {
      PRINTMSG(stmt_start_line, 262, Error, stmt_start_col, "CYCLE");
   }

EXIT:

   NEXT_LA_CH;
   
   TRACE (Func_Exit, "parse_cycle_stmt", NULL);

   return;

}  /* parse_cycle_stmt */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      BNF       - DEALLOCATE ( allocation-list [, STAT = stat-variable] )   *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void parse_deallocate_stmt (void)

{
   boolean      had_stat        = FALSE;
   int          ir_idx;
   int          list1_idx;
   int          list2_idx       = 0;
   opnd_type    opnd;
   boolean      parsed_ok = TRUE;
   token_type   stat_token;


   TRACE (Func_Entry, "parse_deallocate_stmt", NULL);

   if (LA_CH_VALUE != LPAREN) {
      parse_err_flush(Find_EOS, "(");
      goto EXIT;
   }

   if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
      curr_stmt_category = Executable_Stmt_Cat;
   }

   NTR_IR_TBL(ir_idx);
   SH_STMT_TYPE(curr_stmt_sh_idx) = Deallocate_Stmt;
   SH_IR_IDX(curr_stmt_sh_idx)    = ir_idx;

   IR_OPR(ir_idx)                 = Deallocate_Opr;
   IR_TYPE_IDX(ir_idx)            = TYPELESS_DEFAULT_TYPE;
   IR_COL_NUM(ir_idx)             = TOKEN_COLUMN(token);
   IR_LINE_NUM(ir_idx)            = TOKEN_LINE(token);
   IR_FLD_L(ir_idx)               = IL_Tbl_Idx;
   IR_LIST_CNT_L(ir_idx)          = 0;

   do {
      NEXT_LA_CH;

      if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {

         if (strcmp(TOKEN_STR(token),"STAT") == 0) {
            stat_token = token;

            if (LA_CH_VALUE == EQUAL) {
               NEXT_LA_CH;
               had_stat = TRUE;

               if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
                  /* have stat var */
                  /* do that stat stuff */

                  parsed_ok = parse_deref(&opnd, NULL_IDX) && parsed_ok;
                  COPY_OPND(IR_OPND_R(ir_idx), opnd);

                  mark_attr_defined(&opnd);
                  continue;
               } 
               else {

                  parse_err_flush(Find_Comma_Rparen,
                                  "scalar integer STAT variable");
                  continue;
               }
            } /* if (matched_specific_token(Tok_Punct_Eq, Tok_Class_Punct)) */
         } /* if (strcmp(TOKEN_STR(token),"STAT")) */
        
         NTR_IR_LIST_TBL(list1_idx);

         if (list2_idx) {
            IL_NEXT_LIST_IDX(list2_idx) = list1_idx;
            IL_PREV_LIST_IDX(list1_idx) = list2_idx;
         }
         else {
            IR_IDX_L(ir_idx) = list1_idx;
         }
         list2_idx = list1_idx;

         (IR_LIST_CNT_L(ir_idx))++;

         /* have token */
         if (had_stat) {
            PRINTMSG(TOKEN_LINE(stat_token), 203, Error,
                     TOKEN_COLUMN(stat_token), NULL);
         }

         if (parse_deref(&opnd, NULL_IDX)) {
            parsed_ok = change_subscript(&opnd) && parsed_ok;/*don't know why it's dispeared-Dec*/
         }
         else {
            parsed_ok = FALSE;
         }

         COPY_OPND(IL_OPND(list1_idx), opnd);

         if (LA_CH_VALUE != COMMA && LA_CH_VALUE != RPAREN) {

            parse_err_flush(Find_Comma_Rparen,", or )");
         }
         
         if (LA_CH_VALUE == EOS) {
            goto EXIT;
         }

      } else {
         parse_err_flush(Find_EOS, "allocation object or STAT = ");
         goto EXIT;
      }
   }
   while (LA_CH_VALUE == COMMA);

   if (LA_CH_VALUE != RPAREN) {
      parse_err_flush(Find_EOS, ")");
   }
   else {
      NEXT_LA_CH;
   }

EXIT:

   if (LA_CH_VALUE != EOS) {
      parse_err_flush(Find_EOS, EOS_STR);
   }

   matched_specific_token(Tok_EOS, Tok_Class_Punct);

   TRACE (Func_Exit, "parse_deallocate_stmt", NULL);

   return;

}  /* parse_deallocate_stmt */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This function parses all forms of the DO statement.                   *|
|*                                                                            *|
|*      R819  label-do-stmt  is  [do-construct-name:] DO label [loop-control] *|
|*      R820  nonlabel-do-stmt  is  [do-construct-name:] DO [loop-control]    *|
|*      R821  loop-control   is  [,] do-variable = scalar-numeric-expr,       *|
|*                                   scalar-numeric-expr, scalar-numeric-expr *|
|*                           or  [,] WHILE(scalar-logical-expr)               *|
|*                                                                            *|
|*      The leading token possibilities are:                                  *|
|*                                                                            *|
|*                                     DO                                     *|
|*                                     |                                      *|
|*                   -----------------------------------------------------    *|
|*                   |                      |          |         |       |    *|
|*                 label                    ,        WHILE   variable   EOS   *|
|*                   |                      |                                 *|
|*        ----------------------        ----------                            *|
|*        |          |         |        |        |                            *|
|*        ,       variable   WHILE   variable  WHILE                          *|
|*        |                                                                   *|
|*   ------------                                                             *|
|*   |          |                                                             *|
|*  variable  WHILE                                                           *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void parse_do_stmt (void)

{
   int          blk_idx;
   int          cif_il_idx;
   boolean      comma_found     = FALSE;
   opnd_type    do_variable;
   int          expr_start_col;
   int          expr_start_line;
   int          idx;
   int          il_idx;
   int          il_idx_2;
   boolean      label_found     = FALSE;
   int          last_il_idx;
   int          loop_info_idx;
   int          loop_control_il_idx;
   opnd_type    loop_expr;
   int          loop_labels_il_idx;
   int          mp_nest_list_idx = NULL_IDX;
   int          mp_prev_idx;
   int          name_idx;
   opnd_type    while_expr;


   TRACE (Func_Entry, "parse_do_stmt", NULL);

   if (! CURR_BLK_NO_EXEC  ||  ! iss_blk_stk_err()) {

      if (cdir_switches.doall_sh_idx != NULL_IDX) {
         PUSH_BLK_STK (Doall_Blk);
         BLK_IS_PARALLEL_REGION(blk_stk_idx)    = TRUE;
         CURR_BLK_FIRST_SH_IDX     = cdir_switches.doall_sh_idx;
         cdir_switches.doall_sh_idx = NULL_IDX;
         cdir_switches.doall_region = TRUE;
      }
      else if (cdir_switches.doacross_sh_idx != NULL_IDX) {
         /* need BLK stack stuff here BHJ */
         PUSH_BLK_STK (SGI_Doacross_Blk);
         BLK_IS_PARALLEL_REGION(blk_stk_idx)    = TRUE;
         CURR_BLK_FIRST_SH_IDX     = cdir_switches.doacross_sh_idx;
         mp_nest_list_idx = IR_IDX_L(SH_IR_IDX(
                                        cdir_switches.doacross_sh_idx));

         idx = 0;

         while (idx < MP_DIR_NEST_IDX) {
            mp_nest_list_idx =
                       IL_NEXT_LIST_IDX(mp_nest_list_idx);
            idx++;
         }

         if (IL_FLD(mp_nest_list_idx) == NO_Tbl_Idx) {
            NTR_IR_LIST_TBL(idx);
            IL_FLD(mp_nest_list_idx) = IL_Tbl_Idx;
            IL_IDX(mp_nest_list_idx) = idx;
            IL_LIST_CNT(mp_nest_list_idx) = 1;
            mp_prev_idx = mp_nest_list_idx;
            mp_nest_list_idx = idx;
         }
         else {
            mp_nest_list_idx = NULL_IDX;
         }

         cdir_switches.dir_nest_check_sh_idx = cdir_switches.doacross_sh_idx;
         cdir_switches.doacross_sh_idx = NULL_IDX;
      }
      else if (cdir_switches.paralleldo_sh_idx != NULL_IDX) {
         /* need BLK stack stuff here BHJ */
         PUSH_BLK_STK (SGI_Parallel_Do_Blk);
         BLK_IS_PARALLEL_REGION(blk_stk_idx)    = TRUE;
         CURR_BLK_FIRST_SH_IDX     = cdir_switches.paralleldo_sh_idx;
         mp_nest_list_idx = IR_IDX_L(SH_IR_IDX(
                                        cdir_switches.paralleldo_sh_idx));

         idx = 0;

         while (idx < MP_DIR_NEST_IDX) {
            mp_nest_list_idx =
                       IL_NEXT_LIST_IDX(mp_nest_list_idx);
            idx++;
         }

         if (IL_FLD(mp_nest_list_idx) == NO_Tbl_Idx) {
            NTR_IR_LIST_TBL(idx);
            IL_FLD(mp_nest_list_idx) = IL_Tbl_Idx;
            IL_IDX(mp_nest_list_idx) = idx;
            IL_LIST_CNT(mp_nest_list_idx) = 1;
            mp_prev_idx = mp_nest_list_idx;
            mp_nest_list_idx = idx;
         }
         else {
            mp_nest_list_idx = NULL_IDX;
         }

         cdir_switches.dir_nest_check_sh_idx = cdir_switches.paralleldo_sh_idx;
         cdir_switches.paralleldo_sh_idx = NULL_IDX;
      }
      else if (cdir_switches.pdo_sh_idx != NULL_IDX) {
         /* need BLK stack stuff here BHJ */
         PUSH_BLK_STK (SGI_Pdo_Blk);
         BLK_IS_PARALLEL_REGION(blk_stk_idx)    = TRUE;
         CURR_BLK_FIRST_SH_IDX     = cdir_switches.pdo_sh_idx;
         mp_nest_list_idx = IR_IDX_L(SH_IR_IDX(
                                        cdir_switches.pdo_sh_idx));

         idx = 0;

         while (idx < MP_DIR_NEST_IDX) {
            mp_nest_list_idx =
                       IL_NEXT_LIST_IDX(mp_nest_list_idx);
            idx++;
         }

         if (IL_FLD(mp_nest_list_idx) == NO_Tbl_Idx) {
            NTR_IR_LIST_TBL(idx);
            IL_FLD(mp_nest_list_idx) = IL_Tbl_Idx;
            IL_IDX(mp_nest_list_idx) = idx;
            IL_LIST_CNT(mp_nest_list_idx) = 1;
            mp_prev_idx = mp_nest_list_idx;
            mp_nest_list_idx = idx;
         }
         else {
            mp_nest_list_idx = NULL_IDX;
         }

         cdir_switches.dir_nest_check_sh_idx = cdir_switches.pdo_sh_idx;
         cdir_switches.pdo_sh_idx = NULL_IDX;
      }
      else if (cdir_switches.dopar_sh_idx != NULL_IDX) {
         PUSH_BLK_STK (Do_Parallel_Blk);
         CURR_BLK_FIRST_SH_IDX     = cdir_switches.dopar_sh_idx;
         cdir_switches.dopar_sh_idx = NULL_IDX;
      }
      else if (cdir_switches.do_omp_sh_idx != NULL_IDX) {
         PUSH_BLK_STK (Open_Mp_Do_Blk);
         BLK_IS_PARALLEL_REGION(blk_stk_idx)    = TRUE;
         mp_nest_list_idx = IR_IDX_L(SH_IR_IDX(
                                        cdir_switches.do_omp_sh_idx));

         idx = 0;

         while (idx < OPEN_MP_NEST_IDX) {
            mp_nest_list_idx =
                       IL_NEXT_LIST_IDX(mp_nest_list_idx);
            idx++;
         }

         if (IL_FLD(mp_nest_list_idx) == NO_Tbl_Idx) {
            NTR_IR_LIST_TBL(idx);
            IL_FLD(mp_nest_list_idx) = IL_Tbl_Idx;
            IL_IDX(mp_nest_list_idx) = idx;
            IL_LIST_CNT(mp_nest_list_idx) = 1;
            mp_prev_idx = mp_nest_list_idx;
            mp_nest_list_idx = idx;
         }
         else {
            mp_nest_list_idx = NULL_IDX;
         }

         CURR_BLK_FIRST_SH_IDX     = cdir_switches.do_omp_sh_idx;
         cdir_switches.do_omp_sh_idx = NULL_IDX;
      }
      else if (cdir_switches.paralleldo_omp_sh_idx != NULL_IDX) {
         PUSH_BLK_STK (Open_Mp_Parallel_Do_Blk);
         BLK_IS_PARALLEL_REGION(blk_stk_idx)    = TRUE;
         mp_nest_list_idx = IR_IDX_L(SH_IR_IDX(
                                        cdir_switches.paralleldo_omp_sh_idx));

         idx = 0;

         while (idx < OPEN_MP_NEST_IDX) {
            mp_nest_list_idx =
                       IL_NEXT_LIST_IDX(mp_nest_list_idx);
            idx++;
         }

         if (IL_FLD(mp_nest_list_idx) == NO_Tbl_Idx) {
            NTR_IR_LIST_TBL(idx);
            IL_FLD(mp_nest_list_idx) = IL_Tbl_Idx;
            IL_IDX(mp_nest_list_idx) = idx;
            IL_LIST_CNT(mp_nest_list_idx) = 1;
            mp_prev_idx = mp_nest_list_idx;
            mp_nest_list_idx = idx;
         }
         else {
            mp_nest_list_idx = NULL_IDX;
         }

         CURR_BLK_FIRST_SH_IDX     = cdir_switches.paralleldo_omp_sh_idx;
         cdir_switches.paralleldo_omp_sh_idx = NULL_IDX;
      }

      PUSH_BLK_STK (Do_Blk);
      curr_stmt_category = Executable_Stmt_Cat;
   }
   else {

      if (cdir_switches.doall_sh_idx != NULL_IDX) {
         PUSH_BLK_STK (Doall_Blk);
         BLK_IS_PARALLEL_REGION(blk_stk_idx)    = TRUE;
         CURR_BLK_FIRST_SH_IDX     = cdir_switches.doall_sh_idx;
         cdir_switches.doall_sh_idx = NULL_IDX;
         cdir_switches.doall_region = TRUE;
      }
      else if (cdir_switches.doacross_sh_idx != NULL_IDX) {
         /* need BLK stack stuff here BHJ */
         PUSH_BLK_STK (SGI_Doacross_Blk);
         BLK_IS_PARALLEL_REGION(blk_stk_idx)    = TRUE;
         CURR_BLK_FIRST_SH_IDX     = cdir_switches.doacross_sh_idx;
         cdir_switches.dir_nest_check_sh_idx = cdir_switches.doacross_sh_idx;
         cdir_switches.doacross_sh_idx = NULL_IDX;
      }
      else if (cdir_switches.paralleldo_sh_idx != NULL_IDX) {
         /* need BLK stack stuff here BHJ */
         PUSH_BLK_STK (SGI_Parallel_Do_Blk);
         BLK_IS_PARALLEL_REGION(blk_stk_idx)    = TRUE;
         CURR_BLK_FIRST_SH_IDX     = cdir_switches.paralleldo_sh_idx;
         cdir_switches.dir_nest_check_sh_idx = cdir_switches.paralleldo_sh_idx;
         cdir_switches.paralleldo_sh_idx = NULL_IDX;
      }
      else if (cdir_switches.pdo_sh_idx != NULL_IDX) {
         /* need BLK stack stuff here BHJ */
         PUSH_BLK_STK (SGI_Pdo_Blk);
         BLK_IS_PARALLEL_REGION(blk_stk_idx)    = TRUE;
         CURR_BLK_FIRST_SH_IDX     = cdir_switches.pdo_sh_idx;
         cdir_switches.dir_nest_check_sh_idx = cdir_switches.pdo_sh_idx;
         cdir_switches.pdo_sh_idx = NULL_IDX;
      }
      else if (cdir_switches.dopar_sh_idx != NULL_IDX) {
         PUSH_BLK_STK (Do_Parallel_Blk);
         CURR_BLK_FIRST_SH_IDX     = cdir_switches.dopar_sh_idx;
         cdir_switches.dopar_sh_idx = NULL_IDX;
      }
      else if (cdir_switches.do_omp_sh_idx != NULL_IDX) {
         PUSH_BLK_STK (Open_Mp_Do_Blk);
         BLK_IS_PARALLEL_REGION(blk_stk_idx)    = TRUE;
         CURR_BLK_FIRST_SH_IDX     = cdir_switches.do_omp_sh_idx;
         cdir_switches.do_omp_sh_idx = NULL_IDX;
      }
      else if (cdir_switches.paralleldo_omp_sh_idx != NULL_IDX) {
         PUSH_BLK_STK (Open_Mp_Parallel_Do_Blk);
         BLK_IS_PARALLEL_REGION(blk_stk_idx)    = TRUE;
         CURR_BLK_FIRST_SH_IDX     = cdir_switches.paralleldo_omp_sh_idx;
         cdir_switches.paralleldo_omp_sh_idx = NULL_IDX;
      }

      PUSH_BLK_STK (Do_Blk);
      CURR_BLK_ERR = TRUE;
   }

   CURR_BLK_FIRST_SH_IDX = curr_stmt_sh_idx;
   LINK_TO_PARENT_BLK;

   /* Generate the Loop_Info IR.  It's left operand will eventually point at  */
   /* the SH for the stmt that ends the loop.  It's right operand will point  */
   /* at a series of ILs.  The first IL will point at a list of ILs that      */
   /* represent the loop control info (for iterative or WHILE loops); for an  */
   /* infinite loop, there is no loop control info so the first IL is null.   */
   /* The second IL will point at a list of ILs for the top, bottom, and skip */
   /* labels for an iterative or WHILE loop; for an infinite loop, the IL     */
   /* will point directly at the top label.                                   */
   /* If Miscellaneous CIF records are being produced, a third IL exists in   */
   /* the chain attached to the Loop_Info IR.  This IL points at a list of    */
   /* ILs for the DO construct name and the loop label.                       */

   NTR_IR_TBL(loop_info_idx);
   SH_IR_IDX(curr_stmt_sh_idx) = loop_info_idx;
   IR_OPR(loop_info_idx)       = Loop_Info_Opr;
   /* LRR - bhj put in short typeless as type idx */
   IR_TYPE_IDX(loop_info_idx)  = TYPELESS_DEFAULT_TYPE;
   IR_LINE_NUM(loop_info_idx)  = stmt_start_line;
   IR_COL_NUM(loop_info_idx)   = stmt_start_col;

   NTR_IR_LIST_TBL(loop_control_il_idx);
   IR_LIST_CNT_R(loop_info_idx) = 1;
   IR_FLD_R(loop_info_idx)      = IL_Tbl_Idx;
   IR_IDX_R(loop_info_idx)      = loop_control_il_idx;

   NTR_IR_LIST_TBL(loop_labels_il_idx);
   IL_NEXT_LIST_IDX(loop_control_il_idx) = loop_labels_il_idx;
   IL_PREV_LIST_IDX(loop_labels_il_idx)  = loop_control_il_idx;
   ++IR_LIST_CNT_R(loop_info_idx);

   if (cif_flags & MISC_RECS) {
      NTR_IR_LIST_TBL(cif_il_idx);
      IL_NEXT_LIST_IDX(loop_labels_il_idx) = cif_il_idx;
      IL_PREV_LIST_IDX(cif_il_idx)         = loop_labels_il_idx;
      ++IR_LIST_CNT_R(loop_info_idx);

      /* Always generate the ILs for the construct name and loop label if     */
      /* these "labels" are to be saved.                                      */

      NTR_IR_LIST_TBL(il_idx);
      NTR_IR_LIST_TBL(il_idx_2);
      IL_NEXT_LIST_IDX(il_idx)   = il_idx_2;
      IL_PREV_LIST_IDX(il_idx_2) = il_idx;

      IL_FLD(cif_il_idx)      = IL_Tbl_Idx;
      IL_IDX(cif_il_idx)      = il_idx;
      IL_LIST_CNT(cif_il_idx) = 2;
   }

   if (stmt_construct_idx != NULL_IDX) {
      CURR_BLK_NAME                        = stmt_construct_idx;
      ATL_CLASS(stmt_construct_idx)        = Lbl_Construct;
      ATL_DEF_STMT_IDX(stmt_construct_idx) = curr_stmt_sh_idx;
      SH_ERR_FLG(curr_stmt_sh_idx)         = SH_ERR_FLG(curr_stmt_sh_idx) |
                                                AT_DCL_ERR(stmt_construct_idx);

      /* Save the construct name's Attr index in the second IL attached to the*/
      /* CIF IL node.  It's needed for production of the Loop Definition      */
      /* record in the Semantics Pass.  (Can't output the record now because  */
      /* the DO-variable of an iterative DO hasn't been resolved.)            */

      if (cif_flags & MISC_RECS) {
         IL_FLD(il_idx_2) = AT_Tbl_Idx;
         IL_IDX(il_idx_2) = stmt_construct_idx;
         IL_LINE_NUM(il_idx_2) = stmt_start_line;
         IL_COL_NUM(il_idx_2)  = stmt_start_col;
      }

      stmt_construct_idx = NULL_IDX;
   }
   
   if (MATCHED_TOKEN_CLASS(Tok_Class_Label)  &&  ! TOKEN_ERR(token)) {

      CURR_BLK_LABEL = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token),
                                    &name_idx); 

      if (CURR_BLK_LABEL == NULL_IDX) {
         CURR_BLK_LABEL                         = ntr_sym_tbl(&token, name_idx);
         AT_OBJ_CLASS(CURR_BLK_LABEL)           = Label;
         LN_DEF_LOC(name_idx)                   = TRUE;

         if (cmd_line_flags.debug_lvl == Debug_Lvl_1) {  /* -ez  -G1 */
            ATL_DEBUG_CLASS(CURR_BLK_LABEL)     = Ldbg_User_Lbl;
         }
      }
      else if (AT_DEFINED(CURR_BLK_LABEL)) {
         PRINTMSG(TOKEN_LINE(token), 248, Error, TOKEN_COLUMN(token));
         parse_err_flush(Find_EOS, NULL);
         goto EXIT;
      }

      AT_REFERENCED(CURR_BLK_LABEL) = Referenced;
      label_found                   = TRUE;

      build_fwd_ref_entry(CURR_BLK_LABEL, Do_Ref); 

      blk_idx = blk_stk_idx - 1;
      
      while (BLK_IS_PARALLEL_REGION(blk_idx) ||
             BLK_TYPE(blk_idx) == Do_Parallel_Blk  ||
             BLK_TYPE(blk_idx) == Wait_Blk ||
             BLK_TYPE(blk_idx) == SGI_Region_Blk ||
             BLK_TYPE(blk_idx) == Open_Mp_Section_Blk) {
         blk_idx--;
      }

      if (BLK_TYPE(blk_idx) == Do_Blk  &&
          BLK_LABEL(blk_idx) == CURR_BLK_LABEL) {

         if (BLK_LOOP_NUM(blk_idx) == MAX_BLK_LOOP_NUM) {
            PRINTMSG(stmt_start_line, 1324, Internal,  stmt_start_col,
                     MAX_BLK_LOOP_NUM);
         }
         else {
            BLK_LOOP_NUM(blk_stk_idx) = BLK_LOOP_NUM(blk_idx) + 1;
         }
      }
      else {
         BLK_LOOP_NUM(blk_stk_idx) = 1;
      }

      if (cif_flags & XREF_RECS) {
         cif_usage_rec(CURR_BLK_LABEL, AT_Tbl_Idx,
                       TOKEN_LINE(token), TOKEN_COLUMN(token),
                       CIF_Do_Loop_Label);
      }

      /* Save the loop label's Attr index in the first IL attached to the     */
      /* CIF IL node.  It's also needed for production of the Loop Definition */
      /* record in the Semantics Pass.                                        */

      if (cif_flags & MISC_RECS) {
         IL_FLD(il_idx) = AT_Tbl_Idx;
         IL_IDX(il_idx) = CURR_BLK_LABEL;
         IL_LINE_NUM(il_idx) = stmt_start_line;
         IL_COL_NUM(il_idx)  = stmt_start_col;
      }
   }
   else {

      if (last_unlbld_loop_line == stmt_start_line) {

         if (last_unlbld_loop_num == MAX_BLK_LOOP_NUM) {
            PRINTMSG(stmt_start_line, 1324, Internal,  stmt_start_col,
                     MAX_BLK_LOOP_NUM);
         }
         else {
            BLK_LOOP_NUM(blk_stk_idx) = ++last_unlbld_loop_num;
         }
      }
      else {
         last_unlbld_loop_line = stmt_start_line;
         last_unlbld_loop_num  = 1;
         BLK_LOOP_NUM(blk_stk_idx) = 1;
      }
   }

   if (LA_CH_VALUE == COMMA) {
      NEXT_LA_CH;
      comma_found = TRUE;
   }

   
   if (matched_specific_token(Tok_Kwd_While, Tok_Class_Keyword)) {

      /* -------------------------------------------------------------------- */
      /*                             DO WHILE                                 */
      /* -------------------------------------------------------------------- */

      if (LA_CH_VALUE == LPAREN) {
         NEXT_LA_CH;
         SH_STMT_TYPE(curr_stmt_sh_idx) = Do_While_Stmt;
         stmt_type                      = Do_While_Stmt;
         BLK_DO_TYPE(blk_stk_idx)       = While_Loop;

         expr_start_line = LA_CH_LINE;
         expr_start_col  = LA_CH_COLUMN;

         if (parse_expr(&while_expr)) {
     
            if (LA_CH_VALUE == RPAREN) {
               NEXT_LA_CH;

               if (LA_CH_VALUE == EOS) {

                  NTR_IR_LIST_TBL(il_idx);
                  IL_LIST_CNT(loop_control_il_idx) = 1;
                  IL_FLD(loop_control_il_idx)      = IL_Tbl_Idx;
                  IL_IDX(loop_control_il_idx)      = il_idx;
                  COPY_OPND(IL_OPND(il_idx), while_expr);
                  IL_LINE_NUM(il_idx)              = expr_start_line;
                  IL_COL_NUM(il_idx)               = expr_start_col;

                  /* Generate the name of the skip label.                     */
                  /* Attach it to the loop labels IL node.                    */

                  BLK_SKIP_LBL_IDX(blk_stk_idx) =
                     gen_loop_lbl_name(blk_stk_idx, Skip_Lbl);

                  if (BLK_SKIP_LBL_IDX(blk_stk_idx) == NULL_IDX) {
                     goto EXIT;
                  }

# ifndef _HIGH_LEVEL_DO_LOOP_FORM

                  NTR_IR_LIST_TBL(il_idx);
                  IL_LIST_CNT(loop_labels_il_idx) = 1;
                  IL_FLD(loop_labels_il_idx)      = IL_Tbl_Idx;
                  IL_IDX(loop_labels_il_idx)      = il_idx;

                  IL_LINE_NUM(il_idx) = stmt_start_line;
                  IL_COL_NUM(il_idx)  = stmt_start_col;
                  IL_FLD(il_idx)      = AT_Tbl_Idx;
                  IL_IDX(il_idx)      = BLK_SKIP_LBL_IDX(blk_stk_idx);


                  /* Generate the name of the top-of-loop label.              */
                  /* Attach it to the loop labels IL node ahead of the skip   */
                  /* label IL.                                                */

                  NTR_IR_LIST_TBL(il_idx);
                  IL_NEXT_LIST_IDX(il_idx) = IL_IDX(loop_labels_il_idx);
                  IL_PREV_LIST_IDX(IL_IDX(loop_labels_il_idx)) = il_idx;

                  ++IL_LIST_CNT(loop_labels_il_idx);
                  IL_IDX(loop_labels_il_idx) = il_idx;

                  IL_LINE_NUM(il_idx) = stmt_start_line;
                  IL_COL_NUM(il_idx)  = stmt_start_col;
                  IL_FLD(il_idx)      = AT_Tbl_Idx;
                  IL_IDX(il_idx)      = gen_loop_lbl_name(blk_stk_idx, Top_Lbl);

                  AT_DEFINED(IL_IDX(il_idx))  = TRUE;

# endif

                  if (cif_flags & MISC_RECS) {
                     cif_stmt_type_rec(TRUE, 
                                       (CURR_BLK_LABEL == NULL_IDX) ?
                                          CIF_Do_Unlabeled_While_Stmt :
                                          CIF_Do_Labeled_While_Stmt,
                                          statement_number);
                  }
               }
               else {
                  parse_err_flush(Find_EOS, EOS_STR);
               }
            }
            else {
               parse_err_flush(Find_EOS, ")");
            }
         }
         else {
            parse_err_flush(Find_EOS, NULL);
         }
      }
      else if (LA_CH_CLASS == Ch_Class_Letter  ||
               LA_CH_CLASS == Ch_Class_Digit   ||
               LA_CH_VALUE == USCORE           || 
               LA_CH_VALUE == DOLLAR           ||
               LA_CH_VALUE == AT_SIGN) {
         reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
         goto CHECK_FOR_VARIABLE;
      }
      else {
         parse_err_flush(Find_EOS, "( or =");
      }

      goto EXIT;
   }


CHECK_FOR_VARIABLE:

   if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {

      /* -------------------------------------------------------------------- */
      /*                               Iterative DO                           */
      /* -------------------------------------------------------------------- */

      SH_STMT_TYPE(curr_stmt_sh_idx) = Do_Iterative_Stmt;
      stmt_type                      = Do_Iterative_Stmt;
      BLK_DO_TYPE(blk_stk_idx)       = Iterative_Loop;

      expr_start_line = TOKEN_LINE(token);
      expr_start_col  = TOKEN_COLUMN(token);

      if (parse_deref(&do_variable, NULL_IDX)) {

         if (mp_nest_list_idx != NULL_IDX) {
            COPY_OPND(IL_OPND(mp_nest_list_idx), do_variable);
         }

         COPY_OPND(BLK_DO_VAR_OPND(blk_stk_idx), do_variable);
         BLK_DO_VAR_LINE_NUM(blk_stk_idx) = expr_start_line;
         BLK_DO_VAR_COL_NUM(blk_stk_idx)  = expr_start_col;
      
         NTR_IR_LIST_TBL(last_il_idx);
         IL_LIST_CNT(loop_control_il_idx) = 1;
         IL_FLD(loop_control_il_idx)      = IL_Tbl_Idx;
         IL_IDX(loop_control_il_idx)      = last_il_idx;
         COPY_OPND(IL_OPND(last_il_idx), BLK_DO_VAR_OPND(blk_stk_idx));
         
         if (BLK_DO_VAR_FLD(blk_stk_idx) == AT_Tbl_Idx) {

            /* If the DO-variable is a function result, we need to set       */
            /* AT_DEFINED in the functions' Attr now because                 */
            /* prog_unit_semantics checks this right away in the Semantics   */ 
            /* Pass driver (if the flag is not set, a warning is issued about*/
            /* the function result not being defined).                       */

            if (AT_OBJ_CLASS(OPND_IDX(do_variable)) == Data_Obj  &&
                ATD_CLASS(OPND_IDX(do_variable)) == Function_Result) {
               AT_DEFINED(ATD_FUNC_IDX(OPND_IDX(do_variable))) = TRUE;
            }


            blk_idx = blk_stk_idx - 1;

            while (BLK_TYPE(blk_idx) > Module_Proc_Blk) {
         
               if (BLK_TYPE(blk_idx) == Do_Blk) {
            
                  if ((BLK_DO_VAR_FLD(blk_idx) ==
                       BLK_DO_VAR_FLD(blk_stk_idx))       && 
                      (BLK_DO_VAR_IDX(blk_idx) == 
                       BLK_DO_VAR_IDX(blk_stk_idx))       &&
                      ! BLK_ERR(blk_idx)) {
                     PRINTMSG(TOKEN_LINE(token), 517, Error,
                              TOKEN_COLUMN(token));
                     break;
                  }
               }

               --blk_idx;
            }
         }

# if defined(CDIR_INTERCHANGE)
         process_interchange_dir();
# endif

# if defined(CDIR_BLOCKABLE)
         process_blockable_dir();
# endif

# if defined(GENERATE_WHIRL)
         check_mp_dir_nesting();
# endif

      }
      else {
         parse_err_flush(Find_EOS, NULL);
         goto EXIT;
      }

      if (LA_CH_VALUE == EQUAL) {
         NEXT_LA_CH;
      }
      else {
         parse_err_flush(Find_EOS, "=");
         goto EXIT;
      }
     
      /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
      /* Parse the start expression.                                          */
      /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

      expr_start_line = LA_CH_LINE;
      expr_start_col  = LA_CH_COLUMN;

      if (parse_expr(&loop_expr)) {

         /* Note:  parse_expr can return TRUE even though an error message is */
         /* produced (like if the start value is a constant with an invalid   */
         /* kind parameter).  This will cause the DO SH to be marked in       */
         /* error but that's OK.                                              */

         if (! SH_ERR_FLG(curr_stmt_sh_idx)) {
            NTR_IR_LIST_TBL(il_idx);
            IL_NEXT_LIST_IDX(last_il_idx) = il_idx;
            IL_PREV_LIST_IDX(il_idx)      = last_il_idx;
            COPY_OPND(IL_OPND(il_idx), loop_expr);
            IL_LINE_NUM(il_idx)           = expr_start_line;
            IL_COL_NUM(il_idx)            = expr_start_col;
            last_il_idx                   = il_idx;
            ++IL_LIST_CNT(loop_control_il_idx);
         }
         else {
            parse_err_flush(Find_EOS, NULL);
            goto EXIT;
         }
      }
      else {
         parse_err_flush(Find_EOS, NULL);
         goto EXIT;
      }

      if (LA_CH_VALUE == COMMA) {
         NEXT_LA_CH;
      }
      else {
         parse_err_flush(Find_EOS, ",");
         goto EXIT;
      }

      /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
      /* Parse the end expression.                                            */
      /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

      expr_start_line = LA_CH_LINE;
      expr_start_col  = LA_CH_COLUMN;

      if (parse_expr(&loop_expr)) {

         /* parse_expr could return TRUE because the expression is            */
         /* sytactically correct but an error message could still have been   */
         /* issued (like for a constant that has an invalid type parameter    */
         /* value attached to it) so SH_ERR_FLG of the current stmt must also */
         /* be checked.                                                       */

         if (! SH_ERR_FLG(curr_stmt_sh_idx)) {
            NTR_IR_LIST_TBL(il_idx);
            IL_NEXT_LIST_IDX(last_il_idx) = il_idx;
            IL_PREV_LIST_IDX(il_idx)      = last_il_idx;
            COPY_OPND(IL_OPND(il_idx), loop_expr);
            IL_LINE_NUM(il_idx)           = expr_start_line;
            IL_COL_NUM(il_idx)            = expr_start_col;
            last_il_idx                   = il_idx;
            ++IL_LIST_CNT(loop_control_il_idx);
         }
         else {
            parse_err_flush(Find_EOS, NULL);
            goto EXIT;
         }
      }
      else {
         parse_err_flush(Find_EOS, NULL);
         goto EXIT;
      }

      /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
      /* Parse the inc expression.                                            */
      /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

      if (LA_CH_VALUE == COMMA) {
         NEXT_LA_CH;
         expr_start_line = LA_CH_LINE;
         expr_start_col  = LA_CH_COLUMN;
           
         if (parse_expr(&loop_expr)) {

            if (LA_CH_VALUE == EOS) {
                  
               /* parse_expr could return TRUE because the expression is      */
               /* sytactically correct but an error message could still have  */
               /* been issued (like for a constant that has an invalid type   */
               /* parameter value attached to it) so SH_ERR_FLG of the        */
               /* current stmt must also be checked.                          */
           
               if (! SH_ERR_FLG(curr_stmt_sh_idx)) {
                  NTR_IR_LIST_TBL(il_idx);
                  IL_NEXT_LIST_IDX(last_il_idx) = il_idx;
                  IL_PREV_LIST_IDX(il_idx)      = last_il_idx;
                  COPY_OPND(IL_OPND(il_idx), loop_expr);
                  IL_LINE_NUM(il_idx)           = expr_start_line;
                  IL_COL_NUM(il_idx)            = expr_start_col;
                  ++IL_LIST_CNT(loop_control_il_idx);
               }
               else {
                  parse_err_flush(Find_EOS, NULL);
               }
            }
            else {
               parse_err_flush(Find_EOS, EOS_STR);
            }
         }
         else {
            parse_err_flush(Find_EOS, NULL);
         }
      }
      else if (LA_CH_VALUE == EOS) {
         NTR_IR_LIST_TBL(il_idx);
         IL_NEXT_LIST_IDX(last_il_idx) = il_idx;
         IL_PREV_LIST_IDX(il_idx)      = last_il_idx;
         IL_LINE_NUM(il_idx)           = expr_start_line;
         IL_COL_NUM(il_idx)            = expr_start_col;
         IL_FLD(il_idx)                = CN_Tbl_Idx;
         IL_IDX(il_idx)                = CN_INTEGER_ONE_IDX;
         ++IL_LIST_CNT(loop_control_il_idx);
      } 
      else {
         parse_err_flush(Find_EOS, ", or EOS");
      }

      /* Generate the name of the skip label.  (It gets entered in the        */
      /* dictionary and the current block stack entry.)  It's generated now   */
      /* so that we can tell if there are overlapped blocking stmts (see      */
      /* gen_loop_lbl_name for details).  If there are overlapped blocking    */
      /* stmts, we'll never get to the interface so don't bother doing        */
      /* anything more for this DO loop.                                      */
      /* Note:  The skip label is generated even when doing "one-trip" DO     */
      /* loops (so overlapping block errors will be caught).  The label won't */
      /* be used.                                                             */

# ifndef _HIGH_LEVEL_DO_LOOP_FORM

      NTR_IR_LIST_TBL(il_idx);
      IL_LIST_CNT(loop_labels_il_idx) = 1;
      IL_FLD(loop_labels_il_idx)      = IL_Tbl_Idx;
      IL_IDX(loop_labels_il_idx)      = il_idx;

# endif

      BLK_SKIP_LBL_IDX(blk_stk_idx) = gen_loop_lbl_name(blk_stk_idx, Skip_Lbl);

      if (BLK_SKIP_LBL_IDX(blk_stk_idx) != NULL_IDX) {

# ifndef _HIGH_LEVEL_DO_LOOP_FORM

         IL_FLD(il_idx)      = AT_Tbl_Idx;
         IL_IDX(il_idx)      = BLK_SKIP_LBL_IDX(blk_stk_idx);
         IL_LINE_NUM(il_idx) = expr_start_line;
         IL_COL_NUM(il_idx)  = expr_start_col;

# endif

      }
      else {
         goto EXIT;
      }

     
# ifndef _HIGH_LEVEL_DO_LOOP_FORM

      /* Generate the name of the top-of-loop label.  (It gets entered in the */
      /* dictionary and the current block stack entry.)  Put its IL ahead of  */
      /* the IL for the skip label.                                           */

      NTR_IR_LIST_TBL(il_idx);
      ++IL_LIST_CNT(loop_labels_il_idx);
      IL_NEXT_LIST_IDX(il_idx) = IL_IDX(loop_labels_il_idx);
      IL_PREV_LIST_IDX(IL_IDX(loop_labels_il_idx)) = il_idx;
      IL_IDX(loop_labels_il_idx)                   = il_idx;

      BLK_TOP_LBL_IDX(blk_stk_idx) = gen_loop_lbl_name(blk_stk_idx, Top_Lbl);

      IL_LINE_NUM(il_idx) = stmt_start_line;
      IL_COL_NUM(il_idx)  = stmt_start_col;
      IL_FLD(il_idx)      = AT_Tbl_Idx;
      IL_IDX(il_idx)      = BLK_TOP_LBL_IDX(blk_stk_idx);

# endif

      if (cif_flags & MISC_RECS) {
         cif_stmt_type_rec(TRUE, 
                           (CURR_BLK_LABEL == NULL_IDX) ?
                              CIF_Do_Unlabeled_Iterative_Stmt :
                              CIF_Do_Labeled_Iterative_Stmt,
                           statement_number);
      }

      goto EXIT;
    }


   /* ----------------------------------------------------------------------- */
   /* Is this an "infinite" DO loop (that is, "DO ... END DO" or              */
   /* "DO <label> ... <label> <term-stmt>")?                                  */
   /* ----------------------------------------------------------------------- */

   if (LA_CH_VALUE == EOS) {

      if (comma_found) {
         parse_err_flush(Find_EOS, "do-variable or WHILE");
      }
      else {
         SH_STMT_TYPE(curr_stmt_sh_idx) = Do_Infinite_Stmt;
         stmt_type                      = Do_Infinite_Stmt;
         BLK_DO_TYPE(blk_stk_idx)       = Infinite_Loop;

         /* Generate the name of the top-of-loop label.                       */

         NTR_IR_LIST_TBL(il_idx);
         IL_LIST_CNT(loop_labels_il_idx) = 1;
         IL_FLD(loop_labels_il_idx)      = IL_Tbl_Idx;
         IL_IDX(loop_labels_il_idx)      = il_idx;

# ifndef _ACSET

         IL_LINE_NUM(il_idx) = stmt_start_line;
         IL_COL_NUM(il_idx)  = stmt_start_col;
         IL_FLD(il_idx)      = AT_Tbl_Idx;
         IL_IDX(il_idx)      = gen_loop_lbl_name(blk_stk_idx, Top_Lbl);

# endif

         if (cif_flags & MISC_RECS) {
            cif_stmt_type_rec(TRUE, 
                              (CURR_BLK_LABEL == NULL_IDX) ?
                                 CIF_Do_Unlabeled_Infinite_Stmt :
                                 CIF_Do_Labeled_Infinite_Stmt,
                              statement_number);
         }
      }
   }
   else {

      if (comma_found) {
         parse_err_flush(Find_EOS, "do-variable or WHILE");
      }
      else if (label_found) {
         PRINTMSG(LA_CH_LINE, 513, Error, LA_CH_COLUMN, LA_CH_VALUE);
         parse_err_flush(Find_EOS, NULL);
      }
      else {
         PRINTMSG(LA_CH_LINE, 515, Error, LA_CH_COLUMN, LA_CH_VALUE);
         parse_err_flush(Find_EOS, NULL);
      }
   } 

EXIT:

   if (mp_nest_list_idx != NULL_IDX &&
       IL_FLD(mp_nest_list_idx) == NO_Tbl_Idx) {

      /* error situation, free the list entry */
      FREE_IR_LIST_NODE(mp_nest_list_idx);
      IL_OPND(mp_prev_idx) = null_opnd;
   }

   NEXT_LA_CH;

   /* Clear out the shortloop flags. They will be reset in pass 2.            */

   cdir_switches.shortloop    = FALSE;
   cdir_switches.shortloop128 = FALSE;

   TRACE (Func_Exit, "parse_do_stmt", NULL);

   return;

}  /* parse_do_stmt */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This function handles the following syntax:                           *|
|*         else-stmt       => ELSE [if-construct-name]                        *|
|*         else-if-stmt    => ELSE IF (scalar-logical-expr) THEN              *|
|*                                 [if-construct-name]                        *|
|*         elsewhere-stmt  => ELSE WHERE                                      *|
|*                                                                            *|
|*      Note that ELSE WHERE will require consulting the block stack to       *|
|*      determine if it is actually an ELSEWHERE stmt or an ELSE stmt with a  *|
|*      construct name of WHERE.                                              *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void parse_else_stmt (void)

{
   int                  blk_idx;
   blk_cntxt_type       blk_type                = If_Else_Blk;
   opnd_type            cond_expr;

# if 0
   int                  cont_lbl_idx;
   int                  end_lbl_idx;
# endif

   blk_cntxt_type       err_blk;
   int                  expr_start_line;
   int                  expr_start_col;
   boolean              found_name              = FALSE;
   int                  il_idx_1;
   int                  il_idx_2;
   int                  ir_idx;
   boolean              matched_blk             = FALSE;
   int                  name_idx;
   boolean              prev_clause_in_err;
   int                  sh_idx;


   TRACE (Func_Entry, "parse_else_stmt", NULL);

   check_for_vestigial_task_blks();

   /* ----------------------------------------------------------------------- */
   /* ELSE  (with no if-construct-name)                                       */
   /* ----------------------------------------------------------------------- */

   if (LA_CH_VALUE == EOS) {
      matched_blk = STMT_LEGAL_IN_BLK(Else_Stmt, CURR_BLK);

      if (cif_flags & MISC_RECS) {
         cif_stmt_type_rec(TRUE, CIF_Else_Stmt, statement_number);
      }
   }

   else if (MATCHED_TOKEN_CLASS(Tok_Class_Keyword)) {

      /* -------------------------------------------------------------------- */
      /* ELSE IF, or ELSEWHERE, or ELSE with if-construct-name                */
      /* -------------------------------------------------------------------- */

      if (TOKEN_VALUE(token) == Tok_Kwd_If  &&  LA_CH_VALUE == LPAREN) {

         /* ----------------------------------------------------------------- */
         /* ELSE IF                                                           */
         /* ----------------------------------------------------------------- */

         blk_type                       = If_Else_If_Blk;
         stmt_type                      = Else_If_Stmt;
         SH_STMT_TYPE(curr_stmt_sh_idx) = Else_If_Stmt;

         NEXT_LA_CH;

         expr_start_line = LA_CH_LINE;
         expr_start_col  = LA_CH_COLUMN;

         if (parse_expr(&cond_expr)) {
            
            if (LA_CH_VALUE == RPAREN) {
               NEXT_LA_CH;

               if (matched_specific_token(Tok_Kwd_Then, Tok_Class_Keyword)) {
               
                  if (LA_CH_VALUE != EOS) {
      
                     if ( (found_name = MATCHED_TOKEN_CLASS(Tok_Class_Id)) ) {
                     
                        if (LA_CH_VALUE != EOS) {
                           parse_err_flush(Find_EOS, EOS_STR);
                        }
                     }
                     else {
                        parse_err_flush(Find_EOS, "if-construct-name");
                     }
                  }
               }
               else {
                  parse_err_flush(Find_EOS, "THEN");
               }
            }
            else {
               parse_err_flush(Find_EOS, ")");
            }
         }
         else {
            parse_err_flush(Find_EOS, NULL);
         }

         if (SH_ERR_FLG(curr_stmt_sh_idx)) {
            goto EXIT;
         }

         if (cif_flags & MISC_RECS) {
            cif_stmt_type_rec(TRUE, CIF_Else_If_Stmt, statement_number);
         }
    
         if (STMT_LEGAL_IN_BLK(Else_If_Stmt, CURR_BLK)) {
            matched_blk = (found_name) ? (CURR_BLK_NAME != NULL_IDX  &&
                                 (compare_names(TOKEN_ID(token).words,
                                             TOKEN_LEN(token),
                                             AT_OBJ_NAME_LONG(CURR_BLK_NAME),
                                             AT_NAME_LEN(CURR_BLK_NAME)) == 0)):
                                 TRUE;
         }
      }
      else if (TOKEN_VALUE(token) == Tok_Kwd_Where  &&  LA_CH_VALUE == LPAREN) {
         /* ----------------------------------------------------------------- */
         /* ELSE WHERE (mask) [construct_name]                                */
         /* ----------------------------------------------------------------- */

         blk_type                       = Where_Else_Mask_Blk;
         stmt_type                      = Else_Where_Mask_Stmt;
         SH_STMT_TYPE(curr_stmt_sh_idx) = Else_Where_Mask_Stmt;

         NTR_IR_TBL(ir_idx);
         IR_OPR(ir_idx) = Else_Where_Mask_Opr;
         SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
         IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
         IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
         IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;

         NEXT_LA_CH;

         expr_start_line = LA_CH_LINE;
         expr_start_col  = LA_CH_COLUMN;

         if (parse_expr(&cond_expr)) {

            COPY_OPND(IR_OPND_L(ir_idx), cond_expr);

            if (LA_CH_VALUE == RPAREN) {
               NEXT_LA_CH;

               if (LA_CH_VALUE != EOS) {

                  if ( (found_name = MATCHED_TOKEN_CLASS(Tok_Class_Id)) ) {

                     if (LA_CH_VALUE != EOS) {
                        parse_err_flush(Find_EOS, EOS_STR);
                     }
                  }
                  else {
                     parse_err_flush(Find_EOS, "where-construct-name");
                  }
               }
            }
            else {
               parse_err_flush(Find_EOS, ")");
            }
         }
         else {
            parse_err_flush(Find_EOS, NULL);
         }

         if (SH_ERR_FLG(curr_stmt_sh_idx)) {
            goto EXIT;
         }

         if (cif_flags & MISC_RECS) {
            cif_stmt_type_rec(TRUE, CIF_Elsewhere_Stmt, statement_number);
         }

         if (STMT_LEGAL_IN_BLK(Else_Where_Mask_Stmt, CURR_BLK)) {
            SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX;

            matched_blk = (found_name) ? (CURR_BLK_NAME != NULL_IDX  &&
                                 (compare_names(TOKEN_ID(token).words,
                                             TOKEN_LEN(token),
                                             AT_OBJ_NAME_LONG(CURR_BLK_NAME),
                                             AT_NAME_LEN(CURR_BLK_NAME)) == 0)):
                                 TRUE;
         }
      }
      else if (TOKEN_VALUE(token) == Tok_Kwd_Where &&
               (CURR_BLK == Where_Then_Blk ||
                CURR_BLK == Where_Else_Mask_Blk)) {

         /* -------------------------------------------------------------- */
         /* ELSEWHERE [construct_name]                                     */
         /* -------------------------------------------------------------- */

         stmt_type                      = Else_Where_Stmt;
         SH_STMT_TYPE(curr_stmt_sh_idx) = Else_Where_Stmt;
         blk_type                       = Where_Else_Blk;
         SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX;

         NTR_IR_TBL(ir_idx);
         IR_OPR(ir_idx) = Else_Where_Opr;
         SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
         IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
         IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
         IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;


         if (LA_CH_VALUE != EOS) {

            if ( (found_name = MATCHED_TOKEN_CLASS(Tok_Class_Id)) ) {

               if (LA_CH_VALUE != EOS) {
                  parse_err_flush(Find_EOS, EOS_STR);
               }
            }
            else {
               parse_err_flush(Find_EOS, "where-construct-name");
            }
         }

         matched_blk = (found_name) ? (CURR_BLK_NAME != NULL_IDX  &&
                              (compare_names(TOKEN_ID(token).words,
                                          TOKEN_LEN(token),
                                          AT_OBJ_NAME_LONG(CURR_BLK_NAME),
                                          AT_NAME_LEN(CURR_BLK_NAME)) == 0)):
                              TRUE;

         if (cif_flags & MISC_RECS) {
            cif_stmt_type_rec(TRUE, CIF_Elsewhere_Stmt, statement_number);
         }
      }
      else if (TOKEN_VALUE(token) == Tok_Kwd_Where && LA_CH_VALUE == EOS) {

         if (STMT_LEGAL_IN_BLK(Else_Stmt, CURR_BLK)  &&
             (CURR_BLK_NAME != NULL_IDX  &&
              (compare_names(TOKEN_ID(token).words,
                             TOKEN_LEN(token),
                             AT_OBJ_NAME_LONG(CURR_BLK_NAME),
                             AT_NAME_LEN(CURR_BLK_NAME)) == 0)) ) {

            /* -------------------------------------------------------------- */
            /* ELSE with if-construct-name WHERE                              */
            /* -------------------------------------------------------------- */

            matched_blk = TRUE; 
            found_name  = TRUE;

            if (cif_flags & MISC_RECS) {
               cif_stmt_type_rec(TRUE, CIF_Else_Stmt, statement_number);
            }
         }
         else if (match_blk(Where_Then_Blk, FALSE) >=
                  match_blk(If_Blk, FALSE)) {

            /* We got to this "else if" due to an error case:  either the ELSE*/
            /* is not valid in the current block, or the ELSE is valid but    */
            /* WHERE does not match the if-construct-name on the if-then-stmt.*/
            /* Reaching this point means match_blk found a Where_Then_Blk     */
            /* before an If_Blk, or neither a matching If_Blk nor a matching  */
            /* Where_Then_Blk was found.                                      */

            stmt_type                           = Else_Where_Stmt;
            SH_STMT_TYPE(curr_stmt_sh_idx)      = Else_Where_Stmt;
            blk_type                            = Where_Else_Blk;

            if (cif_flags & MISC_RECS) {
               cif_stmt_type_rec(TRUE, CIF_Elsewhere_Stmt, statement_number);
            }
         }
         else {

            /* We've found a matching if-then-stmt but it either has no if-   */
            /* construct-name, or it does but it's not WHERE.                 */

            found_name = TRUE;

            if (cif_flags & MISC_RECS) {
               cif_stmt_type_rec(TRUE, CIF_Else_Stmt, statement_number);
            }
         }
      }
      else {

         /* ----------------------------------------------------------------- */
         /* ELSE statement with construct-name starting with WHERE or IF.     */
         /* ----------------------------------------------------------------- */

         found_name = TRUE;

         if (TOKEN_VALUE(token) != Tok_Id) {    /* In case its WHEREABC */
            reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
            MATCHED_TOKEN_CLASS(Tok_Class_Id);
         }

         if (CURR_BLK == If_Then_Blk  ||  CURR_BLK == If_Else_If_Blk) {
            matched_blk = CURR_BLK_NAME != NULL_IDX  &&
                               (compare_names(TOKEN_ID(token).words,
                                              TOKEN_LEN(token),
                                              AT_OBJ_NAME_LONG(CURR_BLK_NAME),
                                              AT_NAME_LEN(CURR_BLK_NAME)) == 0);
         }

         if (cif_flags & MISC_RECS) {
            cif_stmt_type_rec(TRUE, CIF_Else_Stmt, statement_number);
         }

         if (LA_CH_VALUE != EOS) {
            parse_err_flush(Find_EOS, EOS_STR);
         }
      }
   }
   else {
      parse_err_flush(Find_EOS, "IF, WHERE, a construct name or EOS");
   }

   /* ----------------------------------------------------------------------- */
   /* If the ELSE, ELSE IF, or ELSEWHERE is in a valid location, adjust the   */
   /* block stack and generate the IR (actually for the previous clause) to   */
   /* jump around the clause currently being processed.  Otherwise, recover   */
   /* from the misplaced statement.                                           */
   /* ----------------------------------------------------------------------- */

   if (matched_blk) {
      curr_stmt_category = Executable_Stmt_Cat;

      if ((cif_flags & XREF_RECS)  &&  found_name) {
         cif_usage_rec(CURR_BLK_NAME, AT_Tbl_Idx,
                       TOKEN_LINE(token), TOKEN_COLUMN(token),
                       CIF_Construct_Name_Reference);
      }

      if (blk_type != Where_Else_Blk  &&  
          blk_type != Where_Else_Mask_Blk &&
          ! SH_ERR_FLG(curr_stmt_sh_idx)) {

         /* If we are currently processing the ELSE stmt or the first ELSE IF */
         /* stmt of this IF construct, grab the branch-around label from the  */
         /* If_Blk block stack entry and replace it with the label that will  */
         /* be used by all following clauses for the "end IF" label.  For an  */
         /* ELSE, this just ends up being its branch-around label.            */
         /*                                                                   */
         /* Otherwise, we are processing the second (or beyond) ELSE IF or an */
         /* ELSE following such an ELSE IF.  Since the ELSE IF/ELSE currently */
         /* being processed has not yet been pushed on the block stack, the   */
         /* current block stack entry is for the previous ELSE IF.  Thus, the */
         /* label being plucked out of the block stack entry is the branch-   */
         /* around label for the previous ELSE IF which defines the beginning */
         /* of the current ELSE IF or ELSE clause.                            */

# ifdef _DEBUG
         if (BLK_TYPE(blk_stk_idx - 1) != If_Blk) {
            PRINTMSG(stmt_start_line, 160, Internal, 0, blk_stk_idx);
         }
# endif

#if 0
         if (CURR_BLK == If_Then_Blk) {
            cont_lbl_idx                 = BLK_LABEL(blk_stk_idx - 1);
            end_lbl_idx                  = gen_internal_lbl(stmt_start_line);
            BLK_LABEL(blk_stk_idx - 1)   = end_lbl_idx;
         }
         else {
            cont_lbl_idx = CURR_BLK_LABEL;
            end_lbl_idx  = BLK_LABEL(blk_stk_idx - 1);
         }
#endif

      }

      prev_clause_in_err = SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX);

      if (blk_type != Where_Else_Blk &&
          blk_type != Where_Else_Mask_Blk) {
         blk_idx = blk_stk_idx;

         if (CURR_BLK == If_Then_Blk) {
            --blk_idx;
         }

         sh_idx = BLK_FIRST_SH_IDX(blk_idx);
      }

      if (blk_type == Where_Else_Blk ||
          blk_type == Where_Else_Mask_Blk) {
         name_idx = CURR_BLK_NAME;
      }

      POP_BLK_STK;
      PUSH_BLK_STK(blk_type);
      CURR_BLK_FIRST_SH_IDX = curr_stmt_sh_idx;

      if (blk_type == Where_Else_Blk ||
          blk_type == Where_Else_Mask_Blk) {
         CURR_BLK_NAME = name_idx;
         CURR_BLK_NO_EXEC = TRUE;
      }
      else {
         CURR_BLK_NAME = BLK_NAME(blk_stk_idx - 1);
         LINK_TO_PARENT_BLK;

         if (SH_ERR_FLG(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))  ||
             prev_clause_in_err) {
            SH_ERR_FLG(curr_stmt_sh_idx) = TRUE;
         }
         
         /* If the ELSE IF (and IF) are OK, generate a Br_True IR to hold the */
         /* conditional expression and branch-around label.  The .NOT.        */
         /* subtree is added by the Semantics Pass if the expression is OK.   */
         /* Since the SH_PARENT_BLK_IDX field is needed to link to actual     */
         /* parent blocks for invalid label reference detection and since     */
         /* there is no more room in an SH for another SH index, we need to   */
         /* hold the "previous IF construct part" SH index elsewhere.  For an */
         /* ELSE IF, generate a Br_True IR and attach two ILs to the right    */
         /* operand.  Save the "previous IF construct part" SH index in the   */
         /* second IL.  The Semantics Pass will put the branch-around label   */
         /* in the first IL.  For an ELSE, generate an If IR and save the SH  */
         /* index in the left operand.                                        */
 
         if (! SH_ERR_FLG(curr_stmt_sh_idx)) {
            NTR_IR_TBL(ir_idx);
            SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
            IR_TYPE_IDX(ir_idx)         = LOGICAL_DEFAULT_TYPE;
            IR_LINE_NUM(ir_idx)         = expr_start_line;
            IR_COL_NUM(ir_idx)          = expr_start_col;

            if (blk_type == If_Else_If_Blk) {
               IR_OPR(ir_idx)              = Br_True_Opr;
               COPY_OPND(IR_OPND_L(ir_idx), cond_expr);
               NTR_IR_LIST_TBL(il_idx_1);
               IR_LIST_CNT_R(ir_idx) = 1;
               IR_FLD_R(ir_idx)      = IL_Tbl_Idx;
               IR_IDX_R(ir_idx)      = il_idx_1;
               NTR_IR_LIST_TBL(il_idx_2);
               IR_LIST_CNT_R(ir_idx) = 2;
               IL_NEXT_LIST_IDX(il_idx_1) = il_idx_2;
               IL_PREV_LIST_IDX(il_idx_2) = il_idx_1;
               IL_LINE_NUM(il_idx_2)      = stmt_start_line;
               IL_COL_NUM(il_idx_2)       = stmt_start_col;
               IL_FLD(il_idx_2)           = SH_Tbl_Idx;
               IL_IDX(il_idx_2)           = sh_idx;
            }
            else {
               IR_OPR(ir_idx)        = Else_Opr;
               IR_LINE_NUM(ir_idx)   = stmt_start_line;
               IR_COL_NUM(ir_idx)    = stmt_start_col;
               IR_FLD_L(ir_idx)      = SH_Tbl_Idx;
               IR_IDX_L(ir_idx)      = sh_idx;
            }
#if 0
               CURR_BLK_LABEL        = gen_internal_lbl(stmt_start_line);
               IR_LINE_NUM_R(ir_idx) = stmt_start_line;
               IR_COL_NUM_R(ir_idx)  = stmt_start_col;
               IR_FLD_R(ir_idx)      = AT_Tbl_Idx;
               IR_IDX_R(ir_idx)      = CURR_BLK_LABEL;
#endif
           

#if 0
            /* Now AHEAD of the ELSE IF or ELSE SH, generate a GO TO stmt to  */
            /* branch to the end of the IF construct and a CONTINUE stmt to   */
            /* define the start of the ELSE IF or ELSE.                       */

            gen_sh(Before, Goto_Stmt,
                   SH_GLB_LINE(SH_PREV_IDX(curr_stmt_sh_idx)), 
                   SH_COL_NUM(SH_PREV_IDX(curr_stmt_sh_idx)),
                   FALSE, FALSE, TRUE);

            sh_idx                 = SH_PREV_IDX(curr_stmt_sh_idx);
            NTR_IR_TBL(ir_idx);
            SH_IR_IDX(sh_idx)      = ir_idx;
            IR_OPR(ir_idx)         = Br_Uncond_Opr;
            /* LRR - bhj put in short typeless as type idx */
            IR_TYPE_IDX(ir_idx)         = TYPELESS_DEFAULT_TYPE;
            IR_LINE_NUM(ir_idx)    = SH_GLB_LINE(SH_PREV_IDX(sh_idx));
            IR_COL_NUM(ir_idx)     = SH_COL_NUM(SH_PREV_IDX(sh_idx));
            
            IR_LINE_NUM_R(ir_idx)  = SH_GLB_LINE(SH_PREV_IDX(sh_idx));
            IR_COL_NUM_R(ir_idx)   = SH_COL_NUM(SH_PREV_IDX(sh_idx));
            IR_FLD_R(ir_idx)       = AT_Tbl_Idx;
            IR_IDX_R(ir_idx)       = end_lbl_idx;

            gen_sh(Before, Continue_Stmt, stmt_start_line, stmt_start_col,
                   FALSE, TRUE, TRUE);
         
            sh_idx                         = SH_PREV_IDX(curr_stmt_sh_idx);
            NTR_IR_TBL(ir_idx);
            SH_IR_IDX(sh_idx)              = ir_idx;
            IR_OPR(ir_idx)                 = Label_Opr;
            /* LRR - bhj put in short typeless as type idx */
            IR_TYPE_IDX(ir_idx)            = TYPELESS_DEFAULT_TYPE;
            IR_LINE_NUM(ir_idx)            = stmt_start_line;
            IR_COL_NUM(ir_idx)             = stmt_start_col;
            IR_LINE_NUM_L(ir_idx)          = stmt_start_line;
            IR_COL_NUM_L(ir_idx)           = stmt_start_col;
            IR_FLD_L(ir_idx)               = AT_Tbl_Idx;
            IR_IDX_L(ir_idx)               = cont_lbl_idx;
            AT_DEFINED(cont_lbl_idx)       = TRUE;
            AT_DEF_LINE(cont_lbl_idx)      = stmt_start_line;
            AT_DEF_COLUMN(cont_lbl_idx)    = stmt_start_col;
            AT_REFERENCED(cont_lbl_idx)    = Referenced;
            ATL_DEF_STMT_IDX(cont_lbl_idx) = sh_idx;
#endif
         }
      }
   }
   else {
      err_blk = (blk_type == Where_Else_Blk ||
                 blk_type == Where_Else_Mask_Blk) ? Where_Then_Blk : If_Blk;
      blk_idx = blk_match_err(err_blk, found_name, FALSE);

      /* blk_match_err moves the matched block to the current block */

      if (blk_idx != NULL_IDX) {
         if (blk_type == Where_Else_Blk ||
             blk_type == Where_Else_Mask_Blk) {
            name_idx = CURR_BLK_NAME;
         }

         POP_BLK_STK;
         PUSH_BLK_STK(blk_type);
         CURR_BLK_FIRST_SH_IDX = curr_stmt_sh_idx;

         if (blk_type == Where_Else_Blk ||
             blk_type == Where_Else_Mask_Blk) {
            CURR_BLK_NAME = name_idx;
            CURR_BLK_NO_EXEC = TRUE;
         }
         else {
            CURR_BLK_NAME = BLK_NAME(blk_stk_idx - 1);
            LINK_TO_PARENT_BLK;
            SH_ERR_FLG(curr_stmt_sh_idx) = TRUE;
         }

# if 0
         if (cif_flags & XREF_RECS) {
            cif_usage_rec(CURR_BLK_NAME, AT_Tbl_Idx,
                          TOKEN_LINE(token), TOKEN_COLUMN(token),
                          CIF_Construct_Name_Reference);
         }
# endif
      }
   }

EXIT:

   NEXT_LA_CH;
   
   TRACE (Func_Exit, "parse_else_stmt", NULL);

   return;

}  /* parse_else_stmt */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Parse the EXIT statement.  If a matching DO construct is found,       *|
|*      generate the internal exit point label and a Br_Uncond IR to jump to  *|
|*      it.                                                                   *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void parse_exit_stmt (void)

{
   int          blk_idx;
   boolean      fnd_name        = FALSE;
   int          ir_idx;


   TRACE (Func_Entry, "parse_exit_stmt", NULL);

   if (LA_CH_VALUE != EOS) {
      fnd_name = MATCHED_TOKEN_CLASS(Tok_Class_Id);

      if (fnd_name) {

         if (LA_CH_VALUE != EOS) {
            parse_err_flush(Find_EOS, EOS_STR);
         }

      }
      else {
         parse_err_flush(Find_EOS, "construct-name or EOS");
         goto EXIT;
      }

   }

   blk_idx = match_blk(Do_Blk, fnd_name);

   if (blk_idx != NULL_IDX) {

      if (! CURR_BLK_NO_EXEC  ||  ! iss_blk_stk_err()) {
         curr_stmt_category = Executable_Stmt_Cat;
         SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
         BLK_EXIT_STMT(blk_idx) = TRUE;

         NTR_IR_TBL(ir_idx);
         SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
         IR_OPR(ir_idx)              = Br_Uncond_Opr;
         /* LRR - bhj put in short typeless as type idx */
         IR_TYPE_IDX(ir_idx)         = TYPELESS_DEFAULT_TYPE;
         IR_LINE_NUM(ir_idx)         = stmt_start_line;
         IR_COL_NUM(ir_idx)          = stmt_start_col;
         IR_LINE_NUM_R(ir_idx)       = stmt_start_line;
         IR_COL_NUM_R(ir_idx)        = stmt_start_col;
         IR_FLD_R(ir_idx)            = AT_Tbl_Idx;
         IR_IDX_R(ir_idx)            = gen_loop_lbl_name(blk_idx, Exit_Lbl);

         if (fnd_name  &&  (cif_flags & XREF_RECS)) {
            cif_usage_rec(BLK_NAME(blk_idx), AT_Tbl_Idx,
                          TOKEN_LINE(token), TOKEN_COLUMN(token),
                          CIF_Construct_Name_Reference);
         }
      }

   }
   else {
      PRINTMSG(stmt_start_line, 262, Error, stmt_start_col, "EXIT");
   }

EXIT:

   NEXT_LA_CH;
   
   TRACE (Func_Exit, "parse_exit_stmt", NULL);

   return;

}  /* parse_exit_stmt */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This function parses both the FORALL construct statement and the      *|
|*      FORALL statement.                                                     *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void parse_forall (void)

{
   opnd_type    an_opnd;
   int          blk_stk_start;
   int          expr_start_line;
   int          expr_start_col;
   int          forall_ir_idx;
   int          forall_sh_idx;
   boolean      found_colon;
   boolean      found_comma;
   int          i;
   int          il_idx;
   int          index_name_il_idx;
   int          mask_il_idx;
   int          stride_il_idx;
   int          subscript1_il_idx;
   int          subscript2_il_idx;
   int          triplet_spec_il_idx;


   TRACE (Func_Entry, "parse_forall", NULL);

   /* Generate the Forall IR.  If the FORALL turns out to be a FORALL         */
   /* construct, the left operand will eventually point at the END FORALL SH. */
   /* The right operand will point at an IL list.  If you think of the ILs    */
   /* in a horizontal list, there will be one IL for each                     */
   /* <forall-triplet-spec> and one (at the end of the chain) for the         */
   /* <scalar-mask-expr> (if such an expression is present).  Each of the ILs */
   /* for the triplet specs points at a chain of ILs (think of them as being  */
   /* vertical below the triplet spec ILs) that hold the info for the index   */
   /* name, both subscript expressions, and the stride expression.  If the    */
   /* user does not specify the stride, the compiler will supply the default  */
   /* 1 so the list for each triplet spec is always complete.                 */

   NTR_IR_TBL(forall_ir_idx);
   SH_IR_IDX(curr_stmt_sh_idx) = forall_ir_idx;
   IR_OPR(forall_ir_idx)       = Forall_Opr;
   IR_TYPE_IDX(forall_ir_idx)  = TYPELESS_DEFAULT_TYPE;
   IR_LINE_NUM(forall_ir_idx)  = stmt_start_line;
   IR_COL_NUM(forall_ir_idx)   = stmt_start_col;


   /* ----------------------------------------------------------------------- */
   /* Parse the <forall-header>:                                              */
   /*   ( <forall-triplet-spec-list> [ , <scalar-mask-expr> ] )               */
   /*                                                                         */
   /*   <forall-triplet-spec>  is  <index-name> = <subscript> : <subscript>   */
   /*                                               [ : <stride> ]            */
   /* ----------------------------------------------------------------------- */

   /* Look for the left paren and then the <index-name>.  If there is         */
   /* anything wrong, don't try to recover to the right paren (in the hopes   */
   /* of being able to parse the <forall-assignment-stmt> if this is a FORALL */
   /* stmt because the subscript, stride, and mask can all be expressions     */
   /* that could contain right parens.  Don't check here for the <index-name> */
   /* being a (unqualified) name.  Like the DO-variable check, this is done   */
   /* in semantic processing.  Also, don't check for the <index-name>         */
   /* duplicating an <index-name> of an outer FORALL until we know we've got  */
   /* a valid FORALL.                                                         */

   if (LA_CH_VALUE == LPAREN) {
      NEXT_LA_CH;

      if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
         expr_start_line = TOKEN_LINE(token);
         expr_start_col  = TOKEN_COLUMN(token);

         if (parse_deref(&an_opnd, NULL_IDX)) {
            NTR_IR_LIST_TBL(triplet_spec_il_idx);
            IR_LIST_CNT_R(forall_ir_idx) = 1;
            IR_FLD_R(forall_ir_idx)      = IL_Tbl_Idx;
            IR_IDX_R(forall_ir_idx)      = triplet_spec_il_idx;

            NTR_IR_LIST_TBL(index_name_il_idx);
            IL_FLD(triplet_spec_il_idx) = IL_Tbl_Idx;
            IL_IDX(triplet_spec_il_idx) = index_name_il_idx;
            IL_LIST_CNT(triplet_spec_il_idx) = 1;

            COPY_OPND(IL_OPND(index_name_il_idx), an_opnd);
         }
         else {
            parse_err_flush(Find_EOS, NULL);
            goto EXIT;
         }
      }
      else {
         parse_err_flush(Find_EOS, "index-name");
         goto EXIT;
      }
   }
   else {
      parse_err_flush(Find_EOS, "(");
      goto EXIT;
   }

NEXT_TRIPLET_SPEC:

   if (LA_CH_VALUE == EQUAL) {
      NEXT_LA_CH;
   }
   else {
      parse_err_flush(Find_EOS, "=");
      goto EXIT;
   }


   /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   /* Parse the first subscript expression.                                   */
   /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

   /* Capture the beginning of the expression so the IL line and column will  */
   /* point at the beginning of the expression as opposed to the line and     */
   /* column from the root IR of the expression.                              */

   expr_start_line = LA_CH_LINE;
   expr_start_col  = LA_CH_COLUMN;


   if (parse_expr(&an_opnd)) {

      /* Note:  parse_expr can return TRUE even though an error message is    */
      /* produced (like if the subscript is a constant with an invalid kind   */
      /* parameter).  This will cause the FORALL SH to be marked in error     */
      /* but that's OK.                                                       */

      if (! SH_ERR_FLG(curr_stmt_sh_idx)) {
         NTR_IR_LIST_TBL(subscript1_il_idx);
         IL_NEXT_LIST_IDX(index_name_il_idx) = subscript1_il_idx;
         IL_PREV_LIST_IDX(subscript1_il_idx) = index_name_il_idx;
         COPY_OPND(IL_OPND(subscript1_il_idx), an_opnd);
         IL_LINE_NUM(subscript1_il_idx)      = expr_start_line;
         IL_COL_NUM(subscript1_il_idx)       = expr_start_col;
         ++IL_LIST_CNT(triplet_spec_il_idx);
      }
      else {
         parse_err_flush(Find_EOS, NULL);
         goto EXIT;
      }
   }
   else {
      parse_err_flush(Find_EOS, NULL);
      goto EXIT;
   }

   
   if (LA_CH_VALUE == COLON) {
      NEXT_LA_CH;
   }
   else {
      parse_err_flush(Find_EOS, ":");
      goto EXIT;
   }


   /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   /* Parse the second subscript expression.                                  */
   /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

   expr_start_line = LA_CH_LINE;
   expr_start_col  = LA_CH_COLUMN;

   if (parse_expr(&an_opnd)) {

      if (! SH_ERR_FLG(curr_stmt_sh_idx)) {
         NTR_IR_LIST_TBL(subscript2_il_idx);
         IL_NEXT_LIST_IDX(subscript1_il_idx) = subscript2_il_idx;
         IL_PREV_LIST_IDX(subscript2_il_idx) = subscript1_il_idx;
         COPY_OPND(IL_OPND(subscript2_il_idx), an_opnd);
         IL_LINE_NUM(subscript2_il_idx)      = expr_start_line;
         IL_COL_NUM(subscript2_il_idx)       = expr_start_col;
         ++IL_LIST_CNT(triplet_spec_il_idx);
      }
      else {
         parse_err_flush(Find_EOS, NULL);
         goto EXIT;
      }
   }
   else {
      parse_err_flush(Find_EOS, NULL);
      goto EXIT;
   }

   
   /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   /* If the stride expression is present, parse it.  Else supply the 1.      */
   /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

   /* Set up some flags to allow us to issue reasonably specific error        */
   /* recovery messages.                                                      */

   found_colon     = FALSE;
   found_comma     = FALSE;


   NTR_IR_LIST_TBL(stride_il_idx);
   IL_NEXT_LIST_IDX(subscript2_il_idx) = stride_il_idx;
   IL_PREV_LIST_IDX(stride_il_idx)     = subscript2_il_idx;
   ++IL_LIST_CNT(triplet_spec_il_idx);

   if (LA_CH_VALUE == COLON) {
      NEXT_LA_CH;
      found_colon = TRUE;

      expr_start_line = LA_CH_LINE;
      expr_start_col  = LA_CH_COLUMN;

      if (parse_expr(&an_opnd)) {

         if (! SH_ERR_FLG(curr_stmt_sh_idx)) {
            COPY_OPND(IL_OPND(stride_il_idx), an_opnd);
            IL_LINE_NUM(stride_il_idx) = expr_start_line;
            IL_COL_NUM(stride_il_idx)  = expr_start_col;
         }
         else {
            parse_err_flush(Find_EOS, NULL);
            goto EXIT;
         }
      }
      else {
         parse_err_flush(Find_EOS, NULL);
         goto EXIT;
      }
   }
   else {
      IL_LINE_NUM(stride_il_idx) = LA_CH_LINE;
      IL_COL_NUM(stride_il_idx)  = LA_CH_COLUMN;
      IL_FLD(stride_il_idx)      = CN_Tbl_Idx;
      IL_IDX(stride_il_idx)      = CN_INTEGER_ONE_IDX;
   }


   /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   /* If the next token is a comma, figure out if it is followed by another   */
   /* <forall-triplet-spec> or the <scalar-mask-expr>.  The only way to tell  */
   /* is if an equal sign follows whatever follows the comma.  Nice language  */
   /* design, eh?                                                             */
   /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

   if (LA_CH_VALUE == COMMA) {
      NEXT_LA_CH;
      found_colon = TRUE;      /* Fake this if FALSE so insert is meaningful. */
      found_comma = TRUE;

      expr_start_line = LA_CH_LINE;
      expr_start_col  = LA_CH_COLUMN;


      /* If the next token is a valid <index-name> or a valid token to start  */
      /* a mask expr, reset the source location so parse_expr will start at   */
      /* the right place (so LA_CH is set up correctly).  Else issue a        */
      /* message and bail now.                                                */

      if (MATCHED_TOKEN_CLASS(Tok_Class_Opnd)) {
         reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
      }
      else if (MATCHED_TOKEN_CLASS(Tok_Class_Op)) {
         reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
      }
      else {
         parse_err_flush(Find_EOS, "index-name or mask expression");
         goto EXIT;
      }

      if (parse_expr(&an_opnd)) {

         if (! SH_ERR_FLG(curr_stmt_sh_idx)) {

            if (LA_CH_VALUE == EQUAL) {
               il_idx = triplet_spec_il_idx;
               NTR_IR_LIST_TBL(triplet_spec_il_idx);
               ++IR_LIST_CNT_R(forall_ir_idx);
               IL_NEXT_LIST_IDX(il_idx)              = triplet_spec_il_idx;
               IL_PREV_LIST_IDX(triplet_spec_il_idx) = il_idx;

               NTR_IR_LIST_TBL(index_name_il_idx);
               IL_FLD(triplet_spec_il_idx) = IL_Tbl_Idx;
               IL_IDX(triplet_spec_il_idx) = index_name_il_idx;
               IL_LIST_CNT(triplet_spec_il_idx) = 1;

               COPY_OPND(IL_OPND(index_name_il_idx), an_opnd);

               goto NEXT_TRIPLET_SPEC;
            }
            else {
               NTR_IR_LIST_TBL(mask_il_idx);
               ++IR_LIST_CNT_R(forall_ir_idx);
               IL_NEXT_LIST_IDX(triplet_spec_il_idx) = mask_il_idx;
               IL_PREV_LIST_IDX(mask_il_idx) = triplet_spec_il_idx;

               COPY_OPND(IL_OPND(mask_il_idx), an_opnd);
               IL_LINE_NUM(mask_il_idx) = expr_start_line;
               IL_COL_NUM(mask_il_idx)  = expr_start_col;
            }
         }
         else {
            parse_err_flush(Find_EOS, NULL);
            goto EXIT;
         }
      }
      else {
         parse_err_flush(Find_EOS, NULL);
         goto EXIT;
      }
   }


   if (LA_CH_VALUE == RPAREN) {
      NEXT_LA_CH;
   }
   else {

      if (! found_colon) {
         parse_err_flush(Find_EOS, "colon, comma, or right parenthesis"); 
      }
      else if (! found_comma) {
         parse_err_flush(Find_EOS, "comma or )"); 
      }
      else if (OPND_FLD(an_opnd) == AT_Tbl_Idx) {
         parse_err_flush(Find_EOS, "= or )"); 
      }
      else {
         parse_err_flush(Find_EOS, ")"); 
      }

      goto EXIT;
   }

   forall_sh_idx = curr_stmt_sh_idx;

   if (LA_CH_VALUE == EOS) {
      NEXT_LA_CH;

      /* The FORALL is a FORALL construct.  Push it onto the Blocking Stmt    */
      /* stack.  We'll use common code later to search the stack for its      */
      /* parent (if there is one).  Set CURR_BLK_NO_EXEC to TRUE to force     */
      /* other stmt parsers to call iss_blk_stk_err to check to see if the    */
      /* stmt is allowed in a FORALL construct.                               */

      if (! CURR_BLK_NO_EXEC  ||  CURR_BLK == Forall_Blk) {
         PUSH_BLK_STK(Forall_Blk);
      }
      else {
         iss_blk_stk_err();
         PUSH_BLK_STK(Forall_Blk);
         CURR_BLK_ERR = TRUE;
      }

      if (stmt_construct_idx != NULL_IDX) {
         CURR_BLK_NAME                        = stmt_construct_idx;
         ATL_CLASS(stmt_construct_idx)        = Lbl_Construct;
         ATL_DEF_STMT_IDX(stmt_construct_idx) = curr_stmt_sh_idx;
         SH_ERR_FLG(curr_stmt_sh_idx)         =
            SH_ERR_FLG(curr_stmt_sh_idx)  ||  AT_DCL_ERR(stmt_construct_idx);
         stmt_construct_idx                        = NULL_IDX;
      }

      curr_stmt_category    = Executable_Stmt_Cat;
      CURR_BLK_FIRST_SH_IDX = curr_stmt_sh_idx;
      CURR_BLK_NO_EXEC      = TRUE;
      blk_stk_start         = blk_stk_idx - 1;
   }
   else {

      /* The tokens following the right paren are assumed to be a             */
      /* <forall-assignment-stmt>.  Call MATCHED_TOKEN_CLASS to force the     */
      /* current token to be the first token of the FORALL assignment stmt.   */
      /* Parse the assignment stmt.  determine_stmt_type fills in the stmt    */
      /* type, line number, and column number.                                */
 
      stmt_type                      = Forall_Stmt;
      SH_STMT_TYPE(curr_stmt_sh_idx) = Forall_Stmt;

      if (! CURR_BLK_NO_EXEC  ||  CURR_BLK == Forall_Blk) {
         curr_stmt_category = Executable_Stmt_Cat;
      }
      else {
         iss_blk_stk_err();
         parse_err_flush(Find_EOS, NULL);
         goto EXIT;
      }


      if (MATCHED_TOKEN_CLASS(Tok_Class_Keyword)) {
         gen_sh(After, Null_Stmt, 0, 0, FALSE, FALSE, FALSE);

         determine_stmt_type();

         if (stmt_type == Assignment_Stmt) {

            /* The action statement needs to have its statement */
            /* number be 1 greater than the if statement.       */

            /*  KAY - This needs to be checked to see if this is okay here */

            INCREMENT_STATEMENT_NUMBER;
            in_action_stmt_of_if_where_or_forall        = TRUE;
   
            (*stmt_parsers[Assignment_Stmt])();

            in_action_stmt_of_if_where_or_forall        = FALSE;

            if (SH_ERR_FLG(curr_stmt_sh_idx)) {
               SH_ERR_FLG(forall_sh_idx) = TRUE;
               goto EXIT;
            }

            blk_stk_start = blk_stk_idx;

            /* generate an end forall after the assignment */

            gen_sh(After, End_Forall_Stmt, SH_GLB_LINE(forall_sh_idx), 
                   SH_COL_NUM(forall_sh_idx), FALSE, FALSE, FALSE);

            SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = forall_sh_idx;
            IR_FLD_L(SH_IR_IDX(forall_sh_idx)) = SH_Tbl_Idx;
            IR_IDX_L(SH_IR_IDX(forall_sh_idx)) = curr_stmt_sh_idx;
            IR_LINE_NUM_L(SH_IR_IDX(forall_sh_idx)) =
                                SH_GLB_LINE(forall_sh_idx);
            IR_COL_NUM_L(SH_IR_IDX(forall_sh_idx)) =
                                SH_COL_NUM(forall_sh_idx);

         }
         else {
            PRINTMSG(stmt_start_line, 365, Error, stmt_start_col);
            parse_err_flush(Find_EOS, NULL);
            NEXT_LA_CH;
            SH_ERR_FLG(forall_sh_idx) = TRUE;
         }
      }
      else {
         parse_err_flush(Find_EOS, "identifier or EOS");
         goto EXIT;
      }
   }


   /* Now look back through the Blocking Stmt stack to see if we can find an  */
   /* outer FORALL constructs.  If we find one, link the current FORALL to    */
   /* to the outer one so we can find it in the Semantics Pass.               */

   for (i = blk_stk_start;  i > 0;  --i) {

      if (BLK_TYPE(i) == Forall_Blk) {
         SH_PARENT_BLK_IDX(forall_sh_idx) = BLK_FIRST_SH_IDX(i);
         break;
      }
   }

EXIT:

   if (LA_CH_VALUE == EOS) {
      NEXT_LA_CH;
   }

   TRACE (Func_Exit, "parse_forall", NULL);

   return;

}  /* parse_forall */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This procedure parses the three GO TO statement forms:                *|
|*                                                                            *|
|*        Unconditional:  GO TO label                                         *|
|*                                                                            *|
|*        Computed:       GO TO (label-list) [,] scalar-int-expr              *|
|*                                                                            *|
|*        Assigned:       GO TO scalar-int-variable [ [,] (label-list) ]      *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void    parse_goto_stmt(void)

{
   int          attr_idx;
   int          col;
   boolean      comma_found             = FALSE;
   int          host_attr_idx;
   int          host_name_idx;
   int          ir_idx;
   boolean      label_list_found        = FALSE;
   int          lbl_attr_idx;
   int          line;
   int          name_idx;
   opnd_type    opnd;


   TRACE (Func_Entry, "parse_goto_stmt", NULL);

   /* Have the keyword GO.  The next token must be TO.                        */
   /* Keep parsing to expose as many syntax errors as possible even though    */
   /* the statement might be out of context.  No labels will be checked       */
   /* (because error flags are set) in order to prevent cascading errors.     */

   line = TOKEN_LINE(token);
   col  = TOKEN_COLUMN(token);

   if (matched_specific_token(Tok_Kwd_To, Tok_Class_Keyword)) {
      if ( ! CURR_BLK_NO_EXEC  ||  ! iss_blk_stk_err() ) {
         curr_stmt_category = Executable_Stmt_Cat;
      }
   }
   else {
      parse_err_flush(Find_EOS, "TO");
      goto EXIT;
   }

   /* Let's rashly assume that the stmt is correctly formed and allocate      */
   /* the branch IR now so we have a place to hang things.                    */

   NTR_IR_TBL(ir_idx);
   SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
   IR_LINE_NUM(ir_idx) = line;
   IR_COL_NUM(ir_idx)  = col;


   /* ----------------------------------------------------------------------- */
   /* Unconditional GO TO?                          GO TO label               */
   /* ----------------------------------------------------------------------- */

   if (LA_CH_CLASS == Ch_Class_Digit) {

      MATCHED_TOKEN_CLASS(Tok_Class_Label);

      if ( ! TOKEN_ERR(token)) {
      
         if (LA_CH_VALUE == EOS) {

            /* We've found an unconditional GO TO.  Check the reference to    */
            /* the label and complete the Br_Uncond_Opr IR.                   */

            lbl_attr_idx = check_label_ref();

            IR_OPR(ir_idx)        = Br_Uncond_Opr;
            /* LRR - bhj put in short typeless as type idx */
            IR_TYPE_IDX(ir_idx)   = TYPELESS_DEFAULT_TYPE;
            IR_LINE_NUM(ir_idx)   = TOKEN_LINE(token);
            IR_COL_NUM(ir_idx)    = TOKEN_COLUMN(token);
            IR_LINE_NUM_R(ir_idx) = TOKEN_LINE(token);
            IR_COL_NUM_R(ir_idx)  = TOKEN_COLUMN(token);
            IR_FLD_R(ir_idx)      = AT_Tbl_Idx;
            IR_IDX_R(ir_idx)      = lbl_attr_idx;
            AT_REFERENCED(lbl_attr_idx) = Referenced;

            if (cif_flags & MISC_RECS) {
               cif_stmt_type_rec(TRUE, 
                                 CIF_Go_To_Unconditional_Stmt, 
                                 statement_number);
            }
         }
         else {

            /* Have garbage at the end of the statement.                      */

            parse_err_flush(Find_EOS, EOS_STR);
         }
      }
      else {
         
         /* Something is wrong with the label (like it's too long).  Message  */
         /* has already been issued.  Flush.                                  */

         parse_err_flush(Find_EOS, NULL);
      }

      goto EXIT;
   }


   /* ----------------------------------------------------------------------- */
   /* Computed GO TO?                GO TO (label-list) [,] scalar-int-expr   */
   /* ----------------------------------------------------------------------- */

   if (LA_CH_VALUE == LPAREN) {
      
      IR_OPR(ir_idx) = Br_Index_Opr;
      /* LRR - bhj put in integer as type idx */
      IR_TYPE_IDX(ir_idx)         = INTEGER_DEFAULT_TYPE;
     
      /* Parse the label-list.  If bad, the label-list parser has already     */
      /* issued messages so give up.                                          */

      if (parse_label_list(ir_idx)) {

         /* Recognize and toss the comma following the label-list, if the     */
         /* comma exists.                                                     */

         if (LA_CH_VALUE == COMMA) {
            NEXT_LA_CH;
         }

         /* Parse the expression.  The Semantics Pass will verify that it's   */
         /* scalar and type integer.                                          */

         if (parse_expr(&opnd)) {

            COPY_OPND(IR_OPND_L(ir_idx), opnd);

            if (LA_CH_VALUE != EOS) {

               /* Have garbage at the end of the statement.                   */

               parse_err_flush(Find_EOS, EOS_STR);
            }
         }
         else {
            parse_err_flush(Find_EOS, NULL);
         }
      }

      if (cif_flags & MISC_RECS) {
         cif_stmt_type_rec(TRUE, CIF_Go_To_Computed_Stmt, statement_number);
      }

      goto EXIT;
   }
 

   /* ----------------------------------------------------------------------- */
   /* Must be an assigned GO TO.   GO TO scalar-int-var [ [,] (label-list) ]  */
   /* ----------------------------------------------------------------------- */

   if ( ! MATCHED_TOKEN_CLASS(Tok_Class_Id) ) {
      PRINTMSG(LA_CH_LINE, 339, Error, LA_CH_COLUMN,
               (LA_CH_CLASS == Ch_Class_EOS) ? "EOS" : &LA_CH_VALUE);
      parse_err_flush(Find_EOS, NULL);
      goto EXIT;
   }
 
   IR_OPR(ir_idx) = Br_Asg_Opr;
   /* LRR - bhj put in Integer as type idx */
   IR_TYPE_IDX(ir_idx)   = INTEGER_DEFAULT_TYPE;

   /* Duplicate the bare bones of parse_deref to find (or enter) the Attr     */
   /* entry and get it marked as being referenced.                            */
   /* parse_deref can't be used directly because it would try to parse the    */
   /* "lbl (2,3)"  in     GO TO lbl (2,3)    as an array element designator.  */

   attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx); 

   if (attr_idx == NULL_IDX) {
      host_attr_idx =
         srch_host_sym_tbl(TOKEN_STR(token), 
                           TOKEN_LEN(token), 
                           &host_name_idx,
                           TRUE);
      
      if (host_attr_idx == NULL_IDX) {
         attr_idx = ntr_sym_tbl(&token, name_idx);
         SET_IMPL_TYPE(attr_idx);
      }
      else {
         attr_idx = ntr_host_in_sym_tbl(&token, name_idx,
                                        host_attr_idx, host_name_idx,
                                        TRUE);
      }
   }
 
   if (AT_DCL_ERR(attr_idx)) {
      parse_err_flush(Find_EOS, NULL);
      SH_ERR_FLG(curr_stmt_sh_idx) = TRUE;
      goto EXIT;
   }

   AT_REFERENCED(attr_idx) = Referenced;

   IR_FLD_L(ir_idx)      = AT_Tbl_Idx;
   IR_IDX_L(ir_idx)      = attr_idx;
   IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
   IR_COL_NUM_L(ir_idx)  = TOKEN_COLUMN(token);

   /* If the optional comma exists, absorb it and note its presence.          */

   if (LA_CH_VALUE == COMMA) {
      comma_found = TRUE;
      NEXT_LA_CH;
   }

   /* If the comma exists, the label-list must exist.  If the label-list      */
   /* exists, parse it.                                                       */

   if (LA_CH_VALUE == LPAREN) {
      label_list_found = TRUE;
      
      if ( ! parse_label_list(ir_idx) ) {
         goto EXIT;
      }
   }
   else {
      if (comma_found) {
         parse_err_flush(Find_EOS, "(");
         goto EXIT;
      }
   }

   /* If the next token is the EOS, we're home free.  If not, there are two   */
   /* possibilities:                                                          */
   /*                                                                         */
   /*   - If the label-list exists, then not finding the EOS means there is   */
   /*     junk at the end of the statement (following the label-list).        */
   /*                                                                         */
   /*   - Otherwise, there is junk following the label variable.              */

   if (LA_CH_VALUE == EOS) {
      PRINTMSG(