s_driver.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/s_driver.c  5.13    10/26/99 13:48:21\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 "s_globals.m"
# include "debug.m"

# include "globals.h"
# include "tokens.h"
# include "sytb.h"
# include "s_globals.h"
# include "s_driver.h"


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

static void     attr_link_resolution(void);
static void     check_and_allocate_common_storage(int);
static boolean  compare_global_args(int, int, int, int, int);
static boolean  compare_global_array(int, int, int);
static boolean  compare_global_derived_type(int, int, int);
static boolean  compare_global_type_rank(int, int, int, int, boolean);
static void     decl_semantics_driver(void);
static void     free_stmt_tmp_tbl(void);
static void     final_attr_semantics(int);
static void     final_decl_semantics(void);
static void     final_equivalence_semantics(void);
static void     find_host_associated_attrs_in_il(int);
static void     find_host_associated_attrs_in_ir(int);
static void     init_call_structs(void);
static void     pgm_unit_semantics(void);
static void     reset_stmt_tmp_tbl(void);
static void     storage_blk_resolution(void);

# if defined(GENERATE_WHIRL)
static void     gen_user_code_start_opr(void);
static void     insert_global_sh(void);
# endif

# ifdef _SEPARATE_FUNCTION_RETURNS
static void     check_multiple_entry_func(void);
# endif


/***********************************\
|* Globals used only in this file  *|
\***********************************/

static  int     symbolic_constant_array_list;


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This procedure is the semantics pass driver.                          *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
|* Algorithm note:                                                            *|
|*      The global variable curr_scp_idx is saved and restored so that it can *|
|*      be used by the Semantics Pass routines and other utility routines     *|
|*      are used by both passes.                                              *|
|*                                                                            *|
\******************************************************************************/

void semantics_pass_driver (void)

{
   int          save_curr_scp_idx;
   

   TRACE (Func_Entry, "semantics_pass_driver", NULL);

   /*  init_semantics_pass();  */

   init_call_structs();

   reset_stmt_tmp_tbl();

   /* reinitialize cdir_switches */

   init_directive(2);

   save_curr_scp_idx    = curr_scp_idx;
   pgm_unit_start_line  = SH_GLB_LINE(SCP_FIRST_SH_IDX(curr_scp_idx));

   decl_semantics_driver();

   curr_scp_idx = save_curr_scp_idx;

# if defined(GENERATE_WHIRL)
   if (insert_global_directives &&
       global_stmt_sh_idx != NULL_IDX) {

      insert_global_sh();
   }
# endif
   pgm_unit_semantics();

   curr_scp_idx = save_curr_scp_idx;

   PRINT_EQV_TBL;

   TBL_FREE(equiv_tbl);

   /* free up the call site tables */

   if (arg_list != NULL) {
      MEM_FREE(arg_list);
      arg_list          = NULL;
      arg_list_size     = 0;
   }

   if (arg_info_list != NULL) {
      MEM_FREE(arg_info_list);
      arg_info_list     = NULL;
      arg_info_list_size        = 0;
   }

   /* free up the derived type compare table. */

   if (dt_cmp_tbl != NULL) {
      MEM_FREE(dt_cmp_tbl);
      dt_cmp_tbl        = NULL;
   }

   TRACE (Func_Exit, "semantics_pass_driver", NULL);

   return;

}  /*  semantics_pass_driver  */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This procedure visits all SCP entries for the current scope and any   *|
|*      contained scopes.  It drives the semantic analysis of all statements  *|
|*      by calling a semantic routine for each statement type (if the State-  *|
|*      ment Header is not marked in error).                                  *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
|* Algorithm note:                                                            *|
|*      If the current scope contains a child scope, this procedure is called *|
|*      recursively to process the child's statements.  However, if the       *|
|*      current scope has a sibling scope, the statements are processed by    *|
|*      simply jumping to the top of this procedure.  Recursion is not used   *|
|*      for sibling scopes in order to reduce recursion on anticipated large  *|
|*      modules that implement programming libraries with many module         *|
|*      procedures in a single module (see for example the ISO Varying String *|
|*      Module).                                                              *|
|*                                                                            *|
\******************************************************************************/

static void pgm_unit_semantics (void)

{
   boolean      actual_arg;
   boolean      func_defined;
   boolean      func_ptr_defined;
   int          idx;
   boolean      inline_it;
   boolean      is_function;
   int          pgm_attr_idx;
   int          save_curr_scp_idx;
   int          sh_idx;


   TRACE (Func_Entry, "pgm_unit_semantics", NULL);

PROCESS_SIBLING:

   TRACE (PU_Start, NULL, "Semantics");

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

   while (idx) {
      ATP_SCP_ALIVE(AL_ATTR_IDX(idx))           = TRUE;
      idx                                       = AL_NEXT_IDX(idx);
   }

   if (! SCP_IN_ERR(curr_scp_idx) ) {

      /* clear out the stmt_tmp_tbl for reusing short lived tmps. */

      free_stmt_tmp_tbl();

      curr_stmt_sh_idx  = SCP_FIRST_SH_IDX(curr_scp_idx);
      comp_phase        = Pass2_Semantics;

      while (curr_stmt_sh_idx != NULL_IDX) {
      
         if (SH_STMT_TYPE(curr_stmt_sh_idx) == Statement_Num_Stmt) {

            /* Set statement_number from the SH_PARENT_BLK_IDX field, get the */
            /* line and column for the last character of a DO loop            */
            /* (stmt_end_line and stmt_end_col are only used to produce the   */
            /* CIF Loop Definition record as of now), and delete the          */
            /* Statement_Number SH.                                           */

            stmt_end_line    = SH_GLB_LINE(curr_stmt_sh_idx);
            stmt_end_col     = SH_COL_NUM(curr_stmt_sh_idx);
            statement_number = SH_PARENT_BLK_IDX(curr_stmt_sh_idx);
            sh_idx = curr_stmt_sh_idx;
            SH_PREV_IDX(SH_NEXT_IDX(sh_idx)) = SH_PREV_IDX(sh_idx);
            SH_NEXT_IDX(SH_PREV_IDX(sh_idx)) = SH_NEXT_IDX(sh_idx);
            curr_stmt_sh_idx = SH_NEXT_IDX(sh_idx);
            FREE_SH_NODE(sh_idx);
            continue;
         }

         TRACE_NEW_STMT ("Semantics");

         sh_idx = curr_stmt_sh_idx;

         if (!SH_ERR_FLG(curr_stmt_sh_idx)     &&
             !SH_P2_SKIP_ME(curr_stmt_sh_idx)) {
            stmt_type       = SH_STMT_TYPE(curr_stmt_sh_idx);
            stmt_start_line = SH_GLB_LINE(curr_stmt_sh_idx);
            stmt_start_col  = SH_COL_NUM(curr_stmt_sh_idx);

            (*stmt_semantics[SH_STMT_TYPE(curr_stmt_sh_idx)])();
         }
         else if (SH_STMT_TYPE(curr_stmt_sh_idx) == End_Where_Stmt) {
            /* must go to the end where stmt semantics routine anyway */
            /* since it does clean up for the where block (and nothing*/
            /* else ).                                                */

            stmt_type       = SH_STMT_TYPE(curr_stmt_sh_idx);
            stmt_start_line = SH_GLB_LINE(curr_stmt_sh_idx);
            stmt_start_col  = SH_COL_NUM(curr_stmt_sh_idx);

            (*stmt_semantics[SH_STMT_TYPE(curr_stmt_sh_idx)])();
         }

         /* reset expression descriptor tables to zero */
         
         arg_info_list_base = NULL_IDX;
         arg_info_list_top  = NULL_IDX;

         if (SH_DOALL_LOOP_END(sh_idx)) {
            doall_end_semantics();
         }

         if (SH_LOOP_END(sh_idx)) {
            gen_loop_end_ir();
         }
             
         curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
      }

      final_decl_semantics();

      PRINT_DBG_SYTB;           /* Print scp if SCP_DBG_PRINT_SYTB = TRUE */
      PRINT_DBG_STMT;           /* Print scp if SCP_DBG_PRINT_STMT = TRUE */
   }
   else if (cif_flags & BASIC_RECS) {

      /* CIF still wants output, even if the scope is in error.              */
      /* Check CIF option to see if symbol table needs to be written to CIF. */
      /* Need to use BASIC_RECS to output the Entry Info and Common Block    */
      /* records if the user just specifies "-cf".                           */

      cif_send_sytb();
   }

   if (SCP_FIRST_CHILD_IDX(curr_scp_idx) != NULL_IDX) {
      save_curr_scp_idx         = curr_scp_idx;
      curr_scp_idx              = SCP_FIRST_CHILD_IDX(curr_scp_idx);
      pgm_unit_semantics();
      curr_scp_idx              = save_curr_scp_idx;
   }

   /* if this scope is a function, check if the result var has been defined */
   /* if the function is a pointer, check that the pointer as been assigned */
   /* or allocated.  Clear ATP_SCP_ALIVE.                                   */

   pgm_attr_idx                 = SCP_ATTR_IDX(curr_scp_idx);
   ATP_SCP_ALIVE(pgm_attr_idx)  = FALSE;
   is_function                  = FALSE;

   if (ATP_PGM_UNIT(pgm_attr_idx) == Function  &&
       ! AT_DCL_ERR(pgm_attr_idx)              &&
       ! SCP_IN_ERR(curr_scp_idx))              {

      is_function       = TRUE;
      func_defined      = AT_DEFINED(pgm_attr_idx);
      actual_arg        = AT_ACTUAL_ARG(pgm_attr_idx) || 
                          AT_ACTUAL_ARG(ATP_RSLT_IDX(pgm_attr_idx));
      func_ptr_defined  = ATD_PTR_ASSIGNED(ATP_RSLT_IDX(pgm_attr_idx));
   }

   idx    = SCP_ENTRY_IDX(curr_scp_idx);

   inline_it = (opt_flags.inline_lvl > Inline_Lvl_0) || 
                ATP_MAY_INLINE(pgm_attr_idx);

   /* We keep more ir than we actually write out.  In the case of   */
   /* internal procedures, we want to use the current compile.      */  

   /* KAY  To get rid of the forward reference problem, we need     */
   /* to search for the internal procedures in the inline file,     */
   /* like we do with the module procedures.  We can get the name   */
   /* of the internal procedure's parent from the mangled procedure */
   /* name and search for it and then fill in the ATP_FIRST_SH_IDX. */

   while (idx) {

      if (is_function) {
         func_defined     |= AT_DEFINED(AL_ATTR_IDX(idx));
         actual_arg       |= AT_ACTUAL_ARG(AL_ATTR_IDX(idx)) ||
                             AT_ACTUAL_ARG(ATP_RSLT_IDX(AL_ATTR_IDX(idx)));
         func_ptr_defined |=ATD_PTR_ASSIGNED(ATP_RSLT_IDX(AL_ATTR_IDX(idx)));
      }

      ATP_SCP_ALIVE(AL_ATTR_IDX(idx))    = FALSE;
      ATP_FIRST_SH_IDX(AL_ATTR_IDX(idx)) = (inline_it) ? 
                               SCP_FIRST_SH_IDX(curr_scp_idx) : NULL_IDX;
      idx = AL_NEXT_IDX(idx);
       
   }

   if (is_function && !actual_arg) {

      if (!func_defined) {
         PRINTMSG(AT_DEF_LINE(ATP_RSLT_IDX(pgm_attr_idx)), 287, Warning, 
                  AT_DEF_COLUMN(ATP_RSLT_IDX(pgm_attr_idx)),
                  AT_OBJ_NAME_PTR(ATP_RSLT_IDX(pgm_attr_idx)));
      }
      else if (ATD_POINTER(ATP_RSLT_IDX(pgm_attr_idx)) && !func_ptr_defined){
         PRINTMSG(AT_DEF_LINE(ATP_RSLT_IDX(pgm_attr_idx)), 918, Warning, 
                  AT_DEF_COLUMN(ATP_RSLT_IDX(pgm_attr_idx)),
                  AT_OBJ_NAME_PTR(ATP_RSLT_IDX(pgm_attr_idx)));
      }
   }

   if (ATP_PGM_UNIT(pgm_attr_idx) != Module) {
      ATP_FIRST_SH_IDX(pgm_attr_idx) = inline_it?SCP_FIRST_SH_IDX(curr_scp_idx):
                                                NULL_IDX;
   }

   if (SCP_SIBLING_IDX(curr_scp_idx) != NULL_IDX) {
      curr_scp_idx = SCP_SIBLING_IDX(curr_scp_idx);
      goto PROCESS_SIBLING;
   }

   TRACE (Func_Exit, "pgm_unit_semantics", NULL);

   return;

}  /*  pgm_unit_semantics  */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This is the driver for decl_semantics. All scopes are processed.      *|
|*      NOTE:  The assumption is made that we go from outer scope to inner    *|
|*             scope.  decl_semantics, name resolution and assign storage     *|
|*             all require this.                                              *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

static void decl_semantics_driver(void)

{
   int          idx;
   int          save_curr_scp_idx;

   TRACE (Func_Entry, "decl_semantics_driver", NULL);

PROCESS_SIBLING:

   comp_phase                                   = Decl_Semantics;
   ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx))    = TRUE;
   idx                                          = SCP_ENTRY_IDX(curr_scp_idx);

   while (idx) {
      ATP_SCP_ALIVE(AL_ATTR_IDX(idx))           = TRUE;
      idx                                       = AL_NEXT_IDX(idx);
   }

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

   if (! SCP_IN_ERR(curr_scp_idx) ) {
      attr_link_resolution();
      curr_stmt_sh_idx  = SCP_FIRST_SH_IDX(curr_scp_idx);
      stmt_start_line   = SH_GLB_LINE(curr_stmt_sh_idx);
      stmt_start_col    = SH_COL_NUM(curr_stmt_sh_idx);
      need_new_sh       = TRUE;

      decl_semantics();

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

# ifdef _SEPARATE_FUNCTION_RETURNS
      if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Function &&
          SCP_ALT_ENTRY_CNT(curr_scp_idx) != 0                 &&
          !ATD_IM_A_DOPE(ATP_RSLT_IDX(SCP_ATTR_IDX(curr_scp_idx))) &&
          ATD_ARRAY_IDX(ATP_RSLT_IDX(SCP_ATTR_IDX(curr_scp_idx))) == NULL_IDX &&
          TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(SCP_ATTR_IDX(curr_scp_idx)))) 
                                                      != Structure &&
          TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(SCP_ATTR_IDX(curr_scp_idx)))) 
                                                      != Character) {
 
         check_multiple_entry_func();
      }
# endif

   }

   if (SCP_FIRST_CHILD_IDX(curr_scp_idx) != NULL_IDX) {
      save_curr_scp_idx         = curr_scp_idx;
      curr_scp_idx              = SCP_FIRST_CHILD_IDX(curr_scp_idx);
      decl_semantics_driver();
      curr_scp_idx              = save_curr_scp_idx;
   }

   ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE;

   idx = SCP_ENTRY_IDX(curr_scp_idx);

   while (idx) {

      ATP_SCP_ALIVE(AL_ATTR_IDX(idx))   = FALSE;
      idx                               = AL_NEXT_IDX(idx);
   }

   if (SCP_SIBLING_IDX(curr_scp_idx) != NULL_IDX) {
      curr_scp_idx = SCP_SIBLING_IDX(curr_scp_idx);
      goto PROCESS_SIBLING;
   }


   TRACE (Func_Exit, "decl_semantics_driver", NULL);

   return;

}  /* decl_semantics_driver */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This procedure should never be called.  Its only purpose is to issue  *|
|*      an internal error message if a bad (0) value of curr_stmt_sh_idx is   *|
|*      encountered.                                                          *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void illegal_stmt_type (void)  

{

   TRACE (Func_Entry, "illegal_stmt_type", NULL);

   PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 263, Internal, 0);

   TRACE (Func_Exit, "illegal_stmt_type", NULL);

   return;

}  /* illegal_stmt_type */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This procedure should never be called.  Its only purpose is to issue  *|
|*      an internal error message if a Statement Header is encountered for    *|
|*      which there is no semantic routine.                                   *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void no_semantics_routine (void)

{

   TRACE (Func_Entry, "no_semantics_routine", NULL);

   PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 278, Internal, 0,
            stmt_type_str[stmt_type]);

   TRACE (Func_Exit, "no_semantics_routine", NULL);

   return;

}  /* no_semantics_routine */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This routine goes through the local name table for the current scope. *|
|*      If the name is not locally defined(LN_DEF_LOC = FALSE), the host     *|
|*      symbol tables are researched to make sure that AT_ATTR_LINK is        *|
|*      pointing to the correct attribute entry.                              *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/
static void     attr_link_resolution(void)
{
   int          attr_idx;
   int          host_idx;
   int          host_name_idx;
   int          local_attr_idx;
   int          local_name_idx;
   int          name_idx;
   int          rslt_idx;
   int          save_curr_scp_idx;
   boolean      save_host_dcl_err;
   int          sn_idx;
   int          ultimate_idx;
   int          ultimate_scp_idx;


   TRACE (Func_Entry, "attr_link_resolution", NULL);

   /* Do not need to go thru SCP_ATTR_LIST, because everything on that list */
   /* should be resolved.  At the end of pass1, it should be tmps and       */
   /* library calls.                                                        */

   for (name_idx = SCP_LN_FW_IDX(curr_scp_idx) + 1; 
        name_idx < SCP_LN_LW_IDX(curr_scp_idx); name_idx++) {

# ifdef _DEBUG
      if (name_idx < 0 || name_idx > loc_name_tbl_idx) {
         PRINTMSG(stmt_start_line, 34, Internal, stmt_start_col); 
      }
# endif

      attr_idx = LN_ATTR_IDX(name_idx);
# ifdef _DEBUG
      if (attr_idx <= 0 || attr_idx > attr_tbl_idx) {
         PRINTMSG(stmt_start_line, 34, Internal, stmt_start_col); 
      }
      if (LN_NAME_IDX(name_idx) != AT_NAME_IDX(attr_idx)) {
         PRINTMSG(AT_DEF_LINE(attr_idx), 516, Internal,
                  AT_DEF_COLUMN(attr_idx),
                  AT_OBJ_NAME_PTR(attr_idx),
                  name_idx,
                  attr_idx);
      }
# endif

      if (AT_REFERENCED(attr_idx) != Not_Referenced) {
         AT_REFERENCED(attr_idx) = Referenced;
      }

      if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module &&
          !AT_ACCESS_SET(attr_idx)) {

         /* Set to default access */

         AT_PRIVATE(attr_idx) = AT_PRIVATE(SCP_ATTR_IDX(curr_scp_idx));
      }

      if (LN_DEF_LOC(name_idx)) {
         continue;
      }

      host_idx = srch_host_sym_tbl(&name_pool[LN_NAME_IDX(name_idx)].name_char,
                                   LN_NAME_LEN(name_idx),
                                   &host_name_idx,
                                   FALSE);

      if (host_idx == NULL_IDX) {
         AT_ATTR_LINK(attr_idx) = NULL_IDX;     
         continue;
      }
      else if (IS_STMT_ENTITY(host_idx)) {

         /* Don't host associate a stmt entity. */

         AT_ATTR_LINK(attr_idx) = NULL_IDX;
         continue;
      }

      if (AT_OBJ_CLASS(attr_idx) == Derived_Type) {

         /* Derived type host association */

         if ((AT_OBJ_CLASS(host_idx) != Derived_Type &&
              !AT_DCL_ERR(attr_idx)) ||
            AT_NOT_VISIBLE(attr_idx)) {
            save_host_dcl_err = AT_DCL_ERR(host_idx);
            fnd_semantic_err(Obj_Use_Derived_Type,
                             AT_DEF_LINE(attr_idx),
                             AT_DEF_COLUMN(attr_idx),
                             host_idx,
                             TRUE);
            AT_DCL_ERR(attr_idx) = TRUE; 
            AT_DCL_ERR(host_idx) = save_host_dcl_err; 
            host_idx             = NULL_IDX;  /* Break link */
         }
         else if (AT_OBJ_CLASS(host_idx) == Derived_Type) {
            AT_HOST_ASSOCIATED(attr_idx)        = TRUE;
            AT_HOST_ASSOCIATED(host_idx)        = TRUE;
            ATT_SCP_IDX(attr_idx)               = ATT_SCP_IDX(host_idx);
         }
      }
      else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {
         ultimate_idx = host_idx;

         while (AT_ATTR_LINK(ultimate_idx)) {
            ultimate_idx = AT_ATTR_LINK(ultimate_idx);
         }

         /* Find the scope of the ultimate_idx */

         save_curr_scp_idx      = curr_scp_idx;
         ultimate_scp_idx       = curr_scp_idx;

         while (1) {  /* If scope is an interface block we're not here. */
            curr_scp_idx        = SCP_PARENT_IDX(curr_scp_idx);

            if (curr_scp_idx == 0) {  /* Intrinsic scope - exit */
               ultimate_scp_idx = NULL_IDX;
               break;
            }

            local_attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(ultimate_idx),
                                          AT_NAME_LEN(ultimate_idx),
                                          &local_name_idx);

            if (local_attr_idx == ultimate_idx) {
               ultimate_scp_idx = curr_scp_idx;
               break;
            }
         }

         curr_scp_idx           = save_curr_scp_idx;
         ATP_SCP_IDX(attr_idx)  = ultimate_scp_idx;

         /* if we can change the ultimate attr to a pgm unit we do */

         if (AT_OBJ_CLASS(ultimate_idx) == Data_Obj &&
             ! AT_USE_ASSOCIATED(ultimate_idx)) {

            if (!fnd_semantic_err((ATP_PGM_UNIT(attr_idx) == Subroutine ?
                                                           Obj_Use_Extern_Subr :
                                                           Obj_Use_Extern_Func),
                                   AT_DEF_LINE(ultimate_idx),
                                   AT_DEF_COLUMN(ultimate_idx),
                                   ultimate_idx,
                                   FALSE)) {  /* Check - don't issue message */

               if (ATP_PGM_UNIT(attr_idx) == Function &&
                   ATD_CLASS(ultimate_idx) != Dummy_Argument &&
                   TYP_TYPE(ATD_TYPE_IDX(ultimate_idx)) == Character &&
                   TYP_CHAR_CLASS(ATD_TYPE_IDX(ultimate_idx)) ==
                                            Assumed_Size_Char) {

                   /* This would be an illegal situation, so treat */
                   /* as if fnd_semantic_err returned TRUE.        */

                   /* Intentionally blank */
               }
               else {
                  chg_data_obj_to_pgm_unit(ultimate_idx, (pgm_unit_type)
                                           ATP_PGM_UNIT(attr_idx),
                                           Extern_Proc);
                  ATP_SCP_IDX(ultimate_idx)     = ultimate_scp_idx;

                  if (ATP_PGM_UNIT(ultimate_idx) == Function) {
                     rslt_idx = ATP_RSLT_IDX(ultimate_idx);
   
                     if (ATD_ARRAY_IDX(rslt_idx) != NULL_IDX ||
                         ATD_IM_A_DOPE(rslt_idx) ||
                         TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) == Structure ||
                         TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) == Character) {
   
                        ATP_EXTRA_DARG(ultimate_idx) = TRUE;
   
                        if (ATP_EXPL_ITRFC(ultimate_idx)) {
                           ATD_STOR_BLK_IDX(rslt_idx) = 
                                     SCP_SB_DARG_IDX(ATP_SCP_IDX(ultimate_idx));

                           /* Insert the function result as the zero'th darg */

                           if (ATP_FIRST_IDX(ultimate_idx) == NULL_IDX) {
                              NTR_SN_TBL(sn_idx);
                           }
                           else {
                              sn_idx = ATP_FIRST_IDX(ultimate_idx) - 1;
                           }
                           ATP_FIRST_IDX(ultimate_idx)  = sn_idx;
                           ATP_NUM_DARGS(ultimate_idx) += 1;
                           SN_NAME_LEN(sn_idx)   = AT_NAME_LEN(rslt_idx);
                           SN_NAME_IDX(sn_idx)   = AT_NAME_IDX(rslt_idx);
                           SN_ATTR_IDX(sn_idx)   = rslt_idx;
                           SN_LINE_NUM(sn_idx)   = AT_DEF_LINE(rslt_idx);
                           SN_COLUMN_NUM(sn_idx) = AT_DEF_COLUMN(rslt_idx);
                        }
                     }
                  }
               }
            }
         }
      }

      if (attr_idx == host_idx) {
         PRINTMSG(AT_DEF_LINE(attr_idx), 72, Internal, AT_DEF_COLUMN(attr_idx),
                  AT_OBJ_NAME_PTR(attr_idx), attr_idx);
      }

      AT_ATTR_LINK(attr_idx)    = host_idx;

      host_associated_attr_semantics(attr_idx, FALSE);
   }

   TRACE (Func_Exit, "attr_link_resolution", NULL);

   return;

}  /* attr_link_resolution */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This routine handles the storage blocks for host associated attrs.    *|
|*      All static storage blocks that will be host associated are copied     *|
|*      and linked into the current scope.  There is no link in either        *|
|*      direction.  The attr still points to the original storage block.      *|
|*      The storage block needs to be put into the current scope so that it   *|
|*      can be resolved by storage_blk_resolution before final_decl_semantics *|
|*      During the PDGCS interface, when an attribute is sent across that     *|
|*      references a storage block, not in the current scope, the current     *|
|*      is searched for the storage block.  Then this is the block sent to    *|
|*      PDG.  PDG_SB_IDX is updated for both the blocks so that the search    *|
|*      only has to be done once per block in a program unit.                 *|
|*      See send_stor_blk in i_cvrt.c for more details.                       *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      attr_idx => The host associated attr with the stor blk that needs     *|
|*                  resolving.                                                *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/
void    host_associated_attr_semantics(int      attr_idx,
                                       boolean  add_to_attr_list)

{
   int          bd_idx;
   boolean      defined;
   int          dim;
   int          eq_idx;
   int          first_eq;
   int          group_idx;
   int          il_idx;
   int          local_attr_idx;
   int          local_sb_idx;
   id_str_type  name;
   int          name_idx;
   char        *name_ptr;
   int          new_attr_idx;
   int          new_host_assoc          = FALSE;
   int          new_scp;
   int          new_sn_idx;
   int          referenced;
   int          sb_idx;
   int          sn_idx;
   int          type_idx;


   TRACE (Func_Entry, "host_associated_attr_semantics", NULL);

   /* Do not need to accumulate referenced and defined flags from     */
   /* intermediate attrs, because when each attr is processed, its    */
   /* flags are set into the original attr.  Save the flags, so they  */
   /* can be set if the attr is host associated.                      */

   referenced           = AT_REFERENCED(attr_idx);
   defined              = AT_DEFINED(attr_idx);
   local_attr_idx       = attr_idx;

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

   switch (AT_OBJ_CLASS(attr_idx)) {
   case Data_Obj:

      if (ATD_CLASS(attr_idx) == Constant) {

         /* If this is a structure or array, make sure the tmp associated */
         /* with the structure constructor is host associated.   At the   */
         /* moment stuff needs to be filled in for the temp, so just make */
         /* sure that the storage block gets created in the local scope.  */

         if (ATD_FLD(attr_idx) == AT_Tbl_Idx) {
            host_associated_attr_semantics(ATD_CONST_IDX(attr_idx), TRUE);

            if (referenced) {
               AT_REFERENCED(ATD_CONST_IDX(attr_idx)) = Referenced;
            }
         }
         break;
      }

# if defined(GENERATE_WHIRL)
      if (ATD_IM_A_DOPE(attr_idx)                                   &&
             ATD_CLASS(attr_idx)                     == Dummy_Argument &&
             ATD_ARRAY_IDX(attr_idx)                                   &&
             BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Shape &&
             ATD_SF_ARG_IDX(attr_idx) != NULL_IDX) {

         host_associated_attr_semantics(ATD_SF_ARG_IDX(attr_idx), TRUE);

         if (referenced) {
            AT_REFERENCED(ATD_SF_ARG_IDX(attr_idx)) = Referenced;
         }
      }
# endif

      sb_idx = ATD_STOR_BLK_IDX(attr_idx);

      if (sb_idx == NULL_IDX || SB_SCP_IDX(sb_idx) == curr_scp_idx) {
         break;
      }

      /* The only FUNCTION results that can be host associated are those  */
      /* that are parents of the current program unit.  If this is a      */
      /* reference to a pgm_unit defined in an interface block or in a    */
      /* sibling, this is a call to the program unit.  That causes new    */
      /* tmps to be created.                                              */

      if (ATD_CLASS(attr_idx) == Function_Result && 
          !ATP_SCP_ALIVE(ATD_FUNC_IDX(attr_idx))) {
          break;
      }
         
      switch (SB_BLK_TYPE(sb_idx)) {
      case Common:
      case Task_Common:
      case Threadprivate:

         /* These are NOT host associated.  The storage block is copied into */
         /* the scope and these are treated as if the block was declared in  */
         /* each program unit.  Copy the attr down and break the link.       */

         local_sb_idx = srch_stor_blk_tbl(SB_NAME_PTR(sb_idx),
                                          SB_NAME_LEN(sb_idx),
                                          curr_scp_idx);
         if (local_sb_idx != NULL_IDX && 
             SB_HOST_ASSOCIATED(local_sb_idx) &&
             SB_ORIG_SCP_IDX(sb_idx) == SB_ORIG_SCP_IDX(local_sb_idx) &&
             SB_ORIG_SCP_IDX(sb_idx) != NULL_IDX) {

            /* This storage block has already been host associated into this */
            /* scope.  So do nothing.  Intentionally blank.                  */
         }
         else {
            TBL_REALLOC_CK(stor_blk_tbl, 1);
            stor_blk_tbl[stor_blk_tbl_idx]              = stor_blk_tbl[sb_idx];
            SB_ORIG_SCP_IDX(stor_blk_tbl_idx)           = SB_SCP_IDX(sb_idx);
            SB_SCP_IDX(stor_blk_tbl_idx)                = curr_scp_idx;
            SB_HOST_ASSOCIATED(stor_blk_tbl_idx)        = TRUE;
            SB_COMMON_NEEDS_OFFSET(stor_blk_tbl_idx)    = FALSE;
        
            if (local_sb_idx != NULL_IDX) { 
               SB_HIDDEN(stor_blk_tbl_idx)              = TRUE;
               SB_MERGED_BLK_IDX(stor_blk_tbl_idx)      = local_sb_idx;

               if (!SB_USE_ASSOCIATED(local_sb_idx) || 
                   !SB_USE_ASSOCIATED(sb_idx) ||
                    SB_HAS_RENAMES(local_sb_idx) ||
                    SB_HAS_RENAMES(sb_idx) ||
                   (compare_names(AT_OBJ_NAME_LONG(SB_MODULE_IDX(local_sb_idx)),
                                  AT_NAME_LEN(SB_MODULE_IDX(local_sb_idx)),
                                  AT_OBJ_NAME_LONG(SB_MODULE_IDX(sb_idx)),
                                  AT_NAME_LEN(SB_MODULE_IDX(sb_idx))) != 0)) {
                  SB_DEF_MULT_SCPS(stor_blk_tbl_idx)    = TRUE;
                  SB_DEF_MULT_SCPS(sb_idx)              = TRUE;
               }
            }
            else if (SB_MODULE(stor_blk_tbl_idx)) {

               if (SB_USE_ASSOCIATED(stor_blk_tbl_idx)) {
                  ADD_ATTR_TO_LOCAL_LIST(SB_MODULE_IDX(stor_blk_tbl_idx));
               }
            }
            local_sb_idx                        = stor_blk_tbl_idx;
         }
         break;

      case Static:
      case Static_Local:
      case Static_Named:
         if (SB_BLK_TYPE(sb_idx) == Static) {

            if (referenced) {
               AT_REFERENCED(attr_idx) = Referenced;
               AT_REF_IN_CHILD(attr_idx) = TRUE;
            }

            if (defined) {
               AT_REF_IN_CHILD(attr_idx) = TRUE;
            }  

         }

         /* These are NOT host associated.  This item needs to be in the     */
         /* host associated storage block for its scope.                     */

         if (!SB_USE_ASSOCIATED(sb_idx) &&
             (SB_BLK_TYPE(sb_idx) == Static_Local ||
              SB_BLK_TYPE(sb_idx) == Static_Named)) {
            new_scp = SB_SCP_IDX(sb_idx);

            if (SB_BLK_TYPE(sb_idx) == Static_Named) {

               if (SCP_SB_HOSTED_DATA_IDX(new_scp) == NULL_IDX) {
                  sb_idx = ntr_stor_blk_tbl(
                              SB_NAME_PTR(SCP_SB_STATIC_INIT_IDX(curr_scp_idx)),
                              SB_NAME_LEN(SCP_SB_STATIC_INIT_IDX(curr_scp_idx)),
                              AT_DEF_LINE(attr_idx),
                              AT_DEF_COLUMN(attr_idx),
                              Static);
   
                  name_ptr      = SB_NAME_PTR(sb_idx);
                  name_ptr[1]   = 'H';
                  name_ptr[2]   = 'O';
                  name_ptr[3]   = 'S';
                  name_ptr[4]   = 'T';

                  SB_SCP_IDX(sb_idx) = SB_SCP_IDX(ATD_STOR_BLK_IDX(attr_idx));
                  SB_ORIG_SCP_IDX(sb_idx) = 
                                  SB_ORIG_SCP_IDX(ATD_STOR_BLK_IDX(attr_idx));
                  SB_HOSTED_STATIC(sb_idx)              = TRUE;
                  SCP_SB_HOSTED_DATA_IDX(new_scp)       = sb_idx;
                  local_sb_idx                          = NULL_IDX;
               }
               else {
                  sb_idx        = SCP_SB_HOSTED_DATA_IDX(new_scp);
                  local_sb_idx  = srch_stor_blk_tbl(SB_NAME_PTR(sb_idx),
                                                            SB_NAME_LEN(sb_idx),
                                                            curr_scp_idx);
               }
            }
            else if (SCP_SB_HOSTED_STATIC_IDX(new_scp) == NULL_IDX) {
               sb_idx = ntr_stor_blk_tbl(
                                   SB_NAME_PTR(SCP_SB_STATIC_IDX(curr_scp_idx)),
                                   SB_NAME_LEN(SCP_SB_STATIC_IDX(curr_scp_idx)),
                                   AT_DEF_LINE(attr_idx),
                                   AT_DEF_COLUMN(attr_idx),
                                   Static);

               name_ptr         = SB_NAME_PTR(sb_idx);
               name_ptr[1]      = 'H';
               name_ptr[2]      = 'O';
               name_ptr[3]      = 'S';
               name_ptr[4]      = 'T';

               SB_SCP_IDX(sb_idx) = SB_SCP_IDX(ATD_STOR_BLK_IDX(attr_idx));
               SB_ORIG_SCP_IDX(sb_idx) = 
                                  SB_ORIG_SCP_IDX(ATD_STOR_BLK_IDX(attr_idx));
               SB_HOSTED_STATIC(sb_idx)         = TRUE;
               SCP_SB_HOSTED_STATIC_IDX(new_scp)= sb_idx;
               local_sb_idx                     = NULL_IDX;
            }
            else {
               sb_idx                   = SCP_SB_HOSTED_STATIC_IDX(new_scp);
               local_sb_idx             = srch_stor_blk_tbl(SB_NAME_PTR(sb_idx),
                                                            SB_NAME_LEN(sb_idx),
                                                            curr_scp_idx);
            }

            ATD_STOR_BLK_IDX(attr_idx)  = sb_idx;

            /* We've switched to a new storage block.  If this object is */
            /* equivalenced, we need to switch everything in this group  */
            /* to this new storage block.                                */

            if (ATD_EQUIV(attr_idx)) {
               group_idx = SCP_FIRST_EQUIV_GRP(new_scp);

               while (group_idx != NULL_IDX) {
                  eq_idx        = group_idx;
                  first_eq      = eq_idx;
                  group_idx     = EQ_NEXT_EQUIV_GRP(group_idx);

                  while (eq_idx != NULL_IDX) {

                     if (EQ_ATTR_IDX(eq_idx) == attr_idx) { /* Found */
                        eq_idx          = first_eq;
                        group_idx       = NULL_IDX;

                        while (eq_idx != NULL_IDX) {
                           host_associated_attr_semantics(EQ_ATTR_IDX(eq_idx),
                                                          FALSE);
                           eq_idx = EQ_NEXT_EQUIV_OBJ(eq_idx);
                        }
                     }
                     else {
                        eq_idx = EQ_NEXT_EQUIV_OBJ(eq_idx);
                     }
                  }
               }
            }
         }
         else {
            local_sb_idx = srch_stor_blk_tbl(SB_NAME_PTR(sb_idx),
                                             SB_NAME_LEN(sb_idx),
                                             curr_scp_idx);
         }

         if (local_sb_idx != NULL_IDX && 
             SB_HOST_ASSOCIATED(local_sb_idx) &&
             SB_ORIG_SCP_IDX(sb_idx) == SB_ORIG_SCP_IDX(local_sb_idx) &&
             SB_ORIG_SCP_IDX(sb_idx) != NULL_IDX) {

            /* This storage block has already been host associated into this */
            /* scope.  So do nothing.  Intentionally blank.                  */
         }
         else {
            TBL_REALLOC_CK(stor_blk_tbl, 1);
            stor_blk_tbl[stor_blk_tbl_idx]              = stor_blk_tbl[sb_idx];
            SB_ORIG_SCP_IDX(stor_blk_tbl_idx)           = SB_SCP_IDX(sb_idx);
            SB_SCP_IDX(stor_blk_tbl_idx)                = curr_scp_idx;
            SB_HOST_ASSOCIATED(stor_blk_tbl_idx)        = TRUE;
            SB_COMMON_NEEDS_OFFSET(stor_blk_tbl_idx)    = FALSE;
        
            if (local_sb_idx != NULL_IDX) { 
               SB_HIDDEN(stor_blk_tbl_idx)              = TRUE;
               SB_MERGED_BLK_IDX(stor_blk_tbl_idx)      = local_sb_idx;

               if (!SB_USE_ASSOCIATED(local_sb_idx) || 
                   !SB_USE_ASSOCIATED(sb_idx) ||
                    SB_HAS_RENAMES(local_sb_idx) ||
                    SB_HAS_RENAMES(sb_idx) ||
                   (compare_names(AT_OBJ_NAME_LONG(SB_MODULE_IDX(local_sb_idx)),
                                  AT_NAME_LEN(SB_MODULE_IDX(local_sb_idx)),
                                  AT_OBJ_NAME_LONG(SB_MODULE_IDX(sb_idx)),
                                  AT_NAME_LEN(SB_MODULE_IDX(sb_idx))) != 0)) {
                  SB_DEF_MULT_SCPS(stor_blk_tbl_idx)    = TRUE;
                  SB_DEF_MULT_SCPS(sb_idx)              = TRUE;
               }
            }
            else if (SB_MODULE(stor_blk_tbl_idx)) {

               if (SB_USE_ASSOCIATED(stor_blk_tbl_idx)) {
                  ADD_ATTR_TO_LOCAL_LIST(SB_MODULE_IDX(stor_blk_tbl_idx));
               }
         if (!AT_HOST_ASSOCIATED(local_attr_idx)) {
            AT_HOST_ASSOCIATED(attr_idx)        = TRUE;
            AT_HOST_ASSOCIATED(local_attr_idx)  = TRUE;
           }
         if (defined && ATD_CLASS(attr_idx) != Compiler_Tmp) {
            AT_DEFINED(attr_idx)        = TRUE;
            AT_DEF_IN_CHILD(attr_idx)   = TRUE;
          }

         if (referenced) {
            AT_REFERENCED(attr_idx)     = Referenced;
            AT_REF_IN_CHILD(attr_idx)   = TRUE;
          }

            }
            local_sb_idx = stor_blk_tbl_idx;
         }
         break;

      case Stack:

         if (!AT_HOST_ASSOCIATED(local_attr_idx)) {
            AT_HOST_ASSOCIATED(attr_idx)        = TRUE;
            AT_HOST_ASSOCIATED(local_attr_idx)  = TRUE;
            new_host_assoc                      = TRUE;
            new_scp                             = SB_SCP_IDX(sb_idx);

            if (SCP_SB_HOSTED_STACK_IDX(new_scp) == NULL_IDX) {
               CREATE_ID(name, sb_name[Stack_Host_Blk], sb_len[Stack_Host_Blk]);
               sb_idx = ntr_stor_blk_tbl(name.string,
                                         sb_len[Stack_Host_Blk],
                                         AT_DEF_LINE(attr_idx),
                                         AT_DEF_COLUMN(attr_idx),
                                         Stack);
               SB_SCP_IDX(sb_idx)               = new_scp;
               SB_HOSTED_STACK(sb_idx)          = TRUE;
               SCP_SB_HOSTED_STACK_IDX(new_scp) = sb_idx;
            }
            ATD_STOR_BLK_IDX(attr_idx)  = SCP_SB_HOSTED_STACK_IDX(new_scp);
         }

         /* If this is a compiler tmp, it should be a host associated   */
         /* bounds tmp.  That means it is only referenced in the child. */

         if (defined && ATD_CLASS(attr_idx) != Compiler_Tmp) {
            AT_DEFINED(attr_idx)        = TRUE;
            AT_DEF_IN_CHILD(attr_idx)   = TRUE;
         }

         if (referenced) {
            AT_REFERENCED(attr_idx)     = Referenced;
            AT_REF_IN_CHILD(attr_idx)   = TRUE;
         }

         break;

      case Equivalenced:

         if (!AT_HOST_ASSOCIATED(local_attr_idx)) {
            new_host_assoc                      = TRUE;
            AT_HOST_ASSOCIATED(attr_idx)        = TRUE;
            AT_HOST_ASSOCIATED(local_attr_idx)  = TRUE;
         }

         AT_DEFINED(attr_idx)           = AT_DEFINED(attr_idx) | defined;
         AT_DEF_IN_CHILD(attr_idx)      = AT_DEF_IN_CHILD(attr_idx) | defined;
         SB_HOSTED_STACK(sb_idx)        = TRUE;

         if (referenced) {
            AT_REFERENCED(attr_idx)     = Referenced;
            AT_REF_IN_CHILD(attr_idx)   = TRUE;
         }

         break;

      case Formal:

         if (!AT_HOST_ASSOCIATED(local_attr_idx)) {
            new_host_assoc                      = TRUE;
            AT_HOST_ASSOCIATED(attr_idx)        = TRUE;
            AT_HOST_ASSOCIATED(local_attr_idx)  = TRUE;
         }

         AT_DEFINED(attr_idx)           = AT_DEFINED(attr_idx) | defined;
         AT_DEF_IN_CHILD(attr_idx)      = AT_DEF_IN_CHILD(attr_idx) | defined;

         if (referenced) {
            AT_REFERENCED(attr_idx)     = Referenced;
            AT_REF_IN_CHILD(attr_idx)   = TRUE;
         }
         break;

      case Based:

         if (ATD_AUTOMATIC(attr_idx)) {
            host_associated_attr_semantics(ATD_AUTO_BASE_IDX(attr_idx), TRUE);
         }
         else {       /* Should be a Cray_Pointee */
            host_associated_attr_semantics(ATD_PTR_IDX(attr_idx), TRUE);
         }

         if (!AT_HOST_ASSOCIATED(local_attr_idx)) {
            new_host_assoc                      = TRUE;
            AT_HOST_ASSOCIATED(attr_idx)        = TRUE;
            AT_HOST_ASSOCIATED(local_attr_idx)  = TRUE;
         }

         AT_DEFINED(attr_idx)           = AT_DEFINED(attr_idx) | defined;
         AT_DEF_IN_CHILD(attr_idx)      = AT_DEF_IN_CHILD(attr_idx) | defined;

         if (referenced) {
            AT_REFERENCED(attr_idx)     = Referenced;
            AT_REF_IN_CHILD(attr_idx)   = TRUE;
         }

         /* Carry the local based storage on the local attr, so that it can */
         /* be passed through the interface.  We don't want to use the host */

         ATD_STOR_BLK_IDX(local_attr_idx) = SCP_SB_BASED_IDX(curr_scp_idx);
         break;

      default:

         if (!AT_HOST_ASSOCIATED(local_attr_idx)) {
            new_host_assoc                      = TRUE;
            AT_HOST_ASSOCIATED(attr_idx)        = TRUE;
            AT_HOST_ASSOCIATED(local_attr_idx)  = TRUE;
         }
         AT_DEFINED(attr_idx)           = AT_DEFINED(attr_idx) | defined;
         AT_DEF_IN_CHILD(attr_idx)      = AT_DEF_IN_CHILD(attr_idx) | defined;

         if (referenced) {
            AT_REFERENCED(attr_idx)     = Referenced;
            AT_REF_IN_CHILD(attr_idx)   = TRUE;
         }
         break;
      }  /* End switch */

      if (new_host_assoc) {  /* This attr is now host associated */

         if (ATD_CLASS(attr_idx) == Variable &&
             ATD_FLD(attr_idx) != NO_Tbl_Idx) {

            /* This has data initialized tmps associated with it.  These can */
            /* get here if the attr is use associated and then hosted.       */

            if (ATD_FLD(attr_idx) == AT_Tbl_Idx) {
               host_associated_attr_semantics(ATD_VARIABLE_TMP_IDX(attr_idx), 
                                              TRUE);
            }
            else if (ATD_FLD(attr_idx) == IL_Tbl_Idx) {

               /* Must be structure - Have a list of tmps */

               il_idx = ATD_VARIABLE_TMP_IDX(attr_idx);

               while (il_idx != NULL_IDX) {
                  host_associated_attr_semantics(IL_IDX(il_idx), TRUE); 
                  il_idx = IL_NEXT_LIST_IDX(il_idx);
               }
            }
         }

         type_idx = ATD_TYPE_IDX(attr_idx);
   
         if (TYP_TYPE(type_idx) == Character &&
             TYP_FLD(type_idx) == AT_Tbl_Idx) {
            host_associated_attr_semantics(TYP_IDX(type_idx), TRUE);
         }
   
         bd_idx = ATD_ARRAY_IDX(attr_idx);
   
         if (bd_idx != NULL_IDX &&
             BD_ARRAY_SIZE(bd_idx) != Constant_Size && 
             BD_ARRAY_SIZE(bd_idx) != Unknown_Size     ) {
   
            for (dim = 1; dim <= BD_RANK(bd_idx); dim++) {
   
               if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) {
                  host_associated_attr_semantics(BD_LB_IDX(bd_idx, dim), TRUE);
               }
   
               if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) {
                  host_associated_attr_semantics(BD_UB_IDX(bd_idx, dim), TRUE);
               }
   
               if (BD_XT_FLD(bd_idx, dim) == AT_Tbl_Idx) {
                  host_associated_attr_semantics(BD_XT_IDX(bd_idx, dim), TRUE);
               }
      
               if (BD_SM_FLD(bd_idx, dim) == AT_Tbl_Idx) {
                  host_associated_attr_semantics(BD_SM_IDX(bd_idx, dim), TRUE);
               }
            }
   
            if (BD_LEN_FLD(bd_idx) == AT_Tbl_Idx) {
               host_associated_attr_semantics(BD_LEN_IDX(bd_idx), TRUE);
            }
         }
      }
      break;

   case Pgm_Unit:

      /* If ATP_SCP_ALIVE is set, then we are host associating the host's     */
      /* function result or we are calling the host.  Since we don't know for */
      /* sure what is going on, assume the function result is host associated.*/

      AT_DEFINED(attr_idx)      = AT_DEFINED(attr_idx) | defined;
      AT_DEF_IN_CHILD(attr_idx) = AT_DEF_IN_CHILD(attr_idx) | defined;

      if (referenced) {
         AT_REFERENCED(attr_idx)        = Referenced;
         AT_REF_IN_CHILD(attr_idx)      = TRUE;
      }

      if (ATP_PGM_UNIT(attr_idx) == Function &&
          ATP_SCP_ALIVE(attr_idx) && !ATP_RSLT_NAME(attr_idx)) {
         host_associated_attr_semantics(ATP_RSLT_IDX(attr_idx), FALSE);
      }
      break;

   case Namelist_Grp:

      COPY_ATTR_NTRY(local_attr_idx, attr_idx);

      /* Note that AT_CIF_SYMBOL_ID remains as the symbol id of the name in   */
      /* the host.  We need this to make all references resolve to the host   */
      /* so that CIF processing only sees one namelist group name (the one in */
      /* the host).                                                           */

      AT_ATTR_LINK(local_attr_idx)              = NULL_IDX;
      AT_REFERENCED(local_attr_idx)             = referenced;
      AT_DEFINED(local_attr_idx)                = defined;
      AT_HOST_ASSOCIATED(local_attr_idx)        = TRUE;

      if (ATN_NAMELIST_DESC(attr_idx) != NULL_IDX) {
         host_associated_attr_semantics(ATN_NAMELIST_DESC(attr_idx), TRUE);
      }

      sn_idx            = ATN_FIRST_NAMELIST_IDX(attr_idx);
      new_sn_idx        = NULL_IDX;

      while (sn_idx != NULL_IDX) {

         if (new_sn_idx == NULL_IDX) {
            NTR_SN_TBL(new_sn_idx);
            ATN_FIRST_NAMELIST_IDX(local_attr_idx)      = new_sn_idx;
         }
         else {
            NTR_SN_TBL(name_idx);
            SN_SIBLING_LINK(new_sn_idx) = name_idx;
            new_sn_idx                  = name_idx;
         }

         sec_name_tbl[new_sn_idx]       = sec_name_tbl[sn_idx];

         local_attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(SN_ATTR_IDX(sn_idx)),
                                       AT_NAME_LEN(SN_ATTR_IDX(sn_idx)),
                                       &name_idx);

         if (local_attr_idx != NULL_IDX && 
             AT_ATTR_LINK(local_attr_idx) != NULL_IDX) {

            new_attr_idx = AT_ATTR_LINK(local_attr_idx);

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

            if (new_attr_idx != SN_ATTR_IDX(sn_idx)) {

               /* If the attr indexes are equal, the attr_idx has already */
               /* been host associated into this scope, so use that attr. */
               /* Otherwise, host associate this attr into this scope.    */

               NTR_ATTR_TBL(local_attr_idx);
               AT_ATTR_LINK(local_attr_idx) = SN_ATTR_IDX(sn_idx);
               host_associated_attr_semantics(SN_ATTR_IDX(sn_idx), FALSE);
            }
         }
         else {

            /* Something by this name has not been host associated into   */
            /* this scope, so attr link this and host associate it in.    */

            NTR_ATTR_TBL(local_attr_idx);
            AT_ATTR_LINK(local_attr_idx) = SN_ATTR_IDX(sn_idx);
            host_associated_attr_semantics(SN_ATTR_IDX(sn_idx), FALSE);
         }

         SN_ATTR_IDX(new_sn_idx)        = local_attr_idx;
         sn_idx                         = SN_SIBLING_LINK(sn_idx);
      }

      break;

   case Interface:

      /* KAY - What does this mean.  If there is a program by the same name  */
      /*       as the interface, how do we know its been referenced?   Plus  */
      /*       interfaces are concatted together.  Research this.            */
      /*       What about referenced and defined?                            */

      break;

   case Stmt_Func:

      /* Need to check the statement function body for anything else that is */
      /* host associated.  ie:  Traverse the IR.                             */

      switch (ATS_SF_FLD(attr_idx)) {
      case AT_Tbl_Idx:
         host_associated_attr_semantics(ATS_SF_IDX(attr_idx), TRUE);
         break;

      case IR_Tbl_Idx:
         find_host_associated_attrs_in_ir(ATS_SF_IDX(attr_idx));
         break;

      case IL_Tbl_Idx:
         find_host_associated_attrs_in_il(ATS_SF_IDX(attr_idx));
         break;
      }
      break;
   }

   if (add_to_attr_list) {
      ADD_ATTR_TO_LOCAL_LIST(local_attr_idx);
   }
   
   TRACE (Func_Exit, "host_associated_attr_semantics", NULL);

   return;

}  /* host_associated_attr_semantics */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

static  void    find_host_associated_attrs_in_ir(int    ir_idx)

{

   TRACE (Func_Entry, "find_host_associated_attrs_in_ir", NULL);

   switch (IR_FLD_L(ir_idx)) {
   case AT_Tbl_Idx:
      host_associated_attr_semantics(IR_IDX_L(ir_idx), TRUE);
      break;

   case IR_Tbl_Idx:
      find_host_associated_attrs_in_ir(IR_IDX_L(ir_idx));
      break;

   case IL_Tbl_Idx:
      find_host_associated_attrs_in_il(IR_IDX_L(ir_idx));
      break;

   case CN_Tbl_Idx:
   case NO_Tbl_Idx:
   case SH_Tbl_Idx:
      break;
   }

   switch (IR_FLD_R(ir_idx)) {
   case AT_Tbl_Idx:
      host_associated_attr_semantics(IR_IDX_R(ir_idx), TRUE);
      break;

   case IR_Tbl_Idx:
      find_host_associated_attrs_in_ir(IR_IDX_R(ir_idx));
      break;

   case IL_Tbl_Idx:
      find_host_associated_attrs_in_il(IR_IDX_R(ir_idx));
      break;

   case CN_Tbl_Idx:
   case NO_Tbl_Idx:
   case SH_Tbl_Idx:
      break;
   }

   TRACE (Func_Exit, "find_host_associated_attrs_in_ir", NULL);

   return;

}  /* find_host_associated_attrs_in_ir */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

static  void    find_host_associated_attrs_in_il(int    list_idx)

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

   while (list_idx != NULL_IDX) {

      switch (IL_FLD(list_idx)) {
      case AT_Tbl_Idx:
         host_associated_attr_semantics(IL_IDX(list_idx), TRUE);
         break;

      case IR_Tbl_Idx:
         find_host_associated_attrs_in_ir(IL_IDX(list_idx));
         break;

      case IL_Tbl_Idx:
         find_host_associated_attrs_in_il(IL_IDX(list_idx));
         break;

      case NO_Tbl_Idx:
      case SH_Tbl_Idx:
      case CN_Tbl_Idx:
         break;
      }
      list_idx = IL_NEXT_LIST_IDX(list_idx);
   }

   TRACE (Func_Exit, "find_host_associated_attrs_in_il", NULL);

   return;

}  /* find_host_associated_attrs_in_il */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      initialize the zero'd arg_info struct and the exp_desc struct for     *|
|*      call list processing and expr_semantics.                              *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

static void init_call_structs(void)

{
   int          i;

   TRACE (Func_Entry, "init_call_structs", NULL);

   init_exp_desc.type_idx         = TYPELESS_DEFAULT_TYPE;
   init_exp_desc.rank             = 0;
   init_exp_desc.cif_id           = 0;
   init_exp_desc.type             = Typeless;
   init_exp_desc.linear_type      = Err_Res;
   init_exp_desc.kind0seen        = FALSE;
   init_exp_desc.kind0D0seen      = FALSE;
   init_exp_desc.percent_val_arg  = FALSE;
   init_exp_desc.constant         = FALSE;
   init_exp_desc.foldable         = FALSE;
   init_exp_desc.will_fold_later  = FALSE;
   init_exp_desc.pointer          = FALSE;
   init_exp_desc.target           = FALSE;
   init_exp_desc.vector_subscript = FALSE;
   init_exp_desc.reference        = FALSE;
   init_exp_desc.constructor      = FALSE;
   init_exp_desc.component        = FALSE;
   init_exp_desc.section          = FALSE;
   init_exp_desc.label            = FALSE;
   init_exp_desc.array_elt        = FALSE;
   init_exp_desc.assumed_shape    = FALSE;
   init_exp_desc.assumed_size     = FALSE;
   init_exp_desc.allocatable      = FALSE;
   init_exp_desc.dope_vector      = FALSE;
   init_exp_desc.tmp_reference    = FALSE;
   init_exp_desc.has_constructor  = FALSE;
   init_exp_desc.optional_darg    = FALSE;
   init_exp_desc.pe_dim_ref       = FALSE;
   init_exp_desc.contig_array     = FALSE;
   init_exp_desc.shape_known      = FALSE;
   init_exp_desc.tree_has_ranf    = FALSE;
   init_exp_desc.has_symbolic     = FALSE;
   init_exp_desc.dist_reshape_ref = FALSE;
   init_exp_desc.constructor_size_level = Unknown_Expr_Size;

   init_exp_desc.char_len = null_opnd;

   for (i = 0; i < 7; i++) {
      init_exp_desc.shape[i] = null_opnd;
   }

   init_arg_info.ed = init_exp_desc;

   init_arg_info.kwd                 = NULL_IDX;
   init_arg_info.line                = 0;
   init_arg_info.col                 = 0;
   init_arg_info.association         = 0;
   init_arg_info.arg_opnd            = null_opnd;
   init_arg_info.pgm_unit            = FALSE;
   init_arg_info.maybe_modified      = TRUE;

   TRACE (Func_Exit, "init_call_structs", NULL);

   return;

}  /* init_call_structs */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Check for a pending align cdir for a referenced user label.           *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void label_def_stmt_semantics(void)

{
   int          label_idx;

   TRACE (Func_Entry, "label_def_stmt_semantics", NULL);

   label_idx = IR_IDX_L(SH_IR_IDX(curr_stmt_sh_idx));

   if (ATL_CLASS(label_idx) == Lbl_User &&
       AT_REFERENCED(label_idx) == Referenced && cdir_switches.align) {

      ATL_ALIGN(label_idx)      = TRUE;
      cdir_switches.align       = FALSE;
   }

   if (! cdir_switches.vector) {
      ATL_NOVECTOR(label_idx)  = TRUE;
   }

# if defined(GENERATE_WHIRL)
   if (cdir_switches.notask_region) {
      ATL_NOTASK(label_idx)    = TRUE;
   }
# else
   if (! cdir_switches.task) {
      ATL_NOTASK(label_idx)    = TRUE;
   }
# endif

   if (! cdir_switches.vsearch) {
      ATL_NOVSEARCH(label_idx) = TRUE;
   }

   if (cdir_switches.bl) {
      ATL_BL(label_idx) = TRUE;
   }

   if (! cdir_switches.recurrence) {
      ATL_NORECURRENCE(label_idx) = TRUE;
   }

   if (cdir_switches.pattern) {
      ATL_PATTERN(label_idx) = TRUE;
   }

   TRACE (Func_Exit, "label_def_stmt_semantics", NULL);

   return;

}  /* label_def_stmt_semantics */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This assigns storage offsets at the end of the semantics pass.        *|
|*      This assumes parents are processed before children.  This also        *|
|*      assumes that tmps are assigned after all declared variables.  This is *|
|*      needed for the data initialization array optimization.  ATD_TMP_IDX   *|
|*      on the compiler tmps with ATD_DATA_INIT set is a pointer to the       *|
|*      variable that is being data initialized.                              *|
|*      If CIF records are being generated, it generates OBJECT records for   *|
|*      everything in the local name table that CIF wants.                    *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*       NONE                                                                 *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*       NONE                                                                 *|
|*                                                                            *|
|* Returns:                                                                   *|
|*       NONE                                                                 *|
|*                                                                            *|
\******************************************************************************/
static  void    final_decl_semantics(void)

{
   int                  al_idx;
   int                  attr_idx;
   int                  name_idx;
   int                  symbolic_constant       = NULL_IDX;


# if defined(_ASSIGN_OFFSETS_TO_HOSTED_STACK)
   size_offset_type     length;
   int                  list_idx;
   size_offset_type     result;
   int                  sb_idx;
# endif


   TRACE (Func_Entry, "final_decl_semantics", NULL);

   /* This holds a list of all arrays whose bounds are based on symbolic */
   /* constants that need to have offsets assigned.  (Except for common  */
   /* blocks.)  This ensures that in static and module blocks, all the   */
   /* symbolic constant based arrays are at the end of the block.  Then  */
   /* anything in the block that is not a symbolic constant based array  */
   /* can be equivalenced or data initialized.                           */

   symbolic_constant_array_list = NULL_IDX;

   /* Mark the start of the assign label chain, in case this procedure      */
   /* ends up going out for USE processing and coming back in for inlining. */
   /* We can then find the start of the chain without having a scope table. */

   if (SCP_ASSIGN_LBL_CHAIN(curr_scp_idx) != NULL_IDX) {
      ATL_ASG_LBL_CHAIN_START(SCP_ASSIGN_LBL_CHAIN(curr_scp_idx))       = TRUE;
   }

   /* Do final processing of equivalence groups, it there are no errors.    */

   if (num_prog_unit_errors == 0) {
      final_equivalence_semantics();
   }

   storage_blk_resolution();

   for (name_idx = SCP_LN_FW_IDX(curr_scp_idx) + 1; 
        name_idx < SCP_LN_LW_IDX(curr_scp_idx); name_idx++) {

      attr_idx = LN_ATTR_IDX(name_idx);

      if (!AT_DCL_ERR(attr_idx)) {

         if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
             ATD_SYMBOLIC_CONSTANT(attr_idx) &&
             (ATD_CLASS(attr_idx) == Constant ||
              ATD_CLASS(attr_idx) == Variable)) {
            symbolic_constant = attr_idx;
         }
         else {
            final_attr_semantics(attr_idx);
         }
      }
   }


   if (symbolic_constant != NULL_IDX &&
       (ATD_CLASS(symbolic_constant) == Constant ||
        AT_REFERENCED(symbolic_constant) == Not_Referenced)) {

      /* Remove N$PES from the name table here.  This is needed so N$PES   */
      /* doesn't cause problems in MODULE processing.                      */

      srch_sym_tbl(AT_OBJ_NAME_PTR(symbolic_constant),
                   AT_NAME_LEN(symbolic_constant),
                   &name_idx);

      remove_ln_ntry(name_idx);
   }

   al_idx       = SCP_ATTR_LIST(curr_scp_idx);

   while (al_idx != NULL_IDX) {

      if (!AT_DCL_ERR(AL_ATTR_IDX(al_idx))) {
         final_attr_semantics(AL_ATTR_IDX(al_idx));
      }

      al_idx = AL_NEXT_IDX(al_idx);
   }

   al_idx       = symbolic_constant_array_list;

   while (al_idx != NULL_IDX) {
      assign_offset(AL_ATTR_IDX(al_idx));  /* symbolic constants */
      al_idx = AL_NEXT_IDX(al_idx);
   }

# if defined(_ASSIGN_OFFSETS_TO_HOSTED_STACK)

   if (SCP_SB_HOSTED_STACK_IDX(curr_scp_idx) != NULL_IDX) {

      /* Have stack items that are hosted.  Need to add a tmp for the */
      /* block length.  Any time this hosted stack is used, the tmp   */
      /* must be host associated as well.  Special case is the zero   */
      /* block length.  We do not need a tmp, because if nothing is   */
      /* hosted, the block doesn't get in.  If one or more things are */
      /* hosted, then the length will still be correct at zero.       */

      sb_idx                    = SCP_SB_HOSTED_STACK_IDX(curr_scp_idx);

      /* KAY - If this is set to AT_Tbl_Idx, it should not be 0. */

      if (SB_LEN_FLD(sb_idx) == AT_Tbl_Idx ||
          fold_relationals(SB_LEN_IDX(sb_idx), CN_INTEGER_ZERO_IDX, Ne_Opr)) {

         result.idx     = SB_LEN_IDX(sb_idx);
         result.fld     = SB_LEN_FLD(sb_idx);

         align_bit_length(&result, TARGET_BITS_PER_WORD);

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

         SB_LEN_FLD(sb_idx)     = result.fld;
         SB_LEN_IDX(sb_idx)     = result.idx;
         attr_idx               = gen_compiler_tmp(SB_DEF_LINE(sb_idx),
                                                   SB_DEF_COLUMN(sb_idx),
                                                   Priv, TRUE);

         ATD_TYPE_IDX(attr_idx)         = TYPELESS_DEFAULT_TYPE;
         ATD_STOR_BLK_IDX(attr_idx)     = sb_idx;
         ATD_OFFSET_ASSIGNED(attr_idx)  = TRUE;
         AT_REFERENCED(attr_idx)        = Referenced;  /* Force thru PDGCS */
         AT_REF_IN_CHILD(attr_idx)      = TRUE;        /* Force thru PDGCS */
         NTR_ATTR_LIST_TBL(list_idx);
         AL_ATTR_IDX(list_idx)          = attr_idx;
         SB_LAST_ATTR_LIST(sb_idx)      = list_idx;

         /* This must be at least one word length, because  */
         /* the bit length has been word aligned.           */

         length.fld     = CN_Tbl_Idx;
         length.idx     = CN_INTEGER_BITS_PER_WORD_IDX;

         if (!size_offset_binary_calc(&result, &length, Minus_Opr, &result)) {
            AT_DCL_ERR(attr_idx) = TRUE;
         }

         if (result.fld == NO_Tbl_Idx) {
            ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx;
            ATD_OFFSET_IDX(attr_idx) = ntr_const_tbl(result.type_idx,
                                                     FALSE,
                                                     result.constant);
         }
         else {
            ATD_OFFSET_FLD(attr_idx) = result.fld;
            ATD_OFFSET_IDX(attr_idx) = result.idx;
         }
      }
   }
# endif

   /* Check CIF option to see if symbol table needs to be written to CIF.  */
   /* Need to use BASIC_RECS to output the Entry Info and Common Block     */
   /* records if the user just specifies "-cf".                            */

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

   TRACE (Func_Exit, "final_decl_semantics", NULL);

   return;

}  /* final_decl_semantics */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Allocates storage and offsets for all COMMON blocks.                  *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/
static void     final_attr_semantics(int        attr_idx)

{
                int                     al_idx;
                int                     darg_idx;
                int                     i;
                int                     il_idx;
                int                     local_attr_idx;
                int                     rslt_idx;
                int                     sb_idx;
                int                     sn_idx;

                int                     type_idx;

# if defined(_ASSIGN_OFFSETS_TO_HOSTED_STACK)
   static       int                     tmp_scp_idx     = NULL_IDX;
# endif

# if defined(_TMP_GIVES_COMMON_LENGTH)
                size_offset_type        length;
                size_offset_type        result;
                size_offset_type        size;
                size_offset_type        zero;
# endif

   TRACE (Func_Entry, "final_attr_semantics", NULL);

   if (AT_ATTR_LINK(attr_idx) == NULL_IDX || AT_IGNORE_ATTR_LINK(attr_idx)) {

      switch (AT_OBJ_CLASS(attr_idx)) {
      case Data_Obj:

         if (ATD_EQUIV_LIST(attr_idx) != NULL_IDX) {
            free_attr_list(ATD_EQUIV_LIST(attr_idx));
            ATD_EQUIV_LIST(attr_idx)    = NULL_IDX;
         }

         if (ATD_NO_ENTRY_LIST(attr_idx) != NULL_IDX) {
            free_attr_list(ATD_NO_ENTRY_LIST(attr_idx));
            ATD_NO_ENTRY_LIST(attr_idx) = NULL_IDX;
         }

         switch (ATD_CLASS(attr_idx)) {
         case Constant:

# ifdef _DEBUG
            if (ATD_FLD(attr_idx) == NO_Tbl_Idx) {
               PRINTMSG(AT_DEF_LINE(attr_idx), 893, Internal, 
                        AT_DEF_COLUMN(attr_idx),
                        "ATD_CONST_IDX",
                        "ATD_FLD",
                        "attr_tbl",
                        attr_idx);
            }
# endif

            /* Mark the overlay tmp as Referenced.  Have to delay until this */
            /* point, because the tmp is not created yet.  Can't do it when  */
            /* the tmp is created, because this also must be done for        */
            /* use associated constants.                                     */

            if (ATD_FLD(attr_idx) == AT_Tbl_Idx && 
               AT_REFERENCED(attr_idx) != Not_Referenced) {
               AT_REFERENCED(ATD_CONST_IDX(attr_idx)) = Referenced;
            }

            attr_idx = NULL_IDX;
            break;

         case Struct_Component:
            attr_idx = NULL_IDX;
            break;

         case Function_Result:  /* These are done, when the Function is */
            attr_idx = NULL_IDX;
            break;

         case Compiler_Tmp:
# ifdef _DEBUG
            if (ATD_FLD(attr_idx) == NO_Tbl_Idx &&
                ATD_TMP_IDX(attr_idx) != NULL_IDX) {
               PRINTMSG(AT_DEF_LINE(attr_idx), 893, Internal, 
                        AT_DEF_COLUMN(attr_idx),
                        "ATD_TMP_IDX",
                        "ATD_FLD",
                        "attr_tbl",
                        attr_idx);
            }

# endif
            if (ATD_TMP_INIT_NOT_DONE(attr_idx) &&
                ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) {
 
                /* Have a default init temp.  Generate the init */
                /* in the module, so it is ready to be used     */
                /* wherever the module is used.                 */

               insert_init_stmt_for_tmp(attr_idx);
            }

            sb_idx = ATD_STOR_BLK_IDX(attr_idx);

# if defined(_TMP_GIVES_COMMON_LENGTH)

            if (AT_REFERENCED(attr_idx) == Not_Referenced &&
                !ATD_OFFSET_ASSIGNED(attr_idx) &&
                sb_idx != NULL_IDX &&
                (SB_USE_ASSOCIATED(sb_idx) || SB_HOST_ASSOCIATED(sb_idx)) ) {

               /* If block length is zero, we do not need the tmp, so do  */
               /* not set AT_REFERENCED and it will not get sent across.  */

               if (SB_LEN_FLD(sb_idx) == CN_Tbl_Idx &&
                   fold_relationals(SB_LEN_IDX(sb_idx), 
                                    CN_INTEGER_ZERO_IDX, Ne_Opr)) {
                  size.fld      = CN_Tbl_Idx;
                  size.idx      = CN_INTEGER_BITS_PER_WORD_IDX;
                  length.fld    = SB_LEN_FLD(sb_idx);
                  length.idx    = SB_LEN_IDX(sb_idx);

                  size_offset_binary_calc(&length, &size, Mod_Opr, &size);

                  /* Size should always be less than TARGET_BITS_PER_WORD */

                  zero.fld      = CN_Tbl_Idx;
                  zero.idx      = CN_INTEGER_ZERO_IDX;

                  size_offset_logical_calc(&size, &zero, Eq_Opr, &result);

                  if (THIS_IS_TRUE(result.constant, result.type_idx)) {
                     size.idx   = CN_INTEGER_BITS_PER_WORD_IDX;
                     size.fld   = CN_Tbl_Idx;
                  }

                  CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
                  TYP_TYPE(TYP_WORK_IDX)        = Typeless;
                  TYP_BIT_LEN(TYP_WORK_IDX)     = (size.fld == CN_Tbl_Idx) ?
                      CN_INT_TO_C(size.idx) : F_INT_TO_C(size.constant,
                                                TYP_LINEAR(size.type_idx));
                  ATD_TYPE_IDX(attr_idx)        = ntr_type_tbl();

                  if (!size_offset_binary_calc(&length,
                                               &size,
                                                Minus_Opr, 
                                               &result)) {
                     AT_DCL_ERR(attr_idx) = TRUE;
                  }

                  if (result.fld == NO_Tbl_Idx) {
                     ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx;
                     ATD_OFFSET_IDX(attr_idx) = ntr_const_tbl(result.type_idx,
                                                              FALSE,
                                                              result.constant);
                  }
                  else {
                     ATD_OFFSET_FLD(attr_idx) = result.fld;
                     ATD_OFFSET_IDX(attr_idx) = result.idx;
                  }
                
                  ATD_OFFSET_ASSIGNED(attr_idx) = TRUE;
                  AT_REFERENCED(attr_idx)       = Referenced;
               }

# ifdef _DEBUG
               if (ATD_OFFSET_ASSIGNED(attr_idx) &&
                   ATD_OFFSET_FLD(attr_idx) == CN_Tbl_Idx &&
                   fold_relationals(ATD_OFFSET_IDX(attr_idx),
                                    CN_INTEGER_ZERO_IDX,
                                    Lt_Opr)) {
                  PRINTMSG(AT_DEF_LINE(attr_idx), 1004, Internal, 
                           AT_DEF_COLUMN(attr_idx),
                           AT_OBJ_NAME_PTR(attr_idx),
                           attr_idx);
               }
# endif

                /* KAY - Is this in the correct spot * */

               if (ATD_DEFINING_ATTR_IDX(attr_idx) == NULL_IDX &&
                   ATD_FLD(attr_idx) == IR_Tbl_Idx &&
                   IR_FLD_R(ATD_TMP_IDX(attr_idx)) == AT_Tbl_Idx &&
                   AT_OBJ_CLASS(IR_IDX_R(ATD_TMP_IDX(attr_idx))) == Data_Obj &&
                   ATD_CLASS(IR_IDX_R(ATD_TMP_IDX(attr_idx))) == Compiler_Tmp) {
                  ATD_DEFINING_ATTR_IDX(attr_idx) =
                         ATD_DEFINING_ATTR_IDX(IR_IDX_R(ATD_TMP_IDX(attr_idx)));
               }

               attr_idx                         = NULL_IDX;
            }
# endif
            break;

         case Variable:

            if (ATD_SYMBOLIC_CONSTANT(attr_idx) && 
                AT_REFERENCED(attr_idx) == Referenced) {
               PRINTMSG(AT_DEF_LINE(attr_idx), 1229, Ansi, 
                        AT_DEF_COLUMN(attr_idx),
                        AT_OBJ_NAME_PTR(attr_idx));
            }
               
            if (ATD_FLD(attr_idx) != NO_Tbl_Idx) {

               /* This has data initialized tmps associated with it */

               if (ATD_FLD(attr_idx) == AT_Tbl_Idx) {
                  final_attr_semantics(ATD_VARIABLE_TMP_IDX(attr_idx));
               }
               else if (ATD_FLD(attr_idx) == IL_Tbl_Idx) {

                  /* Must be structure - Have a list of tmps */

                  il_idx = ATD_VARIABLE_TMP_IDX(attr_idx);

                  while (il_idx != NULL_IDX) {
                     final_attr_semantics(IL_IDX(il_idx)); 
                     il_idx = IL_NEXT_LIST_IDX(il_idx);
                  }
               }
            }

            /* Intentional fall through */

         default:
            sb_idx      = ATD_STOR_BLK_IDX(attr_idx);

            if (sb_idx != NULL_IDX) {
               type_idx = ATD_TYPE_IDX(attr_idx);

               if (SB_VOLATILE(sb_idx)) {
                  ATD_VOLATILE(attr_idx) = TRUE;
               }

               if (ATD_EQUIV_IN_BNDS_EXPR(attr_idx) && 
                   !AT_HOST_ASSOCIATED(attr_idx) &&
                   !AT_USE_ASSOCIATED(attr_idx) &&
                   !SB_IS_COMMON(sb_idx) &&
                   !ATD_SYMBOLIC_CONSTANT(attr_idx)) {

                  /* If final_equivalence_semantics isn't called, then */
                  /* we may issue this message in bogus situations.    */

                  if (SCP_FIRST_EQUIV_GRP(curr_scp_idx) == NULL_IDX ||
                      num_prog_unit_errors == 0) {
                     PRINTMSG(AT_DEF_LINE(attr_idx), 521, Error,
                              AT_DEF_COLUMN(attr_idx),
                              AT_OBJ_NAME_PTR(attr_idx));
                  }
               }

               if (SB_AUXILIARY(sb_idx)) {

                  if (AT_NAMELIST_OBJ(attr_idx) && SB_IS_COMMON(sb_idx)) {
                     PRINTMSG(AT_DEF_LINE(attr_idx), 663, Error,
                              AT_DEF_COLUMN(attr_idx),
                              AT_OBJ_NAME_PTR(attr_idx),
                              SB_NAME_PTR(sb_idx));
                  }

                  if (!ATD_AUXILIARY(attr_idx) && 
                      SB_BLK_TYPE(sb_idx) != Formal) {

                     /* Formal dargs do not cause all the dargs to become aux */

                     if (TYP_TYPE(type_idx) == Character) {
                        PRINTMSG(AT_DEF_LINE(attr_idx), 535, Error,
                                 AT_DEF_COLUMN(attr_idx),
                                 AT_OBJ_NAME_PTR(attr_idx));
                        AT_DCL_ERR(attr_idx)  = TRUE;
                     }
                     else if (TYP_TYPE(type_idx) == Structure &&
                              (ATT_POINTER_CPNT(TYP_IDX(type_idx)) ||
                               ATT_CHAR_CPNT(TYP_IDX(type_idx)))) {
                        PRINTMSG(AT_DEF_LINE(attr_idx), 536, Error,
                                 AT_DEF_COLUMN(attr_idx),
                                 AT_OBJ_NAME_PTR(attr_idx),
                                 AT_OBJ_NAME_PTR(TYP_IDX(type_idx)));
                        AT_DCL_ERR(attr_idx)  = TRUE;
                     }
                     else if (ATD_TARGET(attr_idx) ||
                              ATD_DATA_INIT(attr_idx) ||
                              ATD_POINTER(attr_idx) ||
                              TYP_TYPE(type_idx) == CRI_Ptr) {
                        fnd_semantic_err(Obj_Auxiliary, 
                                         AT_DEF_LINE(attr_idx),
                                         AT_DEF_COLUMN(attr_idx), 
                                         attr_idx,
                                         TRUE);
                     }
                     else {
                        ATD_AUXILIARY(attr_idx) = TRUE;
                     }
                  }
               }
            }
            break;
         }

         break;

      case Pgm_Unit:

         if (attr_idx != SCP_ATTR_IDX(curr_scp_idx) &&
             ATP_IN_INTERFACE_BLK(attr_idx) &&
             !AT_HOST_ASSOCIATED(attr_idx) &&
             !AT_USE_ASSOCIATED(attr_idx)) {

            attr_idx = NULL_IDX;
            break;
         }

         switch (ATP_PGM_UNIT(attr_idx)) {
         case Function:
         case Pgm_Unknown:
         case Subroutine:

            if (ATP_GLOBAL_ATTR_IDX(attr_idx) == NULL_IDX &&
                ATP_EXPL_ITRFC(attr_idx) &&
                !AT_COMPILER_GEND(attr_idx) &&
                !ATP_NAME_IN_STONE(attr_idx) &&
                (ATP_PROC(attr_idx) == Unknown_Proc ||
                 ATP_PROC(attr_idx) == Extern_Proc ||
                 ATP_PROC(attr_idx) == Imported_Proc) &&
                !AT_IS_INTRIN(attr_idx) &&
                (attr_idx != glb_tbl_idx[Main_Attr_Idx])) {

               /* This has not been entered or resolved globally yet.  */
               /* This routine checks for this name in the global name */
               /* table.  It enters it, if it doesn't exist or checks  */
               /* for semantics errors if it does exist.               */

               check_global_pgm_unit(attr_idx);
            }

            if (ATP_NO_ENTRY_LIST(attr_idx) != NULL_IDX) {
               free_attr_list(ATP_NO_ENTRY_LIST(attr_idx));
               ATP_NO_ENTRY_LIST(attr_idx)      = NULL_IDX;
            }

            if (ATP_PROC(attr_idx) == Module_Proc) {

               if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module &&
                   !AT_PRIVATE(attr_idx) && !AT_DCL_ERR(attr_idx)) {

                  /* The function result type and all dummy argument types */
                  /* must be public types, if the procedure is public.     */

                  if (ATP_PGM_UNIT(attr_idx) == Function) {
                     type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx));

                     if (TYP_TYPE(type_idx) == Structure &&
                         AT_PRIVATE(TYP_IDX(type_idx)) &&
                        !AT_USE_ASSOCIATED(TYP_IDX(type_idx)) ) {

                        /* Issue error if the Module procedure is PUBLIC,  */
                        /* but its function result is a PRIVATE type.      */
                        /* Unless interp 161 applies.                      */

                        PRINTMSG(AT_DEF_LINE(attr_idx), 684, Error,
                                 AT_DEF_COLUMN(attr_idx),
                                 AT_OBJ_NAME_PTR(attr_idx));
                        AT_DCL_ERR(attr_idx)    = TRUE;
                     }
                  }

                  for (i = (ATP_EXTRA_DARG(attr_idx) ? 1 : 0);
                       i < ATP_NUM_DARGS(attr_idx); i++) {

                     darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(attr_idx) + i);

                     if (AT_DCL_ERR(darg_idx)) {
                        continue;
                     }


                     /* Issue error if the Module procedure is PUBLIC, but */
                     /* one of its dummy arguments is a PRIVATE type.      */

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

                     if (darg_idx != NULL_IDX &&
                        AT_OBJ_CLASS(darg_idx) == Pgm_Unit) {

                        if (ATP_PGM_UNIT(darg_idx) == Function) {
                           darg_idx = ATP_RSLT_IDX(darg_idx);
                        }
                        else {
                           darg_idx = NULL_IDX;
                        }
                     }

                     if (darg_idx != NULL_IDX &&
                         TYP_TYPE(ATD_TYPE_IDX(darg_idx)) == Structure &&
                         AT_PRIVATE(TYP_IDX(ATD_TYPE_IDX(darg_idx))) &&
                         !AT_USE_ASSOCIATED(TYP_IDX(ATD_TYPE_IDX(darg_idx))) ) {
                        PRINTMSG(AT_DEF_LINE(darg_idx), 685, Error,
                                 AT_DEF_COLUMN(darg_idx),
                                 AT_OBJ_NAME_PTR(attr_idx),
                                 AT_OBJ_NAME_PTR(darg_idx));
                        AT_DCL_ERR(attr_idx)    = TRUE;
                     }
                  }
               }
            }

            if (!AT_USE_ASSOCIATED(attr_idx)) {

               if (ATP_PROC(attr_idx) == Unknown_Proc) {
                  ATP_PROC(attr_idx) = Extern_Proc;
               }

               if (ATP_EXT_NAME_IDX(attr_idx) == NULL_IDX) {
# ifdef _DEBUG
                  PRINTMSG(AT_DEF_LINE(attr_idx), 193, Internal,
                           AT_DEF_COLUMN(attr_idx),
                           0, "ATP_EXT_NAME_IDX", attr_idx);
# endif
                  MAKE_EXTERNAL_NAME(attr_idx,
                                     AT_NAME_IDX(attr_idx),
                                     AT_NAME_LEN(attr_idx));
               }

               ATP_ALL_INTENT_IN(attr_idx) = TRUE;

               sn_idx = (ATP_EXTRA_DARG(attr_idx) && ATP_EXPL_ITRFC(attr_idx)) ?
                         ATP_FIRST_IDX(attr_idx)+1: ATP_FIRST_IDX(attr_idx);

               for (;sn_idx < (ATP_FIRST_IDX(attr_idx)+ATP_NUM_DARGS(attr_idx));
                     sn_idx++) {

                  if (AT_OBJ_CLASS(SN_ATTR_IDX(sn_idx)) != Data_Obj ||
                      ATD_CLASS(SN_ATTR_IDX(sn_idx)) != Dummy_Argument ||
                      ATD_INTENT(SN_ATTR_IDX(sn_idx)) != Intent_In) {
                     ATP_ALL_INTENT_IN(attr_idx) = FALSE;
                     break;
                  }
               }
            }

            if (ATP_HAS_ALT_RETURN(attr_idx)) {

               if (ATP_RSLT_IDX(attr_idx) == NULL_IDX) {

                  /* Create a function result as required */
                  /* by the PDGCS interface.              */

                  NTR_ATTR_TBL(rslt_idx);
                  COPY_ATTR_NTRY(rslt_idx, attr_idx);
                  CLEAR_VARIANT_ATTR_INFO(rslt_idx, Data_Obj);
                  ATD_CLASS(rslt_idx)        = Function_Result;
                  ATD_TYPE_IDX(rslt_idx)     = CG_INTEGER_DEFAULT_TYPE;
                  ATD_STOR_BLK_IDX(rslt_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
                  ATP_RSLT_IDX(attr_idx)     = rslt_idx;
               }
               attr_idx = NULL_IDX;
            }
            else {
               attr_idx = ATP_RSLT_IDX(attr_idx);
            }
            break;

         case Blockdata:
         case Program:

            if (ATP_NO_ENTRY_LIST(attr_idx) != NULL_IDX) {
               free_attr_list(ATP_NO_ENTRY_LIST(attr_idx));
               ATP_NO_ENTRY_LIST(attr_idx)      = NULL_IDX;
            }

            /* Intentional fall through to next case */

         case Module:

            if (ATP_GLOBAL_ATTR_IDX(attr_idx) == NULL_IDX &&
                !AT_COMPILER_GEND(attr_idx) &&
                (attr_idx != glb_tbl_idx[Main_Attr_Idx]) &&
                (ATP_PGM_UNIT(attr_idx) != Module ||
                 ATP_MODULE_STR_IDX(attr_idx) == NULL_IDX)) {

               /* This has not been entered or resolved globally yet.  */
               /* This routine checks for this name in the global name */
               /* table.  It enters it, if it doesn't exist or checks  */
               /* for semantics errors if it does exist.               */

               check_global_pgm_unit(attr_idx);
            }

            if (ATP_EXT_NAME_IDX(attr_idx) == NULL_IDX) {
               MAKE_EXTERNAL_NAME(attr_idx,
                                  AT_NAME_IDX(attr_idx),
                                  AT_NAME_LEN(attr_idx));
            }
            attr_idx = NULL_IDX;
            break;

         }  /* End switch */
         break;

      case Interface:

         attr_idx = ATI_PROC_IDX(attr_idx);

         if (attr_idx != NULL_IDX) {

            /* If we're in the module and processing a module procedure */
            /* and this procedure is declared inside this module, then  */
            /* skip processing until we see it in its own declaration.  */

            if (ATP_PROC(attr_idx) == Module_Proc &&
                ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module &&
                !AT_USE_ASSOCIATED(attr_idx)) {
               attr_idx = NULL_IDX;
            }
            else {
               attr_idx = ATP_RSLT_IDX(attr_idx);
            }
         }
         break;

      case Stmt_Func:

         if (!ATS_SF_SEMANTICS_DONE(attr_idx)) {
            stmt_func_semantics(attr_idx);
         }
         attr_idx = NULL_IDX;
         break;

      default:
         attr_idx = NULL_IDX;
         break;
      }

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

      if (!ATD_OFFSET_ASSIGNED(attr_idx)) {

# ifdef _DEBUG
         if (ATD_CLASS(attr_idx) == Compiler_Tmp &&
             ATD_STOR_BLK_IDX(attr_idx) == NULL_IDX &&
             !ATD_SYMBOLIC_CONSTANT(attr_idx)) {
            PRINTMSG(AT_DEF_LINE(attr_idx), 836, Internal,
                     AT_DEF_COLUMN(attr_idx),
                     AT_OBJ_NAME_PTR(attr_idx));
         }
# endif

         if (ATD_STOR_BLK_IDX(attr_idx) == NULL_IDX) {
            assign_storage_blk(attr_idx);
         }

         switch (SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx))) {

         case Static:
         case Static_Local:
         case Static_Named:

            if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX &&
                BD_ARRAY_SIZE(ATD_ARRAY_IDX(attr_idx))==Symbolic_Constant_Size){
               NTR_ATTR_LIST_TBL(al_idx);
               AL_ATTR_IDX(al_idx)              = attr_idx;
               AL_NEXT_IDX(al_idx)              = symbolic_constant_array_list;
               symbolic_constant_array_list     = al_idx;
            }
            else {
               assign_offset(attr_idx);  /* assign offsets to static storage */
               ATD_OFFSET_ASSIGNED(attr_idx) = TRUE;
            }
            break;

         case Stack:

            if (SB_HOSTED_STACK(ATD_STOR_BLK_IDX(attr_idx))) {

               if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX &&
                   BD_ARRAY_SIZE(ATD_ARRAY_IDX(attr_idx)) == 
                                               Symbolic_Constant_Size) {
                  NTR_ATTR_LIST_TBL(al_idx);
                  AL_ATTR_IDX(al_idx)           = attr_idx;
                  AL_NEXT_IDX(al_idx)           = symbolic_constant_array_list;
                  symbolic_constant_array_list  = al_idx;
               }
               else {

# if defined(_ASSIGN_OFFSETS_TO_HOSTED_STACK)
                  assign_offset(attr_idx);      /* Assign to hosted stack */
                  ATD_OFFSET_ASSIGNED(attr_idx) = TRUE;
# else
                  /* Check so the item does not exceed max storage size */

                  stor_bit_size_of(attr_idx, TRUE, FALSE);
# endif
               }
            }
            else if (!AT_DCL_ERR(attr_idx)) {

               /* Check so the item does not exceed max storage size */

               stor_bit_size_of(attr_idx, TRUE, FALSE);
            }
            break;

         case Equivalenced:
            break;

         case Task_Common:
         case Threadprivate:

            if (ATD_CLASS(attr_idx) == Compiler_Tmp &&
                ATD_DATA_INIT(attr_idx) &&
                ATD_FLD(attr_idx) == AT_Tbl_Idx) {
               ATD_OFFSET_FLD(attr_idx) = ATD_OFFSET_FLD(ATD_TMP_IDX(attr_idx));
               ATD_OFFSET_IDX(attr_idx) = ATD_OFFSET_IDX(ATD_TMP_IDX(attr_idx));
               ATD_OFFSET_ASSIGNED(attr_idx) = TRUE;
            }
            else {
               if (! ATD_OFFSET_ASSIGNED(attr_idx)) {
                  assign_offset(attr_idx);   /* Assign to task common */
                  ATD_OFFSET_ASSIGNED(attr_idx) = TRUE;
               }
            }

            break;

         case Based:
         case Formal:
         case Common:

            if (ATD_CLASS(attr_idx) == Compiler_Tmp &&
                ATD_DATA_INIT(attr_idx) && 
                ATD_FLD(attr_idx) == AT_Tbl_Idx) {
               ATD_OFFSET_FLD(attr_idx) = ATD_OFFSET_FLD(ATD_TMP_IDX(attr_idx));
               ATD_OFFSET_IDX(attr_idx) = ATD_OFFSET_IDX(ATD_TMP_IDX(attr_idx));
               ATD_OFFSET_ASSIGNED(attr_idx) = TRUE;
            }
            break;

         default:
            break;
         }
      }

      sb_idx = ATD_STOR_BLK_IDX(attr_idx);

      if (SB_MERGED_BLK_IDX(sb_idx) != NULL_IDX) {
         sb_idx                         = SB_MERGED_BLK_IDX(sb_idx);
         ATD_STOR_BLK_IDX(attr_idx)     = sb_idx;
      }

      if (SB_DEF_MULT_SCPS(sb_idx) || SB_HAS_RENAMES(sb_idx)) {
         ATD_EQUIV(attr_idx) = TRUE;
      }

# if defined(_ASSIGN_OFFSETS_TO_HOSTED_STACK)

      if (SB_HOSTED_STACK(sb_idx) && 
          SB_SCP_IDX(sb_idx) != curr_scp_idx &&
          tmp_scp_idx != curr_scp_idx) {

         /* This is the host associated stack and it is host      */
         /* associated into this scope.  This is the first time   */
         /* this storage block has been seen in this scope        */
         /* because tmp_scp_idx != curr_scp_idx.  Add the storage */
         /* blocks tmp to this scope and set tmp_scp_idx to this  */
         /* scope.  When the scope change, tmp_scp_idx will not   */
         /* change until the tmp has been added to the new scope. */
         /* The storage block's tmp is a tmp whose offset is one  */
         /* storage word size less than the total length of the   */
         /* block, with a length of one storage word size.  This  */
         /* way, the ccg/rcg will get the length of the storage   */
         /* block correct.  (We do not pass them length, they     */
         /* calculate it themselves.)                             */

         if (SB_LAST_ATTR_LIST(sb_idx) != NULL_IDX) {
            ADD_ATTR_TO_LOCAL_LIST(AL_ATTR_IDX(SB_LAST_ATTR_LIST(sb_idx)));
            tmp_scp_idx = curr_scp_idx;
         }
      }
# endif

# ifdef _DEBUG
      if ((ATD_CLASS(attr_idx) == Variable ||
           ATD_CLASS(attr_idx) == Function_Result ||
           ATD_CLASS(attr_idx) == Compiler_Tmp) &&
          ATD_OFFSET_ASSIGNED(attr_idx) &&
          ATD_OFFSET_FLD(attr_idx) == CN_Tbl_Idx &&
          fold_relationals(ATD_OFFSET_IDX(attr_idx),
                           CN_INTEGER_ZERO_IDX,
                           Lt_Opr)) {
         PRINTMSG(AT_DEF_LINE(attr_idx), 1004, Internal, 
                  AT_DEF_COLUMN(attr_idx),
                  AT_OBJ_NAME_PTR(attr_idx),
                  attr_idx);
      }
# endif
   }
   else {
      local_attr_idx    = attr_idx;

      while (AT_ATTR_LINK(attr_idx) != NULL_IDX &&
             ! AT_IGNORE_ATTR_LINK(attr_idx)) {
         attr_idx = AT_ATTR_LINK(attr_idx);
      }

# if defined(COARRAY_FORTRAN)

      if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 
          ATD_PE_ARRAY_IDX(attr_idx) &&
          (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
           ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx)))) {
         PRINTMSG(AT_DEF_LINE(local_attr_idx), 1580, Error, 
                  AT_DEF_COLUMN(local_attr_idx),
                  AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)),
                  AT_OBJ_NAME_PTR(attr_idx));
      }
# endif

      if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
          ATD_STOR_BLK_IDX(attr_idx) != NULL_IDX) {
         sb_idx = ATD_STOR_BLK_IDX(attr_idx);

# if defined(_ASSIGN_OFFSETS_TO_HOSTED_STACK)

         if (SB_HOSTED_STACK(sb_idx) && 
             SB_SCP_IDX(sb_idx) != curr_scp_idx &&
             tmp_scp_idx != curr_scp_idx) {

            /* This is the host associated stack and it is host      */
            /* associated into this scope.  This is the first time   */
            /* this storage block has been seen in this scope        */
            /* because tmp_scp_idx != curr_scp_idx.  Add the storage */
            /* blocks tmp to this scope and set tmp_scp_idx to this  */
            /* scope.  When the scope change, tmp_scp_idx will not   */
            /* change until the tmp has been added to the new scope. */
            /* The storage block's tmp is a tmp whose offset is one  */
            /* storage word size less than the total length of the   */
            /* block, with a length of one storage word size.  This  */
            /* way, the ccg/rcg will get the length of the storage   */
            /* block correct.  (We do not pass them length, they     */
            /* calculate it themselves.)                             */

            /* WARNING - This tmp_scp scheme will only work if there */
            /*           is 1 hosted stack block.                    */

            if (SB_LAST_ATTR_LIST(sb_idx) != NULL_IDX) {
               ADD_ATTR_TO_LOCAL_LIST(AL_ATTR_IDX(SB_LAST_ATTR_LIST(sb_idx)));
               tmp_scp_idx      = curr_scp_idx;
            }
         }
# endif

         if (ATD_AUXILIARY(attr_idx) || SB_AUXILIARY(sb_idx)) {
            PRINTMSG(AT_DEF_LINE(attr_idx), 607, Error,
                     AT_DEF_COLUMN(attr_idx),
                     AT_OBJ_NAME_PTR(attr_idx));
            AT_DCL_ERR(attr_idx)        = TRUE;
            AT_DCL_ERR(local_attr_idx)  = TRUE;
         }

# ifdef _DEBUG

         /* Make sure if this is on the stack that it has been moved */
         /* to a host associated storage block.                      */

         if (SB_BLK_TYPE(sb_idx) == Stack &&
             SCP_SB_HOSTED_STACK_IDX(SB_SCP_IDX(sb_idx)) != sb_idx) {
            PRINTMSG(AT_DEF_LINE(attr_idx), 850, Internal,
                     AT_DEF_COLUMN(attr_idx),
                     AT_OBJ_NAME_PTR(attr_idx));
         }
# endif
      }
   }

EXIT:

   TRACE (Func_Exit, "final_attr_semantics", NULL);

   return;

}  /* final_attr_semantics */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Allocates storage and offsets for all COMMON blocks.                  *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/
static void     check_and_allocate_common_storage(int   sb_idx)

{
   size_offset_type     adjust_by;
   int                  attr_idx;
   boolean              equived;
   int                  group;
   int                  item;
   size_offset_type     largest_len;
   size_offset_type     left;
   size_offset_type     logical_result;
   int                  name_idx;
   size_offset_type     new_len;
   int                  next_attr_idx;
   size_offset_type     result;
   size_offset_type     save_offset;

# if !defined(_TARGET_DOUBLE_ALIGN)
   size_offset_type     right;
# else
   boolean              equal_zero;
   boolean              save_dalign_opt;
# endif

# if !defined(_ERROR_DUPLICATE_GLOBALS)
   boolean              issue_message;
# endif


   TRACE (Func_Entry, "check_and_allocate_common_storage", NULL);

# if defined(_ERROR_DUPLICATE_GLOBALS)

   attr_idx = srch_sym_tbl(SB_NAME_PTR(sb_idx),
                           SB_NAME_LEN(sb_idx),
                           &name_idx);

   if (attr_idx == NULL_IDX) {
      attr_idx = srch_host_sym_tbl(SB_NAME_PTR(sb_idx),
                                   SB_NAME_LEN(sb_idx),
                                   &name_idx,
                                   FALSE);
   }

   if (attr_idx != NULL_IDX) {

      switch (AT_OBJ_CLASS(attr_idx)) {
      case Data_Obj:

         if (ATD_CLASS(attr_idx) == Constant) {

            if (SB_USE_ASSOCIATED(sb_idx)) {
               PRINTMSG(AT_DEF_LINE(attr_idx), 1033, Ansi,
                        AT_DEF_COLUMN(attr_idx),
                        SB_NAME_PTR(sb_idx));
            }
            else if (SB_HOST_ASSOCIATED(sb_idx)) {
               PRINTMSG(AT_DEF_LINE(attr_idx), 1032, Ansi,
                        AT_DEF_COLUMN(attr_idx),
                        SB_NAME_PTR(sb_idx));
            }
            else {
               PRINTMSG(AT_DEF_LINE(attr_idx), 547, Ansi,
                        AT_DEF_COLUMN(attr_idx),
                        SB_NAME_PTR(sb_idx));
            }
         }
         break;

      case Pgm_Unit:

         if (ATP_PROC(attr_idx) == Intrin_Proc &&
             AT_REFERENCED(attr_idx) >= Dcl_Bound_Ref) {

            if (SB_USE_ASSOCIATED(sb_idx)) {
               PRINTMSG(AT_DEF_LINE(attr_idx), 1031, Error,
                        AT_DEF_COLUMN(attr_idx),
                        SB_NAME_PTR(sb_idx));
            }
            else if (SB_HOST_ASSOCIATED(sb_idx)) {
               PRINTMSG(AT_DEF_LINE(attr_idx), 1030, Error,
                        AT_DEF_COLUMN(attr_idx),
                        SB_NAME_PTR(sb_idx));
            }
            else {
               PRINTMSG(AT_DEF_LINE(attr_idx), 1005, Error,
                        AT_DEF_COLUMN(attr_idx),
                        SB_NAME_PTR(sb_idx));
            }
         }
         break;

      case Interface:

         if (AT_IS_INTRIN(attr_idx) && 
             AT_REFERENCED(attr_idx) >= Dcl_Bound_Ref) {

            if (SB_USE_ASSOCIATED(sb_idx)) {
               PRINTMSG(AT_DEF_LINE(attr_idx), 1031, Error,
                        AT_DEF_COLUMN(attr_idx),
                        SB_NAME_PTR(sb_idx));
            }
            else if (SB_HOST_ASSOCIATED(sb_idx)) {
               PRINTMSG(AT_DEF_LINE(attr_idx), 1030, Error,
                        AT_DEF_COLUMN(attr_idx),
                        SB_NAME_PTR(sb_idx));
            }
            else {
               PRINTMSG(AT_DEF_LINE(attr_idx), 1005, Error,
                        AT_DEF_COLUMN(attr_idx),
                        SB_NAME_PTR(sb_idx));
            }
         }
         break;
      }
   }

# else

   issue_message = GET_MESSAGE_TBL(message_warning_tbl, 1033) ||
                   GET_MESSAGE_TBL(message_error_tbl, 1033) ||
                   GET_MESSAGE_TBL(message_warning_tbl, 1032) ||
                   GET_MESSAGE_TBL(message_error_tbl, 1032) ||
                   GET_MESSAGE_TBL(message_warning_tbl, 547) ||
                   GET_MESSAGE_TBL(message_error_tbl, 547) ||
                   GET_MESSAGE_TBL(message_warning_tbl, 1029) ||
                   GET_MESSAGE_TBL(message_error_tbl, 1029) ||
                   GET_MESSAGE_TBL(message_warning_tbl, 1028) ||
                   GET_MESSAGE_TBL(message_error_tbl, 1028) ||
                   GET_MESSAGE_TBL(message_warning_tbl, 714) ||
                   GET_MESSAGE_TBL(message_error_tbl, 714);


   if (issue_message || on_off_flags.issue_ansi_messages) {
      attr_idx = srch_sym_tbl(SB_NAME_PTR(sb_idx),
                              SB_NAME_LEN(sb_idx),
                              &name_idx);

      if (attr_idx == NULL_IDX) {
         attr_idx = srch_host_sym_tbl(SB_NAME_PTR(sb_idx),
                                      SB_NAME_LEN(sb_idx),
                                      &name_idx,
                                      FALSE);
      }

      if (attr_idx != NULL_IDX) {

         switch (AT_OBJ_CLASS(attr_idx)) {
         case Data_Obj:

            if (ATD_CLASS(attr_idx) == Constant) {

               if (SB_USE_ASSOCIATED(sb_idx)) {
                  PRINTMSG(AT_DEF_LINE(attr_idx), 1033, Ansi,
                           AT_DEF_COLUMN(attr_idx),
                           SB_NAME_PTR(sb_idx));
               }
               else if (SB_HOST_ASSOCIATED(sb_idx)) {
                  PRINTMSG(AT_DEF_LINE(attr_idx), 1032, Ansi,
                           AT_DEF_COLUMN(attr_idx),
                           SB_NAME_PTR(sb_idx));
               }
               else {
                  PRINTMSG(AT_DEF_LINE(attr_idx), 547, Ansi,
                           AT_DEF_COLUMN(attr_idx),
                           SB_NAME_PTR(sb_idx));
               }
            }
            break;

         case Pgm_Unit:

            if (ATP_PROC(attr_idx) == Intrin_Proc &&
                AT_REFERENCED(attr_idx) >= Dcl_Bound_Ref) {

               if (SB_USE_ASSOCIATED(sb_idx)) {
                  PRINTMSG(AT_DEF_LINE(attr_idx), 1029, Ansi,
                           AT_DEF_COLUMN(attr_idx),
                           SB_NAME_PTR(sb_idx));
               }
               else if (SB_HOST_ASSOCIATED(sb_idx)) {
                  PRINTMSG(AT_DEF_LINE(attr_idx), 1028, Ansi,
                           AT_DEF_COLUMN(attr_idx),
                           SB_NAME_PTR(sb_idx));
               }
               else {
                  PRINTMSG(AT_DEF_LINE(attr_idx), 714, Ansi,
                           AT_DEF_COLUMN(attr_idx),
                           SB_NAME_PTR(sb_idx));
               }
            }
            break;

         case Interface:

            if (AT_IS_INTRIN(attr_idx) && 
                AT_REFERENCED(attr_idx) >= Dcl_Bound_Ref) {

               if (SB_USE_ASSOCIATED(sb_idx)) {
                  PRINTMSG(AT_DEF_LINE(attr_idx), 1029, Ansi,
                           AT_DEF_COLUMN(attr_idx),
                           SB_NAME_PTR(sb_idx));
               }
               else if (SB_HOST_ASSOCIATED(sb_idx)) {
                  PRINTMSG(AT_DEF_LINE(attr_idx), 1028, Ansi,
                           AT_DEF_COLUMN(attr_idx),
                           SB_NAME_PTR(sb_idx));
               }
               else {
                  PRINTMSG(AT_DEF_LINE(attr_idx), 714, Ansi,
                           AT_DEF_COLUMN(attr_idx),
                           SB_NAME_PTR(sb_idx));
               }
            }
            break;
         }
      }
   }
# endif

   if (SB_USE_ASSOCIATED(sb_idx) || !SB_COMMON_NEEDS_OFFSET(sb_idx)) {
      goto EXIT;
   }

   if (SB_FIRST_ATTR_IDX(sb_idx) == NULL_IDX && !SB_DCL_ERR(sb_idx)) {

      if (SB_SAVED(sb_idx)) {

         /* The common block was declared in a save statement, but */
         /* not as an actual common block.                         */

         PRINTMSG(SB_DEF_LINE(sb_idx), 688, Error,
                  SB_DEF_COLUMN(sb_idx), 
                  SB_NAME_PTR(sb_idx));
         SB_DCL_ERR(sb_idx)     = TRUE;
      }
      else if (SB_BLK_TYPE(sb_idx) == Threadprivate) {
         PRINTMSG(SB_DEF_LINE(sb_idx), 1502, Error,
                  SB_DEF_COLUMN(sb_idx), 
                  SB_NAME_PTR(sb_idx),
                  "THREAD_PRIVATE");
         SB_DCL_ERR(sb_idx)     = TRUE;
      }
      else if (SB_CACHE_ALIGN(sb_idx)) {
         PRINTMSG(SB_DEF_LINE(sb_idx), 1168, Error,
                  SB_DEF_COLUMN(sb_idx), 
                  SB_NAME_PTR(sb_idx));
         SB_DCL_ERR(sb_idx)     = TRUE;
      }
      else if (SB_SECTION_GP(sb_idx)) {
         PRINTMSG(SB_DEF_LINE(sb_idx), 1502, Error,
                  SB_DEF_COLUMN(sb_idx), 
                  SB_NAME_PTR(sb_idx),
                  "SECTION_GP");
         SB_DCL_ERR(sb_idx)     = TRUE;
      }
      else if (SB_SECTION_NON_GP(sb_idx)) {
         PRINTMSG(SB_DEF_LINE(sb_idx), 1502, Error,
                  SB_DEF_COLUMN(sb_idx), 
                  SB_NAME_PTR(sb_idx),
                  "SECTION_NON_GP");
         SB_DCL_ERR(sb_idx)     = TRUE;
      }
# if 0
      else if (SB_ALIGN_SYMBOL(sb_idx)) {
         PRINTMSG(SB_DEF_LINE(sb_idx), 1502, Error,
                  SB_DEF_COLUMN(sb_idx), 
                  SB_NAME_PTR(sb_idx),
                  "ALIGN_SYMBOL");
         SB_DCL_ERR(sb_idx)     = TRUE;
      }
      else if (SB_FILL_SYMBOL(sb_idx)) {
         PRINTMSG(SB_DEF_LINE(sb_idx), 1502, Error,
                  SB_DEF_COLUMN(sb_idx), 
                  SB_NAME_PTR(sb_idx),
                  "FILL_SYMBOL");
         SB_DCL_ERR(sb_idx)     = TRUE;
      }
# endif
      else if (SB_DCL_COMMON_DIR(sb_idx)) {
         SB_DCL_ERR(sb_idx)     = TRUE;
         PRINTMSG(SB_DEF_LINE(sb_idx), 1128, Error,
                  SB_DEF_COLUMN(sb_idx), 
                  SB_NAME_PTR(sb_idx));
      }
      else if (SB_BLK_TYPE(sb_idx) == Task_Common) {
         SB_DCL_ERR(sb_idx)     = TRUE;
         PRINTMSG(SB_DEF_LINE(sb_idx), 690, Error,
                  SB_DEF_COLUMN(sb_idx), 
                  SB_NAME_PTR(sb_idx));
      }
   }

   if (SB_DCL_COMMON_DIR(sb_idx) && SB_BLK_TYPE(sb_idx) == Task_Common) {
      SB_DCL_ERR(sb_idx)        = TRUE;
      PRINTMSG(SB_DEF_LINE(sb_idx), 1129, Error,
               SB_DEF_COLUMN(sb_idx), 
               SB_NAME_PTR(sb_idx));
   }

   attr_idx     = SB_FIRST_ATTR_IDX(sb_idx);
   equived      = FALSE;

   while (attr_idx != NULL_IDX && !equived) {
      equived   = equived || ATD_EQUIV(attr_idx);
      attr_idx  = ATD_NEXT_MEMBER_IDX(attr_idx);
   }

   if (SB_PAD_BLK(sb_idx) && equived) { /* -a pad and equiv don't go together */
      PRINTMSG(SB_DEF_LINE(sb_idx), 1351, Warning,
               SB_DEF_COLUMN(sb_idx), 
               SB_BLANK_COMMON(sb_idx) ?
               "" : SB_NAME_PTR(sb_idx));
      SB_PAD_BLK(sb_idx)= FALSE;
   }

   next_attr_idx        = SB_FIRST_ATTR_IDX(sb_idx);
   largest_len.fld      = SB_LEN_FLD(sb_idx);
   largest_len.idx      = SB_LEN_IDX(sb_idx);

   while (next_attr_idx != NULL_IDX) {
      attr_idx                  = next_attr_idx;
      next_attr_idx             = ATD_NEXT_MEMBER_IDX(attr_idx);

      if (AT_DCL_ERR(attr_idx)) {

         /* Error - Do not attempt to assign offset. */

      }
      else if (!ATD_EQUIV(attr_idx) || num_prog_unit_errors != 0) {

         /* We do not do equivalence processing if we found any errors in */
         /* this program unit.  Error recovery doesn't work too well.     */

         assign_offset(attr_idx);       /* Equivalence */
         ATD_OFFSET_ASSIGNED(attr_idx)  = TRUE;
         ATD_EQUIV(attr_idx)            = equived;
      }
      else {

         if (ATD_OFFSET_IDX(attr_idx) == NULL_IDX) {
            ATD_OFFSET_IDX(attr_idx) = CN_INTEGER_ZERO_IDX;
            ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx;
         }

         save_offset.fld        = ATD_OFFSET_FLD(attr_idx);
         save_offset.idx        = ATD_OFFSET_IDX(attr_idx);

# if defined(_TARGET_DOUBLE_ALIGN)
         save_dalign_opt        = cmd_line_flags.dalign;
         cmd_line_flags.dalign  = FALSE;

         /* Offset will not get daligned, because dalign flag = FALSE */
         /* If daligning is necessary, it will be done by hand here.  */

         assign_offset(attr_idx);   /* Equivalence */

         cmd_line_flags.dalign  = save_dalign_opt;
         left.fld               = ATD_OFFSET_FLD(attr_idx);
         left.idx               = ATD_OFFSET_IDX(attr_idx);

         if (!size_offset_binary_calc(&left,
                                      &save_offset, 
                                       Minus_Opr,
                                      &adjust_by)) {
            AT_DCL_ERR(attr_idx) = TRUE;
         }

# else
         assign_offset(attr_idx);  /* Equivalence */

         left.fld               = ATD_OFFSET_FLD(attr_idx);
         left.idx               = ATD_OFFSET_IDX(attr_idx);

         if (!size_offset_binary_calc(&left,
                                      &save_offset, 
                                       Minus_Opr,
                                      &adjust_by)) {
            AT_DCL_ERR(attr_idx) = TRUE;
         }

         if (ATD_OFFSET_ASSIGNED(attr_idx)) {
            right.fld   = CN_Tbl_Idx;
            right.idx   = CN_INTEGER_ZERO_IDX;

            size_offset_logical_calc(&adjust_by, &right, Eq_Opr, &result);

             if (THIS_IS_TRUE(result.constant, result.type_idx)) {

               /* Offset for this attr is assigned already, because it is in */
               /* a previous equivalence group.  This offset should agree    */
               /* with the new offset just assigned.  If it doesn't continue */
               /* and issue an error later, when we can give a better line   */
               /* and column number.  If it is zero, continue to next attr.  */

               continue;
            }
         }
# endif

         group = SCP_FIRST_EQUIV_GRP(curr_scp_idx);

         while (group != NULL_IDX) {
            item                = group;

            while (item != NULL_IDX) {

# if _DEBUG
               if (!ATD_EQUIV(EQ_ATTR_IDX(item)) && 
                   !AT_DCL_ERR(EQ_ATTR_IDX(item)) &&
                   ATD_CLASS(EQ_ATTR_IDX(item)) == Variable) {
                  PRINTMSG(AT_DEF_LINE(EQ_ATTR_IDX(item)), 
                           1019, 
                           Internal, 
                           AT_DEF_COLUMN(EQ_ATTR_IDX(item)),
                           AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
               }
# endif

               if (EQ_ATTR_IDX(item) == attr_idx) {
                  goto FOUND;
               }
               item = EQ_NEXT_EQUIV_OBJ(item);
            }
            group = EQ_NEXT_EQUIV_GRP(group);
         }

         ATD_OFFSET_ASSIGNED(attr_idx)  = TRUE;

         /* This is a data initialized item.  It is equivalenced to a tmp. */
         /* The tmps offset gets set in final_attr_semantics.              */

         continue;    

FOUND:

         if (ATD_OFFSET_ASSIGNED(attr_idx)) {

            if (fold_relationals(ATD_OFFSET_IDX(attr_idx),
                                 save_offset.idx,
                                 Ne_Opr)) {
                PRINTMSG(EQ_LINE_NUM(item), 862, Error,
                         EQ_COLUMN_NUM(item),
                         AT_OBJ_NAME_PTR(attr_idx));
            }
            continue;
         }

# if defined(_TARGET_DOUBLE_ALIGN)

         else {
            if (EQ_DALIGN_ME(item)) { 
               C_TO_F_INT(result.constant, TARGET_BITS_PER_WORD * 2,
                          CG_INTEGER_DEFAULT_TYPE);
               result.fld               = NO_Tbl_Idx;
               result.type_idx          = CG_INTEGER_DEFAULT_TYPE;

               if (!size_offset_binary_calc(&adjust_by,
                                            &result,
                                             Mod_Opr,
                                            &result)) {
                  AT_DCL_ERR(attr_idx)  = TRUE;
               }

               left.fld = CN_Tbl_Idx;
               left.idx = CN_INTEGER_ZERO_IDX;

               size_offset_logical_calc(&left, &result, Eq_Opr, &result);

               equal_zero = THIS_IS_TRUE(result.constant, result.type_idx);

               if ((equal_zero && EQ_DALIGN_SHIFT(item)) || 
                   (!equal_zero && !EQ_DALIGN_SHIFT(item))) { 

                  if (cmd_line_flags.dalign) {

                     /* If offset % TARGET_BITS == 0, the new offset is on a  */
                     /* double word boundary.  If !EQ_DALIGN_SHIFT then the   */
                     /* equivalence group is on a double word boundary.  What */
                     /* the above if statement says is that if both the new   */
                     /* offset and the equivalence group are on a double word */
                     /* boundary - do nothing.  If neither one is on a double */
                     /* word boundary, do nothing.  But if one is on a double */
                     /* word boundary and the other is not, adjust new offset.*/

                     result.fld = CN_Tbl_Idx;
                     result.idx = CN_INTEGER_BITS_PER_WORD_IDX;

                     if (!size_offset_binary_calc(&adjust_by,
                                                  &result,
                                                   Plus_Opr,
                                                  &adjust_by)) {
                        AT_DCL_ERR(attr_idx) = TRUE;
                     }

                     left.fld   = ATD_OFFSET_FLD(attr_idx);
                     left.idx   = ATD_OFFSET_IDX(attr_idx);

                     if (!size_offset_binary_calc(&left,
                                                  &result,
                                                   Plus_Opr,
                                                  &result)) {
                        AT_DCL_ERR(attr_idx) = TRUE;
                     }

                     if (result.fld == NO_Tbl_Idx) {
                        ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx;
                        ATD_OFFSET_IDX(attr_idx) = ntr_const_tbl(
                                                             result.type_idx,
                                                             FALSE,
                                                             result.constant);
                     }
                     else {
                        ATD_OFFSET_FLD(attr_idx) = result.fld;
                        ATD_OFFSET_IDX(attr_idx) = result.idx;
                     }

                     result.fld = CN_Tbl_Idx;
                     result.idx = CN_INTEGER_BITS_PER_WORD_IDX;
                     left.fld   = SB_LEN_FLD(sb_idx);
                     left.idx   = SB_LEN_IDX(sb_idx);

                     if (!size_offset_binary_calc(&left,
                                                  &result,
                                                   Plus_Opr,
                                                  &result)) {
                        AT_DCL_ERR(attr_idx) = TRUE;
                     }

                     if (result.fld == NO_Tbl_Idx) {
                        SB_LEN_FLD(sb_idx) = CN_Tbl_Idx;
                        SB_LEN_IDX(sb_idx) = ntr_const_tbl(result.type_idx,
                                                           FALSE,
                                                           result.constant);
                     }
                     else {
                        SB_LEN_FLD(sb_idx)  = result.fld;
                        SB_LEN_IDX(sb_idx)  = result.idx;
                     }

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

                    /* -a dalign is always on for IRIX and there is no */
                    /* way to shut it off, so we do not need to issue  */
                    /* this warning for IRIX.                          */

                     PRINTMSG(AT_DEF_LINE(attr_idx), 1013, Warning, 
                              AT_DEF_COLUMN(attr_idx),
                              AT_OBJ_NAME_PTR(attr_idx),
                              SB_BLANK_COMMON(sb_idx) ?
                              "" : SB_NAME_PTR(sb_idx));
# endif
                  } 
                  else {  /* Cannot double align */
                     PRINTMSG(AT_DEF_LINE(attr_idx), 1161, Caution, 
                              AT_DEF_COLUMN(attr_idx),
                              AT_OBJ_NAME_PTR(attr_idx),
                              SB_BLANK_COMMON(sb_idx) ?
                              "" : SB_NAME_PTR(sb_idx));
                  } 
               }
            }
         }
# endif

         ATD_OFFSET_ASSIGNED(attr_idx)  = TRUE;
         item                           = group;

         while (item != NULL_IDX) {

            if (!ATD_OFFSET_ASSIGNED(EQ_ATTR_IDX(item))) {

               if (ATD_OFFSET_IDX(EQ_ATTR_IDX(item)) == NULL_IDX) {
                  ATD_OFFSET_FLD(EQ_ATTR_IDX(item)) = CN_Tbl_Idx;
                  ATD_OFFSET_IDX(EQ_ATTR_IDX(item)) = ntr_const_tbl(
                                                         adjust_by.type_idx,
                                                         FALSE,
                                                         adjust_by.constant);
               }
               else {
                  left.fld      = ATD_OFFSET_FLD(EQ_ATTR_IDX(item));
                  left.idx      = ATD_OFFSET_IDX(EQ_ATTR_IDX(item));

                  if (!size_offset_binary_calc(&left,
                                               &adjust_by,
                                                Plus_Opr,
                                               &result)) {
                     AT_DCL_ERR(EQ_ATTR_IDX(item)) = TRUE;
                  }

                  if (result.fld == NO_Tbl_Idx) {
                     ATD_OFFSET_FLD(EQ_ATTR_IDX(item)) = CN_Tbl_Idx;
                     ATD_OFFSET_IDX(EQ_ATTR_IDX(item)) = ntr_const_tbl(
                                                             result.type_idx,
                                                             FALSE,
                                                             result.constant);
                  }
                  else {
                     ATD_OFFSET_FLD(EQ_ATTR_IDX(item)) = result.fld;
                     ATD_OFFSET_IDX(EQ_ATTR_IDX(item)) = result.idx;
                  }
               }

               ATD_OFFSET_ASSIGNED(EQ_ATTR_IDX(item))    = TRUE;

               if (fold_relationals(ATD_OFFSET_IDX(EQ_ATTR_IDX(item)),
                                    CN_INTEGER_ZERO_IDX,
                                    Lt_Opr)) {
                  PRINTMSG(SB_DEF_LINE(sb_idx), 526, Error,
                           SB_DEF_COLUMN(sb_idx),
                           SB_BLANK_COMMON(sb_idx) ?
                           "" : SB_NAME_PTR(sb_idx),
                           AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
                  ATD_OFFSET_IDX(EQ_ATTR_IDX(item))     = CN_INTEGER_ZERO_IDX;
                  ATD_OFFSET_FLD(EQ_ATTR_IDX(item))     = CN_Tbl_Idx;
                  AT_DCL_ERR(EQ_ATTR_IDX(item))         = TRUE;
               }

               new_len  = stor_bit_size_of(EQ_ATTR_IDX(item), TRUE, FALSE);
               left.fld = ATD_OFFSET_FLD(EQ_ATTR_IDX(item));
               left.idx = ATD_OFFSET_IDX(EQ_ATTR_IDX(item));

               if (!size_offset_binary_calc(&left, &new_len, Plus_Opr,&result)){
                  AT_DCL_ERR(EQ_ATTR_IDX(item)) = TRUE;
               }

               size_offset_logical_calc(&result, 
                                        &largest_len,
                                         Gt_Opr,
                                        &logical_result);

               if (THIS_IS_TRUE(logical_result.constant,
                                logical_result.type_idx)) {
                  largest_len = result;
               }
            }
            else if (!ATD_IN_COMMON(EQ_ATTR_IDX(item))) {
               left.fld = EQ_OFFSET_FLD(item);
               left.idx = EQ_OFFSET_IDX(item);

               if (!size_offset_binary_calc(&left,&adjust_by,Plus_Opr,&result)){
                  AT_DCL_ERR(EQ_ATTR_IDX(item)) = TRUE;
               }

               left.fld = ATD_OFFSET_FLD(EQ_ATTR_IDX(item));
               left.idx = ATD_OFFSET_IDX(EQ_ATTR_IDX(item));

               size_offset_logical_calc(&left, &result, Ne_Opr,&logical_result);

               if (THIS_IS_TRUE(logical_result.constant,
                                logical_result.type_idx)) {
                  PRINTMSG(EQ_LINE_NUM(item), 862, Error,
                           EQ_COLUMN_NUM(item),
                           AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
               }
            }
            item = EQ_NEXT_EQUIV_OBJ(item);
         }
      }
   }
   left.fld     = SB_LEN_FLD(sb_idx);
   left.idx     = SB_LEN_IDX(sb_idx);

   size_offset_logical_calc(&largest_len, &left, Gt_Opr, &logical_result);

   if (!THIS_IS_TRUE(logical_result.constant,
                     logical_result.type_idx)) {
      largest_len.idx   = SB_LEN_IDX(sb_idx);
      largest_len.fld   = SB_LEN_FLD(sb_idx);
   }

   align_bit_length(&largest_len, TARGET_BITS_PER_WORD);

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

   SB_LEN_FLD(sb_idx) = largest_len.fld;
   SB_LEN_IDX(sb_idx) = largest_len.idx;

   SB_COMMON_NEEDS_OFFSET(sb_idx) = FALSE;

   if (cmd_line_flags.taskcommon && !SB_DCL_COMMON_DIR(sb_idx)) {

      /* Switch all common blocks to task common */

      SB_BLK_TYPE(sb_idx)       = Task_Common;
      SB_RUNTIME_INIT(sb_idx)   = FALSE;
   }

EXIT:

   TRACE (Func_Exit, "check_and_allocate_common_storage", NULL);

   return;

}  /* check_and_allocate_common_storage */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Resolves multiple storage blocks in the current scope to one block.   *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/
static void     storage_blk_resolution()
{
   int                  attr_idx;
   int                  ga_idx;
   int                  gac_idx;
   int                  ga_pgm_idx;
   int                  host_sb_idx;
   msg_severities_type  msg_level;
   int                  name_idx;
   size_offset_type     result;
   boolean              same_common_block;
   int                  same_sb_idx;
   int                  sb_idx;

# if !defined(_SEPARATE_NONCOMMON_EQUIV_GROUPS)
   int                  group;
   int                  item;
   id_str_type          name;
   int                  new_sb_idx;
   int                  np_idx;
   size_offset_type     offset;
# endif

# if defined(_TARGET_DOUBLE_ALIGN)
   size_offset_type     left;
# endif


   TRACE (Func_Entry, "storage_blk_resolution", NULL);

   /* Set the data initialized flag for the static initialization stor blk */

   for (sb_idx = 1; sb_idx <= stor_blk_tbl_idx; sb_idx++) {

      if (SB_SCP_IDX(sb_idx) != curr_scp_idx) {
         continue;
      }

      if (SB_IS_COMMON(sb_idx)) {
         SB_PAD_BLK(sb_idx) = cmd_line_flags.pad;

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

         check_and_allocate_common_storage(sb_idx);
  
         if (!SB_HIDDEN(sb_idx) && !SB_HOST_ASSOCIATED(sb_idx)) {

            if (srch_global_name_tbl(SB_NAME_PTR(sb_idx), 
                                     SB_NAME_LEN(sb_idx),
                                     &name_idx)) {

               gac_idx  = GN_ATTR_IDX(name_idx);

               if (GA_OBJ_CLASS(gac_idx) != Common_Block) {

                  /* Have a common and program unit with same name.  The    */
                  /* common entry is always first and then points to the    */
                  /* program unit.  Add a global attr for the common block. */

                  ga_pgm_idx    = gac_idx;
                  gac_idx       = ntr_common_in_global_attr_tbl(sb_idx, 
                                                                name_idx);

                  GAC_PGM_UNIT_IDX(gac_idx) = ga_pgm_idx;
                  GN_ATTR_IDX(name_idx)     = gac_idx;

# if defined(_ERROR_DUPLICATE_GLOBALS)
                  msg_level = Error;
# else
                  msg_level = (GAP_PGM_UNIT(ga_pgm_idx) == Module) ?
                              Error : Ansi;
# endif
                  PRINTMSG(SB_DEF_LINE(sb_idx), 1006, msg_level,
                           SB_DEF_COLUMN(sb_idx),
                           SB_NAME_PTR(sb_idx),
                           pgm_unit_str[GAP_PGM_UNIT(ga_pgm_idx)]);
               }
               else {
                  same_common_block = !SB_EQUIVALENCED(sb_idx) && 
                                      !GAC_EQUIVALENCED(gac_idx);

                  /* Common block used in another program unit. */

                  if (SB_AUXILIARY(sb_idx) ^ GAC_AUXILIARY(gac_idx)) {
                     same_common_block  = FALSE;
                     PRINTMSG(SB_DEF_LINE(sb_idx), 1276, Warning,
                              SB_DEF_COLUMN(sb_idx),
                              SB_NAME_PTR(sb_idx),
                              "AUXILIARY");
                  }

                  if ((SB_BLK_TYPE(sb_idx) == Task_Common && 
                      !GAC_TASK_COMMON(gac_idx)) ||
                      (SB_BLK_TYPE(sb_idx) != Task_Common && 
                       GAC_TASK_COMMON(gac_idx))) {
                     same_common_block  = FALSE;
          
                     PRINTMSG(SB_DEF_LINE(sb_idx), 1276, Warning,
                              SB_DEF_COLUMN(sb_idx),
                              SB_NAME_PTR(sb_idx),
                              "TASK_COMMON");
                  }

                  if (SB_ALIGN_SYMBOL(sb_idx) ^ GAC_ALIGN_SYMBOL(gac_idx)) {
                     same_common_block  = FALSE;
                     PRINTMSG(SB_DEF_LINE(sb_idx), 1602, Warning,
                              SB_DEF_COLUMN(sb_idx),
                              SB_NAME_PTR(sb_idx),
                              "ALIGN_SYMBOL");
                  }

                  if (SB_FILL_SYMBOL(sb_idx) ^ GAC_FILL_SYMBOL(gac_idx)) {
                     same_common_block  = FALSE;
                     PRINTMSG(SB_DEF_LINE(sb_idx), 1602, Warning,
                              SB_DEF_COLUMN(sb_idx),
                              SB_NAME_PTR(sb_idx),
                              "FILL_SYMBOL");
                  }

                  if (SB_SECTION_GP(sb_idx) ^ GAC_SECTION_GP(gac_idx)) {
                     same_common_block  = FALSE;
                     PRINTMSG(SB_DEF_LINE(sb_idx), 1602, Warning,
                              SB_DEF_COLUMN(sb_idx),
                              SB_NAME_PTR(sb_idx),
                              "SECTION_GP");
                  }

                  if (SB_SECTION_NON_GP(sb_idx) ^ GAC_SECTION_NON_GP(gac_idx)) {
                     same_common_block  = FALSE;
                     PRINTMSG(SB_DEF_LINE(sb_idx), 1602, Warning,
                              SB_DEF_COLUMN(sb_idx),
                              SB_NAME_PTR(sb_idx),
                              "SECTION_NON_GP");
                  }

                  if (SB_CACHE_ALIGN(sb_idx) ^ GAC_CACHE_ALIGN(gac_idx)) {
                     same_common_block  = FALSE;
                     PRINTMSG(SB_DEF_LINE(sb_idx), 1602, Warning,
                              SB_DEF_COLUMN(sb_idx),
                              SB_NAME_PTR(sb_idx),
                              "CACHE_ALIGN");
                  }

                  /* Check to make sure all the members have the same type */
                  /* kind and rank.   We'll check for same name too.       */

                  attr_idx      = SB_FIRST_ATTR_IDX(sb_idx);
                  ga_idx        = GAC_FIRST_MEMBER_IDX(gac_idx);

                  while (attr_idx != NULL_IDX && ga_idx != NULL_IDX) {

                     /* We are looking at all Common block objects, so */
                     /* we can assume that these are all Variables.    */

                     if (!compare_global_type_rank(ga_idx,
                                                   NULL_IDX,
                                                   attr_idx,
                                                   NULL_IDX,
                                                   TRUE)) {
                        same_common_block       = FALSE;
# if 0
                        PRINTMSG(AT_DEF_LINE(attr_idx), 1603, Caution,
                                 AT_DEF_COLUMN(attr_idx),
                                 SB_NAME_PTR(sb_idx));
# endif
                        break;
                     }
                     attr_idx   = ATD_NEXT_MEMBER_IDX(attr_idx);
                     ga_idx     = GAD_NEXT_IDX(ga_idx);
                  }

                  if (attr_idx != NULL_IDX || ga_idx != NULL_IDX) {
                     same_common_block  = FALSE;
                  }

                  if (!same_common_block) {
                     GAC_FOUND_DIFFS(gac_idx)           = TRUE;
                     SB_DUPLICATE_COMMON(sb_idx)        = FALSE;
                  }
                  else if (!GAC_FOUND_DIFFS(gac_idx)) {
                     SB_DUPLICATE_COMMON(sb_idx)        = TRUE;
                  }
               }
            }
            else {
               ntr_global_name_tbl(NULL_IDX, sb_idx, name_idx);
            }
         }
      }
      else if (cmd_line_flags.taskcommon) {

         /* All module blocks and all static blocks must be switched to      */
         /* taskcommon if the -a taskcommon commandline option is specified. */

         if (SB_MODULE(sb_idx) ||
             SB_BLK_TYPE(sb_idx) == Static ||
             SB_BLK_TYPE(sb_idx) == Static_Named ||
             SB_BLK_TYPE(sb_idx) == Static_Local) {
            SB_BLK_TYPE(sb_idx) = Task_Common;
         }
      }
      else if (cmd_line_flags.static_threadprivate) {

         /* All module blocks and all static blocks must be switched */
         /* to taskcommon if the -a static_threadprivate commandline */
         /* option is specified.                                     */

         if (SB_MODULE(sb_idx) ||
             SB_BLK_TYPE(sb_idx) == Static ||
             SB_BLK_TYPE(sb_idx) == Static_Named ||
             SB_BLK_TYPE(sb_idx) == Static_Local) {
            SB_BLK_TYPE(sb_idx) = Threadprivate;
         }
      }


      if (SB_BLK_TYPE(sb_idx) == Equivalenced && SB_HOSTED_STACK(sb_idx)) {

# if defined(_DEBUG)

         if (SB_LEN_FLD(sb_idx) != CN_Tbl_Idx) {
            PRINTMSG(SB_DEF_LINE(sb_idx), 1201, Internal, SB_DEF_COLUMN(sb_idx),
                     SB_NAME_PTR(sb_idx));
         }
# endif

         result.fld     = SB_LEN_FLD(sb_idx);
         result.idx     = SB_LEN_IDX(sb_idx);

         align_bit_length(&result, TARGET_BITS_PER_WORD);

         if (result.fld == NO_Tbl_Idx) {
            SB_LEN_FLD(sb_idx) = CN_Tbl_Idx;
            SB_LEN_IDX(sb_idx) = ntr_const_tbl(result.type_idx,
                                               FALSE,
                                               result.constant);
         }
         else {
            SB_LEN_FLD(sb_idx) = result.fld;
            SB_LEN_IDX(sb_idx) = result.idx;
         }

# if !defined(_SEPARATE_NONCOMMON_EQUIV_GROUPS)

         /* Host associated stack equivalence group.  Merge this group with  */
         /* the host associated stack.  If there is no hosted group, just    */
         /* make this one the hosted stack group.                            */

         if (SCP_SB_HOSTED_STACK_IDX(curr_scp_idx) == NULL_IDX) {
            CREATE_ID(name, sb_name[Stack_Host_Blk], sb_len[Stack_Host_Blk]);
            NTR_NAME_POOL(&(name.words[0]), sb_len[Stack_Host_Blk], np_idx);
            SB_NAME_IDX(sb_idx)                   = np_idx;
            SB_NAME_LEN(sb_idx)                   = sb_len[Stack_Host_Blk];
            SB_BLK_TYPE(sb_idx)                   = Stack;
            SB_RUNTIME_INIT(sb_idx)               = TRUE;
            SCP_SB_HOSTED_STACK_IDX(curr_scp_idx) = sb_idx;
         }
         else {  /* Merge this group with the already existing @STACK_HOST    */
                 /* group.  Adjust all offsets and ATD_STOR_BLK_IDX's.        */

            new_sb_idx  = SCP_SB_HOSTED_STACK_IDX(curr_scp_idx);

            offset.fld  = SB_LEN_FLD(new_sb_idx);
            offset.idx  = SB_LEN_IDX(new_sb_idx);

            align_bit_length(&offset, TARGET_BITS_PER_WORD);

            group       = SCP_FIRST_EQUIV_GRP(curr_scp_idx);

            while (ATD_STOR_BLK_IDX(EQ_ATTR_IDX(group)) != sb_idx) {
               group = EQ_NEXT_EQUIV_GRP(group);
            }
            item = group;

# if defined(_TARGET_DOUBLE_ALIGN)

            if (EQ_DALIGN_ME(item)) {
               C_TO_F_INT(result.constant,
                          TARGET_BITS_PER_WORD * 2,
                          CG_INTEGER_DEFAULT_TYPE);
               result.fld               = NO_Tbl_Idx;
               result.type_idx          = CG_INTEGER_DEFAULT_TYPE;
               left.fld                 = CN_Tbl_Idx;
               left.idx                 = CN_INTEGER_ZERO_IDX;

               size_offset_binary_calc(&offset, &result, Mod_Opr, &result);

               size_offset_logical_calc(&result, &left, Ne_Opr, &result);

               if (THIS_IS_TRUE(result.constant, result.type_idx)) {

                  /* This is not on a double word boundary */

                  result.idx    = CN_INTEGER_BITS_PER_WORD_IDX;
                  result.fld    = CN_Tbl_Idx;

                  /* Rather than padding, remove the 32-bit pad */
                  /* added to the front of this equivalence group. */

                  size_offset_binary_calc(&offset,
                                          &result,
                                          EQ_DALIGN_SHIFT(item) ? Minus_Opr :
                                                                  Plus_Opr,
                                          &offset);
               }
            }
# endif

            while (item != NULL_IDX) {

               if (ATD_STOR_BLK_IDX(EQ_ATTR_IDX(item)) == sb_idx) {
                  ATD_STOR_BLK_IDX(EQ_ATTR_IDX(item))   = new_sb_idx;

                  result.fld = ATD_OFFSET_FLD(EQ_ATTR_IDX(item));
                  result.idx = ATD_OFFSET_IDX(EQ_ATTR_IDX(item));

                  size_offset_binary_calc(&result, &offset, Plus_Opr, &result);

                  if (result.fld == NO_Tbl_Idx) {
                     ATD_OFFSET_FLD(EQ_ATTR_IDX(item)) = CN_Tbl_Idx;
                     ATD_OFFSET_IDX(EQ_ATTR_IDX(item)) =