p_dcl_pu.c

Go to the documentation of this file.

/*

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

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

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

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

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

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

  http://www.sgi.com

  For further information regarding this notice, see:

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

*/



static char USMID[] = "\n@(#)5.0_pl/sources/p_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"


/*****************************************************************\
|* 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) = AT_NAME_IDX(attr_idx);  
          
         ATP_EXT_NAME_LEN(attr_idx)     = AT_NAME_LEN(attr_idx);
      }
      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;
   boolean              is_coarray_concurrent = FALSE;


   TRACE (Func_Entry, "parse_function_stmt", NULL);

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

   /* FMZ */    
   if (strncmp(token.token_str.string,"COFUNCTI",8)==0) 
      is_coarray_concurrent = TRUE;

   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 (is_coarray_concurrent)
      ATP_COARRAY_CONCURRENT(attr_idx)=TRUE; 

   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);
                  COPY_COMMON_ATTR_INFO(attr_idx, tmp_attr_idx, Pgm_Unit);
                  AT_IS_INTRIN(attr_idx)        = FALSE;
                  AT_ELEMENTAL_INTRIN(attr_idx) = FALSE;
                  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 ||
       TOKEN_VALUE(token) == Tok_Kwd_CoSubroutine) {
      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 ||
            TOKEN_VALUE(token) == Tok_Kwd_CoFunction) {
      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;
   boolean      is_coarray_concurrent = FALSE;



   TRACE (Func_Entry, "parse_subroutine_stmt", NULL);

   if (curr_stmt_category > Sub_Func_Stmt_Cat) {
      iss_blk_stk_err();
      err_fnd                   = TRUE;
   } 
   
   /* FMZ */    
   if (strncmp(token.token_str.string,"COSUBROUTI",10)==0) 
      is_coarray_concurrent = 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);
   }

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

   if (is_coarray_concurrent)
      ATP_COARRAY_CONCURRENT(attr_idx)=TRUE;

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

}  /* parse_subroutine_stmt */

/******************************************************************************\
|*                                                                            *|
|* 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                  name_idx;
   int                  rslt_idx        = NULL_IDX;
   token_type           save_token;


   TRACE (Func_Entry, "set_function_rslt", NULL);

   if (LA_CH_VALUE != EOS) {            /* Check for RESULT */

      if (!matched_specific_token(Tok_Kwd_Result, Tok_Class_Keyword)) {
         parse_err_flush(Find_EOS, "RESULT or " EOS_STR);
         err_found = TRUE;
      }
      else 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;
         }
      } 
   }

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

      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;
# ifdef SOURCE_TO_SOURCE 
         proc_type              = Intern_Proc;
# else
         proc_type              = Module_Proc;
#endif


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

   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. */
         }

         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 */

# if 0 /* March ,keep original name */

      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;
# endif

      ATP_EXT_NAME_IDX(attr_idx) = AT_NAME_IDX(attr_idx);  
      ATP_EXT_NAME_LEN(attr_idx)     = AT_NAME_LEN(attr_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_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.                          *|
|*                                                                            *|
\******************************************************************************/

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)

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

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

   if (attr_idx == NULL_IDX) {
      attr_idx                          = ntr_sym_tbl(&token, name_idx);
      AT_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];
         AT_DEF_LINE(attr_idx)          = TOKEN_LINE(token);
         AT_DEF_COLUMN(attr_idx)        = TOKEN_COLUMN(token);
         AT_NAME_LEN(attr_idx)          = TOKEN_LEN(token);
         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) {

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

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

      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);
      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 {
         PRINTMSG(TOKEN_LINE(token), 180, Internal, TOKEN_COLUMN(token),
                  TOKEN_STR(token), "attr_tbl");
      }
   }

   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;

   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_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;
      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 (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,
                    TOKEN_LINE(token),
                    TOKEN_COLUMN(token),
                    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;


   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);  /* 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;
         }
         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;
      attr_idx                  = start_new_prog_unit(Function,
                                                      Function_Blk,
                                                      FALSE,
                                                      err_fnd,
                                                      &defer_msg);
      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, Comment,
               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);

   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(GENERATE_WHIRL)

      /* 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 */