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

/*

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

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

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

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

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

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

*/



static char USMID[] = "\n@(#)5.0_pl/sources/messages.c	5.9	10/14/99 14:08:59\n";

# include <stdarg.h>

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


# define  __NLS_INTERNALS  1

# if defined(_HOST_OS_LINUX) || defined(_HOST_OS_DARWIN)
# include <nl_types.h>
# include <nlcatmsg.h>

# else
# include "nl_types.h"
# endif



# 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 "debug.m"
# include "messages.m"

# include "globals.h"
# include "tokens.h"
# include "sytb.h"
# include "main_defs.h"
# include "messages.h"
#ifdef KEY /* Bug 3632 */
# include "src_input.m"
#endif /* KEY Bug 3632 */
#ifdef KEY /* Bug 6673 */
#include "../liberrno.h"
#endif /* KEY Bug 6673 */

#  define	 CIF_VERSION	       3    /* Must be defined before         */
                    			    /*   including cif.h	      */

# include "cif.h"


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

static int      compare_message_recs(const void *, const void *);
static void     flush_msg_file(void);


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	init_msg_processing is called by compiler initialization in main to   *|
|*	determine the name used when the compiler was invoked.	It can either *|
|*	be passed by a script via an environment variable or is the name used *|
|*	when the compiler is directly invoked.				      *|
|*									      *|
|* Input parameters:							      *|
|*	*argv - pointer to command line argument string			      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	value of NLSPATH						      *|
|*									      *|
\******************************************************************************/

#ifdef KEY /* Bug 5089 */
char *init_msg_processing (char *argv[])
#else /* KEY Bug 5089 */
void init_msg_processing (char *argv[])
#endif /* KEY Bug 5089 */

{
   static char	      *allocstr;
#ifdef KEY /* Bug 5089 */
   char *result = getenv("NLSPATH");
#endif /* KEY Bug 5089 */


   TRACE (Func_Entry, "init_msg_processing", NULL);

   /* Unconditionally open the message system */

#if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(TARGET_OS_DARWIN))
#ifdef KEY /* Bug 5089 */
  if (result == NULL)
#else /* KEY Bug 5089 */
  if (getenv("NLSPATH") == NULL)
#endif /* KEY Bug 5089 */
  {
    /* NLSPATH is not set. */
    const char * const toolroot = getenv("TOOLROOT");
    const char * const env_name = "NLSPATH=";
    const char * const env_val = "/usr/lib/locale/C/LC_MESSAGES/%N.cat";
    int len = strlen(env_name) + strlen(env_val) + 1;
    char * new_env;
    if (toolroot != NULL) len += strlen(toolroot);
    new_env = malloc(len);
    if (toolroot == NULL)
      sprintf(new_env, "%s%s", env_name, env_val);
    else
      sprintf(new_env, "%s%s%s", env_name, toolroot, env_val);
    putenv(new_env);
#ifdef KEY /* Bug 5089 */
    result = new_env;
#else /* KEY Bug 5089 */
    free(new_env);
#endif /* KEY Bug 5089 */
  }
#endif

   msg_sys = catopen (group_code, 0);

   if (msg_sys == (nl_catd) -1) {  /* (nl_catd) is msg_sys's type. */

# if defined(_HOST_OS_LINUX) || defined(_HOST_OS_DARWIN)
      fprintf (stderr, PSC_NAME_PREFIX "f95 INTERNAL: Unable to open message system.\n");
# else
      fprintf (stderr, "cf90 INTERNAL: Unable to open message system.\n");
# endif
      exit_compiler(RC_USER_ERROR);

   }

   save_glb_line_num = 0;
   save_column_num   = 0;


   /* Determine the command name used to access the compiler.  This is	      */
   /* needed for message processing and therefore must be done		      */
   /* before any messages are printed.					      */
   /* See if ORIG_CMD_NAME environment variable exists			      */

   command_name = getenv ("ORIG_CMD_NAME");

   if (command_name == NULL) {	/* ORIG_CMD_NAME is not defined; set it.  */ 
      command_name = argv[0];
      command_name = strrchr (argv[0], SLASH);	/* search for rightmost slash */
      command_name = (command_name == NULL) ? argv[0] : command_name+1;
   }
   else {  /* ORIG_CMD_NAME is defined */
      /* Copy it.  Note that allocstr gets the result of memory allocation    */
      /* not command_name.  If an error occurs during memory allocation,      */
      /* command_name is still valid and the message printed will have the    */
      /* correct command name.						      */
      MEM_ALLOC (allocstr, char, strlen(command_name)+1);

      if (allocstr != NULL) {  /* if no memory allocation error... */
	 strcpy (allocstr, command_name); 

	 /* copy is necessary since allocstr could be over written later.     */
	 command_name = allocstr;  
      }
   }

   TRACE (Func_Exit, "init_msg_processing", NULL);

#ifdef KEY /* Bug 5089 */
   return result;
#else /* KEY Bug 5089 */
   return;
#endif /* KEY Bug 5089 */

}  /* init_msg_processing */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This routine is the 'common message processor' for f90.  It is        *|
|*	called by the f90 front-end.				
|*									      *|
|* Input parameters:							      *|
|*	glb_line_num	 If non-zero:  Global line number of source; this     *|
|*			   number maps onto a line number within the current  *|
|*			   file.					      *|
|*			 If zero    :  Indicates that a message header should *|
|*			   should not be output.			      *|
|*	msg_num		 The message number of the text to be output. 	      *|
|*	msg_severity	 The severity level.				      *|
|*	column_num       If non-zero:  Column is put into the header.         *|
|*			 If zero    :  Column is not put into header.         *|
|*	arg1, arg2, 	 Four optional arguments that can be inserted into    *|
|*	arg3, arg4	 into the message text.				      *|
|*									      *|
|*			 Notes:						      *|
|*                         - No validation check is made for missing or extra *|
|*			     arguments in the message text.  It is up to the  *|
|*		 	     developer to insure that the same number of      *|
|*			     arguments passed to PRINTMSG are in the message  *|
|*			     text.			 		      *|
|*	               							      *|
|*                         - Function cif_message_rec must scan the message   *|
|*                           text for the format descriptors.  To make its    *|
|*                           life easier, the formats are restricted to:      *|
|*                             %c  %d  %f  %s                                 *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void PRINTMSG (int			glb_line_num,
	       int			msg_num,
	       msg_severities_type	msg_severity, 
	       int			column_num, 
	       ... )

{
   long		arg1;
   long		arg2;
   long		arg3;
   long		arg4;
   va_list	arg_ptr;
   boolean	error;
   boolean	exit_now;
   boolean	warning;

# if defined(_DEBUG)
   boolean	issue_line_out_of_range_msg	= FALSE;
# endif


/* END_UNIT is stolen from fecif.m so that the whole header need not be       */
/* included.								      */

# define END_UNIT                18             /* End Unit                   */


   TRACE (Func_Entry, "PRINTMSG", NULL);

# ifdef _DEBUG
   /* Validate message number range. */

   if (msg_num > MAX_MSG || msg_num < 0) {
      PRINTMSG (glb_line_num, 1, Internal, 0, msg_num);
   }

# endif

   exit_now = TRUE;

   error	= GET_MESSAGE_TBL(message_error_tbl, msg_num);
   warning	= GET_MESSAGE_TBL(message_warning_tbl, msg_num);

   if ((error && (msg_severity != Error)) || 
       (warning && msg_severity != Warning)) {  /* Switching msg_severity */

      switch (msg_severity) {
      case Ansi:
      case Comment:
      case Note:
      case Caution:
      case Warning:
         msg_severity = (error) ? Error : Warning;
         break;

      case Error:

         if (warning) {
            PRINTMSG (glb_line_num, 1653, Warning, 0, msg_num, "warning");
         }
         error = FALSE; /* This is already an error level */
         break;

      case Vector:
      case Scalar:
      case Table:
      case Inline:
      case Info:
      case Tasking:
      case Optimization:
      case Stream:

      case Internal:
      case Limit:
      case Log_Error:
      case Log_Warning:
      case Log_Summary:
         PRINTMSG (glb_line_num, 1653, Warning, 0, msg_num, 
                   (error) ? "error" : "warning");
         break;
      }
   }

   if (msg_severity != Log_Warning  &&
       msg_severity != Log_Error    &&
       msg_severity != Log_Summary) {

      /* If the line number for the message is 0, it needs extra          */
      /* considerations.  If the message was produced by the front-end,   */
      /* issue the 0 line number message and then issue message 296 to    */
      /* diagnose the 0 line number.  If the message was produced by any  */
      /* component OTHER THAN the front-end and it's an Internal or Limit */
      /* message, just issue the 0 line number message.	If it's NOT an    */
      /* Internal or Limit message, also issue 296.  In all 0 line number */
      /* cases, use stmt_start_line for the line number.  Note that a     */
      /* line number of 0 is acceptable for the Log_ messages.            */


      if (glb_line_num == 0) {

         if (msg_num <= MAX_FE_MSG  ||
             (msg_severity != Limit  &&  msg_severity != Internal)) {

            glb_line_num = (stmt_start_line > 0) ? stmt_start_line : 1;

            /* Set exit_now to FALSE in the event the message is an Internal  */
            /* or Limit message to prevent the call to exit_compiler.         */
            /* exit_compiler will be called when message 296 is issued later. */
     
            exit_now = FALSE;
         }
# if defined(_DEBUG)

         if (dump_flags.msg_checking) {

            /* We are doing extra message checking.      */
            /* Issue an abort for all zero line numbers. */

            exit_now = FALSE;
         }
# endif
      }
      else if (glb_line_num < pgm_unit_start_line && msg_num > MAX_FE_MSG) {

         /* In some cases, a line number outside of the current program unit  */
         /* may be sent to the frontend.  Technically this should be fixed,   */
         /* but to prevent an internal abort we will adjust the line number   */
         /* to be set the the start of the current program unit for a non     */
         /* frontend message.                                                 */

         glb_line_num = pgm_unit_start_line;

# if defined(_DEBUG)

         /* We are doing extra message checking.         */
         /* Issue a message about bad line number later. */

         issue_line_out_of_range_msg = (dump_flags.msg_checking) ? TRUE : FALSE;
# endif
      }
   }

   switch (msg_severity) {

      case Ansi:

         if (on_off_flags.issue_ansi_messages) {

            if (GET_MESSAGE_TBL(message_suppress_tbl, msg_num)) {
               break;
            }

            if (cif_tmp_so_no_msg) {
               break;
            }

            num_ansi++;
            va_start (arg_ptr, column_num);
            arg1 = va_arg (arg_ptr, long);
            arg2 = va_arg (arg_ptr, long);
            arg3 = va_arg (arg_ptr, long);
            arg4 = va_arg (arg_ptr, long);
            va_end (arg_ptr);
            output_msg (glb_line_num, msg_num, msg_severity,
                        column_num, arg1, arg2, arg3, arg4);

# ifdef _DEBUG
            if (dump_flags.abort_on_ansi) {

               output_msg (glb_line_num, 597, Limit, 0, 0, 0, 0, 0);
   
               exit_compiler(RC_USER_ERROR);
            }
# endif

	 }

	 break;
	 

      case Comment:

         if (cmd_line_flags.msg_lvl_suppressed <= Comment_Lvl) {

            if (GET_MESSAGE_TBL(message_suppress_tbl, msg_num)) {
               break;
            }

            if (cif_tmp_so_no_msg) {
               break;
            }

            num_comments++;
            va_start (arg_ptr, column_num);
            arg1 = va_arg (arg_ptr, long);
            arg2 = va_arg (arg_ptr, long);
            arg3 = va_arg (arg_ptr, long);
            arg4 = va_arg (arg_ptr, long);
            va_end (arg_ptr);
            output_msg (glb_line_num, msg_num, msg_severity,  /*PRINTMSG */
                        column_num, arg1, arg2, arg3, arg4);
	 }

	 break;

	 
      case Note:

         if (cmd_line_flags.msg_lvl_suppressed <= Note_Lvl) {

            if (GET_MESSAGE_TBL(message_suppress_tbl, msg_num)) {
               break;
            }

            if (cif_tmp_so_no_msg) {
               break;
            }

            num_notes++;
            va_start (arg_ptr, column_num);
            arg1 = va_arg (arg_ptr, long);
            arg2 = va_arg (arg_ptr, long);
            arg3 = va_arg (arg_ptr, long);
            arg4 = va_arg (arg_ptr, long);
            va_end (arg_ptr);
            output_msg (glb_line_num, msg_num, msg_severity,  
                        column_num, arg1, arg2, arg3, arg4);
	 }

	 break;

	 
      case Caution:

         if (cmd_line_flags.msg_lvl_suppressed <= Caution_Lvl) {

            if (GET_MESSAGE_TBL(message_suppress_tbl, msg_num)) {
               break;
            }

            if (cif_tmp_so_no_msg) {
               break;
            }

            num_cautions++;
            va_start (arg_ptr, column_num);
            arg1 = va_arg (arg_ptr, long);
            arg2 = va_arg (arg_ptr, long);
            arg3 = va_arg (arg_ptr, long);
            arg4 = va_arg (arg_ptr, long);
            va_end (arg_ptr);
            output_msg (glb_line_num, msg_num, msg_severity,
                        column_num, arg1, arg2, arg3, arg4);
	 }

	 break;


      case Warning:

         if (cmd_line_flags.msg_lvl_suppressed <=  Warning_Lvl) {

            if (GET_MESSAGE_TBL(message_suppress_tbl, msg_num)) {
               break;
            }

            if (cif_tmp_so_no_msg) {
               break;
            }

            num_warnings++;
            va_start (arg_ptr, column_num);
            arg1 = va_arg (arg_ptr, long);
            arg2 = va_arg (arg_ptr, long);
            arg3 = va_arg (arg_ptr, long);
            arg4 = va_arg (arg_ptr, long);
            va_end (arg_ptr);
            output_msg (glb_line_num, msg_num, msg_severity,
                        column_num, arg1, arg2, arg3, arg4);
         }

	 break;


      case Error:

         if (cif_tmp_so_no_msg) {
            break;
         }

         num_errors++;
         num_prog_unit_errors++;

         va_start (arg_ptr, column_num);
         arg1 = va_arg (arg_ptr, long);
         arg2 = va_arg (arg_ptr, long);
         arg3 = va_arg (arg_ptr, long);
         arg4 = va_arg (arg_ptr, long);
         va_end (arg_ptr);
         output_msg (glb_line_num, msg_num, msg_severity,  /*PRINTMSG */
                         column_num, arg1, arg2, arg3, arg4);

         if (!error                                         &&
             curr_stmt_sh_idx > NULL_IDX                    && 
             curr_stmt_sh_idx <= sh_tbl_idx                 &&
             glb_line_num >= SH_GLB_LINE(curr_stmt_sh_idx)) {

            /* only set error flag if have statement header to set it on. */
            /* Since src_input delays issuing messages until the correct  */
            /* line is seen, there will be no header for this line if not */
            /* already created.                                           */

            /* Do not set if this is a forced error with -M option.       */

            SH_ERR_FLG(curr_stmt_sh_idx) = TRUE;
         }

         if (on_off_flags.abort_if_any_errors) {

            if (c_i_f != NULL) {
               flush_msg_file();
            }

            /* Put the option into the message as a string substitution       */
            /* because our Technology Partners might use a different option.  */

            output_msg (glb_line_num, 1226, Limit, 0, 0, 0, 0, 0);

            PRINT_GL_TBL;      /* Prints to dump_file ifdef _DEBUG and -u glt */


            /* Output a dummy Summary record signalling the abort because     */
            /* libcif has a very difficult time dealing with a "truncated"    */
            /* CIF.  The CIF must be reopened and c_i_f must be reset so that */
            /* cif_summary_rec will work.  The CIF was closed and c_i_f was   */
            /* set to NULL when flush_msg_file (just above) called            */
            /* print_buffered_messages.  It needs to be reset to NULL to      */
            /* signal to exit_compiler that the messages have been printed.   */

            c_i_f = fopen(cif_name, "a+");

            cif_summary_rec("Ignore this",
                            "Ignore this",
                            "Ignore this",
                            0,
                            0,
                            -1);                               /* Abort flag. */

            c_i_f = NULL;

	    exit_compiler(RC_USER_ERROR);
	 }

         if (on_off_flags.abort_on_100_errors  &&
             num_errors >= MAX_ERR_LIMIT) {

            if (c_i_f != NULL) {
               flush_msg_file();
            }

            output_msg(glb_line_num, 214, Limit, 0, MAX_ERR_LIMIT, 0, 0, 0);

            PRINT_GL_TBL;      /* Prints to dump_file ifdef _DEBUG and -u glt */


            /* Output a dummy Summary record signalling the abort because     */
            /* libcif has a very difficult time dealing with a "truncated"    */
            /* CIF.  The CIF must be reopened and c_i_f must be reset so that */
            /* cif_summary_rec will work.  The CIF was closed and c_i_f was   */
            /* set to NULL when flush_msg_file (just above) called            */
            /* print_buffered_messages.  It needs to be reset to NULL to      */
            /* signal to exit_compiler that the messages have been printed.   */

            c_i_f = fopen(cif_name, "a+");

            cif_summary_rec("Ignore this",
                            "Ignore this",
                            "Ignore this",
                            0,
                            0,
                            -1);                               /* Abort flag. */

            c_i_f = NULL;

	    exit_compiler(RC_USER_ERROR);
	 }

	 break;


      case Log_Error:

         /* Log_Error is seperate from Error because we do not want to do     */
         /* most of the checks that are done in Error, like -ea.              */

         num_errors++;
         num_prog_unit_errors++;

         va_start (arg_ptr, column_num);
         arg1 = va_arg (arg_ptr, long);
         arg2 = va_arg (arg_ptr, long);
         arg3 = va_arg (arg_ptr, long);
         arg4 = va_arg (arg_ptr, long);
         va_end (arg_ptr);
         output_msg (glb_line_num, msg_num, msg_severity,  /*PRINTMSG */
                     column_num, arg1, arg2, arg3, arg4);

         /* VERY SPECIAL CASE:  If message 49 				      */
         /*								      */
         /*                Cannot open source file "%s". 		      */
         /*								      */
         /* is being issued, it means there is no source file so there is no  */
         /* information we can use to construct a valid message file.  So     */
         /* just dump the message file entirely so no other part of the       */
         /* compiler tries to do anything with it.			      */

         if (msg_num == 49) {
            fclose(cif_actual_file);
            remove(cif_name);
            c_i_f = NULL;
            cif_actual_file = NULL;
            fclose(cif_tmp_file);
            remove(cif_tmp_file_name);
            cif_tmp_file = NULL;
         }

         break;


      case Internal:
      case Limit:

         if (c_i_f != NULL) {
            flush_msg_file();
         }

         va_start (arg_ptr, column_num);
         arg1 = va_arg (arg_ptr, long);
         arg2 = va_arg (arg_ptr, long);
         arg3 = va_arg (arg_ptr, long);
         arg4 = va_arg (arg_ptr, long);
         va_end (arg_ptr);
         output_msg (glb_line_num, msg_num, msg_severity,  /*PRINTMSG */
	                 column_num, arg1, arg2, arg3, arg4);


         if (comp_phase == Cmdline_Parsing) {

            /* This message is found in commandline parsing before all */
            /* proper start up is done.  Just abort compilation here.  */

            exit_compiler(RC_INTERNAL_ERROR);
            break;
         }

         /* Output a dummy Summary record signalling the abort because libcif */
         /* has a very difficult time dealing with a "truncated" CIF.         */
         /* The CIF must be reopened and c_i_f must be reset so that          */
         /* cif_summary_rec will work.  The CIF was closed and c_i_f was set  */
         /* to NULL when flush_msg_file (just above) called print_buffered_   */
         /* _messages.  It needs to be reset to NULL to signal to             */
         /* exit_compiler that the messages have been printed.     	      */
      
         c_i_f = fopen(cif_name, "a+");

         cif_summary_rec("Ignore this", 
                         "Ignore this",
                         "Ignore this",
                         0,
                         0,
                         -2);                                  /* Abort flag. */

         c_i_f = NULL;


# ifdef _DEBUG

         /* Will dump tables, if cmdline option -u requests any dumps and */
         /* the dump calls have not been hit int p_driver.c yet.          */

         if (comp_phase < Pdg_Conversion) {
            PRINT_ALL_SYM_TBLS;
            PRINT_BLK_STK;
            PRINT_CMD_LINE_TBLS;
            PRINT_GL_TBL;
            PRINT_GN_TBL;

            while (curr_scp_idx != NULL_IDX) {
               PRINT_DBG_SYTB;
               PRINT_DBG_STMT;
               curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx);
            }

            if (dump_flags.mem_report) {
               free_tables();  /* See what the tables look at, at abort. */
            }
         }
# endif

# ifdef _DEBUG
# if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX)
         if (msg_severity == Internal) {
            TRBK ();	
         }
# endif
# endif

         /* Do not exit yet if the message has a 0 line number and it was     */
         /* produced by the front-end.					      */

         if (exit_now) {
            exit_compiler(RC_INTERNAL_ERROR);
         }

         break;


      case Log_Warning:

         if (GET_MESSAGE_TBL(message_suppress_tbl, msg_num)) {
            break;
         }

         num_warnings++;

         va_start (arg_ptr, column_num);
         arg1 = va_arg (arg_ptr, long);
         arg2 = va_arg (arg_ptr, long);
         arg3 = va_arg (arg_ptr, long);
         arg4 = va_arg (arg_ptr, long);
         va_end (arg_ptr);
         output_msg (glb_line_num, msg_num, msg_severity,  /*PRINTMSG */
                         column_num, arg1, arg2, arg3, arg4);
         break;


      case Log_Summary:

         if (GET_MESSAGE_TBL(message_suppress_tbl, msg_num)) {
            break;
         }

         va_start (arg_ptr, column_num);
         arg1 = va_arg (arg_ptr, long);
         arg2 = va_arg (arg_ptr, long);
         arg3 = va_arg (arg_ptr, long);
         arg4 = va_arg (arg_ptr, long);
         va_end (arg_ptr);
         output_msg (glb_line_num, msg_num, msg_severity,  /*PRINTMSG */
                         column_num, arg1, arg2, arg3, arg4);
         break;


      case Vector:
      case Scalar:
      case Table:
      case Inline:
      case Info:
      case Tasking:
      case Optimization:
      case Stream:

         if (GET_MESSAGE_TBL(message_suppress_tbl, msg_num)) {
            break;
         }

         num_optz_msgs++;
         
         if ((cif_flags & MESSAGE_RECS) || opt_flags.msgs) {
            va_start (arg_ptr, column_num);
            arg1 = va_arg (arg_ptr, long);
            arg2 = va_arg (arg_ptr, long);
            arg3 = va_arg (arg_ptr, long);
            arg4 = va_arg (arg_ptr, long);
            va_end (arg_ptr);
            output_msg (glb_line_num, 
                        msg_num,
                        msg_severity,
                        column_num,
                        arg1,
                        arg2,
                        arg3,
                        arg4);
         }

         break;


      default:   /* Invalid message severity */
         PRINTMSG (glb_line_num, 2, Internal, 0, msg_severity);
         break;
   }  /* switch */


   /* If the message had a 0 line number and the message was produced by the  */
   /* front-end, complain about the 0 line number.			      */

   if (! exit_now) {
      exit_now = TRUE;
      PRINTMSG (glb_line_num, 296, Internal, 0, msg_num, 0);
   }

# if defined(_DEBUG)
   if (issue_line_out_of_range_msg) {
      PRINTMSG (glb_line_num, 626, Internal, 0, "valid line number","PRINTMSG");
   }
# endif

   TRACE (Func_Exit, "PRINTMSG", NULL);

   return; 

}  /* PRINTMSG */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This routine is called by PRINTMSG.  It formats the message and	      *|
|*      outputs it to stderr.						      *|
|*									      *|
|* Input parameters:							      *|
|*	glb_line_num	 If non-zero:  Global line number of source; this     *|
|*			   number maps onto a line number within the current  *|
|*			   file.					      *|
|*			 If zero    :  Indicates that a message header should *|
|*			   should not be output.			      *|
|*	msg_num		 The message number of the text to be output. 	      *|
|*	msg_severity	 The severity level.				      *|
|*	column_num       If non-zero:  Column is put into the header.         *|
|*			 If zero    :  Column is not put into header.         *|
|*	arg1, arg2, 	 Four optional arguments that can be inserted into    *|
|*	arg3, arg4	 into the message text.				      *|
|*									      *|
|*			 Note: no validation check is made for missing or     *|
|*			       or extra arguments in the message text.  It is *|
|*			       up to the developer to insure that the same    *|
|*			       number of arguments passed to PRINTMSG are in  *|
|*			       the message text.	 		      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

/* This error number will be tested as a special case to avoid infinite
 * recursion that would occur due to printing an error while printing an
 * error. */
#define ERROR_ECHOING_SOURCE	995

void output_msg (int				glb_line_num,
        	 int				msg_num,
		 msg_severities_type		msg_severity, 
		 int				column_num, 
		 long				arg1,
		 long				arg2,
		 long				arg3,
		 long				arg4)

{
   	  int			 act_file_line;
   	  char		 	*act_file_name;
   	  char		 	 expanded_text[EXPANDED_MSG_SIZE];
   	  char		 	 final_text[FINAL_MSG_SIZE];
   	  int			 glb_idx;
   static int			 last_msg_idx			= NULL_IDX;
	  int			 msg_idx;
   	  char		 	 orig_text[ORIG_MSG_SIZE];
   	  char		  	 position_buff[MAX_HDR_SIZE];
	  boolean		 print_directly_to_stderr;
#ifdef KEY /* Bug 10177 */
          char                  *scoping_unit_name = 0;
#else /* KEY Bug 10177 */
          char                  *scoping_unit_name;
#endif /* KEY Bug 10177 */
   	  char		 	*text_ptr;
/*
   fprintf (stderr, "output_msg: line = %d, num = %d, severity = %d, col = %d\n",
            glb_line_num, msg_num, msg_severity, column_num);
   return;
*/
# if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX)
	  last_msg_queue_type	 msg_desc;
# endif


   TRACE (Func_Entry, "output_msg", NULL);

   if (comp_phase == Lex_Parsing) {

      /* See if message has already been issued. */

# if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX)
      msg_desc.msg_num	= msg_num;
      msg_desc.line_num	= glb_line_num;
      msg_desc.col_num	= column_num;
# endif

      for (msg_idx = 0; msg_idx < LAST_MSG_QUEUE_SIZE; msg_idx++) {

# if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX)
         if (*((long *) (&msg_desc)) == 
             *((long *) (&last_msg_queue[msg_idx]))){
            TRACE (Func_Exit, "output_msg", NULL);
            return;
         }
# else
         if (last_msg_queue[msg_idx].msg_num  == msg_num &&
             last_msg_queue[msg_idx].line_num == glb_line_num &&
             last_msg_queue[msg_idx].col_num  == column_num) {
            TRACE (Func_Exit, "output_msg", NULL);
            return;
         }
# endif
      }

      last_msg_queue[last_msg_idx].msg_num	= msg_num;
      last_msg_queue[last_msg_idx].line_num	= glb_line_num;
      last_msg_queue[last_msg_idx].col_num	= column_num;

      if (++last_msg_idx == LAST_MSG_QUEUE_SIZE) {
         last_msg_idx = NULL_IDX;
      }
   }


   /* The Syntax Pass depends on the messages coming out in the same order    */
   /* they were issued.  Since the sort routine used to sort messages by line,*/
   /* column, and message number has different internal algorithms on         */
   /* different architectures, we need to use the "relative order" field of   */
   /* the Message record to keep Syntax Pass messages in the intended order.  */

   if (comp_phase == Pass1_Parsing) {

      if (save_glb_line_num == glb_line_num  &&
          save_column_num == column_num) {
         ++relative_order;
      }
      else {
         save_glb_line_num = glb_line_num;
         save_column_num   = column_num;
         relative_order    = 1;
      }
   }
   else {
      relative_order = 0;
   }


   switch (msg_severity) {

      case Log_Warning:
      case Log_Error:
         print_directly_to_stderr = TRUE;
         sprintf (position_buff, "in command line"); 
         break;

      case Log_Summary:
         print_directly_to_stderr = TRUE;
         break;

      default:

         if (comp_phase == Cmdline_Parsing) {
            print_directly_to_stderr = TRUE;
            sprintf (position_buff, "in command line"); 
            break;
         }

         print_directly_to_stderr =

# ifdef _DEBUG
            dump_flags.std_err             ||
# endif
            (msg_severity == Internal  ||  msg_severity == Limit);

         if (print_directly_to_stderr) {

            /* Print source line and ^ before printing the message.	*/

            print_err_line(glb_line_num, column_num);
         }

#ifdef KEY /* Bug 7247 */
	 /* Error while printing error: print it now, while we're in the
	  * process of printing the error that provoked it. */
	 if (ERROR_ECHOING_SOURCE == msg_num) {
	   print_directly_to_stderr = TRUE;
	 }
#endif /* KEY Bug 7247 */

         GLOBAL_LINE_TO_FILE_LINE(glb_line_num, glb_idx, act_file_line);
         act_file_name = GL_FILE_NAME_PTR(glb_idx);

         if (scp_tbl == NULL_IDX) {
            scoping_unit_name = program_unit_name;

            /* Error condition exists before init_parser has been       */
            /* invoked or the tables have already been freed.           */

            if (print_directly_to_stderr) {
               sprintf (position_buff, "%s, File = %s, Line = %d ",
                        program_unit_name,
                        act_file_name,
                        act_file_line);
            }
         }
         else {
            scoping_unit_name = AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx));

            if (print_directly_to_stderr) {

               if (column_num == 0) {
                  sprintf (position_buff, "%s, File = %s, Line = %d ",
                           AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)), 
                           act_file_name,
                           act_file_line);
               }
               else {
                  sprintf (position_buff,
                           "%s, File = %s, Line = %d, Column = %d ",
                           AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)), 
                           act_file_name,
                           act_file_line,
                           column_num);
               }
            }
         }

   }  /* End switch */


   text_ptr = (char *) catgetmsg(msg_sys,
                                 NL_MSGSET,
                                 msg_num,
                                 orig_text,
                                 ORIG_MSG_SIZE);
	     
   if (!*text_ptr) {	/* Unable to retrieve message. */

      if (msg_num == 3) {

         /* The message catalog must really be messed up, because we cannot   */
         /* find the message that says we cannot find the message.  fprintf   */
         /* to stderr and abort compilation.  If the driver provided the      */
         /* message file, get rid of it so the driver won't get confused.     */
         /* exit_compiler will handle the rest.				      */
         /* 								      */
         /* LRR   4/10/97						      */
         /* SPRs 704082 and 700504 complained about message 3 being issued    */
         /* when the compiler ran out of memory and not giving the user a     */
         /* clue as to what happened.  I enhanced message 3 to give users     */
         /* more of a clue as to what could possibly have happened and then   */
         /* added the specific check later for the "out of memory" case.      */

# if defined(_HOST_OS_LINUX) || defined(_HOST_OS_DARWIN)
         fprintf(stderr, PSC_NAME_PREFIX "f95 INTERNAL: "
#else       
         fprintf(stderr, "cft90 INTERNAL: "
#endif
                         "Message system failed trying to issue message %ld\n",
                         arg1);
         fprintf(stderr, "  Possible reasons include:\n");
         fprintf(stderr, "   * The message catalog has been corrupted.\n");
         fprintf(stderr, "   * The message catalog is out of date or "
                         "does not match the compiler release.\n");

         if (c_i_f != NULL  &&  (cif_C_opts & CMD_PROVIDED_CIF)) {
            fclose(cif_actual_file);
            cif_actual_file = NULL;
            remove(cif_name);
         }

         exit_compiler(RC_USER_ERROR);
      }

      /* LRR   4/22/97                                                        */
      /* SPRs 704082 and 700504 complained about message 3 being issued when  */
      /* the compiler ran out of memory and not giving the user a clue as to  */
      /* what happened.  Jeff Drummond and Brian Forney implemented error     */
      /* codes and the entry points to retrieve them but only in UNICOS 9.2   */
      /* and later.  Because Jon and other SL's decided they wanted to use    */
      /* the entry points, MWM changed the build script to copy nl_types.h to */
      /* the local build directory so that we can build for releases prior to */
      /* 9.2.								      */
      /* The code below currently only checks for the "out of memory" case.   */
      /* If, in the future, someone really wants to get fancy with this, then */
      /* the "if" should be changed to a "switch" on the codes returned from  */
      /* __catgetmsg_error_code().					      */

# if !(defined(_HOST_OS_LINUX) || defined(_HOST_OS_DARWIN))

      if (__catgetmsg_error_code() == NL_ERR_MALLOC) {
         fprintf(stderr, "cft90 INTERNAL: "
                         "Message system failed trying to issue message %d\n",
                         msg_num);
         fprintf(stderr, "  User memory space has been exhausted - the "
                         "message system has no space in which to work.\n");

         if (c_i_f != NULL  &&  (cif_C_opts & CMD_PROVIDED_CIF)) {
            fclose(cif_actual_file);
            cif_actual_file = NULL;
            remove(cif_name);
         }

         exit_compiler(RC_USER_ERROR);
      }
      else {
         PRINTMSG (glb_line_num, 3, Internal, 0, msg_num); 
      }
# else
      PRINTMSG (glb_line_num, 3, Internal, 0, msg_num); 
# endif
   }

   if (print_directly_to_stderr) {

      /* Expand optional arguments, if any, into the message text.  	      */

#ifdef KEY /* Bug 4469 */
      snprintf (expanded_text, sizeof expanded_text, orig_text, arg1, arg2,
        arg3, arg4);
#else
      sprintf (expanded_text, orig_text, arg1, arg2, arg3, arg4);
#endif /* KEY Bug 4469 */
   }


   /* Format and output the message header and text (unless the message is */
   /* type Log_Summary; then just output the message text).                */

   if (msg_severity != Log_Summary) {

      if (print_directly_to_stderr) {
         text_ptr = expanded_text;
         catmsgfmt (command_name,
                    message_prefix,
                    msg_num, 
                    msg_severity_name[msg_severity],
                    text_ptr,
                    final_text,
                    FINAL_MSG_SIZE,
                    position_buff,
                    (char *) NULL);
         fputs (final_text, stderr);
#ifdef KEY /* Bug 6673 */
	 if (verbose_message) {
	   verbose_message(group_code, msg_num);
	 }
#endif /* KEY Bug 6673 */
      }
   }
   else {
      fputs (expanded_text, stderr);
      fputc (NEWLINE, stderr);
   }

   if (msg_severity != Log_Warning  &&
       msg_severity != Log_Error    &&
       msg_severity != Log_Summary  &&
       msg_severity != Internal     &&
#ifdef KEY /* Bug 7247 */
       /* Error while printing error: don't recurse */
       msg_num != ERROR_ECHOING_SOURCE &&
#endif /* KEY Bug 7247 */
       msg_severity != Limit) {
      cif_message_rec(msg_num,
                      glb_line_num,
                      column_num,
                      msg_severity,
                      orig_text,
                      arg1,
                      arg2,
                      arg3,
                      arg4,
                      scoping_unit_name,
                      relative_order);
   }

   TRACE (Func_Exit, "output_msg", NULL);

   return;

}  /* output_msg */ 


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Routine that closes necessary files and exits from the compiler	      *|
|*									      *|
|* Input parameters:							      *|
|*	Number that is output with exit					      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void exit_compiler (int		code)

{

   TRACE (Func_Entry, "exit_compiler", NULL);

   if (cif_tmp_file != NULL  &&  c_i_f == cif_tmp_file) {
      flush_msg_file();
   }

   if (c_i_f != NULL) {
      print_buffered_messages();
   }

   if (cif_actual_file) {
      fclose(cif_actual_file);
   }

   if (cif_flags == 0) {
      remove(cif_name);
   }

   catclose (msg_sys);

   clean_up_module_files();

   if (cif_flags != 0) {
      close_cif();
   }


# ifdef _DEBUG

# if defined(_HOST_OS_SOLARIS) || (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX) || defined(_HOST_OS_DARWIN))

   /* Abort if this is a Limit or an Internal error.			      */

   if (code == RC_INTERNAL_ERROR) {
      abort();
   }

# endif

# endif

   exit (code);

   TRACE (Func_Exit, "exit_compiler", NULL);

}  /* exit_compiler */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Routine that finds the file to which a line belongs.  This is needed  *|
|*      for SPARCs.						     	      *|
|*									      *|
|* Input parameters:							      *|
|*	search_line : the global line number				      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

char *global_to_local_file (int search_line)
{
   int		 idx;
   int  	 line;
   char		*act_file_name;


   TRACE (Func_Entry, "global_to_local_file", NULL);

   GLOBAL_LINE_TO_FILE_LINE(search_line, idx, line);
   act_file_name = GL_FILE_NAME_PTR(idx);

   TRACE (Func_Exit, "global_to_local_file", NULL);

   return(act_file_name);

}  /* global_to_local_file */



/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Routine that finds the path to which a global line belongs.           *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      search_line : the global line number                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

char *global_to_local_path (int search_line)
{
   int           idx;
   int           line;
   char         *act_path_name;


   TRACE (Func_Entry, "global_to_local_path", NULL);

   GLOBAL_LINE_TO_FILE_LINE(search_line, idx, line);
   act_path_name = GL_PATH_NAME_PTR(idx);

   TRACE (Func_Exit, "global_to_local_path", NULL);

   return(act_path_name);

}  /* global_to_local_path */





/******************************************************************************\
|*									      *|
|*	   * * *   THE FRONTEND DOES NOT USE THIS ROUTINE.   * * *            *|
|*									      *|
|* Description:								      *|
|*	Routine that finds a CIF file id for a file containing a given        *|
|*      global line number.						      *|
|*									      *|
|* Input parameters:							      *|
|*	search_line : the global line number				      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	The CIF file id.						      *|
|*									      *|
\******************************************************************************/

int global_to_file_id (int	search_line)
{
   int		 idx;
   int  	 line;


   TRACE (Func_Entry, "global_to_file_id", NULL);

   GLOBAL_LINE_TO_FILE_LINE(search_line, idx, line);

   TRACE (Func_Exit, "global_to_file_id", NULL);

   return(GL_CIF_FILE_ID(idx));

}  /* global_to_file_id */


/******************************************************************************\
|*									      *|
|*	   * * *   THE FRONTEND DOES NOT USE THIS ROUTINE.   * * *            *|
|*									      *|
|* Description:								      *|
|*	This routine converts a global line number to a file line number.     *|
|*	It is called by PDGCS to convert the global line for inserts in       *|
|*	optimization messages.  It is called by CCG for line numbers for      *|
|*	CAL listings and the traceback.                                       *|
|*									      *|
|* Input parameters:							      *|
|*	search_line : a global line number 				      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	The file line number.						      *|
|*									      *|
\******************************************************************************/

int global_to_file_line_number (int	search_line)
{
   int	idx;
   int	line;


   TRACE (Func_Entry, "global_to_file_line_number", NULL);

   GLOBAL_LINE_TO_FILE_LINE(search_line, idx, line);

   TRACE (Func_Exit, "global_to_file_line_number", NULL);

   return(line);

}  /* global_to_file_line_number */


/******************************************************************************\
|*									      *|
|*	   * * *   THE FRONTEND DOES NOT USE THIS ROUTINE.   * * *            *|
|*									      *|
|* Description:								      *|
|*	This routine converts a global line number to a file line number.     *|
|*	It is called by PDGCS and code-gen routines that need to convert the  *|
|*	global line number for optional arguments to PRINTMSG.		      *|
|*									      *|
|*      This is simply a different name for global_to_file_line_number.       *|
|*									      *|
|* Input parameters:							      *|
|*	search_line : a global line number				      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	The file line number.						      *|
|*									      *|
\******************************************************************************/

int global_to_local_line_number (int	search_line)
{
   int	idx;
   int	line;


   TRACE (Func_Entry, "global_to_local_line_number", NULL);

   GLOBAL_LINE_TO_FILE_LINE(search_line, idx, line);

   TRACE (Func_Exit, "global_to_local_line_number", NULL);

   return(line);

}  /* global_to_local_line_number */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      The compiler has encountered a condition where it must terminate the  *|
|*      the compilation.  Output all the messages that have been sent to the  *|
|*      message file first.                                                   *|
|*									      *|
|* Input parameters:							      *|
|*      NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*      NONE								      *|
|*									      *|
|* Returns:								      *|
|*      NOTHING								      *|
|*									      *|
\******************************************************************************/

static void flush_msg_file(void)
{
   int        scp_idx;


   TRACE (Func_Entry, "flush_msg_file", NULL);

   if (c_i_f == cif_tmp_file) {
      cif_fake_a_unit();
   }

   if (last_msg_file_rec != END_UNIT) {

      if (curr_scp_idx == 0) {
         cif_end_unit_rec(program_unit_name);
      }
      else {
         scp_idx = curr_scp_idx;

         while (SCP_PARENT_IDX(scp_idx) != 0) {
            scp_idx = SCP_PARENT_IDX(scp_idx);
         }

         cif_end_unit_rec(AT_OBJ_NAME_PTR(SCP_ATTR_IDX(scp_idx)));
      }
   }

   print_buffered_messages();

   TRACE (Func_Exit, "flush_msg_file", NULL);

   return;

}  /* flush_msg_file */

#ifdef KEY /* Bug 7247 */

/* The error message machinery tries very hard to echo the source line
 * before it prints the message itself. But it's possible that a "#" line
 * in a .i file mentions a file which doesn't exist any more, or which has
 * been changed in such a way that we encounter an EOF when we try to find
 * the source line. Whenever something prevents us from recovering the
 * source line, we want to give a warning, omit the printing of the source
 * line, and then print the underlying error message anyway.
 */

static void
cannot_open_include_file(int line_num)
{
  PRINTMSG(line_num, ERROR_ECHOING_SOURCE, Warning, 0,
    "cannot open INCLUDE file");
}

static void
files_too_deeply_nested(int line_num)
{
  PRINTMSG(line_num, ERROR_ECHOING_SOURCE, Warning, 0,
    "source files too deeply nested");
}

static void
cannot_read_source_file(int line_num)
{
  PRINTMSG(line_num, ERROR_ECHOING_SOURCE, Warning, 0,
    "cannot read source file");
}
#endif /* KEY Bug 7247 */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Print the message file.                                               *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void print_buffered_messages(void)
{


#  define	 FILE_STK_MAX	     500    /* Just make something up.	      */
#ifdef KEY /* Bug 3632 */
#else
#  define	 MAX_SRC_LINE_SIZE   256    /* Stolen from src_input.m        */
#endif /* KEY Bug 3632 */

   char		 carat[MAX_SRC_LINE_SIZE];
   char		 expanded_text[EXPANDED_MSG_SIZE];
   int        	 fd;
   int		 file_line;
   char          final_text[FINAL_MSG_SIZE];
   int		 global_idx;
   int		 i;
   int		 line_num;
   nl_catd	 message_catalog;
   char          message_hdr[MAX_HDR_SIZE];
   int		 msg_idx;
   char         *msg_insert;
   int		 my_file_id;
   int		 num_msgs;
   int		 num_recs;
   char    	 orig_text[ORIG_MSG_SIZE];
   int		 rec_type;
   int		 search_idx;
   char		 source_line[MAX_SRC_LINE_SIZE];
   int		 stk_idx;
   int		 unit_idx;

   struct        file_stk_frame	{int	file_id;
			 	 int	file_line;
			 	 FILE  *file_ptr;
               			};

   typedef  struct  file_stk_frame	file_stk_type;

   file_stk_type file_stk[FILE_STK_MAX];


   struct	 Cif_filedir	*filedir;
   struct	 Cif_unitdir	*unitdir;

   struct	 Cif_cifhdr	*header_rec;
   struct	 Cif_file	*file_rec;
   struct	 Cif_message	*message_rec;


# ifdef _DEBUG

   int		 		dbg_global_line;
   struct	 Cif_message	dbg_message_rec;

# endif


   TRACE (Func_Entry, "print_buffered_messages", NULL);

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

   stk_idx = 0;


   num_msgs = num_ansi  + num_cautions + num_comments + num_errors +
              num_notes + num_warnings;

   if (opt_flags.msgs) {
      num_msgs += num_optz_msgs;
   }


   /* It is possible for num_msgs to be nonzero but also have no messages in  */
   /* in the message file.  This happens when a Log_ message is the only kind */
   /* of message issued (they are counted in num_errors and num_warnings).    */
   /* One of the cases where this can happen is when the compiler is asked to */
   /* compile a file that does not exist.  The next check weeds this case out.*/
   /* If it's not this particular case, we'll just exercise the code in this  */
   /* procedure up to the point it figures out there are no Message records   */
   /* in the file and then it'll just exit.                                   */

   if (global_line_tbl_idx == 0) {
      goto EXIT;
   }


# ifdef _DEBUG

   if (dump_flags.std_err) {
      TRACE (Func_Exit, "print_buffered_messages", NULL);
      return;
   }

   if (num_msgs == 0) {

      if (dump_flags.stmt_dmp) {
         dbg_global_line    = 1;
         message_rec        = &dbg_message_rec;
         message_rec->uline = GL_GLOBAL_LINE(global_line_tbl_idx) + 1;
         goto INIT_FILE_STK;
      }
      else {
         goto EXIT;
      }
   }

# else

   if (num_msgs == 0) {
      goto EXIT;
   }

# endif


   /* Convert the ASCII CIF to the more efficient binary form and open the    */
   /* binary form of the CIF.  The last argument to Cif_Cifconv being FALSE   */
   /* means that the binary output file will be deleted by Cif_Close.         */
   /* DEBUG note:  When a scoping unit has problems to the point that         */
   /* SCP_IN_ERR is set to TRUE, we set a field in the CIF Summary record to  */
   /* -3 to indicate that the CIF is incomplete.  However, Cif_Cifconv does   */
   /* not read to the end of the CIF first to read the Summary record, so it  */
   /* will likely print out a bunch of messages complaining about sym id's    */
   /* not being resolved.  The 0x100 flag allows these messages to come out   */
   /* (in a debug compiler); if this flag is FALSE, it tells Cif_Cifconv not  */
   /* to print them.							      */
  
#ifdef _DEBUG

   fd = Cif_Cifconv(cif_name,
                    "r",
                    NULL,
                    CIF_VERSION,
                    0x100);

#else

   fd = Cif_Cifconv(cif_name,
                    "r",
                    NULL,
                    CIF_VERSION,
                    FALSE);

#endif


   if (fd < 0) {
      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);
      c_i_f = NULL;
      remove(cif_name);
      fclose(cif_tmp_file);
      remove(cif_tmp_file_name);
      PRINTMSG(1, 1060, Internal, 0, Cif_Errstring(fd));
   }


   /* Set up the memory management and get the initial records.		      */

   Cif_Memmode(fd, CIF_MEM_MANAGED);

   rec_type = Cif_Getrecord(fd, (struct Cif_generic **) &header_rec);

   if (rec_type != CIF_CIFHDR) {
      line_num = 1;
      msg_insert = "first rec is not hdr rec.";
      goto EMERGENCY_EXIT;
   }

#if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
  if (getenv("NLSPATH") == NULL) {
    /* NLSPATH is not set. */
    const char * const toolroot = getenv("TOOLROOT");
    const char * const env_name = "NLSPATH=";
    const char * const env_val = "/usr/lib/locale/C/LC_MESSAGES/%N.cat";
    int len = strlen(env_name) + strlen(env_val) + 1;
    char * new_env;
    if (toolroot != NULL) len += strlen(toolroot);
    new_env = malloc(len);
    if (toolroot == NULL)
      sprintf(new_env, "%s%s", env_name, env_val);
    else
      sprintf(new_env, "%s%s%s", env_name, toolroot, env_val);
    putenv(new_env);
    free(new_env);
  }
#endif

   message_catalog = catopen(header_rec->group, 0);

   Cif_Getfiledir(fd, &filedir);


   /* File Name records are grouped outside of the Unit records.              */

   Cif_Recgroup(fd, 
                NULL,                  
                CIF_FILE,
                (struct Cif_generic **) &file_rec);


   /* Initialize the first file stack frame with the information about the    */
   /* source file.							      */

INIT_FILE_STK:

   global_idx            = 1;

   file_stk[0].file_id   = GL_CIF_FILE_ID(1);
   file_stk[0].file_line = 0;

   if ((file_stk[0].file_ptr = fopen(GL_FILE_NAME_PTR(1), "r")) == NULL) {
      line_num = 1;
#ifdef KEY /* Bug 7247 */
      cannot_read_source_file(line_num);
#else /* KEY Bug 7247 */
      msg_insert = "can not open source file.";
      goto EMERGENCY_EXIT;
#endif /* KEY Bug 7247 */
   }
         

# ifdef _DEBUG

   if (dump_flags.stmt_dmp  &&  num_msgs == 0) {
      goto NO_MSGS_STMT_DUMP;
   }

# endif
      

   /* Go through all the Unitdir records in order to process the messages     */
   /* associated with each program unit.				      */

   for (unit_idx = 0;  unit_idx < filedir->nunits;  ++unit_idx) {

      Cif_Getunitdir(fd, &filedir->ut[unit_idx], &unitdir);

      num_recs = Cif_Recgroup(fd,
                              unitdir,
                              CIF_MESSAGE,
                              (struct Cif_generic **) &message_rec);

      /* Sort the records by global line and column. 			      */
      /* Note:  Any Message records that precede the first Unit record are    */
      /*        included with the first unit by Cif_Cifconv.                  */

      if (num_recs > 1) {
         (void) qsort ( (char *) message_rec,
                        num_recs,
                        sizeof(struct Cif_message),
                       &compare_message_recs);
      }


      /* Go through all the Message records associated with this program      */
      /* unit.								      */

      for (msg_idx = 0;  msg_idx < num_recs;  ++msg_idx) {

         if ((message_rec->severity == Vector   ||
              message_rec->severity == Scalar   ||
              message_rec->severity == Table    ||
              message_rec->severity == Inline   ||
              message_rec->severity == Info     ||
              message_rec->severity == Tasking  ||
              message_rec->severity == Stream   ||
              message_rec->severity == Optimization)  && 
             ! opt_flags.msgs) {
            ++message_rec;
            continue;
         }

# ifdef _DEBUG

         if (dump_flags.stmt_dmp) {
            goto CHECK_GL_IDX;
         }

# endif
         /* KAY - file_line is set in macro but never used.  Bug???? */

         GLOBAL_LINE_TO_FILE_LINE(message_rec->uline,
				  global_idx,
				  file_line);       
         my_file_id = GL_CIF_FILE_ID(global_idx);

         if (my_file_id != file_stk[stk_idx].file_id) {

            for (search_idx = stk_idx - 1;  search_idx >= 0;  --search_idx) {
           
               if (my_file_id == file_stk[search_idx].file_id) {

#ifdef KEY /* Bug 7247 */
                  for (; stk_idx != search_idx; stk_idx -= 1) {
                    if (NULL != file_stk[stk_idx].file_ptr) {
		      fclose(file_stk[stk_idx].file_ptr);
		    }
		  }
#else /* KEY Bug 7247 */
                  while (stk_idx != search_idx) {
                     fclose(file_stk[stk_idx--].file_ptr);
                  }
#endif /* KEY Bug 7247 */

                  goto HAVE_FILE;
               }
            }

            ++stk_idx;

            if (stk_idx < FILE_STK_MAX) {
               file_stk[stk_idx].file_id = my_file_id;

               for (i = 2;  i < filedir->nfiles;  ++i) {

                  if (file_rec[i].fid == my_file_id) {
                     break;
                  }
               }

               if ((file_stk[stk_idx].file_ptr =
                       fopen(file_rec[i].name, "r")) != NULL) { 
                  file_stk[stk_idx].file_line = 0;
               }
               else {
                  line_num = message_rec->uline;
#ifdef KEY /* Bug 7247 */
		  cannot_open_include_file(line_num);
		  goto JUST_PRINT_MESSAGE;
#else /* KEY Bug 7247 */
                  msg_insert = "can not open INCLUDE file.";
                  goto EMERGENCY_EXIT;
#endif /* KEY Bug 7247 */
               }
            }
            else {
               line_num = message_rec->uline;
#ifdef KEY /* Bug 7247 */
	       files_too_deeply_nested(line_num);
	       goto JUST_PRINT_MESSAGE;
#else /* KEY Bug 7247 */
               msg_insert = "file_stk size exceeded.";
               goto EMERGENCY_EXIT;
#endif /* KEY Bug 7247 */
            }
         }

# ifdef _DEBUG

CHECK_GL_IDX:

         if (global_idx < global_line_tbl_idx) {
        
            if (message_rec->uline >= GL_GLOBAL_LINE(global_idx + 1)) {

               while (dbg_global_line < GL_GLOBAL_LINE(global_idx + 1)) {

#ifdef KEY /* Bug 7247 */
                  if (NULL == file_stk[stk_idx].file_ptr) {
		     goto JUST_PRINT_MESSAGE;
		  }
#endif /* KEY Bug 7247 */
                  if (fgets(source_line,
                             MAX_SRC_LINE_SIZE,
                             file_stk[stk_idx].file_ptr) != NULL) {
                     ++dbg_global_line;
                     ++file_stk[stk_idx].file_line;
                     fprintf(stderr, "%s", source_line);
                  }
                  else {
                     line_num = dbg_global_line;
#ifdef KEY /* Bug 7247 */
                     cannot_read_source_file(line_num);
		     goto JUST_PRINT_MESSAGE;
#else /* KEY Bug 7247 */
                     msg_insert = "can not read source file.";
                     goto EMERGENCY_EXIT;
#endif /* KEY Bug 7247 */
                  }
               }

               ++global_idx;

               for (search_idx = stk_idx - 1;  search_idx >=0;  --search_idx) {
      
                  if (GL_CIF_FILE_ID(global_idx) ==
                         file_stk[search_idx].file_id) {

                     while (stk_idx != search_idx) {
                        fclose(file_stk[stk_idx--].file_ptr);
                     }
  
                     goto CHECK_GL_IDX;
                  }
               }

               ++stk_idx;

               if (stk_idx < FILE_STK_MAX) {
                  file_stk[stk_idx].file_id = GL_CIF_FILE_ID(global_idx);

                  for (i = 2;  i < filedir->nfiles;  ++i) {

                     if (file_rec[i].fid == file_stk[stk_idx].file_id) {
                        break;
                     }
                  }

                  if ((file_stk[stk_idx].file_ptr =
                          fopen(file_rec[i].name, "r")) != NULL) {
                     file_stk[stk_idx].file_line = 0;
                  }
                  else {
                     line_num = message_rec->uline;
#ifdef KEY /* Bug 7247 */
		     cannot_open_include_file(line_num);
		     goto JUST_PRINT_MESSAGE;
#else /* KEY Bug 7247 */
                     msg_insert = "can not open INCLUDE file.";
                     goto EMERGENCY_EXIT;
#endif /* KEY Bug 7247 */
                  }
               }
               else {
                  line_num = message_rec->uline;
#ifdef KEY /* Bug 7247 */
		  files_too_deeply_nested(line_num);
		  goto JUST_PRINT_MESSAGE;
#else /* KEY Bug 7247 */
                  msg_insert = "file_stk size exceeded.";
                  goto EMERGENCY_EXIT;
#endif /* KEY Bug 7247 */
               }

               goto CHECK_GL_IDX;
            }
         }

# endif /* _DEBUG */


         /* We have the file, now find the line within the file.              */
         /* If the message line number matches the file line number, we're    */
         /* done.  If the message line number is greater than the file line   */
         /* number and we're processing an INCLUDE file, then the user must   */
         /* have included the file more than once so rewind it and start over.*/
         /* If it's not an INCLUDE file, abort.				      */

HAVE_FILE:

#ifdef KEY /* Bug 7247 */
         if (NULL == file_stk[stk_idx].file_ptr) {
	   goto JUST_PRINT_MESSAGE;
	 }
#endif /* KEY Bug 7247 */

         if (file_stk[stk_idx].file_line != message_rec->fline) {

            if (file_stk[stk_idx].file_line > message_rec->fline  &&
                stk_idx > 0) {
               rewind(file_stk[stk_idx].file_ptr);
               file_stk[stk_idx].file_line = 0;
            }

            while (file_stk[stk_idx].file_line != message_rec->fline) {

               if (fgets(source_line,
                         MAX_SRC_LINE_SIZE,
                         file_stk[stk_idx].file_ptr) != NULL) {
                  ++file_stk[stk_idx].file_line;

# ifdef _DEBUG
                  if (dump_flags.stmt_dmp) {
                     fprintf(stderr, "%s", source_line);
                     ++dbg_global_line;
                  }
# endif

               }
               else {
                  line_num = message_rec->uline;
#ifdef KEY /* Bug 7247 */
                  cannot_read_source_file(line_num);
		  goto JUST_PRINT_MESSAGE;
#else /* KEY Bug 7247 */
                  sprintf(final_text, 
                         "hit EOF while trying to issue message %d at line %d.",
                         message_rec->msgno,
                         line_num);
                  msg_insert = final_text;
                  goto EMERGENCY_EXIT;
#endif /* KEY Bug 7247 */
               }
            }
   
            fprintf(stderr, "\n%s", source_line);
         }


         /* If a character position was given in the record, output the "^".  */
         /* The algorithm is pretty stupid.  It should be changed to just     */
         /* blank the line from 0 to (message_rec->cpos - 1) but because it   */
         /* was originally written to blank to the NULL character, it would   */
         /* really annoy Testing to change it now because every test that has */
         /* a message with a carat would have to have a new base because the  */
         /* carat line would have fewer blanks in it.  So the algorithm       */
         /* is this:  blank out the carat line to the same length as the      */
         /* source line.  If the character position is beyond that (this      */
         /* should only happen if the user did something like forget to close */
         /* a character string), then continue blanking to the character      */
         /* position.							      */
     
         if (message_rec->cpos != 0) {

            for (i = 0;  source_line[i] != '\0';  ++i) {
               carat[i] = (source_line[i] == '\t') ? '\t' : ' ';
            }

            for ( ;  i < message_rec->cpos;  ++i) {
               carat[i] = ' ';
            }

            carat[i]                     = '\0';
            carat[message_rec->cpos - 1] = '^';
            fprintf(stderr, "%s\n", carat);
         }

#ifdef KEY /* Bug 7247 */
/* Either we've finished echoing the source or we can't, so now it's time
 * to print the error message itself. */
JUST_PRINT_MESSAGE:
#endif /* KEY Bug 7247 */

         catgetmsg(message_catalog,
                   NL_MSGSET,
                   message_rec->msgno,
                   orig_text,
                   ORIG_MSG_SIZE);

         Cif_Msginsert(orig_text,
                       (struct Cif_generic *) message_rec,
                       expanded_text,
                       EXPANDED_MSG_SIZE);
            
         if (message_rec->cpos == 0) {
            sprintf(message_hdr, "%s, File = %s, Line = %d ",
                    message_rec->name,
                    GL_FILE_NAME_PTR(global_idx),
                    message_rec->fline);
         }
         else {
            sprintf(message_hdr, "%s, File = %s, Line = %d, Column = %d ",
                    message_rec->name,
                    GL_FILE_NAME_PTR(global_idx),
                    message_rec->fline,
                    message_rec->cpos);
         }

         catmsgfmt(command_name,
                   message_prefix,
                   message_rec->msgno,
                   msg_severity_name[message_rec->severity],
                   expanded_text,
                   final_text,
                   FINAL_MSG_SIZE,
                   message_hdr,
                   (char *) NULL);

         fputs(final_text, stderr);
#ifdef KEY /* Bug 6673 */
	 if (verbose_message) {
	   verbose_message(group_code, message_rec->msgno);
	 }
#endif /* KEY Bug 6673 */

# ifdef _DEBUG
         if (dump_flags.stmt_dmp) {
            fprintf(stderr, "\n");
         }
# endif

         ++message_rec;

      }  /* End Message record loop. */

   }  /* End Unitdir record loop. */


# ifdef _DEBUG

NO_MSGS_STMT_DUMP:

#ifdef KEY /* Bug 7247 */
   if (NULL == file_stk[stk_idx].file_ptr) {
     goto CLEANUP;
   }
#endif /* KEY Bug 7247 */
   if (dump_flags.stmt_dmp) {
   
CHECK_GL_IDX_AGAIN:

      if (global_idx < global_line_tbl_idx) {
        
         while (dbg_global_line < GL_GLOBAL_LINE(global_idx + 1)) {

            if (fgets(source_line,
                       MAX_SRC_LINE_SIZE,
                       file_stk[stk_idx].file_ptr) != NULL) {
               ++dbg_global_line;
               fprintf(stderr, "%s", source_line);
            }
            else {
               line_num = dbg_global_line;
#ifdef KEY /* Bug 7247 */
               cannot_read_source_file(line_num);
	       goto CLEANUP;
#else /* KEY Bug 7247 */
               msg_insert = "can not read source file.";
               goto EMERGENCY_EXIT;
#endif /* KEY Bug 7247 */
            }
         }

         ++global_idx;

         for (search_idx = stk_idx - 1;  search_idx >=0;  --search_idx) {
      
            if (GL_CIF_FILE_ID(global_idx) == file_stk[search_idx].file_id) {

               while (stk_idx != search_idx) {
                  fclose(file_stk[stk_idx--].file_ptr);
               }
  
               goto CHECK_GL_IDX_AGAIN;
            }
         }

         ++stk_idx;

         if (stk_idx < FILE_STK_MAX) {
            file_stk[stk_idx].file_id = GL_CIF_FILE_ID(global_idx);

            for (i = 2;  i < filedir->nfiles;  ++i) {

               if (file_rec[i].fid == file_stk[stk_idx].file_id) {
                  break;
               }
            }

            if ((file_stk[stk_idx].file_ptr =
                    fopen(file_rec[i].name, "r")) != NULL) {
               file_stk[stk_idx].file_line = 0;
            }
            else {
#ifdef KEY /* Bug 7247 */
	       cannot_open_include_file(message_rec->uline);
	       goto CLEANUP;
#else /* KEY Bug 7247 */
               line_num = message_rec->uline;
               msg_insert = "can not open INCLUDE file.";
               goto EMERGENCY_EXIT;
#endif /* KEY Bug 7247 */
            }
         }
         else {
#ifdef KEY /* Bug 7247 */
	    files_too_deeply_nested(message_rec->uline);
	    goto CLEANUP;
#else /* KEY Bug 7247 */
            line_num = message_rec->uline;
            msg_insert = "file_stk size exceeded.";
            goto EMERGENCY_EXIT;
#endif /* KEY Bug 7247 */
         }

         goto CHECK_GL_IDX_AGAIN;
      }

      while (feof(file_stk[0].file_ptr) == 0) {

         if (fgets(source_line,
                   MAX_SRC_LINE_SIZE,
                   file_stk[0].file_ptr) != NULL  && 
             feof(file_stk[0].file_ptr) == 0) {
            fprintf(stderr, "%s", source_line);
         }
      }
   }

# endif

#ifdef KEY /* Bug 7247 */
/* Here is some work we must perform even if we just encountered an error
 * while dumping source statements.  */
CLEANUP:
#endif /* KEY Bug 7247 */

   fprintf(stderr, "\n");


# ifdef _DEBUG

   if (num_msgs != 0) { 
      Cif_Close(fd, CIF_MEM_FREE);
   }

# else

   Cif_Close(fd, CIF_MEM_FREE);

# endif


#ifdef KEY /* Bug 7247 */
   for (; stk_idx >= 0; stk_idx -= 1) {
      if (NULL != file_stk[stk_idx].file_ptr) {
	fclose(file_stk[stk_idx].file_ptr);
      }
   }
#else /* KEY Bug 7247 */
   while (stk_idx >= 0) {
      fclose(file_stk[stk_idx--].file_ptr);
   }
#endif /* KEY Bug 7247 */

EXIT:
   
   /* Set c_i_f to NULL to indicate the messages have been output but DON'T   */
   /* close it or delete it yet because if the compilation is being           */
   /* terminated by an Internal or Limit error, we need to output a special   */
   /* Summary record yet.						      */

   c_i_f = NULL;


   fclose(cif_tmp_file);
   remove(cif_tmp_file_name);

   TRACE (Func_Exit, "print_buffered_messages", NULL);

   return;


EMERGENCY_EXIT:

   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);
   c_i_f = NULL;
   remove(cif_name);
   remove(cif_tmp_file_name);
   Cif_Close(fd, CIF_MEM_FREE);
   PRINTMSG(line_num, 995, Internal, 0, msg_insert);

} /*  print_buffered_messages */


/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      This is a compare routine for qsort to get the Message records        *|
|*      sorted in global line number then column number order.		      *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

static int compare_message_recs(const void	 *p1,
			        const void 	 *p2)
{
   register int result;
   register int order1;
   register int order2;


   TRACE (Func_Entry, "compare_message_recs", NULL);

   result = ((struct Cif_message *) p1)->uline -
            ((struct Cif_message *) p2)->uline; 

   if (result == 0) {
      result = ((struct Cif_message *) p1)->cpos -
               ((struct Cif_message *) p2)->cpos;


      /* If both the line number and column number are the same, use the      */
      /* relative order field if it is set to break the tie.  If it's not set,*/
      /* use the message number to break the tie to avoid different "same     */
      /* key" algorithms across platforms.  This presumes, of course, that    */
      /* there will (almost?) never be a case where the same message is       */
      /* issued for the same line and column.                                 */
      /* Careful!  The messages could come from different phases.             */

      if (result == 0) {
         order1 = ((struct Cif_message *) p1)->order;
         order2 = ((struct Cif_message *) p2)->order;

         if ( (order1 == order2)  ||  (order1 == 0)  ||  (order2 == 0) ) {
            result = ((struct Cif_message *) p1)->msgno -
                     ((struct Cif_message *) p2)->msgno;
         }
         else {
	    result = ((struct Cif_message *) p1)->order -
                     ((struct Cif_message *) p2)->order;
         }
      }
   }

   TRACE (Func_Exit, "compare_message_recs", NULL);

   return (result);

}  /* compare_message_recs */
# if defined(_USE_FOLD_DOT_f)

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

#define FOLD_ABORT fold_f_abort_

void FOLD_ABORT(int *oper)

{


   TRACE (Func_Entry, "fold_f_abort_", NULL);

#ifdef KEY /* Bug 4867 */
   /* Message 626 (which is used in a lot of other places) doesn't take an
    * integer argument; also, the caller fold_operator_ is schizoid and
    * sometimes passes a simple integer operator enum, while other times it
    * shifts and adds and packed several pieces of data into the integer. */
   PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
            "supported operator or type", "FOLD_OPERATION");
#else /* KEY Bug 4867 */
   PRINTMSG(stmt_start_line, 626, Internal, *oper,
            "supported operator or type", "FOLD_OPERATION");
#endif /* KEY Bug 4867 */

   TRACE (Func_Exit, "fold_f_abort_", NULL);

   return;

}  /* fold_f_abort_ */
# endif
#ifdef KEY /* Bug 5040 */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	For use in calls to PRINTMSG					      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	Return "Ansi" if -ansi is in effect, else "Warning"                   *|
|*									      *|
\******************************************************************************/
msg_severities_type
ansi_or_warning(void) {
  return on_off_flags.issue_ansi_messages ? Ansi : Warning ;
  }
#endif /* KEY Bug 5040 */
