/*
 * Copyright (C) 2008. PathScale, LLC. All Rights Reserved.
 */
/*
 *  Copyright (C) 2006. 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_dcl_pu.c	5.5	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"
# ifdef KEY
# include "i_cvrt.h"
# endif


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

static	void	gen_end_prologue_debug_label (int);
static	void	parse_dummy_args (int);
static	void	parse_prefix_spec (void);
static	void	set_function_rslt (int, boolean);
static	void	start_new_scp (void);
static	int	start_new_subpgm (pgm_unit_type, boolean, boolean);


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*      BNF     - BLOCK DATA [block-data-name]                                *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

void parse_block_stmt (void)
{
		int		defer_msg	= 0;
   static 	char		num_unnamed	= 'A';
   		boolean		parse_error;
		boolean		unnamed_blk	= FALSE;


   TRACE (Func_Entry, "parse_block_stmt", NULL);

   if (matched_specific_token(Tok_Kwd_Data, Tok_Class_Keyword)) {
      parse_error = FALSE;

      if (LA_CH_VALUE == EOS) { /* create BLCKDAT# where # = A, B, C, .. Z.   */
         unnamed_blk		= TRUE;
	 TOKEN_STR(token)[0]	= 'B';
	 TOKEN_STR(token)[1]	= 'L';
	 TOKEN_STR(token)[2]	= 'K';
# if defined(_NO_AT_SIGN_IN_NAMES)
	 TOKEN_STR(token)[3]	= '.';
# else
	 TOKEN_STR(token)[3]	= '@';
# endif
	 TOKEN_STR(token)[4]	= 'D';
	 TOKEN_STR(token)[5]	= 'A';
	 TOKEN_STR(token)[6]	= 'T';
         TOKEN_STR(token)[7]	= num_unnamed;
         TOKEN_LEN(token)	= 8;
         TOKEN_VALUE(token)	= Tok_Id;
	 TOKEN_LINE(token)	= stmt_start_line;
	 TOKEN_COLUMN(token)	= stmt_start_col;

         if (num_unnamed > 'Z') {

            /* > 26 unnamed BLOCK DATA pgm units.  Fix the name, so junk */
            /* does not print in the error message header.               */

            TOKEN_STR(token)[7]	= 'a';
         }
      }
      else if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
         parse_err_flush(Find_EOS, "block-data-name");
         parse_error		= TRUE;
         token			= main_token;
         TOKEN_LINE(token)	= stmt_start_line;		  
         TOKEN_COLUMN(token)	= stmt_start_col;		 
      } 
   }
   else {
      parse_err_flush(Find_EOS, "DATA");
      parse_error		= TRUE;
      token			= main_token;
      TOKEN_LINE(token)		= stmt_start_line;		  
      TOKEN_COLUMN(token)	= stmt_start_col;		 
   }

   start_new_prog_unit(Blockdata, 
                       Blockdata_Blk,
                       FALSE,
                       parse_error,
                      &defer_msg);
   CURR_BLK_NO_EXEC	= TRUE;

   if (unnamed_blk) {
      CURR_BLK_NAME	= NULL_IDX;	/* Clear for unnamed blockdata */

      if (num_unnamed > 'Z') {	/* > 26 unnamed BLOCK DATA pgm units */
         PRINTMSG(stmt_start_line, 29, Error, stmt_start_col);
      } 
      else if (num_unnamed > 'A') {	/* > 1 unnamed BLOCK DATA is non-ansi */
         PRINTMSG(stmt_start_line, 30, Ansi, stmt_start_col);
      }
      num_unnamed++;
   }

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

   NEXT_LA_CH;		/* Consume EOS */

   TRACE (Func_Exit, "parse_block_stmt", NULL);

   return;

}  /* parse_block_stmt */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*      BNF     - ENTRY entry-name [([dummy-arg-list])[RESULT (result-name)]] *|
|*              - dummy-arg     =>      dummy-arg-name or *		      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/
void parse_entry_stmt (void)

{
   int			attr_idx		= NULL_IDX;
   boolean		blk_err			= FALSE;
   int			branch_around_lbl_idx;
   int			host_attr_idx;
   int			host_name_idx;
   int			ir_idx;
   boolean		issue_msg;
   int			length;
   int			list_idx;
   int			name_idx;
   pgm_unit_type	pgm_unit;
   atp_proc_type	proc_type;
   int			save_scp_idx;
   obj_type		sem_type;


   TRACE (Func_Entry, "parse_entry_stmt", NULL);

   if (STMT_CANT_BE_IN_BLK(Entry_Stmt, CURR_BLK) && iss_blk_stk_err()) {

      /* Issued blk error - err issued by rtn */

      blk_err = TRUE;

   }
   else if (curr_stmt_category < Implicit_None_Stmt_Cat) {

      /* The ENTRY statement must follow all USE statements, so set curr_stmt */
      /* _category so that anymore USE statements will be out of context.     */

      curr_stmt_category = Implicit_None_Stmt_Cat;
   }

   if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
      attr_idx = srch_sym_tbl(TOKEN_STR(token),
                              TOKEN_LEN(token),
                              &name_idx);

      pgm_unit	= (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Function) ?
                   Function : Subroutine;

      proc_type	= (atp_proc_type) ATP_PROC(SCP_ATTR_IDX(curr_scp_idx));

      /* This must be an external or a module procedure */

      if (ATP_PROC(SCP_ATTR_IDX(curr_scp_idx)) == Module_Proc) {
         host_attr_idx = srch_host_sym_tbl(TOKEN_STR(token), 
                                           TOKEN_LEN(token),
                                           &host_name_idx,
                                           FALSE);  /* Don't search intrinsic */

         if (host_attr_idx == NULL_IDX) {

            if (attr_idx == NULL_IDX) {
               save_scp_idx	= curr_scp_idx;
               curr_scp_idx	= SCP_PARENT_IDX(curr_scp_idx);
               host_attr_idx	= ntr_sym_tbl(&token, host_name_idx);
               curr_scp_idx	= save_scp_idx;
               attr_idx		= srch_sym_tbl(TOKEN_STR(token),
                                               TOKEN_LEN(token),
                                               &name_idx);

               /* Enter in local scope - but share attrs */

               attr_idx		= ntr_host_in_sym_tbl(&token,
                                                      name_idx,
                                                      host_attr_idx,
                                                      host_name_idx,
                                                      FALSE);

               LN_DEF_LOC(name_idx)		= TRUE;
               LN_DEF_LOC(host_name_idx)	= TRUE;
               AT_OBJ_CLASS(attr_idx)		= Pgm_Unit;
               ATP_PGM_UNIT(attr_idx)		= pgm_unit;
               ATP_PROC(attr_idx)		= proc_type;
            }
            else { /* Have local attr.  Use it for the host as well. */

               sem_type = (pgm_unit == Function) ? Obj_Entry_Func :
                                                   Obj_Entry_Subr;

               if (fnd_semantic_err(sem_type,
                                    TOKEN_LINE(token),
                                    TOKEN_COLUMN(token),
                                    attr_idx,
                                    TRUE)) {
                  CREATE_ERR_ATTR(attr_idx,
                                  TOKEN_LINE(token),
                                  TOKEN_COLUMN(token),
	            		  Pgm_Unit);

                  ATP_PGM_UNIT(attr_idx)	= pgm_unit;
                  ATP_PROC(attr_idx)		= proc_type;
               }
               else {
                  LN_DEF_LOC(name_idx)		= TRUE;
               }

               save_scp_idx			= curr_scp_idx;
               curr_scp_idx			= SCP_PARENT_IDX(curr_scp_idx);
               host_attr_idx			= ntr_sym_tbl(&token,
                                                              host_name_idx);
               curr_scp_idx			= save_scp_idx;
               attr_tbl_idx--;
               attr_aux_tbl_idx--;
               LN_ATTR_IDX(host_name_idx)	= attr_idx;
               LN_NAME_IDX(host_name_idx)	= AT_NAME_IDX(attr_idx);
               LN_DEF_LOC(host_name_idx)	= TRUE;

               if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
                  chg_data_obj_to_pgm_unit(attr_idx,
                                           pgm_unit,
                                           proc_type);
               }
               else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {
                  ATP_PGM_UNIT(attr_idx)	= pgm_unit;
                  ATP_PROC(attr_idx)		= proc_type;
               }
            }
         }
         else {
            issue_msg	= TRUE;

            if (attr_idx != NULL_IDX) { 
               sem_type = (pgm_unit == Function) ? Obj_Entry_Func :
                                                   Obj_Entry_Subr;

               if (fnd_semantic_err(sem_type,
                                    TOKEN_LINE(token),
                                    TOKEN_COLUMN(token),
                                    attr_idx,
                                    TRUE)) {

                  CREATE_ERR_ATTR(attr_idx,
                                  TOKEN_LINE(token),
                                  TOKEN_COLUMN(token),
                                  Pgm_Unit);

                  ATP_PGM_UNIT(attr_idx)	= pgm_unit;
                  ATP_PROC(attr_idx)		= proc_type;
                  issue_msg			= FALSE;
               }
               else {
                  LN_DEF_LOC(name_idx)	= TRUE;
               }
            }

            sem_type = (pgm_unit == Function) ? Obj_Module_Func :
                                                Obj_Module_Subr;

            if (AT_OBJ_CLASS(host_attr_idx) == Interface &&
                ATI_PROC_IDX(host_attr_idx) != NULL_IDX) {
                host_attr_idx = ATI_PROC_IDX(host_attr_idx);
            }
            
            if (fnd_semantic_err(sem_type,
                                 TOKEN_LINE(token),
                                 TOKEN_COLUMN(token),
                                 host_attr_idx,
                                 issue_msg)) {
               CREATE_ERR_ATTR(host_attr_idx,
                               TOKEN_LINE(token),
                               TOKEN_COLUMN(token),
      			       Pgm_Unit);
               ATP_PGM_UNIT(host_attr_idx)	= pgm_unit;
               ATP_PROC(host_attr_idx)		= proc_type;

            }
            else if (AT_OBJ_CLASS(host_attr_idx) == Data_Obj) {
               chg_data_obj_to_pgm_unit(host_attr_idx,
                                        pgm_unit,
                                        proc_type);
            }
            else if (ATP_PROC(host_attr_idx) == Module_Proc &&
                     ATP_EXPL_ITRFC(host_attr_idx)) {

               /* This is already declared as a module procedure. */

               PRINTMSG(TOKEN_LINE(token), 1529, Error,
                        TOKEN_COLUMN(token),
                        AT_OBJ_NAME_PTR(host_attr_idx));
            }
            else {
               ATP_PGM_UNIT(host_attr_idx)	= pgm_unit;
               ATP_PROC(host_attr_idx)		= proc_type;
            }

            if (attr_idx == NULL_IDX) {   /* No local attr - just a host attr */
               attr_idx	= ntr_host_in_sym_tbl(&token,
                                              name_idx,
                                              host_attr_idx,
                                              host_name_idx,
                                              FALSE);
               LN_DEF_LOC(name_idx) = TRUE;
            }
            else {

               /* Have both a local and a host attr.  The host attr can only  */
               /* be a generic interface or have PUBLIC or PRIVATE set.  The  */
               /* local attr can have all sorts of typing and dimension info  */
               /* set if this is a FUNCTION.  If this is a SUBROUTINE, it can */
               /* only have PUBLIC or PRIVATE set.  (And this cannot happen   */
               /* in a module procedure, because these can only be set in     */
               /* modules.  If function, use the local attr as the function   */
               /* result if there were no problems with the local attr.       */
               /* (issue_msg = TRUE)                                          */

               if (issue_msg && pgm_unit == Function) {
                  ATP_RSLT_IDX(host_attr_idx)	= attr_idx;
                  ATD_CLASS(attr_idx)		= Function_Result;
                  ATD_FUNC_IDX(attr_idx)	= host_attr_idx;
               }
            }
            LN_ATTR_IDX(name_idx)	= host_attr_idx;
            LN_NAME_IDX(name_idx)	= AT_NAME_IDX(host_attr_idx);
            LN_DEF_LOC(host_name_idx)	= TRUE;
            attr_idx			= host_attr_idx;
         }

         ATP_EXT_NAME_IDX(attr_idx)	= make_in_parent_string(
                                                  AT_NAME_IDX(attr_idx),
                                                  AT_NAME_LEN(attr_idx),
                                                  SCP_PARENT_IDX(curr_scp_idx),
                                                  &length);
         ATP_EXT_NAME_LEN(attr_idx)	= length;
      }
      else if (attr_idx == NULL_IDX) {
         attr_idx			= ntr_sym_tbl(&token, name_idx);
         LN_DEF_LOC(name_idx)		= TRUE;  /* Not host associable */
         AT_OBJ_CLASS(attr_idx)		= Pgm_Unit;
         ATP_PGM_UNIT(attr_idx)		= pgm_unit;
         ATP_PROC(attr_idx)		= ATP_PROC(SCP_ATTR_IDX(curr_scp_idx));
         MAKE_EXTERNAL_NAME(attr_idx,
         	            AT_NAME_IDX(attr_idx),
        	            AT_NAME_LEN(attr_idx));
      }
      else {
         sem_type = (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Function) ?
                     Obj_Entry_Func : Obj_Entry_Subr;

         if (fnd_semantic_err(sem_type,
                              TOKEN_LINE(token),
                              TOKEN_COLUMN(token),
                              attr_idx,
                              TRUE)) {
            CREATE_ERR_ATTR(attr_idx,
                            TOKEN_LINE(token),
                            TOKEN_COLUMN(token),
			    Pgm_Unit);

            ATP_PGM_UNIT(attr_idx)      = pgm_unit;
            ATP_PROC(attr_idx)	        = ATP_PROC(SCP_ATTR_IDX(curr_scp_idx));
            MAKE_EXTERNAL_NAME(attr_idx,
            	            AT_NAME_IDX(attr_idx),
           	            AT_NAME_LEN(attr_idx));
         }
         else { 
            LN_DEF_LOC(name_idx)= TRUE;

            if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
               chg_data_obj_to_pgm_unit(attr_idx,
                                        pgm_unit,
                                        (atp_proc_type) 
                                        ATP_PROC(SCP_ATTR_IDX(curr_scp_idx)));
            }
            else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {
               ATP_PGM_UNIT(attr_idx)	= pgm_unit;
               ATP_PROC(attr_idx)	= proc_type;
            }
         }
      }

      ATP_SCP_IDX(attr_idx)	= curr_scp_idx;
      ATP_ALT_ENTRY(attr_idx)	= TRUE;
      ATP_RECURSIVE(attr_idx)	= ATP_RECURSIVE(SCP_ATTR_IDX(curr_scp_idx));
      ATP_ELEMENTAL(attr_idx)	= ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx));
      ATP_PURE(attr_idx)	= ATP_PURE(SCP_ATTR_IDX(curr_scp_idx));
      ATP_SCP_ALIVE(attr_idx)	= TRUE;
      ATP_EXPL_ITRFC(attr_idx)  = TRUE;
      ATP_MAY_INLINE(attr_idx)	= ATP_MAY_INLINE(SCP_ATTR_IDX(curr_scp_idx));

      if ((cif_flags & XREF_RECS) != 0) {
         cif_usage_rec(attr_idx,
                       AT_Tbl_Idx,
                       TOKEN_LINE(token),
                       TOKEN_COLUMN(token),
                       CIF_Symbol_Declaration);
      }

      NTR_ATTR_LIST_TBL(list_idx);
      AL_ATTR_IDX(list_idx)		= attr_idx;
      AL_NEXT_IDX(list_idx)		= SCP_ENTRY_IDX(curr_scp_idx);
      SCP_ENTRY_IDX(curr_scp_idx)	= list_idx;

      if (SCP_ALT_ENTRY_CNT(curr_scp_idx) >= MAX_ALTERNATE_ENTRIES) {
         PRINTMSG(TOKEN_LINE(token), 1115, Limit,
                  TOKEN_COLUMN(token),
                  MAX_ALTERNATE_ENTRIES);
      }

      SCP_ALT_ENTRY_CNT(curr_scp_idx)	= SCP_ALT_ENTRY_CNT(curr_scp_idx) + 1;
      AT_DCL_ERR(attr_idx)	       |= blk_err;

      if (LA_CH_VALUE != EOS && LA_CH_VALUE != LPAREN) {
         parse_err_flush(Find_Lparen, "( or " EOS_STR );
      }

      if (CURR_BLK != Interface_Body_Blk &&
          (cmd_line_flags.runtime_argument ||
           cmd_line_flags.runtime_arg_entry)) {

         ATP_ARGCHCK_ENTRY(attr_idx) = TRUE;
      }

      if (LA_CH_VALUE == LPAREN) {
         parse_dummy_args(attr_idx);
      }

      if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Function) {
         set_function_rslt(attr_idx, FALSE);

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

         if (matched_specific_token (Tok_Kwd_Result, Tok_Class_Keyword)){

            /* result keyword not allowed in subroutine subprogram */

            PRINTMSG(TOKEN_LINE(token), 122, Error, TOKEN_COLUMN(token));
            parse_err_flush(Find_EOS, NULL);
         }
         else {
            parse_err_flush(Find_EOS, EOS_STR);
         }
      }

      branch_around_lbl_idx = gen_internal_lbl(TOKEN_LINE(token));

      NTR_IR_TBL(ir_idx);
      SH_IR_IDX(curr_stmt_sh_idx)       = ir_idx;
      SH_COMPILER_GEN(curr_stmt_sh_idx) = TRUE;
      SH_STMT_TYPE(curr_stmt_sh_idx)    = Goto_Stmt;
      IR_OPR(ir_idx)                    = Br_Uncond_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);
      IR_FLD_R(ir_idx)                  = AT_Tbl_Idx;
      IR_IDX_R(ir_idx)                  = branch_around_lbl_idx;
      IR_COL_NUM_R(ir_idx)              = TOKEN_COLUMN(token);
      IR_LINE_NUM_R(ir_idx)             = TOKEN_LINE(token);

      gen_sh(After, stmt_type, TOKEN_LINE(token), TOKEN_COLUMN(token),
             FALSE, FALSE, FALSE);
   
      NTR_IR_TBL(ir_idx);
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
      IR_OPR(ir_idx)              = Entry_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);
      IR_FLD_L(ir_idx)            = AT_Tbl_Idx;
      IR_IDX_L(ir_idx)            = attr_idx;
      IR_COL_NUM_L(ir_idx)        = TOKEN_COLUMN(token);
      IR_LINE_NUM_L(ir_idx)       = TOKEN_LINE(token);

      if (attr_idx != NULL_IDX) {
         ATP_FIRST_SH_IDX(attr_idx)  = curr_stmt_sh_idx;
      }
   
      gen_sh(After, Continue_Stmt, TOKEN_LINE(token), TOKEN_COLUMN(token),
             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)               = TOKEN_LINE(token);
      IR_COL_NUM(ir_idx)                = TOKEN_COLUMN(token);
      IR_FLD_L(ir_idx)                  = AT_Tbl_Idx;
      IR_IDX_L(ir_idx)                  = branch_around_lbl_idx;
      IR_COL_NUM_L(ir_idx)              = TOKEN_COLUMN(token);
      IR_LINE_NUM_L(ir_idx)             = TOKEN_LINE(token);

      if (attr_idx != NULL_IDX) {
         ATP_ENTRY_LABEL_SH_IDX(attr_idx)  = curr_stmt_sh_idx;
      }
   
      if (cmd_line_flags.debug_lvl <= Debug_Lvl_1) {  /* -ez -ed -G0 -G1 */
         gen_end_prologue_debug_label(attr_idx);
      }
   }
   else {
      parse_err_flush(Find_EOS, "entry-name");
   }

   NEXT_LA_CH;

   TRACE (Func_Exit, "parse_entry_stmt", NULL);

   return;

}  /* parse_entry_stmt */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*      BNF     - [ prefix ] FUNCTION function-name                           *|
|*                                   ( [ dummy-arg-name-list ] )              *|
|*                                   [ RESULT ( result-name ) ]               *|
|*                                                                            *|
|*      prefix  -    type-spec [ RECURSIVE ]                                  *|
|*                or RECURSIVE [ type-spec ]				      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/
void parse_function_stmt (void)

{
   int			attr_idx;
   int			defer_msg;
   boolean		err_fnd		= FALSE;
   token_type		save_token;


   TRACE (Func_Entry, "parse_function_stmt", NULL);

   if (curr_stmt_category > Sub_Func_Stmt_Cat) {
      err_fnd			= TRUE;
      iss_blk_stk_err();
   }

   if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
      parse_err_flush(Find_Lparen, "function-name");
      token			= main_token;
      TOKEN_LINE(token)		= stmt_start_line;		  
      TOKEN_COLUMN(token)	= stmt_start_col;		 
      err_fnd			= TRUE;
   }
   else if (LA_CH_VALUE != LPAREN) {
      save_token		= token;
      parse_err_flush(Find_Lparen, "(");
      err_fnd			= TRUE;
      token			= save_token;
   }

   if (curr_stmt_category == Init_Stmt_Cat) {   /* Start new compilation unit */
      defer_msg			= 0;
      attr_idx			= start_new_prog_unit(Function,
                                                      Function_Blk,
                                                      FALSE,
                                                      err_fnd,
                                                      &defer_msg);
      ATP_PROC(attr_idx)	= Extern_Proc;
   }
   else {

      /* Create a scope for this contained routine, but leave curr_scp_idx   */
      /* still pointing to parent's scope.  After the call to start_new_pgm, */
      /* curr_scp_idx will be set correctly.  TRUE means save table idxs if  */
      /* if this is an interface body, for use in collapsing later.          */

      start_new_scp();
      curr_scp_idx		= SCP_PARENT_IDX(curr_scp_idx);
      attr_idx			= start_new_subpgm(Function, err_fnd, TRUE);
   }

   /* Flag problems with the FUNCTION name */

   SCP_IN_ERR(curr_scp_idx)	= SCP_IN_ERR(curr_scp_idx) ||
                                  AT_DCL_ERR(attr_idx);

   if (CURR_BLK != Interface_Body_Blk &&
       (cmd_line_flags.runtime_argument ||
        cmd_line_flags.runtime_arg_entry)) {

      ATP_ARGCHCK_ENTRY(attr_idx) = TRUE;
   }

   if (LA_CH_VALUE == LPAREN) {
      parse_dummy_args(attr_idx);
   }

   set_function_rslt(attr_idx, FALSE);

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

   NEXT_LA_CH;

   TRACE (Func_Exit, "parse_function_stmt", NULL);

   return;

}  /* parse_function_stmt */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*      BNF     -  MODULE module-name                                         *|
|*              or MODULE PROCEDURE procedure-name-list                       *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/
void parse_module_stmt (void)

{
   int		attr_idx;
   int		defer_msg;
   boolean	found_comma;
   int		host_name_idx;
   int		interface_idx		= NULL_IDX;

# if defined(_SPLIT_STATIC_STORAGE_M)
   id_str_type	name;
   int		new_idx;
# endif

   int		name_idx;
   int		new_attr_idx;
   boolean	parse_error;
   int		sn_idx;
   int		stmt_number;
   int		tmp_attr_idx;


   TRACE (Func_Entry, "parse_module_stmt", NULL);

   stmt_number = statement_number;

   if (curr_stmt_category != Init_Stmt_Cat &&
       matched_specific_token (Tok_Kwd_Procedure, Tok_Class_Keyword)) {

      /* If it is Init_Stmt_Cat it must be the start of a MODULE.        */
      /* Send case of a module named PROCEDURE in the correct direction. */

      stmt_type				= Module_Proc_Stmt;
      SH_STMT_TYPE(curr_stmt_sh_idx)	= Module_Proc_Stmt;
     
      if (CURR_BLK == Interface_Blk) {

         if (CURR_BLK_NAME == NULL_IDX) {
            PRINTMSG(stmt_start_line, 4, Error, stmt_start_col);
         }
         else {
            curr_stmt_category	= Sub_Func_Stmt_Cat;

            if (cif_flags & MISC_RECS) {
               cif_stmt_type_rec(TRUE, CIF_Module_Procedure_Stmt, stmt_number);
            }
         }

         interface_idx = CURR_BLK_NAME;
      }
      else if (!iss_blk_stk_err()) {
         curr_stmt_category	= Sub_Func_Stmt_Cat;
      }

      do {
         if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {

            /* loc name table being entered and searched is the local name    */
            /* table for the parent.                                          */

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

            if (attr_idx == NULL_IDX) {
               attr_idx = srch_host_sym_tbl(TOKEN_STR(token), 
                                            TOKEN_LEN(token),
                                            &host_name_idx,
                                            FALSE);

               if (attr_idx == NULL_IDX) {
                  attr_idx			= ntr_sym_tbl(&token, name_idx);
                  LN_DEF_LOC(name_idx)		= TRUE;
                  AT_OBJ_CLASS(attr_idx)	= Pgm_Unit;  
                  ATP_PROC(attr_idx)		= Module_Proc;
                  ATP_SCP_IDX(attr_idx)		= curr_scp_idx;
                  MAKE_EXTERNAL_NAME(attr_idx,
            	                  AT_NAME_IDX(attr_idx),
           	                  AT_NAME_LEN(attr_idx));
               }
               else {  /* Found in host scope - but not local scope */

                  if (AT_OBJ_CLASS(attr_idx) == Interface &&
                      ATI_PROC_IDX(attr_idx) != NULL_IDX) {
                     attr_idx = ATI_PROC_IDX(attr_idx);
                  }

                  if (AT_NOT_VISIBLE(attr_idx)) {
                     PRINTMSG(TOKEN_LINE(token), 486, Error,
                              TOKEN_COLUMN(token),
                              AT_OBJ_NAME_PTR(attr_idx),
                              AT_OBJ_NAME_PTR(AT_MODULE_IDX((attr_idx))));
                     CREATE_ERR_ATTR(attr_idx,
                                     TOKEN_LINE(token),
                                     TOKEN_COLUMN(token),
                                     Pgm_Unit);
                     ATP_PROC(attr_idx)		= Module_Proc;
                     ATP_SCP_IDX(attr_idx)	= curr_scp_idx;
                     MAKE_EXTERNAL_NAME(attr_idx,
            	                     AT_NAME_IDX(attr_idx),
           	                     AT_NAME_LEN(attr_idx));
                  }
                  else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit &&
                           ATP_PROC(attr_idx) == Module_Proc) {

                     /* Enter in local sytb, but share attrs. */

                     attr_idx = ntr_host_in_sym_tbl(&token,
                                                    name_idx,
                                                    attr_idx,
                                                    host_name_idx,
                                                    FALSE);
                     LN_DEF_LOC(name_idx) = TRUE;
                  }
                  else if (AT_OBJ_CLASS(attr_idx) == Interface) {
                     NTR_ATTR_TBL(tmp_attr_idx);
                     COPY_COMMON_ATTR_INFO(attr_idx, tmp_attr_idx, Pgm_Unit);
                     ATI_PROC_IDX(attr_idx)	= tmp_attr_idx;
                     attr_idx			= tmp_attr_idx;
                     AT_USE_ASSOCIATED(attr_idx)= FALSE;
                     AT_IS_INTRIN(attr_idx)	= FALSE;
                     AT_ELEMENTAL_INTRIN(attr_idx)	= FALSE;
                     MAKE_EXTERNAL_NAME(attr_idx,
            	                     AT_NAME_IDX(attr_idx),
           	                     AT_NAME_LEN(attr_idx));
                     ATP_PROC(attr_idx)		= Module_Proc;
                     AT_DEF_LINE(attr_idx)	= TOKEN_LINE(token);
                     AT_DEF_COLUMN(attr_idx)	= TOKEN_COLUMN(token);
                  }
                  else if (fnd_semantic_err(Obj_Module_Proc,
                                            TOKEN_LINE(token),
                                            TOKEN_COLUMN(token),
                                            attr_idx,
                                            FALSE)) {

                     /* Just look for an error - don't issue it.  This one  */
                     /* needs to issue a special error, 707.                */

                     PRINTMSG(TOKEN_LINE(token), 707, Error,
                              TOKEN_COLUMN(token), 
                              AT_OBJ_NAME_PTR(attr_idx));

                     CREATE_ERR_ATTR(attr_idx,
                                     TOKEN_LINE(token),
                                     TOKEN_COLUMN(token),
                                     Pgm_Unit);

                     ATP_PROC(attr_idx)		= Module_Proc;
                     ATP_SCP_IDX(attr_idx)	= curr_scp_idx;
                     MAKE_EXTERNAL_NAME(attr_idx,
            	                        AT_NAME_IDX(attr_idx),
           	                        AT_NAME_LEN(attr_idx));
                  }
                  else {  /* Must just have PUBLIC/PRIVATE specified */
                          /* Enter in local sytb, but share attrs.   */

                     attr_idx = ntr_host_in_sym_tbl(&token, name_idx,
                                                    attr_idx, host_name_idx,
                                                    FALSE);

                     if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit) {
                        CLEAR_VARIANT_ATTR_INFO(attr_idx, Pgm_Unit);
                        MAKE_EXTERNAL_NAME(attr_idx,
            	                           AT_NAME_IDX(attr_idx),
           	                           AT_NAME_LEN(attr_idx));
                     }

                     ATP_PROC(attr_idx)		= Module_Proc;
                     LN_DEF_LOC(name_idx)	= TRUE;
                  }
               }
            }
            else { /* Found this attr in the local scope */

               if (AT_OBJ_CLASS(attr_idx) == Interface &&
                   ATI_PROC_IDX(attr_idx) == NULL_IDX ||
                   AT_IS_INTRIN(attr_idx)) {

                  /* If AT_IS_INTRIN is TRUE, we are overloading an   */
                  /* intrinsic.  Treat this as a new attr.  The       */
                  /* intrinsic will stay in the interface list, but   */
                  /* below this one, where it won't be found.         */

                  /* Make local version and connect to the interface. */

                  NTR_ATTR_TBL(tmp_attr_idx);
#ifdef KEY /* Bug 4197 */
		  /* We want the newly added specific procedure to be
		   * non-intrinsic just like the interface itself. */
                  AT_IS_INTRIN(attr_idx)	= FALSE;
                  AT_ELEMENTAL_INTRIN(attr_idx)	= FALSE;
                  COPY_COMMON_ATTR_INFO(attr_idx, tmp_attr_idx, Pgm_Unit);
#else /* KEY Bug 4197 */
                  COPY_COMMON_ATTR_INFO(attr_idx, tmp_attr_idx, Pgm_Unit);
                  AT_IS_INTRIN(attr_idx)	= FALSE;
                  AT_ELEMENTAL_INTRIN(attr_idx)	= FALSE;
#endif  /* KEY Bug 4197 */
                  ATI_PROC_IDX(attr_idx)	= tmp_attr_idx;
                  attr_idx			= tmp_attr_idx;
                  AT_USE_ASSOCIATED(attr_idx)	= FALSE;
                  MAKE_EXTERNAL_NAME(attr_idx,
                                     AT_NAME_IDX(attr_idx),
                                     AT_NAME_LEN(attr_idx));
                  ATP_PROC(attr_idx)		= Module_Proc;
                  AT_DEF_LINE(attr_idx)		= TOKEN_LINE(token);
                  AT_DEF_COLUMN(attr_idx)	= TOKEN_COLUMN(token);
               }
               else {

                  if (AT_OBJ_CLASS(attr_idx) == Interface) {
                     attr_idx = ATI_PROC_IDX(attr_idx);
                  }

                  if (AT_NOT_VISIBLE(attr_idx) ||
                      AT_OBJ_CLASS(attr_idx) != Pgm_Unit ||
                      ATP_PROC(attr_idx) != Module_Proc) {

                     if (fnd_semantic_err(Obj_Module_Proc,
                                          TOKEN_LINE(token),
                                          TOKEN_COLUMN(token),
                                          attr_idx,
                                          TRUE)) {
                        CREATE_ERR_ATTR(attr_idx,
                                        TOKEN_LINE(token),
                                        TOKEN_COLUMN(token),
                                        Pgm_Unit);
                        ATP_SCP_IDX(attr_idx) = curr_scp_idx;
                     }
                     else if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit) {
                        CLEAR_VARIANT_ATTR_INFO(attr_idx, Pgm_Unit);
                     }

                     MAKE_EXTERNAL_NAME(attr_idx,
                                        AT_NAME_IDX(attr_idx),
                                        AT_NAME_LEN(attr_idx));
                  }

                  ATP_PROC(attr_idx)		= Module_Proc;
               }
            }

            if (ATP_SCP_ALIVE(attr_idx) && !ATP_RECURSIVE(attr_idx) &&
                !on_off_flags.recursive) {
               PRINTMSG(TOKEN_LINE(token), 708, Warning, 
                        TOKEN_COLUMN(token), 
                        AT_OBJ_NAME_PTR(attr_idx));
            }

# if 0
            if ((cif_flags & XREF_RECS) != 0) {
               cif_usage_rec(attr_idx,
                             AT_Tbl_Idx,
                             TOKEN_LINE(token),
                             TOKEN_COLUMN(token),
                             CIF_Symbol_Declaration);
            }
# endif

            /* If the context is okay, interface_idx will be non NULL.  If */
            /* so enter into interface list and set ATI_INTERFACE_CLASS.   */

            if (interface_idx != NULL_IDX) {

               /* Generic or Defined interface - Check if already on list. */

               sn_idx		= ATI_FIRST_SPECIFIC_IDX(interface_idx);
               new_attr_idx	= srch_linked_sn(TOKEN_STR(token),
                                                 TOKEN_LEN(token),
                                                 &sn_idx);

               if (new_attr_idx == NULL_IDX) {
                  NTR_INTERFACE_IN_SN_TBL(sn_idx,
                                          attr_idx,
                                          interface_idx,
                                          TOKEN_LINE(token),
                                          TOKEN_COLUMN(token));

                  if (ATI_INTERFACE_CLASS(interface_idx) ==
                                               Generic_Unknown_Interface &&
                      ATP_PGM_UNIT(attr_idx) != Pgm_Unknown) {

                     ATI_INTERFACE_CLASS(interface_idx) =
                                      (ATP_PGM_UNIT(attr_idx) == Function) ?
                                           Generic_Function_Interface:
                                           Generic_Subroutine_Interface;
                  }
               }
               else if (ATP_SCP_IDX(attr_idx) == curr_scp_idx) {

                  if (AT_USE_ASSOCIATED(new_attr_idx) && 
                      AT_PRIVATE(new_attr_idx)) {

                     /* Found, but the name is private in this scope */
                     /* because it is use associated and only the    */
                     /* generic name is public.  Add - OK            */

                  }
                  else if (AT_IS_INTRIN(new_attr_idx)) {

                     /* The user is overloading intrinsics - allow */
                  }
                  else if (!AT_DCL_ERR(attr_idx)) {
                     PRINTMSG(TOKEN_LINE(token), 671, Error,
                              TOKEN_COLUMN(token),
                              AT_OBJ_NAME_PTR(attr_idx),
                              AT_OBJ_NAME_PTR(interface_idx));
                     AT_DCL_ERR(attr_idx)  = TRUE;

                     /* Add, but it is marked in error. */
                  }


                  NTR_INTERFACE_IN_SN_TBL(sn_idx,
                                          attr_idx,
                                          interface_idx,
                                          TOKEN_LINE(token),
                                          TOKEN_COLUMN(token));
               }
               else {  /* Found, but it is from a different scope. */
                  NTR_INTERFACE_IN_SN_TBL(sn_idx,
                                          attr_idx,
                                          interface_idx,
                                          TOKEN_LINE(token),
                                          TOKEN_COLUMN(token));
               }
            }

            if (LA_CH_VALUE != COMMA && LA_CH_VALUE != EOS) {
               parse_err_flush(Find_Comma, ", or " EOS_STR);
            }
	 }
	 else {
	    parse_err_flush(Find_Comma, "procedure-name");
	 }

         found_comma = (LA_CH_VALUE == COMMA);
         NEXT_LA_CH;
      }
      while (found_comma);
   }
   else {

      if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
         parse_err_flush(Find_EOS, "module-name");
         token			= main_token;
         TOKEN_LINE(token)	= stmt_start_line;		  
         TOKEN_COLUMN(token)	= stmt_start_col;		 
         parse_error		= TRUE;
      }
      else {
         parse_error		= FALSE;
      }

      if (cif_flags & MISC_RECS) {
         cif_stmt_type_rec(TRUE, CIF_Module_Stmt, stmt_number);
      }

      SB_MODULE(SCP_SB_STATIC_IDX(curr_scp_idx))	= TRUE;
      SB_BLK_TYPE(SCP_SB_STATIC_IDX(curr_scp_idx))	= Static;
      SB_RUNTIME_INIT(SCP_SB_STATIC_IDX(curr_scp_idx))	= FALSE;

# if defined(_SPLIT_STATIC_STORAGE_M)

      /* Create an entry for a separate data block for data initialized vars. */
      /* This is only done for static storage in modules.                     */

      CREATE_ID(name, sb_name[Data_Init_Blk], sb_len[Data_Init_Blk]);
      new_idx				= ntr_stor_blk_tbl(name.string,
                                                          sb_len[Data_Init_Blk],
                                                          stmt_start_line,
                                                          stmt_start_col,
                                                          Static);
      SCP_SB_STATIC_INIT_IDX(curr_scp_idx)	= new_idx;
      SB_PAD_BLK(new_idx)			= cmd_line_flags.pad;
      SB_MODULE(new_idx)			= TRUE;

      if (cmd_line_flags.pad_amount != 0) {
         SB_PAD_AMOUNT(new_idx)		= cmd_line_flags.pad_amount;
         SB_PAD_AMOUNT_SET(new_idx)	= TRUE;
      }

# elif defined(_SPLIT_STATIC_STORAGE_2)

      /* Leave data initialized separate from uninitialized. */

      SB_MODULE(SCP_SB_STATIC_INIT_IDX(curr_scp_idx)) = TRUE;

# elif defined(_SPLIT_STATIC_STORAGE_3)

      /* The only way something could have been assigned to             */
      /* SCP_SB_STATIC_INIT_IDX is in an error situation, so we're safe */
      /* to make SCP_SB_STATIC_INIT_IDX point to SCP_SB_STATIC_IDX.  We */
      /* want to do this because it's only local static data that needs */
      /* to go in separate storage blocks, not module data.             */

      SCP_SB_STATIC_INIT_IDX(curr_scp_idx)   = SCP_SB_STATIC_IDX(curr_scp_idx);
      SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx) = SCP_SB_STATIC_IDX(curr_scp_idx);
# else

      /* The only way something could have been assigned to             */
      /* SCP_SB_STATIC_INIT_IDX is in an error situation, so we're safe */
      /* to make SCP_SB_STATIC_INIT_IDX point to SCP_SB_STATIC_IDX.  We */
      /* want to do this because it's only local static data that needs */
      /* to go in separate storage blocks, not module data.             */

      SCP_SB_STATIC_INIT_IDX(curr_scp_idx) = SCP_SB_STATIC_IDX(curr_scp_idx);
# endif

      defer_msg	= 0;
      attr_idx	= start_new_prog_unit(Module, 
                                      Module_Blk,
                                      FALSE,
                                      parse_error,
                                      &defer_msg);

      name_idx				= check_global_pgm_unit(attr_idx);
      ATP_MODULE_STR_IDX(attr_idx)	= GN_NAME_IDX(name_idx);

      CURR_BLK_NO_EXEC			= TRUE;

# if defined(_MODULE_TO_DOT_o)

      if (!cmd_line_flags.binary_output) {
         PRINTMSG(TOKEN_LINE(token), 301, Warning, TOKEN_COLUMN(token),
                  AT_OBJ_NAME_PTR(attr_idx));
      }
# endif

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

      NEXT_LA_CH;
   }

   TRACE (Func_Exit, "parse_module_stmt", NULL);

   return;

}  /* parse_module_stmt */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This function handles the following syntax:                           *|
|*	   program-stmt 	=> PROGRAM program-name [(string of chars)]   *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/
void parse_program_stmt (void)

{
   int		defer_msg	= 0;
   boolean	err_fnd;


   TRACE (Func_Entry, "parse_program_stmt", NULL);

   if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
      parse_err_flush(Find_EOS, "program-name");
      token			= main_token;
      TOKEN_LINE(token)		= stmt_start_line;		  
      TOKEN_COLUMN(token)	= stmt_start_col;		 
      err_fnd			= TRUE;
   }
   else {
      err_fnd			= FALSE;
   }

   start_new_prog_unit(Program,
                       Program_Blk,
                       FALSE,
                       err_fnd,
                      &defer_msg);

   if (LA_CH_VALUE == LPAREN) {

      if (MATCHED_TOKEN_CLASS(Tok_Class_Program_Str)) {

         /* Arguments to a PROGRAM statement are nonstandard. */
         /* The get routine does NOT fill in the TOKEN WORD.  */
         /* Only TOKEN_LINE and TOKEN_COLUMN get set.         */

         PRINTMSG(TOKEN_LINE(token), 31, Ansi, TOKEN_COLUMN(token));
      }
      else {	/* get_token has issued a parse error - Just flush */
         parse_err_flush(Find_EOS, NULL);
      }
   }

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

   NEXT_LA_CH;

   TRACE (Func_Exit, "parse_program_stmt", NULL);

   return;

}  /* parse_program_stmt */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*      BNF     ELEMENTAL [ type-spec ]					      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

void parse_elemental_stmt (void)
{
   TRACE (Func_Entry, "parse_elemental_stmt", NULL);

   CLEAR_ATTR_NTRY(AT_WORK_IDX);
   AT_OBJ_CLASS(AT_WORK_IDX)	= Pgm_Unit;
   ATP_ELEMENTAL(AT_WORK_IDX)	= TRUE;
   parse_prefix_spec();

   TRACE (Func_Exit, "parse_elemental_stmt", NULL);

   return;

}  /* parse_elemental_stmt */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*      BNF     PURE [ type-spec ]					      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

void parse_pure_stmt (void)

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

   CLEAR_ATTR_NTRY(AT_WORK_IDX);
   AT_OBJ_CLASS(AT_WORK_IDX)	= Pgm_Unit;
   ATP_PURE(AT_WORK_IDX)	= TRUE;
   parse_prefix_spec();

   TRACE (Func_Exit, "parse_pure_stmt", NULL);

   return;

}  /* parse_pure_stmt */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*      BNF     RECURSIVE [ type-spec ]					      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

void parse_recursive_stmt (void)
{
   TRACE (Func_Entry, "parse_recursive_stmt", NULL);

   CLEAR_ATTR_NTRY(AT_WORK_IDX);
   AT_OBJ_CLASS(AT_WORK_IDX)	= Pgm_Unit;
   ATP_RECURSIVE(AT_WORK_IDX)	= TRUE;
   parse_prefix_spec();

   TRACE (Func_Exit, "parse_recursive_stmt", NULL);

   return;

}  /* parse_recursive_stmt */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*      BNF     PURE [ type-spec ]					      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static	void	parse_prefix_spec (void)

{
   int			attr_idx;
   blk_cntxt_type	blk_type;
   int			defer_msg;
   boolean		elemental_set;
   boolean		matched;
   pgm_unit_type	pgm_type;
   boolean		pure_set;
   boolean		recursive_set;


   TRACE (Func_Entry, "parse_prefix_spec", NULL);

   while (matched = MATCHED_TOKEN_CLASS(Tok_Class_Keyword)) {

      switch (TOKEN_VALUE(token)) {
      case Tok_Kwd_Recursive:

         if (ATP_ELEMENTAL(AT_WORK_IDX)) {

            /* RECURSIVE and ELEMENTAL should not be set for same subprogram */

            PRINTMSG(TOKEN_LINE(token), 1261, Error, TOKEN_COLUMN(token));
            AT_DCL_ERR(AT_WORK_IDX)	= TRUE;
         }
         else if (ATP_RECURSIVE(AT_WORK_IDX)) {  /* Duplicate declaration */
            PRINTMSG(TOKEN_LINE(token), 1260, Error, TOKEN_COLUMN(token),
                     "RECURSIVE");
            AT_DCL_ERR(AT_WORK_IDX)	= TRUE;
         }
         else {
            ATP_RECURSIVE(AT_WORK_IDX)	= TRUE;
         }
         continue;

      case Tok_Kwd_Elemental:

         if (ATP_RECURSIVE(AT_WORK_IDX)) {

            /* RECURSIVE and ELEMENTAL should not be set for same subprogram */

            PRINTMSG(TOKEN_LINE(token), 1261, Error, TOKEN_COLUMN(token));
            AT_DCL_ERR(AT_WORK_IDX)	= TRUE;
         }
         else if (ATP_ELEMENTAL(AT_WORK_IDX)) {  /* Duplicate declaration */
            PRINTMSG(TOKEN_LINE(token), 1260, Error, TOKEN_COLUMN(token),
                     "ELEMENTAL");
            AT_DCL_ERR(AT_WORK_IDX)	= TRUE;
         }
         else {
            ATP_ELEMENTAL(AT_WORK_IDX)	= TRUE;
         }
         continue;

      case Tok_Kwd_Pure:

         if (ATP_PURE(AT_WORK_IDX)) {  /* Duplicate declaration */
            PRINTMSG(TOKEN_LINE(token), 1260, Error, TOKEN_COLUMN(token),
                     "PURE");
            AT_DCL_ERR(AT_WORK_IDX)	= TRUE;
         }
         ATP_PURE(AT_WORK_IDX)	= TRUE;
         continue;

      case Tok_Kwd_Logical:
      case Tok_Kwd_Integer:
      case Tok_Kwd_Double:
      case Tok_Kwd_Real:
      case Tok_Kwd_Complex:
      case Tok_Kwd_Character:
      case Tok_Kwd_Type:
            parse_typed_function_stmt();  /* Pure, ele ect are in AT_WORK_IDX */
            goto EXIT;

         default:
            break;
      }
      break;
   }

   recursive_set	= ATP_RECURSIVE(AT_WORK_IDX);
   elemental_set	= ATP_ELEMENTAL(AT_WORK_IDX);
   pure_set		= ATP_PURE(AT_WORK_IDX);

   if (TOKEN_VALUE(token) == Tok_Kwd_Subroutine) {
      stmt_type					= Subroutine_Stmt;
      SH_STMT_TYPE(curr_stmt_sh_idx)		= Subroutine_Stmt;
      parse_subroutine_stmt();
      ATP_RECURSIVE(SCP_ATTR_IDX(curr_scp_idx))	= recursive_set;
      ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))	= elemental_set;
      ATP_PURE(SCP_ATTR_IDX(curr_scp_idx))	= pure_set;
   }
   else if (TOKEN_VALUE(token) == Tok_Kwd_Function) {
      stmt_type					= Function_Stmt;
      SH_STMT_TYPE(curr_stmt_sh_idx)		= Function_Stmt;
      parse_function_stmt();
      ATP_RECURSIVE(SCP_ATTR_IDX(curr_scp_idx))	= recursive_set;
      ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))	= elemental_set;
      ATP_PURE(SCP_ATTR_IDX(curr_scp_idx))	= pure_set;
   }
   else if (curr_stmt_category > Sub_Func_Stmt_Cat) {
      iss_blk_stk_err();
      parse_err_flush(Find_EOS, NULL);
      NEXT_LA_CH;  /* Skip EOS */
   }
   else {  /* Assume this is a Function or subroutine statement */

      /* Reset to start of word, if matched something, so msg gets correct */
      /* column and line number.                                           */

      if (matched) {
         reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
      }

      parse_err_flush(Find_Lparen, "FUNCTION, SUBROUTINE, INTEGER, "
           "LOGICAL, DOUBLE PRECISION, REAL, COMPLEX, CHARACTER or TYPE");

      token			= main_token;
      TOKEN_LINE(token)		= stmt_start_line;		  
      TOKEN_COLUMN(token)	= stmt_start_col;		 
      pgm_type			= Subroutine;
      blk_type			= Subroutine_Blk;

      if (curr_stmt_category == Init_Stmt_Cat) {
         defer_msg		= 0;
         attr_idx		= start_new_prog_unit(pgm_type, 
                                                      blk_type, 
                                                      FALSE,
                                                      TRUE,
                                                      &defer_msg);
         ATP_PROC(attr_idx)	= Extern_Proc;
      }
      else { /* Create a scope for this contained routine, but leave          */
             /* curr_scp_idx still pointing to parent's scope.  After the     */
             /* call start_new_subpgm, curr_scp_idx will be set correctly.    */

         start_new_scp();
         curr_scp_idx		= SCP_PARENT_IDX(curr_scp_idx);
         attr_idx		= start_new_subpgm(pgm_type, TRUE, FALSE);
      }

      CURR_BLK_ERR		= TRUE;
      SCP_IN_ERR(curr_scp_idx)	= TRUE;
      ATP_RECURSIVE(attr_idx)	= recursive_set;
      ATP_ELEMENTAL(attr_idx)	= elemental_set;
      ATP_PURE(attr_idx)	= pure_set;

      if (CURR_BLK != Interface_Body_Blk &&
          (cmd_line_flags.runtime_argument ||
           cmd_line_flags.runtime_arg_entry)) {

         ATP_ARGCHCK_ENTRY(attr_idx) = TRUE;
      }

      if (LA_CH_VALUE == LPAREN) {
         parse_dummy_args(attr_idx);
      }

      if (LA_CH_VALUE == 'R') {

         /* Subroutine until now - switch to Function - Interface_Body_Blk,   */
         /* Module_Proc_Blk, Internal_Blk - no change                         */

         ATP_PGM_UNIT(attr_idx)	= Function;

         if (CURR_BLK == Subroutine_Blk) {
            CURR_BLK	= Function_Blk;
         }
         set_function_rslt(attr_idx, FALSE);
      }

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

      NEXT_LA_CH;  /* Skip EOS */
   }

EXIT:

   TRACE (Func_Exit, "parse_prefix_spec", NULL);

   return;

}  /* parse_prefix_spec */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	subroutine-stmt		=> [ RECURSIVE ] SUBROUTINE subroutine-name   *|
|*				                   [ ( [ dummy-arg-list ] ) ] *|
|*	dummy-arg 		=> dummy-arg-name			      *|
|*				   or *					      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/
void parse_subroutine_stmt (void)

{
   int		attr_idx;
   int		defer_msg;
   boolean	err_fnd		= FALSE;


   TRACE (Func_Entry, "parse_subroutine_stmt", NULL);

   if (curr_stmt_category > Sub_Func_Stmt_Cat) {
      iss_blk_stk_err();
      err_fnd			= TRUE;
   }

   if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
      parse_err_flush(Find_Lparen, "subroutine-name");
      token			= main_token;
      TOKEN_LINE(token)		= stmt_start_line;		  
      TOKEN_COLUMN(token)	= stmt_start_col;		 
      err_fnd			= TRUE;
   }

   if (curr_stmt_category == Init_Stmt_Cat) {  /* Start new compilation unit */
      defer_msg			= 0;
      attr_idx			= start_new_prog_unit(Subroutine,
                                                      Subroutine_Blk,
                                                      FALSE,
                                                      err_fnd,
                                                      &defer_msg);
      ATP_PROC(attr_idx)	= Extern_Proc;
   }
   else {

      /* Save the starting indexes of all the tables, to be used when        */
      /* collapsing the interface stuff back into the parent scope.          */

      /* Create a scope for this contained routine, but leave curr_scp_idx   */
      /* still pointing to parent's scope.  After the call to start_new_pgm, */
      /* curr_scp_idx will be set correctly.  TRUE means save table idxs if  */
      /* if this is an interface body, for use in collapsing later.          */

      start_new_scp();
      curr_scp_idx	= SCP_PARENT_IDX(curr_scp_idx);
      attr_idx		= start_new_subpgm(Subroutine, err_fnd, TRUE);
   }

   SCP_IN_ERR(curr_scp_idx)	= AT_DCL_ERR(attr_idx);

   if (CURR_BLK != Interface_Body_Blk &&
       (cmd_line_flags.runtime_argument ||
        cmd_line_flags.runtime_arg_entry)) {

      ATP_ARGCHCK_ENTRY(attr_idx) = TRUE;
   }

   if (LA_CH_VALUE == LPAREN) {
      parse_dummy_args(attr_idx);
   }

#ifdef KEY /* Bug 14150 */
   if (matched_specific_token(Tok_Kwd_Bind, Tok_Class_Keyword)) {
      if (AT_IS_DARG(attr_idx)) {
	parse_language_binding_spec(0);
	AT_BIND_ATTR(attr_idx) = TRUE;
      }
      else {
	parse_language_binding_spec(&new_binding_label);
	set_binding_label(AT_Tbl_Idx, attr_idx, &new_binding_label);
      }
   }
   else
#endif /* KEY Bug 14150 */
   if (LA_CH_VALUE != EOS) {
      parse_err_flush(Find_EOS, EOS_STR);
   }

   NEXT_LA_CH;
    
   TRACE (Func_Exit, "parse_subroutine_stmt", NULL);
   
   return;

}  /* parse_subroutine_stmt */
#ifdef KEY /* Bug 14150 */
/*
 * Parse RESULT clause for FUNCTION suffix.
 * attr_idx		AT_Tbl_Idx for function
 * out_rslt_idx		AT_Tbl_Idx for function result
 * return		TRUE if error found
 */
static int
help_set_function_rslt(int attr_idx, int *out_result_idx) {
   token_type save_token;
   int rslt_idx;
   int name_idx;
   int err_found = FALSE;

   if (LA_CH_VALUE != LPAREN) {
      parse_err_flush(Find_EOS, "(");
      err_found = TRUE;
   }
   else {
      NEXT_LA_CH;

      if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
	 parse_err_flush(Find_EOS, "result-name");
	 err_found = TRUE;
      }
      else {

	 if (LA_CH_VALUE == RPAREN) {
	    NEXT_LA_CH;
	 }
	 else {
	    save_token	= token;
	    parse_err_flush(Find_EOS, ")");
	    err_found	= TRUE;
	    token		= save_token;
	 }

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

	 if (rslt_idx == NULL_IDX) {
	    rslt_idx			= ntr_sym_tbl(&token, name_idx);
	    LN_DEF_LOC(name_idx)	= TRUE;
	    AT_OBJ_CLASS(rslt_idx)	= Data_Obj;
	 }
	 else if (!ATP_ALT_ENTRY(attr_idx)) {

	    /* The function result should not exist in the symbol table */

	    PRINTMSG(TOKEN_LINE(token), 1471, Error, TOKEN_COLUMN(token),
		     AT_OBJ_NAME_PTR(rslt_idx));
	    CREATE_ERR_ATTR(rslt_idx,
			    TOKEN_LINE(token),
			    TOKEN_COLUMN(token),
			    Data_Obj);
	 }
	 else if (fnd_semantic_err(Obj_Ntry_Func_Result,
				   TOKEN_LINE(token),
				   TOKEN_COLUMN(token),
				   rslt_idx,
				   TRUE)) {
	    CREATE_ERR_ATTR(rslt_idx,
			    TOKEN_LINE(token),
			    TOKEN_COLUMN(token),
			    Data_Obj);
	 }
	 else if (AT_REFERENCED(rslt_idx) == Char_Rslt_Bound_Ref) {
	    AT_ATTR_LINK(rslt_idx)	= NULL_IDX;
	    LN_DEF_LOC(name_idx)	= TRUE;
	 }

	 if ((cif_flags & XREF_RECS) != 0) {
	    cif_usage_rec(rslt_idx,
			  AT_Tbl_Idx,
			  TOKEN_LINE(token),
			  TOKEN_COLUMN(token),
			  CIF_Symbol_Declaration);
	 }

	 ATD_CLASS(rslt_idx)		= Function_Result;
	 ATP_RSLT_NAME(attr_idx)	= TRUE;
      }
   } 
   *out_result_idx = rslt_idx;
   return err_found;
}
#endif /* KEY Bug 14150 */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This routine handles the FUNCTION result, whether there is a          *|
|*	result-name or not.  Every function gets a function result.           *|
|*									      *|
|* Input parameters:							      *|
|*	attr_idx - attribute index of the function.			      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/
static void set_function_rslt(int	attr_idx,
                              boolean	type_err)

{
   boolean		err_found	= FALSE;
   int			func_rslt_idx;
   int			rslt_idx	= NULL_IDX;


   TRACE (Func_Entry, "set_function_rslt", NULL);

#ifdef KEY /* Bug 14150 */
   int bind_ok = 1;
   int result_ok = 1;
   while (LA_CH_VALUE != EOS) {
     if (bind_ok && matched_specific_token(Tok_Kwd_Bind, Tok_Class_Keyword)) {
       bind_ok = 0;
       int line, column;
       if (AT_IS_DARG(attr_idx)) {
	 parse_language_binding_spec(0);
	 AT_BIND_ATTR(attr_idx) = TRUE;
       }
       else {
	 parse_language_binding_spec(&new_binding_label);
	 set_binding_label(AT_Tbl_Idx, attr_idx, &new_binding_label);
       }
     }
     else if (result_ok && matched_specific_token(Tok_Kwd_Result,
       Tok_Class_Keyword)) {
       result_ok = 0;
       err_found = help_set_function_rslt(attr_idx, &rslt_idx);
     } else {
       parse_err_flush(Find_EOS, "BIND, RESULT or " EOS_STR);
       err_found = TRUE;
       break;
     }
   }
#endif /* KEY Bug 14150 */

   func_rslt_idx	= ATP_RSLT_IDX(attr_idx);

   if (rslt_idx == NULL_IDX) {

      if (func_rslt_idx == NULL_IDX) {
         NTR_ATTR_TBL(rslt_idx);
         COPY_COMMON_ATTR_INFO(attr_idx, rslt_idx, Data_Obj);
         ATD_CLASS(rslt_idx)		= Function_Result;
      }
      else {
         rslt_idx			= func_rslt_idx;
      }
   }
   else if (func_rslt_idx != NULL_IDX) {

      /* The function entry has a result already.  The result is semantically */
      /* correct.  If it exists, (depending on the type of function), it will */
      /* have access set, be typed, be an array, be a pointer, or be a dummy  */
      /* arg.  The dummy arg part is handled by the caller.   A check has to  */
      /* be made if it is a pointer or array, because these items must be     */
      /* specified using the RESULT name if it exists.  Double typing on a    */
      /* function statement will be handled by parse_typed_function.   Access */
      /* just gets copied.  It can also be a target.                          */

      if (ATD_ARRAY_IDX(func_rslt_idx) != NULL_IDX) {
         err_found = TRUE;
         PRINTMSG(TOKEN_LINE(token), 27, Error, TOKEN_COLUMN(token),
                  AT_OBJ_NAME_PTR(attr_idx), AT_OBJ_NAME_PTR(rslt_idx));

         if (ATD_ARRAY_IDX(rslt_idx) == NULL_IDX) {
            ATD_ARRAY_IDX(rslt_idx) = ATD_ARRAY_IDX(func_rslt_idx);
         }
      }

      if (ATD_POINTER(func_rslt_idx)) {
         err_found = TRUE;
         PRINTMSG(TOKEN_LINE(token), 36, Error, TOKEN_COLUMN(token),
                  AT_OBJ_NAME_PTR(attr_idx), AT_OBJ_NAME_PTR(rslt_idx));

         if (!ATD_POINTER(rslt_idx)) {
            ATD_POINTER(rslt_idx)   = TRUE;
            ATD_IM_A_DOPE(rslt_idx) = TRUE;
         }
      }

      if (ATD_TARGET(func_rslt_idx)) {
         err_found = TRUE;
         PRINTMSG(TOKEN_LINE(token), 132, Error, TOKEN_COLUMN(token),
                  AT_OBJ_NAME_PTR(attr_idx), AT_OBJ_NAME_PTR(rslt_idx));

         if (!ATD_TARGET(rslt_idx)) {
            ATD_TARGET(rslt_idx)   = TRUE;
         }
      }

      if (AT_TYPED(func_rslt_idx)) { 
         err_found = TRUE;
         PRINTMSG(TOKEN_LINE(token), 185, Error, TOKEN_COLUMN(token),
                  AT_OBJ_NAME_PTR(attr_idx), AT_OBJ_NAME_PTR(rslt_idx));

         if (!AT_TYPED(rslt_idx)) {
            ATD_TYPE_IDX(rslt_idx)	= ATD_TYPE_IDX(func_rslt_idx);
            AT_TYPED(rslt_idx)		= AT_TYPED(func_rslt_idx);
         }
      }
      AT_ACCESS_SET(rslt_idx)		= AT_ACCESS_SET(func_rslt_idx);
      AT_PRIVATE(rslt_idx)		= AT_PRIVATE(func_rslt_idx);

      /* Do not use the old result index from the FUNCTION.  Clear it and     */
      /* mark as error - so it will not be used later.                        */

      CLEAR_ATTR_NTRY(func_rslt_idx);
      AT_DCL_ERR(func_rslt_idx)		= TRUE;
   }

   if (!AT_TYPED(rslt_idx) || type_err) {

      if (!AT_DCL_ERR(rslt_idx)) { 
         SET_IMPL_TYPE(rslt_idx);
      }
      else if (ATD_TYPE_IDX(rslt_idx) == NULL_IDX) {
         ATD_TYPE_IDX(rslt_idx)	= TYPELESS_DEFAULT_TYPE;
      }
   }

   ATP_RSLT_IDX(attr_idx)	= rslt_idx;
   ATD_FUNC_IDX(rslt_idx)	= attr_idx;
   AT_DCL_ERR(rslt_idx)		= err_found || AT_DCL_ERR(rslt_idx);
   AT_DCL_ERR(attr_idx)		= AT_DCL_ERR(attr_idx) || AT_DCL_ERR(rslt_idx);

   TRACE (Func_Exit, "set_function_rslt", NULL);
   
   return;

}  /* set_function_rslt */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This routine parses the dummy argument list.                          *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/
static void parse_dummy_args(int	pgm_attr_idx)
{
   int		attr_idx;
   boolean	found_end		= FALSE;
   int		list_idx;
   int		name_idx;
   int		sn_idx;
   int		sn_attr_idx;


   TRACE (Func_Entry, "parse_dummy_args", NULL);

# ifdef _DEBUG
   if (LA_CH_VALUE != LPAREN) {
      PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token),
               "parse_dummy_args", "LPAREN");
   }
# endif

   NEXT_LA_CH;   /* Consume Lparen */

   if (LA_CH_VALUE == RPAREN) {		/* Empty argument list */
      NEXT_LA_CH;
      return;
   }

   /* Reserve a spot for an additional dummy argument, in case this function */
   /* result turns out to need a zero'th dummy argument to return the result */
   /* This should always be reserved right before the darg list in the tbl.  */

   NTR_SN_TBL(sn_attr_idx);

   do {
      if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
         attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx);

         if (attr_idx == NULL_IDX) {
            attr_idx			= ntr_sym_tbl(&token, name_idx);
            LN_DEF_LOC(name_idx)	= TRUE;
            AT_OBJ_CLASS(attr_idx)	= Data_Obj;
            ATD_CLASS(attr_idx)		= Dummy_Argument;
            SET_IMPL_TYPE(attr_idx);
            AT_IS_DARG(attr_idx)	= TRUE;
            AT_DCL_ERR(attr_idx)	= AT_DCL_ERR(pgm_attr_idx);

            /* Create a list of all unique dummy args in the program unit. */

            NTR_ATTR_LIST_TBL(list_idx);
            AL_NEXT_IDX(list_idx)	= SCP_DARG_LIST(curr_scp_idx);
            AL_ATTR_IDX(list_idx)	= attr_idx;
            SCP_DARG_LIST(curr_scp_idx)	= list_idx;
         }
         else if (!fnd_semantic_err(Obj_Dummy_Arg,
                                    TOKEN_LINE(token),
                                    TOKEN_COLUMN(token),
                                    attr_idx,
                                    TRUE)) {

            AT_DCL_ERR(attr_idx)	= AT_DCL_ERR(pgm_attr_idx);
  
            if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) {
               AT_ATTR_LINK(attr_idx)   = NULL_IDX;
               LN_DEF_LOC(name_idx)     = TRUE;
               CLEAR_VARIANT_ATTR_INFO(attr_idx, Data_Obj);
               ATD_CLASS(attr_idx)	= Dummy_Argument;
               SET_IMPL_TYPE(attr_idx);
            }
            else if ((AT_REFERENCED(attr_idx) == Referenced ||
                      AT_DEFINED(attr_idx)) && !AT_IS_DARG(attr_idx)) {

               /* If this is an entry statement, the darg may be used in a    */
               /* bounds specification expression (Dcl_Bound_Ref), but it     */
               /* may not have been used in an executable statement.          */

               PRINTMSG(TOKEN_LINE(token), 529, Error, TOKEN_COLUMN(token),
                        AT_OBJ_NAME_PTR(attr_idx));
            }

            if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {

               if (ATP_PROC(attr_idx) != Dummy_Proc) {
                  ATP_PROC(attr_idx)	=  Dummy_Proc;
               }
            }
            else if (ATD_CLASS(attr_idx) != Dummy_Argument) {
               ATD_CLASS(attr_idx)	= Dummy_Argument;
            }

            /* Create a list of all unique dummy args in the program unit. */

            if (!AT_IS_DARG(attr_idx)) {
               NTR_ATTR_LIST_TBL(list_idx);
               AL_NEXT_IDX(list_idx)		= SCP_DARG_LIST(curr_scp_idx);
               AL_ATTR_IDX(list_idx)		= attr_idx;
               SCP_DARG_LIST(curr_scp_idx)	= list_idx;
            }
            AT_IS_DARG(attr_idx)		= TRUE;
         }

         if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
            ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE;
         }


         if ((cif_flags & XREF_RECS) != 0) {
            cif_usage_rec(attr_idx,
                          AT_Tbl_Idx,
                          TOKEN_LINE(token),
                          TOKEN_COLUMN(token),
                          CIF_Symbol_Is_Dummy_Arg);
         }

	 /* Enter dummy arg name into the secondary name table */

         sn_attr_idx = srch_kwd_name(TOKEN_STR(token), TOKEN_LEN(token),
                                     pgm_attr_idx, &sn_idx);

	 if (sn_attr_idx != NULL_IDX) { /* Have duplicate dummy arg */
	    PRINTMSG(TOKEN_LINE(token), 10, Error, TOKEN_COLUMN(token),
                     TOKEN_STR(token));
	 }
         else { 
            NTR_SN_TBL(sn_idx);
            SN_ATTR_IDX(sn_idx)		= attr_idx;
            SN_NAME_LEN(sn_idx)		= AT_NAME_LEN(attr_idx);
            SN_NAME_IDX(sn_idx)		= AT_NAME_IDX(attr_idx);
            SN_LINE_NUM(sn_idx)		= TOKEN_LINE(token);
            SN_COLUMN_NUM(sn_idx)	= TOKEN_COLUMN(token);

            if (ATP_FIRST_IDX(pgm_attr_idx) == NULL_IDX) {
               ATP_FIRST_IDX(pgm_attr_idx) = sn_idx;
            }
            ATP_NUM_DARGS(pgm_attr_idx) += 1;
         }
      }
      else if (LA_CH_VALUE == STAR && 
               ATP_PGM_UNIT(pgm_attr_idx) == Subroutine) {

         /* Generate a compiler temp and point the secondary name table to it.*/
         /* Do this first to get the line and column number correct.          */

         attr_idx = gen_compiler_tmp(LA_CH_LINE, LA_CH_COLUMN, Shared, TRUE);

         NEXT_LA_CH;		/* Skip star */


         AT_REFERENCED(attr_idx)		= Referenced;
         AT_DEFINED(attr_idx)			= TRUE;
         AT_SEMANTICS_DONE(attr_idx)		= TRUE;
         ATD_TYPE_IDX(attr_idx)			= INTEGER_DEFAULT_TYPE;
         ATD_STOR_BLK_IDX(attr_idx)		= SCP_SB_DARG_IDX(curr_scp_idx);
         ATD_CLASS(attr_idx)			= Dummy_Argument;
         AT_IS_DARG(attr_idx)			= TRUE;
         ATP_HAS_ALT_RETURN(pgm_attr_idx)	= TRUE;
         ATP_HAS_ALT_RETURN(SCP_ATTR_IDX(curr_scp_idx))	= TRUE;

	 NTR_SN_TBL(sn_attr_idx);
         SN_ATTR_IDX(sn_attr_idx)		= attr_idx;
         SN_NAME_IDX(sn_attr_idx)		= AT_NAME_IDX(attr_idx);
         SN_LINE_NUM(sn_attr_idx)		= LA_CH_LINE;
         SN_COLUMN_NUM(sn_attr_idx)		= LA_CH_COLUMN;

	 if (ATP_FIRST_IDX(pgm_attr_idx) == NULL_IDX) {
	    ATP_FIRST_IDX(pgm_attr_idx) = sn_attr_idx;
	 }
	 ATP_NUM_DARGS(pgm_attr_idx) +=1;
      }
      else {
         parse_err_flush(Find_Comma_Rparen, "dummy-arg-name");
         found_end = (LA_CH_VALUE == EOS);
      }

      if (LA_CH_VALUE != RPAREN && LA_CH_VALUE != COMMA && !found_end) {
         parse_err_flush(Find_Comma_Rparen, ", or )");
      }

      if (LA_CH_VALUE == COMMA) {
         NEXT_LA_CH;
      }
      else {
         found_end = TRUE;
      }
   }  /* end do while */
   while (!found_end);

   /* check if this is the largest arg list seen yet.  */
   /* Since some of these could be optional must check */
   /* both here and parse_actual_arg_spec.             */

   if (ATP_NUM_DARGS(pgm_attr_idx) > max_call_list_size) {
      max_call_list_size = (long) ATP_NUM_DARGS(pgm_attr_idx);
   }

   if (LA_CH_VALUE == RPAREN) {
      NEXT_LA_CH;	/* Consume RPAREN */
   }

   TRACE (Func_Exit, "parse_dummy_args", NULL);

   return;

}  /* parse_dummy_args */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Routine called by parse_function and parse_subroutine.  It performs   *|
|*	common tasks such as srch and ntr the program name into the symbol    *|
|*	table,  sets the appropriate fields in the attr entry, establishes    *|
|*	the proper block.  If appropriate, it enters the subprogram name      *|
|*	into a new scope.						      *|
|*									      *|
|*									      *|
|* Input parameters:							      *|
|*	pgm_type	The type of program being processed.                  *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static int start_new_subpgm(pgm_unit_type	pgm_type,
			    boolean		has_error,
			    boolean		save_idxs)

{
   int			attr_idx;
   int			host_name_idx;
   int			interface_idx		= NULL_IDX;
   int			ir_idx;
   int			length;
   int			loc_name_idx;
   int			name_idx;
   atp_proc_type	proc_type;
   int			sb_idx;
   int			sn_idx;
   int			tmp_attr_idx;
   obj_type		type_of_obj;			


   TRACE (Func_Entry, "start_new_subpgm", NULL);

   if (CURR_BLK == Interface_Blk) {
      interface_idx	= CURR_BLK_NAME;

      if (interface_idx) {

         if (ATI_INTERFACE_CLASS(interface_idx) == Generic_Unknown_Interface) {
            ATI_INTERFACE_CLASS(interface_idx) = (pgm_type == Function) ?
                                                  Generic_Function_Interface :
                                                  Generic_Subroutine_Interface;
         }
      }
      else {
         interface_idx = BLK_UNNAMED_INTERFACE(blk_stk_idx);
      }

      ATI_HAS_NON_MOD_PROC(interface_idx)       = TRUE;

      /* This assumes that the attr table is always initialized with */
      /* some kind of entries at start up.                           */

      if (save_idxs && BLK_AT_IDX(blk_stk_idx) == NULL_IDX) {
         BLK_AT_IDX(blk_stk_idx)	= attr_tbl_idx;
         BLK_BD_IDX(blk_stk_idx)	= bounds_tbl_idx;
         BLK_CN_IDX(blk_stk_idx)	= const_tbl_idx;
         BLK_CP_IDX(blk_stk_idx)	= const_pool_idx;
         BLK_NP_IDX(blk_stk_idx)	= name_pool_idx;
         BLK_SB_IDX(blk_stk_idx)	= stor_blk_tbl_idx;
         BLK_SN_IDX(blk_stk_idx)	= sec_name_tbl_idx;
         BLK_TYP_IDX(blk_stk_idx)	= type_tbl_idx;
      }
         
      PUSH_BLK_STK(Interface_Body_Blk);
      CURR_BLK_NO_EXEC	= TRUE;
      proc_type		= Extern_Proc;
      type_of_obj	= (pgm_type == Function) ? Obj_Interface_Func :
                                                   Obj_Interface_Subr;
   }
   else if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) {

      /* Do not check if comp unit is module, because only the first contains */
      /* in a MODULE is a module procedure.  Subsequent ones are Internal proc*/

      PUSH_BLK_STK(Module_Proc_Blk);
      type_of_obj	= (pgm_type == Function) ? Obj_Module_Func :
                                                   Obj_Module_Subr;
      proc_type		= Module_Proc;
   }
   else { /* Must be Internal_Blk */
      PUSH_BLK_STK(Internal_Blk);
      proc_type		= Intern_Proc;
      type_of_obj	= (pgm_type == Function) ? Obj_Intern_Func :
                                                   Obj_Intern_Subr;
   }

   /* Search parent for subprogram name. */

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

   if (CURR_BLK == Interface_Body_Blk) {

      /* If the attr_idx was not found in the interface block's parent     */
      /* entry and this is an interface block inside a contains block -    */
      /* and NOT inside a contains block inside a contains block.  Search  */
      /* the interface block's parent's host for the name.  If the name is */
      /* found and it is the main entry name or an alternate entry name -  */
      /* issue an error.  Recovery = treat this as a new interface entry.  */

      if (SCP_LEVEL(curr_scp_idx) == 1 &&
          (attr_idx == NULL_IDX || AT_OBJ_CLASS(attr_idx) == Interface)) {

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

         if (attr_idx != NULL_IDX &&
             !SH_ERR_FLG(curr_stmt_sh_idx) &&
             (SCP_ATTR_IDX(SCP_PARENT_IDX(curr_scp_idx)) == attr_idx ||
              AT_OBJ_CLASS(attr_idx) == Pgm_Unit && 
              ATP_ALT_ENTRY(attr_idx)) ) {

            /* Issue error - The entry pointer name of the host, "%s" must */
            /*               not be redefined in an interface body.        */
            /* Set SCP_ATTR so that the message pgm unit will be correct.  */

            curr_scp_idx		= SCP_LAST_CHILD_IDX(curr_scp_idx);
            SCP_ATTR_IDX(curr_scp_idx)	= attr_idx;
            PRINTMSG(TOKEN_LINE(token), 44, Error, TOKEN_COLUMN(token),
                     AT_OBJ_NAME_PTR(attr_idx));
            AT_DCL_ERR(attr_idx)	= TRUE;
            curr_scp_idx		= SCP_PARENT_IDX(curr_scp_idx);
         }
         attr_idx = NULL_IDX;
      }
   }

   if (attr_idx == NULL_IDX) {		/* enter into parent's host   */
      attr_idx			= ntr_sym_tbl(&token, name_idx);
      AT_OBJ_CLASS(attr_idx)	= Pgm_Unit;
      LN_DEF_LOC(name_idx)	= TRUE;
      ATP_PROC(attr_idx)	= proc_type;
      ATP_PGM_UNIT(attr_idx)	= pgm_type;
   }
   else if (AT_NOT_VISIBLE(attr_idx)) { /* Not visible in parent's host */
      curr_scp_idx			= SCP_LAST_CHILD_IDX(curr_scp_idx);
      SCP_ATTR_IDX(curr_scp_idx)	= attr_idx;  /* Set for message */

      PRINTMSG(TOKEN_LINE(token), 486, Error,
               TOKEN_COLUMN(token),
               AT_OBJ_NAME_PTR(attr_idx),
               AT_OBJ_NAME_PTR(AT_MODULE_IDX((attr_idx))));

      CREATE_ERR_ATTR(attr_idx,
                      TOKEN_LINE(token), 
                      TOKEN_COLUMN(token),
                      Pgm_Unit);

      ATP_PROC(attr_idx)		= proc_type;
      ATP_PGM_UNIT(attr_idx)		= pgm_type;
      AT_TYPED(attr_idx)		= FALSE;
      curr_scp_idx			= SCP_PARENT_IDX(curr_scp_idx);
   }
   else if (CURR_BLK == Interface_Body_Blk && interface_idx == attr_idx) {

      /* This subprogram name is the same as it's generic interface - legal */

      NTR_ATTR_TBL(tmp_attr_idx);
      COPY_COMMON_ATTR_INFO(attr_idx, tmp_attr_idx, Pgm_Unit);
      ATI_PROC_IDX(attr_idx)	= tmp_attr_idx;
      attr_idx			= tmp_attr_idx;
      ATP_PROC(attr_idx)	= proc_type;
      ATP_PGM_UNIT(attr_idx)	= pgm_type;
      AT_DEF_LINE(attr_idx)	= TOKEN_LINE(token);
      AT_DEF_COLUMN(attr_idx)	= TOKEN_COLUMN(token);
      AT_IS_INTRIN(attr_idx)	= FALSE;
      AT_ELEMENTAL_INTRIN(attr_idx)	= FALSE;
   }
   else if (CURR_BLK == Interface_Body_Blk && 
            SCP_ATTR_IDX(curr_scp_idx) == attr_idx) {

      /* Allow the user to specify an interface block description for the     */
      /* function or subroutine being compiled.  Issue an ANSI message later. */

      NTR_ATTR_TBL(tmp_attr_idx);
      COPY_COMMON_ATTR_INFO(attr_idx, tmp_attr_idx, Pgm_Unit);
      ATP_DUPLICATE_INTERFACE_IDX(attr_idx)	= tmp_attr_idx;
      attr_idx					= tmp_attr_idx;
      ATP_PROC(attr_idx)			= proc_type;
      ATP_PGM_UNIT(attr_idx)			= pgm_type;
      AT_DEF_LINE(attr_idx)			= TOKEN_LINE(token);
      AT_DEF_COLUMN(attr_idx)			= TOKEN_COLUMN(token);
      AT_IS_INTRIN(attr_idx)			= FALSE;
      AT_ELEMENTAL_INTRIN(attr_idx)		= FALSE;
   }
   else {

      if (AT_OBJ_CLASS(attr_idx) == Interface && 
          ATI_PROC_IDX(attr_idx) != NULL_IDX) {
         attr_idx = ATI_PROC_IDX(attr_idx);
      }

      if (proc_type == Intern_Proc &&
          AT_ATTR_LINK(attr_idx) != NULL_IDX && 
          AT_LOCKED_IN(attr_idx)) {

         do {
            tmp_attr_idx = AT_ATTR_LINK(attr_idx);
         }
         while (AT_ATTR_LINK(tmp_attr_idx) != NULL_IDX);

         if (AT_OBJ_CLASS(tmp_attr_idx) == Data_Obj &&
             ATD_CLASS(tmp_attr_idx) == Constant) {

            /* If an error is issued, it will get caught in the next if   */
            /* statement and will go through error processing.            */

            curr_scp_idx		= SCP_LAST_CHILD_IDX(curr_scp_idx);
            SCP_ATTR_IDX(curr_scp_idx)	= attr_idx;  /* Set for msg  */

            PRINTMSG(TOKEN_LINE(token), 919, Error,
                     TOKEN_COLUMN(token),
                     AT_OBJ_NAME_PTR(attr_idx),
                     (pgm_type == Function) ? "FUNCTION" : "SUBROUTINE");
            curr_scp_idx		= SCP_PARENT_IDX(curr_scp_idx);
         }
      }

      if (SH_ERR_FLG(curr_stmt_sh_idx) || 
          attr_idx == glb_tbl_idx[Main_Attr_Idx] ||
          AT_DCL_ERR(attr_idx) ||
          fnd_semantic_err(type_of_obj,
                           TOKEN_LINE(token), 
                           TOKEN_COLUMN(token),
                           attr_idx,
                           TRUE)) {

         /* If this already has an error, or it is $MAIN, or there is a    */
         /* semantic error ==> To prevent errs, create a second attr entry */
         /* for this name.  The local name points to the first (marked in  */
         /* error), the 2nd is used to finish parsing this statement.      */

         CREATE_ERR_ATTR(attr_idx,
                         TOKEN_LINE(token), 
                         TOKEN_COLUMN(token),
                         Pgm_Unit);
         AT_TYPED(attr_idx)	= FALSE;
         ATP_PROC(attr_idx)	= proc_type;
         ATP_PGM_UNIT(attr_idx)	= pgm_type;
      }
      else if (CURR_BLK != Interface_Body_Blk && 
               proc_type == Module_Proc &&
               (AT_OBJ_CLASS(attr_idx) == Pgm_Unit &&
                ATP_PROC(attr_idx) == Module_Proc &&
                ATP_EXPL_ITRFC(attr_idx))) {

         /* This is already declared as a module procedure. */

         curr_scp_idx			= SCP_LAST_CHILD_IDX(curr_scp_idx);
         SCP_ATTR_IDX(curr_scp_idx)	= attr_idx;  /* Set for msg  */

         PRINTMSG(TOKEN_LINE(token), 1529, Error,
                  TOKEN_COLUMN(token),
                  AT_OBJ_NAME_PTR(attr_idx));
         curr_scp_idx			= SCP_PARENT_IDX(curr_scp_idx);
      }
      else if (AT_OBJ_CLASS(attr_idx) == Interface) {

         if (AT_IS_INTRIN(attr_idx) && !LN_DEF_LOC(name_idx)) {

            /* This is just an intrinsic, because of a reference.  It has not */
            /* been declared in an intrinsic statement or as an interface.    */

            CLEAR_VARIANT_ATTR_INFO(attr_idx, Pgm_Unit);
            AT_ATTR_LINK(attr_idx)	= NULL_IDX;
            AT_IS_INTRIN(attr_idx)	= FALSE;
            AT_ELEMENTAL_INTRIN(attr_idx)= FALSE;
            ATP_PROC(attr_idx)		= proc_type;
            ATP_PGM_UNIT(attr_idx)	= pgm_type;
            AT_USE_ASSOCIATED(attr_idx)	= FALSE;
            AT_DEF_LINE(attr_idx)	= TOKEN_LINE(token);
            AT_DEF_COLUMN(attr_idx)	= TOKEN_COLUMN(token);
            LN_DEF_LOC(name_idx)	= TRUE;
         }
         else {
            NTR_ATTR_TBL(tmp_attr_idx);
            COPY_COMMON_ATTR_INFO(attr_idx, tmp_attr_idx, Pgm_Unit);
            ATI_PROC_IDX(attr_idx)	= tmp_attr_idx;
            attr_idx			= tmp_attr_idx;
            AT_USE_ASSOCIATED(attr_idx)	= FALSE;
            MAKE_EXTERNAL_NAME(attr_idx,
                               AT_NAME_IDX(attr_idx),
                               AT_NAME_LEN(attr_idx));
            ATP_PROC(attr_idx)		= proc_type;
            ATP_PGM_UNIT(attr_idx)	= pgm_type;
            AT_DEF_LINE(attr_idx)	= TOKEN_LINE(token);
            AT_DEF_COLUMN(attr_idx)	= TOKEN_COLUMN(token);
            AT_IS_INTRIN(attr_idx)	= FALSE;
            AT_ELEMENTAL_INTRIN(attr_idx)	= FALSE;
         }
      }
      else {

         /* Break any links that this found attr has with host association.*/
         /* Because this subpgm definition makes this the correct thing    */
         /* for the current scope to use.  If it has a function result     */
         /* break the function result links also.                          */

         AT_ATTR_LINK(attr_idx)	= NULL_IDX;
         LN_DEF_LOC(name_idx)	= TRUE;

         if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
            chg_data_obj_to_pgm_unit(attr_idx, pgm_type, proc_type);
         }
         else {
            ATP_PROC(attr_idx)		= proc_type;
            ATP_PGM_UNIT(attr_idx)	= pgm_type;

            if (pgm_type == Function && ATP_RSLT_IDX(attr_idx) != NULL_IDX) {
               AT_ATTR_LINK(ATP_RSLT_IDX(attr_idx))	= NULL_IDX;
            }
         }
         AT_DEF_LINE(attr_idx)		= TOKEN_LINE(token);
         AT_DEF_COLUMN(attr_idx)	= TOKEN_COLUMN(token);
      }

   }

   /* The scope for this routine was created before calling this routine */
   /* so that any type variables would get into the correct scope.  At   */
   /* the time this routine was called, curr_scp_idx points to the       */
   /* parent.  Now set curr_scp_idx and SCP_ATTR_IDX correctly.          */

   curr_scp_idx			= SCP_LAST_CHILD_IDX(curr_scp_idx);
   SCP_ATTR_IDX(curr_scp_idx)	= attr_idx;  /* Set in case of msg  */
   ATP_SCP_IDX(attr_idx)	= curr_scp_idx;
   AT_DCL_ERR(attr_idx)		= AT_DCL_ERR(attr_idx) || has_error;

   /* Add entry to local scope - but point to parent's attr.  */

   tmp_attr_idx			= srch_sym_tbl(TOKEN_STR(token), 
                                              TOKEN_LEN(token),
                                              &loc_name_idx);

   /* Carry the index to the parent's attr.  This is for use in USE    */
   /* processing.  If the module/internal procedure is written out and */
   /* then USEd back again for inlining purposes, we need to know the  */
   /* parent so we can send the procedure IR/SH through the interface. */

   ATP_PARENT_IDX(attr_idx)	= SCP_ATTR_IDX(SCP_PARENT_IDX(curr_scp_idx));

   if (tmp_attr_idx != NULL_IDX) {     /* Have fatal error - must not be seen */
      fnd_semantic_err(type_of_obj,
                       TOKEN_LINE(token),
                       TOKEN_COLUMN(token),
                       tmp_attr_idx,
                       TRUE);

      /* KAY - This is where some of the scoping gets fixed.  Think about     */
      /*       AT_NOT_VISIBLE here.                                           */

      /* This is found in the following situation.  FUNCTION is an internal   */
      /* or module procedure.   CHARACTER*(A) FUNCTION A()     The A is in    */
      /* the local table already.  Replace that attr with the host's attr.    */
      /* AT_DCL_ERR for tmp_attr_idx is set by fnd_semantic_err.              */
      /* During attr resolution, the host symbol table will be researched for */
      /* A.  Then AT_ATTR_LINK for A will point to the internal procedure.    */
      /* This will get flagged when the bounds are checked.                   */

      LN_ATTR_IDX(loc_name_idx)	= attr_idx;
      LN_NAME_IDX(loc_name_idx)	= AT_NAME_IDX(attr_idx);
   }
   else {

      /* Enter in local symbol table, but do NOT create a new attr entry.     */
      /* FALSE means use the same attr entry for the host and the local.      */

      attr_idx	= ntr_host_in_sym_tbl(&token, loc_name_idx, attr_idx, name_idx,
                                      FALSE);
   }

   LN_DEF_LOC(loc_name_idx)	= TRUE;
   curr_stmt_category		= Dir_Integer_Stmt_Cat;
   CURR_BLK_NAME		= attr_idx;
   ATP_EXPL_ITRFC(attr_idx)	= TRUE;
   ATP_PP_ABSTRACT(attr_idx)	= abstract_flag;

   if ((cif_flags & XREF_RECS) != 0) {
      cif_usage_rec(attr_idx,
                    AT_Tbl_Idx,
                    TOKEN_LINE(token),
                    TOKEN_COLUMN(token),
                    CIF_Symbol_Declaration);
   }

   /* Generate a SH for interface blocks.  This is needed to make bounds */
   /* resolution work.  This will be thrown out later.                   */

   CURR_BLK_FIRST_SH_IDX = 
                  (SH_STMT_TYPE(SCP_FIRST_SH_IDX(curr_scp_idx)) != Label_Def) ?
                            SCP_FIRST_SH_IDX(curr_scp_idx) :
                            IR_IDX_L(SH_IR_IDX(SCP_FIRST_SH_IDX(curr_scp_idx)));

   NTR_IR_TBL(ir_idx);
   SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
   IR_OPR(ir_idx)              = Entry_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);
   IR_FLD_L(ir_idx)            = AT_Tbl_Idx;
   IR_IDX_L(ir_idx)            = attr_idx;
   IR_COL_NUM_L(ir_idx)        = TOKEN_COLUMN(token);
   IR_LINE_NUM_L(ir_idx)       = TOKEN_LINE(token);

   ATP_SCP_ALIVE(attr_idx) = TRUE;

   if (CURR_BLK == Interface_Body_Blk) {
      MAKE_EXTERNAL_NAME(attr_idx,
                         AT_NAME_IDX(attr_idx),
                         AT_NAME_LEN(attr_idx));
      ATP_IN_INTERFACE_BLK(attr_idx)	= TRUE;
      ATP_IN_UNNAMED_INTERFACE(attr_idx)= ATI_UNNAMED_INTERFACE(interface_idx);

      if (interface_idx != NULL_IDX) {     /* Generic or Defined interface    */
         sn_idx		= ATI_FIRST_SPECIFIC_IDX(interface_idx);
         tmp_attr_idx	= srch_linked_sn(TOKEN_STR(token),
                                         TOKEN_LEN(token),
                                         &sn_idx);

         if (tmp_attr_idx == NULL_IDX) {

            /* Not found - intentionally blank */
         }
         else if (AT_IS_INTRIN(tmp_attr_idx)) {

            /* The user is overloading intrinsics - allow */
         }
         else if (ATP_SCP_IDX(attr_idx) == curr_scp_idx &&
                  !AT_USE_ASSOCIATED(attr_idx) &&
                  !ATI_UNNAMED_INTERFACE(interface_idx)) {

            if (!AT_DCL_ERR(attr_idx)) {
               PRINTMSG(TOKEN_LINE(token), 671, Error,
                        TOKEN_COLUMN(token),
                        AT_OBJ_NAME_PTR(attr_idx),
                        AT_OBJ_NAME_PTR(interface_idx));
               AT_DCL_ERR(attr_idx)  = TRUE;
            }

            /* Add it, marked in error for better error recovery. */

         }
         else {  /* Intentionally blank */

            /* Found, but it is from a different scope. */
         }

#ifdef KEY /* Bug 4197 */
	 /*
	  * Remove intrinsics if necessary to implement this provision of
	  * the F95 standard (14.1.2.3): "If a generic name is the same as
	  * the name of a generic intrinsic procedure, the generic intrinsic
	  * procedure is not accessible if the procedures in the interface
	  * and the intrinsic procedure are not all functions or not all
	  * subroutines."
	  */
	 if (AT_IS_INTRIN(interface_idx)) {
	   boolean adding_subroutine = (Subroutine == ATP_PGM_UNIT(attr_idx));
	   if (adding_subroutine != (Generic_Subroutine_Interface ==
	     ATI_INTERFACE_CLASS(interface_idx))) {
	     AT_IS_INTRIN(interface_idx) = FALSE;
	     ATI_FIRST_SPECIFIC_IDX(interface_idx) = NULL_IDX;
	     ATI_NUM_SPECIFICS(interface_idx) = 0;
	     ATI_INTERFACE_CLASS(interface_idx) = adding_subroutine ?
	       Generic_Subroutine_Interface :
	       Generic_Function_Interface;
	   }
	 }
#endif /* KEY Bug 4197 */

         NTR_INTERFACE_IN_SN_TBL(sn_idx,
                                 attr_idx,
                                 interface_idx,
                                 TOKEN_LINE(token),
                                 TOKEN_COLUMN(token));
      }

      /* All static blocks inside interface bodies will be treated as if  */
      /* they are host associated.                                        */

      sb_idx			= SCP_SB_STATIC_IDX(curr_scp_idx);
      SB_HOSTED_STATIC(sb_idx)	= TRUE;
      SB_BLK_TYPE(sb_idx)	= Static;
      SB_RUNTIME_INIT(sb_idx)	= FALSE;

      SCP_SB_HOSTED_STATIC_IDX(curr_scp_idx)	= sb_idx;

      /* The @DATA block needs to be renamed to @DATA_in_PGM_UNIT_NAME_in_.. */

      SB_NAME_IDX(sb_idx)	= make_in_parent_string(SB_NAME_IDX(sb_idx),
                                                        SB_NAME_LEN(sb_idx),
                                                        curr_scp_idx,
                                                        &length);
      SB_NAME_LEN(sb_idx)	= length;

      if (sb_idx != SCP_SB_STATIC_INIT_IDX(curr_scp_idx)) {
         sb_idx                    	= SCP_SB_STATIC_INIT_IDX(curr_scp_idx);
         SB_HOSTED_STATIC(sb_idx)  	= TRUE;
         SB_BLK_TYPE(sb_idx)       	= Static_Named;
         SB_RUNTIME_INIT(sb_idx)	= FALSE;
         SCP_SB_HOSTED_DATA_IDX(curr_scp_idx) = sb_idx;

         SB_NAME_IDX(sb_idx)       = make_in_parent_string(SB_NAME_IDX(sb_idx),
                                                           SB_NAME_LEN(sb_idx),
                                                           curr_scp_idx,
                                                           &length);
         SB_NAME_LEN(sb_idx)       = length;
      }

      if (sb_idx != SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx)) {
         sb_idx                    = SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx);
         SB_HOSTED_STATIC(sb_idx)  = TRUE;
         SB_BLK_TYPE(sb_idx)       = Static_Named;
         SB_RUNTIME_INIT(sb_idx)   = FALSE;
         SB_NAME_IDX(sb_idx)       = make_in_parent_string(SB_NAME_IDX(sb_idx),
                                                           SB_NAME_LEN(sb_idx),
                                                           curr_scp_idx,
                                                           &length);
         SB_NAME_LEN(sb_idx)       = length;
      }
   }
   else {  /* Give internal and module procs, unique external names */
      ATP_EXT_NAME_IDX(attr_idx) = make_in_parent_string(AT_NAME_IDX(attr_idx),
                                                  AT_NAME_LEN(attr_idx),
                                                  SCP_PARENT_IDX(curr_scp_idx),
                                                  &length);
      ATP_EXT_NAME_LEN(attr_idx) = length;

      if (cmd_line_flags.debug_lvl <= Debug_Lvl_1) {  /* -ez -ed  -G0 -G1 */
         gen_end_prologue_debug_label(attr_idx);
      }

      /* The @DATA block needs to be renamed to @DATA_in_PGM_UNIT_NAME_in_.. */

      sb_idx			= SCP_SB_STATIC_IDX(curr_scp_idx);
      SB_NAME_IDX(sb_idx)	= make_in_parent_string(SB_NAME_IDX(sb_idx),
                                                        SB_NAME_LEN(sb_idx),
                                                        curr_scp_idx,
                                                        &length);
      SB_NAME_LEN(sb_idx)	= length;

      if (sb_idx != SCP_SB_STATIC_INIT_IDX(curr_scp_idx)) {
         sb_idx                    = SCP_SB_STATIC_INIT_IDX(curr_scp_idx);
         SB_NAME_IDX(sb_idx)       = make_in_parent_string(SB_NAME_IDX(sb_idx),
                                                           SB_NAME_LEN(sb_idx),
                                                           curr_scp_idx,
                                                           &length);
         SB_NAME_LEN(sb_idx)       = length;
      }

      if (sb_idx != SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx)) {
         sb_idx                    = SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx);
         SB_NAME_IDX(sb_idx)       = make_in_parent_string(SB_NAME_IDX(sb_idx),
                                                           SB_NAME_LEN(sb_idx),
                                                           curr_scp_idx,
                                                           &length);
         SB_NAME_LEN(sb_idx)       = length;
      }

      ATP_MAY_INLINE(attr_idx) = 
              ATP_MAY_INLINE(SCP_ATTR_IDX(SCP_PARENT_IDX(curr_scp_idx)));
   }

   /* If basic CIF records were requested, output the Begin Scope record for  */
   /* this interface body, module procedure, or internal procedure.           */

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

   if (CURR_BLK == Interface_Body_Blk) {

      /* Reset this so that implicit_use_semantics will happen for interfaces */
      cdir_switches.implicit_use_idx	= cmd_line_flags.implicit_use_idx;
   }

   implicit_use_semantics();

   TRACE (Func_Exit, "start_new_subpgm", NULL);

   return(attr_idx);

}  /* start_new_subpgm */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Generate a debug label for the end of prologue code.		      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	attr_idx   Index to the new attribute entry.			      *|
|*									      *|
\******************************************************************************/
static	void	gen_end_prologue_debug_label(int	attr_idx)

{
   int		ir_idx;
   int		lbl_attr_idx;


   TRACE (Func_Entry, "gen_end_prologue_debug_label", NULL);

   /* Generate a debug label for the end of prologue.  The label must   */
   /* have the same name as the program unit.                           */

   NTR_ATTR_TBL(lbl_attr_idx);
   COPY_COMMON_ATTR_INFO(attr_idx, lbl_attr_idx, Label);
   AT_DEFINED(lbl_attr_idx)		= TRUE;
   ATL_CLASS(lbl_attr_idx)		= Lbl_Debug;
   ATL_DEBUG_CLASS(lbl_attr_idx)	= Ldbg_End_Prologue;

   if (ATP_EXT_NAME_IDX(attr_idx) != NULL_IDX) {
      AT_NAME_LEN(lbl_attr_idx)		= ATP_EXT_NAME_LEN(attr_idx);
      AT_NAME_IDX(lbl_attr_idx)		= ATP_EXT_NAME_IDX(attr_idx);
   }

   ADD_ATTR_TO_LOCAL_LIST(lbl_attr_idx);

   gen_sh(After,
          Continue_Stmt,
          SH_GLB_LINE(curr_stmt_sh_idx),
          SH_COL_NUM(curr_stmt_sh_idx),
          FALSE,                        /* No errors */
          TRUE,                         /* Labeled */
          TRUE);                        /* Compiler generated */

   SH_P2_SKIP_ME(curr_stmt_sh_idx)      = 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)          	= SH_GLB_LINE(curr_stmt_sh_idx);
   IR_COL_NUM(ir_idx)           	= SH_COL_NUM(curr_stmt_sh_idx);
   IR_LINE_NUM_L(ir_idx)        	= SH_GLB_LINE(curr_stmt_sh_idx);
   IR_COL_NUM_L(ir_idx)         	= SH_COL_NUM(curr_stmt_sh_idx);
   IR_FLD_L(ir_idx)             	= AT_Tbl_Idx;
   IR_IDX_L(ir_idx)             	= lbl_attr_idx;
   ATL_DEF_STMT_IDX(lbl_attr_idx)	= curr_stmt_sh_idx;

   TRACE (Func_Exit, "gen_end_prologue_debug_label", NULL);

   return;

}  /* gen_end_prologue_debug_label */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Common code to start all new external program units.		      *|
|*									      *|
|* Input parameters:							      *|
|*	pgm_type   Module, Program, Function, Subroutine, Blockdata           *|
|*	blk_type   The block type.                                            *|
|*      no_name_entry   TRUE if this is $MAIN entry                           *|
|*      parse_error     TRUE if there is a parse error on the prog unit stmt. *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      defer_msg  If this is nonzero, then set this to 1003 or 1009 if either*|
|*                 of the messages needs to be issued, but do not issue the   *|
|*                 message.  This delay is necessary for some error recovery  *|
|*                 situations.                                                *|
|*									      *|
|* Returns:								      *|
|*	attr_idx   Index to the new attribute entry.			      *|
|*									      *|
\******************************************************************************/
#ifdef KEY /* Bug 8261 */
int start_new_prog_unit_by_token(pgm_unit_type, blk_cntxt_type, boolean,
  boolean, int *, token_type *);
#endif /* KEY Bug 8261 */

int	start_new_prog_unit(pgm_unit_type	pgm_type,
			    blk_cntxt_type	blk_type,
			    boolean		no_name_entry,
			    boolean		parse_error,
                            int                *defer_msg)
#ifdef KEY /* Bug 8261 */
{
  return start_new_prog_unit_by_token(pgm_type, blk_type, no_name_entry,
    parse_error, defer_msg, &token);
}

/* Like start_new_prog_unit, but takes token as an argument instead of
 * assuming it can use the global variable */
int start_new_prog_unit_by_token(pgm_unit_type pgm_type,
  blk_cntxt_type blk_type, boolean  no_name_entry, boolean  parse_error,
  int *defer_msg, token_type *token)
#endif /* KEY Bug 8261 */
{
   		int	attr_idx;
   static	int	num_main_program	= 0;
   static	int	num_no_name_entry	= 0;
		boolean	has_task_dirs		= FALSE;
   		int	ir_idx;
		int	length;
		int	message;
   		int	name_idx;
   		int	save_sh_idx;
   		int	sb_idx;


   TRACE (Func_Entry, "start_new_prog_unit", NULL);

   if (!no_name_entry) {

      if (curr_stmt_category != Init_Stmt_Cat) {
         iss_blk_stk_err();
         SCP_IN_ERR(curr_scp_idx) = TRUE;
 
         /* DO NOT SET CURR_BLK_ERR here - because if context error - this */
         /* stmt cleared the block stack and started over.                 */
      }

      curr_stmt_category	= Dir_Integer_Stmt_Cat;		
   }

#ifdef KEY /* Bug 8261 */
   attr_idx = srch_sym_tbl(TOKEN_STR(*token), TOKEN_LEN(*token), &name_idx);
#else /* KEY Bug 8261 */
   attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx);
#endif /* KEY Bug 8261 */

   if (attr_idx == NULL_IDX) {
#ifdef KEY /* Bug 8261 */
      attr_idx				= ntr_sym_tbl(token, name_idx);
#else /* KEY Bug 8261 */
      attr_idx				= ntr_sym_tbl(&token, name_idx);
#endif /* KEY Bug 8261 */
      AT_DCL_ERR(attr_idx)		= parse_error;
      SCP_ATTR_IDX(curr_scp_idx)	= attr_idx;
      message				= 0;

      if (no_name_entry) {

         /* This routine was called to handle a missing PROGRAM statement. */
         /* TOKEN has been set to main_token and is $MAIN.  The ntr caused */
         /* $MAIN to be in the name_pool twice.  That shouldn't cause      */
         /* problems.  The 2nd attr entry is deleted.  Needed to call      */
         /* ntr_sym_tbl to get name into the local name table.             */

         has_task_dirs = ATP_HAS_TASK_DIRS(glb_tbl_idx[Main_Attr_Idx]);
         attr_idx			= glb_tbl_idx[Main_Attr_Idx];
#ifdef KEY /* Bug 8261 */
         AT_DEF_LINE(attr_idx)		= TOKEN_LINE(*token);
         AT_DEF_COLUMN(attr_idx)	= TOKEN_COLUMN(*token);
         AT_NAME_LEN(attr_idx)		= TOKEN_LEN(*token);
#else /* KEY Bug 8261 */
         AT_DEF_LINE(attr_idx)		= TOKEN_LINE(token);
         AT_DEF_COLUMN(attr_idx)	= TOKEN_COLUMN(token);
         AT_NAME_LEN(attr_idx)		= TOKEN_LEN(token);
#endif /* KEY Bug 8261 */
         AT_NAME_IDX(attr_idx)		= LN_NAME_IDX(name_idx);
         AT_DEFINED(attr_idx)		= TRUE;
         LN_ATTR_IDX(name_idx)		= attr_idx;
         SCP_ATTR_IDX(curr_scp_idx)	= attr_idx;
         attr_tbl_idx--;                /* Delete the new $MAIN attr, use old */
         attr_aux_tbl_idx--;            /* Delete the new $MAIN attr, use old */

         if (++num_no_name_entry == 2) {
            message     = 1003;   /* Issue for 2nd unnamed pgm unit only */
         }
         else if (++num_main_program == 2) {
            message     = 1009;  /* Issue for 2nd pgm unit only */
         }
      }
      else if (pgm_type == Program && ++num_main_program == 2) {
         message        = 1009;  /* Issue for 2nd pgm unit only */
      }

      if (message != 0 && !parse_error) {

         if (*defer_msg > 0) {
            *defer_msg = message;
         }
         else if (!parse_error) {

#ifdef KEY /* Bug 8261 */
            PRINTMSG(TOKEN_LINE(*token), message, 
# if defined(_ERROR_DUPLICATE_GLOBALS)
                     Error, 
# else
                     Warning,
# endif
                     TOKEN_COLUMN(*token));
#else /* KEY Bug 8261 */
            PRINTMSG(TOKEN_LINE(token), message, 
# if defined(_ERROR_DUPLICATE_GLOBALS)
                     Error, 
# else
                     Warning,
# endif
                     TOKEN_COLUMN(token));
#endif /* KEY Bug 8261 */
         }
      }
   }
   else if (pgm_type == Function) {
      SCP_ATTR_IDX(curr_scp_idx)	= attr_idx;

      /* CHARACTER*(BAD) FUNCTION BAD()   - illegal - Cannot have been found  */

#ifdef KEY /* Bug 8261 */
      PRINTMSG(TOKEN_LINE(*token), 666, Error, TOKEN_COLUMN(*token),
               AT_OBJ_NAME_PTR(attr_idx));
      CREATE_ERR_ATTR(attr_idx, TOKEN_LINE(*token),
                      TOKEN_COLUMN(*token), Pgm_Unit);
#else /* KEY Bug 8261 */
      PRINTMSG(TOKEN_LINE(token), 666, Error, TOKEN_COLUMN(token),
               AT_OBJ_NAME_PTR(attr_idx));
      CREATE_ERR_ATTR(attr_idx, TOKEN_LINE(token),
                      TOKEN_COLUMN(token), Pgm_Unit);
#endif /* KEY Bug 8261 */
      SCP_IN_ERR(curr_scp_idx)		= TRUE;
      SCP_ATTR_IDX(curr_scp_idx)	= attr_idx;
   }
   else {
      SCP_ATTR_IDX(curr_scp_idx)	= attr_idx;

      if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
          ATD_CLASS(attr_idx) == Variable &&
          ATD_SYMBOLIC_CONSTANT(attr_idx)) {
      }
      else {
#ifdef KEY /* Bug 8261 */
         PRINTMSG(TOKEN_LINE(*token), 180, Internal, TOKEN_COLUMN(*token),
                  TOKEN_STR(*token), "attr_tbl");
#else /* KEY Bug 8261 */
         PRINTMSG(TOKEN_LINE(token), 180, Internal, TOKEN_COLUMN(token),
                  TOKEN_STR(token), "attr_tbl");
#endif /* KEY Bug 8261 */
      }
   }

   LN_DEF_LOC(name_idx)		= TRUE;
   AT_OBJ_CLASS(attr_idx)	= Pgm_Unit;
   ATP_PGM_UNIT(attr_idx)	= pgm_type;			      
   ATP_HAS_TASK_DIRS(attr_idx)  = has_task_dirs;

#ifdef KEY /* Bug 5089 */
   /* F2003 intrinsic module needs to avoid collision with like-named
    * nonintrinsic (user-created) module when generating linker symbols */
   if (on_off_flags.intrinsic_module_gen &&
     Pgm_Unit == AT_OBJ_CLASS(attr_idx) && Module == ATP_PGM_UNIT(attr_idx)) {
     AT_IS_INTRIN(attr_idx) = TRUE;
   }
#endif /* KEY Bug 5089 */

   MAKE_EXTERNAL_NAME(attr_idx, AT_NAME_IDX(attr_idx), AT_NAME_LEN(attr_idx));

   ATP_SCP_ALIVE(attr_idx)	= TRUE;
   ATP_EXPL_ITRFC(attr_idx)     = TRUE;
   ATP_PP_ABSTRACT(attr_idx)	= abstract_flag;
   ATP_SCP_IDX(attr_idx)	= curr_scp_idx;

   if (cif_flags  &&  pgm_type == Program) {
      AT_CIF_SYMBOL_ID(attr_idx) = 2;       /* Reserved for name of main pgm. */
   }

   ATP_MAY_INLINE(attr_idx)	= opt_flags.modinline || 
				  (pgm_type != Module && dump_flags.preinline);
   if (pgm_type <= Program) {
      NTR_IR_TBL(ir_idx);
      IR_OPR(ir_idx)		= Entry_Opr; 
      IR_TYPE_IDX(ir_idx)       = TYPELESS_DEFAULT_TYPE;
#ifdef KEY /* Bug 8261 */
      IR_LINE_NUM(ir_idx)	= TOKEN_LINE(*token);
      IR_COL_NUM(ir_idx)	= TOKEN_COLUMN(*token);
#else /* KEY Bug 8261 */
      IR_LINE_NUM(ir_idx)	= TOKEN_LINE(token);
      IR_COL_NUM(ir_idx)	= TOKEN_COLUMN(token);
#endif /* KEY Bug 8261 */
      IR_FLD_L(ir_idx)		= AT_Tbl_Idx;
      IR_IDX_L(ir_idx)		= attr_idx;
#ifdef KEY /* Bug 8261 */
      IR_COL_NUM_L(ir_idx)	= TOKEN_COLUMN(*token);
      IR_LINE_NUM_L(ir_idx)	= TOKEN_LINE(*token);
#else /* KEY Bug 8261 */
      IR_COL_NUM_L(ir_idx)	= TOKEN_COLUMN(token);
      IR_LINE_NUM_L(ir_idx)	= TOKEN_LINE(token);
#endif /* KEY Bug 8261 */

      if (no_name_entry ) {

         /* Need to have a statement header for this MAIN entry, before    */
         /* the first statement header of the program.  curr_stmt_sh_idx   */
         /* may not be the first SH, because some statements generate more */
         /* than one SH, so save curr_stmt_sh_idx, set it to the first SH, */
         /* call gen_sh, and then restore curr_stmt_sh_idx.  If gen_sh     */
         /* called with the Before option ever messes with curr_stmt_sh_idx*/
         /* this could cause troubles.                                     */

         save_sh_idx		= curr_stmt_sh_idx;
         curr_stmt_sh_idx	= SCP_FIRST_SH_IDX(curr_scp_idx);

         gen_sh(Before,
                Program_Stmt,
                stmt_start_line,
                stmt_start_col,
                FALSE,               /* No Errors                    */
                FALSE,               /* Not labeled                  */
                TRUE);               /* Compiler generated statement */

         SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))    = ir_idx;
         curr_stmt_sh_idx            = SCP_FIRST_SH_IDX(curr_scp_idx);

         if (cmd_line_flags.debug_lvl <= Debug_Lvl_1) {  /* -ez -ed -G0 -G1  */
            gen_end_prologue_debug_label(attr_idx);
         }

         curr_stmt_sh_idx    = save_sh_idx;
      }
      else {
         SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;

         if (cmd_line_flags.debug_lvl <= Debug_Lvl_1) {  /* -ez -ed  -G0 -G1 */
            gen_end_prologue_debug_label(attr_idx);
         }
      }
   }

   /* The @DATA block needs to be renamed to @DATA_in_PGM_UNIT_NAME.     */

   sb_idx		= SCP_SB_STATIC_IDX(curr_scp_idx);
   SB_NAME_IDX(sb_idx)	= make_in_parent_string(SB_NAME_IDX(sb_idx),
                                                SB_NAME_LEN(sb_idx),
                                                curr_scp_idx,
                                                &length);
   SB_NAME_LEN(sb_idx)	= length;

   if (sb_idx != SCP_SB_STATIC_INIT_IDX(curr_scp_idx)) {
      sb_idx               = SCP_SB_STATIC_INIT_IDX(curr_scp_idx);
      SB_NAME_IDX(sb_idx)  = make_in_parent_string(SB_NAME_IDX(sb_idx),
                                                   SB_NAME_LEN(sb_idx),
                                                   curr_scp_idx,
                                                   &length);
      SB_NAME_LEN(sb_idx)  = length;
   }

   if (sb_idx != SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx)) {
      sb_idx               = SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx);
      SB_NAME_IDX(sb_idx)  = make_in_parent_string(SB_NAME_IDX(sb_idx),
                                                   SB_NAME_LEN(sb_idx),
                                                   curr_scp_idx,
                                                   &length);
      SB_NAME_LEN(sb_idx)  = length;
   }

   CURR_BLK		= blk_type;
   CURR_BLK_NAME	= attr_idx;		           
   CURR_BLK_DEF_LINE	= stmt_start_line;
   CURR_BLK_DEF_COLUMN	= stmt_start_col;

   if (cif_flags & XREF_RECS) {
      cif_usage_rec(attr_idx,
                    AT_Tbl_Idx,
#ifdef KEY /* Bug 8261 */
                    TOKEN_LINE(*token),
                    TOKEN_COLUMN(*token),
#else /* KEY Bug 8261 */
                    TOKEN_LINE(token),
                    TOKEN_COLUMN(token),
#endif /* KEY Bug 8261 */
                    CIF_Symbol_Declaration);
   }

   if (!no_name_entry) {

      /* If this is an unnamed program unit, implicit_use_semantics */
      /* was called in parse_prog_unit in p_driver.                 */

      implicit_use_semantics();
   }

   TRACE (Func_Exit, "start_new_prog_unit", NULL);

   return(attr_idx);

}  /* start_new_prog_unit */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*      BNF     - [ prefix ] FUNCTION function-name                           *|
|*                                   ( [ dummy-arg-name-list ] )              *|
|*                                   [ RESULT ( result-name ) ]               *|
|*                                                                            *|
|*      prefix  -    type-spec [ RECURSIVE ]                                  *|
|*                or RECURSIVE [ type-spec ]				      *|
|*									      *|
|*      At entry, if AT_TYPED in AT_WORK_IDX is FALSE, the type needs to be  *|
|*                parsed and we need to do error checks for the keyword       *|
|*                FUNCTION.  If AT_TYPED in TRUE, the type is in AT_WORK_IDX *|
|*                and LA_CH is set to pick up the ID.  The FUNCTION keyword   *|
|*                has been verified.                                          *|
|*      Must be in correct context when this routine is called.               *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/
void parse_typed_function_stmt()

{
   boolean	assumed_size_ch	= FALSE;
   int		attr_idx;
   int		defer_msg;
   boolean	elemental_set;
   boolean	err_fnd		= FALSE;
   char		err_str[45];
   int		idx;
   int		local_scp_idx	= curr_scp_idx;
   boolean	matched;
   int		interface_idx;
   boolean	pure_set;
   boolean	recursive_set;
   int		rslt_idx;
   int		stmt_number;
   boolean	type_err;
#ifdef KEY /* Bug 8261 */
   token_type   saved_id;
   boolean      use_saved_id = FALSE;
#endif /* KEY Bug 8261 */

   TRACE (Func_Entry, "parse_typed_function_stmt", NULL);

   stmt_type				= Function_Stmt;
   SH_STMT_TYPE(curr_stmt_sh_idx)	= Function_Stmt;
   stmt_number				= statement_number;

   if (curr_stmt_category == Sub_Func_Stmt_Cat) {

      /* Save the starting indexes of all the tables, to be used when         */
      /* collapsing the interface stuff back into the parent scope.           */


      if (CURR_BLK == Interface_Blk) {
         interface_idx	= CURR_BLK_NAME;

         if (interface_idx == NULL_IDX) {
            interface_idx = BLK_UNNAMED_INTERFACE(blk_stk_idx);
         }

         ATI_HAS_NON_MOD_PROC(interface_idx)       = TRUE;

         /* This assumes that the attr table is always initialized with */
         /* some kind of entries at start up.                           */

         if (BLK_AT_IDX(blk_stk_idx) == NULL_IDX) {
            BLK_AT_IDX(blk_stk_idx)	= attr_tbl_idx;
            BLK_BD_IDX(blk_stk_idx)	= bounds_tbl_idx;
            BLK_CN_IDX(blk_stk_idx)	= const_tbl_idx;
            BLK_CP_IDX(blk_stk_idx)	= const_pool_idx;
            BLK_NP_IDX(blk_stk_idx)	= name_pool_idx;
            BLK_SB_IDX(blk_stk_idx)	= stor_blk_tbl_idx;
            BLK_SN_IDX(blk_stk_idx)	= sec_name_tbl_idx;
            BLK_TYP_IDX(blk_stk_idx)	= type_tbl_idx;
         }
      }

      /* Create a scope for this contained routine, but leave curr_scp_idx    */
      /* still pointing to parent's scope.  After calling start_new_subpgm,   */
      /* curr_scp_idx will be set correctly.                                  */

      start_new_scp();
      curr_scp_idx	= SCP_PARENT_IDX(curr_scp_idx);
   }

   if (AT_OBJ_CLASS(AT_WORK_IDX) == Pgm_Unit) {

      /* Control came in from parse_prefix_spec.  Type has not been processed */
      /* yet.  Only recusive, pure and/or elemental have been seen.  Need to  */
      /* save these, becase parse_type_spec will clear AT_WORK_IDX.           */

      err_fnd		= AT_DCL_ERR(AT_WORK_IDX);
      recursive_set	= ATP_RECURSIVE(AT_WORK_IDX);
      elemental_set	= ATP_ELEMENTAL(AT_WORK_IDX);
      pure_set		= ATP_PURE(AT_WORK_IDX);
   }
   else {
      recursive_set	= FALSE;
      elemental_set	= FALSE;
      pure_set		= FALSE;
   }

   if (AT_TYPED(AT_WORK_IDX)) {
      type_err	= AT_DCL_ERR(AT_WORK_IDX);
   }
   else {

      /* Will always go through here for internal and module procedures.      */
      /* External procedures will have their type already.                    */
      /* parse_type_spec may use stmt_type to handle derived type host        */
      /* association.  stmt_type will always be Function_Stmt for this call.  */

      if (curr_stmt_category == Sub_Func_Stmt_Cat) {

         /* Set scope to new scope, so that type info goes into correct scope.*/
         /* Set SCP_ATTR_IDX so that messages are correct.                    */
         /* The current scope becomes the new scope created at entry to this  */
         /* routine.  It doesn't have an attribute yet, because we haven't    */
         /* parsed the name, so we set the name to the parent for now.        */

         curr_scp_idx		    =SCP_LAST_CHILD_IDX(curr_scp_idx);
         SCP_ATTR_IDX(curr_scp_idx) =SCP_ATTR_IDX(SCP_PARENT_IDX(curr_scp_idx));
      }

      type_err	= !parse_type_spec(TRUE, FALSE, TRUE); /* TRUE - Check for kind type. */
      err_fnd	= type_err;

      if (curr_stmt_category == Sub_Func_Stmt_Cat) {

         /* Set scope back to parent, for call to start_new_subpgm */

         local_scp_idx	= curr_scp_idx;
         curr_scp_idx	= SCP_PARENT_IDX(curr_scp_idx);
      }
   }

   while (matched = MATCHED_TOKEN_CLASS(Tok_Class_Keyword)) {

      switch (TOKEN_VALUE(token)) {
      case Tok_Kwd_Recursive:

         if (elemental_set) {

            /* RECURSIVE and ELEMENTAL should not be set for same subprogram */

            PRINTMSG(TOKEN_LINE(token), 1261, Error, TOKEN_COLUMN(token));
            err_fnd	= TRUE;
         }
         else if (recursive_set) {  /* Duplicate declaration */
            PRINTMSG(TOKEN_LINE(token), 1260, Error, TOKEN_COLUMN(token),
                     "RECURSIVE");
            err_fnd	= TRUE;
         }
         else {
            recursive_set	= TRUE;
         }
         continue;

      case Tok_Kwd_Elemental:

         if (recursive_set) {

            /* RECURSIVE and ELEMENTAL should not be set for same subprogram */

            PRINTMSG(TOKEN_LINE(token), 1261, Error, TOKEN_COLUMN(token));
            err_fnd	= TRUE;
         }
         else if (elemental_set) {  /* Duplicate declaration */
            PRINTMSG(TOKEN_LINE(token), 1260, Error, TOKEN_COLUMN(token),
                     "ELEMENTAL");
            err_fnd	= TRUE;
         }
         else {
            elemental_set	= TRUE;
         }
         continue;

      case Tok_Kwd_Pure:

         if (pure_set) {  /* Duplicate declaration */
            PRINTMSG(TOKEN_LINE(token), 1260, Error, TOKEN_COLUMN(token),
                     "PURE");
            err_fnd	= TRUE;
         }
         pure_set	= TRUE;
         continue;

      case Tok_Kwd_Function:

         if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
            parse_err_flush(Find_Lparen, "function-name");
            token			= main_token;
            TOKEN_LINE(token)		= stmt_start_line;
            TOKEN_COLUMN(token)		= stmt_start_col;
            err_fnd			= TRUE;
         }
#ifdef KEY /* Bug 8261 */
	 /* Extension allows *ddd after the function name, e.g.
	  * "integer function i*ddd()" */
         else if (STAR == LA_CH_VALUE) {
	   saved_id = token;
	   use_saved_id = TRUE;
	   int type_idx = ATD_TYPE_IDX(AT_WORK_IDX);
	   if (Character != TYP_TYPE(type_idx) &&
	      !on_off_flags.issue_ansi_messages) {
	      NEXT_LA_CH;
	      ATD_TYPE_IDX(AT_WORK_IDX) = parse_non_char_kind_selector(FALSE);
	   }
	   else {
	     parse_length_selector(AT_WORK_IDX, FALSE, TRUE);
	     TYP_DESC(TYP_WORK_IDX) = TYP_DESC(type_idx);
	     TYP_DCL_VALUE(TYP_WORK_IDX) = TYP_DCL_VALUE(type_idx);
	     ATD_TYPE_IDX(AT_WORK_IDX) = ntr_type_tbl();
	   }
	 }
#endif /* KEY Bug 8261 */
         break;

      default:
         matched = FALSE;
         reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
         break;
      }
      break;
   }

   if (!matched) {
      err_str[0]	= '\0';

      if (!recursive_set) {
         strcat(err_str, "[RECURSIVE] ");
      }
      if (!elemental_set) {
         strcat(err_str, "[ELEMENTAL] ");
      }
      if (!pure_set) {
         strcat(err_str, "[PURE] ");
      }

      strcat(err_str, "FUNCTION");

      parse_err_flush(Find_EOS, err_str);
      token			= main_token;
      TOKEN_LINE(token)		= stmt_start_line;
      TOKEN_COLUMN(token)	= stmt_start_col;
      err_fnd			= TRUE;
   }

   if (TYP_TYPE(ATD_TYPE_IDX(AT_WORK_IDX)) == Character) {

      if (TYP_CHAR_CLASS(ATD_TYPE_IDX(AT_WORK_IDX)) == Assumed_Size_Char) {
         assumed_size_ch = TRUE;
      }
      else if (TYP_CHAR_CLASS(ATD_TYPE_IDX(AT_WORK_IDX)) == Var_Len_Char ||
               TYP_CHAR_CLASS(ATD_TYPE_IDX(AT_WORK_IDX)) == Unknown_Char) {
      
         /* This is a variable length character.  Go thru the symbol table  */
         /* and mark everything in the local scope as Char_Rslt_Bound_Ref.  */

         for (idx = SCP_LN_FW_IDX(local_scp_idx); 
              idx < SCP_LN_LW_IDX(local_scp_idx); idx++) {
             AT_REFERENCED(LN_ATTR_IDX(idx)) = Char_Rslt_Bound_Ref;
         }
      }
   }

   if (curr_stmt_category != Sub_Func_Stmt_Cat) {
      defer_msg			= 0;
#ifdef KEY /* Bug 8261 */
      attr_idx= start_new_prog_unit_by_token(Function, Function_Blk, FALSE,
	err_fnd, &defer_msg, (use_saved_id ? (&saved_id) : (&token)));
#else /* KEY Bug 8261 */
      attr_idx			= start_new_prog_unit(Function,
                                                      Function_Blk,
                                                      FALSE,
                                                      err_fnd,
                                                      &defer_msg);
#endif /* KEY Bug 8422 */
      ATP_PROC(attr_idx)	= Extern_Proc;
   }
   else {
      attr_idx			= start_new_subpgm(Function, err_fnd, FALSE);
   }

   if (assumed_size_ch) {  /* Obsolescent */
      PRINTMSG(AT_DEF_LINE(attr_idx), 1565,
#ifdef KEY /* Bug 318, 321 */
	       Ansi,
#else /* KEY Bug 318, 321 */
	       Comment,
#endif /* KEY Bug 318, 321 */
               AT_DEF_COLUMN(attr_idx));

      if (ATP_PROC(attr_idx) == Intern_Proc ||
         ATP_PROC(attr_idx) == Module_Proc) {

         /* An internal or module procedure cannot be assumed size char. */
         /* Allow it to be character for error recovery.                 */

         PRINTMSG(AT_DEF_LINE(attr_idx), 367, Error,
                  AT_DEF_COLUMN(attr_idx),
                  AT_OBJ_NAME_PTR(attr_idx));
         AT_DCL_ERR(attr_idx)		= TRUE;
         ATD_TYPE_IDX(AT_WORK_IDX)	= CHARACTER_DEFAULT_TYPE;
      }
      else if (CURR_BLK == Interface_Body_Blk) {

         /* An interface block may be typed as assumed size character */
         /* but it cannot be invoked.                                 */

         PRINTMSG(AT_DEF_LINE(attr_idx), 1566, Warning,
                  AT_DEF_COLUMN(attr_idx),
                  AT_OBJ_NAME_PTR(attr_idx));
      }
      else if (recursive_set) { /* Recursive is not allowed to be assumed size*/
                                /* char.  Allow it to be char for err recovery*/
         PRINTMSG(AT_DEF_LINE(attr_idx), 506, Error,
                  AT_DEF_COLUMN(attr_idx),
                  AT_OBJ_NAME_PTR(attr_idx));
         AT_DCL_ERR(attr_idx)		= TRUE;
         ATD_TYPE_IDX(AT_WORK_IDX)	= CHARACTER_DEFAULT_TYPE;
      }
   }

   if ((cif_flags & MISC_RECS)  &&  ! err_fnd) {
      cif_stmt_type_rec(TRUE, CIF_Function_Stmt, stmt_number);
   }

   SCP_IN_ERR(curr_scp_idx)			= AT_DCL_ERR(attr_idx);
   SCP_IN_ERR(SCP_PARENT_IDX(curr_scp_idx))	= AT_DCL_ERR(attr_idx);
   CURR_BLK_ERR					= AT_DCL_ERR(attr_idx);
   ATP_RECURSIVE(attr_idx)			= recursive_set;
   ATP_ELEMENTAL(attr_idx)			= elemental_set;
   ATP_PURE(attr_idx)				= pure_set;

   if (CURR_BLK != Interface_Body_Blk &&
       (cmd_line_flags.runtime_argument ||
        cmd_line_flags.runtime_arg_entry)) {

      ATP_ARGCHCK_ENTRY(attr_idx) = TRUE;
   }

   /* If there was no FUNCTION keyword - careful on further messages. */

   if (LA_CH_VALUE == LPAREN || (!err_fnd &&
                                  parse_err_flush(Find_Lparen, "(") )) {
      parse_dummy_args(attr_idx);
   }

   set_function_rslt(attr_idx, type_err);

   rslt_idx			= ATP_RSLT_IDX(attr_idx);
   AT_TYPED(rslt_idx)		= TRUE;
   ATD_TYPE_IDX(rslt_idx)	= ATD_TYPE_IDX(AT_WORK_IDX);

#ifdef KEY
// Bug 2164
   if (AT_OBJ_CLASS(rslt_idx) == Data_Obj && !AT_IS_INTRIN(rslt_idx) &&
       TYP_LINEAR(ATD_TYPE_IDX(rslt_idx)) == Real_4 &&
       Check_FF2C_Script(AT_OBJ_NAME_PTR(rslt_idx), 0) )
   {
     ATD_TYPE_IDX(rslt_idx) = Real_8;
   }
#endif
   if (LA_CH_VALUE != EOS) {
      parse_err_flush(Find_EOS, EOS_STR);
   }

   NEXT_LA_CH;

   TRACE (Func_Exit, "parse_typed_function_stmt", NULL);

   return;

}  /* parse_typed_function_stmt */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This routine starts a new scope.  New scopes are started whenever a   *|
|*      FUNCTION or SUBROUTINE is found, that is inside a contains or an      *|
|*      interface block.  The interface statement does NOT cause a new scope  *|
|*      scope to start.  This routine links the new scope into the scope      *|
|*      table and the sibling/parent lists.  It also sets the implicit table  *|
|*      for the new scope.  The statement header list is updated.  The        *|
|*      parent's last statement header next index is set to NULL, so that     *|
|*      this new scopes IR is not linked to the old scopes IR.   It is        *|
|*      called by an internal, interface, or contains FUNCTION or SUBROUTINE. *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NONE								      *|
|*									      *|
\******************************************************************************/

static void start_new_scp(void)

{
   int    	first_sh_idx;
   int		idx;
   int		name_idx;
   int		npes_attr;
   token_type	npes_token;
   int		parent_idx;
   int		parent_name_idx;
   int		save_scp;


   TRACE (Func_Entry, "start_new_scp", NULL);

   parent_idx				= curr_scp_idx;
   NTR_SCP_TBL(curr_scp_idx);

   /* Insert new scope at the end of the parent's child list */

   if (SCP_FIRST_CHILD_IDX(parent_idx) == NULL_IDX) {
      SCP_FIRST_CHILD_IDX(parent_idx) = curr_scp_idx;
   }
   else {
      SCP_SIBLING_IDX(SCP_LAST_CHILD_IDX(parent_idx)) = curr_scp_idx;
   }

   SCP_LAST_CHILD_IDX(parent_idx)       = curr_scp_idx;
   SCP_NUM_CHILDREN(parent_idx)		= SCP_NUM_CHILDREN(parent_idx) + 1;
   SCP_PARENT_IDX(curr_scp_idx)		= parent_idx;
   SCP_LEVEL(curr_scp_idx)		= SCP_LEVEL(parent_idx) + 1;
   SCP_IMPL_NONE(curr_scp_idx)		= FALSE;

   /* If this statement is labeled - it has 2 statement headers, so need to   */
   /* back up to the first statement header.   If the statement is not        */
   /* labeled, curr_stmt_sh_idx points to the first statement header for this */
   /* statement.                                                              */

   first_sh_idx = SH_LABELED(curr_stmt_sh_idx) ? SH_PREV_IDX(curr_stmt_sh_idx) :
                                                 curr_stmt_sh_idx;

   SCP_FIRST_SH_IDX(curr_scp_idx)	= first_sh_idx;

   /* Break the linkage between the previous Statement Header (of the host   */
   /* scoping unit) and the current subprogram Statement Header.             */

   SCP_LAST_SH_IDX(parent_idx)			= SH_PREV_IDX(first_sh_idx);
   SH_PREV_IDX(first_sh_idx)			= NULL_IDX;
   SH_NEXT_IDX(SH_PREV_IDX(first_sh_idx))	= NULL_IDX;

   /* Reset ln and sb first and last words.  TRUE -> Also, do storage table  */

   init_name_and_stor_tbls(curr_scp_idx, TRUE);  

   if (CURR_BLK == Interface_Blk) {
      SCP_PARENT_NONE(curr_scp_idx)	= FALSE;
      SCP_IS_INTERFACE(curr_scp_idx)	= TRUE;

      /* Initialize to reflect the default table setting, not the parent's */

      for (idx = 0; idx < MAX_IMPL_CHS; idx++) {
         IM_TYPE_IDX(curr_scp_idx, idx)	= REAL_DEFAULT_TYPE;
         IM_SET(curr_scp_idx, idx)	= FALSE;
      }

      for (idx = IMPL_IDX('I'); idx <= IMPL_IDX('N'); idx++) {
         IM_TYPE_IDX(curr_scp_idx, idx)	= INTEGER_DEFAULT_TYPE;
      }

      /* After an interface block is processed, the only thing left on the  */
      /* stack should be compiler tmps and the function result.  These need */
      /* to go on the parent's stack, so by setting the parent's stack as   */
      /* the default stack, they get there by default.  Compression of      */
      /* interface blocks will remove things put on the stack that are not  */
      /* needed.                                                            */

      SCP_SB_STACK_IDX(curr_scp_idx)	= SCP_SB_STACK_IDX(parent_idx);

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

      /* Set the scope for the darg block to the parent scope. */

      SB_SCP_IDX(SCP_SB_DARG_IDX(curr_scp_idx)) =
                     SB_SCP_IDX(SCP_SB_DARG_IDX(parent_idx));
# endif

   }
   else { /* Use parent's implicit settings - accumulate IMPLICIT NONE's */
      SCP_PARENT_NONE(curr_scp_idx)		= SCP_IMPL_NONE(parent_idx) ||
                                                  SCP_PARENT_NONE(parent_idx);

      for (idx = 0; idx < MAX_IMPL_CHS; idx++) {
      /* IM_SET(curr_scp_idx, idx)		= FALSE;  ntr_scp_tbl clears */
         IM_TYPE_IDX(curr_scp_idx, idx) 	= IM_TYPE_IDX(parent_idx, idx);
      }
   }

   /* Add N$PES to the new scope. */

   CREATE_ID(TOKEN_ID(npes_token), "N$PES", 5);

   TOKEN_COLUMN(npes_token)	= 1;
   TOKEN_LEN(npes_token)	= 5;
   TOKEN_LINE(npes_token)	= stmt_start_line;
   npes_attr			= srch_sym_tbl(TOKEN_STR(npes_token),
                                               TOKEN_LEN(npes_token),
                                               &name_idx);
   npes_attr			= ntr_sym_tbl(&npes_token,name_idx);
   LN_DEF_LOC(name_idx)		= TRUE;
   save_scp			= curr_scp_idx;
   curr_scp_idx			= parent_idx;
   npes_attr			= srch_sym_tbl(TOKEN_STR(npes_token),
                                               TOKEN_LEN(npes_token),
                                               &parent_name_idx);

   /* Assumption is that we will always find it. */

   LN_ATTR_IDX(name_idx)	= npes_attr;
   LN_NAME_IDX(name_idx)	= AT_NAME_IDX(npes_attr);
   curr_scp_idx			= save_scp;

   TRACE (Func_Exit, "start_new_scp", NULL);

   return;

}  /* start_new_scp */
