/*
 * Copyright (c) 1994-2019, 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
 * \brief Fortran parser module
 *
 *   contents:
 *
 *     parser()     - parse and semantically analyze one
 *                    user subprogram unit.
 *     parse_init() - initialize parsing of new statement.
 *     next_state(state, tkntyp) - look up next state in parse tables.
 *     prettytoken(tkntyp, tknval) - returns string of token
 */

#include "ccffinfo.h"
#include "gbldefs.h"
#include "gramtk.h"
#include "gramsm.h"
#include "global.h"
#include "error.h"
#include "symtab.h"
#include "semant.h"
#include "semstk.h"
#include "gramdf.h"
#if DEBUG
#include "proddf.h"
#endif
#include "tokdf.h"
#include "scan.h"

#define LOOP while (TRUE)
#define NOSTATE ((int)(-1))

typedef short int PSTACK;
static PSTACK *pstack;   /* parse stack */
static int sst_size = 0; /* current size of parse & semantic stacks */
static int cstate;       /* current parse state */
static int stktop;
static INT ctknval; /* 'value' of current token */
static int next_state(int, int);
static LOGICAL is_declaration(int);

/*  Function pointers indexed by sem.which_pass */
static void (*p_semant1[])(int, SST *) = {semant1, semant1};
static void (*p_semant2[])(int, SST *) = {NULL, semant2};
static void (*p_semant3[])(int, SST *) = {psemant3, semant3};
static void (*p_semantio[])(int, SST *) = {psemantio, semantio};
static void (*p_semsmp[])(int, SST *) = {psemsmp, semsmp};

static void _parser(void); /* core parsing function */
static char *prettytoken(int, INT);

void
parser(void)
{
  static int maxsev;
  LOGICAL skip_first_pass;
  ISZ_T save_bss_addr, save_saddr;
  int save_lineno;

  skip_first_pass = TRUE;
  if (gbl.internal == 0 && sem.mod_cnt <= 1) {
    /*
     * Perform the first pass on a subprogram or all module-contained
     * contained subprograms.  Semantic analysis is not performed on
     * the executable statements.
     */
    skip_first_pass = FALSE;
    sem.which_pass = 0;
    reset_internal_subprograms();
    save_bss_addr = get_bss_addr();
    save_saddr = gbl.saddr;
    save_lineno = gbl.lineno;
    if (!XBIT(120, 0x4000000)) {
      set_allfiles(0); /* Store file indexes */
    }
    fe_init(); /* init the scanner for the first parse */
#if DEBUG
    if (DBGBIT(1, 1) || DBGBIT(2, 1))
      fprintf(gbl.dbgfil, "-----  First Parse  -----\n");
#endif
    _parser();
    maxsev = gbl.maxsev;
    if (sem.mod_cnt) {
      /*
       * Either a module specification or the first module-contained
       * subprogram was just parsed.  If an error occurred, issue the
       * error summary now.
       */
      if (maxsev >= 3)
        summary(FALSE, FALSE);
      if (gbl.rutype == RU_BDATA)
        /*
         * A module specification part was parsed. Either:
         * 1.  a CONTAINS within the module terminated the first
         *     parse (scan sets scn.end_program_unit to TRUE), or
         * 2.  a module without contained subprograms was parsed.
         * Now, just produce the module-created blockdata - the second
         * parse isn't performed.
         */
        return;
      /*
       * At this point, either:
       * 1.  a module specification part with errors was parsed, or
       * 2.  the first module-contained subprogram was parsed (errors
       *     could have been detected).
       * Perform the first parse on the remaining contained subprograms,
       * recording the maximum error level detected for the all of the
       * contained subprograms.
       */
      while (sem.mod_cnt == 1) {
        reinit();
        errini();
        _parser();
        if (gbl.maxsev > maxsev)
          maxsev = gbl.maxsev;
        if (maxsev >= 3 && gbl.currsub)
          summary(FALSE, FALSE);
      }
    }
    resolve_fwd_refs();
    set_bss_addr(save_bss_addr);
    gbl.saddr = save_saddr;
    gbl.lineno = save_lineno;
    if (!XBIT(120, 0x4000000)) {
      set_allfiles(1); /* Retrieve file indexes */
    }
  }
/*
 * At this point, we're ready to perform the second parse (includes
 * executable statements).  The second parse is performed on a host
 * subprogram, an internal subprogram, or module-contained subprogram
 * if errors were not detected during the first parse.
 */
  if (maxsev < 3) {
    fe_restart();
    if (!skip_first_pass)
      reinit();
    sem.which_pass = 1;
    p_semant1[1] = semant1;
    p_semant2[1] = semant2;
#if DEBUG
    if (DBGBIT(1, 1) || DBGBIT(2, 1))
      fprintf(gbl.dbgfil, "-----  Second Parse  -----\n");
#endif
    _parser();
    resolve_fwd_refs();
    if (gbl.internal || sem.mod_cnt > 1)
      /*
       * If we're processing module-contained subprograms, make sure
       * the scanner is initialized for the next module subprogram.
       */
      fe_init();
  } else if (sem.mod_cnt == 2) {
    /*
     * One or more errors were detected in a module subprogram during the
     * the first parse. Don't perform the second parse on any of the
     * module subprograms.  The ensuing call to parser() will start the
     * first parse on the statement after the ENDMODULE statement.
     */
    end_module();
    sem.mod_cnt = 0;
    sem.mod_sym = 0;
    sem.submod_sym = 0;
  }
}

static void
_parser(void)
{
  int tkntyp, newtop, rednum, get_token(), endflg;
  int t;
  int start, end, nstate;
  int jstart, jend, ptr, i;
  char *ptoken;

  endflg = 0;
  sst_size = SST_SIZE;
  NEW(pstack, PSTACK, sst_size);
  if (pstack == NULL)
    error(7, 4, 0, CNULL, CNULL);
  NEW(sst, SST, sst_size);
  if (sst == NULL)
    error(7, 4, 0, CNULL, CNULL);

  /* set funcline to a best guess value in case profiling info is
     requested for an unnamed program */
  gbl.funcline = gbl.lineno + 1;

  /* loop once for each statement in subprogram unit:  */

  LOOP
  {

    parse_init();

    /* loop once for each token in current Fortran stmt: */

    tkntyp = get_token(&ctknval); /* first token of a statement */

    if (sem.which_pass == 0) {
      /*
       * For the first pass, we want to semantically analyze expressions
       * only if they occur within a declaration statement.  Also, there
       * are semantic actions shared by the semantic analysis routines
       * for declaration and executable statements; for the first
       * pass, we only want these actions to be performed only if they
       * occur within the declarations statements.
       */
      if (is_declaration(tkntyp) ||
          (tkntyp == TK_GENERIC && sem.type_mode == 2) /* generic tbp */
          ) {
        p_semant1[0] = semant1;
        p_semant2[0] = semant2;
      } else {
        p_semant2[0] = psemant2;
      }
      gbl.nowarn = FALSE;
    } else {
      if (is_declaration(tkntyp)) {
        /* warnings issued in first pass for declarations */
        gbl.nowarn = TRUE;
      } else {
        gbl.nowarn = FALSE;
      }
    }

    LOOP
    {
#if DEBUG
      if (tkntyp < 1 || tkntyp >= (sizeof(tokname) / sizeof(char *))) {
        interr("scan error in parser", tkntyp, 3);
        tkntyp = TK_END;
      }
#endif
      if (scn.end_program_unit)
        endflg = 1;

      if (DBGBIT(1, 1)) {
        fprintf(gbl.dbgfil, "tkntyp: %s tknval: %d", tokname[tkntyp], ctknval);
        if (tkntyp == TK_IDENT)
          fprintf(gbl.dbgfil, " (%s)", scn.id.name + ctknval);
        fprintf(gbl.dbgfil, " lineno: %d \n", gbl.lineno);
      }

      /*
       * loop once for each reduction which can be made with tkntyp as
       * look ahead token (note that a production index may be 0):
       */
      LOOP
      {

        /*
         * perform binary search on parse tables to determine if a
         * reduction can be made:
         */
        start = fred[cstate];
        end = fred[cstate + 1] - 1;
        if (start > end)
          break; /* no reduction */
        for (i = start; i <= end; i++) {
          jstart = lset[nset[i]];
          jend = lset[nset[i] + 1] - 1;
          while (jstart <= jend) {
            ptr = (jstart + jend) >> 1;
            t = ls[ptr];
            if (t == tkntyp)
              goto perform_reduction;
            if (t < tkntyp)
              jstart = ptr + 1;
            else
              jend = ptr - 1;
          }
        }
        break; /* no reduction found */

      perform_reduction:
        rednum = prod[i];
        sem.tkntyp = tkntyp;
        if (DBGBIT(2, 1))
#if DEBUG
          fprintf(gbl.dbgfil, "%4d %crod(%4d) %s\n",
                  gbl.lineno, sem.which_pass ? 'P' : 'p',
                  rednum, prodstr[rednum]);
#else
          fprintf(gbl.dbgfil, "     %cednum: %d\n",
                  sem.which_pass ? 'R' : 'r', rednum);
#endif

        /* call appropriate semantic action routine: */

        newtop = stktop - len[rednum] + 1;
        if (rednum < SEM2)
          p_semant1[sem.which_pass](rednum, &sst[newtop]);
        else if (rednum < SEM3)
          p_semant2[sem.which_pass](rednum, &sst[newtop]);
        else if (rednum < SEM4)
          p_semant3[sem.which_pass](rednum, &sst[newtop]);
        else if (rednum < SEM5)
          p_semantio[sem.which_pass](rednum, &sst[newtop]);
        else
          p_semsmp[sem.which_pass](rednum, &sst[newtop]);

        if (sem.ignore_stmt) {
          sem.ignore_stmt = FALSE;
          goto ignore_stmt;
        }

        /* look for reduce transition:    */

        nstate = next_state(pstack[newtop - 1], (int)lhs[rednum]);
        if (nstate == NOSTATE)
          goto issue_error;
        else {
          cstate = nstate;
          pstack[newtop] = nstate;
          stktop = newtop;
        }
      } /* end of reduce loop. */

      /* look for a read transition:  */

      nstate = next_state(cstate, tkntyp);
      if (nstate == NOSTATE) {
        /* tpr 535
         * the grammar cannot be modified to support complex
         * constants of the form '( const-expr , const-expr )' but
         * can modified if a special token is returned for ',' (i.e.,
         * a "complex comma").
         * if a syntax error occurs when the current token is a comma,
         * check if a "complex comma" is legal; if so, continue
         * by parsing as if we have a complex constant, and semant
         * will determine if the real & imag parts are constants.
         */
        if (tkntyp == TK_COMMA) {
          nstate = next_state(cstate, TK_CMPLXCOMMA);
          if (nstate != NOSTATE) {
            if (DBGBIT(1, 1))
              fprintf(gbl.dbgfil, ">>> comma changed to complex comma %d\n",
                      gbl.lineno);
            goto read_trans;
          }
        }
      issue_error:

        ptoken = prettytoken(tkntyp, ctknval);
        errWithSrc(34, 3, gbl.lineno, ptoken, CNULL, getCurrColumn(), 1, false,
                   getDeduceStr(ptoken));
        sem.psfunc = FALSE; /* allow no stmt func defs */
        break;
      }
    read_trans:
      stktop++;
      if (stktop >= sst_size) {
        sst_size += SST_SIZE;
        pstack = (PSTACK *)sccrelal((char *)pstack,
                                    ((BIGUINT64)((sst_size) * sizeof(PSTACK))));
        sst = (SST *)sccrelal((char *)sst, ((BIGUINT64)((sst_size) * sizeof(SST))));
        assert(pstack != NULL, "parser:stack ovflw", stktop, 4);
        assert(sst != NULL, "parser:stack ovflw", stktop, 4);
      }
      pstack[stktop] = nstate;
      SST_SYMP(&sst[stktop], ctknval);
      SST_LINENOP(&sst[stktop], gbl.lineno);
      SST_COLUMNP(&sst[stktop], getCurrColumn());
      cstate = nstate;

      if (tkntyp == TK_EOL) {
        if (endflg == 1)
          goto parse_done;

        if (!scn.multiple_stmts && gbl.eof_flag ) { 
          if (gbl.empty_contains) {
            gbl.internal = 0;
            goto parse_done;
          }

          errsev(22);
          sem.mod_cnt = 0;
          sem.mod_sym = 0;
          sem.submod_sym = 0;
          goto parse_done;
        }
        break;
      }

      tkntyp = get_token(&ctknval); /* next token in the statement */

    } /* end foreach token LOOP */

  ignore_stmt:;

  } /* end foreach statement LOOP */

parse_done:
  FREE(pstack);
  FREE(sst);
  pstack = NULL;
  sst = NULL;
  sst_size = 0;
}

/*  Initialize parser to begin parsing of next Fortran statement */
void
parse_init(void)
{
  pstack[0] = 0;
  pstack[1] = 1;
  cstate = 1;
  stktop = 1;

  scan_reset();
}

/*  Return next parse state, given current state and look ahead
    token.  NOSTATE is returned if there is no next state (syntax
    error).
*/
static int
next_state(int state, int tkntyp)
{
  int start, end, ptr, t;

  start = ftrn[state];
  end = ftrn[state + 1] - 1;

  while (start <= end) {
    ptr = (start + end) >> 1;
    t = ent[tran[ptr]];
    if (t == tkntyp)
      return (tran[ptr]);
    if (t < tkntyp)
      start = ptr + 1;
    else
      end = ptr - 1;
  }
  return (NOSTATE);
}

static char *
prettytoken(int tkntyp, INT tknval)
{
  static char symbuf[132];
  INT v[2];

  switch (tkntyp) {
  case TK_EOL:
    sprintf(symbuf, "end of line");
    break;
  case TK_IDENT:
  case TK_NAMED_CONSTRUCT:
    sprintf(symbuf, "identifier %s", scn.id.name + tknval);
    break;
  case TK_LOGCONST:
    sprintf(symbuf, "logical constant %s",
            tknval == SCFTN_TRUE ? ".TRUE." : ".FALSE.");
    break;
  case TK_K_LOGCONST:
    sprintf(symbuf, "logical literal %s", getprint((int)tknval));
    break;
  case TK_ICON:
    sprintf(symbuf, "integer constant %d", tknval);
    break;
  case TK_K_ICON:
    sprintf(symbuf, "integer literal %s", getprint((int)tknval));
    break;
  case TK_RCON:
    strcpy(symbuf, "real constant ");
    v[0] = tknval;
    v[1] = 0;
    cprintf(symbuf + 14, "%.7e", v);
    break;
  case TK_DCON:
    sprintf(symbuf, "doubleprecision constant %s", getprint((int)tknval));
    break;
  case TK_CCON:
    sprintf(symbuf, "complex constant %s", getprint((int)tknval));
    break;
  case TK_DCCON:
    sprintf(symbuf, "doublecomplex constant %s", getprint((int)tknval));
    break;
  case TK_HOLLERITH:
    sprintf(symbuf, "hollerith constant %10.10s",
            stb.n_base + CONVAL1G(tknval));
    break;
  case TK_NONDDEC:
    sprintf(symbuf, "%s", getprint((int)tknval));
    break;
  case TK_NONDEC:
    sprintf(symbuf, "non-decimal constant %x", tknval);
    break;
  case TK_CMPLXCOMMA:
    sprintf(symbuf, ",");
    break;
  case TK_IOLP:
  case TK_IMPLP:
    sprintf(symbuf, "(");
    break;
  case TK_EQ:
    if (tknval)
      sprintf(symbuf, "==");
    else
      sprintf(symbuf, "%s", tokname[tkntyp]);
    break;
  case TK_GE:
    if (tknval)
      sprintf(symbuf, ">=");
    else
      sprintf(symbuf, "%s", tokname[tkntyp]);
    break;
  case TK_GT:
    if (tknval)
      sprintf(symbuf, ">");
    else
      sprintf(symbuf, "%s", tokname[tkntyp]);
    break;
  case TK_LE:
    if (tknval)
      sprintf(symbuf, "<=");
    else
      sprintf(symbuf, "%s", tokname[tkntyp]);
    break;
  case TK_LT:
    if (tknval)
      sprintf(symbuf, "<");
    else
      sprintf(symbuf, "%s", tokname[tkntyp]);
    break;
  case TK_NE:
    if (tknval == (('/' << 8) | '='))
      sprintf(symbuf, "/=");
    else if (tknval == (('<' << 8) | '>'))
      sprintf(symbuf, "<>");
    else
      sprintf(symbuf, "%s", tokname[tkntyp]);
    break;
  case TK_DIMATTR:
    sprintf(symbuf, "DIMENSION");
    break;
  case TK_MP_ATOMIC:
    sprintf(symbuf, "ATOMIC");
    break;
  case TK_MP_BARRIER:
    sprintf(symbuf, "BARRIER");
    break;
  case TK_MP_CANCEL:
    sprintf(symbuf, "%s", "CANCEL");
    break;
  case TK_MP_CRITICAL:
    sprintf(symbuf, "CRITICAL");
    break;
  case TK_MP_DECLAREREDUCTION:
    sprintf(symbuf, "%s", "DECLAREREDUCTION");
    break;
  case TK_MP_DECLARESIMD:
    sprintf(symbuf, "%s", "DECLARESIMD");
    break;
  case TK_MP_DECLARETARGET:
    sprintf(symbuf, "%s", "DECLARETARGET");
    break;
  case TK_MP_DISTPARDO:
    sprintf(symbuf, "%s", "DISTRIBUTEPARALLELDO");
    break;
  case TK_MP_DISTPARDOSIMD:
    sprintf(symbuf, "%s", "DISTRIBUTEPARALLELDOSIMD");
    break;
  case TK_MP_DISTRIBUTE:
    sprintf(symbuf, "%s", "DISTRIBUTE");
    break;
  case TK_MP_DISTSIMD:
    sprintf(symbuf, "%s", "DISTRIBUTESIMD");
    break;
  case TK_MP_DOSIMD:
    sprintf(symbuf, "%s", "DOSIMD");
    break;
  case TK_MP_DOACROSS:
    sprintf(symbuf, "DOACROSS");
    break;
  case TK_MP_ENDCRITICAL:
    sprintf(symbuf, "ENDCRITICAL");
    break;
  case TK_MP_ENDMASTER:
    sprintf(symbuf, "ENDMASTER");
    break;
  case TK_MP_ENDORDERED:
    sprintf(symbuf, "ENDORDERED");
    break;
  case TK_MP_ENDPARALLEL:
    sprintf(symbuf, "ENDPARALLEL");
    break;
  case TK_MP_ENDPARDO:
    sprintf(symbuf, "ENDPARALLELDO");
    break;
  case TK_MP_ENDPARSECTIONS:
    sprintf(symbuf, "ENDPARALLELSECTIONS");
    break;
  case TK_MP_ENDPDO:
    sprintf(symbuf, "ENDDO");
    break;
  case TK_MP_ENDSECTIONS:
    sprintf(symbuf, "ENDSECTIONS");
    break;
  case TK_MP_ENDSINGLE:
    sprintf(symbuf, "ENDSINGLE");
    break;
  case TK_MP_ENDDOSIMD:
    sprintf(symbuf, "ENDDOSIMD");
    break;
  case TK_MP_ENDDISTPARDO:
    sprintf(symbuf, "%s", "ENDDISTRIBUTEPARALLELDO");
    break;
  case TK_MP_ENDDISTPARDOSIMD:
    sprintf(symbuf, "%s", "ENDDISTRIBUTEPARALELLDOSIMD");
    break;
  case TK_MP_ENDDISTRIBUTE:
    sprintf(symbuf, "%s", "ENDDISTRIBUTE");
    break;
  case TK_MP_ENDDISTSIMD:
    sprintf(symbuf, "%s", "ENDDISTRIBUTESIMD");
    break;
  case TK_MP_ENDPARDOSIMD:
    sprintf(symbuf, "%s", "ENDPARALLELDOSIMD");
    break;
  case TK_MP_ENDSIMD:
    sprintf(symbuf, "%s", "ENDSIMD");
    break;
  case TK_MP_ENDTARGET:
    sprintf(symbuf, "%s", "ENDTARGTARGET");
    break;
  case TK_MP_ENDTASK:
    sprintf(symbuf, "%s", "ENDTASK");
    break;
  case TK_MP_ENDTASKLOOP:
    sprintf(symbuf, "%s", "ENDTASKLOOP");
    break;
  case TK_MP_ENDTASKLOOPSIMD:
    sprintf(symbuf, "%s", "ENDTASKLOOPSIMD");
    break;
  case TK_MP_ENDTEAMS:
    sprintf(symbuf, "%s", "ENDTEAMS");
    break;
  case TK_MP_ENDTEAMSDIST:
    sprintf(symbuf, "%s", "ENDTEAMSDISTRIBUTE");
    break;
  case TK_MP_ENDTEAMSDISTPARDO:
    sprintf(symbuf, "%s", "ENDTEAMSDISTRIBUTEPARALLELDO");
    break;
  case TK_MP_ENDTEAMSDISTPARDOSIMD:
    sprintf(symbuf, "%s", "ENDTEAMSDISTRIBUTEPARALLELDOSIMD");
    break;
  case TK_MP_ENDTEAMSDISTSIMD:
    sprintf(symbuf, "%s", "ENDTEAMSDISTRIBUTESIMD");
    break;
  case TK_MP_FLUSH:
    sprintf(symbuf, "FLUSH");
    break;
  case TK_MP_MASTER:
    sprintf(symbuf, "MASTER");
    break;
  case TK_MP_ORDERED:
    sprintf(symbuf, "ORDERED");
    break;
  case TK_MP_PARALLEL:
    sprintf(symbuf, "PARALLEL");
    break;
  case TK_MP_PARDO:
    sprintf(symbuf, "PARALLELDO");
    break;
  case TK_MP_PARSECTIONS:
    sprintf(symbuf, "PARALLELSECTIONS");
    break;
  case TK_MP_PARDOSIMD:
    sprintf(symbuf, "%s", "PARALLELDOSIMD");
    break;
  case TK_MP_PDO:
    sprintf(symbuf, "DO");
    break;
  case TK_MP_SECTION:
    sprintf(symbuf, "SECTION");
    break;
  case TK_MP_SECTIONS:
    sprintf(symbuf, "SECTIONS");
    break;
  case TK_MP_SINGLE:
    sprintf(symbuf, "SINGLE");
    break;
  case TK_MP_SIMD:
    sprintf(symbuf, "SIMD");
    break;
  case TK_MP_TARGET:
    sprintf(symbuf, "%s", "TARGET");
    break;
  case TK_MP_TARGETDATA:
    sprintf(symbuf, "%s", "TARGETDATA");
    break;
  case TK_MP_TARGETENTERDATA:
    sprintf(symbuf, "%s", "TARGETENTERDATA");
    break;
  case TK_MP_TARGETEXITDATA:
    sprintf(symbuf, "%s", "TARGETEXITDATA");
    break;
  case TK_MP_TARGETUPDATE:
    sprintf(symbuf, "%s", "TARGETUPDATE");
    break;
  case TK_MP_TARGPAR:
    sprintf(symbuf, "%s", "TARGETPAR");
    break;
  case TK_MP_TARGPARDO:
    sprintf(symbuf, "%s", "TARGETPARALLELDO");
    break;
  case TK_MP_TARGPARDOSIMD:
    sprintf(symbuf, "%s", "TARGETPARALLELDOSIMD");
    break;
  case TK_MP_TARGPARSIMD:
    sprintf(symbuf, "%s", "TARGETPARALLELSIMD");
    break;
  case TK_MP_TARGSIMD:
    sprintf(symbuf, "%s", "TARGETSIMD");
    break;
  case TK_MP_TARGTEAMS:
    sprintf(symbuf, "%s", "TARGETTEAMS");
    break;
  case TK_MP_TARGTEAMSDIST:
    sprintf(symbuf, "%s", "TARGETTEAMSDISTRIBUTE");
    break;
  case TK_MP_TARGTEAMSDISTPARDO:
    sprintf(symbuf, "%s", "TARGETTEAMSDISTRIBUTEPARALLELDO");
    break;
  case TK_MP_TARGTEAMSDISTPARDOSIMD:
    sprintf(symbuf, "%s", "TARGETTEAMSDISTRIBUTEPARALLELDOSIMD");
    break;
  case TK_MP_TARGTEAMSDISTSIMD:
    sprintf(symbuf, "%s", "TARGETTEAMSDISTRIBUTESIMD");
    break;
  case TK_MP_TASK:
    sprintf(symbuf, "%s", "TASK");
    break;
  case TK_MP_TASKLOOP:
    sprintf(symbuf, "%s", "TASKLOOP");
    break;
  case TK_MP_TASKLOOPSIMD:
    sprintf(symbuf, "%s", "TASKLOOPSIMD");
    break;
  case TK_MP_TEAMS:
    sprintf(symbuf, "%s", "TEAMS");
    break;
  case TK_MP_TEAMSDIST:
    sprintf(symbuf, "%s", "TEAMSDISTRIBUTE");
    break;
  case TK_MP_TEAMSDISTPARDO:
    sprintf(symbuf, "%s", "TEAMSDISTRIBUTEPARALLELDO");
    break;
  case TK_MP_TEAMSDISTPARDOSIMD:
    sprintf(symbuf, "%s", "TEAMSDISTRIBUTEPARALLELDOSIMD");
    break;
  case TK_MP_TEAMSDISTSIMD:
    sprintf(symbuf, "%s", "TEAMSDISTRIBUTESIMD");
    break;
  case TK_MP_THREADPRIVATE:
    sprintf(symbuf, "THREADPRIVATE");
    break;
  default:
    sprintf(symbuf, "%s", tokname[tkntyp]);
    break;
  }
  return symbuf;
}

static LOGICAL
is_declaration(int tkntyp)
{
  switch (tkntyp) {
  /*
   * It would be better if the tokens which can begin a declaration statement
   * were produced by prstab.
   */
  case TK_ENDSTMT:
  case TK_DIMATTR:
  case TK_DIRECTIVE:
  case TK_EMPTYFILE:
  case TK_ABSTRACT:
#ifdef TK_ACCDECL
  case TK_ACCDECL:
#endif
  case TK_ALIAS:
  case TK_ALIGN:
  case TK_ALLOCATABLE:
  case TK_ASYNCHRONOUS:
  case TK_ATTRIBUTES:
  case TK_AUTOMATIC:
  case TK_BIND:
  case TK_BLOCKDATA:
  case TK_BYTE:
  case TK_CHARACTER:
  case TK_CLASS:
  case TK_COMMON:
  case TK_COMPLEX:
  case TK_CONTIGUOUS:
  case TK_DATA:
  case TK_DIMENSION:
  case TK_DBLECMPLX:
  case TK_DBLEPREC:
#ifdef TK_DECLARE
  case TK_DECLARE:
#endif
  case TK_ELEMENTAL:
  case TK_ENDBLOCKDATA:
  case TK_ENDENUM:
  case TK_ENDFUNCTION:
  case TK_ENDINTERFACE:
  case TK_ENDMAP:
  case TK_ENDMODULE:
  case TK_ENDPROCEDURE:
  case TK_ENDPROGRAM:
  case TK_ENDSTRUCTURE:
  case TK_ENDSUBMODULE:
  case TK_ENDSUBROUTINE:
  case TK_ENDTYPE:
  case TK_ENDUNION:
  case TK_ENTRY:
  case TK_ENUM:
  case TK_ENUMERATOR:
  case TK_EOL: /* just so is_executable() will produce FALSE */
  case TK_EQUIV:
  case TK_EXTERNAL:
  case TK_FINAL:
  case TK_FUNCTION:
  case TK_IGNORE_TKR:
  case TK_IMPORT:
  case TK_IMPLICIT:
  case TK_IMPURE:
  case TK_INCLUDE:
  case TK_INTEGER:
  case TK_INTENT:
  case TK_INTERFACE:
  case TK_INTRINSIC:
  case TK_LOCAL:
  case TK_LOGICAL:
  case TK_MAP:
  case TK_MODULE:
  case TK_MOVEDESC:
  case TK_MP_DECLAREREDUCTION:
  case TK_MP_DECLARESIMD:
  case TK_MP_DECLARETARGET:
  case TK_MP_THREADPRIVATE:
  case TK_NAMELIST:
  case TK_NCHARACTER:
  case TK_NON_INTRINSIC:
  case TK_NOSEQUENCE:
  case TK_OPTIONAL:
  case TK_OPTIONS:
  case TK_PARAMETER:
  case TK_POINTER:
  case TK_PRIVATE:
  case TK_PROCEDURE:
  case TK_PROGRAM:
  case TK_PROTECTED:
  case TK_PUBLIC:
  case TK_PURE:
  case TK_REAL:
  case TK_RECORD:
  case TK_RECURSIVE:
  case TK_SAVE:
  case TK_SEQUENCE:
  case TK_STATIC:
  case TK_STRUCTURE:
  case TK_SUBMODULE:
  case TK_SUBROUTINE:
  case TK_TARGET:
  case TK_TCONTAINS:
  case TK_TPROCEDURE:
  case TK_TYPE:
  case TK_UNION:
  case TK_USE:
  case TK_VALUE:
  case TK_VOLATILE:
    return TRUE;
  default:
    break;
  }
  return FALSE;
}

LOGICAL
is_executable(int tkntyp)
{
  return !is_declaration(tkntyp);
}

#if DEBUG
static FILE *dfile = NULL;

void
dumpsst(SST *stk)
{
  int ast, sptr;
  dfile = gbl.dbgfil ? gbl.dbgfil : stderr;
  switch (SST_IDG(stk)) {
  case S_NULL:
    fprintf(dfile, "null");
    break;
  case S_CONST:
    fprintf(dfile, "const");
    break;
  case S_EXPR:
    fprintf(dfile, "expr");
    break;
  case S_LVALUE:
    fprintf(dfile, "lvalue");
    break;
  case S_LOGEXPR:
    fprintf(dfile, "logexpr");
    break;
  case S_STAR:
    fprintf(dfile, "star");
    break;
  case S_VAL:
    fprintf(dfile, "val");
    break;
  case S_IDENT:
    fprintf(dfile, "ident");
    sptr = SST_SYMG(stk);
    fprintf(dfile, " sptr=%d", sptr);
    if (sptr > 0 && sptr < stb.stg_avail) {
      fprintf(dfile, "=%s", SYMNAME(sptr));
    }
    break;
  case S_LABEL:
    fprintf(dfile, "label");
    break;
  case S_STFUNC:
    fprintf(dfile, "stfunc");
    break;
  case S_REF:
    fprintf(dfile, "ref");
    break;
  case S_TRIPLE:
    fprintf(dfile, "triple");
    break;
  case S_KEYWORD:
    fprintf(dfile, "keyword");
    break;
  case S_ACONST:
    fprintf(dfile, "aconst");
    break;
  case S_SCONST:
    fprintf(dfile, "sconst");
    break;
  case S_DERIVED:
    fprintf(dfile, "derived");
    break;
  default:
    fprintf(dfile, "ID=%d", SST_IDG(stk));
  }
  if (SST_PARENG(stk))
    fprintf(dfile, " paren");
  if (SST_ALIASG(stk))
    fprintf(dfile, " alias");
  ast = SST_ASTG(stk);
  if (ast) {
    fprintf(dfile, " ast=%d", ast);
    if (ast > 0) {
      fprintf(dfile, "\n");
      dump_ast_tree(ast);
    }
  }
  fprintf(dfile, "\n");
} /* dumpsst */

void
dumppstack(void)
{
  int i;

  dfile = gbl.dbgfil ? gbl.dbgfil : stderr;
  fprintf(dfile, "Semant stack\n");
  for (i = stktop; i >= 0; --i) {
    fprintf(dfile, "[%d] ", i);
    dumpsst(&sst[i]);
  }
} /* dumppstack */
#endif