/*

  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

*/


/* ====================================================================
 * ====================================================================
 *
 * Module: w2f_driver.c
 * $Revision$
 * $Date$
 * $Author$
 * $Source$
 *
 * Revision history:
 *  07-Oct-95 - Original Version
 *
 * Description:
 *
 *  Defines an interface for a DSO version of whirl2f, with facilities
 *  for translating a PU at a time or arbitrary subexpressions.
 *
 *  Note that before any of these routines can be called, general
 *  WHIRL accessor routine initiation must have occurred.  
 *  Furthermore, there is no longer any concept of a .B input file
 *  (although we assume there may be a .B input file-name), only a
 *  WN* input tree and SYMTABs.
 *
 * ====================================================================
 * ====================================================================
 */
#ifdef _KEEP_RCS_ID
/*REFERENCED*/
static char *rcs_id = "$Source$ $Revision$";
#endif

#include <sys/elf_whirl.h>  /* for WHIRL_REVISION */
#include <time.h>
#include <errno.h>          /* For sys_errlist */
#include "whirl2f_common.h" /* For defs.h, config.h, erglob.h, etc. */
#include "config_flist.h"   /* For FLIST command line parameters */
#include "config_list.h"    /* For List_Cite */
#include "w2cf_parentize.h" /* For W2CF_Parent_Map and W2FC_Parentize */
#include "file_util.h"      /* For Last_Pathname_Component */
#include "flags.h"          /* for OPTION_GROUP */
#include "timing.h"         /* Start/Stop Timer */
#include "wn_lower.h"       /* WN_lower() */

#include "const.h"          /* For FOR_ALL_CONSTANTS */
#include "PUinfo.h"
#include "st2f.h"
#include "wn2f.h"
#include "wn2f_stmt.h"

/* Avoid errors due to uses of "int" in stdio.h macros.
 */
#undef int


/* ====================================================================
 *
 * Local data and macros.
 *
 * ====================================================================
 */

/* Default extensions for input/outfile files: */
static const char *W2F_File_Extension[W2F_NUM_FILES] = 
{
   ".f",       /* Fortran input file */
   ".w2f.f",   /* Fortran output file */
   ".w2f.loc"  /* .loc output file */
};

/* CITE extensions for input/outfile files: */
static const char *W2F_Cite_Extension[W2F_NUM_FILES] = 
{
   ".c",	        /* original input file */
   "-after-lno.f",	/* transformed source */
   ".loc"	        /* .loc output file */
};

/* PROMPF extensions for input/outfile files: */
static const char *W2F_Prompf_Extension[W2F_NUM_FILES] = 
{
   ".c",	 /* original input file */
   ".m",	 /* transformed source */
   ".anl_srcpos" /* srcpos mapping (temporary) output file */
};

/* Get the right extension: */
#define W2F_Extension(i) \
	(W2F_Prompf_Emission? W2F_Prompf_Extension[i] : \
	 (List_Cite ? W2F_Cite_Extension[i] : W2F_File_Extension[i]))


/* statements that can be skipped in w2f translation
 */
#define W2F_MAX_SKIP_ITEMS 128
static W2CF_SKIP_ITEM Skip[W2F_MAX_SKIP_ITEMS+1];
static INT Next_Skip_Item = 0;


/* W2F status information */
static BOOL         W2F_Initialized = FALSE;
static BOOL         W2F_Outfile_Initialized = FALSE;
static FORMAT_KIND  W2F_Format_Kind = F77_TAB_FORMAT;
static WN2F_CONTEXT Global_Context = INIT_WN2F_CONTEXT;
static const char  *W2F_Progname = "";
static const char  *W2F_File_Name[W2F_NUM_FILES] = {NULL, NULL, NULL};
static BOOL         File_Is_Created[W2F_NUM_FILES] = {FALSE, FALSE, FALSE};
static MEM_POOL     W2F_Parent_Pool;

/* External data set through -FLIST command-line options */
FILE  *W2F_File[W2F_NUM_FILES] = {NULL, NULL, NULL};
BOOL   W2F_Enabled = TRUE;          /* Invoke W2F */
BOOL   W2F_Verbose = TRUE;          /* Show translation information */
BOOL   W2F_Old_F77 = FALSE;         /* Use macros for new intrinsics */
BOOL   W2F_Ansi_Format = FALSE;     /* Line-formatting to f77 standard */
BOOL   W2F_No_Pragmas = FALSE;      /* By default, emit pragmas */
BOOL   W2F_Emit_Prefetch = FALSE;   /* Emit comments for prefetches */
BOOL   W2F_Emit_All_Regions = FALSE;/* Emit cmplr-generated regions */
BOOL   W2F_Emit_Linedirs = FALSE;   /* Emit preproc line-directives */
BOOL   W2F_Emit_Nested_PUs = FALSE; /* Emit code for nested PUs */
BOOL   W2F_Emit_Frequency = FALSE;  /* Emit feedback frequency info */
BOOL   W2F_Emit_Cgtag = FALSE;      /* Emit codegen tags for loop */
BOOL   W2F_Emit_Pcf = FALSE;        /* Force Pcf pragmas wherever possible */
BOOL   W2F_Emit_Omp = FALSE;        /* Force OMP pragmas wherever possible */
INT32  W2F_Line_Length = 0;         /* 'zero' means: use the default */

/* External data set through the API or otherwise */
BOOL    W2F_Only_Mark_Loads = FALSE; /* Only mark, do not translate loads */
BOOL    WN2F_F90_pu = FALSE;        /* Global variable indicating F90 or F77 */
BOOL    W2F_Purple_Emission = FALSE; /* Emitting purple extracted sources */
BOOL    W2F_Prompf_Emission = FALSE; /* Emitting prompf transformed sources */
WN_MAP *W2F_Construct_Map = NULL;    /* Construct id mapping for prompf */
WN_MAP  W2F_Frequency_Map = WN_MAP_UNDEFINED; /* Frequency mapping */


/* ====================================================================
 *
 * Process_Filename_Options()
 *
 *    Once the command line is parsed, check for option interaction.
 *
 * Open_Read_File()
 *    Opens the file with the given name and path for reading.
 *
 * Open_Append_File()
 *
 *    Opens the file with the given name for appending more to its
 *    end if it already exists, or to create it if it does not
 *    already exist.
 *
 * Open_Create_File()
 *
 *    Same as Open_Append_File(), but a new file is always created,
 *    possibly overwriting an existing file.
 *
 * Close_File()
 *
 *    Closes the given file if different from NULL and not stdout or
 *    stderr.
 *
 * Open_W2f_Output_File()
 *
 *    Assuming that Process_Filename_Options() has been called, open
 *    the given kind of output file.  No effect if the file is already
 *    open, and the output will be appended to the output file if the
 *    file has already been created by this process.
 *
 * Close_W2f_Output_File()
 *
 *    If the file-pointer is non-NULL, we assume the file is open and
 *    close it.  Otherwise, this operation has no effect.
 *
 * ====================================================================
 */

static void 
Process_Filename_Options(const char *src_filename, const char *irb_filename)
{
   /* The name of the original source can be used to derive the 
    * names of the output .c and .h files when these are not 
    * explicitly provided.  If no original source file-name 
    * (-W2F:src_file) has been specified, then we assume the name
    * given by src_file_name, irb_file_name, or "anonymous.c".  
    * The -W2F:ftn_file name is derived from the resultant
    * -W2F:src_file, unless it is explicitly provided.
    *
    * Postcondition:
    *
    *   (W2F_File_Name[W2F_ORIG_FILE] != NULL) &&
    *   (W2F_File_Name[W2F_FTN_FILE] != NULL)
    */
   #define MAX_FNAME_LENGTH 256-7 /* allow for suffix ".w2f.f\0" */
   static char filename[MAX_FNAME_LENGTH+7];
   char       *fname;
   
   /* If we do not have an original source file name, then invent one */
   if (W2F_File_Name[W2F_ORIG_FILE] == NULL)
   {
      if (src_filename != NULL && src_filename[0] != '\0')
	 W2F_File_Name[W2F_ORIG_FILE] = src_filename;
      else if (irb_filename != NULL && irb_filename[0] != '\0')
	 W2F_File_Name[W2F_ORIG_FILE] = irb_filename;
      else
	 W2F_File_Name[W2F_ORIG_FILE] = "anonymous.f";
   }

   /* Copy the original file-name to a static buffer */
   if (strlen(W2F_File_Name[W2F_ORIG_FILE]) > MAX_FNAME_LENGTH)
   {
      W2F_File_Name[W2F_ORIG_FILE] = 
	 strncpy(filename, W2F_File_Name[W2F_ORIG_FILE], MAX_FNAME_LENGTH);
      filename[MAX_FNAME_LENGTH] = '\0';
      fprintf(stderr, 
	      "WARNING: src_file name truncated to (max=%d chars): \"%s\"\n",
	      MAX_FNAME_LENGTH, W2F_File_Name[W2F_ORIG_FILE]);
   }
   else
      W2F_File_Name[W2F_ORIG_FILE] =
	 strcpy(filename, W2F_File_Name[W2F_ORIG_FILE]);

   /* We want the output files to be created in the current directory,
    * so strip off any directory path, and substitute the suffix 
    * appropriately.
    */
   fname = Last_Pathname_Component(filename);
   if (W2F_File_Name[W2F_FTN_FILE] == NULL)
   {
      W2F_File_Name[W2F_FTN_FILE] = 
	 New_Extension(fname, W2F_Extension(W2F_FTN_FILE));
   }
   if (W2F_File_Name[W2F_LOC_FILE] == NULL)
   {
      if (List_Cite || W2F_Prompf_Emission)
      {
	 W2F_File_Name[W2F_LOC_FILE] =
	    New_Extension(fname, W2F_Extension(W2F_LOC_FILE));
      }
   }
} /* Process_Filename_Options */


static FILE *
Open_Read_File(const char *filename)
{
   FILE *f = NULL;

   /* Open the input file */
   if (filename == NULL || 
       (f = fopen(filename, "r")) == NULL)
   {
      ErrMsg(EC_IR_Open, filename, errno);
   }
   return f;
} /* Open_Read_File */


static FILE *
Open_Append_File(const char *filename)
{
   FILE *f = NULL;

   /* Open the input file */
   if (filename == NULL || 
       (f = fopen(filename, "a")) == NULL)
   {
      ErrMsg(EC_IR_Open, filename, errno);
   }
   return f;
} /* Open_Append_File */


static FILE *
Open_Create_File(const char *filename)
{
   FILE *f = NULL;

   /* Open the input file */
   if (filename == NULL || 
       (f = fopen(filename, "w")) == NULL)
   {
      ErrMsg(EC_IR_Open, filename, errno);
   }
   return f;
} /* Open_Create_File */


static void
Close_File(const char *filename, FILE *afile)
{
  if (afile != NULL             && 
      !Same_File(afile, stdout) && 
      !Same_File(afile, stderr) && 
      fclose(afile) != 0)
  {
     Set_Error_Line(ERROR_LINE_UNKNOWN); /* No line number for error */
     ErrMsg(EC_Src_Close, filename, errno);
  }
} /* Close_File */


static void 
Open_W2f_Output_File(W2F_FILE_KIND kind)
{
   if (W2F_File[kind] == NULL)
   {
      if (File_Is_Created[kind])
      {
	 W2F_File[kind] = Open_Append_File(W2F_File_Name[kind]);
      }
      else
      {
	 W2F_File[kind] = Open_Create_File(W2F_File_Name[kind]);
	 File_Is_Created[kind] = TRUE;
      }
   } /* if (!files_are_open) */
} /* Open_W2f_Output_File */


static void
Close_W2f_Output_File(W2F_FILE_KIND kind)
{
   Close_File(W2F_File_Name[kind], W2F_File[kind]);
   W2F_File[kind] = NULL;
} /* Close_W2f_Output_File */


/* ====================================================================
 * Begin_New_Location_File: should be called when we start processing
 *     a new file for which we want locations information.
 *
 * End_Locations_File: should be called when we end processing of
 *     a new file for which we want locations information.
 *
 * Continue_Locations_File: should be called for each PU translation 
 *     for which we want locations information.  After the PU
 *     translation we should call Close_W2f_Output_File(W2F_LOC_FILE).
 *
 * ==================================================================== 
 */

static void
Begin_New_Locations_File(void)
{
   /* This should only be called every time a new output file
    * is to be generated by whirl2f.  Note that we open and
    * close the file here, to make sure we only generate entries
    * in the location file when W2F_Outfile_Translate_Pu() is called!
    */
   if (W2F_File_Name[W2F_LOC_FILE] != NULL)
   {
      /* Need to do this before writing to a file for which a 
       * SRCPOS mapping should be maintained.
       */
      if (W2F_Prompf_Emission)
      {
	 Open_W2f_Output_File(W2F_LOC_FILE);
	 Write_String(W2F_File[W2F_LOC_FILE], NULL/* No srcpos map */,
		      "SRCPOS_MAP_BEGIN\n");
      }
      else
      {
	 Open_W2f_Output_File(W2F_LOC_FILE);
	 Write_String(W2F_File[W2F_LOC_FILE], NULL/* No srcpos map */,
		      "(SRCPOS-MAP\n");
      }
    }
} /* Begin_New_Locations_File */


static void
End_Locations_File(void)
{
   /* This should only be called every time we are done with *all*
    * location information for a file.
    */
   if (W2F_File_Name[W2F_LOC_FILE] != NULL)
   {
      /* Need to do this before writing to a file for which a 
       * SRCPOS mapping should be maintained.
       */
      if (W2F_Prompf_Emission)
      {
	 Open_W2f_Output_File(W2F_LOC_FILE);
	 Write_String(W2F_File[W2F_LOC_FILE],
		      NULL/* No srcpos map */,
		      "SRCPOS_MAP_END\n");
      }
      else
      {
	 Open_W2f_Output_File(W2F_LOC_FILE);
	 Write_String(W2F_File[W2F_LOC_FILE], NULL/* No srcpos map */, ")\n");
      }
      Terminate_Token_Buffer(W2F_File[W2F_LOC_FILE]);
      Close_W2f_Output_File(W2F_LOC_FILE);
   }
} /* End_Locations_File */


static void
Continue_Locations_File(void)
{
   /* Need to do this for every PU, i.e. every time 
    * W2F_Outfile_Translate_Pu() is called.
    */
   if (W2F_File_Name[W2F_LOC_FILE] != NULL)
   {
      Open_W2f_Output_File(W2F_LOC_FILE);
   }
} /* Continue_Locations_File */


static void
Move_Locations_To_Anl_File(const char *loc_fname)
{
#define MAX_ANL_FNAME_LENGTH 256-5 /* allow for suffix ".anl\0" */
   char        cbuf[MAX_ANL_FNAME_LENGTH+1];
   INT         i, next_ch;
   FILE       *anl_file;
   FILE       *loc_file;
   char       *anl_fname;
   static char fname[MAX_ANL_FNAME_LENGTH+5];

   strncpy(fname, loc_fname, MAX_ANL_FNAME_LENGTH);
   anl_fname = Last_Pathname_Component(fname);
   anl_fname = New_Extension(anl_fname, ".anl");
   anl_file = Open_Append_File(anl_fname);
   loc_file = Open_Read_File(loc_fname);

   next_ch = getc(loc_file);
   while (next_ch != EOF)
   {
      for (i = 0; (next_ch != EOF && i < MAX_ANL_FNAME_LENGTH); i++)
      {
	 cbuf[i] = next_ch;
	 next_ch = getc(loc_file);
      }
      if (i > 0)
      {
	 cbuf[i] = '\0';
	 fputs(cbuf, anl_file);
      }
   }
   Close_File(anl_fname, anl_file);
   Close_File(loc_fname, loc_file);
   remove(loc_fname);
} /* Move_Locations_To_Anl_File */


/* ====================================================================
 *                   Undo side-effects to the incoming WHIRL
 *                   ---------------------------------------
 *
 * W2F_Undo_Whirl_Side_Effects: This subroutine must be called after
 * every translation phase which may possibly create side-effects
 * in the incoming WHIRL tree.  The translation should thus become
 * side-effect free as far as concerns the incoming WHIRL tree.
 *
 * ==================================================================== 
 */

static void
W2F_Undo_Whirl_Side_Effects(void)
{
   Stab_Free_Tmpvars();
   Stab_Free_Namebufs();
}


/* ====================================================================
 *                   Setting up the global symbol table
 *                   ----------------------------------
 *
 * W2F_Enter_Global_Symtab: Enter the global symbols into the w2f
 * symbol table.  The global symbol-table should be the top-of the
 * stack at this point.
 *
 * ==================================================================== 
 */

// function object to enter FLD names in w2f symbol table. 
// See call in W2F_Enter_Global_Symbols

struct enter_fld
{
  void operator() (UINT32 ty_idx, const TY* typ) const 
    {

    TY & ty = (TY &) typ;

    if (TY_kind(ty) == KIND_STRUCT)
      {
	(void)W2CF_Symtab_Nameof_Ty(ty_idx);

	FLD_HANDLE fld = TY_flist(ty);
	FLD_ITER fld_iter = Make_fld_iter(fld);
	do
	  {
	    FLD_HANDLE fld_rt (fld_iter);
	    
	    if (TY_Is_Pointer(FLD_type(fld_rt)))
	      (void)W2CF_Symtab_Nameof_Fld_Pointee(fld);
	    (void)W2CF_Symtab_Nameof_Fld(fld);

	  } while (!FLD_last_field (fld_iter++)); 
      }
  }
} ;

// function object to enter fn & varbl names in w2f symbol table. 
// See call in W2F_Enter_Global_Symbols.

struct enter_st 
{
  void operator() (UINT32 idx, const ST * st) const 
    {
      if ((ST_sym_class(st) == CLASS_VAR && !ST_is_not_used(st)) || 
	   ST_sym_class(st) == CLASS_FUNC)
      {
	TY_IDX ty ;

	(void)W2CF_Symtab_Nameof_St(st);
	
	if (ST_sym_class(st) == CLASS_VAR)
	  ty = ST_type(st);
	else
	  ty = ST_pu_type(st);
	
	if (TY_Is_Pointer(ty))
	  (void)W2CF_Symtab_Nameof_St_Pointee(st);
      }
    }
};


static void
W2F_Enter_Global_Symbols(void)
{

   /* Enter_Sym_Info for every struct or class type in the current 
    * symbol table, with associated fields.  Do this prior to any
    * variable declarations, just to ensure that field names and
    * common block names retain their names to the extent this is
    * possible.
    */

   For_all(Ty_Table,enter_fld());

   /* Enter_Sym_Info for every variable and function in the current 
    * (global) symbol table.  Note that we always invent names for the
    * pointees of Fortran pointers, since the front-end invariably
    * does not generate ST entries for these.
    */

   For_all(St_Table,GLOBAL_SYMTAB,enter_st());

#if 0
   // FIX constants ??
   FOR_ALL_CONSTANTS(st, const_idx)
   {
      if (ST_symclass(st) != CLASS_SYM_CONST)
	(void)W2CF_Symtab_Nameof_St(st);
   }
#endif


} /* W2F_Enter_Global_Symbols */

/* =================================================================
 * Routines for checking correct calling order of excported routines
 * =================================================================
 */

static BOOL
Check_Outfile_Initialized(const char *caller_name)
{
   if (!W2F_Outfile_Initialized)
      fprintf(stderr, 
	      "NOTE: Ignored call to %s(); call W2F_Outfile_Init() first!\n",
	      caller_name);
   return W2F_Outfile_Initialized;
} /* Check_Outfile_Initialized */

static BOOL
Check_Initialized(const char *caller_name)
{
   if (!W2F_Initialized)
      fprintf(stderr, 
	      "NOTE: Ignored call to %s(); call W2F_Init() first!\n",
	      caller_name);
   return W2F_Initialized;
} /* Check_Initialized */

static BOOL
Check_PU_Pushed(const char *caller_name)
{
   if (PUinfo_current_func == NULL)
      fprintf(stderr, 
	      "NOTE: Ignored call to %s(); call W2F_Push_PU() first!\n",
	      caller_name);
   return (PUinfo_current_func != NULL);
} /* Check_PU_Pushed */


/* =================================================================
 *                 EXPORTED LOW-LEVEL W2F INTERFACE
 *                 --------------------------------
 *
 * See comments in w2f_driver.h
 *
 * =================================================================
 */

BOOL
W2F_Should_Emit_Nested_PUs(void)
{
   return W2F_Emit_Nested_PUs;
} /* W2F_Should_Emit_Nested_PUs */


void
W2F_Process_Command_Line (INT phase_argc, const char *phase_argv[],
			  INT argc, const char *argv[])
{
    /* Get the program name
     */
    if (argv[0] != NULL)
       W2F_Progname = argv[0];

    /* The processing of the FLIST group was moved out to the back-end.
     * Instead of directly using the Current_FLIST, we initiate
     * whirl2f specific variables to hold the values.
     */
    W2F_File_Name[W2F_ORIG_FILE] = FLIST_orig_filename;
    W2F_File_Name[W2F_FTN_FILE] = FLIST_ftn_filename;
    W2F_File_Name[W2F_LOC_FILE] = FLIST_loc_filename;
    W2F_Enabled = FLIST_enabled;
    W2F_Verbose = FLIST_verbose;
    W2F_Old_F77 = FLIST_old_f77;
    W2F_Ansi_Format = FLIST_ansi_format;
    W2F_No_Pragmas = FLIST_no_pragmas;
    W2F_Emit_Prefetch = FLIST_emit_prefetch;
    W2F_Emit_Linedirs = FLIST_emit_linedirs;
    W2F_Emit_All_Regions = FLIST_emit_all_regions;
    W2F_Emit_Nested_PUs = FLIST_emit_nested_pus;
    W2F_Emit_Frequency = FLIST_emit_frequency;
    W2F_Emit_Cgtag = FLIST_emit_cgtag;
    W2F_Emit_Pcf = FLIST_emit_pcf;
    W2F_Emit_Omp = FLIST_emit_omp;
    W2F_Line_Length = FLIST_line_length;

    Process_Filename_Options(Src_File_Name, Irb_File_Name);

    if (W2F_Ansi_Format)
       W2F_Format_Kind = F77_ANSI_FORMAT;
    else
       W2F_Format_Kind = F77_TAB_FORMAT;

} /* W2F_Process_Command_Line */


void
W2F_Init(void)
{
   const char * const caller_err_phase = Get_Error_Phase ();

   /* Initialize the various whirl2c subcomponents, unless they
    * are already initialized.
    */
   if (W2F_Initialized)
      return; /* Already initialized */

   Diag_Init();
   if (W2F_Progname != NULL)
      Diag_Set_Phase(W2F_Progname);
   else
      Diag_Set_Phase("FLIST");
   Diag_Set_Max_Diags(100); /* Maximum 100 warnings by default */

   /* Create a pool to hold the parent map for every PU, one at a time.
    */
   MEM_POOL_Initialize(&W2F_Parent_Pool, "W2f_Parent_Pool", FALSE);
   MEM_POOL_Push(&W2F_Parent_Pool);


   /* Always do this first!*/

   Initialize_Token_Buffer(W2F_Format_Kind, W2F_Prompf_Emission);
   if (W2F_Line_Length > 0)
      Set_Maximum_Linelength(W2F_Line_Length);

   /* Enter the global symbols into the symbol table, since that
    * ensures these get the first priority at keeping their names 
    * unchanged (note that a w2f invented name-suffix is added to 
    * disambiguate names).  Note that we can only emit 
    * declarations locally to PUs for Fortran, but we can still 
    * keep a global symbol-table for naming purposes.
    */
   Stab_initialize_flags();

   W2CF_Symtab_Push(); /* Push global (i.e. first ) symbol table */
   W2F_Enter_Global_Symbols();

   /* Initiate the various W2F modules.
    */
   reset_WN2F_CONTEXT(Global_Context);
   ST2F_initialize();
   PUinfo_initialize();
   WN2F_initialize();

   W2F_Initialized = TRUE;
   Diag_Set_Phase(caller_err_phase);
} /* W2F_Init */


void 
W2F_Push_PU(WN *pu, WN *body_part_of_interest)
{
   if (!Check_Initialized("W2F_Push_PU"))
      return;

   Is_True(WN_opcode(pu) == OPC_FUNC_ENTRY, 
	   ("Invalid opcode for W2F_Push_PU()"));

   Stab_initialize();
   Clear_w2fc_flags()  ;

   /* Set up the parent mapping
    */
   MEM_POOL_Push(&W2F_Parent_Pool);
   W2CF_Parent_Map = WN_MAP_Create(&W2F_Parent_Pool);
   W2CF_Parentize(pu);


   /* See if the body_part_of_interest has any part to be skipped
    * by the w2f translator.
    */
   if (WN_opc_operator(body_part_of_interest) == OPR_BLOCK)
   {
      Remove_Skips(body_part_of_interest, 
                   Skip,
                   &Next_Skip_Item,
                   W2F_MAX_SKIP_ITEMS,
                   FALSE /*Not C*/);
   }

   /* Get the current PU name and ST.
    */
   PUinfo_init_pu(pu, body_part_of_interest);
} /* W2F_Push_PU */


void 
W2F_Pop_PU(void)
{
   if (!Check_Initialized("W2F_Pop_PU") ||
       !Check_PU_Pushed("W2F_Pop_PU"))
      return;

   PUinfo_exit_pu();

   /* Restore any removed statement sequence
    */
   if (Next_Skip_Item > 0)
   {
      Restore_Skips(Skip, Next_Skip_Item, FALSE /*Not C*/);
      Next_Skip_Item = 0;
   }

   Stab_finalize();

   WN_MAP_Delete(W2CF_Parent_Map);
   W2CF_Parent_Map = WN_MAP_UNDEFINED;
   MEM_POOL_Pop(&W2F_Parent_Pool);

   W2F_Frequency_Map = WN_MAP_UNDEFINED;
} /* W2F_Pop_PU */


void
W2F_Mark_Loads(void)
{
   W2F_Only_Mark_Loads = TRUE;
} /* W2F_Mark_Loads */


void
W2F_Nomark_Loads(void)
{
   W2F_Only_Mark_Loads = FALSE;
} /* W2F_Nomark_Loads */


void 
W2F_Set_Prompf_Emission(WN_MAP *construct_map)
{
   W2F_Prompf_Emission = TRUE;
   W2F_Construct_Map = construct_map; /* Construct id mapping for prompf */
} /* W2F_Set_Prompf_Emission */


void 
W2F_Set_Frequency_Map(WN_MAP frequency_map)
{
   W2F_Frequency_Map = frequency_map; /* Feedback frequency mapping for wopt */
} /* W2F_Set_Frequency_Map */


const char *
W2F_Get_Transformed_Src_Path(void)
{
   return W2F_File_Name[W2F_FTN_FILE];
} /* W2F_Get_Transformed_Src_Path */


void
W2F_Set_Purple_Emission(void)
{
   W2F_Purple_Emission = TRUE;
} /* W2F_Set_Purple_Emission */


void
W2F_Reset_Purple_Emission(void)
{
   W2F_Purple_Emission = FALSE;
} /* W2C_Reset_Purple_Emission */


void
W2F_def_ST(FILE *outfile, ST *st)
{
   TOKEN_BUFFER tokens;

   if (!Check_Initialized("W2F_def_ST"))
      return;

   tokens = New_Token_Buffer();
   ST2F_decl_translate(tokens, st);
   Write_And_Reclaim_Tokens(outfile, W2F_File[W2F_LOC_FILE], &tokens);
   W2F_Undo_Whirl_Side_Effects();
} /* W2F_def_ST */


const char * 
W2F_Object_Name(ST *func_st)
{
   return W2CF_Symtab_Nameof_St(func_st);
} /* W2F_Object_Name */


void 
W2F_Translate_Stid_Lhs(char       *strbuf,
		       UINT        bufsize,
		       ST         *stid_st, 
		       STAB_OFFSET stid_ofst, 
		       TY_IDX      stid_ty, 
		       TYPE_ID     stid_mtype)
{
   TOKEN_BUFFER tokens;
   WN2F_CONTEXT context = INIT_WN2F_CONTEXT;

   tokens = New_Token_Buffer();
   if (ST_class(stid_st) == CLASS_PREG)
   {
      ST2F_Use_Preg(tokens, ST_type(stid_st), stid_ofst);
   }
   else
   {
      WN2F_Offset_Symref(tokens, 
			 stid_st,                         /* base-symbol */
			 Stab_Pointer_To(ST_type(stid_st)), /* base-type */
			 stid_ty,                         /* object-type */
			 stid_ofst,                       /* object-ofst */
			 context);
   }
   Str_Write_And_Reclaim_Tokens(strbuf, bufsize, &tokens);
   W2F_Undo_Whirl_Side_Effects();
} /* W2F_Translate_Stid_Lhs */


void 
W2F_Translate_Istore_Lhs(char       *strbuf, 
			 UINT        bufsize,
			 WN         *lhs,
			 STAB_OFFSET istore_ofst, 
			 TY_IDX      istore_addr_ty, 
			 TYPE_ID     istore_mtype)
{
   TOKEN_BUFFER tokens;
   TY_IDX       base_ty;
   WN2F_CONTEXT context = INIT_WN2F_CONTEXT;

   /* Get the base address into which we are storing a value */
   base_ty = WN_Tree_Type(lhs);
   if (!TY_Is_Pointer(base_ty))
      base_ty = istore_addr_ty;

   /* Get the lhs of the assignment (dereference address) */
   tokens = New_Token_Buffer();
   WN2F_Offset_Memref(tokens, 
		      lhs,                   /* base-symbol */
		      base_ty,               /* base-type */
		      TY_pointed(istore_addr_ty), /* object-type */
		      istore_ofst,           /* object-ofst */
		      context);
   Str_Write_And_Reclaim_Tokens(strbuf, bufsize, &tokens);
   W2F_Undo_Whirl_Side_Effects();
} /* W2F_Translate_Istore_Lhs */


void 
W2F_Translate_Wn(FILE *outfile, WN *wn)
{
   TOKEN_BUFFER       tokens;
   WN2F_CONTEXT       context = INIT_WN2F_CONTEXT;
   const char * const caller_err_phase = Get_Error_Phase ();

   if (!Check_Initialized("W2F_Translate_Wn") ||
       !Check_PU_Pushed("W2F_Translate_Wn"))
      return;

   Start_Timer(T_W2F_CU);
   if (W2F_Progname != NULL)
      Diag_Set_Phase(W2F_Progname);
   else
      Diag_Set_Phase("FLIST");

   tokens = New_Token_Buffer();
   (void)WN2F_translate(tokens, wn, context);
   Write_And_Reclaim_Tokens(outfile, W2F_File[W2F_LOC_FILE], &tokens);
   W2F_Undo_Whirl_Side_Effects();

   Stop_Timer (T_W2F_CU);
   Diag_Set_Phase(caller_err_phase);
} /* W2F_Translate_Wn */


void 
W2F_Translate_Wn_Str(char *strbuf, UINT bufsize, WN *wn)
{
   TOKEN_BUFFER       tokens;
   WN2F_CONTEXT       context = INIT_WN2F_CONTEXT;
   const char * const caller_err_phase = Get_Error_Phase ();

   if (!Check_Initialized("W2F_Translate_Wn_Str") ||
       !Check_PU_Pushed("W2F_Translate_Wn_Str"))
      return;

   Start_Timer (T_W2F_CU);
   if (W2F_Progname != NULL)
      Diag_Set_Phase(W2F_Progname);
   else
      Diag_Set_Phase("FLIST");

   tokens = New_Token_Buffer();
   (void)WN2F_translate(tokens, wn, context);
   Str_Write_And_Reclaim_Tokens(strbuf, bufsize, &tokens);
   W2F_Undo_Whirl_Side_Effects();

   Stop_Timer (T_W2F_CU);
   Diag_Set_Phase(caller_err_phase);
} /* W2F_Translate_Wn_Str */


void 
W2F_Translate_Purple_Main(FILE *outfile, WN *pu, const char *region_name)
{
   TOKEN_BUFFER       tokens;
   WN2F_CONTEXT       context = INIT_WN2F_CONTEXT;
   const char * const caller_err_phase = Get_Error_Phase ();

   if (!Check_Initialized("W2F_Translate_Purple_Main"))
      return;

   Is_True(WN_opcode(pu) == OPC_FUNC_ENTRY, 
	   ("Invalid opcode for W2F_Translate_Purple_Main()"));

   Start_Timer (T_W2F_CU);
   Set_Error_Phase ("WHIRL To F");

   /* Translate the function header as a purple main program
    */
   tokens = New_Token_Buffer();
   W2F_Push_PU(pu, WN_func_body(pu));
   (void)WN2F_translate_purple_main(tokens, pu, region_name, context);
   W2F_Pop_PU();
   W2F_Undo_Whirl_Side_Effects();
   Write_And_Reclaim_Tokens(outfile, W2F_File[W2F_LOC_FILE], &tokens);

   Stop_Timer (T_W2F_CU);
   Set_Error_Phase (caller_err_phase);
} /* W2F_Translate_Purple_Main */


void
W2F_Fini(void)
{
   /* Ignore this call if W2F_Outfile_Initialized, since a call to
    * W2F_Outfile_Fini() must take care of the finalization for
    * this case.
    */
   INT i;

   if (!Check_Initialized("W2F_Fini"))
      return;
   else if (!W2F_Outfile_Initialized)
   {

      ST2F_finalize();
      PUinfo_finalize();
      WN2F_finalize();
      W2CF_Symtab_Terminate();
      Stab_finalize_flags();

      if (W2F_File_Name[W2F_LOC_FILE] != NULL)
	 End_Locations_File(); /* Writes filenames-table to file */
      else
	 Terminate_Token_Buffer(NULL);
      Diag_Exit();

      /* Reset all global variables */

      W2F_Initialized = FALSE;
      W2F_Format_Kind = F77_TAB_FORMAT;
      reset_WN2F_CONTEXT(Global_Context);
      W2F_Progname = "";
      for (i=0;i<W2F_NUM_FILES;i++) W2F_File_Name[i] = NULL;
      for (i=0;i<W2F_NUM_FILES;i++) File_Is_Created[i] = FALSE;
      for (i=0;i<W2F_NUM_FILES;i++) W2F_File[i] = NULL;
      W2F_Enabled = TRUE;          /* Invoke W2F */
      W2F_Verbose = TRUE;          /* Show translation information */
      W2F_Old_F77 = FALSE;         /* Use macros for new intrinsics */
      W2F_Ansi_Format = FALSE;     /* Line-formatting to f77 standard */
      W2F_No_Pragmas = FALSE;      /* By default, emit pragmas */
      W2F_Emit_Prefetch = FALSE;   /* Emit comments for prefetches */
      W2F_Emit_All_Regions = FALSE;/* Emit cmplr-generated regions */
      W2F_Emit_Linedirs = FALSE;   /* Emit preproc line-directives */
      W2F_Emit_Nested_PUs = FALSE; /* Emit code for nested MP PUs */
      W2F_Emit_Frequency = FALSE;  /* Emit feedback frequency info */
      W2F_Line_Length = 0;         /* 'zero' means: use the default */

      W2F_Only_Mark_Loads = FALSE;

      MEM_POOL_Pop(&W2F_Parent_Pool);
      MEM_POOL_Delete(&W2F_Parent_Pool);
   } /* if (initialized) */
} /* W2F_Fini */


/* =================================================================
 *                  EXPORTED OUTPUT-FILE INTERFACE
 *                  ------------------------------
 *
 * This is the easiest interface for using whirl2f.so, and it
 * maintains output file status and produces a uniform output
 * format based on the -FLIST options.  There are strict rules
 * as to how this interface interacts with the lower-level 
 * interface described above (see .h file for details).
 *
 * W2F_Outfile_Init()
 *    Initializes the output-files for whirl2f, based on the
 *    command-line options.  Will call W2F_Init() is this has
 *    not already been done.
 *
 * W2F_Outfile_Translate_Pu()
 *    Translates a PU, presupposing W2F_Outfile_Init() has been 
 *    called.  The PU will be lowered (for Fortran) and the 
 *    output Fortran code will be appended to the output files.
 *
 * W2F_Output_Fini()
 *    Finalizes a W2F translation by closing the output-files, and
 *    calling W2F_Fini().
 *
 * =================================================================
 */

void
W2F_Outfile_Init(void)
{
   /* Initialize the various whirl2f subcomponents.  It is not
    * always desirable to open a .h file for global declarations,
    * and this can be suppressed (no global declarations will be
    * emitted) by passing emit_global_decls=FALSE.  For even more
    * control over the W2F translation process, use the lower-level
    * translation routines, instead of this more abstract
    * interface.
    */
   time_t systime;

   if (W2F_Outfile_Initialized)
      return; /* Already initialized */

   W2F_Outfile_Initialized = TRUE;
   if (W2F_Verbose)
   {
      if (W2F_Prompf_Emission || W2F_File_Name[W2F_LOC_FILE] == NULL)
	 fprintf(stderr, 
		 "%s translates %s into %s, based on source %s\n",
		 W2F_Progname,
		 Irb_File_Name,
		 W2F_File_Name[W2F_FTN_FILE], 
		 W2F_File_Name[W2F_ORIG_FILE]);
      else
	 fprintf(stderr, 
		 "%s translates %s into %s and %s, based on source %s\n", 
		 W2F_Progname,
		 Irb_File_Name,
		 W2F_File_Name[W2F_FTN_FILE],
		 W2F_File_Name[W2F_LOC_FILE],
		 W2F_File_Name[W2F_ORIG_FILE]);
   } /* if verbose */

   /* Initialize the whirl2f modules!
    */
   if (!W2F_Initialized)
      W2F_Init();

   /* Open the output files (and write location mapping header).
    */
   Begin_New_Locations_File();
   Open_W2f_Output_File(W2F_FTN_FILE);

   /* Write out a header-comment into the whirl2f generated 
    * source file.
    */
   systime = time(NULL);
   Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE],
		"C ********************************************"
		"***************\n"
		"C Fortran file translated from WHIRL ");
   Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE],
		((systime != (time_t)-1)? 
		 ctime(&systime) : "at unknown time\n"));
   Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE],
		"C **********************************************"
		"*************\n");

   if (W2F_Old_F77)
   {
      Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE],
		   "C Include builtin operators "
		   "(TODO: add missing ones into this included file)\n"
		   "#include <whirl2f.h>\n\n");
   }

   W2F_Outfile_Initialized = TRUE;

} /* W2F_Outfile_Init */


void
W2F_Outfile_Translate_Pu(WN *pu)
{
   TOKEN_BUFFER       tokens;
   LOWER_ACTIONS      lower_actions = LOWER_NULL;
   const BOOL         pu_is_pushed = (PUinfo_current_func == pu);
   const char * const caller_err_phase = Get_Error_Phase ();

   if (!Check_Outfile_Initialized("W2F_Outfile_Translate_Pu"))
      return;

   Is_True(WN_opcode(pu) == OPC_FUNC_ENTRY, 
	   ("Invalid opcode for W2F_Outfile_Translate_Pu()"));

   /* Make sure all necessary output files are open.
    */
   Continue_Locations_File();
   Open_W2f_Output_File(W2F_FTN_FILE);

   if (W2F_Emit_Nested_PUs)
      lower_actions = LOWER_MP;

   if (lower_actions != LOWER_NULL)
      pu = WN_Lower(pu, lower_actions, NULL, "W2F Lowering");

   Start_Timer(T_W2F_CU);
   if (W2F_Progname != NULL)
      Diag_Set_Phase(W2F_Progname);
   else
      Diag_Set_Phase("FLIST");

   if (!pu_is_pushed)
      W2F_Push_PU(pu, WN_func_body(pu));

   /* Set the flag for an F90 program unit */

   PU & pucur  = Pu_Table[ST_pu(PUINFO_FUNC_ST)];
   WN2F_F90_pu = PU_f90_lang(pucur) != 0;

   // indented nested f90 routines, close CONTAINS for f90, if reqd..

   BOOL nested = PU_is_nested_func(pucur) && !(PU_mp(pucur)) ;

   tokens = New_Token_Buffer();

   if (nested) 
   {
      WN2F_Emit_End_Stmt(tokens,TRUE);
      Increment_Indentation();
   } else
      WN2F_Emit_End_Stmt(tokens,FALSE);

   

   (void)WN2F_translate(tokens, pu, Global_Context);
   Write_And_Reclaim_Tokens(W2F_File[W2F_FTN_FILE], 
			    W2F_File[W2F_LOC_FILE], 
			    &tokens);

   if (nested)
      Decrement_Indentation();

   if (!pu_is_pushed)
      W2F_Pop_PU();

   W2F_Undo_Whirl_Side_Effects();

   Stop_Timer(T_W2F_CU);
   Diag_Set_Phase(caller_err_phase);
} /* W2F_Outfile_Translate_Pu */


void
W2F_Outfile_Fini(void)
{
   TOKEN_BUFFER  tokens;

   /* This finalization must be complete enough to allow repeated
    * invocations of whirl2c during the same process life-time.
    */
   const char *loc_fname = W2F_File_Name[W2F_LOC_FILE];

   if (!Check_Outfile_Initialized("W2F_Outfile_Fini"))
      return;

   Clear_w2fc_flags()  ;

   // Emit END for nested routines if reqd. 
   // Look at global symtab for initalized COMMON.

   tokens = New_Token_Buffer();

   WN2F_Emit_End_Stmt(tokens,FALSE);

   WN2F_Append_Block_Data(tokens);
   Write_And_Reclaim_Tokens(W2F_File[W2F_FTN_FILE], 
			    W2F_File[W2F_LOC_FILE], 
			    &tokens);

   /* All files must be closed before doing a partial 
    * finalization.
    */
   Close_W2f_Output_File(W2F_FTN_FILE);
   W2F_Outfile_Initialized = FALSE;
   W2F_Fini(); /* End_Locations_File() and sets W2F_Initialized to FALSE */

   if (W2F_Prompf_Emission && loc_fname != NULL)
   {
      /* Copy the locations file to the .anl file and remove it 
       */
      Move_Locations_To_Anl_File(loc_fname);
   }
} /* W2F_Outfile_Fini */


void
W2F_Cleanup(void)
{
   /* Cleanup in case of error condition (or a forgotten call to Anl_Fini())
    */
   Close_W2f_Output_File(W2F_LOC_FILE);
   Close_W2f_Output_File(W2F_FTN_FILE);
   if (W2F_File_Name[W2F_LOC_FILE] != NULL)
      unlink(W2F_File_Name[W2F_LOC_FILE]);
}
