fecif.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/fecif.c     5.9     10/14/99 12:53:57\n";

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


#define __NLS_INTERNALS 1  /* Obtain internal <nl_types.h> definitions.      */
                           /* (Required to get at prototype for              */
                           /* __cat_path_name.)                       */
#include <nl_types.h>      /* Contains typedef for nl_catd and prototype for */
                           /* __cat_path_name.                               */

#if defined(_HOST_OS_LINUX)
# include <nlcatmsg.h>
#endif



#include <time.h>


#define CIF_VERSION     3

#include "cif.h"

#include "cifprocs.h"


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

#include "globals.m"
#include "tokens.m"
#include "sytb.m"
#include "p_globals.m"
#include "s_globals.m"
#include "debug.m"
#include "cif.m"
#include "fecif.m"

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

#if (defined(_HOST_OS_SOLARIS) || defined(_HOST_OS_IRIX))
# include <sys/systeminfo.h>
#else
# include <unistd.h> /* for gethostname() */
#endif

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

static int      cif_data_type(int);
static void     cif_flush_include_recs (void);
static int      get_line_and_file_id (int, int *);
static void     output_minimal_object_rec (int);
static void     process_attr_list (int, boolean);
static boolean  output_struct_ids(opnd_type *);

static char     output_buf[2][64];

# define outbuf1 output_buf[0]
# define outbuf2 output_buf[1]


/*****************************************************************************\
|*                                                                           *|
|* Description:                                                              *|
|*      Open the Compiler Information File and output the header record.     *|
|*                                                                           *|
|* Input parameters:                                                         *|
|*      NONE                                                                 *|
|*                                                                           *|
|* Output parameters:                                                        *|
|*      NONE                                                                 *|
|*                                                                           *|
|* Returns:                                                                  *|
|*      NOTHING                                                              *|
|*                                                                           *|
\*****************************************************************************/

void init_cif(char *comp_date_time, char *release_level)
{
                char             cif_date[9];
                char             cif_time[9];
                char             cpu_name[MAXHOSTNAMELEN + 1];
                char             month[4];
                int              save_cif_file_id;
                char            *msg_cat_name;

# if defined(_GETPMC_AVAILABLE)
   extern        int      GETPMC(long *, char *);   /* UNICOS library routine*/

   union  {long   int_form;
           char   char_form[9];
           } host_cpu_type;

   union  host_machine_entry    {struct  {long          mcpmt;
                                          Ulong         unused[127];
                                          } fld;
                                long     host_tbl[128];
                                };

   typedef union host_machine_entry     host_machine_type;

   host_machine_type    host_machine_info;

# elif (defined(_HOST_OS_SOLARIS) || defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
   char         host_cpu_type[9];              /* Max of 8 chars (plus NULL).*/
# endif


   TRACE (Func_Entry, "init_cif", NULL);

   cif_end_unit_column         = 0;
   cif_file_id                 = 2;            /* Reserve 1 for msg cat name.*/
   cif_first_pgm_unit          = TRUE;
   cif_need_unit_rec           = TRUE;
   cif_pgm_unit_error_recovery = FALSE;
   cif_pgm_unit_start_line     = 1;


   /* If the CIF name was provided by the command line processor, open it.   */
   /* If the user specified -C, set_prog_file_names has already created the  */
   /* .T name in cif_name.                                                   */
   /* Otherwise, get a temporary file.                                       */

   if ((cif_C_opts & CMD_PROVIDED_CIF)  ||  cif_flags != 0) {

      if ((cif_actual_file = fopen(cif_name, "w")) == NULL) {
         PRINTMSG(0, 556, Log_Error, 0);
         perror("Reason");

# ifdef _DEBUG

         fprintf(stderr, "  Trying to open file %s\n", cif_name);
         system("df /tmp");

# endif

         exit_compiler(RC_USER_ERROR);
      }
   }
   else {

      if (! get_temp_file("w+", &cif_actual_file, cif_name)) {
         PRINTMSG(1, 556, Log_Error, 0);
         perror("  Reason");

# ifdef _DEBUG

         fprintf(stderr, "  Trying to open file %s\n", cif_name);
         system("df /tmp");

# endif

         exit_compiler(RC_USER_ERROR);
      }
   }

   c_i_f = cif_actual_file;

   /* Create a temporary file to save records that are output while the      */
   /* first stmt of a program unit is being parsed.  (All records for a      */
   /* program unit must be between the Unit and End Unit records for the     */
   /* program unit.)                                                         */

   if (! get_temp_file("w+", &cif_tmp_file, cif_tmp_file_name)) {
      PRINTMSG(0, 556, Log_Error, 0);
      perror("Reason");

# ifdef _DEBUG

      fprintf(stderr, "  Trying to open file %s\n", cif_name);
      system("df /tmp");

# endif

      if (c_i_f == cif_actual_file) {
         /* prevent closing the same file twice. Linux does not handle it */
         cif_actual_file = NULL;
      }

      fclose(c_i_f);

      if (! (cif_C_opts & CMD_PROVIDED_CIF)) {
         remove(cif_name);
      }

      exit_compiler(RC_USER_ERROR);
   }


   /* -----------------------------------------------------------------------*/
   /* Output the CIF header record.                                          */
   /*                                                                        */
   /* First, brute-force the date from the format in comp_date_time to the   */
   /* format CIF expects:  Ddd Mmm dd, yyyy  ->  mm/dd/yy                    */
   /* -----------------------------------------------------------------------*/

   memcpy(month, comp_date_time+4, 3);

   switch (month[0]) {

      case 'A': 
         strcpy(cif_date, (month[1] == 'p') ? "04/" : "08/");
         break;

      case 'D':
         strcpy(cif_date, "12/");
         break;

      case 'F':
         strcpy(cif_date, "02/");
         break;

      case 'J': 
         if (month[1] == 'a') {
            strcpy(cif_date, "01/");
         }
         else {
            strcpy(cif_date, (month[2] == 'n') ? "06/" : "07/");
         }
         break;

      case 'M':
         strcpy(cif_date, (month[2] == 'r') ? "03/" : "05/");
         break;
   
      case 'N':
         strcpy(cif_date, "11/");
         break;

      case 'O': 
         strcpy(cif_date, "10/");
         break;

      case 'S':
         strcpy(cif_date, "09/");
   }

   cif_date[3] = (comp_date_time[8] == ' ') ? '0' : comp_date_time[8];
   cif_date[4] = comp_date_time[9];
   cif_date[5] = '/';
   cif_date[6] = comp_date_time[14];
   cif_date[7] = comp_date_time[15];
   cif_date[8] = EOS;

   memcpy(cif_time, comp_date_time+18, 8);
   cif_time[8] = NULL_CHAR;

# if defined(_HOST_OS_LINUX)
   msg_cat_name = "shouldnotgethere";
# else

   /*
    * Solaris workaround
    * there is no __cat_path_name() declaration in Solaris nl_types.h
    * for now we just explicitly set up the message catalog file path.
    * it also works for IRIX.
    *
    */
   msg_cat_name = CF90CATPATHNAME;

# endif


# if (defined(_HOST_OS_SOLARIS) || defined(_HOST_OS_IRIX))
   
   if (sysinfo(SI_HOSTNAME, cpu_name, ((long int) MAXHOSTNAMELEN)) < 0L) {
       Cif_Error();
   }
   
# else

   /* eraxxon: this used to be used on _HOST_OS_LINUX */
   /* strcpy(cpu_name, "LINUX"); */

   if (gethostname(cpu_name, (MAXHOSTNAMELEN + 1)) < 0) {
      Cif_Error();
   }

# endif


# if defined(_GETPMC_AVAILABLE)
   GETPMC (host_machine_info.host_tbl, "HOST");
   host_cpu_type.int_form = host_machine_info.fld.mcpmt;
   host_cpu_type.char_form[8] = NULL_CHAR;
# elif defined(_HOST_OS_SOLARIS)
   strcpy(host_cpu_type, "SPARC");
# elif defined(_HOST_OS_IRIX)
   strcpy(host_cpu_type, "SGI");
# elif defined(_HOST_OS_LINUX)
   strcpy(host_cpu_type, "INTEL");
# endif


   Cif_Cifhdr_Rec(c_i_f,
                  CIF_LG_F90,
                  release_level,
                  cif_date,
                  cif_time,
                  group_code,
                  1,                    /* Message catalog file id.           */
                  cpu_name,

# if defined(_GETPMC_AVAILABLE)
                  host_cpu_type.char_form);
# elif (defined(_HOST_OS_SOLARIS) || defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
                  host_cpu_type);
# endif

   Cif_Src_Pos_Rec(c_i_f,
                   CIF_SRC_KIND_MAIN,
                   2,
                   0,
                   0,
                   0,
                   2,
                   0,
                   0,
                   0);
                   

   save_cif_file_id = cif_file_id;
   cif_file_id      = 1;

   cif_file_name_rec(msg_cat_name, (char *) NULL);

   cif_file_id      = save_cif_file_id;

   if (cif_flags & COMPILER_RECS) {
      cif_enable_disable_rec();
      cif_misc_compiler_opts_rec();
      cif_optimization_opts_rec();
      cif_machine_characteristics_rec();
   }

   
   /* orig_cmd_line should only be NULL if the compiler is called directly    */
   /* (like in debug mode).  Even if it is NULL for another reason, there is  */
   /* no great harm; the Original Command Line record will just not be        */
   /* produced in the CIF.                                                    */

   if (orig_cmd_line != NULL) {
      Cif_Orig_Cmd(c_i_f, orig_cmd_line);
      MEM_FREE(orig_cmd_line);
   }


   /* Set the CIF to the temp file so that all records preceding the Unit     */
   /* record will go to the temp file.  cif_unit_rec will copy the temp       */
   /* file to the actual file so that these records will properly follow      */
   /* the Unit record.                                                        */

   c_i_f = cif_tmp_file;

   TRACE (Func_Exit, "init_cif", NULL);

   return;

} /*  init_cif  */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Perform initializations that need to be done for each program unit.   *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void cif_prog_unit_init(void)
{

   TRACE (Func_Entry, "cif_prog_unit_init", NULL);

   cif_derived_type_id    = 101;
   cif_symbol_or_scope_id = 3;                 /* Reserve 1 for main program  */
                                               /*   scope ID.                 */
                                               /* Reserve 2 for main pgm name.*/
   SCP_CIF_ID(curr_scp_idx) =
      (BLK_TYPE(blk_stk_idx) == Program_Blk) ? 1 : NEXT_SCOPE_ID;

   cif_end_unit_column         = 0;
   cif_need_unit_rec           = TRUE;
   cif_pgm_unit_error_recovery = FALSE;

   c_i_f = cif_tmp_file;

   TRACE (Func_Exit, "cif_prog_unit_init", NULL);

   return;

}  /* cif_prog_unit_init */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Send the symbol table to CIF:                                         *|
|*        - Go through the Storage Block table to find all storage blocks     *|
|*          that belong to the current scoping unit.  Produce a Common Block  *|
|*          record for each common block declared in the scoping unit.        *|
|*        - If "-ci" (or an option that includes "i") was specified, go       *|
|*          through the Local Name table to find ALL entities associated with *|
|*          the current scoping unit.  If "-Cf" was specified, go through the *|
|*          Local Name table to find all Pgm_Unit and Stmt_Func Attrs (to     *|
|*          produce Entry Point records) and to find all the interface blocks *|
|*          (to produce Interface Block records).                             *|
|*          Note:  Common Block records are also produced when only "-Cf" is  *|
|*                 specified.                                                 *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void    cif_send_sytb()
{
   int          al_idx;
   int          attr_idx;
   long_type    blk_len;
   int          module_symbol_id;
   int          name_idx;
   long_type    result[MAX_WORDS_FOR_INTEGER];
   int          sb_idx;
   int          stor_class;
   int          type_idx;


   TRACE (Func_Entry, "cif_send_sytb", NULL);

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

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

      if (SB_CIF_SYMBOL_ID(sb_idx) == 0) {
         SB_CIF_SYMBOL_ID(sb_idx) = NEXT_SYMBOL_ID;
      }

      if (SB_BLK_TYPE(sb_idx) == Common) {
         stor_class = CIF_CB_REG;
      }
      else if (SB_BLK_TYPE(sb_idx) == Task_Common) {
         stor_class = CIF_CB_TASK;
      }
      else {
         continue;
      }

      if (SB_USE_ASSOCIATED(sb_idx)) {

         if (AT_CIF_SYMBOL_ID(SB_MODULE_IDX(sb_idx)) == 0) {
            AT_CIF_SYMBOL_ID(SB_MODULE_IDX(sb_idx)) = NEXT_SYMBOL_ID;
         }

         module_symbol_id = AT_CIF_SYMBOL_ID(SB_MODULE_IDX(sb_idx));
      }
      else {
    
         /* If the common block is defined in a module, get the symbol id of  */
         /* the module name.  Each common block, whether it is host           */
         /* associated or not, will carry it's original SCP_ID.  Use this to  */
         /* determine if it came from a module.                               */
         /* Need to check for NULL_IDX because common blocks from interface   */
         /* bodies will have NULL_IDX for SB_ORIG_SCP_IDX.                    */

         module_symbol_id = 0;

         if (SB_ORIG_SCP_IDX(sb_idx) != NULL_IDX) {
            attr_idx = SCP_ATTR_IDX(SB_ORIG_SCP_IDX(sb_idx));

            if (ATP_PGM_UNIT(attr_idx) == Module) {
               module_symbol_id = AT_CIF_SYMBOL_ID(attr_idx);
            }
         }
      }

      /* The SB_LEN_IDX may not always be a constant.  */
      /* 0 is issued, if the length is variable.       */

      blk_len = 0;

      if (SB_LEN_FLD(sb_idx) == CN_Tbl_Idx) {
         type_idx = CN_TYPE_IDX(SB_LEN_IDX(sb_idx));

         if (folder_driver((char *) &CN_CONST(SB_LEN_IDX(sb_idx)),
                                     CN_TYPE_IDX(SB_LEN_IDX(sb_idx)),
                           (char *) &CN_CONST(CN_INTEGER_THREE_IDX),
                                     CN_TYPE_IDX(CN_INTEGER_THREE_IDX),
                                     result,
                                    &type_idx,
                                     SB_DEF_LINE(sb_idx),
                                     SB_DEF_COLUMN(sb_idx),
                                     2,
                                     Shiftr_Opr)) {
            blk_len = (long) F_INT_TO_C(result, TYP_LINEAR(type_idx));
         }
      }

      /* On the receiving end, blk_len is an int, so we can loose precision. */
      /* KAY */

      Cif_F90_Comblk_Rec(c_i_f,
                         SB_NAME_PTR(sb_idx),
                         SB_CIF_SYMBOL_ID(sb_idx),
                         SCP_CIF_ID(curr_scp_idx),
                         stor_class,
                         module_symbol_id,
                         blk_len,
                         0);
   }

   if (cif_flags & INFO_RECS) {

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

         /* Attrs that have AT_DCL_ERR set to TRUE will be dealt with in      */
         /* cif_send_attr.                                                    */
         /* A variable used as a loop control variable (LCV) in a DATA or     */
         /* array constructor implied-DO is local to thta implied-DO nest.    */
         /* If no variable with the same name exists outside the implied-DOs, */
         /* implied-DO processing creates an Attr entry for the variable in   */
         /* order to "borrow" the data type for the implied-DO LCV.  Implied- */
         /* DO processing then creates a temp with the same name as the       */
         /* variable (to make the implied-DO LCV local to the implied-DO) and */
         /* uses the temp as the LCV.  This special case temp must be sent    */
         /* through cif_send_attr to have an Object record produced for it.   */
         /* If no variable of the same name ever appears anywhere else in     */
         /* the program unit outside the implied-DOs, the "master" Attr       */
         /* becomes redundant and must not be sent through cif_send_attr.     */
         /* (If this extra Attr is sent through cif_send_attr, it will appear */
         /* in a xref listing as an implicitly declared variable with no      */
         /* references - an impossibility).  So, to weed out such extra Attrs,*/
         /* we look for:                                                      */
         /*   * a variable   [ AT_OBJ_CLASS == Data_Obj  and                  */
         /*                    ATD_CLASS == Variable                          */
         /*   * that only appeared as an implied-DO LCV                       */
         /*                  [ ATD_SEEN_OUTSIDE_IMP_DO == FALSE ]             */
         /*   * and, in particular, appeared only as a DATA or array          */
         /*     constructor implied-DO LCV [ ATD_SEEN_AS_IO_LCV == FALSE ]    */

         if (AT_OBJ_CLASS(attr_idx) == Data_Obj   &&
             ATD_CLASS(attr_idx) == Variable      &&
             ! ATD_SEEN_OUTSIDE_IMP_DO(attr_idx)  &&
             ! ATD_SEEN_AS_IO_LCV(attr_idx)) {       
            continue;
         }

         cif_send_attr(attr_idx, NULL_IDX);
      }

      process_attr_list(SCP_ATTR_LIST(curr_scp_idx), FALSE);
      process_attr_list(SCP_CIF_ERR_LIST(curr_scp_idx), TRUE);
   }
   else {

      /* "-Cf" was specified.                                                 */

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

         /* Only want to generate entry records. */

         if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit   &&  
             AT_OBJ_CLASS(attr_idx) != Stmt_Func  &&
             AT_OBJ_CLASS(attr_idx) != Interface) {
            continue;
         }

         cif_send_attr(attr_idx, NULL_IDX);
      }

      /* Go through the Attr list to pick up Attrs for nongeneric (unnamed)   */
      /* interface blocks (and interface bodies inherited from a host scope   */
      /* when interface blocks with the same name are merged?).               */
      /* See also the comments preceding the analogous loop above.            */

      al_idx = SCP_ATTR_LIST(curr_scp_idx);

      while (al_idx != NULL_IDX) {

         if ((AT_OBJ_CLASS(attr_idx) == Pgm_Unit  &&
              AT_CIF_SYMBOL_ID(AL_ATTR_IDX(al_idx)) == 0)  ||
             AT_OBJ_CLASS(attr_idx) == Interface) {
            cif_send_attr(AL_ATTR_IDX(al_idx), NULL_IDX);
         }

         al_idx = AL_NEXT_IDX(al_idx);
      }
   }

   TRACE (Func_Exit, "cif_send_sytb", NULL);

   return;

}  /* cif_send_sytb */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Produce records representing the entities associated with the current *|
|*      scoping unit.                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void    cif_send_attr(int       attr_idx,
                      int       dt_attr_idx)

{
   long                 attributes;
   int                  bd_idx;
   char                 buffer[160];
   char                 char_len[20];
   int                  darg_idx;
   linear_type_type     data_type;
   int                  derived_type;
   int                  dt_idx;
   int                  i;
   int                  interface_idx;
   int                  interface_type;
   int                  namelist_idx;
   int                  num_dargs;
   int                  num_namelist;
   char                *obj_name_ptr;
   long64               offset;
   char                 offset_buf[20];
   int                  pgm_unit_type;
   int                  pointer_id;
   int                  rslt_id;
   int                  rslt_idx;
   boolean              save_cif_done;
# if 0
   int                  save_symbol_id;
# endif
   int                  scope_id;
   int                  sn_idx;
   int                  storage_class;
   int                  storage_id;
   char                 string[20];
   int                  symbol_class;
   int                  type_idx;


   TRACE (Func_Entry, "cif_send_attr", NULL);

   /* Skip this Attribute entry if:                                           */
   /*   - It has already been processed.                                      */
   /*   - It's for a compiler generated variable.                             */
   /*   - It is host associated and is not a program unit Attr.  Even if a    */
   /*     program unit Attr is host associated, it must be processed because  */
   /*     CIF needs a record for both the reference to the program unit and   */
   /*     the definition of the program unit.  Example:                       */
   /*                                                                         */
   /*        module mod                                                       */
   /*                                                                         */
   /*        contains                                                         */
   /*                                                                         */
   /*           subroutine sub1(i)                                            */
   /*              integer i                                                  */
   /*              ...                                                        */
   /*           end subroutine                                                */
   /*                                                                         */
   /*           subroutine sub2(j)                                            */
   /*              integer j                                                  */
   /*              call sub1(2)                                               */
   /*           end subroutine                                                */
   /*                                                                         */
   /*        end module                                                       */
   /*                                                                         */
   /*     An Attr for SUB1 will exist at the module level so SUB2 can call it.*/
   /*     An Attr for SUB1 will also exist in SUB2 and be attr-linked to the  */
   /*     the Attr for SUB1 at the module level.  The module does not actually*/
   /*     reference SUB1 so no Entry record will be generated for SUB1 there. */
   /*     But there will be a definition Entry record generated within SUB1   */
   /*     and there must be a reference Entry record generated within SUB2 for*/
   /*     SUB1.  Thus, even though the Attr for SUB1 in SUB2 is attr-linked to*/
   /*     the Attr for SUB1 at the module level, the Attr in SUB2 must be     */
   /*     sent through cif_send_attr so that the reference Entry record will  */
   /*     show up in the proper scoping unit.                                 */

   if (AT_CIF_DONE(attr_idx)) {
      goto EXIT;
   }

   if (!AT_CIF_IN_USAGE_REC(attr_idx) &&
       ((AT_COMPILER_GEND(attr_idx)  &&
        (AT_OBJ_CLASS(attr_idx) != Data_Obj ||
         ATD_CLASS(attr_idx) != Compiler_Tmp  || 
         ! ATD_TMP_NEEDS_CIF(attr_idx))) ||
       (AT_ATTR_LINK(attr_idx) != NULL_IDX  &&
        AT_OBJ_CLASS(attr_idx) != Pgm_Unit))) {
      goto EXIT;
   }


   AT_CIF_DONE(attr_idx) = TRUE;


   switch (AT_OBJ_CLASS(attr_idx)) {

   /* ----------------------------------------------------------------------- */
   /*                              Data_Obj                                   */
   /* ----------------------------------------------------------------------- */

   case Data_Obj:

      /* If the Attr entry is marked in error, produce an Object record       */
      /* anyway (with "symbol class" and most other fields set to 0 to        */
      /* indicate the record is incomplete) because we can't stop all Usage   */
      /* records from being produced (and Usage records must have a "defining"*/
      /* record).  All Usage records can not be stopped primarily because     */
      /* they are produced in the Syntax Pass while the Object record is      */
      /* produced in the Semantics Pass, and because they are generally       */
      /* produced as the objects are seen.  Example:                          */
      /*                         REAL i                                       */
      /*                         INTEGER i                                    */
      /* A Usage record is produced for I when the REAL stmt is parsed.  When */
      /* the INTEGER stmt is parsed, I has already been typed so an error is  */
      /* issued and AT_DCL_ERR for I is set to TRUE.  Since the Usage record  */
      /* already exists, an Object record must also exist.  libcif will       */
      /* ignore all records that relate to an Object record that is marked    */
      /* in error.                                                            */

      if (AT_DCL_ERR(attr_idx)) {
         output_minimal_object_rec(attr_idx);
         goto EXIT;
      }

      if (AT_CIF_SYMBOL_ID(attr_idx) == 0) {
         AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID;
      }

      char_len[0]       = NULL_CHAR;
      type_idx          = ATD_TYPE_IDX(attr_idx);

      if (TYP_TYPE(type_idx) == Structure) {

         if (! AT_DCL_ERR(TYP_IDX(type_idx))) {
            dt_idx = (AT_ATTR_LINK(TYP_IDX(type_idx)) == NULL_IDX) ?
                     TYP_IDX(type_idx) : AT_ATTR_LINK(TYP_IDX(type_idx));
         }
         else {
            output_minimal_object_rec(attr_idx);
            goto EXIT;
         }


         /* If the CIF derived type id is 0, it means that the derived type   */
         /* was use associated (or made available by other means?) and not    */
         /* included in the LN table, and thus we have to send it through now */
         /* to get all of its members processed.  Normally, the declaration   */
         /* rules of Fortran 90 would require the derived type to have been   */
         /* defined prior to its being used in a declaration (which would     */
         /* normally mean that it would already have been seen and processed).*/

         if (ATT_CIF_DT_ID(dt_idx) == 0) {
            cif_send_attr(dt_idx, NULL_IDX);
         }


         data_type = (linear_type_type) ATT_CIF_DT_ID(dt_idx);
      }
      else {
         data_type = TYP_LINEAR(type_idx);

         if (TYP_TYPE(type_idx) == Character) {
 
            if (TYP_FLD(type_idx) == CN_Tbl_Idx) {
               convert_to_string(&CN_CONST(TYP_IDX(type_idx)),
                                  CN_TYPE_IDX(TYP_IDX(type_idx)),
                                  char_len);
            }
            else {
               char_len[0] = (TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char) ?
                                                          ASSUMED_SIZE_CHAR :
                                                          VAR_LEN_CHAR;
               char_len[1] = NULL_CHAR;
            }
         }
      }


      obj_name_ptr = AT_OBJ_NAME_PTR(attr_idx);

      switch (ATD_CLASS(attr_idx)) {

      case Struct_Component:
         storage_class  = CIF_F90_ST_NO_STORAGE;
         storage_id     = 0;
         offset         = (ATD_OFFSET_FLD(attr_idx) == CN_Tbl_Idx) ? 
                           CN_INT_TO_C(ATD_CPNT_OFFSET_IDX(attr_idx)) : -1;
         symbol_class   = CIF_F90_SC_STRUCT;
         attributes     = 0;
         derived_type   = ATT_CIF_DT_ID(dt_attr_idx);
         break;

      case Constant:
         storage_class  = CIF_F90_ST_NO_STORAGE;

         if (AT_USE_ASSOCIATED(attr_idx)) {

            if (AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)) == 0) {

               /* If the module's symbol ID is 0, it probably means the       */
               /* module is being used indirectly.  If so, the module Attr    */
               /* won't exist in the current scope (or any parent scope) so   */
               /* send it through to get an Entry Point record generated to   */
               /* resolve the storage id field of the Object record currently */
               /* being constructed.                                          */
 
               cif_send_attr(AT_MODULE_IDX(attr_idx), NULL_IDX);
            }

            storage_id = AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx));
         }
         else if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) {
            storage_id = AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)); 
         }
         else {
            storage_id = 0;
         }

         offset         = -1;
         symbol_class   = CIF_F90_SC_NAMED_CONST;
         attributes     = 0;
         derived_type   = 0;

         /* If the named constant is use associated, spit out a dummy Named   */
         /* Constant record (line and column numbers will be zero and value   */
         /* is meaningful only if it is a simple constant).                   */

         if (AT_USE_ASSOCIATED(attr_idx)) {
            cif_named_constant_rec(attr_idx, 0, 0);
         }

         break;

      case Function_Result:

         /* If get_other_func_rslt_info is TRUE, it means we're processing    */
         /* a function reference from one internal function to another or     */
         /* from one module function to another.  If the function result of   */
         /* the CALLED function is of derived type, we need to produce all    */
         /* the records necessary to represent the derived type (and any      */
         /* nested derived types) in the scoping unit of the CALLING function */
         /* because the referencing Entry Point record points to the Object   */
         /* record for the called function result which in turn contains the  */
         /* CIF derived type id.  We must satisfy the derived type id which   */
         /* means we need to provide all the records to do so.  To do this,   */
         /* we need to send all the Attrs representing the derived type in    */
         /* the CALLED function's scoping unit through cif_send_attr again.   */

         if (get_other_func_rslt_info) {

            if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure) {
               AT_CIF_DONE(dt_idx)      = FALSE;
               AT_CIF_SYMBOL_ID(dt_idx) = 0;
               ATT_CIF_DT_ID(dt_idx)    = 0;
               cif_send_attr(dt_idx, NULL_IDX);
               data_type = (linear_type_type) ATT_CIF_DT_ID(dt_idx);
            }
         }

           
         if (ATD_STOR_BLK_IDX(attr_idx) == NULL_IDX) {  /* Stmt func result */
            storage_class = CIF_F90_ST_NO_STORAGE;
            storage_id    = 0;
         }
         else {

            /* May be the hidden first dummy arg, rather than the result.     */

            storage_class =
               (SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Formal) ?
               CIF_F90_ST_DUMMY : CIF_F90_ST_STACK;

            /* A function result can be use associated if the function        */
            /* belongs to an interface block that was use associated.         */

            storage_id = (AT_USE_ASSOCIATED(attr_idx)) ?
                            AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)) : 0;
         }

         offset         = -1;
         symbol_class   = CIF_F90_SC_FUNC_RESULT;
         attributes     = 0;
         derived_type   = 0;

         if (ATP_PROC(ATD_FUNC_IDX(attr_idx)) == Intrin_Proc  &&
             AT_OBJ_NAME(attr_idx) == '_') {
            ++obj_name_ptr;
         }

         break;

      case Dummy_Argument:
         derived_type   = 0;
         symbol_class   = CIF_F90_SC_VARIABLE;
         attributes     = (AT_CIF_USE_IN_BND(attr_idx)) ? CIF_DARG_IN_BND : 0;
         storage_id     = 0;

         if (ATD_SF_DARG(attr_idx)) {
            offset        = -1;
            storage_class = CIF_F90_ST_NO_STORAGE;
         }
         else {

            /* If the dummy arg name is in the main entry point's dummy arg   */
            /* list, make its offset its position within the list.  (If the   */
            /* same dummy arg is named in an alternate entry, the offset is   */
            /* meaningless.)  If the dummy arg appeared in an alternate entry */
            /* dummy arg list but not in the main dummy arg list, set its     */
            /* offset to 0.                                                   */

            storage_class = CIF_F90_ST_DUMMY;
            offset        = 0;
            sn_idx        = ATP_FIRST_IDX(SCP_ATTR_IDX(curr_scp_idx));

            for (i = 1;  i <= ATP_NUM_DARGS(SCP_ATTR_IDX(curr_scp_idx));  ++i) {
               
               if (attr_idx == SN_ATTR_IDX(sn_idx)) {
                  offset = (ATP_EXTRA_DARG(SCP_ATTR_IDX(curr_scp_idx))) ?
                           (i - 1) : i;
                  break;
               }
               else {
                  ++sn_idx;
               }
            }
         }

         break;

      default:
         derived_type   = 0;
         symbol_class   = CIF_F90_SC_VARIABLE;
         attributes     = 0;
         offset         = (ATD_OFFSET_ASSIGNED(attr_idx) && 
                           ATD_OFFSET_FLD(attr_idx) == CN_Tbl_Idx) ?
                             CN_INT_TO_C(ATD_OFFSET_IDX(attr_idx)) : -1;

         storage_id = SB_CIF_SYMBOL_ID(ATD_STOR_BLK_IDX(attr_idx));

         switch (SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx))) {

         case Static:
         case Static_Local:
         case Static_Named:

            if (ATD_ALLOCATABLE(attr_idx)  ||  ATD_POINTER(attr_idx)) {
               storage_class = CIF_F90_ST_BASED;
            }
            else {
               storage_class = CIF_F90_ST_STATIC;
            }

            if (SB_MODULE(ATD_STOR_BLK_IDX(attr_idx))) {
               symbol_class = CIF_F90_SC_MODULE;

               storage_id = (AT_USE_ASSOCIATED(attr_idx)) ?
                               AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)) :
                               AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)); 
            }

            break;

         case Stack:
         case Equivalenced:
            if (ATD_ALLOCATABLE(attr_idx)  ||  ATD_POINTER(attr_idx)) {
               storage_class = CIF_F90_ST_BASED;
            }
            else {
               storage_class = (ATD_AUXILIARY(attr_idx) == 0) ?
                                  CIF_F90_ST_STACK : CIF_F90_ST_AUXILIARY;
            }

            break;

         case Common:
         case Task_Common:
            symbol_class = (ATD_EQUIV(attr_idx) && !ATD_IN_COMMON(attr_idx)) ?
                                                    CIF_F90_SC_EQUIV :
                                                    CIF_F90_SC_COMMON;
            storage_class = (ATD_AUXILIARY(attr_idx) == 0) ?
                               CIF_F90_ST_COMMON : CIF_F90_ST_AUXILIARY;
            break;

         case Formal:
            storage_class = CIF_F90_ST_DUMMY;
            break;

         case Based:
            storage_class = (ATD_CLASS(attr_idx) == CRI__Pointee) ?
                               CIF_F90_ST_POINTEE : CIF_F90_ST_BASED;
            break;

         default:
            storage_class = CIF_F90_ST_ERROR;
            break;
         }
         break;
      }

      /* Set attributes */

      switch (TYP_DESC(type_idx)) {
         case Default_Typed:
            attributes = attributes | CIF_DEFAULT_TYPED;
            break;

         case Star_Typed:
            attributes = attributes | CIF_STAR_TYPED;
            break;

         case Kind_Typed:
            attributes = attributes | CIF_KIND_TYPED;
            break;
      }

      if (!AT_TYPED(attr_idx)) {
         attributes = attributes | CIF_IMPLICITLY_TYPED;
      }

      if (ATD_SAVED(attr_idx)) {
         attributes = attributes | CIF_SAVED;
      }
                                             
      if (ATD_DATA_INIT(attr_idx)) {
         attributes = attributes | CIF_DATA_INIT;
         attributes = attributes | CIF_SAVED;   /* Implied by initialization. */
      }

      if (ATD_DCL_EQUIV(attr_idx)) {
         attributes = attributes | CIF_EQUIVALENCED;
      }

      if (ATD_ALLOCATABLE(attr_idx)) {
         attributes = attributes | CIF_ALLOCATABLE;
      }

      if (ATD_CLASS(attr_idx) == Dummy_Argument) {
       
         switch (ATD_INTENT(attr_idx)) {
           case Intent_Unseen:
              break;

           case Intent_In:
              attributes = attributes | CIF_INTENT_IN;
              break;

           case Intent_Out:
              attributes = attributes | CIF_INTENT_OUT;
              break;

           case Intent_Inout:
              attributes = attributes | CIF_INTENT_INOUT;
              break;
         }

         if (AT_OPTIONAL(attr_idx)) {
            attributes = attributes | CIF_OPTIONAL;
         }
      }

      pointer_id = 0;

      if (ATD_POINTER(attr_idx)) {
         attributes = attributes | CIF_POINTER;
      }
      else if (ATD_CLASS(attr_idx) == CRI__Pointee) { 
         attributes = attributes | CIF_CRI_POINTEE;

         if (AT_CIF_SYMBOL_ID(ATD_PTR_IDX(attr_idx)) == 0) {
            AT_CIF_SYMBOL_ID(ATD_PTR_IDX(attr_idx)) = NEXT_SYMBOL_ID;
         }

         pointer_id = AT_CIF_SYMBOL_ID(ATD_PTR_IDX(attr_idx));
      }

      if (AT_PRIVATE(attr_idx)) {
         attributes = attributes | CIF_PRIVATE;
      }

      if (ATD_TARGET(attr_idx)) {
         attributes = attributes | CIF_TARGET;
      }

      if (AT_USE_ASSOCIATED(attr_idx) && 
          AT_ORIG_NAME_IDX(attr_idx) != AT_NAME_IDX(attr_idx)) {
         attributes = attributes | CIF_RENAMED;
      }

      scope_id = SCP_CIF_ID(curr_scp_idx);

      if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) {
         CONVERT_CVAL_TO_STR(&offset, Integer_8, offset_buf);

         if (fprintf(c_i_f, 
         "%d%c%s%c%d%c%d%c%d%c%d%c%d%c%d%c%s%c%lx%c%d%c%s%c%d%c%d%c%d%c%d%c%d%c",
                     CIF_F90_OBJECT, EOI, 
                     obj_name_ptr, EOI,
                     AT_CIF_SYMBOL_ID(attr_idx), EOI,
                     scope_id, EOI,
                     cif_data_type(data_type), EOI,
                     symbol_class, EOI,
                     storage_class, EOI,
                     storage_id, EOI,
                     offset_buf, EOI,
                     attributes, EOI,
                     derived_type, EOI,
                     char_len, EOI,
                     0, EOI,                                  /* num dims     */
                     0, EOI,                                  /* array type   */
                     0, EOI,                                  /* distribution */
                     0, EOI,                                  /* geometry id  */
                     pointer_id, EOR) < 0) {
            Cif_Error();
         }
      }
      else {
         bd_idx    = ATD_ARRAY_IDX(attr_idx);
         buffer[0] = NULL_CHAR;

/*         if (BD_ARRAY_CLASS(bd_idx) == Assumed_Shape) {

            for (i = 1; i <= BD_RANK(bd_idx); i++) {

               if (BD_LB_FLD(bd_idx,i) == CN_Tbl_Idx) {
                  sprintf(string, "%c%s",
                          EOI,
                          convert_to_string(&CN_CONST(BD_LB_IDX(bd_idx,i)),
                                             CN_TYPE_IDX(BD_LB_IDX(bd_idx,i)),
                                             outbuf1));
               }
               else {
                  string[0] = EOI;
                  string[1] = VAR_LEN_CHAR;
                  string[2] = NULL_CHAR;
               }
               strcat(buffer, string);
            }
         }
*/
/*         else if (BD_ARRAY_CLASS(bd_idx) != Deferred_Shape)  */
         {

            for (i = 1; i <= BD_RANK(bd_idx); i++) {

               if (BD_LB_FLD(bd_idx,i) == CN_Tbl_Idx) {
                  sprintf(string, "%c%s", 
                          EOI,
                          convert_to_string(&CN_CONST(BD_LB_IDX(bd_idx,i)),
                                             CN_TYPE_IDX(BD_LB_IDX(bd_idx,i)),
                                             outbuf1));
               }
               else if (BD_LB_FLD(bd_idx,i) != NO_Tbl_Idx) {
                  string[0] = EOI;
                  string[1] = VAR_LEN_CHAR;
                  string[2] = NULL_CHAR;
               }

               strcat(buffer, string);

               if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size && 
                   BD_RANK(bd_idx) == i) {
                  string[0] = EOI;
                  string[1] = ASSUMED_SIZE_CHAR;
                  string[2] = NULL_CHAR;
               }
               else if (BD_UB_FLD(bd_idx,i) == CN_Tbl_Idx) {
                  sprintf(string, "%c%s", 
                          EOI, 
                          convert_to_string(&CN_CONST(BD_UB_IDX(bd_idx,i)),
                                             CN_TYPE_IDX(BD_UB_IDX(bd_idx,i)),
                                             outbuf1));
               }
               else {
                  string[0] = EOI;
                  string[1] = (BD_UB_FLD(bd_idx,i) != NO_Tbl_Idx) ?
                                                      VAR_LEN_CHAR :
                                                      ASSUMED_SIZE_CHAR;
                  string[2] = NULL_CHAR;
               }
               strcat(buffer, string);
            }
         }

         CONVERT_CVAL_TO_STR(&offset, Integer_8, offset_buf);

         if (fprintf(c_i_f,
       "%d%c%s%c%d%c%d%c%d%c%d%c%d%c%d%c%s%c%lx%c%d%c%s%c%d%c%d%s%c%d%c%d%c%d%c",
                   CIF_F90_OBJECT, EOI, 
                   AT_OBJ_NAME_PTR(attr_idx), EOI,
                   AT_CIF_SYMBOL_ID(attr_idx), EOI,
                   SCP_CIF_ID(curr_scp_idx), EOI,
                   cif_data_type(data_type), EOI,
                   symbol_class, EOI,
                   storage_class, EOI,
                   storage_id, EOI,
                   offset_buf, EOI,
                   attributes, EOI,
                   derived_type, EOI,
                   char_len, EOI,
                   BD_RANK(bd_idx), EOI, 
                   BD_ARRAY_CLASS(bd_idx),
                   buffer, EOI,
                   0, EOI,                                    /* distribution */
                   0, EOI,                                    /* geometry id  */
                   pointer_id, EOR) < 0) {
            Cif_Error();
         }
      }

      break;


   /* ----------------------------------------------------------------------- */
   /*                              Pgm_Unit                                   */
   /* ----------------------------------------------------------------------- */

   case Pgm_Unit:

      if (ATP_PROC(attr_idx) != Intrin_Proc &&
          ((name_pool[AT_NAME_IDX(attr_idx)].name_char == '$'  &&
           attr_idx != glb_tbl_idx[Main_Attr_Idx])  ||
           name_pool[AT_NAME_IDX(attr_idx)].name_char == '_')) {  /* Lib call */
         break;
      }

      /* If the Attr entry is marked in error, produce an Entry Point record  */
      /* anyway so that its symbol id will be defined.  See the comments at   */
      /* the head of the Data_Obj case for details.                           */

      if (AT_DCL_ERR(attr_idx)) {

         if (AT_CIF_SYMBOL_ID(attr_idx) == 0) {
            AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID;
         }

         Cif_F90_Entry_Rec(c_i_f, 
                           AT_OBJ_NAME_PTR(attr_idx),
                           AT_CIF_SYMBOL_ID(attr_idx),
                           SCP_CIF_ID(curr_scp_idx), 
                           0, 
                           0,
                           0,
                           0,
                           0,
                           0,
                           NULL);
         goto EXIT;
      }

      if (ATP_IN_INTERFACE_BLK(attr_idx)) {

         if (ATP_SCP_ALIVE(attr_idx)) {
            attributes = CIF_PGM_IN_INTERFACE;
         }
         else if (AT_REFERENCED(attr_idx) != Not_Referenced) {
            attributes = CIF_PGM_REFERENCE;
         }
         else {
    
            /* This stops interface body records from being produced in the   */
            /* host procedure if the interface body is not referenced.        */
    
            AT_CIF_DONE(attr_idx) = FALSE;
            goto EXIT;
         }
      }
      else if (ATP_SCP_ALIVE(attr_idx)) {
         attributes = CIF_PGM_DEFINITION;
      }
      else if (AT_REFERENCED(attr_idx) != Not_Referenced  &&
               ! AT_REF_IN_CHILD(attr_idx)) {

         /* The program unit is being referenced in some fashion but its      */
         /* scope is not alive.  If Attr for the entry point exists because   */
         /* it was referenced in a child scope (for example, one internal     */
         /* procedure references another so an Attr for the referenced        */
         /* internal procedure also exists at the parent level), then DON'T   */
         /* send it through again or it will mess up the Usage records that   */
         /* have already been generated (their symbol ids won't match the     */
         /* symbol id in the Attr we're currently processing).                */
         /* In contrast, if one sibling is referencing another and we're in   */
         /* of the sibling scopes, reset AT_CIF_DONE back to FALSE so the     */
         /* definitional Entry Point record will be produced when the Attr is */
         /* sent through cif_send_attr a little later.                        */

         AT_CIF_DONE(attr_idx) = FALSE;


         /* If the program unit name is a dummy argument AND it's referenced  */
         /* somewhere in the current procedure, we don't want to produce      */
         /* multiple Entry Point records for it but for the above reasons we  */
         /* can't use AT_CIF_DONE so use ATP_CIF_DARG_PROC.  If this flag is  */
         /* TRUE, we're processing the dummy arg so clear it and continue.    */
         /* If it's FALSE, we're here the second time for the reference so    */
         /* quit.                                                             */

         if (AT_IS_DARG(attr_idx)) {

            if (ATP_CIF_DARG_PROC(attr_idx)) {
               ATP_CIF_DARG_PROC(attr_idx) = FALSE;
            }
            else {
              goto EXIT;
            }
         }


         /* If this is a module procedure and it was referenced by another    */
         /* module procedure but we are now processing the Attrs in the       */
         /* specification part of the module, do not produce an Entry Point   */
         /* record for the module procedure now.  Produce it when the module  */
         /* procedure is being processed.                                     */
         /* The second case covers a module that's been used indirectly.      */

         if (ATP_PROC(attr_idx) == Module_Proc  &&
             ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) {
            goto EXIT;
         }
         else if (ATP_PGM_UNIT(attr_idx) == Module  &&
                  AT_USE_ASSOCIATED(attr_idx)) {
            attributes = CIF_PGM_USE_ASSOCIATED;
         }
         else {
            attributes = CIF_PGM_REFERENCE;
         }
      }
      else if (AT_IS_DARG(attr_idx)) {

         /* If the program unit name is a dummy argument and its name is not  */
         /* "referenced" in the Fortran 90 sense, an Entry Point record still */
         /* must be generated to satisfy the symbol ID in the Usage record    */
         /* generated for the appearance of the name.                         */

         attributes = CIF_PGM_REFERENCE;
      }
      else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && 
               (ATP_VFUNCTION(attr_idx) ||
                ATP_NOSIDE_EFFECTS(attr_idx) ||
                ATP_NAME_IN_STONE(attr_idx) ||
                ATP_DCL_EXTERNAL(attr_idx))) {

         /* Same idea as above for a dummy arg procedure.  If the name only   */
         /* appears in an EXTERNAL stmt, we must still generate an Entry      */
         /* Point record to satisfy the Usage record.                         */
         /* Also VFUNCTION, NOSIDE EFFECTS and NAME dirs.                     */
  
         attributes = CIF_PGM_REFERENCE;
      }
      else if (AT_USE_ASSOCIATED(attr_idx)) {

         /* This case catches a module procedure that was brought in by use   */
         /* association but never referenced.  Without this case, if it was   */
         /* brought in and never invoked but WAS named in a PUBLIC stmt, for  */
         /* instance, a Usage record for the PUBLIC stmt appearance would be  */
         /* generated but no Entry Point record would be generated to satisfy */
         /* the symbol id in the Usage record.                                */
         /* CIF_PGM_USE_ASSOCIATED is added to "attributes" later.            */

      }
      else {

         /* This stops internal and module procedure records from being       */
         /* produced in the host procedure if the internal or module          */
         /* procedure was not referenced.                                     */

         AT_CIF_DONE(attr_idx) = FALSE;
         goto EXIT;
      }


      /* If AT_ATTR_LINK is not NULL_IDX, it means we're processing:          */
      /*   - a reference from one module procedure to another module          */
      /*     procedure in the same module,                                    */
      /*   - a reference from one module procedure to another module          */
      /*     procedure but the other module procedure name was use associated */
      /*     into the module specification part,                              */
      /*   - a reference from one internal procedure to another internal      */
      /*     procedure within the same program unit,                          */
      /*   - a reference from an internal procedure to another procedure      */
      /*     where the other procedure name is host associated into the       */
      /*     internal procedure, or                                           */
      /*   - a procedure that belongs to an interface block.                  */
      /* If the reference is to another procedure whose name is known in an   */
      /* outer scope, get some of the info from the outer Attr.               */
 
      if (AT_ATTR_LINK(attr_idx) == NULL_IDX) {
         get_other_func_rslt_info = FALSE;
      }
      else if (AT_OBJ_CLASS(AT_ATTR_LINK(attr_idx)) != Interface) {
         get_other_func_rslt_info = TRUE;
         attr_idx                 = AT_ATTR_LINK(attr_idx);
      }
      else {
        goto EXIT;
      }

      if (AT_CIF_SYMBOL_ID(attr_idx) == 0) {
         AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID;
      }

      switch (ATP_PGM_UNIT(attr_idx)) {

         case Pgm_Unknown:
            pgm_unit_type = CIF_F90_ET_UNKNOWN;
            num_dargs     = ATP_NUM_DARGS(attr_idx);
            break;

         case Function:
            pgm_unit_type =
               (ATP_ALT_ENTRY(attr_idx)) ? CIF_F90_ET_ALT_ENTRY :
                                           CIF_F90_ET_FUNCTION;

            /* This may be a reference only.  Then there is no darg list */
            /* but ATP_EXTRA_DARG will be set.                           */

            if (ATP_EXPL_ITRFC(attr_idx) && ATP_EXTRA_DARG(attr_idx)) {
               num_dargs = ATP_NUM_DARGS(attr_idx) - 1;
            }
            else {
               num_dargs = ATP_NUM_DARGS(attr_idx);
            }
            
            if (AT_USE_ASSOCIATED(attr_idx)) {
               attributes = attributes | CIF_PGM_USE_ASSOCIATED;
            }

            break;

         case Subroutine:
            pgm_unit_type =
               (ATP_ALT_ENTRY(attr_idx)) ? CIF_F90_ET_ALT_ENTRY :
                                           CIF_F90_ET_SUBROUTINE;

            num_dargs = ATP_NUM_DARGS(attr_idx);

            if (AT_USE_ASSOCIATED(attr_idx)) {
               attributes = attributes | CIF_PGM_USE_ASSOCIATED;
            }

            break;

         case Program:
            num_dargs = 0;
            pgm_unit_type= CIF_F90_ET_PROGRAM;
            break;

         case Blockdata:
            num_dargs = 0;
            pgm_unit_type = CIF_F90_ET_BLOCKDATA;
            break;

         case Module:
            num_dargs = 0;
            pgm_unit_type= CIF_F90_ET_MODULE;
      }

      if ((attributes & CIF_PGM_REFERENCE)  ||
          AT_USE_ASSOCIATED(attr_idx)       ||
          get_other_func_rslt_info) {
         num_dargs = 0;
      }


      if (AT_OPTIONAL(attr_idx)) {
         attributes = attributes | CIF_PGM_OPTIONAL;
      }


      /* The Attr entry associated with the SCP for a module is marked        */
      /* private if the module contains a bare PRIVATE statement.  But the    */
      /* name of the module does not have an accessibility attribute          */
      /* associated with it - only the names within the module.  So don't set */
      /* the CIF PRIVATE attribute in this case.                              */

      if (AT_PRIVATE(attr_idx)  &&  ATP_PGM_UNIT(attr_idx) != Module) {
         attributes = attributes | CIF_PGM_PRIVATE;
      }

      if (ATP_RECURSIVE(attr_idx)) {
         attributes = attributes | CIF_PGM_RECURSIVE;
      }

      if (ATP_PGM_UNIT(attr_idx) == Function) {
         rslt_idx = ATP_RSLT_IDX(attr_idx);

         if (ATP_SCP_ALIVE(attr_idx)) {

            if (! AT_CIF_DONE(rslt_idx)) {
               cif_send_attr(rslt_idx, NULL_IDX);
            }

            rslt_id = AT_CIF_SYMBOL_ID(rslt_idx);
         }
         else {

            /* We might be getting information from an outer Attr for         */
            /* multiple references to a function whose name is known in an    */
            /* outer scope.  We need to produce an Object record for the      */
            /* result to satisfy the symbol id in the Entry Point record.     */
            /* If the function has been called before, the result would have  */
            /* already been processed which means we need to clear            */
            /* AT_CIF_DONE so an Object record can be produced in the current */
            /* scope.  Since the function's scope is not alive, it may well   */
            /* be processed AFTER this (that is, the Pgm_Unit attr we're      */
            /* processing now could be due to a forward reference).  This     */
            /* means we need to save the symbol id and restore it so that if  */
            /* we later process the result when its scope is alive, the       */
            /* symbol id will match the symbol ids in the Usage records that  */
            /* were generated for the result.                                 */

            AT_CIF_DONE(rslt_idx)      = FALSE;

# if 0
            save_symbol_id             = AT_CIF_SYMBOL_ID(rslt_idx);
            AT_CIF_SYMBOL_ID(rslt_idx) = 0;
# endif
            cif_send_attr(rslt_idx, NULL_IDX);
            rslt_id                    = AT_CIF_SYMBOL_ID(rslt_idx);
# if 0
            AT_CIF_SYMBOL_ID(rslt_idx) = save_symbol_id;
# endif
            AT_CIF_DONE(rslt_idx)      = FALSE;
         }
      }
      else {
         rslt_id = 0;
      }

      if (ATP_PROC(attr_idx) == Module_Proc) {

         if (AT_MODULE_IDX(attr_idx) == 0) {
            storage_id = (SCP_LEVEL(curr_scp_idx) == 0) ?
                            AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)) :
                            AT_CIF_SYMBOL_ID(
                               SCP_ATTR_IDX(SCP_PARENT_IDX(curr_scp_idx)));
         }
         else {

            if (AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)) == 0) {

               /* If the module's symbol id is 0, it probably means the       */
               /* module is being used indirectly.  If so, the module Attr    */
               /* won't exist in the current scope (or any parent scope) so   */
               /* send it through to get an Entry record generated to resolve */
               /* the storage id field of the Object record currently being   */
               /* constructed.                                                */

               cif_send_attr(AT_MODULE_IDX(attr_idx), NULL_IDX);
            }

            storage_id = AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx));
         }
      }
      else if (AT_USE_ASSOCIATED(attr_idx)) {

         if (AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)) == 0) {

            /* See reasoning above for sending the module's Attr through      */
            /* cif_send_attr.                                                 */

            cif_send_attr(AT_MODULE_IDX(attr_idx), NULL_IDX);
         }

         storage_id = AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx));
      }
      else {
         storage_id = 0;
      }

      if (num_dargs != 0) { 
         sn_idx = ATP_FIRST_IDX(attr_idx);

         if (ATP_EXTRA_DARG(attr_idx)) {
            ++sn_idx;
         }

         for (i = 0; i < num_dargs; i++) {
            darg_idx = SN_ATTR_IDX(sn_idx++);

            if (! AT_COMPILER_GEND(darg_idx)) { 

               /* Not an alternate return dummy arg.                          */

               /* If the program unit name is a dummy arg AND it's referenced */
               /* somewhere in the current procedure, we don't want to        */
               /* produce multiple Entry Point records for it but for reasons */
               /* documented earlier in the Pgm_Unit case we can't use        */
               /* AT_CIF_DONE.  So set ATP_CIF_DARG_PROC to indicate we should*/
               /* process the Attr as a dummy arg.  The flag is cleared       */
               /* farther up in this case code.                               */

               if (AT_OBJ_CLASS(darg_idx) == Pgm_Unit) {
                  ATP_CIF_DARG_PROC(darg_idx) = TRUE;
               }
 
               cif_send_attr(darg_idx, NULL_IDX);
            }
         }
      }

      if (fprintf(c_i_f, 
                  "%d%c%s%c%d%c%d%c%d%c%d%c%lx%c%d%c%d%c%d",
                  CIF_F90_ENTRY, EOI, 
                  AT_OBJ_NAME_PTR(attr_idx), EOI,
                  AT_CIF_SYMBOL_ID(attr_idx), EOI,
                  SCP_CIF_ID(curr_scp_idx), EOI,
                  pgm_unit_type, EOI,
                  ATP_PROC(attr_idx), EOI,
                  attributes, EOI,
                  rslt_id, EOI,
                  storage_id, EOI,
                  num_dargs) < 0) {
         Cif_Error();
      }

      if (num_dargs != 0) {
         sn_idx = ATP_FIRST_IDX(attr_idx);

         if (ATP_EXTRA_DARG(attr_idx)) {
            ++sn_idx;
         }

         for (i = 0; i < num_dargs; i++) {
            darg_idx = SN_ATTR_IDX(sn_idx++);

            if (AT_COMPILER_GEND(darg_idx)) {   /* An alternate return darg.  */
               darg_idx = 0;
            }
            else {
               darg_idx = AT_CIF_SYMBOL_ID(darg_idx);
            }

            if (fprintf(c_i_f, "%c%d", EOI, darg_idx) < 0) {
               Cif_Error();
            }
         }
      }

      if (fprintf(c_i_f, "\n") < 0) {
         Cif_Error();
      }

      get_other_func_rslt_info = FALSE;

      break;


   /* ----------------------------------------------------------------------- */
   /*                              Label                                      */
   /* ----------------------------------------------------------------------- */

   case Label:
      cif_label_rec(attr_idx);
      break;


   /* ----------------------------------------------------------------------- */
   /*                            Derived_Type                                 */
   /* ----------------------------------------------------------------------- */

   case Derived_Type:

# if 0
      /* If the Attr entry is marked in error, produce a Derived Type Def     */
      /* record anyway so that its symbol id will be defined.  See the        */
      /* comments at the head of the Data_Obj case for details.               */

      if (AT_DCL_ERR(attr_idx)) {

         if (AT_CIF_SYMBOL_ID(attr_idx) == 0) {
            AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID;
         }

         Cif_F90_Derived_Type_Rec(c_i_f,
                                  AT_OBJ_NAME_PTR(attr_idx),
                                  AT_CIF_SYMBOL_ID(attr_idx),
                                  SCP_CIF_ID(curr_scp_idx), 
                                  ATT_CIF_DT_ID(attr_idx), 
                                  0,
                                  0,
                                  NULL,
                                  0);
         goto EXIT;
      }
# endif

      if (AT_CIF_SYMBOL_ID(attr_idx) == 0) {
         AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID;
      }

      if (ATT_CIF_DT_ID(attr_idx) == 0) {
         ATT_CIF_DT_ID(attr_idx) = NEXT_DERIVED_TYPE_ID;
      }

      attributes = (ATT_SEQUENCE_SET(attr_idx)) ? (CIF_DRT_SEQUENCE) : 0;

      if (AT_PRIVATE(attr_idx)) {
         attributes = attributes | CIF_DRT_PRIVATE;
      }

      if (ATT_PRIVATE_CPNT(attr_idx)) {
         attributes = attributes | CIF_DRT_COMP_PRIVATE;
      }

      sn_idx = ATT_FIRST_CPNT_IDX(attr_idx);

      while (sn_idx != NULL_IDX) {

         if (get_other_func_rslt_info) {
            AT_CIF_DONE(SN_ATTR_IDX(sn_idx))      = FALSE;
            AT_CIF_SYMBOL_ID(SN_ATTR_IDX(sn_idx)) = 0;
         }

         cif_send_attr(SN_ATTR_IDX(sn_idx), attr_idx);
         sn_idx = SN_SIBLING_LINK(sn_idx);
      }

      if (fprintf(c_i_f, "%d%c%s%c%d%c%d%c%d%c%lx%c%d",
                         CIF_F90_DERIVED_TYPE, EOI, 
                         AT_OBJ_NAME_PTR(attr_idx), EOI,
                         AT_CIF_SYMBOL_ID(attr_idx), EOI,
                         SCP_CIF_ID(curr_scp_idx), EOI,
                         ATT_CIF_DT_ID(attr_idx), EOI,
                         attributes, EOI,
                         ATT_NUM_CPNTS(attr_idx)) < 0) {
         Cif_Error();
      }

      sn_idx = ATT_FIRST_CPNT_IDX(attr_idx);

      while (sn_idx != NULL_IDX) {

         if (fprintf(c_i_f, "%c%d",
                            EOI, AT_CIF_SYMBOL_ID(SN_ATTR_IDX(sn_idx))) < 0) {
            Cif_Error();
         }

         sn_idx = SN_SIBLING_LINK(sn_idx);
      }

      if (fprintf(c_i_f, "\n") < 0) {
         Cif_Error();
      }

      break;


   /* ----------------------------------------------------------------------- */
   /*                            Interface                                    */
   /* ----------------------------------------------------------------------- */

   case Interface:

      /* If the interface identifier is marked in error but its symbol id has */
      /* been referenced somewhere (like in a Usage record), output a dummy   */
      /* Interface Block record to define the symbol id).                     */
   
      if (AT_DCL_ERR(attr_idx)  &&  AT_CIF_SYMBOL_ID(attr_idx) != 0) {
         scope_id = (AT_USE_ASSOCIATED(attr_idx)) ?
                       SCP_CIF_ID(curr_scp_idx) :
                       ATI_CIF_SCOPE_ID(attr_idx);

         switch (ATI_INTERFACE_CLASS(attr_idx)) {

            case Defined_Assign_Interface:
               interface_type = CIF_IB_ASSIGNMENT;
               break;

            case Generic_Unknown_Interface:
            case Generic_Function_Interface:
            case Generic_Subroutine_Interface:
               interface_type = CIF_IB_GENERIC;
               break;

            default:
               interface_type = CIF_IB_OPERATOR;
               break;
         }

         Cif_F90_Int_Block_Rec(c_i_f,
                               AT_OBJ_NAME_PTR(attr_idx),
                               AT_CIF_SYMBOL_ID(attr_idx),
                               scope_id, 
                               interface_type,
                               0, 
                               0, 
                               NULL,
                               0);

         goto EXIT;
      }


      if (AT_CIF_SYMBOL_ID(attr_idx) == 0) {
         AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID;
      }


      /* If the interface block was brought in from a module and the module's */
      /* Attr entry has not yet been produced, normally the module's Attr     */
      /* entry would be sent through cif_send_attr to get an Entry Point      */
      /* record produced.  But if the interface is for an intrinsic procedure,*/
      /* don't do this because it will cause redundant Entry Point records to */
      /* be generated.  See the "if" stmt immediately following the one this  */
      /* comment is documenting.                                              */

      if (AT_USE_ASSOCIATED(attr_idx)          && 
          AT_MODULE_IDX(attr_idx) != NULL_IDX  &&
          ! AT_CIF_DONE(AT_MODULE_IDX(attr_idx))) {

         if (AT_IS_INTRIN(attr_idx)          &&
             ! ATI_USER_SPECIFIED(attr_idx)  &&
             ATI_CIF_SEEN_IN_CALL(attr_idx)) {

            /* Do nothing.  Easier to visualize the code this way.            */

         }
         else {
            cif_send_attr(AT_MODULE_IDX(attr_idx), NULL_IDX);
         }
      }


      if (AT_IS_INTRIN(attr_idx)  &&  ! ATI_USER_SPECIFIED(attr_idx)) {

         /* If this intrinsic procedure has been referenced and a Call Site   */
         /* record was output to record the call, then the Entry record (and  */
         /* Object record if it is a function) have already been output.      */

         if (ATI_CIF_SEEN_IN_CALL(attr_idx)) {
            goto EXIT;
         }


         rslt_id = 0;

         if (ATI_INTERFACE_CLASS(attr_idx) == Generic_Function_Interface) {
            pgm_unit_type = CIF_F90_ET_FUNCTION;


            /* Count on the fact that the last specific Attr in the intrinsic */
            /* interface block is the "default" type Attr.  That is, if the   */
            /* specific form of the intrinsic is passed as an actual argument,*/
            /* this is the one that records what the specific's argument type */
            /* must be (and thus the result type of the specific).  Generics  */
            /* can't be passed as arguments but some, like SQRT, have the     */
            /* same generic and specific name and cflint needs to have a      */
            /* result type to compare the characteristics of actual procedure */
            /* arguments to how the dummy procedure argument is invoked.      */

            sn_idx = ATI_FIRST_SPECIFIC_IDX(attr_idx);

            for (i = 2;  i <= ATI_NUM_SPECIFICS(attr_idx);  ++i) {
               sn_idx = SN_SIBLING_LINK(sn_idx);
            }

            rslt_idx = ATP_RSLT_IDX(SN_ATTR_IDX(sn_idx));
              

            /* Always send the function result Attr through even though its   */
            /* symbol id might already be nonzero and AT_CIF_DONE might       */
            /* already be TRUE because the Entry Point record generated for   */
            /* each intrinsic function in each CIF scope must have an         */
            /* associated Object record to pass on to CIF the function        */
            /* result type.  For example, if a module contains several module */
            /* procedures, each of which reference BIT_SIZE, each module      */
            /* procedure has its own Attr for BIT_SIZE but they all refer to  */
            /* the same function result Attr so we can't go by CIF_SYMBOL_ID  */
            /* being 0 in that function result Attr.                          */
            
            save_cif_done         = AT_CIF_DONE(rslt_idx);
            AT_CIF_DONE(rslt_idx) = FALSE;
            cif_send_attr(rslt_idx, NULL_IDX);
            AT_CIF_DONE(rslt_idx) = save_cif_done;

            rslt_id = AT_CIF_SYMBOL_ID(rslt_idx);
         }
         else if (ATI_INTERFACE_CLASS(attr_idx) ==Generic_Subroutine_Interface){
            pgm_unit_type = CIF_F90_ET_SUBROUTINE;
         }
         else {
            pgm_unit_type = CIF_F90_ET_UNKNOWN;
         }
   
         attributes = CIF_PGM_REFERENCE;
   
         if (AT_PRIVATE(attr_idx)) {
            attributes = attributes | CIF_PGM_PRIVATE;
         }
   
         Cif_F90_Entry_Rec(c_i_f,
                           AT_OBJ_NAME_PTR(attr_idx),
                           AT_CIF_SYMBOL_ID(attr_idx),
                           SCP_CIF_ID(curr_scp_idx), 
                           pgm_unit_type, 
                           CIF_F90_PT_INTRINSIC,
                           attributes, 
                           rslt_id, 
                           0, 
                           0, 
                           NULL);

         break;
      }

      if (ATI_UNNAMED_INTERFACE(attr_idx)) {

         if (fprintf(c_i_f, 
                     "%d%c%c%d%c%d%c%d%c%x%c%d",
                     CIF_F90_INT_BLOCK, EOI, 
                     EOI,                              /* Do not put out name */
                     AT_CIF_SYMBOL_ID(attr_idx), EOI,
                     ATI_CIF_SCOPE_ID(attr_idx), EOI,
                     CIF_IB_SPECIFIC, EOI,
                     0, EOI,
                     ATI_NUM_SPECIFICS(attr_idx)) < 0) {
            Cif_Error();
         }
      }
      else {

         if (ATI_PROC_IDX(attr_idx) != NULL_IDX) {
            cif_send_attr(ATI_PROC_IDX(attr_idx), NULL_IDX);
         }

         attributes = (AT_PRIVATE(attr_idx)) ? 1 : 0;

         switch (ATI_INTERFACE_CLASS(attr_idx)) {
           case Defined_Assign_Interface:
              interface_type = CIF_IB_ASSIGNMENT;
              break;

           case Generic_Unknown_Interface:
           case Generic_Function_Interface:
           case Generic_Subroutine_Interface:
              interface_type = CIF_IB_GENERIC;
              break;

           default:
              interface_type = CIF_IB_OPERATOR;
              break;
         }

         /* If the interface block is pulled in from a module, there are no   */
         /* Begin Scope or End Scope records associated with it (they only    */
         /* occur where the interface block was defined).  So give it the     */
         /* scope id of the current scope (the USEing scope) so that libcif   */
         /* some kind of valid scope id to sort by.                           */
         /* LRR:  Could this same thing happen if the interface block is      */
         /*       pulled in from a host scoping unit?                         */
         /* LRR:  We may need to add a flag to the Interface Block record in  */
         /*       the future to flag the fact that scope id is the containing */
         /*       scope rather than the scope that the interface blk defines. */

         scope_id = (AT_USE_ASSOCIATED(attr_idx)) ?
                       SCP_CIF_ID(curr_scp_idx) :
                       ATI_CIF_SCOPE_ID(attr_idx);

         if (fprintf(c_i_f, 
                     "%d%c%s%c%d%c%d%c%d%c%lx%c%d",
                     CIF_F90_INT_BLOCK, EOI, 
                     AT_OBJ_NAME_PTR(attr_idx), EOI,
                     AT_CIF_SYMBOL_ID(attr_idx), EOI,
                     scope_id, EOI,
                     interface_type, EOI,
                     attributes, EOI,
                     ATI_NUM_SPECIFICS(attr_idx)) < 0) {
            Cif_Error();
         }
      }


      /* Go through the SN list to get the symbol IDs for the procedure names */
      /* in the interface block (finishes off the Interface Block record).    */

      sn_idx = ATI_FIRST_SPECIFIC_IDX(attr_idx);

      while (sn_idx != NULL_IDX) {
         interface_idx  = SN_ATTR_IDX(sn_idx);
         sn_idx         = SN_SIBLING_LINK(sn_idx);

         if (AT_CIF_SYMBOL_ID(interface_idx) == 0) {
            AT_CIF_SYMBOL_ID(interface_idx) = NEXT_SYMBOL_ID;
         }

         if (fprintf(c_i_f, "%c%d",
                            EOI,
                            AT_CIF_SYMBOL_ID(interface_idx)) < 0) {
            Cif_Error();
         }
      }

      if (fprintf(c_i_f, "%c", EOR) < 0) {
         Cif_Error();
      }


      /* Go through the SN list again to produce an Entry record for each     */
      /* module procedure and/or intrinsic procedure named in the (possibly   */
      /* user extended intrinsic) interface block.  All interface bodies      */
      /* were taken care of when the interface scope was still alive.         */
      /* Note, however, that if an interface body was brought in by use       */
      /* association (because it belongs to an interface block that was use   */
      /* associated), the interface body has NOT been taken care of so we     */
      /* to produce an Entry Point record for it here.                        */

      sn_idx = ATI_FIRST_SPECIFIC_IDX(attr_idx);

      while (sn_idx != NULL_IDX) {
         interface_idx  = SN_ATTR_IDX(sn_idx);
         sn_idx         = SN_SIBLING_LINK(sn_idx);

         if (ATP_PROC(interface_idx) == Module_Proc       ||
             ATP_PROC(interface_idx) == Intrin_Proc       ||
             (ATP_PROC(interface_idx) == Extern_Proc  &&
              AT_USE_ASSOCIATED(interface_idx))) {

            if (ATP_PGM_UNIT(interface_idx) == Function) {
               pgm_unit_type = CIF_F90_ET_FUNCTION;
               rslt_id       = ATP_RSLT_IDX(interface_idx);
               cif_send_attr(rslt_id, NULL_IDX);
               rslt_id       = AT_CIF_SYMBOL_ID(rslt_id);
            }
            else {
               pgm_unit_type = CIF_F90_ET_SUBROUTINE;
               rslt_id       = 0;
            }

            if (AT_MODULE_IDX(interface_idx) == NULL_IDX) {

               if (SCP_LEVEL(curr_scp_idx) == 0) {
                  storage_id = AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx));
               }
               else {
                  i = SCP_PARENT_IDX(curr_scp_idx);

                  while (SCP_LEVEL(i) != 0) {
                     i = SCP_PARENT_IDX(i);
                  }

                  storage_id = AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(i));
               }
            }
            else {

               if (AT_CIF_SYMBOL_ID(AT_MODULE_IDX(interface_idx)) == 0) {
                  cif_send_attr(AT_MODULE_IDX(interface_idx), NULL_IDX);
               }

               storage_id = AT_CIF_SYMBOL_ID(AT_MODULE_IDX(interface_idx));
            }


            attributes = CIF_PGM_REFERENCE;

            if (AT_OPTIONAL(interface_idx)) {
               attributes = attributes | CIF_PGM_OPTIONAL;
            }

            if (AT_PRIVATE(interface_idx)) {
               attributes = attributes | CIF_PGM_PRIVATE;
            }

            if (AT_USE_ASSOCIATED(interface_idx)) {
               attributes = attributes | CIF_PGM_USE_ASSOCIATED;
            }

            if (ATP_RECURSIVE(interface_idx)) {
               attributes = attributes | CIF_PGM_RECURSIVE;
            }


            Cif_F90_Entry_Rec(c_i_f,
                              AT_OBJ_NAME_PTR(interface_idx),
                              AT_CIF_SYMBOL_ID(interface_idx),
                              scope_id, 
                              pgm_unit_type,
                              ATP_PROC(interface_idx),
                              attributes, 
                              rslt_id,
                              storage_id,
                              0,
                              NULL);
         }
      }

      break;


   /* ----------------------------------------------------------------------- */
   /*                            Namelist_Grp                                 */
   /* ----------------------------------------------------------------------- */

   case Namelist_Grp:
     
      if (AT_CIF_SYMBOL_ID(attr_idx) == 0) {
         AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID;
      }

      if (AT_USE_ASSOCIATED(attr_idx)) {
        
         if (AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)) == 0) {
            cif_send_attr(AT_MODULE_IDX(attr_idx), NULL_IDX);
         }

         storage_id = AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx));
      }
      else if (AT_HOST_ASSOCIATED(attr_idx)) {

         /* If the namelist group name is host associated, don't produce      */
         /* another Namelist record.  (AT_ATTR_LINK was broken earlier in     */
         /* the Semantics Pass driver so there's an independent local Attr    */
         /* for the namelist group name.  That's how we got here.)            */

         goto EXIT;
      }
      else {

         if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) {
            storage_id = AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx));
         }
         else {
            storage_id = 0;
         }
      }

      num_namelist = AT_DCL_ERR(attr_idx) ? 0: ATN_NUM_NAMELIST(attr_idx);

      if (fprintf(c_i_f, 
                  "%d%c%s%c%d%c%d%c%d%c%d",
                  CIF_F90_NAMELIST, EOI, 
                  AT_OBJ_NAME_PTR(attr_idx), EOI,
                  AT_CIF_SYMBOL_ID(attr_idx), EOI,
                  SCP_CIF_ID(curr_scp_idx), EOI,
                  storage_id, EOI,
                  num_namelist) < 0) {
         Cif_Error();
      }

      if (num_namelist > 0) {
         sn_idx = ATN_FIRST_NAMELIST_IDX(attr_idx);

         while (sn_idx != NULL_IDX) {
            namelist_idx = SN_ATTR_IDX(sn_idx);
            sn_idx       = SN_SIBLING_LINK(sn_idx);

            if (AT_CIF_SYMBOL_ID(namelist_idx) == 0) {
               AT_CIF_SYMBOL_ID(namelist_idx) = NEXT_SYMBOL_ID;
            }

            if (fprintf(c_i_f,"%c%d",EOI,AT_CIF_SYMBOL_ID(namelist_idx)) < 0) {
               Cif_Error();
            }
         }
      }

      if (fprintf(c_i_f, "%c", EOR) < 0) {
         Cif_Error();
      }

      break;


   /* ----------------------------------------------------------------------- */
   /*                            Stmt_Func                                    */
   /* ----------------------------------------------------------------------- */

   case Stmt_Func:
     attributes = 0; /* eraxxon: add to avoid unitialized read below */

# if 0
      if (AT_DCL_ERR(attr_idx)) {
         goto EXIT;
      }
# endif
 
      if (AT_CIF_SYMBOL_ID(attr_idx) == 0) {
         AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID;
      }

      if (fprintf(c_i_f, 
                  "%d%c%s%c%d%c%d%c%d%c%d%c%lx%c%d%c%d%c%d",
                  CIF_F90_ENTRY, EOI, 
                  AT_OBJ_NAME_PTR(attr_idx), EOI,
                  AT_CIF_SYMBOL_ID(attr_idx), EOI,
                  SCP_CIF_ID(curr_scp_idx), EOI,
                  CIF_F90_ET_STMT, EOI,
                  Unknown_Proc, EOI,
                  attributes, EOI,
                  0, EOI,
                  0, EOI,
                  ATP_NUM_DARGS(attr_idx)) < 0) {
         Cif_Error();
      }

      if (ATP_NUM_DARGS(attr_idx) != NULL_IDX) {
         sn_idx = ATP_FIRST_IDX(attr_idx);

         for (i = 0; i < ATP_NUM_DARGS(attr_idx); i++) {

            if (AT_CIF_SYMBOL_ID(SN_ATTR_IDX(sn_idx)) == 0) {
               AT_CIF_SYMBOL_ID(SN_ATTR_IDX(sn_idx)) = NEXT_SYMBOL_ID;
            }

            darg_idx = AT_CIF_SYMBOL_ID(SN_ATTR_IDX(sn_idx++));

            if (fprintf(c_i_f, "%c%d", EOI, darg_idx) < 0) {
               Cif_Error();
            }
         }

         if (fprintf(c_i_f, "%c", EOR) < 0) {
            Cif_Error();
         }

         sn_idx = ATP_FIRST_IDX(attr_idx);

         for (i = 0; i < ATP_NUM_DARGS(attr_idx); i++) {
            cif_send_attr(SN_ATTR_IDX(sn_idx++), NULL_IDX);
         }
      }
      else if (fprintf(c_i_f, "%c", EOR) < 0) {
         Cif_Error();
      }

      break;

   }


EXIT:

   TRACE (Func_Exit, "cif_send_attr", NULL);

   return;

}  /* cif_send_attr */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output a CDIR$ record [5].                                            *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      dir:   The CDIR$ type.                                                *|
|*      line:  Global line number of the line containing the CDIR$.           *|
|*      col:   Column in which the CDIR$ begins.                              *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void cif_directive_rec(cif_directive_code_type  dir,
                       int                      line,
                       int                      col)

{
   int          file_line_num;
   int          local_file_id;

   TRACE (Func_Entry, "cif_directive_rec", NULL);

   file_line_num = get_line_and_file_id(line, &local_file_id);

   Cif_Cdir_Rec(c_i_f, dir, local_file_id, file_line_num, col, 0, NULL);

   TRACE (Func_Exit, "cif_directive_rec", NULL);

   return;

}  /* cif_directive_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output a File Name record [7].  The file name is assigned the next    *|
|*      file id value.                                                        *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      expanded_file_name:       The fully expanded path name for the file.  *|
|*      user_specified_file_name: The file name as the user wrote it on the   *|
|*                                command line or in an INCLUDE.              *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      The CIF file id.                                                      *|
|*                                                                            *|
\******************************************************************************/

int cif_file_name_rec(char       *file_name,
                      char       *user_specified_file_name)
{
   int           return_val;


   TRACE (Func_Entry, "cif_file_name_rec", NULL);

   return_val = NEXT_FILE_ID;

   Cif_File_Rec(c_i_f,
                file_name,
                return_val,
                user_specified_file_name); 

   TRACE (Func_Exit, "cif_file_name_rec", NULL);

   return(return_val);

}  /* cif_file_name_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output an Include record [9].                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      line_num:                                                             *|
|*      col_num:                                                              *|
|*      include_file_id:                                                      *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void cif_include_rec(int        line_num,
                     int        col_num,
                     int        include_file_id)
{
   int          file_line_num;
   int          parent_file_id;


   TRACE (Func_Entry, "cif_include_rec", NULL);

   file_line_num = get_line_and_file_id(line_num, &parent_file_id);

   Cif_Include_Rec(c_i_f,
                   parent_file_id,
                   file_line_num,
                   col_num, 
                   include_file_id);
   
   Cif_Src_Pos_Rec(c_i_f,
                   CIF_SRC_KIND_INCLUDE,
                   include_file_id,
                   parent_file_id,
                   file_line_num,
                   col_num,
                   include_file_id,
                   0,
                   0,
                   0);

   TRACE (Func_Exit, "cif_include_rec", NULL);

   return;

}  /* cif_include_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output a Message record [11].                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      msg_num         The message number.                                   *|
|*      glb_line_num    The global source line number.                        *|
|*      col_num         The column number of the offending text (may be 0).   *|
|*      msg_severity    The severity level of the message.                    *|
|*      msg_text        A pointer to the character string containing the      *|
|*                        message text (from the message catalog).            *|
|*      arg1, arg2,     The 4 optional arguments that may be used to insert   *|
|*      arg3, arg4        text into a message.                                *|
|*                                                                            *|
|*      scoping_unit_name  Only used for the buffered message file.           *|
|*      file_name          Only used for the buffered message file.           *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Algorithm notes:                                                           *|
|*   The size of "insert" was chosen because it seemed "big enough".  See the *|
|*   definitions of ORIG_MSG_SIZE and EXPANDED_MSG_SIZE in messages.m.        *|
|*                                                                            *|
\******************************************************************************/

void cif_message_rec(int                         msg_num,
                     int                         glb_line_num,
                     int                         col_num,
                     msg_severities_type         msg_severity,
                     char                       *msg_text,
                     long                        arg0,
                     long                        arg1,
                     long                        arg2,
                     long                        arg3,
                     char                       *scoping_unit_name,
                     int                         relative_order)

{
   char        *char_ptr;
   int          file_line_num;
   char        *format[4] = { "%c", "%d", "%f", "%s" };
   int          format_idx; 
   char         insert[4][128];
   char        *insert_ptr[4];
   int          local_file_id;
   int          num_inserts     = 0;


   TRACE (Func_Entry, "cif_message_rec", NULL);

   if (msg_severity == Log_Error  ||  msg_severity == Log_Warning  ||
       glb_line_num == 0) {
      goto EXIT;
   }

   file_line_num = get_line_and_file_id(glb_line_num, &local_file_id);
 
   char_ptr  = msg_text;

   while ((char_ptr = strchr(char_ptr, '%')) != NULL) {
      ++char_ptr;

      switch (*char_ptr++) {

         case 'c':
            format_idx = 0;
            break;

         case 'd':
            format_idx = 1;
            break;

         case 'f':
            format_idx = 2;
            break;

         case 's':
            format_idx = 3;
            break;

         case '%':
            continue;

         case EOS:
            goto LOOP_EXIT;

         default:
            PRINTMSG(glb_line_num, 179, Internal, 0, "cif_message_rec");
      }  

      switch (num_inserts) {

         case 0:
            sprintf(insert[0], format[format_idx], arg0);
            break;

         case 1:
            sprintf(insert[1], format[format_idx], arg1);
            break;

         case 2:
            sprintf(insert[2], format[format_idx], arg2);
            break;

         case 3:
            sprintf(insert[3], format[format_idx], arg3);
      }

      insert_ptr[num_inserts] = insert[num_inserts];

      ++num_inserts;
   }

LOOP_EXIT:

   Cif_Message_Rec(c_i_f,
                   msg_severity,
                   msg_num, 
                   local_file_id,
                   glb_line_num,
                   col_num, 
                   file_line_num,
                   num_inserts,
                   insert_ptr,
                   scoping_unit_name,
                   relative_order,
                   0,
                   local_file_id);
   
   last_msg_file_rec = CIF_MESSAGE;

EXIT:

   TRACE (Func_Exit, "cif_message_rec", NULL);

   return;

}  /* cif_message_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output a Source File record [14].                                     *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      source_file_id  The file id of the file containing the program.       *|
|*      source_form     The source form in which the program is written (at   *|
|*                        least initially).                                   *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void cif_source_file_rec(int            source_file_id,
                         src_form_type  source_form)
{

   TRACE (Func_Entry, "cif_source_file_rec", NULL);

   Cif_Srcfile_Rec(c_i_f,
                   source_file_id,
                   (source_form == Fixed_Form) ? CIF_F90_FORM_FIXED :
                                                 CIF_F90_FORM_FREE);

   TRACE (Func_Exit, "cif_source_file_rec", NULL);

   return;

}  /* cif_source_file_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output a Summary record [15].                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      release_level    : compiler release level                             *|
|*      gen_date         : date the compiler was created                      *|
|*      gen_time         : time of day the compiler was created               *|
|*      elapsed_time     : Cray    : compilation time in microseconds         *|
|*                         non-Cray: compilation time in microseconds for a   *|
|*                                   "short" compilation, otherwise in        *|
|*                                   seconds; see Algorithm notes below       *|
|*      aux_elapsed_time : Cray    : not used (always 0)                      *|
|*                         non-Cray: if compilation time is "short", this is  *|
|*                                   the compilation time in microseconds     *|
|*      max_field_len    : maximum amount of memory used                      *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Algorithm notes:                                                           *|
|*    LRR notes:  URGENT SPR 701346 demonstrated that the compile time info   *|
|*    we were printing in the summary lines was grossly wrong for some        *|
|*    compilations on the T3E.  TAM told me that SECOND had not been ported   *|
|*    to T3E's and advised me to use SECONDR.  However, when I tried it, it   *|
|*    also failed.  I then checked with KRZ to find out what the C front-end  *|
|*    uses.  They use clock() on all platforms.  In order to perturb the      *|
|*    front-end as little as possible with this change, I've only changed     *|
|*    the MPP timing to use clock().  If someone has the time sometime in     *|
|*    the future, someone should probably investigate using clock() where     *|
|*    we now use SECOND.                                                      *|
|*    The first sentence of the following paragraph has existed for a very    *|
|*    long time.  Knowing what we now know about clock(), the description and *|
|*    concluseion no longer seem to make sense.  If anyone ever gets around   *|
|*    to changing from SECOND to clock() for general use, the following       *|
|*    paragraph should be corrected as well.                  4 March 1997    *|
|*    The clock() function on both Crays and Suns counts in microseconds.     *|
|*    For this reason, SECOND is used on Crays.  It returns a floating point  *|
|*    value of the number of seconds (down to at least a microsecond) of CPU  *|
|*    time.                                                                   *|
|*    Since the Sun word is 32 bits, the counter rolls over in just over 2147 *|
|*    seconds (about 36 minutes).  main.c captures the compilation start and  *|
|*    end times from both clock() and time().  time()'s granularity is in     *|
|*    seconds.  For a Sun, (end_time - start_time) is passed to elapsed_time. *|
|*    If elapsed_time <= 2147 seconds, the compilation time is taken from     *|
|*    aux_elapsed_time (the value of the second call to clock() in main.c)    *|
|*    and is reported in milliseconds.  If the counter rolled over, the time  *|
|*    is reported in seconds.  Since the compilation time would have to be    *|
|*    at least 36 minutes, it was thought that 1 part in 36*3600 is           *|
|*    sufficiently accurate.                                                  *|
|*                                                                            *|
|*    CLOCKS_PER_SEC is defined in time.h.                                    *|
|*                                                                            *|
\******************************************************************************/

void cif_summary_rec(char       *release_level,
                     char       *gen_date,
                     char       *gen_time,
                     float       elapsed_time,
                     long        aux_elapsed_time,
                     long        max_field_len)
{
   char         comp_time[13];
   int          hms;
   int          hours;
   int          milliseconds;
   int          minutes;
   int          seconds;


   TRACE (Func_Entry, "cif_summary_rec", NULL);

   if (max_field_len == -1) {              /* Signalling abort on 100 errors. */
      comp_time[0] = '0';
      comp_time[1] = NULL_CHAR;
   }
   else {
      
      hms = elapsed_time;


# if (defined(_HOST_OS_UNICOS) || defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))

      elapsed_time = elapsed_time - hms;
      milliseconds = (elapsed_time + .0005) * 1000;
      
# elif defined(_HOST_OS_MAX)

      milliseconds = ((aux_elapsed_time % CLOCKS_PER_SEC) + 500L) / 1000L;
      hms          = aux_elapsed_time / CLOCKS_PER_SEC;

# else /* defined(_HOST_OS_SOLARIS) */   

      if (hms <= 2147) {
         milliseconds = ((aux_elapsed_time % CLOCKS_PER_SEC) + 500L) / 1000L;
         hms          = aux_elapsed_time / CLOCKS_PER_SEC;
      }
      else {
         milliseconds = -1;
      }

# endif


      hours   = hms / 3600;
      hms     = hms % 3600;
      minutes = hms / 60;
      seconds = hms % 60;


# ifndef _HOST_OS_SOLARIS

      sprintf(comp_time, "%2.2d:%2.2d:%2.2d.%3.3d",
                         hours, minutes, seconds, milliseconds);

# else

      if (milliseconds >= 0) {
         sprintf(comp_time, "%2.2d:%2.2d:%2.2d.%3.3d",
                            hours, minutes, seconds, milliseconds);
      }
      else {
         sprintf(comp_time, "%2.2d:%2.2d:%2.2d", hours, minutes, seconds);
      }

# endif

   }

   Cif_Summary_Rec(c_i_f,
                   release_level,
                   gen_date, 
                   gen_time,
                   comp_time, 
                   max_field_len,
                   --curr_glb_line,
                   code_size, 
                   data_size);

   /* Don't leave contents of curr_glb_line destroyed.                        */

   ++curr_glb_line;


   TRACE (Func_Exit, "cif_summary_rec", NULL);

   return;

}  /* cif_summary_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output a Unit record [17].                                            *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void cif_unit_rec(void)
{
   int          cif_col_num;
   int          file_line_num;
   int          glb_line_num;
   int          local_file_id;


   TRACE (Func_Entry, "cif_unit_rec", NULL);

   if (cif_pgm_unit_start_line == stmt_start_line) {

      /* For a program that is tremendously screwed up, it is possible for    */
      /* cif_unit_rec to be called from cif_fake_a_unit even before the Block */
      /* Stack has been set up.  If this is so, just fake the line and column.*/

      if (blk_stk_idx > 0) {
         glb_line_num = CURR_BLK_DEF_LINE;
         cif_col_num  = CURR_BLK_DEF_COLUMN;
      }
      else {
         glb_line_num = 1;
         cif_col_num  = 1;
      }
   }
   else {

      /* For the pathological case where the only significant line in the     */
      /* program contains an END statement, cif_pgm_unit_start_line is        */
      /* incremented before we get here.                                      */

      glb_line_num = (cif_pgm_unit_start_line < stmt_start_line) ?
                        cif_pgm_unit_start_line : stmt_start_line;
      cif_col_num  = 1;
   }

   file_line_num = get_line_and_file_id(glb_line_num, &local_file_id);
   

   /* Write the Unit record in the actual CIF.                                */

   c_i_f = cif_actual_file;


   Cif_Unit_Rec(c_i_f,
                (scp_tbl != NULL) ?
                   AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)) : 
                   UNNAMED_PROGRAM_NAME,
                local_file_id,
                file_line_num,
                cif_col_num);

   cif_need_unit_rec  = FALSE; 
   cif_first_pgm_unit = FALSE; 

   last_msg_file_rec = CIF_UNIT;

   if (! cif_pgm_unit_error_recovery) {
      cif_copy_temp_to_actual_CIF();
   }

   TRACE (Func_Exit, "cif_unit_rec", NULL);

   return;

}  /* cif_unit_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Copy records from the temporary CIF to the actual CIF.                *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void cif_copy_temp_to_actual_CIF(void)
{
   char         cif_rec[256];                          /* Arbitrary size.     */


   TRACE (Func_Entry, "cif_copy_temp_to_actual_CIF", NULL);

   /* Copy any records in the temporary file to the actual CIF.  Rewind the   */
   /* temporary CIF file so it's ready for the next program unit (if one      */
   /* exists).                                                                */

   fprintf(cif_tmp_file, "%d\n", EOF);
   fflush(cif_tmp_file);
   rewind(cif_tmp_file);

   while (fgets(cif_rec, 256, cif_tmp_file) != NULL  &&  atoi(cif_rec) != EOF) {
      fputs(cif_rec, c_i_f);
   }

   rewind(cif_tmp_file);

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

}  /* cif_copy_temp_to_actual_CIF */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output an End Unit record [18].                                       *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void cif_end_unit_rec(char      *name_ptr)
{
   int          file_line_num;
   int          local_file_id;


   TRACE (Func_Entry, "cif_end_unit_rec", NULL);

   file_line_num = get_line_and_file_id(cif_end_unit_line, &local_file_id);

   cif_flush_include_recs();

   Cif_Endunit_Rec(c_i_f, 
                   name_ptr,
                   local_file_id,
                   file_line_num,
                   (cif_end_unit_column > 0) ?
                      cif_end_unit_column : stmt_start_col);

   last_msg_file_rec = CIF_ENDUNIT;

   TRACE (Func_Exit, "cif_end_unit_rec", NULL);

   return;

}  /* cif_end_unit_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output a Usage record [19].                                           *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      obj_idx     : An Attr index, IR index or symbol id depending on the   *|
|*                    value of obj_fld                                        *|
|*      obj_fld     : AT_Tbl_Idx, IR_Tbl_Idx or NO_Tbl_Idx                    *|
|*      line_num    : the line number containing the symbol for which this    *|
|*                    Usage record is being produced                          *|
|*      col_num     : the column number for the symbol                        *|
|*      usage_code  : the CIF-defined usage code                              *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void cif_usage_rec(int                  obj_idx,
                   fld_type             obj_fld,
                   int                  line_num,
                   int                  col_num,
                   int                  usage_code)
{
   int          attr_idx;
   int          cif_symbol_id;
   int          file_line_num;
   int          local_file_id;
   opnd_type    opnd;


   TRACE (Func_Entry, "cif_usage_rec", NULL);
/*
   if (SH_CIF_SKIP_ME(curr_stmt_sh_idx) || usage_code == CIF_No_Usage_Rec) {
      goto EXIT;
   }
*/

   if (usage_code == CIF_No_Usage_Rec) {
      goto EXIT;
   }


   switch (obj_fld) {

   case AT_Tbl_Idx:
      attr_idx = obj_idx;
      AT_CIF_IN_USAGE_REC(attr_idx) = TRUE;

      if (AT_DCL_ERR(attr_idx)                                  || 
          (AT_COMPILER_GEND(attr_idx)                       &&
           (AT_OBJ_CLASS(attr_idx) != Data_Obj          ||
            ! (ATD_CLASS(attr_idx) == Compiler_Tmp  &&
               ATD_TMP_NEEDS_CIF(attr_idx))))) {
         goto EXIT;
      }

      /* If this is the specific name of an intrinsic procedure, we are       */
      /* looking at the compiler-generated name (like _NABS_ for IABS).  Get  */
      /* back to the interface Attr entry that describes the specific         */
      /* intrinsic (and that contains the name the user wrote in the program) */
      /* and use it instead.                                                  */

      if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit  &&  
          ATP_PROC(attr_idx) == Intrin_Proc   &&
          ! ATP_IN_INTERFACE_BLK(attr_idx)) {
         attr_idx = ATP_INTERFACE_IDX(attr_idx);
      }

           
      if (AT_CIF_SYMBOL_ID(attr_idx) == 0) {
         AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID;
      }

      file_line_num = get_line_and_file_id(line_num, &local_file_id);

      Cif_Usage_Rec(c_i_f,
                    AT_CIF_SYMBOL_ID(attr_idx),
                    local_file_id,
                    file_line_num,
                    col_num, 
                    usage_code,
                    0,
                    NULL);

      break;

   case NO_Tbl_Idx:
      file_line_num = get_line_and_file_id(line_num, &local_file_id);

      Cif_Usage_Rec(c_i_f,
                    obj_idx,
                    local_file_id,
                    file_line_num,
                    col_num, 
                    usage_code,
                    0,
                    NULL);

      break;

   default:
      skip_struct_base  = TRUE;
      OPND_FLD(opnd)    = obj_fld;
      OPND_IDX(opnd)    = obj_idx;

      /* Get line and column of last component.                               */

      attr_idx = find_base_attr(&opnd, &line_num, &col_num);


      /* Get base attr.                                                       */

      attr_idx = find_left_attr(&opnd);

      if (AT_DCL_ERR(attr_idx)) {
         goto EXIT;
      }

      if (AT_CIF_SYMBOL_ID(attr_idx) == 0) {
         AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID;
      }

      cif_symbol_id = AT_CIF_SYMBOL_ID(attr_idx);
      AT_CIF_IN_USAGE_REC(attr_idx) = TRUE;

      file_line_num = get_line_and_file_id(line_num, &local_file_id);

      if (fprintf(c_i_f, "%d%c%d%c%d%c%d%c%d%c%d",
                         CIF_USAGE, EOI,
                         cif_symbol_id, EOI,
                         local_file_id, EOI,
                         file_line_num, EOI,
                         col_num, EOI,
                         usage_code) < 0) {
         Cif_Error();
      }

      cif_number_of_struct_ids = 0;
    
      output_struct_ids(&opnd);

      if (fprintf(c_i_f, "%c%d", EOI, cif_number_of_struct_ids) < 0) {
         Cif_Error();
      }

      cif_number_of_struct_ids = -1;

      if (! output_struct_ids(&opnd)) {
         Cif_Error();
      }

      if (fprintf(c_i_f, "%c", EOR) < 0) {
         Cif_Error();
      }

      break;
   }

EXIT:

   TRACE (Func_Exit, "cif_usage_rec", NULL);

   return;

}  /* cif_usage_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output a Usage record [19] for a common block name.                   *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      sb_idx      : stor blk index                                          *|
|*      line_num    : the line number containing the symbol for which this    *|
|*                    Usage record is being produced                          *|
|*      col_num     : the column number for the block                         *|
|*      usage_code  : the CIF-defined usage code                              *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void cif_sb_usage_rec(int                       sb_idx,
                      int                       line_num,
                      int                       col_num,
                      cif_usage_code_type       usage_code)
{
   int          file_line_num;
   int          local_file_id;


   TRACE (Func_Entry, "cif_sb_usage_rec", NULL);

   file_line_num = get_line_and_file_id(line_num, &local_file_id);

   if (SB_CIF_SYMBOL_ID(sb_idx) == 0) {
      SB_CIF_SYMBOL_ID(sb_idx) = NEXT_SYMBOL_ID;
   }

   Cif_Usage_Rec(c_i_f,
                 SB_CIF_SYMBOL_ID(sb_idx),
                 local_file_id, 
                 file_line_num,
                 col_num, 
                 usage_code,
                 0,
                 NULL);

   TRACE (Func_Exit, "cif_sb_usage_rec", NULL);

   return;

}  /* cif_sb_usage_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output an Enable/Disable Compiler Options record [21].                *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void cif_enable_disable_rec(void)
{
   long         enable_disable_opts;


   TRACE (Func_Entry, "cif_enable_disable_rec", NULL);

   enable_disable_opts = 0;

   if (on_off_flags.abort_if_any_errors) {
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTa;
   }


# ifdef _ACCEPT_FLOW

   if (on_off_flags.flowtrace_option) {
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTf;
   }

# endif


# ifdef _ACCEPT_CMD_ed_i

   if (on_off_flags.indef_init) {
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTi;
   }

# endif


# ifdef _ACCEPT_CMD_ed_j

   if (on_off_flags.exec_doloops_once) { 
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTj;
   }

# endif


   if (on_off_flags.issue_ansi_messages) {
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTn;
   }

   if (on_off_flags.enable_double_precision) {
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTp;
   }

   if (on_off_flags.abort_on_100_errors) {
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTq;
   }


# ifdef _ACCEPT_CMD_ed_r

   if (on_off_flags.round_mult_operations) {
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTr;
   }

# endif


   if (on_off_flags.alloc_autos_on_stack) {
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTt;
   }

   if (on_off_flags.eu) { 
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTu;
   }

   if (on_off_flags.save_all_vars) {
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTv;
   }


# ifdef _ACCEPT_CMD_ed_A

   if (on_off_flags.MPP_apprentice) {
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTA;
   }

# endif


   if (cmd_line_flags.binary_output) {
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTB;
   }

   if (cmd_line_flags.assembly_output) {
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTS;
   }


# ifdef _ACCEPT_CMD_ed_X

   if (on_off_flags.atexpert) {
      enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTX;
   }

# endif


   Cif_EDopts_Rec(c_i_f, enable_disable_opts);

   TRACE (Func_Exit, "cif_enable_disable_rec", NULL);

   return;

}  /* cif_enable_disable_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output a Machine Characteristics record [22].                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void cif_machine_characteristics_rec(void)
{


# if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX)

   int          characteristics;

   union        {long   int_form;
                 char   char_form[9];
                } cpu_type;

# endif


   TRACE (Func_Entry, "cif_machine_characteristics_rec", NULL);


# ifdef _TARGET_OS_UNICOS

# ifdef _GETPMC_AVAILABLE

   /* Get the "primary" name of the machine.                                  */

   cpu_type.int_form     = target_machine.fld.mcpmt;
   cpu_type.char_form[8] = NULL_CHAR;


   /* Get the "characteristics" bitmask values.                               */

   characteristics = 0;

   if (target_machine.fld.mcvpop) {
      characteristics = characteristics | CIF_MC_VPOP;
   }

   if (target_machine.fld.mcema) {
      characteristics = characteristics | CIF_MC_EMA;
   }

   if (target_machine.fld.mccigs) {
      characteristics = characteristics | CIF_MC_CIGS;
   }

   if (target_machine.fld.mcpc) {
      characteristics = characteristics | CIF_MC_PCF;
   }

   if (target_machine.fld.mcrdvl) {
      characteristics = characteristics | CIF_MC_READVL;
   }

   if (target_machine.fld.mcvrcr) {
      characteristics = characteristics | CIF_MC_VRECUR;
   }

   if (target_machine.fld.mcavl) {
      characteristics = characteristics | CIF_MC_AVL;
   }

   if (target_machine.fld.mchpm) {
      characteristics = characteristics | CIF_MC_HPF;
   }

   if (target_machine.fld.mcbdm) {
      characteristics = characteristics | CIF_MC_BDM;
   }

   if (target_machine.fld.mcstr) {
      characteristics = characteristics | CIF_MC_SREG;
   }

   if (target_machine.fld.mcstr) {
      characteristics = characteristics | CIF_MC_CLUSTER;
   }

   if (target_machine.fld.mccori) {
      characteristics = characteristics | CIF_MC_COR;
   }

   if (target_machine.fld.mcaddr32) {
      characteristics = characteristics | CIF_MC_ADDR32;
   }

   if (target_machine.fld.mcbmm) {
      characteristics = characteristics | CIF_MC_BMM;
   }

   if (target_machine.fld.mcxea) {
      characteristics = characteristics | CIF_MC_XEA;
   }

   if (target_machine.fld.mcavpop) {
      characteristics = characteristics | CIF_MC_AVPOP;
   }

   if (target_machine.fld.mcfullsect) {
      characteristics = characteristics | CIF_MC_FULLSECT;
   }

   if (target_machine.fld.mcieee) {
      characteristics = characteristics | CIF_MC_IEEE;
   }

   if (target_machine.fld.mccmrreq) {
      characteristics = characteristics | CIF_MC_CMRREQ;
   }

   if (target_machine.fld.mccache) {
      characteristics = characteristics | CIF_MC_CACHE;
   }

   Cif_Mach_Char_Rec(c_i_f,
                     cpu_type.char_form,
                     target_machine.fld.mcmspd,
                     target_machine.fld.mcmsz, 
                     characteristics, 
                     target_machine.fld.mcbank,
                     target_machine.fld.mcncpu,
                     target_machine.fld.mcibsz,
                     target_machine.fld.mcclk, 
                     target_machine.fld.mcncl,
                     target_machine.fld.mcbbsy,
                     TARGET_BITS_PER_WORD);


# else


   /* Assume since target is UNICOS and host is not that this is a DPE        */
   /* compiler.                                                               */
   /* Dummy up a record until the machine characteristics library routine has */
   /* been ported.  mcpmt already has the target machine name in it in char   */
   /* form.                                                                   */
 
   Cif_Mach_Char_Rec(c_i_f,
                     target_machine.fld.mcpmt, 
                     -1L,
                     -1L,
                     0, 
                     -1L,
                     -1L,
                     -1L,
                     -1L,
                     -1L,
                     -1L,
                     TARGET_BITS_PER_WORD);

# endif


# endif


# ifdef _TARGET_OS_MAX


# if defined(_GETPMC_AVAILABLE)

   /* Get the "primary" name of the machine.                                  */

   cpu_type.int_form     = target_machine.fld.mcpmt;
   cpu_type.char_form[8] = NULL_CHAR;


   Cif_Mach_Char_Rec(c_i_f,
                     cpu_type.char_form,
                     -1L, 
                     target_machine.fld.mcmsz,
                     0, 
                     -1L,
                     -1L,
                     -1L,
                     -1L,
                     -1L,
                     -1L,
                     TARGET_BITS_PER_WORD);

# else


   /* Assume since target is MAX and host is not UNICOS that this is a cross  */
   /* compiler.                                                               */
   /* Dummy up a record until the machine characteristics library routine has */
   /* been ported.  mcpmt already has the target machine name in it in char   */
   /* form.                                                                   */
 
   Cif_Mach_Char_Rec(c_i_f,
                     target_machine.fld.mcpmt,
                     -1L, 
                     -1L, 
                     0, 
                     -1L,
                     -1L, 
                     -1L, 
                     -1L, 
                     -1L, 
                     -1L,
                     TARGET_BITS_PER_WORD);


# endif


# endif


# if defined(GENERATE_WHIRL)


   /* Produce a dummy Machine Characteristics record for a IRIX.             */

   Cif_Mach_Char_Rec(c_i_f,
                     "IRIX",
                     -1L, 
                     -1L, 
                     0, 
                     -1L,
                     -1L,
                     -1L,
                     -1L,
                     -1L,
                     -1L,
                     TARGET_BITS_PER_WORD);

# elif defined(_TARGET_OS_SOLARIS)

   /* Produce a dummy Machine Characteristics record for a SPARC.             */

   Cif_Mach_Char_Rec(c_i_f,
                     "SPARC",
                     -1L, 
                     -1L, 
                     0, 
                     -1L,
                     -1L,
                     -1L,
                     -1L,
                     -1L,
                     -1L,
                     TARGET_BITS_PER_WORD);
# endif


   TRACE (Func_Exit, "cif_machine_characteristics_rec", NULL);

   return;

}  /* cif_machine_characteristics_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output a Statement Type record [25].                                  *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      exact_stmt_type_known :                                               *|
|*      exact_stmt_type       :                                               *|
|*      stmt_number           :                                               *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void cif_stmt_type_rec(boolean          exact_stmt_type_known,
                       cif_stmt_type    exact_stmt_type,
                       int              stmt_number)
{
   int                  file_line_num;
   int                  local_file_id;
   cif_stmt_type        local_stmt_type;


   TRACE (Func_Entry, "cif_stmt_type_rec", NULL);

   local_stmt_type = (exact_stmt_type_known) ?
                        exact_stmt_type : mapped_stmt_type[stmt_type];

   switch (local_stmt_type) {

      case CIF_Not_Exact:
         if (comp_phase < Decl_Semantics  &&  stmt_type == Assignment_Stmt) {

            /* Place a Statement_Num_Stmt before this to hold the value of    */
            /* stmt_number in its SH_PARENT_BLK_IDX field.                    */

            gen_sh(Before, Statement_Num_Stmt, stmt_start_line, stmt_start_col,
                   FALSE, FALSE, TRUE);
            SH_PARENT_BLK_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = stmt_number;
         }

         break;

      case CIF_Stmt_Type_Error:
         PRINTMSG(stmt_start_line, 776, Internal, stmt_start_col);

      default:
         file_line_num = get_line_and_file_id(stmt_start_line, &local_file_id);

         Cif_Stmt_Type_Rec(c_i_f,
                           local_stmt_type,
                           local_file_id, 
                           file_line_num,
                           stmt_start_col,
                           stmt_number);
   }

   TRACE (Func_Exit, "cif_stmt_type_rec", NULL);

   return;

}  /* cif_stmt_type_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output a Continuation Line record [27].                               *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      continuation_type : 0 = source line, 1 = CDIR$ line                   *|
|*      line_number       : line number of the continuation line              *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void cif_cont_line_rec(int      continuation_type,
                       int      line_number)
{
   int          file_line_num;  /* placeholder */
   int          local_file_id;


   file_line_num = get_line_and_file_id(line_number, &local_file_id);

   Cif_Continuation_Rec(c_i_f,
                        continuation_type,
                        local_file_id,
                        line_number,
                        1);

   return;

}  /* cif_cont_line_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*    Output a Call Site [28] record.                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      ir_idx - ir idx for call operator.                                    *|
|*      gen_idx - attr_idx of original call attr.                             *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void  cif_call_site_rec(int     ir_idx,
                        int     gen_idx)

{
   int          array_type;
   long         attributes;
   int          attr_idx;
   int          bd_idx;
   char         buffer[160];                    /* Copied from cif_send_attr. */
   char         char_len[20];
   int          column;
   int          derived_type_id;
   int          file_line_num;
   int          i;
   int          info_idx;
   int          k;
   int          list_idx;
   int          local_file_id;
   int          misc_attrs;
   int          num_args;
   int          num_dims;
   opnd_type    opnd;
   int          pgm_unit_type;
   int          rslt_id;
   int          save_reference;
   int          spec_idx;
   int          specific_symbol_id;
   char         string[20];                     /* Copied from cif_send_attr. */
   int          symbol_id;
   int          type;
   char         var_len_bound[3];


   TRACE (Func_Entry, "cif_call_site_rec", NULL);

/*
   if (SH_CIF_SKIP_ME(curr_stmt_sh_idx)) {
      TRACE (Func_Exit, "cif_call_site_rec", NULL);
      return;
   }
*/

   skip_struct_base     = FALSE;
   file_line_num        = get_line_and_file_id(IR_LINE_NUM_L(ir_idx), 
                                               &local_file_id);
   spec_idx             = IR_IDX_L(ir_idx);

   /* If this is a generic procedure reference and there is something wrong   */
   /* with the generic procedure Attr, then don't output the Call Site record */
   /* because other records might not be generated to resolve symbol ids in   */
   /* the Call Site record.                                                   */

   if (spec_idx != gen_idx  &&  AT_DCL_ERR(gen_idx)) {
      goto EXIT;
   }

   num_args = IR_LIST_CNT_R(ir_idx);
   list_idx = IR_IDX_R(ir_idx);

   for (i = 1; i <= num_args; i++) {

      info_idx = IL_ARG_DESC_IDX(list_idx);

      if (info_idx == 0) {
         /* cif id is 0 */
      }
      else if (arg_info_list[info_idx].ed.component) {
         arg_info_list[info_idx].ed.cif_id = list_idx;
      }
      else if (arg_info_list[info_idx].ed.cif_id != 0) {
         /* intentionally blank */
      }
      else if (arg_info_list[info_idx].ed.reference  || 
               (IL_FLD(list_idx) == AT_Tbl_Idx  && 
                ! AT_COMPILER_GEND(IL_IDX(list_idx)))) {

         /* If no CIF symbol id yet, get one. */

         COPY_OPND(opnd, IL_OPND(list_idx));
         attr_idx = find_left_attr(&opnd);

         if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit  &&
             ATP_PROC(attr_idx) == Intrin_Proc) {
            attr_idx = ATP_INTERFACE_IDX(attr_idx);
         }

         if (AT_CIF_SYMBOL_ID(attr_idx) == 0) {
            AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID;
         }

         arg_info_list[info_idx].ed.cif_id = AT_CIF_SYMBOL_ID(attr_idx);
      }
      else {
         symbol_id      = NEXT_SYMBOL_ID;
         char_len[0]    = NULL_CHAR;

         COPY_OPND(opnd, IL_OPND(list_idx));
         attr_idx       = find_left_attr(&opnd);

         type = (arg_info_list[info_idx].ed.type == Structure) ?
                 ATT_CIF_DT_ID(TYP_IDX(arg_info_list[info_idx].ed.type_idx)) :
                 arg_info_list[info_idx].ed.linear_type;

         if (arg_info_list[info_idx].ed.type == Character) {

            if (arg_info_list[info_idx].ed.char_len.fld == CN_Tbl_Idx) {
               convert_to_string(
                          &CN_CONST(arg_info_list[info_idx].ed.char_len.idx),
                           CN_TYPE_IDX(arg_info_list[info_idx].ed.char_len.idx),
                           char_len);
            }
            else {
               char_len[0] = VAR_LEN_CHAR;
               char_len[1] = NULL_CHAR;
            }
         }

         misc_attrs      = 0;
         derived_type_id = 0;

         if (arg_info_list[info_idx].ed.constant) {

            if (IL_FLD(list_idx) == CN_Tbl_Idx) {
               attr_idx = IL_IDX(list_idx);
            }
         }
             
         num_dims = arg_info_list[info_idx].ed.rank;

         array_type = (num_dims > 0) ? 1   /* explicit shape */  : 0;

         if (fprintf(c_i_f, 
                     "%d%c%s%c%d%c%d%c%d%c%d%c%d%c%d%c%d%c%d%c%d%c%s%c%d%c%d",
                     CIF_F90_OBJECT, EOI,
                     "", EOI,
                     symbol_id, EOI,
                     SCP_CIF_ID(curr_scp_idx), EOI,
                     cif_data_type(type), EOI,
                     2, EOI,
                     7,EOI,
                     0,EOI,
                     -1, EOI,
                     misc_attrs, EOI,
                     derived_type_id, EOI,
                     char_len, EOI,
                     num_dims, EOI,
                     array_type) < 0) {
            Cif_Error();
            goto EXIT;
         }

         buffer[0] = NULL_CHAR;

         var_len_bound[0] = EOI;
         var_len_bound[1] = VAR_LEN_CHAR;
         var_len_bound[2] = NULL_CHAR;

         for (k = 0; k < num_dims; k++) {

            if (arg_info_list[info_idx].ed.constant &&
                attr_idx != NULL_IDX)               {

               bd_idx = ATD_ARRAY_IDX(attr_idx);

               if (BD_LB_FLD(bd_idx, k+1) == CN_Tbl_Idx) {
                  sprintf(string, "%c%s",
                          EOI,
                          convert_to_string(&CN_CONST(BD_LB_IDX(bd_idx,k+1)),
                                             CN_TYPE_IDX(BD_LB_IDX(bd_idx,k+1)),
                                             outbuf1));
                  strcat(buffer, string);
               }
               else {
                  strcat(buffer, var_len_bound);
               }

               if (BD_UB_FLD(bd_idx, k+1) == CN_Tbl_Idx) {
                  sprintf(string, "%c%s",
                          EOI,
                          convert_to_string(&CN_CONST(BD_UB_IDX(bd_idx,k+1)),
                                             CN_TYPE_IDX(BD_UB_IDX(bd_idx,k+1)),
                                             outbuf1));
                  strcat(buffer, string);
               }
               else {
                  strcat(buffer, var_len_bound);
               }
            }
            else {
               buffer[0] = EOI;
               buffer[1] = '1';
               buffer[2] = NULL_CHAR;
          
               if (OPND_FLD(arg_info_list[info_idx].ed.shape[k]) == 
                                                                  CN_Tbl_Idx) {
                  sprintf(string, "%c%s",
                          EOI,
                          convert_to_string(
                             &CN_CONST(OPND_IDX(
                                          arg_info_list[info_idx].ed.shape[k])),
                              CN_TYPE_IDX(OPND_IDX(
                                         arg_info_list[info_idx].ed.shape[k])),
                              outbuf1));
                  strcat(buffer, string);
               }
               else {
                  strcat(buffer, var_len_bound);
               }
            }

            if (fprintf(c_i_f, "%s", buffer) < 0) {
               Cif_Error();
               goto EXIT;
            }
         }

         if (fprintf(c_i_f, "%c%d%c%d%c%d%c",
                            EOI,
                            0, EOI,                         /*  Distribution  */
                            0, EOI,                         /*  Geometry id   */
                            0, EOR) < 0) {                  /*  CRI ptr id    */
            Cif_Error();
            goto EXIT;
         }

         arg_info_list[info_idx].ed.cif_id = symbol_id;
      }

      list_idx = IL_NEXT_LIST_IDX(list_idx);
   }

   if (ATP_PROC(spec_idx) == Intrin_Proc && !ATI_USER_SPECIFIED(gen_idx)) {

      /* Intrinsic call where the intrinsic name was NOT specified as the     */
      /* generic name on a user interface block.                              */

      if (AT_CIF_SYMBOL_ID(gen_idx) == 0) {
         AT_CIF_SYMBOL_ID(gen_idx) = NEXT_SYMBOL_ID;
      }

      symbol_id          = AT_CIF_SYMBOL_ID(gen_idx);

      if (AT_CIF_SYMBOL_ID(spec_idx) == 0) {
         AT_CIF_SYMBOL_ID(spec_idx) = NEXT_SYMBOL_ID;
      }

      specific_symbol_id = 0;
      specific_symbol_id = AT_CIF_SYMBOL_ID(spec_idx);

      column = (ATP_PGM_UNIT(spec_idx) == Function) ? IR_COL_NUM_L(ir_idx) :
                                                      IR_COL_NUM(ir_idx);
      if (! ATI_CIF_SEEN_IN_CALL(gen_idx)) {

         /* Issue an entry record for the interface.  These do not go out */
         /* in cif_send_attr but need to be specially sent through here.  */

         rslt_id = 0;

         if (ATI_INTERFACE_CLASS(gen_idx) == Generic_Function_Interface) {
            pgm_unit_type = CIF_F90_ET_FUNCTION;

            /* Just set the result's symbol id for now.  The Object record    */
            /* will be produced via calls directly from call site processing  */
            /* code after all information about the function being called has */
            /* been resolved.  The specific entry will be sent at that time.  */

            if (AT_CIF_SYMBOL_ID(ATP_RSLT_IDX(spec_idx)) == 0) {
               AT_CIF_SYMBOL_ID(ATP_RSLT_IDX(spec_idx)) = NEXT_SYMBOL_ID;
            }
         
            rslt_id = AT_CIF_SYMBOL_ID(ATP_RSLT_IDX(spec_idx));
         }
         else if (ATI_INTERFACE_CLASS(gen_idx) == Generic_Subroutine_Interface){
            pgm_unit_type = CIF_F90_ET_SUBROUTINE;

            /* Send the specific entry as it will not get sent when the */
            /* symbol table gets sent as intrinsics are special cased.  */

            save_reference       = AT_REFERENCED(spec_idx);
            AT_REFERENCED(spec_idx) = Referenced;
            cif_send_attr(spec_idx, NULL_IDX);
            AT_REFERENCED(spec_idx) = save_reference;
         
         }
         else {
            pgm_unit_type = CIF_F90_ET_UNKNOWN;
            cif_send_attr(spec_idx, NULL_IDX);
         }
  
         attributes = CIF_PGM_REFERENCE;
  
         if (AT_PRIVATE(gen_idx)) {
            attributes = attributes | CIF_PGM_PRIVATE;
         }

         Cif_F90_Entry_Rec(c_i_f,
                           AT_OBJ_NAME_PTR(gen_idx),
                           AT_CIF_SYMBOL_ID(gen_idx),
                           SCP_CIF_ID(curr_scp_idx), 
                           pgm_unit_type, 
                           CIF_F90_PT_INTRINSIC,
                           attributes, 
                           rslt_id, 
                           0, 
                           0, 
                           NULL);
      }
   }
   else if (spec_idx == gen_idx) {     /*  Specific call.       */

      if (AT_CIF_SYMBOL_ID(spec_idx) == 0) {
         AT_CIF_SYMBOL_ID(spec_idx) = NEXT_SYMBOL_ID;
      }

      symbol_id = AT_CIF_SYMBOL_ID(spec_idx);
      specific_symbol_id = 0;

      if (ATP_PGM_UNIT(spec_idx) == Function) {
         column = IR_COL_NUM_L(ir_idx);
      }
      else {
         column = IR_COL_NUM(ir_idx);
      }
   }
   else if (ATI_INTERFACE_CLASS(gen_idx) == Defined_Assign_Interface) {
      
      if (AT_CIF_SYMBOL_ID(spec_idx) == 0) {
         AT_CIF_SYMBOL_ID(spec_idx) = NEXT_SYMBOL_ID;
      }

      specific_symbol_id = AT_CIF_SYMBOL_ID(spec_idx);

      if (AT_CIF_SYMBOL_ID(gen_idx) == 0) {
         AT_CIF_SYMBOL_ID(gen_idx) = NEXT_SYMBOL_ID;
      }

      symbol_id = AT_CIF_SYMBOL_ID(gen_idx);
      column    = IR_COL_NUM(ir_idx);
   }
   else {
      
      if (AT_CIF_SYMBOL_ID(spec_idx) == 0) {
         AT_CIF_SYMBOL_ID(spec_idx) = NEXT_SYMBOL_ID;
      }

      specific_symbol_id = AT_CIF_SYMBOL_ID(spec_idx);

      if (AT_CIF_SYMBOL_ID(gen_idx) == 0) {
         AT_CIF_SYMBOL_ID(gen_idx) = NEXT_SYMBOL_ID;
      }

      symbol_id = AT_CIF_SYMBOL_ID(gen_idx);

      if (ATI_INTERFACE_CLASS(gen_idx) == Generic_Function_Interface) {
         column = IR_COL_NUM_L(ir_idx);
      }
      else {
         column = IR_COL_NUM(ir_idx);
      }
   }

   if (fprintf(c_i_f, "%d%c%d%c%d%c%d%c%d%c%d%c%d%c%d",
               CIF_F90_CALLSITE, EOI,
               symbol_id, EOI,
               SCP_CIF_ID(curr_scp_idx), EOI,
               local_file_id, EOI,
               file_line_num, EOI,
               column, EOI,
               specific_symbol_id, EOI,
               num_args) < 0) {

      Cif_Error();
      goto EXIT;
   }


   /* Output the symbol IDs for the actual arguments.                         */

   list_idx = IR_IDX_R(ir_idx);

   for (i = 1; i <= num_args; i++) {

      info_idx = IL_ARG_DESC_IDX(list_idx);

      if (info_idx == 0) {

         if (fprintf(c_i_f, "%c%d", EOI, 0) < 0) {
            Cif_Error();
            goto EXIT;
         }
      }
      else if (arg_info_list[info_idx].ed.component) {

         if (fprintf(c_i_f, "%c%c", EOI, '%') < 0) {
            Cif_Error();
            goto EXIT;
         }

         COPY_OPND(opnd, 
                   IL_OPND(arg_info_list[info_idx].ed.cif_id));

         cif_number_of_struct_ids = 0;

         output_struct_ids(&opnd);

         if (fprintf(c_i_f, "%c%d", EOI, cif_number_of_struct_ids) < 0) {
            Cif_Error();
            goto EXIT;
         }

         cif_number_of_struct_ids = -1;

         if (! output_struct_ids(&opnd)) {
            Cif_Error();
            goto EXIT;
         }

         if (fprintf(c_i_f, "%c%c", EOI, '%') < 0) {
            Cif_Error();
            goto EXIT;
         }
      }
      else {
         if (fprintf(c_i_f, "%c%d",
                     EOI, 
                     arg_info_list[info_idx].ed.cif_id) < 0) {
            Cif_Error();
            goto EXIT;
         }
      }

      list_idx = IL_NEXT_LIST_IDX(list_idx);
   }


   /* Output the rank for the each actual argument.                           */

   list_idx = IR_IDX_R(ir_idx);

   for (i = 1; i <= num_args; i++) {

      info_idx = IL_ARG_DESC_IDX(list_idx);

      if (info_idx == 0) {

         if (fprintf(c_i_f, "%c%d", EOI, 0) < 0) {
            Cif_Error();
            goto EXIT;
         }
      }
      else {

         if (fprintf(c_i_f, "%c%d",
                     EOI, 
                     arg_info_list[info_idx].ed.rank) < 0) {
            Cif_Error();
            goto EXIT;
         }
      }

      list_idx = IL_NEXT_LIST_IDX(list_idx);
   }

   if (fprintf(c_i_f,"%c", EOR) < 0) {
      Cif_Error();
      goto EXIT;
   }

EXIT:

   TRACE (Func_Exit, "cif_call_site_rec", NULL);

   return;

}  /* cif_call_site_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output a Named Constant record [30].                                  *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      attr_idx     : AT table index of the named constant                   *|
|*      start_line   : line where the value starts                            *|
|*      start_column : column where the value starts                          *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void cif_named_constant_rec(int         attr_idx,
                           int          start_line,
                           int          start_column)
{
   int          cn_idx;
   int          const_idx;
   int          end_col;
   int          end_line;
   int          file_id;
   long64       length;
   boolean      ok;
   long_type    result[MAX_WORDS_FOR_NUMERIC];
   char         str[80];
   int          type_idx;


   TRACE (Func_Entry, "cif_named_constant_rec", NULL);

   if (AT_CIF_SYMBOL_ID(attr_idx) == 0) {
      AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID;
   }

   if (TYP_LINEAR(ATD_TYPE_IDX(attr_idx)) != Structure_Type  &&
       ATD_ARRAY_IDX(attr_idx) == NULL_IDX) {
      const_idx = ATD_CONST_IDX(attr_idx);
   }
   else {
      const_idx = NULL_IDX;
   }

   get_line_and_file_id(start_line, &file_id);

   if (fprintf(c_i_f, "%d%c%d%c%d%c%d%c",
                      CIF_F90_CONST, EOI,
                      AT_CIF_SYMBOL_ID(attr_idx), EOI,
                      (c_i_f == cif_actual_file) ? 
                                SCP_CIF_ID(curr_scp_idx) : 1, EOI,
                      (const_idx) ? 0 : 1, EOI) < 0) {
      Cif_Error();
   }

   if (const_idx) {

      switch (TYP_TYPE(ATD_TYPE_IDX(attr_idx))) {

         case Logical:
            if (fprintf(c_i_f, "%s", 
                               (THIS_IS_TRUE(&(CN_CONST(const_idx)),
                                             CN_TYPE_IDX(const_idx)) ?
                                           
                                  ".TRUE." : ".FALSE.")) < 0) {
               Cif_Error();
            }
   
            break;

         case Integer:
         case Real:
         case Complex:

            if (fprintf(c_i_f, "%s", convert_to_string(&CN_CONST(const_idx),
                                                       CN_TYPE_IDX(const_idx),
                                                       str)) < 0) {
               Cif_Error();
            }

            break;

         case Typeless:
            if (TYP_LINEAR(CN_TYPE_IDX(const_idx)) == Typeless_4 ||
                TYP_LINEAR(CN_TYPE_IDX(const_idx)) == Typeless_8) {

               if (fprintf(c_i_f, "%s",
                                  convert_to_string(&CN_CONST(const_idx),
                                                    CN_TYPE_IDX(const_idx),
                                                    str)) < 0) {
                  Cif_Error();
               }
            }
            else if (fprintf(c_i_f, "%s", (char *) &CN_CONST(const_idx)) < 0) {
               Cif_Error();
            }

            break;

         case Character:

            C_TO_F_INT(result, TARGET_CHARS_PER_WORD, CG_INTEGER_DEFAULT_TYPE);

            cn_idx      = TYP_IDX(CN_TYPE_IDX(const_idx));
            type_idx    = CG_INTEGER_DEFAULT_TYPE;

            ok          = folder_driver((char *) &CN_CONST(cn_idx),
                                        CN_TYPE_IDX(cn_idx),
                                        (char *) result,
                                        type_idx,
                                        result,
                                        &type_idx,
                                        stmt_start_line,
                                        stmt_start_col,
                                        2,
                                        Mod_Opr);

            ok         |= folder_driver((char *) result,
                                        type_idx,
                                        (char *) &CN_CONST(CN_INTEGER_ZERO_IDX),
                                        CN_TYPE_IDX(CN_INTEGER_ZERO_IDX),
                                        result,
                                        &type_idx,
                                        stmt_start_line,
                                        stmt_start_col,
                                        2,
                                        Eq_Opr);
 

            if (ok && THIS_IS_TRUE(result, type_idx)) {
     
               if (fprintf(c_i_f, "%s", (char *) &CN_CONST(const_idx)) < 0) {
                  Cif_Error();
               }
            }
            else {
               length = CN_INT_TO_C(TYP_IDX(CN_TYPE_IDX(const_idx)));
               ((char *) &CN_CONST(const_idx)) [length] = NULL_CHAR;

               if (fprintf(c_i_f, "%s", (char *) &CN_CONST(const_idx)) < 0) {
                  Cif_Error();
               }

               ((char *) &CN_CONST(const_idx)) [length] = ' ';
            }

            break;

      } /* End switch */
   }

   /* If start_line is 0, it means cif_named_constant_rec is being called from*/
   /* the ATD_CLASS == Constant case of cif_send_attr to spit out a dummy     */
   /* Named Constant record for a use associated named constant.              */

   if (start_line != 0) {
      prev_char_line_and_col(&end_line, &end_col);
   }
   else {
      file_id  = 0;
      end_line = 0;
      end_col  = 0;
   }

   if (fprintf(c_i_f, "%c%d%c%d%c%d%c%d%c%d%c",
                      EOI,
                      file_id, EOI,
                      start_line, EOI,
                      start_column, EOI,
                      end_line, EOI,
                      end_col, EOR) < 0) {
      Cif_Error();
   }

   TRACE (Func_Exit, "cif_named_constant_rec", NULL);

   return;

}  /* cif_named_constant_rec */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Output a Loop Definitions record [32].                                *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/

void cif_loop_def_rec(void)
{
   int          construct_name_id;
   int          do_sh_idx;
   int          do_var_idx;
   int          end_file_id;
   int          end_line;
   int          il_idx;
   int          loop_info_il_idx;
   int          loop_ir_idx;
   int          loop_label_id;
   int          loop_type;
   int          lcv_symbol_id;
   int          start_file_id;
   int          start_line;


   TRACE (Func_Entry, "cif_loop_def_rec", NULL);

   do_sh_idx = SH_PARENT_BLK_IDX(curr_stmt_sh_idx);

   if (do_sh_idx == NULL_IDX || SH_COMPILER_GEN(do_sh_idx)) {
      TRACE (Func_Exit, "cif_loop_def_rec", NULL);
      return;
   }

   loop_ir_idx      = SH_IR_IDX(do_sh_idx);
   loop_info_il_idx = IR_IDX_R(loop_ir_idx);

   if (SH_STMT_TYPE(do_sh_idx) == Do_Iterative_Stmt) {
      loop_type = CIF_LP_DO;

      /* There are two version of this.  The first is what we need */
      /* The second should only be compiler generated so we should */
      /* not get here, but I have code here just in case.          */

      if (IL_FLD(loop_info_il_idx) == IL_Tbl_Idx) {
         il_idx    = IL_IDX(loop_info_il_idx);
      }
      else {
         il_idx    = loop_info_il_idx;
      }

      if (IL_FLD(il_idx) == AT_Tbl_Idx) {
         do_var_idx = IL_IDX(il_idx);
      }
      else {

         /* Had better be a Dv_Deref IR.                                      */

         do_var_idx = IR_IDX_L(IL_IDX(il_idx));
      }

      if (AT_CIF_SYMBOL_ID(do_var_idx) == 0) {
         AT_CIF_SYMBOL_ID(do_var_idx) = NEXT_SYMBOL_ID;
      }

      lcv_symbol_id = AT_CIF_SYMBOL_ID(do_var_idx);
   }
   else {
      loop_type = (SH_STMT_TYPE(do_sh_idx) == Do_While_Stmt) ?
                     CIF_LP_DOWHILE : CIF_LP_DO_INFINITE;
      lcv_symbol_id = 0;
   }


   /* Get the line number and file id of the DO statement and the file id of  */
   /* line that ends the DO loop.  For the ending line case, the line number  */
   /* is already known (obtained from the Statement_Number SH already         */
   /* processed by prog_unit_semantics).                                      */

   start_line = get_line_and_file_id(SH_GLB_LINE(do_sh_idx),
                                     &start_file_id);

   end_line = get_line_and_file_id(stmt_end_line, &end_file_id);


   loop_info_il_idx = IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(loop_info_il_idx));
   il_idx = IL_IDX(loop_info_il_idx);

   if (IL_FLD(il_idx) == NO_Tbl_Idx) {
      loop_label_id = 0;
   }
   else {

      if (AT_CIF_SYMBOL_ID(