/*
 * Copyright (c) 1994-2018, NVIDIA CORPORATION.  All rights reserved.
 *
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 *     http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *
 */

/** \file main.c
    \brief main program and initialization routines for fortran front-end
*/
#include "gbldefs.h"
#include <stdbool.h>
#include "flang/ArgParser/arg_parser.h"
#include "error.h"
#if !defined(TARGET_WIN)
#include <unistd.h>
#endif
#include <time.h>
#include "global.h"
#include "symtab.h"
#include "dtypeutl.h"
#include "version.h"
#include "inliner.h"
#include "interf.h"
#include "semant.h"
#include "dinit.h"

#include "ast.h"
#include "lower.h"
#include "dbg_out.h"
#include "ccffinfo.h"
#include "x86.h"
#include "direct.h"
#include "optimize.h"
#include "transfrm.h"
#include "extern.h"
#include "commopt.h"
#include "scan.h"
#include "hlvect.h"

#define IPA_ENABLED                  0
#define IPA_NO_ASM                   0
#define IPA_COLLECTION_ENABLED       0
#define IPA_INHERIT_ENABLED          0
#define IPA_FUTURE_INHERIT_DISABLED  0
#define IPA_REPORT_ENABLED           0

/* static prototypes */

static void reptime(void);
static void add_debuglist(char *phasearg, char *dumparg);
static void do_debug(char *phase);
static void cleanup(void);
static void init(int argc, char *argv[]);
static void datastructure_reinit(void);
static void set_ipa_export_file(char *name);
static void set_ipa_import_mode(void);
static void set_ipa_import_offset(char *offset);
static void set_debug(LOGICAL value);
static void set_debug_symbol(LOGICAL value);
static void set_debug_line(LOGICAL value);
static void do_set_tp(char *tp);
static void fini(void);
static void mkDwfInfoFilename(void);

/* ******************************************************************** */

/* Below are definitions/static variables required by main function */
static int saveoptflag;
static int savevectflag;
static int savex8flag;
static int saverecursive;
static LOGICAL has_accel_code = FALSE;
static action_map_t *phase_dump_map;
#if DEBUG
static int debugfunconly = -1;
#endif
static LOGICAL ipa_import_mode = FALSE;
static char *ipa_export_file = NULL;
static BIGUINT ipa_import_offset = 0;
static char *who[] = {"init",     "parser",   "bblock", "vectorize", "optimize",
                      "schedule", "assemble", "xref",   "unroll"};
#define _N_WHO (sizeof(who) / sizeof(char *))
static INT xtimes[_N_WHO];
static LOGICAL postprocessing = TRUE;

/* Feature names for Fortran front-end */
#if defined(TARGET_LINUX_X8664)
static char *feature = "flang";
static char *os = "lin";
static char *accel = NULL;
#elif defined(TARGET_WIN_X8664)
static char *feature2 = "pgi-f95-win64";
static char *feature = "pgfortran";
static char *os = "win";
static char *accel = NULL;
#elif defined(TARGET_OSX_X8664)
static char *feature2 = "pgi-f95-osx64";
static char *feature = "pgfortran";
static char *os = "osx";
static char *accel = NULL;
#elif defined(OSF86)
static char *feature = "pgi-f95-osf32";
static char *os = NULL;
static char *accel = NULL;
#elif defined(TARGET_LLVM_POWER)
static char *feature2 = "pgi-f95-power";
static char *feature = "pgfortran";
static char *os = "lin";
static char *accel = NULL;
#else
static char *feature2 = "pgi-f95";
static char *feature = "pgfortran";
static char *os = "lin";
static char *accel = NULL;
#endif

/** Product name in debug output
 */
#define DNAME "F90"

#if DEBUG
static int dodebug = 0;
#define TR(str)               \
  if (dodebug) {              \
    fprintf(gbl.dbgfil, str); \
    fflush(gbl.dbgfil);       \
  }
#define TR1(str)      \
  if (DBGBIT(0, 512)) \
  dump_stg_stat(str)
#define DUMP(a) do_debug(a)
#else
#define TR(str)
#define TR1(str)
#define DUMP(a)
#endif /* DEBUG */

#define NO_FLEXLM

/** \brief Fortran front-end main entry
    \param argc number of command-line arguments
    \pram argv array of command-line argument strings
*/
int
main(int argc, char *argv[])
{
  int savescope, savecurrmod = 0;
  getcpu();
  init(argc, argv); /* initialize */
  if (gbl.fn == NULL)
    gbl.fn = gbl.src_file;

#if DEBUG
  if (debugfunconly > 0)
    dodebug = 0;
#endif

  saveoptflag = flg.opt;
  savevectflag = flg.vect;
  savex8flag = flg.x[8];
  saverecursive = flg.recursive;

  if (IPA_INHERIT_ENABLED && (flg.opt >= 2 || IPA_COLLECTION_ENABLED)) {
    ipa_init();
  }

  gbl.findex = addfile(gbl.fn, NULL, 0, 0, 0, 1, 0);

  if (ipa_export_file && ipa_import_mode) {
    ipa_import_open(ipa_export_file, ipa_import_offset);
  }
  if (IPA_ENABLED && ipa_export_file && !ipa_import_mode) {
    /* export the program unit for IPA recompilation */
    ipa_export_open(ipa_export_file);
  }

  if (gbl.srcfil == NULL) {
    if (!ipa_import_mode) {
      finish();
    }
  }
  do { /* loop once for each user program unit */
#if DEBUG
    if (debugfunconly > 0) {
      if (debugfunconly == gbl.func_count + 1)
        dodebug = 1;
      else
        dodebug = 0;
    }
#endif
    reinit();
    errini();
    if (ipa_export_file && ipa_import_mode && gbl.func_count == 0) {
      ipa_import_highpoint();
    }
    if (IPA_ENABLED && ipa_export_file && !ipa_import_mode &&
        gbl.func_count == 0) {
      ipa_export_highpoint();
    }
    xtimes[0] += getcpu();
    if (ipa_export_file && ipa_import_mode) {
      ipa_import();
      if (gbl.eof_flag & 2)
        break;
    } else {
      TR(DNAME " PARSER begins\n")
      parser(); /* parse and do semantic analysis */
      set_tag();
    }
    gbl.func_count++;
    ccff_open_unit_f90();
    if (gbl.internal <= 1) {
      gbl.outersub = 0;
      gbl.outerentries = 0;
    }
    savescope = stb.curr_scope;
    if (gbl.currsub) {
      if (SCOPEG(gbl.currsub)) {
        stb.curr_scope = SCOPEG(gbl.currsub);
        if (STYPEG(stb.curr_scope) != ST_ALIAS ||
            SYMLKG(stb.curr_scope) != gbl.currsub) {
          stb.curr_scope = gbl.currsub;
        }
      } else {
        stb.curr_scope = gbl.currsub;
      }
    }
    TR1("- after semant");
    xtimes[1] += getcpu();
    DUMP("parser");
    if (gbl.rutype == RU_BDATA) {
      /* a module? */
      if (has_cuda_data())
        has_accel_code = TRUE;
    }
    if (gbl.currsub == 0) {
      if (IPA_ENABLED && ipa_export_file && !ipa_import_mode) {
        /* export the program unit for IPA recompilation */
        ipa_export_endmodule();
      }
      continue; /* end of a module */
    }
    if (CUDAG(gbl.currsub) & (CUDA_GLOBAL | CUDA_DEVICE)) {
      /* remember that this routine needs a constructor */
      has_accel_code = TRUE;
    }
    savecurrmod = gbl.currmod;
#if DEBUG
    if (DBGBIT(5, 1))
      symdmp(gbl.dbgfil, DBGBIT(5, 8));
    if (DBGBIT(5, 2))
      dump_std();
    if (DBGBIT(5, 16))
      dmp_dtype();
#endif
    if (IPA_ENABLED && ipa_export_file && !ipa_import_mode) {
      /* export the program unit for IPA recompilation */
      ipa_export();
    }

#if DEBUG
    if (DBGBIT(4, 256))
      dump_ast();
#endif
    if (IPA_INHERIT_ENABLED && gbl.rutype != RU_BDATA) {
      int func;
      ipa_startfunc(gbl.currsub);
      ipa_header1(gbl.currsub);
      ipa_header2(gbl.currsub);
    }
    postprocessing = FALSE;
    if (gbl.maxsev < 3 && !DBGBIT(2, 4)) {
      postprocessing = TRUE;

      flg.ipa |= 0x20;
      if (XBIT(57, 0x2000) && !flg.inliner) {
        /* try to eliminate unused common blocks here */
        eliminate_unused_variables(1);
        DUMP("staticunused");
      }
      /* by default, generate data initialization inline. */
      if (gbl.rutype != RU_BDATA) {
        direct_rou_load(gbl.currsub);
        if (flg.opt > 1 && !XBIT(47, 0x40000000)) {
          if (sem.stats.allocs > 800 && sem.stats.nodes > 1000) {
            direct_rou_setopt(gbl.currsub, 1);
            /*
             * Also, inhibit sectfloat() which is enabled with
             * -fast or -O2 or greater.
             */
            flg.x[70] &= (~0x400);
          }
        }
        ili_lpprg_init();

        TR(DNAME " BBLOCK begins\n");
        has_accel_code |= bblock();
        TR1("- after bblock");
        DUMP("bblock");
        if (flg.inliner) {
          TR(DNAME " INLINER begins\n");
#if DEBUG
          if (flg.x[29] == 0 || flg.x[29] == gbl.func_count)
#endif
            inliner();
          DUMP("inliner");
          TR1("- after inliner");
        }

        if (flg.opt >= 2 && XBIT(50, 0x40)) {
          unconditional_branches();
          DUMP("unconditional");
        }
        if (flg.opt >= 2 && !XBIT(47, 0x20)) {
          TR(DNAME " OPTIMIZE_ALLOC begins\n");
          optimize_alloc();
          DUMP("optalloc");
          TR1("- after optimize_alloc");
        }

        if (IPA_ENABLED) {
          ipasave();
          if (IPA_NO_ASM) {
            ipasave_endfunc();
            direct_rou_end();
            continue;
          }
        }
        if (IPA_INHERIT_ENABLED && !IPA_FUTURE_INHERIT_DISABLED) {
          if (!IPA_ENABLED) {
            fill_ipasym();
          }
          ipa();
          DUMP("ipa");
          if (IPA_Vestigial) {
            ipasave_endfunc();
            if (gbl.internal == 1) {
              ipa_set_vestigial_host(); /* interf.c */
              save_host_state(0x2 + (ipa_import_mode ? 0x20 : 0));
              gbl.outersub = gbl.currsub;
              gbl.outerentries = gbl.entries;
            }
            (void)summary(FALSE, FALSE);
            continue;
          }
        }

        /* infer array alignments */
        TR(DNAME " PROCESS_ALIGN begins\n");
        trans_process_align();
        TR1("- after process_align");
        DUMP("process-align");

        if (flg.opt >= 2) {
          if (XBIT(53, 2)) {
            points_to_anal();
            DUMP("pointsto");
          }
          pstride_analysis();
          DUMP("pstride");
        }

        if (!XBIT(49, 1)) {
          TR(DNAME " TRANSFORMER begins\n");
          transform();
          DUMP("transform");
          TR1("- after transform");

          forall_init();

          if (!XBIT(49, 0x20)) {
            if (flg.opt >= 2 && !XBIT(47, 0x02)) {
              TR(DNAME " COMMUNICATIONS pre-OPTIMIZER begins\n");
              comm_optimize_pre();
              DUMP("comm-analyze-pre");
              TR1("- after comm pre-optimizer");
            }
            TR(DNAME " COMMUNICATIONS ANALYZER begins\n");
            comm_analyze();
            DUMP("comm-analyze");
            TR1("- after comm_analyze");

            TR(DNAME " CALL ANALYZER begins\n");
            call_analyze();
            DUMP("call-analyze");
            TR1("- after call_analyze");
            if (flg.opt >= 2 && !XBIT(47, 0x01)) {
              TR(DNAME " COMMUNICATIONS post-OPTIMIZER begins\n");
              comm_optimize_post();
              DUMP("comm-optimize-post");
              TR1("- after comm post-optimizer");
            }
            if (flg.opt >= 2 && !XBIT(47, 0x08)) {
              TR(DNAME " COMMUNICATIONS hoisting begins\n");
              comm_invar();
              DUMP("comm-invar");
              TR1("- after comm_invar");
            }
            TR(DNAME " COMMUNICATIONS GENERATOR begins\n");
            comm_generator();
            DUMP("comm-generator");
            TR1("- after comm_generator");
          }
          TR(DNAME " CONVERT_FORALL begins\n");
          convert_forall();
          DUMP("convert-forall");
          TR1("- after convert_forall");

          TR(DNAME " CONVERT_OUTPUT begins\n");
          convert_output();
          TR1("- after convert_output");
          DUMP("convert-output");
        }
        if (XBIT(70, 0x400) || XBIT(47, 0x400000)
                ) {
          optimize(1);
          DUMP("optimize0");
          TR1("- after optimize0");
        }
        if (XBIT(70, 0x400)) {
          sectfloat();
          DUMP("sectfloat");
        }
        if (XBIT(47, 0x400000) || flg.opt >= 2 || XBIT(163, 1)
                ) {
          sectinline();
          DUMP("sectinline");
        }
        if (XBIT(70, 0x18)) {
          linearize_arrays();
          DUMP("linearize");
        }
        if (!XBIT(70, 0x40)) {
          DUMP("bredundss");
          redundss();
          DUMP("redundss");
        }
        if (flg.opt >= 2 && !XBIT(47, 0x1000)) {
          TR(DNAME " OPTIMIZER begins\n");
          optimize(0);
          DUMP("optimize");
          TR1("- after optimize");
        }
        if (IPA_ENABLED) {
          ipasave_endfunc();
        }
        if (IPA_REPORT_ENABLED) {
          ipa_report();
        }

        direct_rou_end();
        if (flg.opt >= 2 && XBIT(53, 2)) {
          fini_points_to_all();
        }
      } else { /* gbl.rutype == RU_BDATA */
        direct_rou_load(gbl.currsub);
        if (IPA_ENABLED) {
          ipasave();
        }
        merge_commons();
        if (XBIT(55, 2)) {
          cleanup();
          goto skip_compile;
        }
        /* block data must be transformed so that common blocks
         * get handled -- lfm
         */
        /* infer array alignments */
        TR("Blkdata -- " DNAME " PROCESS_ALIGN begins\n");
        trans_process_align();
        DUMP("process-align");
        TR1("- after process_align");
        if (!XBIT(49, 1)) {
          TR("Blkdata -- " DNAME " TRANSFORMER begins\n");
          transform();
          DUMP("transform");
          TR1("- after transform");
        }
      }
#if DEBUG
      if (XBIT(57, 0x100)) {
        renumber_lines();
      }
#endif
      if (XBIT(57, 0x2000)) {
        DUMP("bunused");
        eliminate_unused_variables(2);
        DUMP("unused");
      }
      DUMP("before-output");
      lower(0);
      if (gbl.internal == 1) {
        save_host_state(0x2 + (ipa_import_mode ? 0x20 : 0));
      }
      DUMP("output");
      if (gbl.rutype != RU_BDATA && flg.opt >= 2 && XBIT(53, 2)) {
        fini_pstride_analysis();
      }
#if DEBUG
      if (DBGBIT(5, 4))
        symdmp(gbl.dbgfil, DBGBIT(5, 8));
      if (DBGBIT(5, 16))
        dmp_dtype();
#endif
    } else { /* if( gbl.maxsev < 3 && !DBGBIT(2, 4) ) */
      if (gbl.internal == 1) {
        save_host_state(0x2);
      }
    } /* if( gbl.maxsev < 3 && !DBGBIT(2, 4) ) */

    if (flg.xref) {
      xref(); /* write cross reference map */
      xtimes[7] += getcpu();
    }
    skip_compile:
    (void)summary(FALSE, FALSE);
    errini();

    if (gbl.internal == 1) {
      gbl.outersub = gbl.currsub;
      gbl.outerentries = gbl.entries;
    }
    stb.curr_scope = savescope;
    ccff_close_unit_f90();
  } while (!gbl.eof_flag);
  finish(); /* finish does not return */
  return 0; /* never reached */
}

/* ************************************************************** */

/*
 * static structures/variables used in command line processing/init() function:
 */

#define __ATOI(s, p, l, r) _atoi(s, p, l)
static char *objectfile;
static char *outfile_name;
LOGICAL fpp_ = FALSE;
static LOGICAL no_specified;
static int preproc = -1; /* not specified */

/* ***************************************************************** */

/*
 * Various types of AST dumpers, wrapper functions
 */

static void
dump_stds(void)
{
  dstds(0, 0);
}

static void
dump_sstds(void)
{
  dsstds(0, 0);
}

static void
dump_stdps(void)
{
  dstdps(0, 0);
}

/** \brief Dump symbols
 */
static void
dump_symbols(void)
{
  dsyms(0, 0);
}

/** \brief Dump all symbols
 */
static void
dump_all_symbols(void)
{
  dsyms(1, 0);
}

/** \brief Dump symbols from current source file
 */
static void
dump_current_symbols(void)
{
  dsyms(stb.firstosym, 0);
}

/** \brief Yet another symbol table dumper
 */
static void
dump_old_symbols(void)
{
  symdmp(gbl.dbgfil, 0);
}

/** \brief Dump memory area
 */
static void
report_area(void)
{
  reportarea(0);
}

static char *current_phase;

/** \brief Dump stg statistics
 */
static void
dump_stg_stats(void)
{
  dump_stg_stat(current_phase);
}

/**
 * \brief Initialize Fortran frontend at the beginning of compilation.
 */
static void
init(int argc, char *argv[])
{
  int argindex;
  char *argstring;
  int indice, next;
  char *sourcefile;
  char *stboutfile;
  int nosuffixcheck = 0;
  char *listfile;
  char *cppfile;
  char *tempfile;
  char *asmfile;
  int i;
  int def_count = 0;  /* number of -def switches */
  int idir_count = 0; /* number of -idir switches */
  INT qval1;
  INT qval2;
  int val_follows;
  LOGICAL dbgflg;
  char *dbgfile = NULL;
  LOGICAL errflg;
  FILE *fd;
  int exlib_flag = 0;
  char *file_suffix;
  int copy_curr_file = 1;
  static struct {
    char *nm; /* name, 0 = end of list */
    int form; /* 0 = fixed, 1 = form */
    int fpp;  /* 0 = don't preprocess, 1 = preprocess */
  } suffixes[] = {
          {".hpf", 0, 0}, {".f", 0, 0},   {".F", 0, 1},   {".f90", 1, 0},
          {".F90", 1, 1}, {".f95", 1, 0}, {".F95", 1, 1}, {".for", 0, 0},
          {".fpp", 0, 1}, {0, 0, 0},
  };
  char *followval;
  int followindex;
  time_t now;

  flg.freeform = -1;
  file_suffix = ".f90"; /* default suffix for source files */
  /*
   * initialize error and symbol table modules in case error messages are
   * issued:
   */
  errini();
  gbl.curr_file = NULL;
  gbl.fn = NULL;
  sym_init();
  interf_init();
  BZERO(&sem, SEM, 1);

  /* fill in date and time */
  time(&now);
  strftime(gbl.datetime, sizeof gbl.datetime, "%m/%d/%Y  %H:%M:%S",
           localtime(&now));

  dbgflg = FALSE;
  errflg = FALSE;

  sourcefile = NULL;
  listfile = NULL;
  cppfile = NULL;
  objectfile = NULL;
  asmfile = NULL;
  outfile_name = NULL;
  gbl.ipaname = NULL;
  argindex = 0;
  stboutfile = NULL;

  flg.x[79] = 16; /* Hardwire XBIT(79,16): CSE DP loads for a distance of 16 */

  flg.x[27] = -1; /* overlap not set */

  if (argc < 2)
    goto empty_cl;

  char *tp;            /* Target architecture */
  char *omptp = NULL;         /* OpenMP Target architecture */
  int vect_val;        /* Vectorizer settings */
  char *modexport_val; /* Modexport file name */
  char *modindex_val;  /* Modindex file name */
  char **module_dirs;  /* Null-terminated list of module directories */
  bool arg_preproc;    /* Argument to turn preprocessor on and off */
  bool arg_freeform;   /* Argument to force free-form source */
  bool arg_extend;     /* Argument to force line extension */
  bool arg_reentrant;  /* Argument to enable generating reentrant code */

  /* Create a datastructure of various dump actions and their names */
  action_map_t *dump_map; /* Deallocated after arguments are parsed */
  create_action_map(&dump_map);
  add_action(dump_map, "ast", dump_ast);
  add_action(dump_map, "dtype", dumpdts);
  add_action(dump_map, "std", dump_stds);
  add_action(dump_map, "sstd", dump_sstds);
  add_action(dump_map, "stdp", dump_stdps);
  add_action(dump_map, "sym", dump_symbols);
  add_action(dump_map, "syms", dump_symbols);
  add_action(dump_map, "symtab", dump_symbols);
  add_action(dump_map, "allsym", dump_all_symbols);
  add_action(dump_map, "stats", dump_stg_stats);
  add_action(dump_map, "area", report_area);
  add_action(dump_map, "olddtype", dmp_dtype);
  add_action(dump_map, "odtype", dmp_dtype);
  add_action(dump_map, "oldsym", dump_old_symbols);
  add_action(dump_map, "osym", dump_current_symbols);
  add_action(dump_map, "hsym", dump_current_symbols);
  add_action(dump_map, "hsyms", dump_current_symbols);
  add_action(dump_map, "common", dcommons);
  add_action(dump_map, "commons", dcommons);
  add_action(dump_map, "nast", dumpasts);
  add_action(dump_map, "stdtree", dumpstdtrees);
  add_action(dump_map, "stdtrees", dumpstdtrees);
  add_action(dump_map, "shape", dumpshapes);
  add_action(dump_map, "aux", dumplists);
  /* Initialize the map that will be used by dump handler later */
  create_action_map(&phase_dump_map);

  arg_parser_t *arg_parser;

  create_arg_parser(&arg_parser, true);

  /* Register two ways for supplying source file argument */
  register_filename_arg(arg_parser, &sourcefile);
  register_string_arg(arg_parser, "src", &sourcefile, NULL);
  /* Output file (.ilm) */
  register_combined_bool_string_arg(arg_parser, "output", (bool *)&(flg.output),
                                    &outfile_name);
  /* Other files to input or output */
  register_string_arg(arg_parser, "stbfile", &stboutfile, NULL);
  register_string_arg(arg_parser, "modexport", &modexport_val, NULL);
  register_string_arg(arg_parser, "modindex", &modindex_val, NULL);
  register_string_arg(arg_parser, "qfile", &dbgfile, NULL);

  /* Optimization level */
  register_integer_arg(arg_parser, "opt", &(flg.opt), 1);

  /* Allocate space for command line macro definitions */
  flg.def = (char **)getitem(8, argc * sizeof(char *));
  flg.undef = (char **)getitem(8, argc * sizeof(char *));
  flg.idir = (char **)getitem(8, argc * sizeof(char *));
  module_dirs = (char **)getitem(8, argc * sizeof(char *));
  /* Command line macro definitions */
  register_string_list_arg(arg_parser, "def", flg.def);
  register_string_list_arg(arg_parser, "undef", flg.undef);
  register_string_list_arg(arg_parser, "idir", flg.idir);
  register_string_list_arg(arg_parser, "moddir", module_dirs);

  /* x flags */
  register_xflag_arg(arg_parser, "x", flg.x,
                     (sizeof(flg.x) / sizeof(flg.x[0])));
  register_yflag_arg(arg_parser, "y", flg.x);
  /* Debug flags */
  register_qflag_arg(arg_parser, "q", flg.dbg,
                     (sizeof(flg.dbg) / sizeof(flg.dbg[0])));
  register_action_map_arg(arg_parser, "qq", phase_dump_map, dump_map);

  /* Other flags */
  register_boolean_arg(arg_parser, "mp", (bool *)&(flg.smp), false);
  register_string_arg(arg_parser, "fopenmp-targets", &omptp, NULL);
  register_boolean_arg(arg_parser, "preprocess", &arg_preproc, true);
  register_boolean_arg(arg_parser, "reentrant", &arg_reentrant, false);
  register_integer_arg(arg_parser, "terse", &(flg.terse), 1);
  register_inform_level_arg(arg_parser, "inform",
                            (inform_level_t *)&(flg.inform), LV_Inform);
  register_boolean_arg(arg_parser, "hpf", (bool *)&(flg.hpf), true);
  register_boolean_arg(arg_parser, "static", (bool *)&(flg.doprelink), true);
  register_boolean_arg(arg_parser, "quad", (bool *)&(flg.quad), true);
  register_boolean_arg(arg_parser, "freeform", &arg_freeform, false);
  register_string_arg(arg_parser, "tp", &tp, NULL);
  register_string_arg(arg_parser, "stdinc", &(flg.stdinc), (char *)1);
  register_integer_arg(arg_parser, "vect", &(vect_val), 0);
  register_boolean_arg(arg_parser, "standard", (bool *)&(flg.standard), false);
  register_boolean_arg(arg_parser, "save", (bool *)&(flg.save), false);
  register_boolean_arg(arg_parser, "extend", &arg_extend, false);
  register_boolean_arg(arg_parser, "recursive", (bool *)&(flg.recursive),
                       false);
  register_string_arg(arg_parser, "cmdline", &(flg.cmdline), NULL);
  register_boolean_arg(arg_parser, "es", (bool *)&(flg.es), false);
  register_boolean_arg(arg_parser, "pp", (bool *)&(flg.p), false);

  /* Set values form command line arguments */
  parse_arguments(arg_parser, argc, argv);

  /* Direct debug output */
  if (was_value_set(arg_parser, &(flg.dbg)) ||
      was_value_set(arg_parser, phase_dump_map)) {
#if DEBUG
    dodebug = 1;
#endif
    if (dbgfile) {
      gbl.dbgfil = fopen(dbgfile, "w");
      if (gbl.dbgfil == NULL)
        errfatal(5);
    } else if ((flg.dbg[0] & 1) || sourcefile == NULL) {
      gbl.dbgfil = stderr;
    } else {
      if (ipa_import_mode) {
        tempfile = mkfname(sourcefile, file_suffix, ".qdbh");
      } else {
        tempfile = mkfname(sourcefile, file_suffix, ".qdbf");
        if ((gbl.dbgfil = fopen(tempfile, "w")) == NULL)
          errfatal(5);
      }
    }
  }

  /* Set preporocessor and Fortran source form
   * ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
   * FIXME this logic needs to be moved to where those values are consumed
   */
  if (was_value_set(arg_parser, &arg_preproc)) {
    /* If the argument was present on command line set the value, otherwise
     * keep "undefined" -1 */
    preproc = arg_preproc;
  }
  if (was_value_set(arg_parser, &arg_freeform)) {
    /* If the argument was present on command line set the value, otherwise
     * keep "undefined" -1 */
    flg.freeform = arg_freeform;
  }

  /* Enable reentrant code */
  if (was_value_set(arg_parser, &arg_reentrant)) {
    if (arg_reentrant) {
      flg.x[7] |= 0x2;      /* inhibit terminal func optz. */
      flg.recursive = TRUE; /* no static locals */
    } else {
      flg.x[7] &= ~(0x2);
      flg.recursive = FALSE;
    }
  }

  /* Free memory */
  destroy_arg_parser(&arg_parser);
  destroy_action_map(&dump_map);

  /* Now do some postprocessing
   * ^^^^^^^^^^^^^^^^^^^^^^^^^^
   */

  /* Check optimization level */
  if (flg.opt > 4) {
    fprintf(stderr, "%s-W-Opt levels greater than 4 are not supported\n", version.lang);
  }
  /* -nostatic postprocessing */
  if (!flg.doprelink)
    flg.ipa |= 0x50; /* don't defer initialization, issue errors */

  /* Postprocess target architecture */
  do_set_tp(tp);
#ifdef OMP_OFFLOAD_LLVM
  if(omptp != NULL)
    flg.omptarget = TRUE;
#endif
  /* Vectorizer settings */
  flg.vect |= vect_val;
  if (flg.vect & 0x10)
    flg.x[19] &= ~0x10;
  if (flg.vect & 0x20)
    flg.x[19] &= ~8;
  set_yflag(34, 0x30);

  /* modexport file name */
  mod_combined_name(modexport_val);
  /* modindex file name */
  mod_combined_index(modindex_val);

  /* Extend source file lines */
  if (arg_extend)
    flg.extend_source = 132;

  /* Set module directory linked list
   * ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
   * FIXME this is bad, have different implementations for different string
   * lists, that needs to stop.
   */
  char **module_dir = module_dirs;
  while (module_dir && *module_dir) {
    moddir_list *mdl;
    NEW(mdl, moddir_list, 1);
    mdl->module_directory = *module_dir;
    mdl->next = NULL;
    if (module_directory_list == NULL) {
      module_directory_list = mdl;
    } else {
      moddir_list *link;
      for (link = module_directory_list; link->next; link = link->next)
        ;
      link->next = mdl;
    }
    ++module_dir;
  }

  flg.genilm = TRUE;
  /* set -x 49 0x400000, F90-style output */
  set_xflag(49, 0x400000);
  /* set -x 58 0x10000, handle all pointers */
  set_xflag(58, 0x10000);
  gbl.is_f90 = TRUE;
  /* set -x 58 0x40, and reset hpf flag, no static-init */
  set_xflag(58, 0x40);
  flg.defaulthpf = flg.hpf = FALSE;
  flg.defaultsequence = flg.sequence = TRUE;
  /* set -x 58 0x20000, allocate temps only as big as needed */
  set_xflag(58, 0x20000);

  if (XBIT(25, 0xf0)) {
    fprintf(stderr, "%s-I-Beta Release Optimizations Activated\n", version.lang);
  }

  if (flg.x[27] == -1)
    flg.x[27] = 4; /* default/max overlap of 4 */

  if (flg.es && !flg.p)
    flg.x[123] |= 0x100;

  empty_cl:
  if (sourcefile == NULL) {
    if (flg.ipa & 0x0a) {
      /* for IPA propagation or when generating static$init, no sourcefile */
      sourcefile = "pghpf.prelink.f";
      gbl.src_file = (char *)malloc(strlen(sourcefile) + 1);
      strcpy(gbl.src_file, sourcefile);
      gbl.srcfil = NULL;
      copy_curr_file = 0;
    } else {
      gbl.src_file = sourcefile = "STDIN.f";
      gbl.srcfil = stdin;
    }
    goto do_curr_file;
  }

  if (errflg)
    finish();

  if (ipa_import_mode) {
    char *s;
    if (!sourcefile) {
      gbl.src_file = (char *)malloc(strlen(sourcefile) + 1);
      strcpy(gbl.src_file, sourcefile);
      basenam(gbl.src_file, "", sourcefile);
    } else {
      sourcefile = "STDIN.f";
      gbl.src_file = (char *)malloc(strlen(sourcefile) + 1);
      strcpy(gbl.src_file, sourcefile);
    }
    file_suffix = "";
    for (s = gbl.src_file; *s; ++s) {
      if (*s == '.')
        file_suffix = s;
    }

  } else {
    if (!nosuffixcheck) {
      /* open sourcefile */
      for (i = 0; suffixes[i].nm; ++i) {
        int lsuf, lsrc;
        lsuf = strlen(suffixes[i].nm);
        lsrc = strlen(sourcefile);
        if (lsuf >= lsrc)
          continue;
        if (strcmp(sourcefile + (lsrc - lsuf), suffixes[i].nm))
          continue;
        gbl.src_file = mkfname(sourcefile, suffixes[i].nm, suffixes[i].nm);
        if ((gbl.srcfil = fopen(gbl.src_file, "r")) != NULL) {
          /* fill in flg.freeform, file_suffix, fpp_, gbl.src_file */
          if (flg.freeform == -1)
            flg.freeform = suffixes[i].form;
          file_suffix = suffixes[i].nm;
          if (suffixes[i].fpp) {
            if (preproc == -1 || preproc == 1)
              fpp_ = TRUE;
            /* -nopreproc overrides use of .F extension */
          }
          /* strip pathname, if any */
          /* use mkfname to allocate space */
          sourcefile = mkfname(gbl.src_file, file_suffix, file_suffix);
          /* base name strips the pathname */
          basenam(gbl.src_file, "", sourcefile);
          goto is_open;
        }
        /* ** else will be reported_as_an error(2...) below ** */
      }
    }
    if ((gbl.srcfil = fopen(sourcefile, "r")) != NULL) {
      /* fill in gbl.src_file, file_suffix */
      char *s;
      gbl.src_file = (char *)malloc(strlen(sourcefile) + 1);
      strcpy(gbl.src_file, sourcefile);
      basenam(gbl.src_file, "", sourcefile);
      file_suffix = "";
      for (s = gbl.src_file; *s; ++s) {
        if (*s == '.')
          file_suffix = s;
      }
      goto is_open;
    }
    /* not found */
    error(2, 4, 0, sourcefile, CNULL);
    is_open:
    if (preproc == 1)
      fpp_ = TRUE; /* -preproc forces preprocessing */
  }

  do_curr_file:

  if (gbl.file_name == NULL)
    gbl.file_name = gbl.src_file;
  if (sourcefile != NULL)
    gbl.module = mkfname(sourcefile, file_suffix, "");
  if (copy_curr_file)
    gbl.curr_file = gbl.src_file;

  /* process  object file: */

  gbl.objfil = NULL;

  if (sourcefile == NULL) {
    if (!flg.output || outfile_name == NULL) {
      gbl.outfil = stdout;
    } else {
      if ((gbl.outfil = fopen(outfile_name, "w")) == NULL)
        error(4, 0, 0, "Unable to open output file", outfile_name);
    }
    if (OUTPUT_DWARF && (dbg_file == NULL) && outfile_name != NULL) {
      /* make dwarf debug info file from the source file */
      mkDwfInfoFilename();
      if ((dbg_file = fopen(dbg_file_name, "wb")) == NULL)
        errfatal(9);
      dwarf_set_fn();
    } else {
      flg.debug = 0;
    }
    if (stboutfile != NULL) {
      char *tname;
      if ((gbl.stbfil = fopen(stboutfile, "w")) == NULL)
        errfatal(9);
    } else {
      gbl.stbfil = 0;
    }
  } else {
    char *tname;
    /* process listing file */
    if (flg.code || flg.list || flg.xref) {
      if (listfile == NULL) {
        /* make listing filename from sourcefile name */
        listfile = mkfname(sourcefile, file_suffix, LISTFILE);
      }
      if ((fd = fopen(listfile, "w")) == NULL)
        errfatal(3);
      list_init(fd);
    }
    if (OUTPUT_DWARF && (dbg_file == NULL)) {
      /* make dwarf debug info file from the source file */
      if (outfile_name != NULL) {
        mkDwfInfoFilename();
      } else {
        dbg_file_name = mkfname(sourcefile, file_suffix, ".dbg");
      }
      if ((dbg_file = fopen(dbg_file_name, "wb")) == NULL)
        errfatal(9);
    }
    if (stboutfile) {
      if ((gbl.stbfil = fopen(stboutfile, "w")) == NULL)
        errfatal(9);
    } else {
      gbl.stbfil = NULL;
    }

    /* process assembly output file */
    if (flg.asmcode) {
      if (asmfile == NULL) {
        /* make assembly filename from sourcefile name */
        asmfile = mkfname(sourcefile, file_suffix, ASMFILE);
      }
      if ((gbl.asmfil = fopen(asmfile, "w")) == NULL)
        errfatal(9);
    } else /* do this for compilers which write asm code to stdout */
      gbl.asmfil = stdout;
    /* process source output file */
    if (flg.output && !flg.es) {
      /* make output filename from sourcefile name */
      if (outfile_name == NULL) {
        outfile_name = mkfname(sourcefile, file_suffix, ".ilm");
      }
      if ((gbl.outfil = fopen(outfile_name, "w")) == NULL)
        error(4, 0, 0, "Unable to open output file", outfile_name);
    } else
      gbl.outfil = stdout;


    if (flg.doprelink && (flg.ipa & 0x03) == 0 && gbl.ipaname == NULL) {
      gbl.ipaname = mkfname(sourcefile, file_suffix, ".d");
      gbl.gblfil = NULL;
      unlink(gbl.ipaname);
    }

    /* create temporary file for preprocessor output & preprocess */
    if (!ipa_import_mode) {
      if (fpp_) {
        if (flg.es) {
          if (cppfile == NULL)
            gbl.cppfil = stdout;
          else if ((gbl.cppfil = fopen(cppfile, "w")) == NULL)
            errfatal(5);
        } else {
          if ((gbl.cppfil = tmpf("a")) == NULL)
            errfatal(5);
        }
        fpp();
        if (flg.es || gbl.maxsev >= 3)
          finish();
        if (flg.list)
          list_page();
        scan_init(gbl.cppfil);
      } else
        scan_init(gbl.srcfil);
    }
#if DEBUG
    assert(flg.es == 0, "init:flg.esA", 0, 0);
#endif
    assemble_init();
    if (OUTPUT_DWARF && dbg_file != NULL) {
      dwarf_set_fn();
    }
  }
  gbl.func_count = 0;

  if (XBIT(125, 0x8))
    gbl.ftn_true = 1;
  else
    gbl.ftn_true = -1;

  /*
   * direct_init() must be called at a point where we are sure that
   * the values of flg members, especially xflags, can be propagated
   * to the global, routine, etc. directive data structures. For example,
   * direct_init() can only be called after the code above which can
   * disable the cuda/accel features in the code by clearing their
   * respective xflags.
   */
  direct_init();

  /* set mach, currently need for -mp=align optimization on sandybridge */
  set_mach(&mach, flg.tpvalue[0]);

  return;
}

/* *************************************************************** */

static char *uses_name;

moddir_list *module_directory_list = NULL;

#if DEBUG

static void
do_debug(char *phase)
{
  if (debugfunconly > 0 && gbl.func_count != debugfunconly) {
    /* only for some functions */
    return;
  }
  if (dodebug)
    fprintf(gbl.dbgfil, "{%s after %s\n", feature, phase);

  current_phase = phase;
  execute_actions_for_keyword(phase_dump_map, phase);
} /* do_debug */

#endif /* if DEBUG */

/* call this routine to clean up data structures if not compiling all the
 * way to the end */
static void
cleanup(void)
{
  direct_rou_end();
  dinit_end();
  df_dinit_end();
  freearea(15);
  postprocessing = FALSE;
} /* cleanup */

static void
reptime(void)
{
  char buf[80];
  int i;
  INT total;
  int prct;
  int tmp;

  total = 0;
  for (i = 0; i < _N_WHO; i++)
    total += xtimes[i];

  if (!DBGBIT(0, 8) || DBGBIT(14, 3))
    goto xbitcheck;

  if (flg.code || flg.list || flg.xref) {
    list_line("");
    list_line("  Timing stats:");
  } else if (gbl.dbgfil)
    fprintf(gbl.dbgfil, "  Timing stats:\n");
  for (i = 0; i < _N_WHO; i++) {
    if (xtimes[i]) {
      tmp = 100 * xtimes[i];
      prct = tmp / total;
      sprintf(buf, "    %-10.10s %15d millisecs %5d%%", who[i], xtimes[i],
              prct);
      if (flg.code || flg.list || flg.xref)
        list_line(buf);
      else if (gbl.dbgfil)
        fprintf(gbl.dbgfil, "%s\n", buf);
    }
  }

  sprintf(buf, "    Total time %15d millisecs", total);
  if (flg.code || flg.list || flg.xref) {
    list_line(buf);
  } else if (gbl.dbgfil)
    fprintf(gbl.dbgfil, "%s\n", buf);

  xbitcheck:
  if (!XBIT(0, 1))
    return;
  fprintf(stderr, "  Timing stats:\n");

  for (i = 0; i < _N_WHO; i++) {
    if (xtimes[i]) {
      tmp = 100 * xtimes[i];
      prct = tmp / total;
      sprintf(buf, "    %-10.10s %15d millisecs %5d%%", who[i], xtimes[i],
              prct);
      fprintf(stderr, "%s\n", buf);
    }
  }
  sprintf(buf, "    Total time %15d millisecs", total);
  fprintf(stderr, "%s\n", buf);
}

static void
datastructure_reinit(void)
{
  /* initialize global variables:  */
  gbl.currsub = 0;
  gbl.arets = FALSE;
  gbl.rutype = RU_PROG;
  gbl.cmblks = NOSYM;
  gbl.externs = NOSYM;
  gbl.consts = NOSYM;
  gbl.locals = NOSYM;
  gbl.statics = NOSYM;
  gbl.ent_select = 0;
  gbl.stfuncs = NOSYM;
  gbl.locaddr = 0;
  gbl.saddr = 0;
  set_bss_addr(0);
  gbl.autobj = NOSYM;
  gbl.asgnlbls = 0;
  gbl.exitstd = 0;
  gbl.tp_adjarr = NOSYM;
  gbl.p_adjarr = NOSYM;
  gbl.p_adjstr = NOSYM;
  gbl.denorm = FALSE;
  gbl.inomptarget = false;
  /* restore opt flag to its original value */
  flg.opt = saveoptflag;
  flg.vect = savevectflag;
  flg.x[8] = savex8flag;
  flg.recursive = saverecursive;

  sym_init();   /* initialize symbol table module */
  dinit_init(); /* initialize data init file module  */
  /* close data initialization files */
  dinit_end();
  if (astb.df != NULL)
    fclose(astb.df);
  astb.df = NULL;

  astout_init();
} /* datastructure_reinit */

/** \brief perform initializations for new user subprogram unit.
*/
void
reinit(void)
{
  scan_opt_restore(); /* if OPTIONS statement was seen in prev */

  datastructure_reinit();

  semant_init(ipa_export_file != 0 && ipa_import_mode);
  /* initialize semantic analyzer.
   * WARNING:  when compiling module subprograms,
   * it's assumed that the certain data structures
   * (asts, dtypes, etc.) of entities in the
   * module specification part will have the same
   * indices when imported into a CONTAINS'd
   * subprogram. All inits, on which importing
   * module information depends, must be peformed
   * before semant_init().
   */
  if (flg.xref)
    xrefinit();   /* initialize cross reference module */
  dpm_out_init(); /* initialize dp output module -- should
                   * be replaced with call to transform_init().
                   */

  queue_tbp(0, 0, 0, 0, TBP_CLEAR_STALE_RECORDS);
}

/* *************************************************************** */

static int exitcode;

/** \brief set exit code for compiler (see finish() function)
    \param ec - the exit code to set
*/
void
set_exitcode(int ec)
{
  exitcode = ec;
}

/** \brief Write summary line to terminal, and exit compiler.
*/
void
finish(void)
{
  int maxfilsev;
  static int called = 0;

  if (!ipa_import_mode)
    scan_fini();
  if (IPA_INHERIT_ENABLED && (flg.opt >= 2 || IPA_COLLECTION_ENABLED)) {
    ipa_fini();
  }
  ipasave_fini();
  DUMP("fini");
  symtab_fini();
  fih_fini();
  ast_fini();
  direct_fini();
  sem_fini();
  mod_fini();
  if (XBIT(123, 0x30000)) {
    import_module_print();
  }

  called++;
  if (gbl.maxsev < 3 && called == 1 && (XBIT(123, 2) || XBIT(123, 8))) {
    FILE *fp;
    char *dependfile;

    if (XBIT(123, 8)) {
      /* -MD option:  Print list of include files to file <program>.d */
      dependfile = mkfname(gbl.module, "", ".d");
      if ((fp = fopen(dependfile, "w")) == NULL)
        errfatal(5);
    } else {
      /* -M option:  Print list of include files to stdout */
      fp = stdout;
    }
    if (gbl.moddependfil) {
      rewind(gbl.moddependfil);
      while (1) {
        int c;
        c = fgetc(gbl.moddependfil);
        if (c == EOF)
          break;
        fputc(c, fp);
      }
    }
    if (!XBIT(123, 0x40000)) {
      fprintf(fp, "%s%s : ", gbl.module, OBJFILE);
      fprintf(fp, "%s ", gbl.src_file);
    } else {
      fprintf(fp, "\"%s%s\" : ", gbl.module, OBJFILE);
      fprintf(fp, "\"%s\" ", gbl.src_file);
    }
    if (gbl.dependfil) {
      rewind(gbl.dependfil);
      while (1) {
        int c;
        c = fgetc(gbl.dependfil);
        if (c == EOF)
          break;
        fputc(c, fp);
      }
    }
    fputc('\n', fp);
    if (XBIT(123, 8))
      fclose(fp);
  }

  if (!flg.es) {
    reptime();
    maxfilsev = summary(TRUE, FALSE);
  } else
    maxfilsev = gbl.maxsev;

  if (maxfilsev >= 3) {
    /* remove objectfile if there were severe errors */
    if (flg.object && gbl.objfil)
      if (!DBGBIT(0, 16))
        unlink(objectfile);
  } else {
    if (gbl.objfil != NULL)
      fclose(gbl.objfil);
    if (IPA_ENABLED || IPA_INHERIT_ENABLED)
      ipasave_closefile();
    if (IPA_INHERIT_ENABLED)
      ipa_closefile();
    if (!flg.es) {
      fini();
    }
  }
  if (gbl.asmfil != NULL && gbl.asmfil != stdout)
    fclose(gbl.asmfil);
  if (gbl.outfil != NULL && gbl.outfil != stdout)
    fclose(gbl.outfil);
  if (IPA_ENABLED && ipa_export_file && !ipa_import_mode) {
    /* export the program unit for IPA recompilation */
    ipa_export_close();
  }

  freearea(8);      /* temporary filenames and pathnames space  */
  free_getitem_p(); /* getitem_p tbl contains area 8 pointers */
  destroy_action_map(&phase_dump_map);
  /*free( gbl.src_file );*/
  gbl.src_file = NULL;
  if (maxfilsev >= 3) {
    if (!XBIT(123, 0x40000) || exitcode == 0)
      exit(1);
    else
      exit(exitcode);
  } else
    exit(0);
}

/* ******************************************************************* */

/* dummies for dwarf */
FILE *dbg_file = NULL;
char *dbg_file_name = NULL;
void dwarf_set_fn(void) {}
void setrefsymbol(int symbol) {}
void scan_for_dwarf_module(void) {}

static void
do_set_tp(char *tp)
{
  if (tp) {
    if (strcmp(tp, "x64") == 0) {
      set_tp("k8-64");
      set_tp("p7-64");
    } else {
      set_tp(tp);
    }
  }
}

/** \brief This function creates a dwarf debug info filename from source file.
*/
static void
mkDwfInfoFilename(void)
{
  int i;
  /* first, find the file suffix of the output file (created by the driver) */
  for (i = strlen(outfile_name) - 1; i > 0; i--)
    if (outfile_name[i] == '.')
      break;
  if (i == 0)
    i = strlen(outfile_name) - 1; /* punt if no suffix */
  dbg_file_name = mkfname(outfile_name, &outfile_name[i], ".dbg");
}

/** \brief called at end of processing contains subprograms */
void
end_contained(void)
{
  lower_end_contains();
  if (ipa_export_file && !ipa_import_mode) {
    ipa_export_endcontained();
  }
}

static void
fini()
{
  assemble_end();
}

/* dummies required to link when we don't have IPA */

int IPA_Vestigial = 0;

void ipa_closefile() {}
void ipa_export() {}
void ipa_export_close() {}
void ipa_export_endcontained() {}
void ipa_export_endmodule() {}
void ipa_export_highpoint() {}
void ipa_export_open(char *export_filename) {}
void ipa_header1(int currfunc) {}
void ipa_header2(int currfunc) {}
void ipa_import_highpoint(void) {}
void ipa_import_open(char *import_file, BIGUINT offset) {}
void ipa_import(void) {}
void ipa_init() {}
void ipa_report() {}
void ipasave_closefile() {}
void ipasave_compname(char *name, int argc, char *argv[]) {}
void ipasave_endfunc() {}
void ipasave_fini(void) {}
void ipasave(void) {}
void ipa_startfunc(int currfunc) {}
void ipa_fini() {}
void fill_ipasym() {}
void ipa() {}
void ipa_set_vestigial_host() {}
int IPA_isnoconflict(int sptr) { return 0; }

static void set_ipa_export_file(char *name) {}
static void set_ipa_import_mode() {}
static void set_ipa_import_offset(char *offset) {}
static void set_debug(LOGICAL value) {}
static void set_debug_symbol(LOGICAL value) {}
static void set_debug_line(LOGICAL value) {}

