/*
 * Copyright (C) 2007, 2008. PathScale, LLC. All Rights Reserved.
 */
/*
 *  Copyright (C) 2006, 2007. QLogic Corporation. All Rights Reserved.
 */

/*
 * Copyright 2004, 2005, 2006 PathScale, Inc.  All Rights Reserved.
 */

/*

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

   Path64 is free software; you can redistribute it and/or modify it
   under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2, or (at your option)
   any later version.

   Path64 is distributed in the hope that it will be useful, but WITHOUT
   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
   or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
   License for more details.

   You should have received a copy of the GNU General Public License
   along with Path64; see the file COPYING.  If not, write to the Free
   Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
   02110-1301, USA.

   Special thanks goes to SGI for their continued support to open source

*/



static char USMID[] = "\n@(#)5.0_pl/sources/p_end.c	5.7	09/01/99 09:11:00\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"
# include "p_end.h"


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

/* The prototypes for the end_.. routines are in p_end.h.  They are needed */
/* there so that the end routine calling table can be initialized.         */

static char	*blk_desc_str(int);
static boolean	 end_task_do_blk(void);
static void	 finish_cdir_id(void);
static void	 loop_end_processing(void);

# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
static void      check_loop_bottom_nesting(void);
# endif


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      If there were CDIR ID directives in the program unit, terminate the   *|
|*      USMID string with a null character.                                   *|
|*                                                                            *|
|*      Here's how this works.  Each !DIR$ ID line is assigned its own        *|
|*      compiler temp.  The size of the temp is the number or chars in the    *|
|*      string.  There is no null character at the end of the string.  For    *|
|*      instance if !DIR$ ID="hello", at temp is created of type CHAR*5.      *|
|*      This routine is called after all !DIR$ ID's have been parsed (at the  *|
|*      END statement.  Another temp is created whose length is at least one  *|
|*      character with the size such that the whole block is word aligned.    *|
|*      All the temps are in the same storage block and their offsets are     *|
|*      such that all the temps are concatenated together with the NULL at    *|
|*      the end of the last temp.                                             *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/
 
static void finish_cdir_id(void)
{

   size_offset_type	aligned_length;
   int                  column;
   int                  init_idx;
   size_offset_type	length;
   int                  line;
   int                  list_idx;
   id_str_type		name;
   int                  new_str_idx;
   opnd_type            opnd;
   int                  prog_unit_has_id_line;
   int			tmp_idx;
   int                  type_idx;


   TRACE (Func_Entry, "finish_cdir_id", NULL);
   
   CREATE_ID(name, sb_name[What_Blk], sb_len[What_Blk]);
   
   prog_unit_has_id_line = srch_stor_blk_tbl(name.string,
                                             sb_len[What_Blk],
                                             curr_scp_idx);

   if (prog_unit_has_id_line != NULL_IDX) {

      /* Must have an ID string.  Get a temp, initialize to null characters,  */
      /* then put into named static block.				      */

      line                            = curr_glb_line;
      column                          = 0;
      tmp_idx                    = gen_compiler_tmp(line, column, Shared, TRUE);
      ATD_STOR_BLK_IDX(tmp_idx)       = prog_unit_has_id_line;
      ATD_TMP_SEMANTICS_DONE(tmp_idx) = TRUE;
      ATD_OFFSET_ASSIGNED(tmp_idx)    = TRUE;

# if defined(_DEBUG)

      /* Must be a constant length. */

      if (SB_LEN_FLD(ATD_STOR_BLK_IDX(tmp_idx)) != CN_Tbl_Idx) {
         PRINTMSG(line, 1201, Internal, column, 
                  SB_NAME_PTR(ATD_STOR_BLK_IDX(tmp_idx)));
      }
# endif

      length.idx		= SB_LEN_IDX(ATD_STOR_BLK_IDX(tmp_idx));
      length.fld		= SB_LEN_FLD(ATD_STOR_BLK_IDX(tmp_idx));
      ATD_OFFSET_IDX(tmp_idx)	= length.idx;
      ATD_OFFSET_FLD(tmp_idx)	= length.fld;
      aligned_length.idx	= CN_INTEGER_CHAR_BIT_IDX;
      aligned_length.fld	= CN_Tbl_Idx;

      if (!size_offset_binary_calc(&length, &aligned_length, Plus_Opr, 
                                   &aligned_length)) {
         AT_DCL_ERR(tmp_idx)	= TRUE;
      }

      align_bit_length(&aligned_length, TARGET_BITS_PER_WORD);

      if (!size_offset_binary_calc(&aligned_length,&length,Minus_Opr,&length)) {
         AT_DCL_ERR(tmp_idx)	= TRUE;
      }

      if (aligned_length.fld == NO_Tbl_Idx) {
         aligned_length.fld	= CN_Tbl_Idx;
         aligned_length.idx	= ntr_const_tbl(aligned_length.type_idx,
                                                FALSE,
                                                aligned_length.constant);
      }

      SB_LEN_FLD(ATD_STOR_BLK_IDX(tmp_idx)) = aligned_length.fld;
      SB_LEN_IDX(ATD_STOR_BLK_IDX(tmp_idx)) = aligned_length.idx;

      /* We now have the length in bits of the null temp in length.      */
      /* This needs to be translated to # of chars for character length. */

      aligned_length.fld	= CN_Tbl_Idx;
      aligned_length.idx	= CN_INTEGER_CHAR_BIT_IDX;

      if (!size_offset_binary_calc(&length, &aligned_length, Div_Opr, &length)){
         AT_DCL_ERR(tmp_idx)	= TRUE;
      }

      if (length.fld == NO_Tbl_Idx) {
         length.fld	= CN_Tbl_Idx;
         length.idx	= ntr_const_tbl(length.type_idx,
                                        FALSE,
                                        length.constant);
      }

      OPND_FLD(opnd)               = AT_Tbl_Idx;
      OPND_IDX(opnd)               = tmp_idx;
      OPND_LINE_NUM(opnd)          = line;
      OPND_COL_NUM(opnd)           = column;

      CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
      TYP_TYPE(TYP_WORK_IDX)       = Character;
      TYP_LINEAR(TYP_WORK_IDX)     = CHARACTER_DEFAULT_TYPE;
      TYP_DESC(TYP_WORK_IDX)       = Default_Typed;
      TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char;
      TYP_FLD(TYP_WORK_IDX)        = CN_Tbl_Idx;
      TYP_IDX(TYP_WORK_IDX)        = length.idx;
      type_idx                     = ntr_type_tbl();

      /* Call ntr_const_tbl with NULL for the incoming constant so it         */
      /* will just allocate the amount of space needed.   ntr_const_tbl does  */
      /* zero out the memory.                                                 */

      new_str_idx = ntr_const_tbl(type_idx, TRUE, NULL);

      ATD_TYPE_IDX(tmp_idx) = CN_TYPE_IDX(new_str_idx);

      gen_whole_substring(&opnd, 0);

      /* Initialize the temp.  						      */

      NTR_IR_TBL(init_idx);
      IR_OPR(init_idx) = Init_Opr;
# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
      IR_OPR(init_idx) = Null_Opr;
# endif

      /* Must have a type idx.						      */

      IR_TYPE_IDX(init_idx)	= ATD_TYPE_IDX(tmp_idx);
      IR_LINE_NUM(init_idx)	= line;
      IR_COL_NUM(init_idx)	= column;
      IR_LINE_NUM_R(init_idx)	= line;
      IR_COL_NUM_R(init_idx)	= column;
      COPY_OPND(IR_OPND_L(init_idx), opnd);

      NTR_IR_LIST_TBL(list_idx);
      IR_FLD_R(init_idx)	= IL_Tbl_Idx;
      IR_IDX_R(init_idx)	= list_idx;
      IR_LIST_CNT_R(init_idx)	= 3;
      IL_IDX(IR_IDX_R(init_idx))= new_str_idx;

      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx))	= list_idx;
      IL_FLD(list_idx)					= CN_Tbl_Idx;
      IL_IDX(list_idx)					= new_str_idx;
      IL_LINE_NUM(list_idx)				= line;
      IL_COL_NUM(list_idx)				= column;

      list_idx			= IL_NEXT_LIST_IDX(list_idx);

      IL_FLD(list_idx)		= CN_Tbl_Idx;
      IL_IDX(list_idx)		= CN_INTEGER_ONE_IDX;
      IL_LINE_NUM(list_idx)	= line;
      IL_COL_NUM(list_idx)	= column;
         
      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
      list_idx					   = IL_NEXT_LIST_IDX(list_idx);
 
      IL_FLD(list_idx)		= CN_Tbl_Idx;
      IL_IDX(list_idx)		= CN_INTEGER_ZERO_IDX;
      IL_LINE_NUM(list_idx)	= line;
      IL_COL_NUM(list_idx)	= column;
         
      gen_sh(Before, Assignment_Stmt, line, column,
             FALSE, FALSE, TRUE);
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = init_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
      
   }

   TRACE (Func_Exit, "finish_cdir_id", NULL);

} /* finish_cdir_id */



/******************************************************************************\
|*									      *|
|* Description:								      *|
|*   If the kind specification of the function result hasn't been folded      *|
|*   yet, fold it now.							      *|
|*									      *|
|* Input parameters:							      *|
|*	Function attribute						      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

static void function_result_kindspec(void) {
int line, col, type, function_attr, save, m;
expr_arg_type expr_desc;

    if (OPND_FLD(function_ret_kindspec) == NO_Tbl_Idx)
	return;

    expr_desc.rank = 0;
    save = expr_mode;
    expr_mode = Initialization_Expr;
    m = expr_semantics(&function_ret_kindspec, &expr_desc);
    expr_mode = save;

    if (!m)
	return;

    line = OPND_LINE_NUM(function_ret_kindspec);
    col  = OPND_COL_NUM(function_ret_kindspec);

    if (expr_desc.rank != 0) {
	PRINTMSG(line, 907, Error, col);
	return;
    }
	
    if (OPND_FLD(function_ret_kindspec) != CN_Tbl_Idx) {
	PRINTMSG(line, 1531, Error, col);
	return;
    }

    function_attr = SCP_ATTR_IDX(curr_scp_idx);
    save = ATD_TYPE_IDX(AT_WORK_IDX);
    ATD_TYPE_IDX(AT_WORK_IDX) = function_ret_type;

    m = kind_to_linear_type(&function_ret_kindspec,
			    AT_WORK_IDX,
			    expr_desc.kind0seen,
			    expr_desc.kind0E0seen,
			    expr_desc.kind0D0seen,
			    !expr_desc.kindnotconst);

    ATD_TYPE_IDX(AT_WORK_IDX) = save;
    if (!m)
	return;

    ATD_TYPE_IDX(ATP_RSLT_IDX(function_attr)) = ATD_TYPE_IDX(AT_WORK_IDX);
}



/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Parse the END statement, find out what kind of end it is, check for   *|
|*      block errors, and call the particular end processing routine.         *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

void parse_end_stmt (void)

{
   int			blk_idx;
   int			buf_idx;
   boolean		found_name;
   token_values_type	keyword;
   boolean		match_name	= TRUE;
   boolean              msg_issued;
   int			stmt_num;


   TRACE (Func_Entry, "parse_end_stmt", NULL);

   end_of_contains = FALSE;

   if (LA_CH_VALUE == EOS) {

      /* If the END stmt is the action-stmt of a logical IF, don't parse it.  */

      if (if_stmt_lbl_idx != NULL_IDX) {
         NEXT_LA_CH;
         goto EXIT;
      }
         
      check_for_vestigial_task_blks();

      if (CURR_BLK == Contains_Blk) {
         end_contains(FALSE);
      }

      if (stmt_label_idx != NULL_IDX) {
         gen_attr_and_IR_for_lbl(FALSE);
      }

      blk_idx = blk_stk_idx;

      if (CURR_BLK > Interface_Body_Blk) {

         /* Search for the nearest program unit block if it's just an END     */
         /* stmt or if the current block was a popped CONTAINS block.  If     */
         /* there is a parse error, then just pop the current block.  Have    */
         /* end_of_contains check, because if a CONTAINS block is popped,     */
         /* then need to pop a program unit block.                            */

# ifdef _DEBUG
         if (blk_stk_idx == NULL_IDX) {
            PRINTMSG(stmt_start_line, 160, Internal, stmt_start_col, NULL_IDX);
         }
# endif

         if (stmt_label_idx == NULL_IDX) {

            for (blk_idx = blk_stk_idx;
                 BLK_TYPE(blk_idx) > Interface_Body_Blk;
                 blk_idx--);
         }
         else {

            /* If this END statement is the termination statement for a DO    */
            /* loop, issue an error message and pop the DO block.             */

            msg_issued = FALSE;
            blk_idx    = blk_stk_idx;

            while (BLK_TYPE(blk_idx) > Module_Proc_Blk) {

               if (stmt_label_idx == BLK_LABEL(blk_idx)) { 

                  if (! msg_issued) {
                     PRINTMSG(stmt_start_line, 244, Error, stmt_start_col,
                              stmt_type_str[stmt_type]);
                     msg_issued = TRUE;
                  }

                  if (blk_idx != blk_stk_idx) {
                     pop_and_err_blk_stk(blk_idx, FALSE);
                  }

                  move_blk_to_end(blk_idx);

                  POP_BLK_STK;
               }
               --blk_idx;
            }
         }
         blk_idx = blk_match_err(BLK_TYPE(blk_idx), FALSE, FALSE);
      }
   }
   else if (MATCHED_TOKEN_CLASS (Tok_Class_Keyword)) {
      keyword	= TOKEN_VALUE(token);
      buf_idx   = TOKEN_BUF_IDX(token);
      stmt_num  = TOKEN_STMT_NUM(token);

      check_for_vestigial_task_blks();

      if (keyword == Tok_Kwd_File) {
         stmt_type			= Endfile_Stmt;
         SH_STMT_TYPE(curr_stmt_sh_idx)	= Endfile_Stmt;

         if (stmt_label_idx != NULL_IDX) {
            gen_attr_and_IR_for_lbl(FALSE);
         }

         parse_endfile_stmt();
         goto EXIT;
      }
    
      /* If the END stmt is the action-stmt of a logical IF, don't parse it.  */

      if (if_stmt_lbl_idx != NULL_IDX) {
         parse_err_flush(Find_EOS, NULL);
         NEXT_LA_CH;
         goto EXIT;
      }
         
      if (keyword == Tok_Kwd_Block && 
          !matched_specific_token(Tok_Kwd_Data, Tok_Class_Keyword)) {
         reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
         keyword = Tok_Id;  /* Force to default clause for error */
      }

#ifdef KEY /* Bug 5550 */
      /* If we are ending an interface block which began with "operator(.x.)"
       * or "assignment(=)", the "end interface" may have an optional
       * "operator(.x.)" or "assignment(=)" too. Notice that there's no
       * confusion between "interface x" and "interface operator(.x.)" here
       * because the former generates upper case token "X" but the latter
       * generates lower case token "x". */
      int blk_name = BLK_NAME(blk_stk_idx);
      if (AT_OBJ_CLASS(blk_name) == Interface)
      {
	found_name = (LA_CH_VALUE != EOS) && parse_generic_spec();
      }
      else
#endif /* KEY Bug 5550 */

      found_name = MATCHED_TOKEN_CLASS(Tok_Class_Id);

      if (CURR_BLK == Contains_Blk && 
          (keyword == Tok_Kwd_Module   || keyword == Tok_Kwd_Program    ||
           keyword == Tok_Kwd_Function || keyword == Tok_Kwd_Subroutine ||
           keyword == Tok_Kwd_Block)) {

         /* Because a contains may happen in a BLOCKDATA unit (an error is    */
         /* issued), it must be popped off at the end of the blockdata.       */

         end_contains(FALSE);
      }

      if (found_name) {
         match_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) :
                              FALSE;
      }

      if (stmt_label_idx != NULL_IDX  &&  keyword != Tok_Kwd_Type) {
         gen_attr_and_IR_for_lbl(FALSE);
      } 

      blk_idx = blk_stk_idx;

      switch (keyword) {

	 case Tok_Kwd_Block:
            stmt_type			    = End_Blockdata_Stmt;
            SH_STMT_TYPE(curr_stmt_sh_idx)  = End_Blockdata_Stmt;
            SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;


            /* Issue any deferred src_input messages.                         */

            issue_deferred_msgs();


            if (CURR_BLK != Blockdata_Blk || !match_name) {
               blk_idx = blk_match_err(Blockdata_Blk, found_name, FALSE);

               if (CURR_BLK != Blockdata_Blk) {
                  SCP_IN_ERR(curr_scp_idx)	= TRUE;
               }
            }

	    break;


	 case Tok_Kwd_Module:
            stmt_type			    = End_Module_Stmt;
            SH_STMT_TYPE(curr_stmt_sh_idx)  = End_Module_Stmt;
            SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;


            /* Issue any deferred src_input messages.                         */

            issue_deferred_msgs();


            if (CURR_BLK != Module_Blk || !match_name) {
               blk_idx = blk_match_err(Module_Blk, found_name, FALSE);

               if (CURR_BLK != Module_Blk) {
                  SCP_IN_ERR(curr_scp_idx)	= TRUE;
               }
            }

	    break;


	 case Tok_Kwd_Program:
            stmt_type			    = End_Program_Stmt;
            SH_STMT_TYPE(curr_stmt_sh_idx)  = End_Program_Stmt;

            if (stmt_label_idx != NULL_IDX) {
               end_labeled_do();
               blk_idx = blk_stk_idx;	/* end_labeled_do may have popped stk.*/
            }


            /* Issue any deferred src_input messages.                         */

            issue_deferred_msgs();


            if (CURR_BLK != Program_Blk || !match_name) {
               blk_idx = blk_match_err(Program_Blk, found_name, FALSE);

               if (CURR_BLK != Program_Blk) {
                  SCP_IN_ERR(curr_scp_idx)	= TRUE;
               }
            }

	    break;


	 case Tok_Kwd_Subroutine:
            stmt_type			    = End_Subroutine_Stmt;
            SH_STMT_TYPE(curr_stmt_sh_idx)  = End_Subroutine_Stmt;

            if (stmt_label_idx != NULL_IDX) {
               end_labeled_do();
               blk_idx = blk_stk_idx;	/* end_labeled_do may have popped stk.*/
            }


            /* Issue any deferred src_input messages.                         */

            issue_deferred_msgs();


            if (STMT_CANT_BE_IN_BLK(End_Subroutine_Stmt, CURR_BLK) ||
                !match_name || ATP_PGM_UNIT(CURR_BLK_NAME) != Subroutine) {
               blk_idx = blk_match_err(Subroutine_Blk, found_name, FALSE);
               SCP_IN_ERR(curr_scp_idx)	= TRUE;
            }

	    break;


	 case Tok_Kwd_Function:
            stmt_type			    = End_Function_Stmt;
            SH_STMT_TYPE(curr_stmt_sh_idx)  = End_Function_Stmt;

            if (stmt_label_idx != NULL_IDX) {
               end_labeled_do();
               blk_idx = blk_stk_idx;	/* end_labeled_do may have popped stk.*/
            }


            /* Issue any deferred src_input messages.                         */

            issue_deferred_msgs();


            if (STMT_CANT_BE_IN_BLK(End_Function_Stmt, CURR_BLK) ||
                !match_name || ATP_PGM_UNIT(CURR_BLK_NAME) != Function) {
               blk_idx = blk_match_err(Function_Blk, found_name, FALSE);
               SCP_IN_ERR(curr_scp_idx)	= TRUE;
            }

	    break;


	 case Tok_Kwd_Interface:

            stmt_type				= End_Interface_Stmt;
            SH_STMT_TYPE(curr_stmt_sh_idx)	= End_Interface_Stmt;

            if (CURR_BLK != Interface_Blk || !match_name) {
               blk_idx = blk_match_err(Interface_Blk, found_name, FALSE);
            }

            if (blk_idx != NULL_IDX) {
               curr_stmt_category = Declaration_Stmt_Cat;
            }

	    break;

#ifdef KEY /* Bug 10572 */
	 case Tok_Kwd_Enum:

            stmt_type				= End_Enum_Stmt;
            SH_STMT_TYPE(curr_stmt_sh_idx)	= End_Enum_Stmt;

            if (CURR_BLK != Enum_Blk || !match_name) {
               blk_idx = blk_match_err(Enum_Blk, found_name, FALSE);
            }

            if (blk_idx != NULL_IDX) {
               curr_stmt_category = Declaration_Stmt_Cat;
            }

	    break;
#endif /* KEY Bug 10572 */


	 case Tok_Kwd_Type:

            stmt_type				= End_Type_Stmt;
            SH_STMT_TYPE(curr_stmt_sh_idx)	= End_Type_Stmt;

            if (CURR_BLK != Derived_Type_Blk  ||  !match_name) {
               blk_idx = blk_match_err(Derived_Type_Blk, found_name, FALSE);
            }

            if (blk_idx != NULL_IDX) {
               curr_stmt_category = Declaration_Stmt_Cat;
            }

	    break;


	 case Tok_Kwd_If:
            stmt_type				= End_If_Stmt;
            SH_STMT_TYPE(curr_stmt_sh_idx)	= End_If_Stmt;


            /* The END IF stmt must have a construct name if the              */
            /* corresponding IF stmt has a construct name.  The names must    */
            /* be the same, of course.					      */

            if (CURR_BLK_NAME != NULL_IDX  &&  ! found_name) {
               match_name = FALSE;   
            }

            if (STMT_CANT_BE_IN_BLK(End_If_Stmt, CURR_BLK)  ||  ! match_name) {
               blk_idx = blk_match_err(If_Blk, found_name, TRUE);
            }

            if ((cif_flags & XREF_RECS)  &&  found_name  &&  match_name) {

               /* There are 3 cases to consider at this point:		      */
               /*   - The construct-name on the END IF matches the construct- */
               /*     name on the current IF construct.			      */
               /*   - The construct-name on the END IF matches the construct- */
               /*     name on some other IF construct.			      */
               /*   - No matching construct-name on an IF construct was found */
               /*     but the current block is an IF construct with a         */
               /*     construct-name.					      */
               /* The result of each of these cases is that the current Block */
               /* Stack frame has a nonnull BLK_NAME.  There is no way to tell*/
               /* whether or not the construct-name matches the END IF        */
               /* construct-name other than by comparing the strings.         */
               /* We also must ensure that CURR_BLK_NAME is not null (this    */
               /* happens if no match was found and the top Block Stack frame */
               /* has no name).						      */
               /* We can not call cif_usage_rec unless we find a matching     */
               /* name because an Attr only exists if the name is defined     */
               /* somewhere (and we need the Attr to hold the CIF symbol id). */

               cif_usage_rec(CURR_BLK_NAME,
                             AT_Tbl_Idx,
		             TOKEN_LINE(token),
                             TOKEN_COLUMN(token),
		   	     CIF_Construct_Name_Reference);
            }
            
	    break;


	 case Tok_Kwd_Do:
            stmt_type				= End_Do_Stmt;
            SH_STMT_TYPE(curr_stmt_sh_idx)	= End_Do_Stmt;


            /* The END DO stmt must have a construct name if the              */
            /* corresponding DO stmt has a construct name.  The names must    */
            /* be the same, of course.					      */

            if (CURR_BLK_NAME != NULL_IDX  &&   ! found_name) {
               match_name = FALSE;   
            }

            if (STMT_CANT_BE_IN_BLK(End_Do_Stmt, CURR_BLK) || !match_name) {
               blk_idx = blk_match_err(Do_Blk, found_name, TRUE);
            }

            if ((cif_flags & XREF_RECS) && found_name && match_name) {

               /* See the comment block in the END IF code above for the      */
               /* cases that must be considered.	   		      */

               cif_usage_rec(CURR_BLK_NAME,
                             AT_Tbl_Idx,
                             TOKEN_LINE(token),
                             TOKEN_COLUMN(token),
                             CIF_Construct_Name_Reference);
            }

	    break;


	 case Tok_Kwd_Select:
            stmt_type				= End_Select_Stmt;
            SH_STMT_TYPE(curr_stmt_sh_idx)	= End_Select_Stmt;


            /* The END SELECT stmt must have a construct name if the          */
            /* corresponding SELECT CASE stmt has a construct name.  The      */
            /* names must be the same, of course.			      */

            if (CURR_BLK_NAME != NULL_IDX  &&  ! found_name) {
               match_name = FALSE; 
            }

            if (STMT_CANT_BE_IN_BLK(End_Select_Stmt, CURR_BLK) || !match_name) {
               blk_idx = blk_match_err(Select_Blk, found_name, TRUE);
            }


            if ((cif_flags & XREF_RECS)  &&  found_name  &&  match_name) {

               /* See the comment block in the END IF code above for the      */
               /* cases that must be considered.			      */

               cif_usage_rec(CURR_BLK_NAME,
                             AT_Tbl_Idx,
		             TOKEN_LINE(token),
                             TOKEN_COLUMN(token),
		   	     CIF_Construct_Name_Reference);
            }

	    break;

	 case Tok_Kwd_Forall:

            stmt_type				= End_Forall_Stmt;
            SH_STMT_TYPE(curr_stmt_sh_idx)	= End_Forall_Stmt;

            /* The END FORALL stmt must have a construct name if the          */
            /* corresponding FORALL stmt has a construct name.  The names must*/
            /* be the same, of course.                                        */

            if (CURR_BLK_NAME != NULL_IDX  &&  ! found_name) {
               match_name = FALSE;
            }

            if (STMT_CANT_BE_IN_BLK(End_Forall_Stmt, CURR_BLK)  || !match_name){
               blk_idx = blk_match_err(Forall_Blk, found_name, TRUE);
            }

	    break;

	 case Tok_Kwd_Where:

            stmt_type				= End_Where_Stmt;
            SH_STMT_TYPE(curr_stmt_sh_idx)	= End_Where_Stmt;

            /* The END WHERE stmt must have a construct name if the           */
            /* corresponding WHERE stmt has a construct name.  The names must */
            /* be the same, of course.                                        */

            if (CURR_BLK_NAME != NULL_IDX  &&  ! found_name) {
               match_name = FALSE;
            }

            if (STMT_CANT_BE_IN_BLK(End_Where_Stmt, CURR_BLK) || !match_name) {
               blk_idx = blk_match_err(Where_Then_Blk, found_name, TRUE);
            }

	    break;


	 default:
            reset_lex(buf_idx, stmt_num);
            MATCHED_TOKEN_CLASS(Tok_Class_Id);

            /* Msg is expecting END, for whatever is the CURRENT block.  If   */
            /* the current block is a CONTAINS block, pop it and we'll assume */
            /* this is supposed to be a END PROGRAM, END MODULE, END FUNCTION */
            /* or END SUBROUTINE statement.  The SELECT CASE construct is     */
            /* weird because its END statement does not make use of both of   */
            /* the construct keywords SELECT and CASE.                        */

            if (CURR_BLK == Contains_Blk) {
               end_contains(FALSE);
            }

            PRINTMSG(TOKEN_LINE(token), 186, Error, TOKEN_COLUMN(token),
                     (CURR_BLK == Select_Blk) ? "SELECT" :
                        blk_desc_str(blk_stk_idx),
                     TOKEN_STR(token));

            /* Do not POP the block - but mark it in error - (like popping)   */

            CURR_BLK_ERR			= TRUE;
            SH_ERR_FLG(curr_stmt_sh_idx)	= TRUE;
            blk_idx				= NULL_IDX;
            parse_err_flush(Find_EOS, NULL);
	    break;

      }  /* switch */

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

   }
   else {  /* Didn't find EOS and didn't find keyword. */
      PRINTMSG(LA_CH_LINE, 769, Error, LA_CH_COLUMN,
               (CURR_BLK == Select_Blk) ? "SELECT" : blk_desc_str(blk_stk_idx),
               LA_CH_VALUE);

      parse_err_flush(Find_EOS, NULL);

      /* Do not POP the block - but mark it in error - (like popping)   */

      if (if_stmt_lbl_idx == NULL_IDX) {
         CURR_BLK_ERR = TRUE;
      }

      blk_idx = NULL_IDX;
   }


   if (blk_idx != NULL_IDX) {   /* call the END routine for block */

      /* Finish up any CDIR$ ID strings.                                      */

      if ( (BLK_TYPE(blk_idx) >= Blockdata_Blk) && 
           (BLK_TYPE(blk_idx) <= Subroutine_Blk) ) {
         finish_cdir_id();
      }

      if (stmt_type == End_Function_Stmt ||
	  (BLK_TYPE(blk_idx) == Function_Blk && stmt_type == End_Stmt)) {
	  function_result_kindspec();
      }

      (*end_blocks[BLK_TYPE(blk_idx)]) (FALSE);
   }

   /* We should be sitting at EOS.  Check to see if this is a continued END   */
   /* statement.  If it is, issue an ANSI.  stmt_line_idx is from src_input   */

   if (LA_CH_VALUE == EOS && stmt_line_idx > 1) {
      PRINTMSG(LA_CH_LINE, 1640, Ansi, LA_CH_COLUMN);
   }

   /* Save the line and column of the EOS (which tells us where the END stmt  */
   /* really ends).  Eat the EOS.  If we are not at the end of the file, then */
   /* the next program unit either starts on the current line or the line     */
   /* immediately following.						      */

   cif_end_unit_line   = LA_CH_LINE;
   cif_end_unit_column = LA_CH_COLUMN - 1;

   NEXT_LA_CH;

   if (EOPU_encountered  &&  LA_CH_CLASS != Ch_Class_EOF) {
      cif_pgm_unit_start_line =
         (LA_CH_LINE == cif_end_unit_line) ? cif_end_unit_line :
                                             cif_end_unit_line + 1;
   }

EXIT:

   TRACE (Func_Exit, "parse_end_stmt", NULL);

   return;

}  /* parse_end_stmt */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END statement for a main program.      *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_program_unit(boolean	err_call)

{
   int          ir_idx;
   int          glb_idx;
   int          rtn_idx;
   int          act_file_line;


   TRACE (Func_Entry, "end_program_unit", NULL);


   do_cmic_blk_checks();

   if (glb_tbl_idx[End_Attr_Idx] == NULL_IDX) {
      glb_tbl_idx[End_Attr_Idx] = create_lib_entry_attr(END_LIB_ENTRY,
                                                        END_NAME_LEN,
                                                        TOKEN_LINE(token),
                                                        TOKEN_COLUMN(token));
      ATP_NOSIDE_EFFECTS(glb_tbl_idx[End_Attr_Idx])	= TRUE;
   }

   ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[End_Attr_Idx]);

   NTR_IR_TBL(ir_idx);
   IR_OPR(ir_idx)              = Call_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);

   GLOBAL_LINE_TO_FILE_LINE(TOKEN_LINE(token), glb_idx, act_file_line);
   GL_SOURCE_LINES(global_line_tbl_idx) = act_file_line;
   set_related_gl_source_lines(global_line_tbl_idx);

   IR_FLD_L(ir_idx)            = AT_Tbl_Idx;
   IR_IDX_L(ir_idx)            = glb_tbl_idx[End_Attr_Idx];
   IR_COL_NUM_L(ir_idx)        = IR_COL_NUM(ir_idx);
   IR_LINE_NUM_L(ir_idx)       = IR_LINE_NUM(ir_idx); 

   if (err_call) {  /* This is an error situation */
      gen_sh(Before, End_Program_Stmt, stmt_start_line, stmt_start_col,
             TRUE, FALSE, FALSE);

      SCP_LAST_SH_IDX(curr_scp_idx)		= SH_PREV_IDX(curr_stmt_sh_idx);
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))	= ir_idx;
      SCP_IN_ERR(curr_scp_idx)			= TRUE;
   }
   else {
      SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx;
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;

      NTR_IR_TBL(rtn_idx);
      IR_TYPE_IDX(rtn_idx) = TYPELESS_DEFAULT_TYPE;
      IR_OPR(rtn_idx) = Return_Opr;
      IR_LINE_NUM(rtn_idx) = IR_LINE_NUM(ir_idx);
      IR_COL_NUM(rtn_idx) = IR_COL_NUM(ir_idx);
      gen_sh(After,
             Return_Stmt,
             IR_LINE_NUM(ir_idx),
             IR_COL_NUM(ir_idx),
             FALSE,
             TRUE,
             TRUE);
      SH_IR_IDX(curr_stmt_sh_idx) = rtn_idx;
      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

      if (stmt_label_idx != NULL_IDX && !err_call) {
         ATL_CLASS(stmt_label_idx) = Lbl_User;
         ATL_DEBUG_CLASS(stmt_label_idx) = Ldbg_User_Lbl;
         ATL_EXECUTABLE(stmt_label_idx)	= TRUE;

         if (!AT_DEFINED(stmt_label_idx)  && 
              ATL_FWD_REF_IDX(stmt_label_idx) != NULL_IDX) {
            resolve_fwd_lbl_refs();
         }

         stmt_label_idx = NULL_IDX;
      }

      if (cmd_line_flags.debug_lvl == Debug_Lvl_0) {  /* -ed  -G0 */

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

   EOPU_encountered			     = TRUE;
   curr_stmt_category			     = Init_Stmt_Cat;

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

   if (cif_flags & BASIC_RECS) {
      cif_end_scope_rec();
   }

   if (err_call  &&  ! clearing_blk_stk) {

      /* Needed for both CIF and buffered message file.			      */

      if (cif_flags & BASIC_RECS) {
         cif_send_attr(SCP_ATTR_IDX(curr_scp_idx), NULL_IDX);
      }
      cif_end_unit_rec(AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
   }

   ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE;

   POP_BLK_STK;
   PRINT_SCP_TBL;
   PRINT_EQV_TBL;

   TRACE (Func_Exit, "end_program_unit", NULL);

   return;

}  /* end_program_unit */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END statement for a FUNCTION program.  *|
|*	This is for external FUNCTIONS only.  Internal, module, and interface *|
|*	FUNCTIONS have their own end routines.                                *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_function(boolean	err_call)
{
   int		idx;
   int		ir_idx;
   int		glb_idx;
   int		act_file_line;


   TRACE (Func_Entry, "end_function", NULL);

   do_cmic_blk_checks();

   NTR_IR_TBL(ir_idx);

   IR_OPR(ir_idx)	= Return_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);

   GLOBAL_LINE_TO_FILE_LINE(TOKEN_LINE(token), glb_idx, act_file_line);
   GL_SOURCE_LINES(global_line_tbl_idx) = act_file_line;
   set_related_gl_source_lines(global_line_tbl_idx);

   if (err_call) {  /* This is an error situation */
      gen_sh(Before, End_Function_Stmt, stmt_start_line, stmt_start_col,
             TRUE, FALSE, FALSE);

      SCP_LAST_SH_IDX(curr_scp_idx)		= SH_PREV_IDX(curr_stmt_sh_idx);
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))	= ir_idx;
      SCP_IN_ERR(curr_scp_idx)			= TRUE;
   }
   else {
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
      SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx;
      SH_STMT_TYPE(curr_stmt_sh_idx) = End_Function_Stmt;

      if (stmt_label_idx != NULL_IDX) {
         ATL_CLASS(stmt_label_idx) = Lbl_User;
         ATL_DEBUG_CLASS(stmt_label_idx) = Ldbg_User_Lbl;
         ATL_EXECUTABLE(stmt_label_idx)	= TRUE;

         if (!AT_DEFINED(stmt_label_idx)  && 
              ATL_FWD_REF_IDX(stmt_label_idx) != NULL_IDX) {
            resolve_fwd_lbl_refs();
         }

         stmt_label_idx = NULL_IDX;
      }

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

   EOPU_encountered	           = TRUE;
   curr_stmt_category	           = Init_Stmt_Cat;

   /* Entry points are linked thru the current scopes SCP_ENTRY_IDX.  This   */
   /* points to the attr list table, which contains a list of all entry pts. */

   if (cif_flags & MISC_RECS) {
      cif_stmt_type_rec(TRUE, CIF_End_Function_Stmt, statement_number);
   }
 
   if (cif_flags & BASIC_RECS) {
      cif_end_scope_rec();
   }

   if (err_call  &&  ! clearing_blk_stk) {

      /* Needed for both CIF and buffered message file.			      */

      if (cif_flags & BASIC_RECS) {
         cif_send_attr(SCP_ATTR_IDX(curr_scp_idx), NULL_IDX);
      }
      cif_end_unit_rec(AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));

      ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx))	= FALSE;
      idx					= SCP_ENTRY_IDX(curr_scp_idx);

      while (idx != NULL_IDX) {

         if (cif_flags & BASIC_RECS) {
            cif_send_attr(AL_ATTR_IDX(idx), NULL_IDX);
         }
         ATP_SCP_ALIVE(AL_ATTR_IDX(idx))	= FALSE;
         idx				= AL_NEXT_IDX(idx);
      }
   }
   else {

      ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx))	= FALSE;
      idx					= SCP_ENTRY_IDX(curr_scp_idx);

      while (idx != NULL_IDX) {
         ATP_SCP_ALIVE(AL_ATTR_IDX(idx))	= FALSE;
         idx				= AL_NEXT_IDX(idx);
      }
   }

   POP_BLK_STK;
   PRINT_SCP_TBL;
   PRINT_EQV_TBL;

   TRACE (Func_Exit, "end_function", NULL);

   return;

}  /* end_function */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END statement for a SUBROUTINE program.*|
|*	This is for external SUBROUTINES only.  Internal, module, and         *|
|*	interface SUBROUTINES have their own end routines.                    *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_subroutine(boolean	err_call)

{
   int		idx;
   int		ir_idx;
   int		glb_idx;
   int		act_file_line;


   TRACE (Func_Entry, "end_subroutine", NULL);

   do_cmic_blk_checks();

   NTR_IR_TBL(ir_idx);

   IR_OPR(ir_idx)	= Return_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);

   GLOBAL_LINE_TO_FILE_LINE(TOKEN_LINE(token), glb_idx, act_file_line);
   GL_SOURCE_LINES(global_line_tbl_idx) = act_file_line;
   set_related_gl_source_lines(global_line_tbl_idx);

   if (ATP_HAS_ALT_RETURN(SCP_ATTR_IDX(curr_scp_idx))) {
      /* if no alt return spec was specified, supply zero */
      IR_FLD_L(ir_idx) = CN_Tbl_Idx;
      IR_IDX_L(ir_idx) = CN_INTEGER_ZERO_IDX;
      IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
      IR_COL_NUM_L(ir_idx)  = TOKEN_COLUMN(token);
   }

   if (err_call) {  /* This is an error situation */
      gen_sh(Before, End_Subroutine_Stmt, stmt_start_line, stmt_start_col,
             TRUE, FALSE, FALSE);

      SCP_LAST_SH_IDX(curr_scp_idx) = SH_PREV_IDX(curr_stmt_sh_idx);
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
      SCP_IN_ERR(curr_scp_idx) = TRUE;
   }
   else {
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
      SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx;

      if (stmt_label_idx != NULL_IDX) {
         ATL_CLASS(stmt_label_idx) = Lbl_User;
         ATL_DEBUG_CLASS(stmt_label_idx) = Ldbg_User_Lbl;
         ATL_EXECUTABLE(stmt_label_idx)	= TRUE;

         if (!AT_DEFINED(stmt_label_idx)  && 
              ATL_FWD_REF_IDX(stmt_label_idx) != NULL_IDX) {
            resolve_fwd_lbl_refs();
         }

         end_labeled_do();
         stmt_label_idx = NULL_IDX;
      }

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

   EOPU_encountered		   = TRUE;
   curr_stmt_category		   = Init_Stmt_Cat;

   /* Entry points are linked thru the current scopes SCP_ENTRY_IDX.  This   */
   /* points to the attr list table, which contains a list of all entry pts. */

   if (cif_flags & MISC_RECS) {
      cif_stmt_type_rec(TRUE, CIF_End_Subroutine_Stmt, statement_number);
   }
 
   if (cif_flags & BASIC_RECS) {
      cif_end_scope_rec();
   }

   if (err_call  &&  ! clearing_blk_stk) {

      /* Needed for both CIF and buffered message file.			      */

      if (cif_flags & BASIC_RECS) {
         cif_send_attr(SCP_ATTR_IDX(curr_scp_idx), NULL_IDX);
      }
      cif_end_unit_rec(AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));

      ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx))	= FALSE;
      idx					= SCP_ENTRY_IDX(curr_scp_idx);

      while (idx != NULL_IDX) {

         if (cif_flags & BASIC_RECS) {
            cif_send_attr(AL_ATTR_IDX(idx), NULL_IDX);
         }
         ATP_SCP_ALIVE(AL_ATTR_IDX(idx))	= FALSE;
         idx					= AL_NEXT_IDX(idx);
      }
   }
   else {
      ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx))	= FALSE;
      idx					= SCP_ENTRY_IDX(curr_scp_idx);

      while (idx != NULL_IDX) {
         ATP_SCP_ALIVE(AL_ATTR_IDX(idx))	= FALSE;
         idx					= AL_NEXT_IDX(idx);
      }
   }

   POP_BLK_STK;
   PRINT_SCP_TBL;
   PRINT_EQV_TBL;

   TRACE (Func_Exit, "end_subroutine", NULL);

   return;

}  /* end_subroutine */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END statement for a MODULE program.    *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_module(boolean	err_call)
{

   int      act_file_line;
   int      glb_idx;


   TRACE (Func_Entry, "end_module", NULL);

   GLOBAL_LINE_TO_FILE_LINE(stmt_start_line, glb_idx, act_file_line);
   GL_SOURCE_LINES(global_line_tbl_idx) = act_file_line;
   set_related_gl_source_lines(global_line_tbl_idx);

   if (err_call) {  /* This is an error situation */
      gen_sh(Before, End_Module_Stmt, stmt_start_line, stmt_start_col,
             TRUE, FALSE, FALSE);
      SCP_LAST_SH_IDX(curr_scp_idx) = SH_PREV_IDX(curr_stmt_sh_idx);
      SCP_IN_ERR(curr_scp_idx) = TRUE;
   }
   else {
      SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx;

      if (stmt_label_idx != NULL_IDX && !err_call) {
         ATL_CLASS(stmt_label_idx) = Lbl_User;
         ATL_DEBUG_CLASS(stmt_label_idx) = Ldbg_User_Lbl;
         ATL_EXECUTABLE(stmt_label_idx)	= TRUE;

         if (!AT_DEFINED(stmt_label_idx) && 
              ATL_FWD_REF_IDX(stmt_label_idx) != NULL_IDX) {
            resolve_fwd_lbl_refs();
         }
         stmt_label_idx = NULL_IDX;
      }
   }

   EOPU_encountered		    	     = TRUE;
   curr_stmt_category			     = Init_Stmt_Cat;

   if (cif_flags & MISC_RECS) {
      cif_stmt_type_rec(TRUE, CIF_End_Module_Stmt, statement_number);
   }
 
   if (cif_flags & BASIC_RECS) {
      cif_end_scope_rec();
   }

   if (err_call  &&  ! clearing_blk_stk) {

      /* Needed for both CIF and buffered message file.			      */

      if (cif_flags & BASIC_RECS) {
         cif_send_attr(SCP_ATTR_IDX(curr_scp_idx), NULL_IDX);
      }
      cif_end_unit_rec(AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
   }

   ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE;

   POP_BLK_STK;
   PRINT_SCP_TBL;
   PRINT_EQV_TBL;

   TRACE (Func_Exit, "end_module", NULL);

   return;

}  /* end_module */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END statement for a BLOCKDATA program. *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_blockdata(boolean	err_call)
{

int       glb_idx;
int       act_file_line;

   TRACE (Func_Entry, "end_blockdata", NULL);

   GLOBAL_LINE_TO_FILE_LINE(stmt_start_line, glb_idx, act_file_line);
   GL_SOURCE_LINES(global_line_tbl_idx) = act_file_line;
   set_related_gl_source_lines(global_line_tbl_idx);

   if (err_call) {  /* This is an error situation */
      gen_sh(Before, End_Blockdata_Stmt, stmt_start_line, stmt_start_col,
             TRUE, FALSE, FALSE);
      SCP_LAST_SH_IDX(curr_scp_idx) = SH_PREV_IDX(curr_stmt_sh_idx);
      SCP_IN_ERR(curr_scp_idx) = TRUE;
   }
   else {
      SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx;

      if (stmt_label_idx != NULL_IDX && !err_call) {
         ATL_CLASS(stmt_label_idx) = Lbl_User;
         ATL_DEBUG_CLASS(stmt_label_idx) = Ldbg_User_Lbl;
         ATL_EXECUTABLE(stmt_label_idx)	= TRUE;

         if (!AT_DEFINED(stmt_label_idx)  && 
              ATL_FWD_REF_IDX(stmt_label_idx) != NULL_IDX) {
            resolve_fwd_lbl_refs();
         }
         stmt_label_idx = NULL_IDX;
      }
   }

   EOPU_encountered			     = TRUE;
   curr_stmt_category			     = Init_Stmt_Cat;
   ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE;

   if (cif_flags & MISC_RECS) {
      cif_stmt_type_rec(TRUE, CIF_End_Block_Data_Stmt, statement_number);
   }
 
   if (cif_flags & BASIC_RECS) {
      cif_end_scope_rec();
   }

   if (err_call  &&  ! clearing_blk_stk) {

      /* Needed for both CIF and buffered message file.			      */

      if (cif_flags & BASIC_RECS) {
         cif_send_attr(SCP_ATTR_IDX(curr_scp_idx), NULL_IDX);
      }
      cif_end_unit_rec(AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
   }

   ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE;

   POP_BLK_STK;
   PRINT_SCP_TBL;
   PRINT_EQV_TBL;

   TRACE (Func_Exit, "end_blockdata", NULL);

   return;

}  /* end_blockdata */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END statement for an internal procedure*|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_internal_proc(boolean	err_call)

{
   int		 attr_idx;
   int		 ir_idx;

   TRACE (Func_Entry, "end_internal_proc", NULL);

#ifdef KEY /* Bug 14110 */
   revisit_volatile();
#endif /* KEY Bug 14110 */

   do_cmic_blk_checks();

   NTR_IR_TBL(ir_idx);

   IR_OPR(ir_idx)	= Return_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);
   attr_idx		= SCP_ATTR_IDX(curr_scp_idx);

   if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Subroutine &&
       ATP_HAS_ALT_RETURN(SCP_ATTR_IDX(curr_scp_idx))) {
      /* if no alt return spec was specified, supply zero */
      IR_FLD_L(ir_idx) = CN_Tbl_Idx;
      IR_IDX_L(ir_idx) = CN_INTEGER_ZERO_IDX;
      IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
      IR_COL_NUM_L(ir_idx)  = TOKEN_COLUMN(token);
   }

   if (err_call) {  /* This is an error situation */
      gen_sh(Before,
             stmt_type,
             stmt_start_line,
             stmt_start_col,
             TRUE,
             FALSE,
             FALSE);

      SCP_LAST_SH_IDX(curr_scp_idx)		= SH_PREV_IDX(curr_stmt_sh_idx);
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))	= ir_idx;
      SCP_IN_ERR(curr_scp_idx)			= TRUE;
   }
   else {
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
      SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx;

      if (stmt_label_idx != NULL_IDX) {
         ATL_CLASS(stmt_label_idx) = Lbl_User;
         ATL_DEBUG_CLASS(stmt_label_idx) = Ldbg_User_Lbl;
         ATL_EXECUTABLE(stmt_label_idx) = TRUE;

         if (!AT_DEFINED(stmt_label_idx) && 
              ATL_FWD_REF_IDX(stmt_label_idx) != NULL_IDX) {
            resolve_fwd_lbl_refs();
         }
         stmt_label_idx = NULL_IDX;
      }

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

   if (cif_flags & BASIC_RECS) {
      cif_end_scope_rec();
   }

   if (cif_flags & MISC_RECS) {
      cif_stmt_type_rec(TRUE, (ATP_PGM_UNIT(attr_idx) == Function) ?
                               CIF_End_Function_Stmt : CIF_End_Subroutine_Stmt,
                        statement_number);
   }
 
   if (stmt_type == End_Stmt) {
      PRINTMSG(stmt_start_line, 86, Error, stmt_start_col,
               "internal-procedure",
               (ATP_PGM_UNIT(attr_idx) == Function) ? "FUNCTION" :
                                                      "SUBROUTINE");
   }

   curr_stmt_category		   = Sub_Func_Stmt_Cat;
   ATP_SCP_ALIVE(attr_idx)	   = FALSE;
   curr_scp_idx			   = SCP_PARENT_IDX(curr_scp_idx);

   /* SH_NEXT_IDX of curr_stmt_sh_idx is NULL_IDX and will stay that way,   */
   /* because if there are SH's for the parent, curr_stmt_sh_idx will be    */
   /* set to the last of them.  If there are no stmt headers for the parent */
   /* a new statement header will be generated.  The only way there should  */
   /* be no SH's for the parent is if the parent is an interface block.  If */
   /* this is true, we're in a scoping error situation, because internal    */
   /* procedures cannot be in an interface block.  We check for this to     */
   /* prevent aborts and other bad things, if we're in an error situation.  */

   if (SCP_LAST_SH_IDX(curr_scp_idx) == NULL_IDX) { /* No IR for parent scp */
      curr_stmt_sh_idx			= ntr_sh_tbl();
      SCP_FIRST_SH_IDX(curr_scp_idx)	= curr_stmt_sh_idx;
      need_new_sh			= FALSE;   /* Use this SH */
   }
   else {
      curr_stmt_sh_idx			= SCP_LAST_SH_IDX(curr_scp_idx);
   }

   POP_BLK_STK;
   PRINT_SCP_TBL;
   PRINT_EQV_TBL;

   TRACE (Func_Exit, "end_internal_proc", NULL);

   return;

}  /* end_internal_proc */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END statement for a module procedure.  *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_module_proc(boolean	err_call)

{
   int		attr_idx;
   int		idx;
   int		ir_idx;


   TRACE (Func_Entry, "end_module_proc", NULL);

#ifdef KEY /* Bug 14110 */
   revisit_volatile();
#endif /* KEY Bug 14110 */

   do_cmic_blk_checks();

   NTR_IR_TBL(ir_idx);

   IR_OPR(ir_idx)		= Return_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);
   attr_idx			= SCP_ATTR_IDX(curr_scp_idx);

   if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Subroutine &&
       ATP_HAS_ALT_RETURN(SCP_ATTR_IDX(curr_scp_idx))) {
      /* if no alt return spec was specified, supply zero */
      IR_FLD_L(ir_idx) = CN_Tbl_Idx;
      IR_IDX_L(ir_idx) = CN_INTEGER_ZERO_IDX;
      IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
      IR_COL_NUM_L(ir_idx)  = TOKEN_COLUMN(token);
   }

   if (err_call) {  /* This is an error situation */
      gen_sh(Before,
             stmt_type,
             stmt_start_line,
             stmt_start_col,
             TRUE,
             FALSE,
             FALSE);

      SCP_LAST_SH_IDX(curr_scp_idx) = SH_PREV_IDX(curr_stmt_sh_idx);
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
      SCP_IN_ERR(curr_scp_idx) = TRUE;
   }
   else {
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
      SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx;

      if (stmt_label_idx != NULL_IDX) {
         ATL_CLASS(stmt_label_idx)      	= Lbl_User;
         ATL_DEBUG_CLASS(stmt_label_idx)	= Ldbg_User_Lbl;
         ATL_EXECUTABLE(stmt_label_idx) 	= TRUE;

         if (!AT_DEFINED(stmt_label_idx) && 
              ATL_FWD_REF_IDX(stmt_label_idx) != NULL_IDX) {
            resolve_fwd_lbl_refs();
         }

         stmt_label_idx = NULL_IDX;
      }

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

   if (cif_flags & BASIC_RECS) {
      cif_end_scope_rec();
   }

   if (cif_flags & MISC_RECS) {
      cif_stmt_type_rec(TRUE, (ATP_PGM_UNIT(CURR_BLK_NAME) == Function) ?
                               CIF_End_Function_Stmt : CIF_End_Subroutine_Stmt,
                        statement_number);
   }

   if (stmt_type == End_Stmt) {
      PRINTMSG(stmt_start_line, 86, Error,
               stmt_start_col,
               "module-procedure",
               (ATP_PGM_UNIT(CURR_BLK_NAME) == Function) ? "FUNCTION" :
                                                           "SUBROUTINE");
   }

   ATP_SCP_ALIVE(attr_idx) = FALSE;

   /* Entry points are linked thru the current scopes SCP_ENTRY_IDX.  This   */
   /* points to the attr list table, which contains a list of all entry pts. */

   idx = SCP_ENTRY_IDX(curr_scp_idx);

   while (idx != NULL_IDX) {
      ATP_SCP_ALIVE(AL_ATTR_IDX(idx)) = FALSE;
      idx = AL_NEXT_IDX(idx);
   }

   curr_stmt_category = Sub_Func_Stmt_Cat;
   curr_scp_idx	= SCP_PARENT_IDX(curr_scp_idx);

   /* SH_NEXT_IDX of curr_stmt_sh_idx is NULL_IDX and will stay that way,   */
   /* because if there are SH's for the parent, curr_stmt_sh_idx will be    */
   /* set to the last of them.  If there are no stmt headers for the parent */
   /* a new statement header will be generated.  The only way there should  */
   /* be no SH's for the parent is if the parent is an interface block.  If */
   /* this is true, we're in a scoping error situation, because internal    */
   /* procedures cannot be in an interface block.  We check for this to     */
   /* prevent aborts and other bad things, if we're in an error situation.  */


   if (SCP_LAST_SH_IDX(curr_scp_idx) == NULL_IDX) { /* No IR for parent scp */
      curr_stmt_sh_idx			= ntr_sh_tbl();
      SCP_FIRST_SH_IDX(curr_scp_idx)	= curr_stmt_sh_idx;
      need_new_sh			= FALSE;   /* Use this SH */
   }
   else {
      curr_stmt_sh_idx			= SCP_LAST_SH_IDX(curr_scp_idx);
   }

   POP_BLK_STK;
   PRINT_SCP_TBL;
   PRINT_EQV_TBL;

   TRACE (Func_Exit, "end_module_proc", NULL);

   return;

}  /* end_module_proc */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END statement for an interface body.   *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_interface_body(boolean	err_call)

{
   int		interface_idx;
   int		parent_idx;
   int		save_curr_scp_idx;
   int		sibling_idx;


   TRACE (Func_Entry, "end_interface_body", NULL);

   if (cif_flags & BASIC_RECS) {
      cif_scope_info_rec();
      cif_end_scope_rec();
   }

   if (cif_flags & MISC_RECS) {
      cif_stmt_type_rec(TRUE,
                        (ATP_PGM_UNIT(CURR_BLK_NAME) == Function) ?
                        CIF_End_Function_Stmt : CIF_End_Subroutine_Stmt,
                        statement_number);
   }

   curr_stmt_sh_idx	= SCP_FIRST_SH_IDX(curr_scp_idx);
   stmt_start_line	= SH_GLB_LINE(curr_stmt_sh_idx);
   stmt_start_col	= SH_COL_NUM(curr_stmt_sh_idx);
   need_new_sh		= TRUE;

   interface_semantics_pass_driver();

   parent_idx		= SCP_PARENT_IDX(curr_scp_idx);

   free_attr_list(SCP_TMP_FW_IDX2(curr_scp_idx));
   free_attr_list(SCP_TMP_FW_IDX(curr_scp_idx));
   free_attr_list(SCP_ENTRY_IDX(curr_scp_idx));
   free_attr_list(SCP_TMP_LIST(curr_scp_idx));
   free_attr_list(SCP_ATTR_LIST(curr_scp_idx));

   SCP_ATTR_LIST(curr_scp_idx)		= NULL_IDX;
   SCP_TMP_FW_IDX2(curr_scp_idx)	= NULL_IDX;
   SCP_TMP_FW_IDX(curr_scp_idx)		= NULL_IDX;
   SCP_ENTRY_IDX(curr_scp_idx)		= NULL_IDX;
   SCP_TMP_LIST(curr_scp_idx)		= NULL_IDX;

   remove_hidden_name_tbl(curr_scp_idx);

   if (!SCP_IN_ERR(curr_scp_idx) &&
        BLK_TYPE(blk_stk_idx - 1) == Interface_Blk) {
      blk_stk_idx--;
      interface_idx = (BLK_NAME(blk_stk_idx) == NULL_IDX) ?
                       BLK_UNNAMED_INTERFACE(blk_stk_idx) :
                       BLK_NAME(blk_stk_idx);

      if ((ATI_NUM_SPECIFICS(interface_idx) % 8) == 0 &&
          !AT_DCL_ERR(interface_idx) && ATI_HAS_NON_MOD_PROC(interface_idx)) {
         save_curr_scp_idx			= curr_scp_idx;
         curr_scp_idx				= parent_idx;
         collapse_interface_blk(interface_idx);
         ATI_HAS_NON_MOD_PROC(interface_idx)	= FALSE;
         BLK_AT_IDX(blk_stk_idx)		= NULL_IDX;
         BLK_BD_IDX(blk_stk_idx)		= NULL_IDX;
         BLK_CN_IDX(blk_stk_idx)		= NULL_IDX;
         BLK_CP_IDX(blk_stk_idx)		= NULL_IDX;
         BLK_NP_IDX(blk_stk_idx)		= NULL_IDX;
         BLK_SB_IDX(blk_stk_idx)		= NULL_IDX;
         BLK_SN_IDX(blk_stk_idx)		= NULL_IDX;
         BLK_TYP_IDX(blk_stk_idx)		= NULL_IDX;
         curr_scp_idx				= save_curr_scp_idx;
      }
      blk_stk_idx++;
   }

   if (SCP_FIRST_CHILD_IDX(curr_scp_idx) == NULL_IDX) {

      if (SCP_SIBLING_IDX(curr_scp_idx) == NULL_IDX) {

         /* NO block errors - so reuse loc name table space */

         loc_name_tbl_idx	= SCP_LN_FW_IDX(curr_scp_idx) - 1;
      }
      scp_tbl_idx		= curr_scp_idx - 1;
      
      if (SCP_NUM_CHILDREN(parent_idx) == 1) {          /* only one child */
         SCP_FIRST_CHILD_IDX(parent_idx) = NULL_IDX;
         SCP_LAST_CHILD_IDX(parent_idx)  = NULL_IDX;
         SCP_NUM_CHILDREN(parent_idx)    = 0;
      }
      else { /* find next to last sibling scp */
         sibling_idx = SCP_FIRST_CHILD_IDX(parent_idx);

         while (SCP_SIBLING_IDX(sibling_idx) != curr_scp_idx) {
            sibling_idx = SCP_SIBLING_IDX(sibling_idx);
         }

         SCP_SIBLING_IDX(sibling_idx)   = NULL_IDX;
         SCP_LAST_CHILD_IDX(parent_idx) = sibling_idx;
         (SCP_NUM_CHILDREN(parent_idx))--;
      }
   }
   else { /* There are one or more block errors, so remove this interface  */
          /* body carefully.  Merge the interface's sibling list with the  */
          /* interface's child's sibling list.  Then  curr_scp_idx becomes */
          /* inaccessible, because it is out of the scope table link.      */

      SCP_PARENT_IDX(SCP_FIRST_CHILD_IDX(curr_scp_idx)) = parent_idx;

      sibling_idx		= SCP_FIRST_CHILD_IDX(curr_scp_idx);

      while (SCP_SIBLING_IDX(sibling_idx) != NULL_IDX) {
         sibling_idx = SCP_SIBLING_IDX(sibling_idx);
         SCP_PARENT_IDX(sibling_idx) = parent_idx;
      }

      if (SCP_NUM_CHILDREN(parent_idx) == 1) {    /* only one child */
         SCP_FIRST_CHILD_IDX(parent_idx) = SCP_FIRST_CHILD_IDX(curr_scp_idx);
         SCP_LAST_CHILD_IDX(parent_idx)  = SCP_LAST_CHILD_IDX(curr_scp_idx);
         SCP_NUM_CHILDREN(parent_idx)    = SCP_NUM_CHILDREN(curr_scp_idx);
      }
      else { /* find next to last sibling scp */
         sibling_idx = SCP_FIRST_CHILD_IDX(parent_idx);

         while (SCP_SIBLING_IDX(sibling_idx) != curr_scp_idx) {
            sibling_idx = SCP_SIBLING_IDX(sibling_idx);
         }

         SCP_SIBLING_IDX(sibling_idx)   = SCP_FIRST_CHILD_IDX(curr_scp_idx);
         SCP_LAST_CHILD_IDX(parent_idx) = SCP_LAST_CHILD_IDX(curr_scp_idx);
         SCP_NUM_CHILDREN(parent_idx)   = SCP_NUM_CHILDREN(parent_idx) - 1 +
                                          SCP_NUM_CHILDREN(curr_scp_idx);
      }
   }

   curr_scp_idx		= parent_idx;
   curr_stmt_category	= Sub_Func_Stmt_Cat;

   /* If there are no stmt headers for the parent, always reuse curr_stmt_sh */
   /* _idx because even if this statement is labeled, it doesn't need a SH.  */
   /* The only IR that can be generated for this interface body is labels.   */
   /* These can never be referenced, because you can't jump from one scope   */
   /* to another, and you can't have a goto inside an interface body.        */
   /* There will be no SH's for the parent if the parent is an interface     */
   /* block.  This is perfectly legal.                                       */

   if (SCP_LAST_SH_IDX(curr_scp_idx) == NULL_IDX) { /* No IR for parent scp */
      SCP_FIRST_SH_IDX(curr_scp_idx)	= curr_stmt_sh_idx;
      SH_PREV_IDX(curr_stmt_sh_idx)	= NULL_IDX;
      need_new_sh			= FALSE;
   }
   else {
      curr_stmt_sh_idx			= SCP_LAST_SH_IDX(curr_scp_idx);
      need_new_sh			= TRUE;
   }

   POP_BLK_STK;
   PRINT_SCP_TBL;
   PRINT_EQV_TBL;

   TRACE (Func_Exit, "end_interface_body", NULL);

   return;

}  /* end_interface_body */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END FORALL statement.	              *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_forall_blk(boolean	err_call)

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

   if (cmd_line_flags.debug_lvl <= Debug_Lvl_1  &&  ! err_call) { 

      /*-ez -ed -G0 -G1*/

      gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX);
   }

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

   SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX;

   IR_FLD_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = SH_Tbl_Idx;
   IR_IDX_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = curr_stmt_sh_idx;
   IR_LINE_NUM_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = 
                       SH_GLB_LINE(CURR_BLK_FIRST_SH_IDX);
   IR_COL_NUM_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = 
                       SH_COL_NUM(CURR_BLK_FIRST_SH_IDX);
   
   /* LRR:  Before popping the Blocking Stmt stack, need to use it to get to  */
   /* the FORALL SH to get to each of the index name Attrs and clear the flag */
   /* that says it's alive.						      */

   POP_BLK_STK;

   TRACE (Func_Exit, "end_forall_blk", NULL);

   return;

}  /* end_forall_blk */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END WHERE statement.	              *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_where_blk(boolean	err_call)

{
   int		sh_idx;

   TRACE (Func_Entry, "end_where_blk", NULL);

   if (cmd_line_flags.debug_lvl <= Debug_Lvl_1 && !err_call) { 
      /*-ez -ed -G0 -G1*/
      gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX);
   }

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

   if (CURR_BLK == Where_Then_Blk ||
       CURR_BLK == Where_Else_Blk ||
       CURR_BLK == Where_Else_Mask_Blk) {

      SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX;

      sh_idx = SH_PARENT_BLK_IDX(curr_stmt_sh_idx);
      while (sh_idx != NULL_IDX &&
             SH_STMT_TYPE(sh_idx) != Where_Cstrct_Stmt) {

         sh_idx = SH_PARENT_BLK_IDX(sh_idx);
      }

      if (sh_idx != NULL_IDX) {
         IR_FLD_R(SH_IR_IDX(sh_idx)) = SH_Tbl_Idx;
         IR_IDX_R(SH_IR_IDX(sh_idx)) = curr_stmt_sh_idx;
      }
   }

   POP_BLK_STK;

   TRACE (Func_Exit, "end_where_blk", NULL);

   return;

}  /* end_where_blk */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END statement for a SELECT construct.  *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_select_blk(boolean	err_call)

{
   int		blk_idx;
   int          il_idx_1;
   int          il_idx_2;
   int		name_idx;
   long		num_cases_value;
   int		ir_idx;
   int		save_curr_stmt_sh_idx;
   int		sh_idx;
 

   TRACE (Func_Entry, "end_select_blk", NULL);

   if (err_call) {  /* This is an error situation */
      gen_sh(Before, End_Select_Stmt, stmt_start_line, stmt_start_col,
             TRUE, FALSE, FALSE);
      curr_stmt_sh_idx	= SH_PREV_IDX(curr_stmt_sh_idx);
   }

   if (CURR_BLK == Case_Blk) {
      POP_BLK_STK; 
   }

   if (CURR_BLK == Select_Blk) {

      if (CURR_BLK_ERR) {
         goto EXIT;
      }

      /* Generate a CONTINUE stmt before the END SELECT stmt to define the    */
      /* branch-around label.  If the END SELECT stmt already has a user      */
      /* label, insert the CONTINUE stmt ahead of the Label_Def SH.	      */

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

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


      sh_idx           = SH_PREV_IDX(curr_stmt_sh_idx);
      curr_stmt_sh_idx = save_curr_stmt_sh_idx;

      if (cmd_line_flags.debug_lvl == Debug_Lvl_0) {  /* -ed -G0 */
         gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX);
      }

      NTR_IR_TBL(ir_idx);
      SH_IR_IDX(sh_idx)     = ir_idx;
      IR_OPR(ir_idx)        = Label_Opr;
      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)      = CURR_BLK_LABEL;

      /* CURR_BLK_LABEL is an internal label generated by the select stmt */

      AT_DEFINED(CURR_BLK_LABEL)       = TRUE;
      AT_DEF_LINE(CURR_BLK_LABEL)      = stmt_start_line;
      ATL_DEF_STMT_IDX(CURR_BLK_LABEL) = sh_idx;

      if (cmd_line_flags.debug_lvl == Debug_Lvl_1) {  /* -ez -G1 */
         ATL_DEBUG_CLASS(CURR_BLK_LABEL) = Ldbg_Stmt_Lbl;
      }

      /* Now go back to the Select IR and generate the ILs to hold the number */
      /* of cases, the branch-around label, and (if it exists) the CASE       */
      /* DEFAULT label.							      */

      ir_idx = IR_IDX_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX));

      NTR_IR_LIST_TBL(il_idx_1);
      IR_FLD_R(ir_idx) = IL_Tbl_Idx;
      IR_IDX_R(ir_idx) = il_idx_1;
      IL_FLD(il_idx_1) = CN_Tbl_Idx;
      num_cases_value  = (long) BLK_NUM_CASES(blk_stk_idx);
      IL_IDX(il_idx_1) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num_cases_value); 
      IL_LINE_NUM(il_idx_1) = stmt_start_line;
      IL_COL_NUM(il_idx_1)  = stmt_start_col;

      NTR_IR_LIST_TBL(il_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)           = AT_Tbl_Idx;
      IL_IDX(il_idx_2)           = CURR_BLK_LABEL;

      if (BLK_CASE_DEFAULT_LBL_FLD(blk_stk_idx) == NO_Tbl_Idx) {
         IR_LIST_CNT_R(ir_idx) = 2;
      }
      else {
         IR_LIST_CNT_R(ir_idx) = 3;
         il_idx_1              = il_idx_2;

         NTR_IR_LIST_TBL(il_idx_2);
         IL_NEXT_LIST_IDX(il_idx_1) = il_idx_2;
         IL_PREV_LIST_IDX(il_idx_2) = il_idx_1;
         COPY_OPND(IL_OPND(il_idx_2), BLK_CASE_DEFAULT_LBL_OPND(blk_stk_idx));
      }

   }
   else {

      /* Error blocks got in the way - try to find the Select_Blk.            */

      name_idx = BLK_NAME(blk_stk_idx + 1);

      for (blk_idx = blk_stk_idx;  blk_idx > 0;  --blk_idx) {

         if (BLK_TYPE(blk_idx) == Select_Blk  &&
             BLK_NAME(blk_idx) == name_idx) {
            blk_idx = move_blk_to_end(blk_idx);
            break;
         }
      }
   }


EXIT:

   SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX;

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


   /* Check before popping it because the program could be really messed up   */
   /* which would cause the Block Stack to be equally messed up.              */

   if (CURR_BLK == Select_Blk) {
      POP_BLK_STK;
   }


   if (err_call) {
      curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
   }
 
   TRACE (Func_Exit, "end_select_blk", NULL);

   return;

}  /* end_select_blk */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This procedure is called from the main parse driver and the "end      *|
|*      program unit" routines in this file when the current statement is     *|
|*      labeled.  It determines whether or not the labeled statement is       *|
|*      terminating one or more DO loops.				      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

void end_labeled_do()

{
   int		blk_idx;
#ifdef KEY /* Bug 10177 */
   boolean	error_flag = FALSE;
#else /* KEY Bug 10177 */
   boolean	error_flag;
#endif /* KEY Bug 10177 */
   int		fake_blk_stk_idx;
   int		loop_num = 0;
   boolean	msg_issued;
   int		save_blk_stk_idx;
   int		save_sh_err_flg;


   TRACE (Func_Entry, "end_labeled_do", NULL);


   if (stmt_label_idx == NULL_IDX) {
      return;  /* This requires that stmt_label_idx be valid */
   }

   /* Does this statement label terminate a DO loop?			      */

   if (stmt_label_idx == CURR_BLK_LABEL) {
      blk_idx = blk_stk_idx;
   }
   else {

      if (blk_stk_idx > 1) {
         blk_idx = blk_stk_idx - 1;

         while (BLK_TYPE(blk_idx) > Module_Proc_Blk) {
         
            if (stmt_label_idx == BLK_LABEL(blk_idx)) {
               goto FOUND_DO_BLK;
            }
            --blk_idx;
         }
      }

      goto EXIT;
   }


   /* Verify that the termination statement is acceptable.                    */

FOUND_DO_BLK:
  
   if (cmd_line_flags.debug_lvl == Debug_Lvl_0) {  /* -ed -G0 */
      gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX);
   }

   if (stmt_type != End_Do_Stmt  &&  BLK_NAME(blk_idx) != NULL_IDX) {
      PRINTMSG(stmt_start_line, 669, Error, stmt_start_col);
   }

   switch (stmt_type) {

      case Continue_Stmt:
         if (BLK_LOOP_NUM(blk_idx) > 1) {
            PRINTMSG(stmt_start_line, 241,
#ifdef KEY /* Bug 318, 321 */
	      Ansi,
#else /* KEY Bug 318, 321 */
	      Comment,
#endif /* KEY Bug 318, 321 */
	      stmt_start_col);
         }

         break;

      case End_Do_Stmt:
         break;

      case Goto_Stmt:
         if (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) == Br_Uncond_Opr) {
            PRINTMSG(stmt_start_line, 242, Error, stmt_start_col);
         }
         else if (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) == Br_Asg_Opr) {
            PRINTMSG(stmt_start_line, 243, Error, stmt_start_col);
         }
         else {
            PRINTMSG(stmt_start_line, 241,
#ifdef KEY /* Bug 318, 321 */
	      Ansi,
#else /* KEY Bug 318, 321 */
	      Comment,
#endif /* KEY Bug 318, 321 */
	      stmt_start_col);
         }                   
             
         break;

      case Outmoded_If_Stmt:
         PRINTMSG(stmt_start_line, 246, Error, stmt_start_col);
         break;

      case Do_Iterative_Stmt:
      case Do_While_Stmt:
      case Do_Infinite_Stmt:
      case If_Cstrct_Stmt:
      case Select_Stmt:
      case Where_Cstrct_Stmt:
         msg_issued       = FALSE;
         save_sh_err_flg  = SH_ERR_FLG(curr_stmt_sh_idx);

         if (stmt_type == If_Cstrct_Stmt) {
            blk_idx          = blk_stk_idx - 2;
            fake_blk_stk_idx = blk_stk_idx - 2;
         }
         else {
            blk_idx          = blk_stk_idx - 1;
            fake_blk_stk_idx = blk_stk_idx - 1;
         }

         while (BLK_TYPE(blk_idx) > Module_Proc_Blk) {

            if (stmt_label_idx == BLK_LABEL(blk_idx)) { 

               if (! msg_issued) {
                  PRINTMSG(stmt_start_line, 244, Error, stmt_start_col,
                           stmt_type_str[stmt_type]);
                  msg_issued = TRUE;
               }

               if (blk_idx != fake_blk_stk_idx) {
                  save_blk_stk_idx = blk_stk_idx;
                  blk_stk_idx      = fake_blk_stk_idx;
                  error_flag = pop_and_err_blk_stk(blk_idx, FALSE);
                  blk_stk_idx      = save_blk_stk_idx;
               }

               move_blk_to_end(blk_idx);

               if (msg_issued || error_flag) {
                  SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX) = TRUE;
               }
               POP_BLK_STK;

               if (CURR_BLK == Doall_Blk) {
                  POP_BLK_STK;
                  cdir_switches.doall_region = FALSE;
                  CLEAR_DIRECTIVE_STATE(Doall_Region);
               }
               else if (CURR_BLK == SGI_Parallel_Do_Blk) {
                  POP_BLK_STK;
                  CLEAR_DIRECTIVE_STATE(Parallel_Do_Region);
               }
               else if (CURR_BLK == SGI_Doacross_Blk) {
                  POP_BLK_STK;
                  CLEAR_DIRECTIVE_STATE(Doacross_Region);
               }

               --fake_blk_stk_idx;
            }

            --blk_idx;
         }

         SH_ERR_FLG(curr_stmt_sh_idx) = save_sh_err_flg;
         goto EXIT;
         
      case End_Stmt:
      case End_Function_Stmt:
      case End_Program_Stmt:
      case End_Subroutine_Stmt:
         msg_issued = FALSE;
         blk_idx    = blk_stk_idx;

         while (BLK_TYPE(blk_idx) > Module_Proc_Blk) {

            if (stmt_label_idx == BLK_LABEL(blk_idx)) {
               PRINTMSG(stmt_start_line, 244, Error, stmt_start_col,
                        stmt_type_str[stmt_type]);
               msg_issued = TRUE;
               break;
            }

            --blk_idx;
         }
           
         if (msg_issued) {
            break;
         }
         else { 
            goto EXIT;
         }

      case Arith_If_Stmt:
      case Cycle_Stmt:
      case Exit_Stmt:
      case Return_Stmt:
      case Stop_Stmt:
         PRINTMSG(stmt_start_line, 244, Error, stmt_start_col,
                  stmt_type_str[stmt_type]);
         break;

      case End_If_Stmt:
      case End_Select_Stmt:
      case End_Where_Stmt:
      case Case_Stmt:
      case Else_Stmt:
      case Else_If_Stmt:
      case Else_Where_Stmt:
         PRINTMSG(stmt_start_line, 244, Error, stmt_start_col,
                  stmt_type_str[stmt_type]);
        
         blk_idx = blk_stk_idx;

         while (BLK_TYPE(blk_idx) > Module_Proc_Blk) {

            if (stmt_label_idx == BLK_LABEL(blk_idx)) {

               if (blk_idx != blk_stk_idx) {
                  move_blk_to_end(blk_idx);
               }

               SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX) = TRUE;
               POP_BLK_STK;

               if (CURR_BLK == Doall_Blk) {
                  POP_BLK_STK;
                  cdir_switches.doall_region = FALSE;
                  CLEAR_DIRECTIVE_STATE(Doall_Region);
               }
               else if (CURR_BLK == SGI_Parallel_Do_Blk) {
                  POP_BLK_STK;
                  CLEAR_DIRECTIVE_STATE(Parallel_Do_Region);
               }
               else if (CURR_BLK == SGI_Doacross_Blk) {
                  POP_BLK_STK;
                  CLEAR_DIRECTIVE_STATE(Doacross_Region);
               }
            }

            --blk_idx;
         }
      
         goto EXIT;

      default:
         if (ATL_EXECUTABLE(stmt_label_idx)) {
            PRINTMSG(stmt_start_line, 241,
#ifdef KEY /* Bug 318, 321 */
	      Ansi,
#else /* KEY Bug 318, 321 */
	      Comment,
#endif /* KEY Bug 318, 321 */
	      stmt_start_col);
         }
         else {
            PRINTMSG(stmt_start_line, 544, Error, stmt_start_col);
         }
   }

   /* remove any Do Parallel blocks that are above the do block */

   blk_idx = blk_stk_idx;

   while (BLK_TYPE(blk_idx) > Module_Proc_Blk) {

      if (BLK_TYPE(blk_idx) == Do_Parallel_Blk ||
          BLK_TYPE(blk_idx) == SGI_Pdo_Blk ||
          BLK_TYPE(blk_idx) == Open_Mp_Do_Blk ||
          BLK_TYPE(blk_idx) == Open_Mp_Parallel_Do_Blk) {

         if (BLK_TYPE(blk_idx) == Do_Parallel_Blk) {
            CLEAR_DIRECTIVE_STATE(Do_Parallel_Region);
         }
         else if (BLK_TYPE(blk_idx) == SGI_Pdo_Blk) {
            CLEAR_DIRECTIVE_STATE(Pdo_Region);
         }
         else if (BLK_TYPE(blk_idx) == Open_Mp_Do_Blk) {
            CLEAR_DIRECTIVE_STATE(Open_Mp_Do_Region);
         }
         else if (BLK_TYPE(blk_idx) == Open_Mp_Parallel_Do_Blk) {
            CLEAR_DIRECTIVE_STATE(Open_Mp_Parallel_Do_Region);
         }

         move_blk_to_end(blk_idx);
         POP_BLK_STK;
         blk_idx--;
         continue;
      }

      if (stmt_label_idx == BLK_LABEL(blk_idx)) {
         break;
      }
      --blk_idx;
   }

   /* Now close all loops this statement terminates.                          */

   blk_idx = blk_stk_idx;

   while (BLK_TYPE(blk_idx) > Module_Proc_Blk) {

      if (stmt_label_idx == BLK_LABEL(blk_idx)) { 

         if (blk_idx != blk_stk_idx) {
            error_flag = pop_and_err_blk_stk(blk_idx, FALSE);
            move_blk_to_end(blk_idx);

            if (error_flag) {
               SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX) = TRUE;
            }
         }

         if (! SH_ERR_FLG(curr_stmt_sh_idx)  &&
             ! SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX)) {
            loop_end_processing();
            loop_num = BLK_LOOP_NUM(blk_idx);
         }

         POP_BLK_STK;

         if (CURR_BLK == Doall_Blk) {
            POP_BLK_STK;
            cdir_switches.doall_region = FALSE;
            CLEAR_DIRECTIVE_STATE(Doall_Region);
         }
         else if (CURR_BLK == SGI_Parallel_Do_Blk) {
            POP_BLK_STK;
            CLEAR_DIRECTIVE_STATE(Parallel_Do_Region);
         }
         else if (CURR_BLK == SGI_Doacross_Blk) {
            POP_BLK_STK;
            CLEAR_DIRECTIVE_STATE(Doacross_Region);
         }
      }  
      else if (loop_num > 1 &&
               end_task_do_blk ()) {
         POP_BLK_STK;
      }

      --blk_idx;
   }

EXIT:

   (void) end_task_do_blk();

   TRACE (Func_Exit, "end_labeled_do", NULL);

   return;

}  /* end_labeled_do */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

static boolean end_task_do_blk(void)

{
   int		ir_idx;
   boolean	left_on_stk = FALSE;

   TRACE (Func_Entry, "end_task_do_blk", NULL);

   if (CURR_BLK == Do_Parallel_Blk &&
       BLK_ENDDO_PARALLEL_SH_IDX(blk_stk_idx) == NULL_IDX) {

      left_on_stk = TRUE;

      /* insert enddo parallel statement after */
      need_new_sh = TRUE;

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

      NTR_IR_TBL(ir_idx);
      IR_OPR(ir_idx) = Enddo_Cmic_Opr;

      /* must have a 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;

      SH_IR_IDX(curr_stmt_sh_idx)  = ir_idx;

      BLK_ENDDO_PARALLEL_SH_IDX(blk_stk_idx) = curr_stmt_sh_idx;
   }
   else if ((CURR_BLK == SGI_Pdo_Blk ||
             CURR_BLK == Open_Mp_Do_Blk ||
             CURR_BLK == Open_Mp_Parallel_Do_Blk) &&
             BLK_ENDPDO_SH_IDX(blk_stk_idx) == NULL_IDX) {


      /* insert endpdo statement after */
      need_new_sh = TRUE;


      NTR_IR_TBL(ir_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) = SH_Tbl_Idx;
      IR_IDX_R(ir_idx) = CURR_BLK_FIRST_SH_IDX;

      switch (CURR_BLK) {
         case SGI_Pdo_Blk:
            IR_OPR(ir_idx) = End_Pdo_Par_Opr;
            gen_sh(After, SGI_End_Pdo_Stmt, stmt_start_line, stmt_start_col,
                   FALSE, FALSE, TRUE);
            CLEAR_DIRECTIVE_STATE(Pdo_Region);
            POP_BLK_STK;
            break;

         case Open_Mp_Do_Blk:
            IR_OPR(ir_idx) = Enddo_Open_Mp_Opr;
            gen_sh(After, Open_MP_End_Do_Stmt, stmt_start_line, stmt_start_col,
                   FALSE, FALSE, TRUE);
            CLEAR_DIRECTIVE_STATE(Open_Mp_Do_Region);
            POP_BLK_STK;
            break;

         case Open_Mp_Parallel_Do_Blk:
            IR_OPR(ir_idx) = Endparalleldo_Open_Mp_Opr;
            gen_sh(After, Open_MP_End_Do_Stmt, stmt_start_line, stmt_start_col,
                   FALSE, FALSE, TRUE);
            CLEAR_DIRECTIVE_STATE(Open_Mp_Parallel_Do_Region);
            POP_BLK_STK;
            break;
      }

      SH_IR_IDX(curr_stmt_sh_idx)  = ir_idx;
   }


   TRACE (Func_Exit, "end_task_do_blk", NULL);

   return(left_on_stk);

}  /* end_task_do_blk */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END DO statement.		      *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_do_blk(boolean	err_call)

{
   int		blk_idx;
   boolean      loop_end_ir_gend	= FALSE;
   boolean	msg_issued;
   boolean	no_err			= TRUE;
   int		unlabeled_do_idx;


   TRACE (Func_Entry, "end_do_blk", NULL);

   /* If err_call is TRUE, it means this procedure is being called due to a   */
   /* blocking stmt mismatch to close out the current Block Stack frame.  Pop */
   /* the Block Stack.							      */

   if (err_call) {
      POP_BLK_STK;
      if (CURR_BLK == Doall_Blk) {
         POP_BLK_STK;
         cdir_switches.doall_region = FALSE;
         CLEAR_DIRECTIVE_STATE(Doall_Region);
      }
      else if (CURR_BLK == SGI_Parallel_Do_Blk) {
         POP_BLK_STK;
         CLEAR_DIRECTIVE_STATE(Parallel_Do_Region);
      }
      else if (CURR_BLK == SGI_Doacross_Blk) {
         POP_BLK_STK;
         CLEAR_DIRECTIVE_STATE(Doacross_Region);
      }

      goto EXIT;
   }

   /* Remove any Do Parallel blocks that are above the DO block.              */

   blk_idx = blk_stk_idx;

   while (BLK_TYPE(blk_idx) > Module_Proc_Blk) {

      if (BLK_TYPE(blk_idx) == Do_Parallel_Blk ||
          BLK_TYPE(blk_idx) == SGI_Pdo_Blk ||
          BLK_TYPE(blk_idx) == Open_Mp_Do_Blk ||
          BLK_TYPE(blk_idx) == Open_Mp_Parallel_Do_Blk) {

         if (BLK_TYPE(blk_idx) == Do_Parallel_Blk) {
            CLEAR_DIRECTIVE_STATE(Do_Parallel_Region);
         }
         else if (BLK_TYPE(blk_idx) == SGI_Pdo_Blk) {
            CLEAR_DIRECTIVE_STATE(Pdo_Region);
         }
         else if (BLK_TYPE(blk_idx) == Open_Mp_Do_Blk) {
            CLEAR_DIRECTIVE_STATE(Open_Mp_Do_Region);
         }
         else if (BLK_TYPE(blk_idx) == Open_Mp_Parallel_Do_Blk) {
            CLEAR_DIRECTIVE_STATE(Open_Mp_Parallel_Do_Region);
         }

         move_blk_to_end(blk_idx);
         POP_BLK_STK;
         blk_idx--;
         continue;
      }
      else if (BLK_TYPE(blk_idx) == Do_Blk) {
         break;
      }

      --blk_idx;
   }


   if (cmd_line_flags.debug_lvl == Debug_Lvl_0) {  /* -ed -G0 */
      gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX);
   }
 
   if (cif_flags & MISC_RECS) {
      cif_stmt_type_rec(TRUE, CIF_End_Do_Stmt, statement_number);
   }

   SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

   if (stmt_label_idx == NULL_IDX) {
      blk_idx = blk_stk_idx;

      /* Must search back through the Block Stack because there could be      */
      /* labeled DOs between this unlabeled END DO and an unlabeled DO.       */

      while (BLK_TYPE(blk_idx) > Module_Proc_Blk) {
            
         if (BLK_TYPE(blk_idx) == Do_Blk  &&  BLK_LABEL(blk_idx) == NULL_IDX) {
               
            if (blk_idx == blk_stk_idx) {

               if (! SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX)) {
                  loop_end_processing();
                  loop_end_ir_gend = TRUE;
               }

            }
            else {
               pop_and_err_blk_stk(blk_idx, FALSE);
               move_blk_to_end(blk_idx);
            }

            POP_BLK_STK;

            if (CURR_BLK == Doall_Blk) {
               POP_BLK_STK;
               cdir_switches.doall_region = FALSE;
               CLEAR_DIRECTIVE_STATE(Doall_Region);
            }
            else if (CURR_BLK == SGI_Parallel_Do_Blk) {
               POP_BLK_STK;
               CLEAR_DIRECTIVE_STATE(Parallel_Do_Region);
            }
            else if (CURR_BLK == SGI_Doacross_Blk) {
               POP_BLK_STK;
               CLEAR_DIRECTIVE_STATE(Doacross_Region);
            }

            goto EXIT;
         }

         --blk_idx;
      }

      PRINTMSG(stmt_start_line, 289, Error, stmt_start_col, "END DO", "DO");
   }
   else {
      unlabeled_do_idx = NULL_IDX;
      blk_idx          = blk_stk_idx;
      msg_issued       = FALSE;

      while (BLK_TYPE(blk_idx) > Module_Proc_Blk) {
            
         if (BLK_TYPE(blk_idx) == Do_Blk) {

            if (BLK_LABEL(blk_idx) != NULL_IDX) {
       
               if (BLK_LABEL(blk_idx) == stmt_label_idx) {
                     
                  if (blk_idx == blk_stk_idx) {
      
                     if (BLK_LOOP_NUM(blk_stk_idx) > 1) {

                        if (! msg_issued) {
                           PRINTMSG(stmt_start_line, 735, Ansi, stmt_start_col);
      			   msg_issued = TRUE;
                        }
                     }

                     if (! SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX)) {
                        loop_end_processing();
                        loop_end_ir_gend = TRUE;
                     }
                     else {
                        no_err = FALSE;
                     }
                  }
                  else {
                     pop_and_err_blk_stk(blk_idx, FALSE);
                     move_blk_to_end(blk_idx);
                     no_err = FALSE;
                  }

                  POP_BLK_STK;

                  if (CURR_BLK == Doall_Blk) {
                     POP_BLK_STK;
                     cdir_switches.doall_region = FALSE;
                     CLEAR_DIRECTIVE_STATE(Doall_Region);
                  }
                  else if (CURR_BLK == SGI_Parallel_Do_Blk) {
                     POP_BLK_STK;
                     CLEAR_DIRECTIVE_STATE(Parallel_Do_Region);
                  }
                  else if (CURR_BLK == SGI_Doacross_Blk) {
                     POP_BLK_STK;
                     CLEAR_DIRECTIVE_STATE(Doacross_Region);
                  }
               }
            }
            else if (unlabeled_do_idx == NULL_IDX) {
               unlabeled_do_idx = blk_idx;
            }
         }

         --blk_idx;
      }


      /* If the end-of-loop IR has not been generated, it means we didn't     */
      /* find a DO stmt with a matching label or there was something else     */
      /* wrong with the loop.  If we didn't find any UNlabeled DO stmts       */
      /* either, issue an error.  Otherwise, use the END DO to match the      */
      /* unlabeled DO.							      */

      if (! loop_end_ir_gend  &&  no_err) {

         if (unlabeled_do_idx == NULL_IDX) {
            PRINTMSG(stmt_start_line, 289, Error, stmt_start_col,
                     "END DO", "DO");
         }
         else {

            if (unlabeled_do_idx == blk_stk_idx) {

               if (! SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX)) {
                  loop_end_processing();
               }
            }
            else {
               pop_and_err_blk_stk(blk_idx, FALSE);
               move_blk_to_end(blk_idx);
            }
   
            POP_BLK_STK;

            if (CURR_BLK == Doall_Blk) {
               POP_BLK_STK;
               cdir_switches.doall_region = FALSE;
               CLEAR_DIRECTIVE_STATE(Doall_Region);
            }
            else if (CURR_BLK == SGI_Parallel_Do_Blk) {
               POP_BLK_STK;
               CLEAR_DIRECTIVE_STATE(Parallel_Do_Region);
            }
            else if (CURR_BLK == SGI_Doacross_Blk) {
               POP_BLK_STK;
               CLEAR_DIRECTIVE_STATE(Doacross_Region);
            }
         }
      }
   }


EXIT:

   (void) end_task_do_blk();

   TRACE (Func_Exit, "end_do_blk", NULL);

   return;

}  /* end_do_blk */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END IF statement for an IF construct.  *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_if_blk(boolean	err_call)

{
   int		blk_idx;
   boolean	error;
   int		name_idx;

# ifdef _HIGH_LEVEL_IF_FORM
# ifdef KEY /* Bug 10177 */
   int		curr_sh = 0;
# else /* KEY Bug 10177 */
   int		curr_sh;
# endif /* KEY Bug 10177 */
   int		ir_idx;
# endif

# if 0
   int		sh_idx;
# endif


   TRACE (Func_Entry, "end_if_blk", NULL);

   if (err_call) {  /* This is an error situation */
      gen_sh(Before, End_If_Stmt, stmt_start_line, stmt_start_col,
             TRUE, FALSE, FALSE);
      curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
   }
   else {

#ifdef _HIGH_LEVEL_IF_FORM

      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
      curr_sh = curr_stmt_sh_idx;

      NTR_IR_TBL(ir_idx);
      IR_OPR(ir_idx)      = Endif_Opr;
      IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
      IR_LINE_NUM(ir_idx) = stmt_start_line;
      IR_COL_NUM(ir_idx)  = stmt_start_col;

      SH_IR_IDX(curr_sh) = ir_idx;
#endif

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

   error = err_call || CURR_BLK_ERR || SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX);

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


#if 0
   /* If the last clause of the IF construct is an ELSE IF, generate a        */
   /* CONTINUE statement to define its branch-around label.                   */

   if (CURR_BLK == If_Else_If_Blk &&  !error) {
      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;
      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_FLD_L(ir_idx)    = AT_Tbl_Idx;
      IR_IDX_L(ir_idx)    = CURR_BLK_LABEL;
      IR_LINE_NUM_L(ir_idx) = stmt_start_line;
      IR_COL_NUM_L(ir_idx)  = stmt_start_col;

      AT_DEFINED(CURR_BLK_LABEL)       = TRUE;
      AT_DEF_LINE(CURR_BLK_LABEL)      = stmt_start_line;
      ATL_DEF_STMT_IDX(CURR_BLK_LABEL) = sh_idx;
      AT_REFERENCED(CURR_BLK_LABEL)    = Referenced;
   }
#endif

   
   if (CURR_BLK == If_Else_If_Blk  ||  CURR_BLK == If_Else_Blk) {
      SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX;
   }

   POP_BLK_STK;     /* Pop the Then, Else, or Else if */

   if (CURR_BLK != If_Blk) {

      /* Error blocks got in the way - try to find the If_Blk.		      */

      name_idx = BLK_NAME(blk_stk_idx + 1);

      for (blk_idx = blk_stk_idx;  blk_idx > 0;  --blk_idx) {

         if (BLK_TYPE(blk_idx) == If_Blk  &&  BLK_NAME(blk_idx) == name_idx) {
            blk_idx = move_blk_to_end(blk_idx);
            break;
         }
      }
   }


   /* Before popping the If_Blk, make sure that if the IF-THEN stmt is        */
   /* marked in error, the END IF is too. 				      */

   SH_ERR_FLG(curr_stmt_sh_idx) = error;


#if 0
   /* Generate a CONTINUE statement to define the "end IF" label.             */

   if (! error) {
      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;
      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_FLD_L(ir_idx)			= AT_Tbl_Idx;
      IR_IDX_L(ir_idx)			= CURR_BLK_LABEL;
      IR_LINE_NUM_L(ir_idx)		= stmt_start_line;
      IR_COL_NUM_L(ir_idx)		= stmt_start_col;

      AT_DEFINED(CURR_BLK_LABEL)	= TRUE;
      AT_DEF_LINE(CURR_BLK_LABEL)	= stmt_start_line;
      ATL_DEF_STMT_IDX(CURR_BLK_LABEL)	= sh_idx;
      AT_REFERENCED(CURR_BLK_LABEL)	= Referenced;
   }
#endif

   /* Check before popping it because the program could be really messed up   */
   /* which would cause the Block Stack to be equally messed up.	      */

   if (CURR_BLK == If_Blk) {

      if (SH_PARENT_BLK_IDX(curr_stmt_sh_idx) == NULL_IDX) {
         SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX;
      }

#ifdef _HIGH_LEVEL_IF_FORM
      if (! error) {
         /* set the right opnd of the Br_True_Opr of the If to point */
         /* to point to curr stmt. */

# if defined(_DEBUG)
         if (IR_OPR(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) != Br_True_Opr) {
            PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
                     "Br_True_Opr", "end_if_blk");
         }
# endif

         IR_FLD_R(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = SH_Tbl_Idx;
         IR_IDX_R(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = curr_sh;

         /* have the left opnd of the Endif_Opr point to the If stmt */
         IR_FLD_L(SH_IR_IDX(curr_sh)) = SH_Tbl_Idx;
         IR_IDX_L(SH_IR_IDX(curr_sh)) = CURR_BLK_FIRST_SH_IDX;
      }
# endif
      POP_BLK_STK;
   }


   TRACE (Func_Exit, "end_if_blk", NULL);

   return;

}  /* end_if_blk */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END statement for an INTERFACE block.  *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_interface_blk(boolean	err_call)

{
   int		attr_idx;
   boolean	found;
   int		interface_idx;
   int		sn_idx;


   TRACE (Func_Entry, "end_interface_blk", NULL);

   /* Do not need to mess with scope here, because we are in the parent's */
   /* scope.  The INTERFACE and the END INTERFACE routines do not cause   */
   /* a new scope to be entered.  It is the FUNCTION/END FUNCTION and the */
   /* SUBROUTINE/END SUBROUTINE that cause new scopes and delete old      */
   /* interface scopes.                                                   */

   /* Make sure that if the interface block shares a name with a pgm unit */
   /* that the pgm unit is in the generic interface.                      */

   if (CURR_BLK_NAME != NULL_IDX && 
       ATI_PROC_IDX(CURR_BLK_NAME) != NULL_IDX &&
       !AT_DCL_ERR(ATI_PROC_IDX(CURR_BLK_NAME)) && !err_call) {
      attr_idx	= ATI_PROC_IDX(CURR_BLK_NAME);
      found	= FALSE;
      sn_idx	= ATI_FIRST_SPECIFIC_IDX(CURR_BLK_NAME);

      while (sn_idx != NULL_IDX) {

         if (attr_idx == SN_ATTR_IDX(sn_idx)) {
            found = TRUE;
            break;
         }

         sn_idx = SN_SIBLING_LINK(sn_idx);
      }

      if (!found) {
         AT_DCL_ERR(attr_idx)		= TRUE;
         AT_DCL_ERR(CURR_BLK_NAME)	= TRUE;
         PRINTMSG(AT_DEF_LINE(attr_idx), 713, Error, AT_DEF_COLUMN(attr_idx),
                  AT_OBJ_NAME_PTR(attr_idx),
                  AT_OBJ_NAME_PTR(attr_idx));
      }
   }

   if (!SCP_IN_ERR(curr_scp_idx)) {
      interface_idx = (BLK_NAME(blk_stk_idx) == NULL_IDX) ?
                       BLK_UNNAMED_INTERFACE(blk_stk_idx):BLK_NAME(blk_stk_idx);

      if (!AT_DCL_ERR(interface_idx) && ATI_HAS_NON_MOD_PROC(interface_idx) &&
          BLK_AT_IDX(blk_stk_idx) != NULL_IDX) {
         collapse_interface_blk(interface_idx);
         ATI_HAS_NON_MOD_PROC(interface_idx) = FALSE;
      }
   }

   if (cif_flags & BASIC_RECS) {
      cif_end_scope_rec();
   }

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

   POP_BLK_STK;

   TRACE (Func_Exit, "end_interface_blk", NULL);

   return;

}  /* end_interface_blk */


#ifdef KEY /* Bug 10572 */
/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END statement for an enum block.  *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_enum_blk(boolean	err_call)

{
   int		attr_idx;
   boolean	found;
   int		enum_idx;
   int		sn_idx;


   TRACE (Func_Entry, "end_enum_blk", NULL);

   if (BLK_ENUM_EMPTY(blk_stk_idx) && !(BLK_ERR(blk_stk_idx) || err_call)) {
     PRINTMSG(stmt_start_line, 197, Error, stmt_start_col, "ENUMERATOR",
       "END ENUM");
   }

   POP_BLK_STK;

   TRACE (Func_Exit, "end_enum_blk", NULL);

}  /* end_enum_blk */

#endif /* KEY Bug 10572 */
/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Complete the processing of the END statement for a contains block.    *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

static void end_contains(boolean	err_call)

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

   POP_BLK_STK;                                 /* Pop the contains */

   /* Illegal to have a CONTAINS with nothing in it.  The only way this   */
   /* check will not work, is if there have been previous block, scoping  */
   /* errors with an interface block.  If that happens, the program is so */
   /* messed up, this check wouldn't matter much.  In all valid cases,    */
   /* SCP_FIRST_CHILD_IDX will be clear at the CONTAINS statement, and    */
   /* must be set by having a least one routine inside the CONTAINS block.*/

   if (SCP_FIRST_CHILD_IDX(curr_scp_idx) == NULL_IDX && 
       !SCP_IN_ERR(curr_scp_idx)) {
      PRINTMSG(stmt_start_line, 387, Error, stmt_start_col);
   }

   end_of_contains = TRUE;

   TRACE (Func_Exit, "end_contains", NULL);

   return;

}  /* end_contains */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Complete the processing of the END statement for an TYPE block.       *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_type_blk(boolean	err_call)

{
   boolean		aligned;
   size_offset_type	bit_len;

# if defined(_TARGET_DOUBLE_ALIGN)
   int			i;
   int			sn_idx;
# endif


   TRACE (Func_Entry, "end_type_blk", NULL);

   if (err_call) {

      /* Intentionally blank. */
   }
   else if (ATT_NUM_CPNTS(CURR_BLK_NAME) == 0) {
      PRINTMSG(CURR_BLK_DEF_LINE, 290, Error, CURR_BLK_DEF_COLUMN,
               AT_OBJ_NAME_PTR(CURR_BLK_NAME));
   }
   else {

# ifdef _DEBUG
      if (!ATT_CHAR_CPNT(CURR_BLK_NAME) &
          !ATT_NUMERIC_CPNT(CURR_BLK_NAME) &
#ifdef KEY /* Bug 6845 */
          !ATT_ALLOCATABLE_CPNT(CURR_BLK_NAME) &
#endif /* KEY Bug 6845 */
          !ATT_POINTER_CPNT(CURR_BLK_NAME)) {
         PRINTMSG(stmt_start_line, 193, Internal, stmt_start_col,
                  FALSE,
#ifdef KEY /* Bug 6845 */
                  "ATT_CHAR_CPNT, ATT_NUMERIC_CPNT, ATT_POINTER_CPNT",
#else /* KEY Bug 6845 */
                  "ATT_CHAR_CPNT, ATT_NUMERIC_CPNT, ATT_POINTER_CPNT,"
		  " ATT_ALLOCATABLE_CPNT",
#endif /* KEY Bug 6845 */
                  CURR_BLK_NAME);
      }
# endif

      ATT_CHAR_SEQ(CURR_BLK_NAME) = !ATT_NUMERIC_CPNT(CURR_BLK_NAME) &&
#ifdef KEY /* Bug 6845 */
                                    !ATT_ALLOCATABLE_CPNT(CURR_BLK_NAME) &&
#endif /* KEY Bug 6845 */
                                    !ATT_POINTER_CPNT(CURR_BLK_NAME);

      ATT_DCL_NUMERIC_SEQ(CURR_BLK_NAME) = !ATT_POINTER_CPNT(CURR_BLK_NAME) &&
#ifdef KEY /* Bug 6845 */
				    !ATT_ALLOCATABLE_CPNT(CURR_BLK_NAME) &&
#endif /* KEY Bug 6845 */
				    !ATT_CHAR_CPNT(CURR_BLK_NAME) &&
				    ATT_SEQUENCE_SET(CURR_BLK_NAME);

# if defined(_TARGET_DOUBLE_ALIGN)

      if (!cmd_line_flags.dalign &&
          ATT_DCL_NUMERIC_SEQ(CURR_BLK_NAME) && 
          ATT_DALIGN_ME(CURR_BLK_NAME)) {

         /* These components have been daligned, but cannot be because */
         /* this is a numeric sequence derived type and -a dalign has  */
         /* not been specified on the commandline.  Clear the block    */
         /* length and reassign offsets to all the components.         */

         ATT_DALIGN_ME(CURR_BLK_NAME)	    	= FALSE;
         ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME)	= CN_Tbl_Idx;
         ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME)	= CN_INTEGER_ZERO_IDX;
         sn_idx				    = ATT_FIRST_CPNT_IDX(CURR_BLK_NAME);

         for (i = 0; i < ATT_NUM_CPNTS(CURR_BLK_NAME); i++) {
            ATD_CPNT_OFFSET_IDX(SN_ATTR_IDX(sn_idx))	= CN_INTEGER_ZERO_IDX;
            ATD_OFFSET_FLD(SN_ATTR_IDX(sn_idx))		= CN_Tbl_Idx;
            assign_offset(SN_ATTR_IDX(sn_idx)); /* reassign to components */
            sn_idx = SN_SIBLING_LINK(sn_idx);
         }
      }
# endif

      if (ATT_NUMERIC_CPNT(CURR_BLK_NAME) || ATT_POINTER_CPNT(CURR_BLK_NAME)
#ifdef KEY /* Bug 6845 */
        || ATT_ALLOCATABLE_CPNT(CURR_BLK_NAME)
#endif /* KEY Bug 6845 */
      ) {
         bit_len.fld	= ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME);
         bit_len.idx	= ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME);
         aligned	= FALSE;

# if defined(_TARGET_PACK_HALF_WORD_TYPES)

# ifdef _WHIRL_HOST64_TARGET64
         {
            /* check to see if all components have alignment restrictions
             * less than or equal to Align_32.
             * If they do, then change alignment of structure to 32
             * bits.
             */

            int     i;
            int	    sn_idx;
            boolean use_align_32 = TRUE;

            sn_idx = ATT_FIRST_CPNT_IDX(CURR_BLK_NAME);

            for (i = 0; i < ATT_NUM_CPNTS(CURR_BLK_NAME); i++) {
               if (ATD_ALIGNMENT(SN_ATTR_IDX(sn_idx)) > Align_32) {
                  use_align_32 = FALSE;
                  break;
               }
               sn_idx = SN_SIBLING_LINK(sn_idx);
            }

            if (use_align_32)
               ATT_ALIGNMENT(CURR_BLK_NAME) = Align_32;
         }
# endif /* _WHIRL_HOST64_TARGET64 */

         if (!aligned && ATT_ALIGNMENT(CURR_BLK_NAME) == Align_32) {

            /* This structure contains all 32 bit components */
            /* or structures made up of 32 bit components.   */

            align_bit_length(&bit_len, TARGET_BITS_PER_WORD/2);
            aligned	= TRUE;
         }
# endif

         if (!aligned) {

# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))

            switch(ATT_ALIGNMENT(CURR_BLK_NAME)) {
            case Align_Bit:
               break;           /* Should not see character here */

/* For the forseeable future we are going to pad integer(kind=1) and */
/* integer(kind=2) to full words.                                    */

            case Align_8:
            case Align_16:
               align_bit_length(&bit_len, TARGET_BITS_PER_WORD);
               break;

            case Align_32:
               align_bit_length(&bit_len, 32);
               break;

            case Align_64:
               align_bit_length(&bit_len, 64);
               break;

            case Align_Double:
            case Align_128:
               align_bit_length(&bit_len, 128);
               break;
            }
# else
            align_bit_length(&bit_len, TARGET_BITS_PER_WORD);
# endif
         }

         if (bit_len.fld == NO_Tbl_Idx) {
            ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME) = CN_Tbl_Idx;
            ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME) = ntr_const_tbl(
                                                         bit_len.type_idx,
                                                         FALSE,
                                                         bit_len.constant);
         }
         else {
            ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME) = bit_len.fld;
            ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME) = bit_len.idx;
         }
      }

# if defined(_TARGET_DOUBLE_ALIGN)

      if (ATT_DALIGN_ME(CURR_BLK_NAME)) {

         /* This structure has been daligned.  Make sure the total   */
         /* length is a double length, so that elements of arrays of */
         /* this structure are double aligned.                       */

         bit_len.fld	= ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME);
         bit_len.idx	= ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME);

         align_bit_length(&bit_len, (TARGET_BITS_PER_WORD * 2));

         if (bit_len.fld == NO_Tbl_Idx) {
            ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME) = CN_Tbl_Idx;
            ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME) = ntr_const_tbl(
                                                        bit_len.type_idx,
                                                        FALSE,
                                                        bit_len.constant);
         }
         else {
            ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME) = bit_len.fld;
            ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME) = bit_len.idx;
         }
      }
# endif

   }
    
   /* Note that no Attr entry is created for the label (if any) on an END     */
   /* TYPE statement here because check_for_dup_derived_type_lbl in           */
   /* p_driver.c makes sure that the label on the END TYPE statement does     */
   /* not duplicate any other label in the derived type and creates the Attr  */
   /* entry for the label.						      */


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

   POP_BLK_STK;

   TRACE (Func_Exit, "end_type_blk", NULL);

   return;

}  /* end_type_blk */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Perform tasks that must be done at the end of a loop.  This	      *|
|*      procedure is called by both end_do_blk and end_labeled_do.	      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void loop_end_processing()

{
   int		attr_idx;
   int		ir_idx;
   int		save_curr_stmt_sh_idx; 
   int		sh_idx;

# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) || defined(_TARGET_OS_DARWIN) 
   int		blk_idx;
# endif


   TRACE (Func_Entry, "loop_end_processing", NULL);


# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) || defined(_TARGET_OS_DARWIN) 

   /* If the current loop is in a loop nest preceded by a BLOCKABLE directive,*/
   /* make sure all the loops in the DO-variable list of the directive are    */
   /* accounted for.  This means if this is the first loop ending, the value  */
   /* of BLK_BLOCKABLE_NUM_LCVS in the current Block Stack entry had better   */
   /* 1.  If not, issue an error, and clear all knowledge that the loop nest  */
   /* was subject to a BLOCKABLE directive so that no other processing will   */
   /* take place.			      				      */

   if (BLK_BLOCKABLE_NUM_LCVS(blk_stk_idx) == 1) {

      for (blk_idx = blk_stk_idx;  blk_idx > 1;  --blk_idx) {

         if (BLK_BLOCKABLE_DIR_SH_IDX(blk_idx) != NULL_IDX) {
            BLK_BLOCKABLE_NEST_OK(blk_idx) = TRUE;
            break;
         }
      }
   }
   else if (BLK_BLOCKABLE_NUM_LCVS(blk_stk_idx) > 1) {

      for (blk_idx = blk_stk_idx;  blk_idx > 1;  --blk_idx) {

         if (BLK_BLOCKABLE_DIR_SH_IDX(blk_idx) != NULL_IDX) {
            break;
         }
      }

      if (! BLK_BLOCKABLE_NEST_OK(blk_idx)) {
         PRINTMSG(stmt_start_line, 1389, Error, 0);

         for (blk_idx = blk_stk_idx;  blk_idx > 1;  --blk_idx) {
            BLK_BLOCKABLE_NUM_LCVS(blk_idx) = 0;

            if (BLK_BLOCKABLE_DIR_SH_IDX(blk_idx) != NULL_IDX) {
               SH_ERR_FLG(BLK_BLOCKABLE_DIR_SH_IDX(blk_idx)) = TRUE;
               BLK_BLOCKABLE_DIR_SH_IDX(blk_idx)             = NULL_IDX;
               break;
            }
         }
      }
   }

# endif


   /* If we're generating the Loop Definition record, output a		      */
   /* Statement_Num_Stmt SH because we need to put the statement number of    */
   /* loop ending statement in the Loop Definition record for Apprentice's    */
   /* use.  								      */
   /*                          SLEAZY TRICK ALERT!!			      */
   /* The statement number is stored in the SH_PARENT_BLK_IDX field.          */
   /* 									      */
   /* If the statement is labeled and it's not an END DO stmt, it has been    */
   /* completely processed by the time we get here which means its EOS has    */
   /* been eaten which means statement_number has been incremented already.   */
   /* If the loop-ending stmt is an END DO, this procedure is called before   */
   /* the EOS is eaten, so the current statement_number can be used.	      */
   /* As this code stands right now, the Statement_Num SH will be inserted    */
   /* between the statement's SH and its Label_Def SH.  If proves to be a     */
   /* problem, then insert code to search back to find the Label_Def SH and   */
   /* insert the Statement_Num SH ahead of it.				      */
   /* We also use the Statement_Num_Stmt SH to hold the position of the very  */
   /* last character of the DO loop (used in the Loop Definition record).     */

   if (cif_flags & MISC_RECS) {
      save_curr_stmt_sh_idx = 0;

      if (SH_COMPILER_GEN(curr_stmt_sh_idx)) {

         /* The current SH is compiler-generated so it means the loop-ending  */
         /* statement is labeled and that compiler-generated SH's were        */
         /* produced to represent the current statement.  We need to back up  */
         /* to the statement's actual SH and insert the Statement_Num SH      */
         /* ahead of it.  Otherwise, the Statement_Num SH would get buried    */
         /* among the compiler-generated SH's and possibly get unlinked       */
         /* (tossed) later.						      */

         sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);

         while (! SH_LABELED(sh_idx)) {
            sh_idx = SH_PREV_IDX(sh_idx);
         }

         save_curr_stmt_sh_idx = curr_stmt_sh_idx;
         curr_stmt_sh_idx      = sh_idx;
      }
         
      if (SH_LABELED(curr_stmt_sh_idx)  &&  stmt_type != End_Do_Stmt) {
         gen_sh(Before, Statement_Num_Stmt, stmt_end_line, stmt_end_col,
                FALSE, FALSE, TRUE);
         SH_PARENT_BLK_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) =
            statement_number - 1;
      }
      else {
         gen_sh(Before, Statement_Num_Stmt, LA_CH_LINE, LA_CH_COLUMN - 1,
                FALSE, FALSE, TRUE);
         SH_PARENT_BLK_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = statement_number;
      }

      if (save_curr_stmt_sh_idx != 0) {
         curr_stmt_sh_idx = save_curr_stmt_sh_idx;
      }
   }


   /* If a CYCLE exists that references the name of the current loop,         */
   /* generate a CONTINUE statement to define the CYCLE point label.          */
   /* Note:  Obtaining the label would be quicker (but at the expense of a    */
   /* larger Block Stack entry) if the label was generated and its index      */
   /* saved in the Block Stack entry when the CYCLE statement is parsed.      */
   /* Another alternative is to just always generate the label (don't even    */
   /* have a flag in the Block Stack entry).                                  */

   if (BLK_CYCLE_STMT(blk_stk_idx)) {
      attr_idx = gen_loop_lbl_name(blk_stk_idx, Cycle_Lbl);

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

      NTR_IR_TBL(ir_idx);
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
      IR_OPR(ir_idx)              = Label_Opr;
      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)            = attr_idx;

      AT_DEFINED(attr_idx)        = TRUE;
      AT_DEF_LINE(attr_idx)       = stmt_start_line;
      AT_REFERENCED(attr_idx)     = Referenced;
      ATL_DEF_STMT_IDX(attr_idx)  = curr_stmt_sh_idx;
      ATL_CYCLE_LBL(attr_idx)     = TRUE;
   }


# ifdef _HIGH_LEVEL_DO_LOOP_FORM

   gen_sh(After, Continue_Stmt, stmt_start_line, stmt_start_col,
          FALSE,		/* Set SH_ERR_FLAG to this value. */
          FALSE,		/* Not labeled.			  */
          TRUE);		/* Compiler-generated.		  */

   NTR_IR_TBL(ir_idx);
   SH_IR_IDX(curr_stmt_sh_idx)   = ir_idx;
   SH_LOOP_END(curr_stmt_sh_idx) = TRUE;
   IR_OPR(ir_idx)                = Loop_End_Opr;
   IR_TYPE_IDX(ir_idx)           = TYPELESS_DEFAULT_TYPE;
   IR_LINE_NUM(ir_idx)           = stmt_start_line;
   IR_COL_NUM(ir_idx)            = stmt_start_col;

   SH_LOOP_END(curr_stmt_sh_idx)       = TRUE;
   SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX;
 
   IR_FLD_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = SH_Tbl_Idx;
   IR_IDX_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = curr_stmt_sh_idx;


# endif


# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
       
   /* If the current loop is in a loop nest preceded by an INTERCHANGE,       */
   /* PDO, PARALLELDO, or DOACROSS directive, check to see if the current     */
   /* loop ending is perfectly nested in its containing loop.		      */

   if (BLK_INTERCHANGE_NUM_LCVS(blk_stk_idx) > 1  ||
       BLK_DIR_NEST_CHECK_NUM_LCVS(blk_stk_idx) > 1) {
      check_loop_bottom_nesting();
   }

# endif


   /* If an EXIT exists that references the name of the current loop,         */
   /* generate a CONTINUE statement to define the EXIT point label.           */
   /* Note:  Obtaining the label would be quicker (but at the expense of a    */
   /* larger Block Stack entry) if the label was generated and its index      */
   /* saved in the Block Stack entry when the EXIT statement is parsed.       */
   /* Another alternative is to just always generate the label (don't even    */
   /* have a flag in the Block Stack entry).                                  */

   if (BLK_EXIT_STMT(blk_stk_idx)) {
      attr_idx = gen_loop_lbl_name(blk_stk_idx, Exit_Lbl);

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

#ifndef _HIGH_LEVEL_DO_LOOP_FORM

      /* (For a high level iterative DO IR form, these links are on the       */
      /* Loop_End SH).							      */

      SH_LOOP_END(curr_stmt_sh_idx)       = TRUE;
      SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX;

      IR_FLD_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = SH_Tbl_Idx;
      IR_IDX_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = curr_stmt_sh_idx;

#endif

      NTR_IR_TBL(ir_idx);
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
      IR_OPR(ir_idx)              = Label_Opr;
      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)            = attr_idx;

      AT_DEFINED(attr_idx)        = TRUE;
      AT_DEF_LINE(attr_idx)       = stmt_start_line;
      AT_REFERENCED(attr_idx)     = Referenced;
      ATL_DEF_STMT_IDX(attr_idx)  = curr_stmt_sh_idx;
   }


   /* When generating IR for low-level DO loop forms, always generate a       */
   /* CONTINUE statement to define the end of the loop (even if the loop is   */
   /* an infinite DO or "one-trip" DO loops were specified).  We need this    */
   /* SH to find the actual end of the loop because if a loop ends with an    */
   /* executable stmt, that stmt may get expanded into multiple SH's.  This   */
   /* CONTINUE statement can also be used to define the branch-around label.  */

# ifndef _HIGH_LEVEL_DO_LOOP_FORM

   gen_sh(After, Continue_Stmt, stmt_start_line, stmt_start_col,
          FALSE,			/* Set SH_ERR_FLAG to this value.     */
          TRUE,		  		/* Labeled.			      */
          TRUE);			/* Compiler-generated.		      */

   if (BLK_DO_TYPE(blk_stk_idx) != Infinite_Loop) {
      NTR_IR_TBL(ir_idx);
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
      IR_OPR(ir_idx)              = Label_Opr;
      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)            = BLK_SKIP_LBL_IDX(blk_stk_idx);
      AT_DEFINED(BLK_SKIP_LBL_IDX(blk_stk_idx))       = TRUE;
      AT_DEF_LINE(BLK_SKIP_LBL_IDX(blk_stk_idx))      = stmt_start_line;
      AT_REFERENCED(BLK_SKIP_LBL_IDX(blk_stk_idx))    = Referenced;
      ATL_DEF_STMT_IDX(BLK_SKIP_LBL_IDX(blk_stk_idx)) = curr_stmt_sh_idx;
   }

   if (! BLK_EXIT_STMT(blk_stk_idx)) {
      SH_LOOP_END(curr_stmt_sh_idx)       = TRUE;
      SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX;
 
      IR_FLD_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = SH_Tbl_Idx;
      IR_IDX_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = curr_stmt_sh_idx;
   }

# endif


   TRACE (Func_Exit, "loop_end_processing", NULL);

   return;

}  /* loop_end_processing */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Called if bad block is found on the block stack.                      *|
|*	Issues internal error message and aborts compilation.                 *|
|*									      *|
|* Input parameters:							      *|
|*	err_call => Boolean - TRUE if this is called from an error situation. *|
|*	            This means the compiler is trying to clean up the block   *|
|*	            stack and do error recovery.                              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void end_internal_err(boolean	err_call)

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

   PRINTMSG(stmt_start_line, 160, Internal, stmt_start_col);

   TRACE (Func_Exit, "end_internal_err", NULL);

   return;

}  /* end_internal_err */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Sets char ptrs for issuing meaningful end block error msgs.	      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static char *blk_desc_str(int	 blk_idx)
{
#ifdef KEY /* Bug 10177 */
   char		*blk_stmt_str = 0;
#else /* KEY Bug 10177 */
   char		*blk_stmt_str;
#endif /* KEY Bug 10177 */
   int		 idx;

   TRACE (Func_Entry, "blk_desc_str", NULL);

   /* The cases in the following switch statement are in the same order as    */
   /* the values in blk_cntxt_values in p_globals.h.			      */

   switch (BLK_TYPE(blk_idx)) {

      case Unknown_Blk:
         PRINTMSG(stmt_start_line, 160, Internal, stmt_start_col);
         break;

      case Blockdata_Blk:
         blk_stmt_str = "BLOCKDATA";
         break;

      case Module_Blk:
         blk_stmt_str = "MODULE";
         break;

      case Program_Blk:
         blk_stmt_str = "PROGRAM";
         break;

      case Function_Blk:
         blk_stmt_str = "FUNCTION";
         break;

      case Subroutine_Blk:
         blk_stmt_str = "SUBROUTINE";
         break;

      case Internal_Blk:
      case Module_Proc_Blk:
      case Interface_Body_Blk:
         blk_stmt_str = (ATP_PGM_UNIT(BLK_NAME(blk_idx)) == Function) ?
                         "FUNCTION" :  "SUBROUTINE";
         break;

      case Do_Blk:
         blk_stmt_str = "DO";
         break;

      case Forall_Blk:
         blk_stmt_str = "FORALL";
         break;

      case If_Blk:
      case If_Then_Blk:
      case If_Else_If_Blk:
      case If_Else_Blk:
         blk_stmt_str = "IF";
         break;

      case Select_Blk:
      case Case_Blk:
         blk_stmt_str = "SELECT CASE";
         break;

      case Where_Then_Blk:
      case Where_Else_Blk:
      case Where_Else_Mask_Blk:
         blk_stmt_str = "WHERE";
         break;

      case Parallel_Blk:
         blk_stmt_str = "PARALLEL";
         break;

      case Doall_Blk:
         blk_stmt_str = "DOALL";
         break;

      case Do_Parallel_Blk:
         blk_stmt_str = "DO PARALLEL";
         break;

      case Guard_Blk:
         blk_stmt_str = "GUARD";
         break;

      case Parallel_Case_Blk:
         blk_stmt_str = "CASE";
         break;

      case Wait_Blk:
         blk_stmt_str = "WAIT";
         break;

      case SGI_Doacross_Blk:
         blk_stmt_str = "DOACROSS";
         break;

      case SGI_Psection_Blk:
         blk_stmt_str = "PSECTION";
         break;

      case SGI_Section_Blk:
         blk_stmt_str = "SECTION";
         break;

      case SGI_Pdo_Blk:
         blk_stmt_str = "PDO";
         break;

      case SGI_Parallel_Do_Blk:
         blk_stmt_str = "PARALLEL DO";
         break;

      case SGI_Parallel_Blk:
         blk_stmt_str = "PARALLEL";
         break;

      case SGI_Critical_Section_Blk:
         blk_stmt_str = "CRITICAL SECTION";
         break;

      case SGI_Single_Process_Blk:
         blk_stmt_str = "SINGLE PROCESS";
         break;

      case SGI_Region_Blk:
         blk_stmt_str = "REGION";
         break;

      case Open_Mp_Parallel_Blk:
         blk_stmt_str = "!$OMP PARALLEL";
         break;

      case Open_Mp_Do_Blk:
         blk_stmt_str = "!$OMP DO";
         break;

      case Open_Mp_Parallel_Sections_Blk:
         blk_stmt_str = "!$OMP PARALLEL SECTIONS";
         break;

      case Open_Mp_Sections_Blk:
         blk_stmt_str = "!$OMP SECTIONS";
         break;

      case Open_Mp_Section_Blk:
         blk_stmt_str = "!$OMP SECTION";
         break;

      case Open_Mp_Single_Blk:
         blk_stmt_str = "!$OMP SINGLE";
         break;

      case Open_Mp_Parallel_Do_Blk:
         blk_stmt_str = "!$OMP PARALLEL DO";
         break;

      case Open_Mp_Master_Blk:
         blk_stmt_str = "!$OMP MASTER";
         break;

      case Open_Mp_Critical_Blk:
         blk_stmt_str = "!$OMP CRITICAL";
         break;

      case Open_Mp_Ordered_Blk:
         blk_stmt_str = "!$OMP ORDERED";
         break;

      case Contains_Blk:
         for (idx = blk_idx;
              idx > NULL_IDX && (BLK_TYPE(idx) > Blockdata_Blk);
              idx--);

         /* First entry will always be at least $MAIN */

         blk_stmt_str = blk_desc_str(idx);
         break;

      case Interface_Blk:
         blk_stmt_str = "INTERFACE";
         break;

#ifdef KEY /* Bug 10572 */
      case Enum_Blk:
         blk_stmt_str = "ENUM";
         break;
#endif /* KEY Bug 10572 */

      case Derived_Type_Blk:
         blk_stmt_str = "TYPE";
         break;

   }  /* End switch */

   TRACE (Func_Exit, "blk_desc_str", NULL);
   return(blk_stmt_str);

}  /* blk_desc_str */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This issues the error message if there is a block matching error.     *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

int	blk_match_err(blk_cntxt_type	blk_type,
		      boolean		has_name,
		      boolean		all_match)

{
   int			blk_idx;
   boolean		name_err	= FALSE;
   pgm_unit_type	pgm_type;


   TRACE (Func_Entry, "blk_match_err", NULL);

   if (stmt_type == End_Subroutine_Stmt || stmt_type == End_Function_Stmt) {
   
      /* Need to search for Internal_Blk, Module_Proc_Blk, Interface_Body_Blk */
      /* Subroutine_Blk or Function_Blk                                       */

      pgm_type = (stmt_type == End_Function_Stmt) ? Function : Subroutine;

      /* Check to see if this matchs the first block.  If it does, then only  */
      /* the name is in error.                                                */

      name_err = (STMT_LEGAL_IN_BLK(stmt_type, CURR_BLK) &&
                  ATP_PGM_UNIT(CURR_BLK_NAME) == pgm_type);

      for (blk_idx = blk_stk_idx; blk_idx > NULL_IDX; blk_idx--) {

         if (STMT_LEGAL_IN_BLK(stmt_type, BLK_TYPE(blk_idx)) &&
             ATP_PGM_UNIT(BLK_NAME(blk_idx)) == pgm_type) {

            if (!has_name || 
                (compare_names(TOKEN_ID(token).words,
                               TOKEN_LEN(token),
                               AT_OBJ_NAME_LONG(BLK_NAME(blk_idx)),
                               AT_NAME_LEN(BLK_NAME(blk_idx))) == 0)) {
               break;   /* Found the match */
            }
         }
      }
   }
   else {
      name_err = STMT_LEGAL_IN_BLK(stmt_type, CURR_BLK);

      for (blk_idx = blk_stk_idx; blk_idx > NULL_IDX; blk_idx--) {

         if (STMT_LEGAL_IN_BLK(stmt_type, BLK_TYPE(blk_idx))) {

            if (stmt_type == Else_If_Stmt  ||  stmt_type == Else_Stmt  ||
                stmt_type == Case_Stmt) {
               name_err = FALSE;

               if (has_name) {

                  if (BLK_NAME(blk_idx) == NULL_IDX) {
                     PRINTMSG(TOKEN_LINE(token), 285, Error,
			      TOKEN_COLUMN(token),
                              blk_desc_str(blk_idx),
			      stmt_type_str[stmt_type]);
                  }
                  else if (compare_names(TOKEN_ID(token).words,
				  	 TOKEN_LEN(token),
                                         AT_OBJ_NAME_LONG(BLK_NAME(blk_idx)),
                                         AT_NAME_LEN(BLK_NAME(blk_idx))) != 0) {
                     PRINTMSG(TOKEN_LINE(token), 284, Error,
                              TOKEN_COLUMN(token),
                              blk_desc_str(blk_idx),
                              AT_OBJ_NAME_PTR(BLK_NAME(blk_idx)),
                              stmt_type_str[stmt_type]);
                  }
               }

               break;
            }
            else {

               if (!has_name) {

                  /* If all_match is set, then if the block has a name, the   */
                  /* thing that's looking for the match must have the same    */
                  /* name.						      */

                  if (!all_match || BLK_NAME(blk_idx) == NULL_IDX) {
                     break;
                  }
               }
               else if (BLK_NAME(blk_idx) != NULL_IDX && 
                        (compare_names(TOKEN_ID(token).words,
                                       TOKEN_LEN(token),
                                       AT_OBJ_NAME_LONG(BLK_NAME(blk_idx)),
                                       AT_NAME_LEN(BLK_NAME(blk_idx))) == 0)) {
                  break;
               }
            }
         }
      }
   }

   if (blk_idx == NULL_IDX && name_err) {

      /* Didn't find a match on the block, so if the statement fits in the    */
      /* current block, assume there is just a name error and issue it.       */

      /* Possible combinations:                                               */
      /*   CURR_BLK_NAME       has_name        stmt_type                      */
      /*     NULL_IDX            TRUE       all stmts                         */
      /*     NULL_IDX            FALSE      Won't be here.  This is a match.  */
      /*     have name           TRUE       Must be name mismatch             */
      /*     have name           FALSE      Only err for END of IF, DO, SELCT */

      switch (stmt_type) {
         case End_If_Stmt:
         case End_Do_Stmt:
         case End_Select_Stmt:
         case Else_If_Stmt:
         case Else_Stmt:
         case Then_Stmt:
         case Case_Stmt:
         case End_Forall_Stmt:
         case Else_Where_Stmt:
         case Else_Where_Mask_Stmt:
         case End_Where_Stmt:
            if (CURR_BLK_NAME == NULL_IDX) {
               PRINTMSG(TOKEN_LINE(token), 285, Error, TOKEN_COLUMN(token),
                        blk_desc_str(blk_stk_idx), stmt_type_str[stmt_type]);
            }
            else {
               PRINTMSG((has_name) ? TOKEN_LINE(token) : stmt_start_line,
                        284, Error,
                        (has_name) ? TOKEN_COLUMN(token) : stmt_start_col,
                        blk_desc_str(blk_stk_idx),
                        AT_OBJ_NAME_PTR(CURR_BLK_NAME),
                        stmt_type_str[stmt_type]);
            }
            break;

         case End_Blockdata_Stmt:
         case End_Program_Stmt:
            if (CURR_BLK_NAME == NULL_IDX) {

               if (stmt_type == End_Blockdata_Stmt) { /* No BLOCKDATA name */
                  PRINTMSG(TOKEN_LINE(token), 158, Error,
                           TOKEN_COLUMN(token));
               }
               else {  /* No PROGRAM statement */
                  PRINTMSG(TOKEN_LINE(token), 40, Error, 
                           TOKEN_COLUMN(token));
               }
   
               /* We've found an END BLOCK DATA or (more likely) END PROGRAM  */
               /* stmt that has no matching BLOCK DATA or (more likely)       */
               /* PROGRAM stmt.  blk_match_err is going to call the           */
               /* appropriate end-of-program unit routine which will produce  */
               /* the CIF End Scope and End Unit records.  They will go in    */
               /* the temporary CIF.  When control returns to p_driver.c, it  */
               /* will think a new program unit is beginning so it will call  */
               /* cif_unit_rec which will produce the Unit record then copy   */
               /* the temporary CIF to the actual CIF.  This means that the   */
               /* End Scope and End Unit will get copied to the actual CIF.   */
               /* THEN p_driver.c will call cif_scope_rec to issue the Begin  */
               /* Scope record, which will, of course, now be out of order.   */
               /* (Not to mention that the end-of-program unit routine has    */
               /* reset blk_stk_idx to 0 which means the CIF routines will    */
               /* be accessing the 0th (bad) Block Stack entry.  To recover   */
               /* from this weird case, set cif_pgm_unit_error_recovery to    */
               /* TRUE here.  When cif_unit_rec sees it is TRUE, it won't     */
               /* copy the temporary CIF to the actual CIF.  When p_driver.c  */
               /* sees its TRUE, it'll produce the Begin Scope record, THEN   */
               /* copy the temporary CIF to the actual CIF.		      */

               cif_pgm_unit_error_recovery = TRUE;

               break;
            }

            /* Break intentionally not here.  Should fall through.            */

         case End_Module_Stmt:
         case End_Function_Stmt:
         case End_Subroutine_Stmt:
         case End_Interface_Stmt:
         case End_Type_Stmt: /* These must have a CURR_BLK_NAME */
            PRINTMSG(TOKEN_LINE(token), 283, Error, TOKEN_COLUMN(token),
                     stmt_type_str[stmt_type],
                     blk_desc_str(blk_stk_idx),
                     AT_OBJ_NAME_PTR(CURR_BLK_NAME));
            break;

#ifdef KEY /* Bug 10572 */
         case End_Enum_Stmt:
	    PRINTMSG(TOKEN_LINE(token), 197, Error, TOKEN_COLUMN(token),
	      EOS_STR, TOKEN_STR(token));
	    break;
#endif /* KEY Bug 10572 */
# ifdef _DEBUG
         default:
            PRINTMSG(stmt_start_line, 179, Internal,
                     stmt_start_col, "blk_match_err");
            break;
# endif
      }  /* End switch */
      SH_ERR_FLG(curr_stmt_sh_idx)	= TRUE;
      blk_idx				= blk_stk_idx;
   }
   else if ((stmt_type == Else_Stmt  &&  CURR_BLK == If_Else_Blk)  ||
            (stmt_type == Else_Where_Stmt  &&  CURR_BLK == Where_Else_Blk) ) {

      /* An IF construct may contain only a single ELSE block and a WHERE     */
      /* construct may contain only a single ELSEWHERE block.                 */

      PRINTMSG(stmt_start_line, 43, Error, stmt_start_col, 
               stmt_type_str[stmt_type], blk_desc_str(blk_stk_idx));
   }
   else if (stmt_type == Else_If_Stmt  &&  CURR_BLK == If_Else_Blk) {

      /* An ELSE IF block must not follow an ELSE block.                      */

      PRINTMSG(stmt_start_line, 1158, Error, stmt_start_col);
   } 
   else if (stmt_type == Else_Where_Mask_Stmt  &&  CURR_BLK == Where_Else_Blk) {

      /* An ELSE WHERE (mask) block must not follow an ELSE WHERE block.      */

      PRINTMSG(stmt_start_line, 1609, Error, stmt_start_col);
   } 
   else if (blk_idx == NULL_IDX) { 

      /* Push the blk_type on the stack, so blk_desc_str can describe it for  */
      /* the error message.  Then POP it.  It is only needed for the message. */

      PUSH_BLK_STK(blk_type);
      PRINTMSG(stmt_start_line, 289, Error, stmt_start_col,
               stmt_type_str[stmt_type], blk_desc_str(blk_stk_idx));
      POP_BLK_STK;

      SH_ERR_FLG(curr_stmt_sh_idx)	= TRUE;
   }
   else {                   /* Have a match, but not to the current block.    */

      pop_and_err_blk_stk(blk_idx, (BLK_TYPE(blk_idx) <= Interface_Body_Blk));

      if (BLK_TYPE(blk_idx) > Interface_Body_Blk && 
          BLK_TYPE(blk_idx) != Select_Blk) {
         blk_idx = move_blk_to_end(blk_idx);
      }
   }

   TRACE (Func_Exit, "blk_match_err", NULL);

   return(blk_idx);

}  /* blk_match_err */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Go through the blk_stk until match_idx is reached.  For each blk,     *|
|*	passed up; issue a missing end err if the err is not already set;     *|
|*	call the appropriate end routine for the block, and then pop it.      *|
|*	When the matched item is reached, just leave it and don't pop it.     *|
|*	It is the responsibility of the calling routine to handle the         *|
|*	match block.                                                          *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE - if error was issued, else FALSE                                *|
|*									      *|
\******************************************************************************/

boolean	pop_and_err_blk_stk(int		match_idx,
			    boolean	pop_the_blks)

{
   int		blk_idx;
   int		blk_line_idx;
   boolean	issued_error = FALSE;
   boolean	save_sh_err_flg;
   int		sh_idx;


   TRACE (Func_Entry, "pop_and_err_blk_stk", NULL);

   blk_idx = blk_stk_idx;

   while (blk_idx > match_idx) {

      if (BLK_TYPE(blk_idx) == Do_Parallel_Blk ||
          BLK_TYPE(blk_idx) == SGI_Pdo_Blk ||
          BLK_TYPE(blk_idx) == Open_Mp_Do_Blk ||
          BLK_TYPE(blk_idx) == Open_Mp_Parallel_Do_Blk) {

         if (BLK_TYPE(blk_idx) == Do_Parallel_Blk) {
            CLEAR_DIRECTIVE_STATE(Do_Parallel_Region);
         }
         else if (BLK_TYPE(blk_idx) == SGI_Pdo_Blk) {
            CLEAR_DIRECTIVE_STATE(Pdo_Region);
         }
         else if (BLK_TYPE(blk_idx) == Open_Mp_Do_Blk) {
            CLEAR_DIRECTIVE_STATE(Open_Mp_Do_Region);
         }
         else if (BLK_TYPE(blk_idx) == Open_Mp_Parallel_Do_Blk) {
            CLEAR_DIRECTIVE_STATE(Open_Mp_Parallel_Do_Region);
         }

         move_blk_to_end(blk_idx);
         POP_BLK_STK;
         blk_idx--;
         continue;
      }

      /* Issue missing end msg if it doesn't already have a msg issued for */
      /* it.  (blk_err=TRUE).  Also, don't issue msgs for contains blocks. */

      if (!BLK_ERR(blk_idx) &&
           BLK_TYPE(blk_idx) != Contains_Blk) {

         if (BLK_TYPE(blk_idx) != Program_Blk) {

            save_sh_err_flg = SH_ERR_FLG(curr_stmt_sh_idx);

           /* Missing termination or END statement.                          */

            if (BLK_TYPE(blk_idx) == Do_Blk) {
   
               if (stmt_label_idx == NULL_IDX  || 
                   stmt_label_idx != BLK_LABEL(blk_idx)) {
                  PRINTMSG(BLK_DEF_LINE(blk_idx), 288, Error,
                           BLK_DEF_COLUMN(blk_idx));
                  issued_error = TRUE;
                  SH_ERR_FLG(BLK_FIRST_SH_IDX(blk_idx)) = TRUE;
               }
            }
            else if (BLK_TYPE(blk_idx) == Parallel_Blk) {
               PRINTMSG(BLK_DEF_LINE(blk_idx), 1217, Error,
                        BLK_DEF_COLUMN(blk_idx),
                        "END PARALLEL","PARALLEL");
               issued_error = TRUE;
               SH_ERR_FLG(BLK_FIRST_SH_IDX(blk_idx)) = TRUE;
            }
            else if (BLK_TYPE(blk_idx) == Guard_Blk) {
               PRINTMSG(BLK_DEF_LINE(blk_idx), 1217, Error,
                        BLK_DEF_COLUMN(blk_idx),
                        "END GUARD","GUARD");
               issued_error = TRUE;
               SH_ERR_FLG(BLK_FIRST_SH_IDX(blk_idx)) = TRUE;
            }
            else if (BLK_TYPE(blk_idx) == Parallel_Case_Blk) {
               PRINTMSG(BLK_DEF_LINE(blk_idx), 1217, Error,
                        BLK_DEF_COLUMN(blk_idx),
                        "END CASE","CASE");
               issued_error = TRUE;
               SH_ERR_FLG(BLK_FIRST_SH_IDX(blk_idx)) = TRUE;
            }
            else if (BLK_TYPE(blk_idx) == Wait_Blk) {
               PRINTMSG(BLK_DEF_LINE(blk_idx), 1217, Error,
                        BLK_DEF_COLUMN(blk_idx),
                        "SEND","WAIT");
               issued_error = TRUE;
               SH_ERR_FLG(BLK_FIRST_SH_IDX(blk_idx)) = TRUE;
            }
            else {
               blk_line_idx = blk_idx;

               if (BLK_TYPE(blk_idx) == Case_Blk) {
                  for (; BLK_TYPE(blk_line_idx) != Select_Blk; blk_line_idx--);
               }
               else if (BLK_TYPE(blk_idx) == If_Then_Blk ||
                        BLK_TYPE(blk_idx) == If_Else_If_Blk ||
                        BLK_TYPE(blk_idx) == If_Else_Blk) {
                  do {

                    if (BLK_TYPE(blk_line_idx) == If_Then_Blk ||
                        BLK_TYPE(blk_line_idx) == If_Else_If_Blk ||
                        BLK_TYPE(blk_line_idx) == If_Else_Blk) {
                       BLK_ERR(blk_line_idx)                      = TRUE;
                       SH_ERR_FLG(BLK_FIRST_SH_IDX(blk_line_idx)) = TRUE;
                    }
                    blk_line_idx--;
                 } while (BLK_TYPE(blk_line_idx) != If_Blk);
               }

               if (!BLK_ERR(blk_line_idx)) {  /* Prevent duplicate errors */
                  PRINTMSG(BLK_DEF_LINE(blk_line_idx), 291, Error,
                           BLK_DEF_COLUMN(blk_line_idx), 
                           blk_desc_str(blk_idx));
                  issued_error = TRUE;
                  BLK_ERR(blk_line_idx)                      = TRUE;
                  SH_ERR_FLG(BLK_FIRST_SH_IDX(blk_line_idx)) = TRUE;
               }
            }

            SH_ERR_FLG(curr_stmt_sh_idx) = save_sh_err_flg;

         }
         else {   /* Main program unit is missing its END statement. */

            if (SCP_ATTR_IDX(curr_scp_idx) == glb_tbl_idx[Main_Attr_Idx]) {

               /* This is $MAIN.  Make sure this isn't just a bad end stmt  */
               /* that results from an earlier mess, the compiler is trying */
               /* to clean up.  If so, do not issue an error.               */

               if (!AT_DCL_ERR(glb_tbl_idx[Main_Attr_Idx]) && 
                   !SCP_IN_ERR(curr_scp_idx)) {
                  PRINTMSG(BLK_DEF_LINE(blk_idx), 293, Error,
                           BLK_DEF_COLUMN(blk_idx));
                  issued_error = TRUE;
               }
            } 
            else {
               PRINTMSG(BLK_DEF_LINE(blk_idx), 955, Error,
                        BLK_DEF_COLUMN(blk_idx),
                        AT_OBJ_NAME_PTR(CURR_BLK_NAME));
               issued_error = TRUE;
            } 

            if (need_new_sh) {
               sh_idx				= curr_stmt_sh_idx;
               curr_stmt_sh_idx			= ntr_sh_tbl();
               SH_NEXT_IDX(sh_idx)		= curr_stmt_sh_idx;
               SH_PREV_IDX(curr_stmt_sh_idx)	= sh_idx;
            }

            SH_GLB_LINE(curr_stmt_sh_idx)	= stmt_start_line;
            SH_COL_NUM(curr_stmt_sh_idx)	= stmt_start_col;
            SH_STMT_TYPE(curr_stmt_sh_idx)	= End_Stmt;
         }
      }

      BLK_ERR(blk_idx) = TRUE;

      if (pop_the_blks) { /* Call the end routine for each block to pop. */

         if (BLK_TYPE(blk_idx) == Case_Blk ||
             BLK_TYPE(blk_idx) == If_Then_Blk ||
             BLK_TYPE(blk_idx) == If_Else_If_Blk ||
             BLK_TYPE(blk_idx) == If_Else_Blk) {
            (*end_blocks[BLK_TYPE(blk_idx)]) (TRUE);	/* Pop 2 blocks */
            blk_idx--;
         }
         else {
            (*end_blocks[BLK_TYPE(blk_idx)]) (TRUE);
         }
      }

      /* Always pop the Where_Else_Blk and If_Else_Blk, if another Where_Else */
      /* _Blk or If_Else_Blk follows it, to prevent multiple Else_Blks from   */
      /* getting on the stack.                                                */

      else if (BLK_TYPE(blk_idx) == Where_Else_Blk &&
               (stmt_type == Else_Where_Stmt || 
                stmt_type == Else_Where_Mask_Stmt)) { 
         move_blk_to_end(blk_idx);
         POP_BLK_STK;
      }
      else if (BLK_TYPE(blk_idx) == If_Else_Blk &&
               (stmt_type == Else_Stmt || stmt_type == Else_If_Stmt)) { 
         move_blk_to_end(blk_idx);
         POP_BLK_STK;
      }

      blk_idx--;
   }  /* End while */

   TRACE (Func_Exit, "pop_and_err_blk_stk", NULL);

   return(issued_error);

}  /* pop_and_err_blk_stk */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This procedure moves a block to the end of a block stack.  It's used  *|
|*      for popping bad blocks.                                               *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

int move_blk_to_end(int	blk_idx)

{
   int		new_idx;

   TRACE (Func_Entry, "move_blk_to_end", NULL);

   if (blk_idx != blk_stk_idx) {

      PUSH_BLK_STK(BLK_TYPE(blk_idx));    		/* Make a spot for blk*/
      blk_stk[blk_stk_idx]	= blk_stk[blk_idx];	/* Copy block to end */

      if (BLK_TYPE(blk_idx) == Do_Blk &&
          BLK_TYPE(blk_idx - 1) == Doall_Blk) {

         for (new_idx = blk_idx - 1; new_idx < blk_stk_idx - 1; new_idx++) {
             blk_stk[new_idx]	= blk_stk[new_idx + 2];
         }

         POP_BLK_STK;
         POP_BLK_STK;
         cdir_switches.doall_region = FALSE;
      }
      else {
         for (new_idx = blk_idx; new_idx < blk_stk_idx; new_idx++) {
             blk_stk[new_idx]	= blk_stk[new_idx + 1];
         }

         POP_BLK_STK;
      }
   }

   TRACE (Func_Exit, "move_blk_to_end", NULL);

   return(blk_stk_idx);

}  /* move_blk_to_end */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void end_parallel_blk(boolean  err_call)

{

   TRACE (Func_Entry, "end_parallel_blk", NULL);

   if (CURR_BLK == Do_Parallel_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Do_Parallel_Region);
   }

   if (CURR_BLK == SGI_Pdo_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Pdo_Region);
   }

   if (! err_call) {

      if (cdir_switches.dopar_sh_idx != NULL_IDX) {
         PRINTMSG(SH_GLB_LINE(cdir_switches.dopar_sh_idx), 1219, Error,
                  SH_COL_NUM(cdir_switches.dopar_sh_idx),
                  "DO PARALLEL");
         cdir_switches.dopar_sh_idx = NULL_IDX;
      }

      if (STMT_CANT_BE_IN_BLK(End_Parallel_Stmt, CURR_BLK)) {
         blk_match_err(Parallel_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Parallel_Blk) {
         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_parallel_blk", NULL);

   return;

}  /* end_parallel_blk */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void end_doall_blk(boolean  err_call)

{

   TRACE (Func_Entry, "end_doall_blk", NULL);

   POP_BLK_STK;

   TRACE (Func_Exit, "end_doall_blk", NULL);

   return;

}  /* end_doall_blk */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void end_wait_blk(boolean  err_call)

{

   TRACE (Func_Entry, "end_wait_blk", NULL);

   /* NOTE - This routine should never be called.  Everything is handled */
   /*        in directive.c under the SEND directive.                    */

   POP_BLK_STK;

   TRACE (Func_Exit, "end_wait_blk", NULL);

   return;

}  /* end_wait_blk */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void end_do_parallel_blk(boolean  err_call)

{
   int		sh_idx;


   TRACE (Func_Entry, "end_do_parallel_blk", NULL);

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(End_Do_Parallel_Stmt, CURR_BLK)) {

         if (cdir_switches.dopar_sh_idx != NULL_IDX) {
            PRINTMSG(SH_GLB_LINE(cdir_switches.dopar_sh_idx), 1219, Error,
                     SH_COL_NUM(cdir_switches.dopar_sh_idx),
                     "DO PARALLEL");
            cdir_switches.dopar_sh_idx = NULL_IDX;
         }
         else {
            blk_match_err(Do_Parallel_Blk, FALSE, FALSE);
         }
      }

      if (CURR_BLK == Do_Parallel_Blk) {

         /* remove the enddo statement that was generated at the */
         /* end of the Do Blk. This one supersedes it. */

         if (BLK_ENDDO_PARALLEL_SH_IDX(blk_stk_idx) != NULL_IDX) {
            sh_idx = BLK_ENDDO_PARALLEL_SH_IDX(blk_stk_idx);
            SH_PREV_IDX(SH_NEXT_IDX(sh_idx)) = SH_PREV_IDX(sh_idx);
            SH_NEXT_IDX(SH_PREV_IDX(sh_idx)) = SH_NEXT_IDX(sh_idx);

            FREE_IR_NODE(SH_IR_IDX(sh_idx));
            FREE_SH_NODE(sh_idx);
         }

         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_do_parallel_blk", NULL);

   return;

}  /* end_do_parallel_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_pdo_blk(boolean  err_call)

{
   int          sh_idx;


   TRACE (Func_Entry, "end_pdo_blk", NULL);

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(SGI_End_Pdo_Stmt, CURR_BLK)) {

         if (cdir_switches.pdo_sh_idx != NULL_IDX) {
            PRINTMSG(SH_GLB_LINE(cdir_switches.pdo_sh_idx), 1219, Error,
                     SH_COL_NUM(cdir_switches.pdo_sh_idx),
                     "PDO");
            cdir_switches.pdo_sh_idx = NULL_IDX;
         }
         else {
            blk_match_err(SGI_Pdo_Blk, FALSE, FALSE);
         }
      }

      if (CURR_BLK == SGI_Pdo_Blk) {
         /* remove the enddo statement that was generated at the */
         /* end of the Do Blk. This one supersedes it. */

         if (BLK_ENDPDO_SH_IDX(blk_stk_idx) != NULL_IDX) {
            sh_idx = BLK_ENDPDO_SH_IDX(blk_stk_idx);
            SH_PREV_IDX(SH_NEXT_IDX(sh_idx)) = SH_PREV_IDX(sh_idx);
            SH_NEXT_IDX(SH_PREV_IDX(sh_idx)) = SH_NEXT_IDX(sh_idx);

            FREE_IR_NODE(SH_IR_IDX(sh_idx));
            FREE_SH_NODE(sh_idx);
         }

         IR_LINE_NUM_R(SH_IR_IDX(curr_stmt_sh_idx)) = stmt_start_line;
         IR_COL_NUM_R(SH_IR_IDX(curr_stmt_sh_idx))  = stmt_start_col;
         IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx;
         IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX;

         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_pdo_blk", NULL);

   return;

}  /* end_pdo_blk */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void end_guard_blk(boolean  err_call)

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

   if (CURR_BLK == Do_Parallel_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Do_Parallel_Region);
   }

   if (CURR_BLK == SGI_Pdo_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Pdo_Region);
   }

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(End_Guard_Stmt, CURR_BLK)) {
         blk_match_err(Guard_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Guard_Blk) {
         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_guard_blk", NULL);

   return;

}  /* end_guard_blk */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void end_parallel_case_blk(boolean  err_call)

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

   if (CURR_BLK == Do_Parallel_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Do_Parallel_Region);
   }

   if (CURR_BLK == SGI_Pdo_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Pdo_Region);
   }

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(stmt_type, CURR_BLK)) {
         blk_match_err(Parallel_Case_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Parallel_Case_Blk) {
         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_parallel_case_blk", NULL);

   return;

}  /* end_parallel_case_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_SGI_parallel_blk(boolean  err_call)

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

   while (blk_stk_idx > 0 &&
          (CURR_BLK == Do_Parallel_Blk ||
           CURR_BLK == SGI_Pdo_Blk     ||
           CURR_BLK == SGI_Psection_Blk ||
           CURR_BLK == SGI_Section_Blk ||
           CURR_BLK == SGI_Single_Process_Blk ||
           CURR_BLK == SGI_Critical_Section_Blk)) {

      switch (CURR_BLK) {
         case Do_Parallel_Blk:
            CLEAR_DIRECTIVE_STATE(Do_Parallel_Region);
            break;

         case SGI_Pdo_Blk:
            CLEAR_DIRECTIVE_STATE(Pdo_Region);
            break;

         case SGI_Psection_Blk:
            CLEAR_DIRECTIVE_STATE(Parallel_Section_Region);
            break;

         case SGI_Section_Blk:
            CLEAR_DIRECTIVE_STATE(Parallel_Section_Region);
            break;

         case SGI_Single_Process_Blk:
            CLEAR_DIRECTIVE_STATE(Single_Process_Region);
            break;

         case SGI_Critical_Section_Blk:
            CLEAR_DIRECTIVE_STATE(Critical_Section_Region);
            break;
      }

      /* just pop it */
      POP_BLK_STK;
   }

   if (! err_call) {

      if (cdir_switches.pdo_sh_idx != NULL_IDX) {
         PRINTMSG(SH_GLB_LINE(cdir_switches.pdo_sh_idx), 1219, Error,
                  SH_COL_NUM(cdir_switches.pdo_sh_idx),
                  "PDO");
         cdir_switches.pdo_sh_idx = NULL_IDX;
      }

      if (STMT_CANT_BE_IN_BLK(SGI_End_Parallel_Stmt, CURR_BLK)) {
         blk_match_err(SGI_Parallel_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == SGI_Parallel_Blk) {
         /* point to the PARALLEL directive */
         IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx;
         IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX;

         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_SGI_parallel_blk", NULL);

   return;

}  /* end_SGI_parallel_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_doacross_blk(boolean  err_call)

{

   TRACE (Func_Entry, "end_doacross_blk", NULL);

   POP_BLK_STK;

   TRACE (Func_Exit, "end_doacross_blk", NULL);

   return;

}  /* end_doacross_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_critical_section_blk(boolean  err_call)

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

   if (CURR_BLK == Do_Parallel_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Do_Parallel_Region);
   }

   if (CURR_BLK == SGI_Pdo_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Pdo_Region);
   }

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(SGI_End_Critical_Section_Stmt, CURR_BLK)) {
         blk_match_err(SGI_Critical_Section_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == SGI_Critical_Section_Blk) {
         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_critical_section_blk", NULL);

   return;

}  /* end_critical_section_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_psection_blk(boolean  err_call)

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

   if (CURR_BLK == Do_Parallel_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Do_Parallel_Region);
   }

   if (CURR_BLK == SGI_Pdo_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Pdo_Region);
   }

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(SGI_End_Psection_Stmt, CURR_BLK)) {
         blk_match_err(SGI_Section_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == SGI_Section_Blk) {
         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   if (CURR_BLK == SGI_Psection_Blk) {
      /* point to the PSECTION directive */
      IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx;
      IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX;

      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_psection_blk", NULL);

   return;

}  /* end_psection_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_single_process_blk(boolean  err_call)

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

   if (CURR_BLK == Do_Parallel_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Do_Parallel_Region);
   }

   if (CURR_BLK == SGI_Pdo_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Pdo_Region);
   }

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(SGI_End_Single_Process_Stmt, CURR_BLK)) {
         blk_match_err(SGI_Single_Process_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == SGI_Single_Process_Blk) {
         /* point to the SINGLE PROCESS directive */
         IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx;
         IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX;

         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_single_process_blk", NULL);

   return;

}  /* end_single_process_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_region_blk(boolean  err_call)

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

   if (CURR_BLK == Do_Parallel_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Do_Parallel_Region);
   }

   if (CURR_BLK == SGI_Pdo_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Pdo_Region);
   }

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(SGI_Region_End_Stmt, CURR_BLK)) {
         blk_match_err(SGI_Region_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == SGI_Region_Blk) {
         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_region_blk", NULL);

   return;

}  /* end_region_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_open_mp_parallel_blk(boolean  err_call)

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

   if (CURR_BLK == Open_Mp_Do_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Open_Mp_Do_Region);
   }

   if (CURR_BLK == Open_Mp_Parallel_Do_Blk) {
      /* just pop it */
      POP_BLK_STK;
      CLEAR_DIRECTIVE_STATE(Open_Mp_Parallel_Do_Region);
   }


   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(Open_MP_End_Parallel_Stmt, CURR_BLK)) {
         blk_match_err(Open_Mp_Parallel_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Open_Mp_Parallel_Blk) {
         /* point to the PARALLEL directive */
         IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx;
         IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX;

         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_open_mp_parallel_blk", NULL);

   return;

}  /* end_open_mp_parallel_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_open_mp_do_blk(boolean  err_call)

{
   int		sh_idx;


   TRACE (Func_Entry, "end_open_mp_do_blk", NULL);

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(Open_MP_End_Do_Stmt, CURR_BLK)) {
         blk_match_err(Open_Mp_Do_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Open_Mp_Do_Blk) {
         /* remove the enddo statement that was generated at the */
         /* end of the Do Blk. This one supersedes it. */

         if (BLK_ENDPDO_SH_IDX(blk_stk_idx) != NULL_IDX) {
            sh_idx = BLK_ENDPDO_SH_IDX(blk_stk_idx);
            SH_PREV_IDX(SH_NEXT_IDX(sh_idx)) = SH_PREV_IDX(sh_idx);
            SH_NEXT_IDX(SH_PREV_IDX(sh_idx)) = SH_NEXT_IDX(sh_idx);

            FREE_IR_NODE(SH_IR_IDX(sh_idx));
            FREE_SH_NODE(sh_idx);
         }

         IR_LINE_NUM_R(SH_IR_IDX(curr_stmt_sh_idx)) = stmt_start_line;
         IR_COL_NUM_R(SH_IR_IDX(curr_stmt_sh_idx))  = stmt_start_col;
         IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx;
         IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX;

         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_open_mp_do_blk", NULL);

   return;

}  /* end_open_mp_do_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_open_mp_parallel_sections_blk(boolean  err_call)

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

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(Open_MP_End_Parallel_Sections_Stmt, CURR_BLK)) {
         blk_match_err(Open_Mp_Parallel_Sections_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Open_Mp_Parallel_Sections_Blk) {
         /* point to the PARALLEL SECTIONS directive */
         IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx;
         IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX;

         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_open_mp_parallel_sections_blk", NULL);

   return;

}  /* end_open_mp_parallel_sections_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_open_mp_sections_blk(boolean  err_call)

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

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(Open_MP_End_Sections_Stmt, CURR_BLK)) {
         blk_match_err(Open_Mp_Sections_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Open_Mp_Sections_Blk) {
         /* point to the SECTIONS directive */
         IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx;
         IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX;

         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_open_mp_sections_blk", NULL);

   return;

}  /* end_open_mp_sections_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_open_mp_section_blk(boolean  err_call)

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

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(Open_MP_End_Section_Stmt, CURR_BLK)) {
         blk_match_err(Open_Mp_Section_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Open_Mp_Section_Blk) {
         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_open_mp_section_blk", NULL);

   return;

}  /* end_open_mp_section_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_open_mp_single_blk(boolean  err_call)

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

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(Open_MP_End_Single_Stmt, CURR_BLK)) {
         blk_match_err(Open_Mp_Single_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Open_Mp_Single_Blk) {
         /* point to the SINGLE directive */
         IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx;
         IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX;

         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_open_mp_single_blk", NULL);

   return;

}  /* end_open_mp_single_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_open_mp_parallel_do_blk(boolean  err_call)

{
   int		sh_idx;


   TRACE (Func_Entry, "end_open_mp_parallel_do_blk", NULL);

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(Open_MP_End_Parallel_Do_Stmt, CURR_BLK)) {
         blk_match_err(Open_Mp_Parallel_Do_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Open_Mp_Parallel_Do_Blk) {
         /* remove the enddo statement that was generated at the */
         /* end of the Do Blk. This one supersedes it. */

         if (BLK_ENDPDO_SH_IDX(blk_stk_idx) != NULL_IDX) {
            sh_idx = BLK_ENDPDO_SH_IDX(blk_stk_idx);
            SH_PREV_IDX(SH_NEXT_IDX(sh_idx)) = SH_PREV_IDX(sh_idx);
            SH_NEXT_IDX(SH_PREV_IDX(sh_idx)) = SH_NEXT_IDX(sh_idx);

            FREE_IR_NODE(SH_IR_IDX(sh_idx));
            FREE_SH_NODE(sh_idx);
         }

         IR_LINE_NUM_R(SH_IR_IDX(curr_stmt_sh_idx)) = stmt_start_line;
         IR_COL_NUM_R(SH_IR_IDX(curr_stmt_sh_idx))  = stmt_start_col;
         IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx;
         IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX;

         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_open_mp_parallel_do_blk", NULL);

   return;
}

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_open_mp_master_blk(boolean  err_call)

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

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(Open_MP_End_Master_Stmt, CURR_BLK)) {
         blk_match_err(Open_Mp_Master_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Open_Mp_Master_Blk) {
         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_open_mp_master_blk", NULL);

   return;

}  /* end_open_mp_master_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_open_mp_critical_blk(boolean  err_call)

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

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(Open_MP_End_Critical_Stmt, CURR_BLK)) {
         blk_match_err(Open_Mp_Critical_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Open_Mp_Critical_Blk) {
         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_open_mp_critical_blk", NULL);

   return;

}  /* end_open_mp_critical_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_open_mp_ordered_blk(boolean  err_call)

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

   if (! err_call) {

      if (STMT_CANT_BE_IN_BLK(Open_MP_End_Ordered_Stmt, CURR_BLK)) {
         blk_match_err(Open_Mp_Ordered_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Open_Mp_Ordered_Blk) {
         POP_BLK_STK;
      }
   }
   else {
      POP_BLK_STK;
   }

   TRACE (Func_Exit, "end_open_mp_ordered_blk", NULL);

   return;

}  /* end_open_mp_ordered_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_open_mp_parallel_workshare_blk(boolean  err_call)

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

   if (! err_call) {
      if (STMT_CANT_BE_IN_BLK(Open_MP_End_Parallel_Workshare_Stmt, CURR_BLK)) {
	 blk_match_err(Open_Mp_Parallel_Workshare_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Open_Mp_Parallel_Workshare_Blk) {
	 IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx;
	 IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX;

	 POP_BLK_STK;
      }
   }
   else{
      POP_BLK_STK;
   }

   TRACE(Func_Exit, "end_open_mp_parallel_workshare_blk", NULL);

   return;
} /* end_open_mp_parallel_workshare_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void end_open_mp_workshare_blk(boolean  err_call)

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

   if (! err_call) {
      if (STMT_CANT_BE_IN_BLK(Open_MP_End_Workshare_Stmt, CURR_BLK)) {
	 blk_match_err(Open_Mp_Workshare_Blk, FALSE, FALSE);
      }

      if (CURR_BLK == Open_Mp_Workshare_Blk) {
	 IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx;
	 IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX;

	 POP_BLK_STK;
      }
   }
   else{
      POP_BLK_STK;
   }

   TRACE(Func_Exit, "end_open_mp_workshare_blk", NULL);

   return;
} /* end_open_mp_workshare_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Look for Do_Parallel_Blk's on the block stack. If we are outside the  *|
|*      associated Do_Blk, remove the Do_Parallel_Blk. If we are inside the   *|
|*      associated Do_Blk, and cannot_nest is true, issue an error.           *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

boolean remove_do_parallel_blk(boolean  cannot_nest,
                               char     *str,
                               int      line,
                               int      col)


{
   int          blk_idx;
   boolean	err = FALSE;

   TRACE (Func_Entry, "remove_do_parallel_blk", NULL);

   blk_idx = blk_stk_idx;

   while (BLK_TYPE(blk_idx) > Module_Proc_Blk) {

      if (BLK_TYPE(blk_idx) == Do_Parallel_Blk) {
         if (blk_idx < blk_stk_idx &&
             BLK_TYPE(blk_idx + 1) == Do_Blk &&
             BLK_DEF_LINE(blk_idx) == BLK_DEF_LINE(blk_idx + 1)) {

            /* inside the do block for the do parallel */
            if (cannot_nest) {
               PRINTMSG(line, 1289, Error, col, str);
               err = TRUE;
            }
            else {
               /* intentionally blank, just leave as is */
            }
         }
         else {
            /* outside the do block for the do parallel */
            /* just remove the do parallal blk          */

            move_blk_to_end(blk_idx);
            CLEAR_DIRECTIVE_STATE(Do_Parallel_Region);
            POP_BLK_STK;
         }
      }

      blk_idx--;
   }

   TRACE (Func_Exit, "remove_do_parallel_blk", NULL);

   return(err);

}  /* remove_do_parallel_blk */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Look for SGI_Pdo_Blk's on the block stack. If we are outside the      *|
|*      associated Do_Blk, remove the SGI_Pdo_Blk. If we are inside the       *|
|*      associated Do_Blk, and cannot_nest is true, issue an error.           *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

boolean remove_pdo_blk(boolean  cannot_nest,
                       char     *str,
                       int      line,
                       int      col)


{
   int          blk_idx;
   boolean      err = FALSE;

   TRACE (Func_Entry, "remove_pdo_blk", NULL);

   blk_idx = blk_stk_idx;

   while (BLK_TYPE(blk_idx) > Module_Proc_Blk) {

      if (BLK_TYPE(blk_idx) == SGI_Pdo_Blk) {
         if (blk_idx < blk_stk_idx &&
             BLK_TYPE(blk_idx + 1) == Do_Blk &&
             BLK_DEF_LINE(blk_idx) == BLK_DEF_LINE(blk_idx + 1)) {

            /* inside the do block for the pdo */
            if (cannot_nest) {
               /* need new message BHJ */
               PRINTMSG(line, 1289, Error, col, str);
               err = TRUE;
            }
            else {
               /* intentionally blank, just leave as is */
            }
         }
         else {
            /* outside the do block for the pdo */
            /* just remove the pdo blk          */

            move_blk_to_end(blk_idx);
            CLEAR_DIRECTIVE_STATE(Pdo_Region);
            POP_BLK_STK;
         }
      }

      blk_idx--;
   }

   TRACE (Func_Exit, "remove_pdo_blk", NULL);

   return(err);

}  /* remove_pdo_blk */


# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Check to see if the current iterative DO ending statement immediately *|
|*      follows a preceding iterative DO ending statement.  That is, check to *|
|*      see if the bottom of the current loop is perfectly nested within its  *|
|*      containing iterative DO loop.                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      TRUE if the current DO ending statement immediately follows a         *|
|*      preceding iterative DO ending statement.                              *|
|*                                                                            *|
\******************************************************************************/

static void check_loop_bottom_nesting(void)

{
   int		blk_idx;
   boolean	perfectly_nested	= FALSE;
   int		sh_idx;
   char		str[80];


   TRACE (Func_Entry, "check_loop_bottom_nesting", NULL);

   /* Look back through the SH's to find the loop ending IR for the next      */
   /* inner loop.  The following SH types can occur between the current loop  */
   /* ending IR and the inner loop ending IR:				      */
   /*									      */
   /* * Anything that is compiler-generated (we're looking for the compiler-  */
   /*   generated Loop_End IR).						      */
   /*									      */
   /* * END DO statements.  A nest of loops that end with END DO's looks like:*/
   /*      SH:  End_Do_Stmt						      */
   /*      SH:  CG Continue (Loop_End)					      */
   /*      SH:  End_Do_Stmt						      */
   /*      SH:  CG Continue (Loop_End)					      */
   /*   So, if we're at the second Loop_End, it's OK to pass through the      */
   /*   End_Do above it to get to the next Loop_End.			      */
   /*									      */
   /* * The IR that represents a labeled stmt that terminates the loop.  An   */
   /*   example:							      */
   /*									      */
   /*       C*$*  INTERCHANGE(m, i, n)					      */
   /*									      */
   /*             DO 30, i = 1, 3					      */
   /*               DO 30, m = 1, 3					      */
   /*                 DO n = 1, 3					      */
   /*                   PRINT *, 'In innermost loop', n			      */
   /*                 END DO						      */
   /*       30    array2(i,m) = m + i					      */
   /*									      */
   /*   produces the IR:						      */
   /*      SH:  End_Do							      */
   /*      SH:  CG CONTINUE  (Loop_End)					      */
   /*      SH:  Label_Def    (30)					      */
   /*      SH:  Assignment						      */
   /*      SH:  CG CONTINUE  (Loop_End)					      */
   /*      SH:  CG CONTINUE  (Loop_End)					      */
   /*									      */
   /*   So when the middle Loop_End is the current loop being ended, we need  */
   /*   to be able to pass through the labeled stmt to make sure the inner    */
   /*   loop is perfectly nested in the middle loop.  We can tell this        */
   /*   labeled stmt is OK because if stmt_label_idx is not null, it means    */
   /*   the labeled stmt is still being worked on which means the labeled     */
   /*   stmt is the loop ending stmt.					      */

   sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);

   while (SH_COMPILER_GEN(sh_idx)              ||
          SH_STMT_TYPE(sh_idx) == End_Do_Stmt  ||
          (stmt_label_idx != NULL_IDX  &&
           (SH_LABELED(sh_idx)  ||  SH_STMT_TYPE(sh_idx) == Label_Def))) { 

      if (SH_LOOP_END(sh_idx)) {
         perfectly_nested = TRUE;
         break;
      }
      else {
         sh_idx = SH_PREV_IDX(sh_idx);
      }
   }

   if (! perfectly_nested) {

      if (SH_LOOP_END(sh_idx)) {
         perfectly_nested = TRUE;
      }
   }

  
   /* The loop inside the current loop is not perfectly nested.  Find the     */
   /* statement that interrupted the nesting and issue an error message.      */
   /* The search starts with the Loop_End IR.  The previous SH could be for   */
   /* an END DO (the actual end of the current loop) so pass through it (and  */
   /* its label if it has one) to get to the offending statement.	      */
   /* Use "DO" as the default insert in the message.  Fill in the correct     */
   /* insert as the type of directive is determined.			      */

   if (! perfectly_nested) {

      if (BLK_HAS_NESTED_LOOP(blk_stk_idx)) {
         sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);

         while (SH_COMPILER_GEN(sh_idx)              ||
                SH_STMT_TYPE(sh_idx) == End_Do_Stmt  ||
                SH_STMT_TYPE(sh_idx) == Label_Def) {
            sh_idx = SH_PREV_IDX(sh_idx);
         }

      }
      
      strcpy(str, "DO");

      for (blk_idx = blk_stk_idx;  blk_idx > 1;  --blk_idx) {

         if (BLK_TYPE(blk_idx) == Do_Blk) {

            if (BLK_DIR_NEST_CHECK_SH_IDX(blk_idx) != NULL_IDX) {

               switch (IR_OPR(SH_IR_IDX(BLK_DIR_NEST_CHECK_SH_IDX(blk_idx)))) {

                  case Pdo_Par_Opr:
                     strcpy(str, "PDO");
                     break;

                  case Parallel_Do_Par_Opr:
                     strcpy(str, "PARALLEL DO");
                     break;

                  case Doacross_Dollar_Opr:
                     strcpy(str, "DOACROSS");
                     break;

                  default:
                     strcpy(str, "DO");
                     break;
               }

               break;
            }
            else if (BLK_INTERCHANGE_DIR_SH_IDX(blk_idx) != NULL_IDX) {
               strcpy(str,"INTERCHANGE");
               break;
            }
         }
      }

      PRINTMSG(SH_GLB_LINE(sh_idx), 1380, Error, SH_COL_NUM(sh_idx),
               str); 

      for (blk_idx = blk_stk_idx;  blk_idx > 1;  --blk_idx) {
      
         if (BLK_TYPE(blk_idx) == Do_Blk) {
            BLK_INTERCHANGE_NUM_LCVS(blk_idx)    = 0;
            BLK_DIR_NEST_CHECK_NUM_LCVS(blk_idx) = 0;
            BLK_HAS_NESTED_LOOP(blk_idx)         = FALSE;

            if (BLK_DIR_NEST_CHECK_SH_IDX(blk_idx) != NULL_IDX) {
               SH_ERR_FLG(BLK_DIR_NEST_CHECK_SH_IDX(blk_idx)) = TRUE;
               BLK_DIR_NEST_CHECK_SH_IDX(blk_idx)             = NULL_IDX;
            }

            if (BLK_INTERCHANGE_DIR_SH_IDX(blk_idx) != NULL_IDX) {
               SH_ERR_FLG(BLK_INTERCHANGE_DIR_SH_IDX(blk_idx)) = TRUE;
               BLK_INTERCHANGE_DIR_SH_IDX(blk_idx)             = NULL_IDX;
               break;
            }
         }
      }
   }

   TRACE (Func_Exit, "loop_bottom_is_perfectly_nested", NULL);

   return;

}  /* check_loop_bottom_nesting */

# endif

# if defined(_EXPRESSION_EVAL)

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Simulate an END statement.                                            *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

void expression_eval_end (void)
{

   TRACE (Func_Entry, "expression_eval_end", NULL);

   end_of_contains			= FALSE;
   stmt_type				= End_Program_Stmt;
   SH_STMT_TYPE(curr_stmt_sh_idx)	= End_Program_Stmt;

   if (stmt_label_idx != NULL_IDX) {
      end_labeled_do();
   }

   /* Issue any deferred src_input messages.                         */

   issue_deferred_msgs();

   if (CURR_BLK != Program_Blk) {
      SCP_IN_ERR(curr_scp_idx)	= TRUE;
   }

   end_program_unit(FALSE);

   /* Save the line and column of the EOS (which tells us where the END stmt  */
   /* really ends).                                                           */

   cif_end_unit_line   = LA_CH_LINE;
   cif_end_unit_column = LA_CH_COLUMN - 1;

   TRACE (Func_Exit, "expression_eval_end", NULL);

   return;

}  /* expression_eval_end */

# endif
