/*
 * Copyright (c) 2006-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
   \brief Do "points to" analysis; save information in NME and PTE structures
 */
/*
 * ###
 * handle struct member LHS
 * check that function arguments and return value are handled properly
 *
 * F90 - pointer arguments handled properly, also pointer return values via IPA
 * F90 - IPA initial values
 */

#include "gbldefs.h"
#include "global.h"
#include "error.h"
#include "symtab.h"
#include "nme.h"
#include "ast.h"
#include "gramtk.h"
#include "pd.h"
#include "optimize.h"

#define TRACEFLAG 10
#define TRACEBIT 0x100000
#define TRACESTRING "pte-"
#include "trace.h"

/*
 * The data structures used:
 * . temporary pointer descriptor (TPD) structure, used while processing a
 *   single statement.  This is used to build the subsequent data structures.
 *   descriptor type, symbol table pointer, integer value
 * . pointer source descriptor (PSD), used to describe the pointers assigned
 *   in the program.  This is quite like a persistent PD; the number of these
 *   is the 'width' of the data flow value carried between blocks.
 * . pointer assignment (PA), describes the LHS with a PSD, and the RHS
 *   with either another PSD, for assignment like p=q, or ++p, or with
 *   a pointer target entry if the RHS is a constant address, like p=&a
 *   or p=NULL.
 *
 *  tpdx = index to temporary pointer descriptor
 *  psdx = index to pointer source descriptor
 *  ptex = index to pointer target entry
 *  atex = index to actual target entry
 *  asx  = index to assignment table
 *  sl   = slot number
 *  sptr = symbol table pointer
 *  bihx = block table index
 *  ilix = ili table index
 *  iltx = ilt table index
 *  nmex = nme table index
 */

/*
 * This is a temporary pointer descriptor (TPD) data structure, to hold
 * addresses
 * while processing a single statement
 */
typedef struct {
  int type;
  int sym;
  int val;
  int link;
} TPD;

static STG_DECLARE(gtpd, TPD) = { STG_INIT };

#if DEBUG
#define TTYPE(tpdx)                                            \
  gtpd.stg_base[tpdx >= 0 && tpdx < gtpd.stg_avail             \
                    ? tpdx                                     \
                    : (interr("bad TTYPE index", tpdx, 4), 0)] \
      .type
#define TSYM(tpdx)                                            \
  gtpd.stg_base[tpdx >= 0 && tpdx < gtpd.stg_avail            \
                    ? tpdx                                    \
                    : (interr("bad TSYM index", tpdx, 4), 0)] \
      .sym
#define TVAL(tpdx)                                            \
  gtpd.stg_base[tpdx >= 0 && tpdx < gtpd.stg_avail            \
                    ? tpdx                                    \
                    : (interr("bad TVAL index", tpdx, 4), 0)] \
      .val
#define TLINK(tpdx)                                            \
  gtpd.stg_base[tpdx >= 0 && tpdx < gtpd.stg_avail             \
                    ? tpdx                                     \
                    : (interr("bad TLINK index", tpdx, 4), 0)] \
      .link
#else
#define TTYPE(tpdx) gtpd.stg_base[tpdx].type
#define TSYM(tpdx) gtpd.stg_base[tpdx].sym
#define TVAL(tpdx) gtpd.stg_base[tpdx].val
#define TLINK(tpdx) gtpd.stg_base[tpdx].link
#endif

/* unknown target */
#define TT_UNINIT 0x100
/* unknown target */
#define TT_UNK 0x110
/* unknown global ... used for type target or for dummy pointer source */
#define TT_GLOB 0x120
/* precise symbol */
#define TT_PSYM 0x130
/* imprecise symbol */
#define TT_ISYM 0x140
/* anonymous memory, from IPA */
#define TT_ANON 0x150
/* dynamically allocated memory, also from IPA */
#define TT_GDYN 0x160
/* imprecise dynamically allocated memory, also from IPA */
#define TT_IGDYN 0x170
/* dynamically allocated memory, from this function call */
#define TT_LDYN 0x180
/* imprecise dynamically allocated memory, from this function call */
#define TT_ILDYN 0x190
/* constant address, used for NULL */
#define TT_CON 0x1a0
/* indirection */
#define TT_IND 0x1b0
/* imprecise indirection */
#define TT_IIND 0x1c0
/* member */
#define TT_MEM 0x1d0
/* nonlocal memory */
#define TT_NLOC 0x1e0

#define TTE_NULL -1

/* MUSTFLAG is set if this is a must point to situation
   IMPFLAG is set if this is an imprecise descriptor */
#define TTMUSTFLAG 1
#define TTIMPFLAG 2
/* remove MUST flag */
#define TTMASKMUST(typ) ((typ)&0xfffe)
/* remove MUST and IMP flags */
#define TTMASK(typ) ((typ)&0xfffd)
#define TTMUST(typ) ((typ)&TTMUSTFLAG)
#define TTIMP(typ) ((typ)&TTIMPFLAG)

/*
 * this is a temporary pointer source descriptor (PSD)
 * it looks a lot like NMEs (but no subscripts, yes struct members)
 */
typedef struct {
  int type;
  int parent;
  int sym;
  int next;  /* next PSD with same parent */
  int child; /* child PSD */
  int slot;
  int hashlk;
} PSD;

static struct {
  STG_MEMBERS(PSD);
  int *slot;
  int nslots;
} gpsd = {STG_INIT, NULL, 0};

#if DEBUG
#define PSD_TYPE(psdx)                                            \
  gpsd.stg_base[psdx >= 0 && psdx < gpsd.stg_avail                \
                    ? psdx                                        \
                    : (interr("bad PSD_TYPE index", psdx, 4), 0)] \
      .type
#define PSD_PARENT(psdx)                                            \
  gpsd.stg_base[psdx >= 0 && psdx < gpsd.stg_avail                  \
                    ? psdx                                          \
                    : (interr("bad PSD_PARENT index", psdx, 4), 0)] \
      .parent
#define PSD_SYM(psdx)                                            \
  gpsd.stg_base[psdx >= 0 && psdx < gpsd.stg_avail               \
                    ? psdx                                       \
                    : (interr("bad PSD_SYM index", psdx, 4), 0)] \
      .sym
#define PSD_CHILD(psdx)                                            \
  gpsd.stg_base[psdx >= 0 && psdx < gpsd.stg_avail                 \
                    ? psdx                                         \
                    : (interr("bad PSD_CHILD index", psdx, 4), 0)] \
      .child
#define PSD_NEXT(psdx)                                            \
  gpsd.stg_base[psdx >= 0 && psdx < gpsd.stg_avail                \
                    ? psdx                                        \
                    : (interr("bad PSD_NEXT index", psdx, 4), 0)] \
      .next
#define PSD_HASHLK(psdx)                                            \
  gpsd.stg_base[psdx >= 0 && psdx < gpsd.stg_avail                  \
                    ? psdx                                          \
                    : (interr("bad PSD_HASHLK index", psdx, 4), 0)] \
      .hashlk
#define PSD_SLOT(psdx)                                            \
  gpsd.stg_base[psdx >= 0 && psdx < gpsd.stg_avail                \
                    ? psdx                                        \
                    : (interr("bad PSD_SLOT index", psdx, 4), 0)] \
      .slot
#define SLOT(sl)                         \
  gpsd.slot[sl >= 0 && sl <= gpsd.nslots \
                ? sl                     \
                : (interr("bad SLOT index", sl, 4), 0)]
#else
#define PSD_TYPE(psdx) gpsd.stg_base[psdx].type
#define PSD_PARENT(psdx) gpsd.stg_base[psdx].parent
#define PSD_SYM(psdx) gpsd.stg_base[psdx].sym
#define PSD_CHILD(psdx) gpsd.stg_base[psdx].child
#define PSD_NEXT(psdx) gpsd.stg_base[psdx].next
#define PSD_HASHLK(psdx) gpsd.stg_base[psdx].hashlk
#define PSD_SLOT(psdx) gpsd.stg_base[psdx].slot
#define SLOT(sl) gpsd.slot[sl]
#endif

/* pointer source descriptor hash table */
#define PSDHSZ 127

static int psdhsh[PSDHSZ];

/*
 * This is a table of actual pointer target entries (APTE), hashed lookup
 */
typedef struct {
  int hashlk;
  int type;
  int sym;
  int val;
  unsigned int mark;
  int stride;
} APTE;
#define APTEHSZ 521
static STG_DECLARE(apte, APTE) = { STG_INIT };
static int aptehsh[APTEHSZ];

#if DEBUG
#define APTE_HASHLK(aptex)                                            \
  apte.stg_base[aptex >= 0 && aptex < apte.stg_avail                  \
                    ? aptex                                           \
                    : (interr("bad APTE_HASHLK index", aptex, 4), 0)] \
      .hashlk
#define APTE_TYPE(aptex)                                            \
  apte.stg_base[aptex >= 0 && aptex < apte.stg_avail                \
                    ? aptex                                         \
                    : (interr("bad APTE_TYPE index", aptex, 4), 0)] \
      .type
#define APTE_SPTR(aptex)                                            \
  apte.stg_base[aptex >= 0 && aptex < apte.stg_avail                \
                    ? aptex                                         \
                    : (interr("bad APTE_SPTR index", aptex, 4), 0)] \
      .sym
#define APTE_VAL(aptex)                                            \
  apte.stg_base[aptex >= 0 && aptex < apte.stg_avail               \
                    ? aptex                                        \
                    : (interr("bad APTE_VAL index", aptex, 4), 0)] \
      .val
#define APTE_STRIDE(aptex)                                            \
  apte.stg_base[aptex >= 0 && aptex < apte.stg_avail                  \
                    ? aptex                                           \
                    : (interr("bad APTE_STRIDE index", aptex, 4), 0)] \
      .stride
#define APTE_MARK(aptex)                                            \
  apte.stg_base[aptex >= 0 && aptex < apte.stg_avail                \
                    ? aptex                                         \
                    : (interr("bad APTE_MARK index", aptex, 4), 0)] \
      .mark
#else
#define APTE_HASHLK(aptex) apte.stg_base[aptex].hashlk
#define APTE_TYPE(aptex) apte.stg_base[aptex].type
#define APTE_SPTR(aptex) apte.stg_base[aptex].sym
#define APTE_VAL(aptex) apte.stg_base[aptex].val
#define APTE_STRIDE(aptex) apte.stg_base[aptex].stride
#define APTE_MARK(aptex) apte.stg_base[aptex].mark
#endif

/*
 * This is a temporary pointer target entry (TPTE) table, with a free list
 */
typedef struct {
  int next;  /* next pointer target */
  int aptex; /* actual pointer target */
#if DEBUG
  int flag; /* used for debugging */
#endif
} TPTE;
static struct {
  STG_MEMBERS(TPTE);
  int xstg_free, save_stg_avail, save_stg_free;
} gpte = {STG_INIT, -1, 0, 0};

#define TPTE_UNK 0
#define TPTE_UNINIT 1
#define TPTE_NULL -1

#if DEBUG
#define TPTE_NEXT(ptex)                                            \
  gpte.stg_base[ptex >= 0 && ptex < gpte.stg_avail                 \
                    ? ptex                                         \
                    : (interr("bad TPTE_NEXT index", ptex, 4), 0)] \
      .next
#define TPTE_APTEX(ptex)                                            \
  gpte.stg_base[ptex >= 0 && ptex < gpte.stg_avail                  \
                    ? ptex                                          \
                    : (interr("bad TPTE_APTEX index", ptex, 4), 0)] \
      .aptex
#define TPTE_TYPE(ptex)                                                      \
  APTE_TYPE(gpte.stg_base[ptex >= 0 && ptex < gpte.stg_avail                 \
                              ? ptex                                         \
                              : (interr("bad TPTE_TYPE index", ptex, 4), 0)] \
                .aptex)
#define TPTE_SPTR(ptex)                                                      \
  APTE_SPTR(gpte.stg_base[ptex >= 0 && ptex < gpte.stg_avail                 \
                              ? ptex                                         \
                              : (interr("bad TPTE_SPTR index", ptex, 4), 0)] \
                .aptex)
#define TPTE_VAL(ptex)                                                     \
  APTE_VAL(gpte.stg_base[ptex >= 0 && ptex < gpte.stg_avail                \
                             ? ptex                                        \
                             : (interr("bad TPTE_VAL index", ptex, 4), 0)] \
               .aptex)
#define TPTE_STRIDE(ptex)                                                \
  APTE_STRIDE(                                                           \
      gpte.stg_base[ptex >= 0 && ptex < gpte.stg_avail                   \
                        ? ptex                                           \
                        : (interr("bad TPTE_STRIDE index", ptex, 4), 0)] \
          .aptex)
#define TPTE_FLAG(ptex)                                            \
  gpte.stg_base[ptex >= 0 && ptex < gpte.stg_avail                 \
                    ? ptex                                         \
                    : (interr("bad TPTE_FLAG index", ptex, 4), 0)] \
      .flag
#else
#define TPTE_NEXT(ptex) gpte.stg_base[ptex].next
#define TPTE_APTEX(ptex) gpte.stg_base[ptex].aptex
#define TPTE_TYPE(ptex) APTE_TYPE(gpte.stg_base[ptex].aptex)
#define TPTE_SPTR(ptex) APTE_SPTR(gpte.stg_base[ptex].aptex)
#define TPTE_VAL(ptex) APTE_VAL(gpte.stg_base[ptex].aptex)
#define TPTE_STRIDE(ptex) APTE_STRIDE(gpte.stg_base[ptex].aptex)
#endif

/*
 * This is a structure defining pseudo assignments
 * the LHS is a PSD
 * the RHS is a PTE (for direct targets) or PSD (for indirect targets)
 */

typedef struct {
  int type;
  int lhs;
  int rhs;
  int node;
  int iltx;
  int stride;
  int next;
} AS;

static STG_DECLARE(as, AS) = { STG_INIT };

#if DEBUG
#define ASTYPE(asx)                                          \
  as.stg_base[asx >= 0 && asx < as.stg_avail                 \
                  ? asx                                      \
                  : (interr("bad ASTYPE index", asx, 4), 0)] \
      .type
#define ASLHS(asx)                                          \
  as.stg_base[asx >= 0 && asx < as.stg_avail                \
                  ? asx                                     \
                  : (interr("bad ASLHS index", asx, 4), 0)] \
      .lhs
#define ASRHS(asx)                                          \
  as.stg_base[asx >= 0 && asx < as.stg_avail                \
                  ? asx                                     \
                  : (interr("bad ASRHS index", asx, 4), 0)] \
      .rhs
#define ASNODE(asx)                                          \
  as.stg_base[asx >= 0 && asx < as.stg_avail                 \
                  ? asx                                      \
                  : (interr("bad ASNODE index", asx, 4), 0)] \
      .node
#define ASILT(asx)                                          \
  as.stg_base[asx >= 0 && asx < as.stg_avail                \
                  ? asx                                     \
                  : (interr("bad ASILT index", asx, 4), 0)] \
      .iltx
#define ASSTRIDE(asx)                                          \
  as.stg_base[asx >= 0 && asx < as.stg_avail                   \
                  ? asx                                        \
                  : (interr("bad ASSTRIDE index", asx, 4), 0)] \
      .stride
#define ASNEXT(asx)                                          \
  as.stg_base[asx >= 0 && asx < as.stg_avail                 \
                  ? asx                                      \
                  : (interr("bad ASNEXT index", asx, 4), 0)] \
      .next
#else
#define ASTYPE(asx) as.stg_base[asx].type
#define ASLHS(asx) as.stg_base[asx].lhs
#define ASRHS(asx) as.stg_base[asx].rhs
#define ASNODE(asx) as.stg_base[asx].node
#define ASILT(asx) as.stg_base[asx].iltx
#define ASSTRIDE(asx) as.stg_base[asx].stride
#define ASNEXT(asx) as.stg_base[asx].next
#endif

#define AS_DIRECT 1
#define AS_INDIRECT 2
#define AS_CLEAR 3
#define AS_UNK 4
#define AS_UNINIT 5
#define AS_INIT 6
#define AS_ADD_DIRECT 7
#define AS_ADD_INDIRECT 8

#define FIRSTAS(std) STD_PTASGN(std)
static int prevasx;

static STG_DECLARE(head, int) = { STG_INIT };
static int *nodeoffset = NULL;

/* at node n, for slot sl, list of pointer targets starts at HEAD(n,sl) */
#if DEBUG
#define HEAD(v, sl)                                                          \
  head.stg_base[nodeoffset[v >= 0 && v <= opt.num_nodes                      \
                               ? v                                           \
                               : (interr("bad HEAD node index", v, 4), 0)] + \
                (sl >= 0 && sl <= gpsd.nslots                                \
                     ? sl                                                    \
                     : (interr("bad HEAD slot index", sl, 4), 0))]
#else
#define HEAD(v, sl) head.stg_base[nodeoffset[v] + sl]
#endif

static int *localhead = NULL;
#if DEBUG
#define LHEAD(psdx)                          \
  localhead[psdx >= 0 && psdx <= gpsd.nslots \
                ? psdx                       \
                : (interr("bad LHEAD index", psdx, 4), 0)]
#else
#define LHEAD(psdx) localhead[psdx]
#endif

/*
 * keep track of VAL values given to anonymous and global dynamically allocated
 * vars
 */
static STG_DECLARE(ganon, int) = { STG_INIT };

static struct {
  STG_MEMBERS(int);
  int local_dyn;
} gdyn = {STG_INIT, 0};

static struct {
  int tot, ntot;
} gcount = {0, 0};

#if defined(TARGET_WIN_X8664)
static char *importname = "__imp_";
static int importnamelen = 6;
#else
static char *importname = "";
static int importnamelen = 0;
#endif

#if DEBUG
static void
puttds(int tdsx)
{
  switch (TTYPE(tdsx)) {
  case TT_UNK:
    fprintf(gbl.dbgfil, "Unknown");
    break;
  case TT_UNINIT:
    fprintf(gbl.dbgfil, "Uninit");
    break;
  case TT_PSYM:
    fprintf(gbl.dbgfil, "%d:%s", TSYM(tdsx), SYMNAME(TSYM(tdsx)));
    break;
  case TT_ISYM:
    fprintf(gbl.dbgfil, "%d:%s?", TSYM(tdsx), SYMNAME(TSYM(tdsx)));
    break;
  case TT_ANON:
    fprintf(gbl.dbgfil, ".anon%d.", TVAL(tdsx));
    break;
  case TT_GDYN:
    fprintf(gbl.dbgfil, ".dyn%d.", TVAL(tdsx));
    break;
  case TT_IGDYN:
    fprintf(gbl.dbgfil, ".dyn%d?.", TVAL(tdsx));
    break;
  case TT_LDYN:
    fprintf(gbl.dbgfil, ".ldyn%d.", TVAL(tdsx));
    break;
  case TT_ILDYN:
    fprintf(gbl.dbgfil, ".ldyn%d?.", TVAL(tdsx));
    break;
  case TT_CON:
    if (TVAL(tdsx) == 0) {
      fprintf(gbl.dbgfil, ".null.");
    } else {
      fprintf(gbl.dbgfil, ".con.");
    }
    break;
  case TT_IND:
    fprintf(gbl.dbgfil, "*");
    puttds(TVAL(tdsx));
    break;
  case TT_IIND:
    fprintf(gbl.dbgfil, "*(");
    puttds(TVAL(tdsx));
    fprintf(gbl.dbgfil, ")?");
    break;
  case TT_MEM:
    puttds(TVAL(tdsx));
    fprintf(gbl.dbgfil, ".%s", SYMNAME(TSYM(tdsx)));
    break;
  case TT_GLOB:
    /* dummy, used when all globals might be modified */
    fprintf(gbl.dbgfil, ".glob.");
    break;
  case TT_NLOC:
    /* pseudo target for any nonlocal variable */
    fprintf(gbl.dbgfil, ".nloc.");
    break;
  default:
    fprintf(gbl.dbgfil, "?? %d:%d:%d", TTYPE(tdsx), TSYM(tdsx), TVAL(tdsx));
    break;
  }
} /* puttds */

static void
putpsd(int psdx)
{
  switch (PSD_TYPE(psdx)) {
  case TT_PSYM:
    fprintf(gbl.dbgfil, "%d:%s", PSD_SYM(psdx), SYMNAME(PSD_SYM(psdx)));
    break;
  case TT_ISYM:
    fprintf(gbl.dbgfil, "%d:%s?", PSD_SYM(psdx), SYMNAME(PSD_SYM(psdx)));
    break;
  case TT_IND:
    fprintf(gbl.dbgfil, "*(");
    putpsd(PSD_PARENT(psdx));
    fprintf(gbl.dbgfil, ")");
    break;
  case TT_IIND:
    fprintf(gbl.dbgfil, "*(");
    putpsd(PSD_PARENT(psdx));
    fprintf(gbl.dbgfil, ")?");
    break;
  case TT_MEM:
    putpsd(PSD_PARENT(psdx));
    fprintf(gbl.dbgfil, ".%s", SYMNAME(PSD_SYM(psdx)));
    break;
  case TT_GLOB:
    fprintf(gbl.dbgfil, ".glob.");
    break;
  case TT_NLOC:
    fprintf(gbl.dbgfil, ".nloc!.");
    break;
  case TT_UNK:
    fprintf(gbl.dbgfil, "Unknown!");
    break;
  case TT_UNINIT:
    fprintf(gbl.dbgfil, "Uninit!");
    break;
  default:
    fprintf(gbl.dbgfil, ".??%d:%d.", PSD_TYPE(psdx), PSD_SYM(psdx));
    break;
  }
} /* putpsd */

static void
putpte(int ptex)
{
  fprintf(gbl.dbgfil, "[%d:%d]", ptex, TPTE_APTEX(ptex));
  switch (TTMASK(TPTE_TYPE(ptex))) {
  case TT_UNINIT:
    fprintf(gbl.dbgfil, "&.uninit.");
    break;
  case TT_UNK:
    fprintf(gbl.dbgfil, "&.unk.");
    break;
  case TT_PSYM:
    fprintf(gbl.dbgfil, "&%d:%s", TPTE_SPTR(ptex), SYMNAME(TPTE_SPTR(ptex)));
    break;
  case TT_ISYM:
    fprintf(gbl.dbgfil, "&%d:%s?", TPTE_SPTR(ptex), SYMNAME(TPTE_SPTR(ptex)));
    break;
  case TT_ANON:
    fprintf(gbl.dbgfil, "&anon:%d", TPTE_VAL(ptex));
    break;
  case TT_GDYN:
    fprintf(gbl.dbgfil, "&dyn:%d", TPTE_VAL(ptex));
    break;
  case TT_IGDYN:
    fprintf(gbl.dbgfil, "&dyn:%d?", TPTE_VAL(ptex));
    break;
  case TT_LDYN:
    fprintf(gbl.dbgfil, "&ldyn:%d", TPTE_VAL(ptex));
    break;
  case TT_ILDYN:
    fprintf(gbl.dbgfil, "&ldyn:%d?", TPTE_VAL(ptex));
    break;
  case TT_CON:
    fprintf(gbl.dbgfil, "&con:%d", TPTE_VAL(ptex));
    break;
  case TT_NLOC:
    fprintf(gbl.dbgfil, "&.nloc.");
    break;
  case TT_IND:
    /* should not appear */
    fprintf(gbl.dbgfil, "*(");
    putpte(TPTE_VAL(ptex));
    fprintf(gbl.dbgfil, ")");
    break;
  case TT_IIND:
    /* should not appear */
    fprintf(gbl.dbgfil, "*(");
    putpte(TPTE_VAL(ptex));
    fprintf(gbl.dbgfil, ")?");
    break;
  case TT_MEM:
    /* should not appear */
    putpte(TPTE_VAL(ptex));
    fprintf(gbl.dbgfil, ".%s", SYMNAME(TPTE_SPTR(ptex)));
    break;
  case TT_GLOB:
    /* should not appear */
    fprintf(gbl.dbgfil, ".glob%d!.", TPTE_VAL(ptex));
    break;
  default:
    /* should not appear */
    fprintf(gbl.dbgfil, "???%d:%d", TPTE_TYPE(ptex), TPTE_VAL(ptex));
    break;
  }
  if (TPTE_STRIDE(ptex) > 0) {
    fprintf(gbl.dbgfil, "(::%d)", TPTE_STRIDE(ptex));
  }
  if (TTMUST(TPTE_TYPE(ptex))) {
    fprintf(gbl.dbgfil, "!");
  }
} /* putpte */

static void
putassign(int asx)
{
  fprintf(gbl.dbgfil, "          as:%d node:%d ", asx, ASNODE(asx));
  fprintf(gbl.dbgfil, "std:%d  ", ASILT(asx));
  putpsd(ASLHS(asx));
  switch (ASTYPE(asx)) {
  case AS_DIRECT:
    fprintf(gbl.dbgfil, "  <=  ");
    putpte(ASRHS(asx));
    break;
  case AS_ADD_DIRECT:
    fprintf(gbl.dbgfil, "  <+=  ");
    putpte(ASRHS(asx));
    break;
  case AS_INDIRECT:
    fprintf(gbl.dbgfil, "  <==  ");
    putpsd(ASRHS(asx));
    break;
  case AS_ADD_INDIRECT:
    fprintf(gbl.dbgfil, "  <+==  ");
    putpsd(ASRHS(asx));
    break;
  case AS_INIT:
    fprintf(gbl.dbgfil, "  <=  ");
    putpte(ASRHS(asx));
    fprintf(gbl.dbgfil, "  (init)");
    break;
  case AS_CLEAR:
    fprintf(gbl.dbgfil, "  <==  CLEAR");
    break;
  case AS_UNK:
    fprintf(gbl.dbgfil, "  <==  UNKNOWN");
    break;
  default:
    fprintf(gbl.dbgfil, "  <<-- type:%d(%d)", ASTYPE(asx), ASRHS(asx));
    break;
  }
  fprintf(gbl.dbgfil, "   stride(%d)", ASSTRIDE(asx));
  fprintf(gbl.dbgfil, "\n");
} /* putassign */

void
putstdassigns(int stdx)
{
  int a;
  if (as.stg_base) {
    for (a = FIRSTAS(stdx); a > 0; a = ASNEXT(a)) {
      putassign(a);
    }
  }
} /* putstdassigns */

static void
putptelist(int ptelistx)
{
  int ptex;
  for (ptex = ptelistx; ptex > 0; ptex = TPTE_NEXT(ptex)) {
    putpte(ptex);
    if (TPTE_NEXT(ptex) > 0) {
      fprintf(gbl.dbgfil, ", ");
    }
  }
} /* putptelist */

static void
puttarget(int sl)
{
  int psdx;
  psdx = SLOT(sl);
  fprintf(gbl.dbgfil, "psd:%d ", psdx);
  putpsd(psdx);
  if (LHEAD(sl) == TTE_NULL) {
    fprintf(gbl.dbgfil, " --> ...");
  } else if (LHEAD(sl) == TPTE_UNK) {
    fprintf(gbl.dbgfil, " --> unknown");
  } else {
    fprintf(gbl.dbgfil, " --> ");
    putptelist(LHEAD(sl));
  }
  fprintf(gbl.dbgfil, "\n");
} /* puttarget */

static void
puttargets(void)
{
  int sl;
  for (sl = 1; sl < gpsd.nslots; ++sl) {
    puttarget(sl);
  }
} /* puttargets */

static void
putnodetarget(char *ch, int v, int sl)
{
  int psdx;
  psdx = SLOT(sl);
  fprintf(gbl.dbgfil, "%s node:%d psd:%d ", ch, v, psdx);
  putpsd(psdx);
  if (HEAD(v, sl) == TTE_NULL) {
    fprintf(gbl.dbgfil, " --> ...");
  } else if (HEAD(v, sl) == TPTE_UNK) {
    fprintf(gbl.dbgfil, " --> unknown");
  } else {
    fprintf(gbl.dbgfil, " --> ");
    putptelist(HEAD(v, sl));
  }
  fprintf(gbl.dbgfil, "\n");
} /* puttarget */

static void
putnodetargets(char *ch, int v)
{
  int sl;

  for (sl = 1; sl < gpsd.nslots; ++sl) {
    putnodetarget(ch, v, sl);
  }
} /* puttargets */
#endif

/*
 * return TRUE if this source is a global symbol,
 * or is an indirection that might point to a global symbol.
 */
static int
is_source_global(int psdx)
{
  int sptr, parentpsdx, sl, ptex;
  switch (PSD_TYPE(psdx)) {
  case TT_PSYM:
  case TT_ISYM:
    /* is this a global symbol? */
    sptr = PSD_SYM(psdx);
    if (SCG(sptr) == SC_EXTERN || SCG(sptr) == SC_CMBLK) {
      return TRUE;
    }
    if (SCG(sptr) == SC_BASED && MIDNUMG(sptr)) {
      sptr = MIDNUMG(sptr);
      if (SCG(sptr) == SC_EXTERN || SCG(sptr) == SC_CMBLK) {
        return TRUE;
      }
    }
    break;
  case TT_IND:
  case TT_IIND:
    /* look at parent */
    /* look at pointer targets of the parent */
    parentpsdx = PSD_PARENT(psdx);
    if (is_source_global(parentpsdx))
      return TRUE;
    sl = PSD_SLOT(parentpsdx);
    if (LHEAD(sl) == TPTE_UNK)
      return TRUE;
    for (ptex = LHEAD(sl); ptex > 0; ptex = TPTE_NEXT(ptex)) {
      switch (TTMASK(TPTE_TYPE(ptex))) {
      case TT_UNK:
      case TT_UNINIT:
        return TRUE;
      case TT_PSYM:
      case TT_ISYM:
        sptr = TPTE_SPTR(ptex);
        if (SCG(sptr) == SC_EXTERN || SCG(sptr) == SC_CMBLK) {
          return TRUE;
        }
        if (SCG(sptr) == SC_BASED && MIDNUMG(sptr)) {
          sptr = MIDNUMG(sptr);
          if (SCG(sptr) == SC_EXTERN || SCG(sptr) == SC_CMBLK) {
            return TRUE;
          }
        }
        break;
      case TT_NLOC:
        return TRUE; /* all we know is something nonlocal, may be global */
      case TT_ANON:
      case TT_GDYN:
      case TT_IGDYN:
      case TT_LDYN:
      case TT_ILDYN:
      case TT_CON:
        break;
      default:
        /* real error */
        interr("bad PTE type", TPTE_TYPE(ptex), ERR_Fatal);
        return TRUE;
      }
    }
    return FALSE;
    break;
  case TT_GLOB:
    return TRUE;
  case TT_UNK:
  case TT_UNINIT:
    return TRUE;
  }
  return FALSE;
} /* is_source_global */

/*
 * return TRUE if this source is a global symbol that we know to be safe
 */
static int
safe_symbol(int psdx)
{
  int sptr;
  switch (PSD_TYPE(psdx)) {
  case TT_PSYM:
  case TT_ISYM:
    /* is this a global symbol? */
    sptr = PSD_SYM(psdx);
    if (VOLG(sptr))
      return FALSE;
    break;
    /* we don't know anything about other pointer sources */
  }
  return FALSE;
} /* safe_symbol */

/*
 * return TRUE if this source is a global or static symbol,
 * or is an indirection that might point to a global or static symbol.
 */
static int
is_source_nonlocal(int psdx)
{
  int sptr, parentpsdx, sl, ptex;
  switch (PSD_TYPE(psdx)) {
  case TT_PSYM:
  case TT_ISYM:
    /* is this a global symbol? */
    sptr = PSD_SYM(psdx);
    if (SCG(sptr) == SC_EXTERN || SCG(sptr) == SC_CMBLK ||
        SCG(sptr) == SC_DUMMY || (gbl.internal > 1 && !INTERNALG(sptr))) {
      return TRUE;
    }
    if (SCG(sptr) == SC_BASED && MIDNUMG(sptr)) {
      sptr = MIDNUMG(sptr);
      if (SCG(sptr) == SC_EXTERN || SCG(sptr) == SC_CMBLK ||
          SCG(sptr) == SC_DUMMY || (gbl.internal > 1 && !INTERNALG(sptr))) {
        return TRUE;
      }
    }
    break;
  case TT_IND:
  case TT_IIND:
    /* look at pointer targets of the parent */
    parentpsdx = PSD_PARENT(psdx);
    if (is_source_nonlocal(parentpsdx))
      return TRUE;
    sl = PSD_SLOT(parentpsdx);
    if (LHEAD(sl) == TPTE_UNK)
      return TRUE;
    for (ptex = LHEAD(sl); ptex > 0; ptex = TPTE_NEXT(ptex)) {
      switch (TTMASK(TPTE_TYPE(ptex))) {
      case TT_UNK:
      case TT_UNINIT:
        return TRUE;
      case TT_PSYM:
      case TT_ISYM:
        sptr = TPTE_SPTR(ptex);
        if (SCG(sptr) == SC_EXTERN || SCG(sptr) == SC_CMBLK ||
            SCG(sptr) == SC_DUMMY || (gbl.internal > 1 && !INTERNALG(sptr))) {
          return TRUE;
        }
        if (SCG(sptr) == SC_BASED && MIDNUMG(sptr)) {
          sptr = MIDNUMG(sptr);
          if (SCG(sptr) == SC_EXTERN || SCG(sptr) == SC_CMBLK ||
              SCG(sptr) == SC_DUMMY || (gbl.internal > 1 && !INTERNALG(sptr))) {
            return TRUE;
          }
        }
        break;
      case TT_NLOC: /* all we know is something nonlocal, may be global */
      case TT_ANON: /* anonymous nonlocal */
      case TT_GLOB:
        return TRUE;
      case TT_GDYN:
      case TT_IGDYN:
      case TT_LDYN:
      case TT_ILDYN:
      case TT_CON:
        break;
      default:
        /* real error */
        interr("bad PTE type", TPTE_TYPE(ptex), ERR_Warning);
        return TRUE;
      }
    }
    return FALSE;
    break;
  case TT_GLOB:
    return TRUE;
  case TT_UNINIT:
  case TT_UNK:
    return TRUE;
  }
  return FALSE;
} /* is_source_nonlocal */

/*
 * add a new pointer source descriptor to the table
 * if this is an LHS reference, make sure it has a slot number
 */
static void
add_psd(int tpdx, int type, int parent, int sym, bool lhs)
{
  int val, psdx, t;

  t = TTMASK(type);
  val = (int)((t ^ sym ^ parent) & 0x7fff) % PSDHSZ;
  for (psdx = psdhsh[val]; psdx > 0; psdx = PSD_HASHLK(psdx)) {
    if (PSD_TYPE(psdx) == t && PSD_PARENT(psdx) == parent &&
        PSD_SYM(psdx) == sym) {
      if (tpdx)
        TLINK(tpdx) = psdx;
      if (TTIMP(type)) {
        PSD_TYPE(psdx) |= TTIMPFLAG;
      }
      if (lhs && PSD_SLOT(psdx) == 0) {
        PSD_SLOT(psdx) = gpsd.nslots++;
      }
      return;
    }
  }
  psdx = STG_NEXT(gpsd);
  PSD_TYPE(psdx) = type;
  PSD_PARENT(psdx) = parent;
  PSD_SYM(psdx) = sym;
  PSD_NEXT(psdx) = 0;
  PSD_CHILD(psdx) = 0;
  PSD_SLOT(psdx) = 0;
  PSD_HASHLK(psdx) = psdhsh[val];
  psdhsh[val] = psdx;
  if (tpdx)
    TLINK(tpdx) = psdx;
  if (parent) {
    PSD_NEXT(psdx) = PSD_CHILD(parent);
    PSD_CHILD(parent) = psdx;
  }
  if (lhs) {
    PSD_SLOT(psdx) = gpsd.nslots++;
  } else if (type == TT_PSYM || type == TT_ISYM) {
    if (is_source_nonlocal(psdx)) {
      PSD_SLOT(psdx) = gpsd.nslots++;
    }
  }
} /* add_psd */

/*
 * call add_psd to build a pointer source descriptor for this entry;
 * make sure all dependent (parent) pointer source descriptors are also built.
 */
static void
build_psd(int tdsx, bool lhs)
{
  int subtds;
  if (TLINK(tdsx))
    return;
  switch (TTYPE(tdsx)) {
  case TT_PSYM:
    add_psd(tdsx, TT_PSYM, 0, TSYM(tdsx), lhs);
    break;
  case TT_ISYM:
    add_psd(tdsx, TT_ISYM, 0, TSYM(tdsx), lhs);
    break;
  case TT_IND:
    subtds = TVAL(tdsx);
    build_psd(subtds, lhs);
    add_psd(tdsx, TT_IND, TLINK(subtds), 0, lhs);
    break;
  case TT_IIND:
    subtds = TVAL(tdsx);
    build_psd(subtds, lhs);
    add_psd(tdsx, TT_IIND, TLINK(subtds), 0, lhs);
    break;
  case TT_MEM:
    subtds = TVAL(tdsx);
    build_psd(subtds, lhs);
    add_psd(tdsx, TT_MEM, TLINK(subtds), TSYM(tdsx), lhs);
    break;
  case TT_GLOB:
    add_psd(tdsx, TT_GLOB, 0, 0, lhs);
    break;
  default:
    TLINK(tdsx) = 0;
    break;
  }
} /* build_psd */

/*
 * find pointer source descriptor in the table
 */
static int
find_psd(int type, int parent, int sym)
{
  int val, psdx;

  val = (int)((type ^ sym ^ parent) & 0x7fff) % PSDHSZ;
  for (psdx = psdhsh[val]; psdx > 0; psdx = PSD_HASHLK(psdx)) {
    if (PSD_TYPE(psdx) == type && PSD_PARENT(psdx) == parent &&
        PSD_SYM(psdx) == sym) {
      return psdx;
    }
  }
  return TTE_NULL;
} /* find_psd */

/*
 * get APTE entry, lookup in hash table
 */
static int
get_apte(int type, int sptr, int val, int stride)
{
  int h, aptex;
  h = (type * 51 + sptr + val) << 4;
  h = h & 0xffffff;
  h = h % APTEHSZ;
  for (aptex = aptehsh[h]; aptex; aptex = APTE_HASHLK(aptex)) {
    if (APTE_TYPE(aptex) == type && APTE_SPTR(aptex) == sptr &&
        APTE_VAL(aptex) == val
        && APTE_STRIDE(aptex) == stride
        ) {
      return aptex;
    }
  }
  aptex = STG_NEXT(apte);
  APTE_TYPE(aptex) = type;
  APTE_SPTR(aptex) = sptr;
  APTE_VAL(aptex) = val;
  APTE_MARK(aptex) = 0;
  APTE_STRIDE(aptex) = stride;
  APTE_HASHLK(aptex) = aptehsh[h];
  aptehsh[h] = aptex;
  return aptex;
} /* get_apte */

/*
 * find but don't add APTE entry, lookup in hash table
 */
static int
find_apte(int type, int sptr, int val)
{
  int h, aptex;
  h = (type * 51 + sptr + val) << 4;
  h = h & 0xffffff;
  h = h % APTEHSZ;
  for (aptex = aptehsh[h]; aptex; aptex = APTE_HASHLK(aptex)) {
    if (APTE_TYPE(aptex) == type && APTE_SPTR(aptex) == sptr &&
        APTE_VAL(aptex) == val) {
      return aptex;
    }
  }
  return -1;
} /* find_apte */

/*
 * get new pte entry, use free list if available
 */
static int
get_pte(int type, int sptr, int val, int stride)
{
  int ptex;
  ptex = gpte.xstg_free;
  if (ptex > 0) {
    gpte.xstg_free = TPTE_NEXT(ptex);
  } else {
    ptex = STG_NEXT(gpte);
  }
  TPTE_APTEX(ptex) = get_apte(type, sptr, val, stride);
  TPTE_NEXT(ptex) = TTE_NULL;
  return ptex;
} /* get_pte */

/*
 * return the imprecise version of this ptetype
 */
static int
imprecise_ptetype(int ptetype)
{
  if (ptetype == TT_PSYM)
    ptetype = TT_ISYM;
  else if (ptetype == TT_GDYN)
    ptetype = TT_IGDYN;
  else if (ptetype == TT_LDYN)
    ptetype = TT_ILDYN;
  else if (ptetype == TT_IND)
    ptetype = TT_IIND;
  return ptetype;
} /* imprecise_ptetype */

/*
 * copy pte tree
 */
static int
copy_pte(int ptex, int imprecise, int mstride)
{
  int newptex, ptetype;
  ptetype = TTMASK(TPTE_TYPE(ptex));
  if (imprecise)
    ptetype = imprecise_ptetype(ptetype);
  newptex = get_pte(ptetype, TPTE_SPTR(ptex), TPTE_VAL(ptex),
                    TPTE_STRIDE(ptex) * mstride
                    );
  switch (TTMASK(TPTE_TYPE(newptex))) {
  case TT_IND:
  case TT_IIND:
  case TT_MEM:
    TPTE_VAL(newptex) = copy_pte(TPTE_VAL(ptex), imprecise, 0);
    break;
  }
  return newptex;
} /* copy_pte */

/*
 * free a single pte
 */
static void
free_pte(int ptex)
{

  switch (TTMASK(TPTE_TYPE(ptex))) {
  case TT_IND:
  case TT_IIND:
  case TT_MEM:
    free_pte(TPTE_VAL(ptex));
    break;
  }
  TPTE_APTEX(ptex) = 0;
  TPTE_NEXT(ptex) = gpte.xstg_free;
  gpte.xstg_free = ptex;
} /* free_pte */

/*
 * clear the TPTE list at LHEAD(sl)
 */
static void
free_list(int ptelistx)
{
  int ptex, nextptex;
  nextptex = ptelistx;
  for (ptex = nextptex; ptex > 0; ptex = nextptex) {
    nextptex = TPTE_NEXT(ptex);
    free_pte(ptex);
  }
} /* free_list */

/*
 * clear the TPTE list at LHEAD(sl)
 */
static void
free_list_slot(int sl)
{
  free_list(LHEAD(sl));
  LHEAD(sl) = TTE_NULL;
} /* free_list_slot */

/*
 * reverse depth first ordering, and rdfo number for each node
 */
static int rdfocount, *rdfo, *rdfonum;
#if DEBUG
#define RDFO(r) \
  rdfo[r >= 0 && r <= opt.num_nodes ? r : (interr("bad RDFO index", r, 4), 0)]
#define RDFONUM(r)                     \
  rdfonum[r >= 0 && r <= opt.num_nodes \
              ? r                      \
              : (interr("bad RDFONUM index", r, 4), 0)]
#else
#define RDFO(r) rdfo[r]
#define RDFONUM(r) rdfonum[r]
#endif

/*
 * v is a flow graph number; build reverse-depth-first order
 * of flow graph nodes
 */
static void
buildrdfo(int v)
{
  PSI_P s;
  int sv;
  RDFONUM(v) = -1;
  for (s = FG_SUCC(v); s != PSI_P_NULL; s = PSI_NEXT(s)) {
    sv = PSI_NODE(s);
    if (RDFONUM(sv) == 0) {
      buildrdfo(sv);
    }
  }
  ++rdfocount;
  RDFO(rdfocount) = v;
  RDFONUM(v) = rdfocount;
} /* buildrdfo */

static int
make_address(int astx, int pt, int sym, int offset)
{
  int tdsx;
  if (pt == TT_UNK)
    return 0;
  tdsx = STG_NEXT(gtpd);
  TTYPE(tdsx) = pt;
  TSYM(tdsx) = sym;
  TVAL(tdsx) = offset;
  return tdsx;
} /* make_address */

/*
 * fill in temporary pointer structure descriptors
 */
static int
make_address_for_ast(int astx, int parentast)
{
  int a, sptr, ttype, ret;
  ttype = TT_PSYM;
  a = astx;
  sptr = 0;
  while (!sptr) {
    switch (A_TYPEG(a)) {
    case A_ID:
      sptr = A_SPTRG(a);
      break;
    case A_MEM:
      if (parentast && A_TKNG(parentast) == TK_ALLOCATE &&
          A_SPTRG(A_MEMG(a)) && DTY(DTYPEG(A_SPTRG(A_MEMG(a)))) == TY_ARRAY) {
        /* process allocate of an array that is a structure member */
        sptr = A_SPTRG(A_MEMG(a));
      }
      a = A_PARENTG(a);
      ttype = TT_ISYM;
      break;
    case A_SUBSCR:
      a = A_LOPG(a);
      ttype = TT_ISYM;
      break;
    default:
      sptr = -1;
      break;
    }
  }
  if (sptr > 0) {
    ret = make_address(astx, ttype, sptr, 0);
  } else {
    ret = make_address(astx, TT_UNK, 0, 0);
  }
  return ret;
} /* make_address_for_ast */

/*
 * get ptr source descriptor of LHS
 * decide if RHS is a real pointer target or indirect through pointer source
 * create pseudo assignment to represent all this
 * stride is only used for F90
 */
static void
make_assignment(int v, int iltx, int lhstds, int rhstds, int add, int stride)
{
  int lhspsdx, asx, rhsptex, rhspsdx;
#if DEBUG
  if (DBGBIT(TRACEFLAG, TRACEBIT)) {
    fprintf(gbl.dbgfil, "node:%d bih:%d ilt:%d lhs:%d <= rhs:%d  ", v,
            FG_TO_BIH(v), iltx, lhstds, rhstds);
    puttds(lhstds);
    fprintf(gbl.dbgfil, " <= ");
    puttds(rhstds);
    fprintf(gbl.dbgfil, "\n");
    printast(iltx);
    fprintf(gbl.dbgfil, " (stride=%d)\n", stride);
  }
#endif
  build_psd(lhstds, true);
  lhspsdx = TLINK(lhstds);
  asx = 0;
  switch (TTYPE(rhstds)) {
  case TT_PSYM:
  case TT_ISYM:
    /* real pointer target */
    rhsptex = get_pte(TTYPE(rhstds), TSYM(rhstds), 0,
                      stride
                      );

    asx = STG_NEXT(as);
    ASTYPE(asx) = add ? AS_ADD_DIRECT : AS_DIRECT;
    ASLHS(asx) = lhspsdx;
    ASRHS(asx) = rhsptex;
    ASNODE(asx) = v;
    ASILT(asx) = iltx;
    ASNEXT(asx) = 0;
    ASSTRIDE(asx) = stride;
    break;

  case TT_CON:
  case TT_GDYN:
  case TT_IGDYN:
  case TT_LDYN:
  case TT_ILDYN:
    /* real pointer target */
    rhsptex = get_pte(TTYPE(rhstds), TSYM(rhstds), TVAL(rhstds),
                      stride
                      );

    asx = STG_NEXT(as);
    ASTYPE(asx) = add ? AS_ADD_DIRECT : AS_DIRECT;
    ASLHS(asx) = lhspsdx;
    ASRHS(asx) = rhsptex;
    ASNODE(asx) = v;
    ASILT(asx) = iltx;
    ASNEXT(asx) = 0;
    ASSTRIDE(asx) = stride;
    break;
  case TT_UNK:
    asx = STG_NEXT(as);
    ASTYPE(asx) = AS_UNK;
    ASLHS(asx) = lhspsdx;
    ASRHS(asx) = 0;
    ASNODE(asx) = v;
    ASILT(asx) = iltx;
    ASNEXT(asx) = 0;
    ASSTRIDE(asx) = stride;
    break;
  case TT_UNINIT:
    asx = STG_NEXT(as);
    ASTYPE(asx) = AS_UNINIT;
    ASLHS(asx) = lhspsdx;
    ASRHS(asx) = 0;
    ASNODE(asx) = v;
    ASILT(asx) = iltx;
    ASNEXT(asx) = 0;
    ASSTRIDE(asx) = stride;
    break;
  default:
    /* indirect or otherwise; need dataflow analysis */
    build_psd(rhstds, false);
    rhspsdx = TLINK(rhstds);

    asx = STG_NEXT(as);
    ASTYPE(asx) = add ? AS_ADD_INDIRECT : AS_INDIRECT;
    ASLHS(asx) = lhspsdx;
    ASRHS(asx) = rhspsdx;
    ASNODE(asx) = v;
    ASILT(asx) = iltx;
    ASNEXT(asx) = 0;
    ASSTRIDE(asx) = stride;
    break;
  }
  if (asx) {
    if (prevasx) {
      ASNEXT(prevasx) = asx;
    } else {
      FIRSTAS(v) = asx;
    }
    prevasx = asx;
  }
#if DEBUG
  if (asx && DBGBIT(TRACEFLAG, TRACEBIT)) {
    putassign(asx);
    fprintf(gbl.dbgfil, "\n");
  }
#endif
} /* make_assignment */

/*
 * Find the stride of the leftmost dimension of this pointer target reference
 * Return zero if it's not a constant.
 */
static int
find_stride(int astx)
{
  if (A_TYPEG(astx) == A_ID) {
    /* pointer points to whole array */
    return 1;
  } else if (A_TYPEG(astx) == A_SUBSCR) {
    /* find stride of leftmost subscript */
    int asd, astss, sptr;
    asd = A_ASDG(astx);
    astss = ASD_SUBS(asd, 0);
    if (A_TYPEG(astss) != A_TRIPLE) {
      return 0;
    }
    astss = A_STRIDEG(astss);
    if (astss == 0)
      return 1;
    if (!A_ALIASG(astss))
      return 0;
    astss = A_ALIASG(astss);
    if (A_TYPEG(astss) != A_CNST)
      return 0;
    sptr = A_SPTRG(astss);
    switch (DTY(DTYPEG(sptr))) {
    case TY_INT8:
    case TY_INT:
    case TY_SINT:
    case TY_BINT:
      if (CONVAL1G(sptr) != 0)
        return 0;
      return CONVAL2G(sptr);
    default:
      return 0;
    }
  } else {
    return 0;
  }
} /* find_stride */

/*
 * find pointer assignments
 * characterize both LHS and RHS as pointer source descriptors
 * this must also handle other assignments that change pointers
 * and treat them as unknown assignments
 * as well as function calls with pointer arguments
 */
static int globalv;

static void
_find_pointer_assignments_f90(int astx, int *pstdx)
{
  int lop, allglobals, allargs, dpdsc, funcsptr;
  int dummy, args, argcnt, a, arg, argsptr;
  switch (A_TYPEG(astx)) {
  case A_ICALL:
    /* intrinsic call, see if it is ptr assignment */
    if (A_OPTYPEG(astx) == I_PTR2_ASSIGN) {
      /* pointer assignment */
      int args, lhsastx, rhsastx, lhsdsx, rhsdsx, stride;
      args = A_ARGSG(astx);
      lhsastx = ARGT_ARG(args, 0);
      rhsastx = ARGT_ARG(args, 1);
      lhsdsx = make_address_for_ast(lhsastx, astx);
      rhsdsx = make_address_for_ast(rhsastx, astx);
      stride = find_stride(rhsastx);
      make_assignment(globalv, *pstdx, lhsdsx, rhsdsx, 0, stride);
    } else if (A_OPTYPEG(astx) == I_NULLIFY) {
      /* pointer nullify */
      int args, lhsastx, lhsdsx, rhsdsx;
      args = A_ARGSG(astx);
      lhsastx = ARGT_ARG(args, 0);
      lhsdsx = make_address_for_ast(lhsastx, astx);
      rhsdsx = make_address(astx, TT_CON, 0, 0);
      make_assignment(globalv, *pstdx, lhsdsx, rhsdsx, 0, 0);
    }
    break;
  case A_CALL:
    lop = A_LOPG(astx);
    allglobals = 1;
    allargs = 0;
    if (A_TYPEG(lop) == A_ID) {
      funcsptr = A_SPTRG(lop);
      dpdsc = DPDSCG(funcsptr);
      if (DPDSCG(funcsptr)) {
        allargs = 1; /* all pointer dummy args might be modified */
      }
    }
    if (allglobals) {
      make_assignment(globalv, *pstdx, 2, 0, 0, 0);
    }
    if (allargs) {
      /* have funcsptr, dpdsc */
      args = A_ARGSG(astx);
      argcnt = A_ARGCNTG(astx);
      for (a = 0; a < argcnt; ++a) {
        arg = ARGT_ARG(args, a);
        if (A_TYPEG(arg) == A_ID) {
          argsptr = A_SPTRG(arg);
          if (POINTERG(argsptr)) {
            int lhsdsx, rhsdsx;
            /* if the pointer might otherwise be modified */
            dummy = aux.dpdsc_base[dpdsc + a];
            if (dummy && POINTERG(dummy)) {
              /* yes, it might */
              lhsdsx = make_address_for_ast(arg, astx);
              rhsdsx = make_address(astx, TT_UNK, 0, 0);
              make_assignment(globalv, *pstdx, lhsdsx, rhsdsx, 0, 0);
            }
          }
        }
      }
    }
    break;
  case A_ALLOC:
    /* allocate/deallocate */
    if (A_TKNG(astx) == TK_ALLOCATE) {
      /* allocate */
      int objastx, lhsdsx, rhsdsx;
      objastx = A_SRCG(astx);
      if (A_TYPEG(objastx) == A_SUBSCR) {
        objastx = A_LOPG(objastx);
      }
      lhsdsx = make_address_for_ast(objastx, astx);
      rhsdsx = make_address(astx, TT_LDYN, 0, gdyn.local_dyn++);
      make_assignment(globalv, *pstdx, lhsdsx, rhsdsx, 0, 1);
    } else {
      /* deallocate */
      int objastx, lhsdsx, rhsdsx;
      objastx = A_SRCG(astx);
      if (A_TYPEG(objastx) == A_SUBSCR) {
        objastx = A_LOPG(objastx);
      }
      lhsdsx = make_address_for_ast(objastx, astx);
      rhsdsx = make_address(astx, TT_CON, 0, 0);
      make_assignment(globalv, *pstdx, lhsdsx, rhsdsx, 0, 0);
    }
    break;
  }
} /* _find_pointer_assignments_f90 */

/*
 * symbolically interpret the statements in this statement
 * represent the pointer target information as a TPTE list
 */
static void
find_pointer_assignments_f90(int stdx)
{
  prevasx = 0;
  gtpd.stg_avail = 3;
  ast_visit(1, 1);
  globalv = stdx;
  ast_traverse(STD_AST(stdx), NULL, _find_pointer_assignments_f90, &stdx);
  ast_unvisit();
} /* find_pointer_assignments_f90 */

/*
 * return unique identifier for an anonymous variable
 */
static int
anonymous_number(int n)
{
  int a;
  for (a = 1; a < ganon.stg_avail; ++a) {
    if (ganon.stg_base[a] == n)
      return a;
  }
  a = STG_NEXT(ganon);
  ganon.stg_base[a] = n;
  return a;
} /* anonymous_number */

/*
 * return unique identifier for a dynamically-allocated block of space
 */
static int
dynamic_number(int n)
{
  int d;
  for (d = 1; d < gdyn.stg_avail; ++d) {
    if (gdyn.stg_base[d] == n)
      return d;
  }
  d = STG_NEXT(gdyn);
  gdyn.stg_base[d] = n;
  return d;
} /* dynamic_number */

/*
 * Add pseudo assignments for initial pointer information at the program entry
 */
static void
make_init_assignment(int v, int sourcesptr, int stars, int targettype,
                     int targetinfo)
{
  int lhspsdx, asx, rhsptex;
  int lhstds;
  /* get LHS tds for source */
  Trace(("init assignment node %d sourcesptr %d stars=%d targettype=%d "
         "targetinfo=%d",
         v, sourcesptr, stars, targettype, targetinfo));
  lhstds = make_address(0, TT_PSYM, sourcesptr, 0);
  while (stars-- > 0) {
    lhstds = make_address(0, TT_IND, 0, lhstds);
  }
  build_psd(lhstds, true);
  lhspsdx = TLINK(lhstds);
  asx = 0;
  /* get PTE for RHS */
  switch (targettype) {
  case 1:
    /* another SPTR */
    rhsptex = get_pte(TT_ISYM, targetinfo, 0, 0);
    asx = STG_NEXT(as);
    ASTYPE(asx) = AS_INIT;
    ASLHS(asx) = lhspsdx;
    ASRHS(asx) = rhsptex;
    ASNODE(asx) = v;
    ASILT(asx) = 0;
    ASNEXT(asx) = 0;
    break;
  case 2:
    /* anonymous variable */
    rhsptex = get_pte(TT_ANON, 0, anonymous_number(targetinfo), 0);
    asx = STG_NEXT(as);
    ASTYPE(asx) = AS_INIT;
    ASLHS(asx) = lhspsdx;
    ASRHS(asx) = rhsptex;
    ASNODE(asx) = v;
    ASILT(asx) = 0;
    ASNEXT(asx) = 0;
    break;
  case 3:
    /* allocatable storage */
    rhsptex = get_pte(TT_GDYN, 0, dynamic_number(targetinfo), 0);
    asx = STG_NEXT(as);
    ASTYPE(asx) = AS_INIT;
    ASLHS(asx) = lhspsdx;
    ASRHS(asx) = rhsptex;
    ASNODE(asx) = v;
    ASILT(asx) = 0;
    ASNEXT(asx) = 0;
    break;
  default:
    interr("bad target type", targettype, ERR_Fatal);
    return;
  }
  if (asx) {
    ASNEXT(asx) = FIRSTAS(v);
    FIRSTAS(v) = asx;
  }
} /* make_init_assignment */

/*
 * add the TPTE at ptex to the TPTE list at LHEAD(s)
 */
static void
add_list(int ptex, int psdx, int imprecise, int mstride)
{
  int newptex;
  newptex = copy_pte(ptex, imprecise, mstride);
  TPTE_NEXT(newptex) = LHEAD(PSD_SLOT(psdx));
  LHEAD(PSD_SLOT(psdx)) = newptex;
} /* add_list */

/*
 * copy the TPTE list at T to the TPTE list at position LHEAD(s)
 */
static int
copy_list(int ptelistx)
{
  int ptex, newptex, headptex;
  if (ptelistx == TPTE_UNK) {
    return TPTE_UNK;
  } else {
    headptex = TTE_NULL;
    for (ptex = ptelistx; ptex > 0; ptex = TPTE_NEXT(ptex)) {
      newptex = copy_pte(ptex, 0, 1);
      TPTE_NEXT(newptex) = headptex;
      headptex = newptex;
    }
    return headptex;
  }
} /* copy_list */

/*
 * combine (take the meet) of the 'old' list at T
 * with the new list at N.  return the result
 */
static int
combine_list(int T, int N)
{
  return T;
} /* combine_list */

/*
 * we're at a point where we know nothing, assume worst case
 */
static void
unk_all(void)
{
  int sl;
  for (sl = 1; sl < gpsd.nslots; ++sl) {
    free_list_slot(sl);
    LHEAD(sl) = TPTE_UNK;
  }
} /* unk_all */

/*
 * clear all information for globals, or anything that might point to a global
 */
static void
unk_globals(void)
{
  int sl;
  for (sl = 1; sl < gpsd.nslots; ++sl) {
    if (is_source_global(SLOT(sl)) && !safe_symbol(SLOT(sl))) {
      free_list_slot(sl);
      LHEAD(sl) = TPTE_UNK;
    }
  }
} /* unk_globals */

/*
 * set up the APTE flags
 * mark any APTE that might be a target of the given psd
 *  we're looking for the case
 *   p = &q;
 *   q = &a;
 *   so we have to add &a to the target list of *p as well.
 */
static unsigned int marker = 0;
static unsigned int unknown_mark = 0, nonlocal_mark = 0, some_nonlocal_mark = 0;
static void
mark_apte_targets(int psdx)
{
  int parentpsdx, parentsl, ptex, sptr, aptex;
  ++marker;
  switch (PSD_TYPE(psdx)) {
  case TT_PSYM:
  case TT_ISYM:
    aptex = find_apte(TT_PSYM, PSD_SYM(psdx), 0);
    if (aptex > 0)
      APTE_MARK(aptex) = marker;
    aptex = find_apte(TT_ISYM, PSD_SYM(psdx), 0);
    if (aptex > 0)
      APTE_MARK(aptex) = marker;
    sptr = PSD_SYM(psdx);
    break;
  case TT_IND:
  case TT_IIND:
    parentpsdx = PSD_PARENT(psdx);
    /* mark targets of parentpsdx */
    parentsl = PSD_SLOT(parentpsdx);
    if (LHEAD(parentsl) == TPTE_UNK) {
      unknown_mark = marker;
    } else {
      for (ptex = LHEAD(parentsl); ptex > 0; ptex = TPTE_NEXT(ptex)) {
        switch (TTMASK(TPTE_TYPE(ptex))) {
        case TT_UNK:
        case TT_UNINIT:
          unknown_mark = marker;
          some_nonlocal_mark = marker;
          break;
        case TT_PSYM:
        case TT_ISYM:
          sptr = TPTE_SPTR(ptex);
          aptex = find_apte(TT_PSYM, sptr, 0);
          if (aptex > 0)
            APTE_MARK(aptex) = marker;
          aptex = find_apte(TT_ISYM, sptr, 0);
          if (aptex > 0)
            APTE_MARK(aptex) = marker;
          break;
        case TT_NLOC: /* all we know is something nonlocal, may be global */
          nonlocal_mark = marker;
          some_nonlocal_mark = marker;
          break;
        case TT_ANON: /* anonymous nonlocal */
        case TT_GDYN:
        case TT_IGDYN:
        case TT_LDYN:
        case TT_ILDYN:
          some_nonlocal_mark = marker;
          break;
        case TT_CON:
          aptex = find_apte(TTMASK(TPTE_TYPE(ptex)), 0, TPTE_VAL(ptex));
          if (aptex > 0)
            APTE_MARK(aptex) = marker;
          break;
        default:
          /* real error */
          interr("bad PTE type", TPTE_TYPE(ptex), ERR_Warning);
          break;
        }
      }
    }
    break;
  case TT_MEM:
    /* ### */
    break;
  case TT_GLOB:
  case TT_NLOC:
  case TT_UNK:
  case TT_UNINIT:
  default:
    interr("bad PSD type", PSD_TYPE(psdx), ERR_Fatal);
    break;
  }
} /* mark_apte_targets */

/*
 * return TRUE if the pointer source at psdx might
 * intersect with the target at targetpsdx, that is
 * psdx is an indirect with a parent PSD that might point to targetpsdx
 */
static int
might_target(int psdx)
{
  int parentpsdx, parentsl, ptex, sptr, aptex;
  switch (PSD_TYPE(psdx)) {
  case TT_IND:
  case TT_IIND:
    /* see if the parent might point to the lhs;
     * changing the lhs changes the parent pointee, which is this */
    parentpsdx = PSD_PARENT(psdx);
    parentsl = PSD_SLOT(parentpsdx);
    if (LHEAD(parentsl) == TPTE_UNK)
      return TRUE;
    if (unknown_mark == marker)
      return TRUE;
    for (ptex = LHEAD(parentsl); ptex > 0; ptex = TPTE_NEXT(ptex)) {
      switch (TTMASK(TPTE_TYPE(ptex))) {
      case TT_UNK:
      case TT_UNINIT:
        return TRUE;
      case TT_PSYM:
      case TT_ISYM:
        aptex = TPTE_APTEX(ptex);
        if (APTE_MARK(aptex) == marker)
          return TRUE;
        break;
      case TT_NLOC: /* all we know is something nonlocal, may be global */
        if (some_nonlocal_mark == marker)
          return TRUE;
        break;
      case TT_ANON: /* anonymous nonlocal */
      case TT_GDYN:
      case TT_IGDYN:
      case TT_LDYN:
      case TT_ILDYN:
      case TT_CON:
        aptex = TPTE_APTEX(ptex);
        if (APTE_MARK(aptex) == marker)
          return TRUE;
        break;
      default:
        /* real error */
        interr("bad PTE type", TPTE_TYPE(ptex), ERR_Warning);
        return TRUE;
      }
    }
    break;
  case TT_ISYM:
  case TT_PSYM:
    aptex = find_apte(TT_PSYM, PSD_SYM(psdx), 0);
    if (aptex > 0 && APTE_MARK(aptex) == marker)
      return TRUE;
    aptex = find_apte(TT_ISYM, PSD_SYM(psdx), 0);
    if (aptex > 0 && APTE_MARK(aptex) == marker)
      return TRUE;
    sptr = PSD_SYM(psdx);
    break;
    /* ignore the other types, which don't / can't point to the LHS */
  }
  return FALSE;
} /* might_target */

static int CHANGES;

/*
 * Check all the pte's in the list for the lhs
 * if the lhs target list is unknown, stop here
 * if the pte is 'unknown', change lhs target list to unknown, increment
 * CHANGES, stop
 * if there is a match, stop here, no changes
 * if there is a less precise one match, stop here, no changes
 * if there is a more precise one, make it less precise, increment CHANGES, stop
 * here
 * otherwise, add this pte to the list, increment CHANGES
 *  stride is only used for F90
 */
static void
_addtpte(int lhspsdx, int ptex, int imprecise, int mstride)
{
  int ptetype, lpte, lptetype, ptes, ptestype, lptes, lptestype, match, sl;
  int rhspsdx, rsl;
  sl = PSD_SLOT(lhspsdx);
  if (LHEAD(sl) == TPTE_UNK)
    return;
  if (ptex == TPTE_UNK) {
    ++CHANGES;
    free_list_slot(sl);
    LHEAD(sl) = TPTE_UNK;
    return;
  }
  ptetype = TTMASK(TPTE_TYPE(ptex));
  if (imprecise)
    ptetype = imprecise_ptetype(ptetype);
  /* in PGF90, we can't have a pointer to a pointer.
   * p => b where b is a pointer or allocatable means make p
   * point to what b points to */
  if ((ptetype == TT_PSYM || ptetype == TT_ISYM) && TPTE_SPTR(ptex) &&
      (POINTERG(TPTE_SPTR(ptex)) || ALLOCATTRG(TPTE_SPTR(ptex)))) {
    /* get the RHS PSD entry */
    rhspsdx = find_psd(TT_PSYM, 0, TPTE_SPTR(ptex));
    /* if p => a, and a is a pointer or allocatable, then p can point to
     * anything that a can point to */
    if (rhspsdx <= 0) {
      _addtpte(lhspsdx, TPTE_UNK, 0, 0);
    } else {
      int rptex, imp;
      rsl = PSD_SLOT(rhspsdx);
      if (rsl) {
        imp = 0;
        if (ptetype == TT_ISYM || imprecise_ptetype(ptetype) == ptetype)
          imp = 1;
        for (rptex = LHEAD(rsl); rptex > 0; rptex = TPTE_NEXT(rptex)) {
          _addtpte(lhspsdx, rptex, imp, TPTE_STRIDE(ptex));
        }
      }
    }
    return;
  }
  match = 0;
  for (lpte = LHEAD(sl); lpte > 0; lpte = TPTE_NEXT(lpte)) {
    lptetype = TTMASK(TPTE_TYPE(lpte));
    if (imprecise)
      lptetype = imprecise_ptetype(lptetype);
    if (lptetype == ptetype && TPTE_SPTR(lpte) == TPTE_SPTR(ptex) &&
        TPTE_VAL(lpte) == TPTE_VAL(ptex)
        && TPTE_STRIDE(lpte) * mstride == TPTE_STRIDE(lpte)
            ) {
      return;
    }
    /* see if this is indirection from the same symbol */
    match = 1;
    for (lptes = lpte, ptes = ptex; lptes > 0 && ptes > 0;
         lptes = TPTE_VAL(lptes), ptes = TPTE_VAL(ptes)) {
      lptestype = TTMASK(TPTE_TYPE(lptes));
      if (imprecise)
        lptestype = imprecise_ptetype(lptestype);
      ptestype = TTMASK(TPTE_TYPE(ptes));
      if (TPTE_STRIDE(lpte) * mstride != TPTE_STRIDE(lpte)) {
        match = 0;
        break;
      }
      if (lptestype == TT_IND || lptestype == TT_IIND) {
        if (ptestype != TT_IND && ptestype != TT_IIND) {
          match = 0;
          break;
        } else if (TPTE_SPTR(ptes) != TPTE_SPTR(lptes)) {
          match = 0;
          break;
        }
      } else if (lptestype == TT_PSYM || lptestype == TT_ISYM) {
        if (ptestype != TT_PSYM && ptestype != TT_ISYM) {
          match = 0;
          break;
        } else if (TPTE_SPTR(ptes) != TPTE_SPTR(lptes)) {
          match = 0;
          break;
        }
      } else if (lptestype == TT_GDYN || lptestype == TT_IGDYN) {
        if (ptestype != TT_GDYN && ptestype != TT_IGDYN) {
          match = 0;
          break;
        } else if (TPTE_VAL(ptes) != TPTE_VAL(lptes)) {
          match = 0;
          break;
        }
        break;
      } else if (lptestype == TT_LDYN || lptestype == TT_ILDYN) {
        if (ptestype != TT_LDYN && ptestype != TT_ILDYN) {
          match = 0;
          break;
        } else if (TPTE_VAL(ptes) != TPTE_VAL(lptes)) {
          match = 0;
          break;
        }
        break;
      } else {
        match = 0;
        break;
      }
    }
    if (match) {
      /* change lptes to the more imprecise of lptes and ptex, and be done with
       * it */
      for (lptes = lpte, ptes = ptex; lptes > 0 && ptes > 0;
           lptes = TPTE_VAL(lptes), ptes = TPTE_VAL(ptes)) {
        lptestype = TTMASK(TPTE_TYPE(lptes));
        if (imprecise)
          lptestype = imprecise_ptetype(lptestype);
        ptestype = TTMASK(TPTE_TYPE(ptes));
        if (ptestype == TT_IIND) {
          if (lptestype == TT_IND) {
            TPTE_APTEX(lptes) =
                get_apte(TT_IIND, TPTE_SPTR(lptes), TPTE_VAL(lptes),
                         TPTE_STRIDE(lptes) * mstride
                         );
            ++CHANGES;
          }
          /* loop */
        } else if (ptestype == TT_IND) {
          /* loop */
        } else if (ptestype == TT_ISYM) {
          if (lptestype == TT_PSYM) {
            TPTE_APTEX(lptes) =
                get_apte(TT_ISYM, TPTE_SPTR(lptes), TPTE_VAL(lptes),
                         TPTE_STRIDE(lptes) * mstride
                         );
            ++CHANGES;
          }
          break;
        } else if (ptestype == TT_PSYM) {
          break;
        } else if (ptestype == TT_IGDYN) {
          if (lptestype == TT_GDYN) {
            TPTE_APTEX(lptes) =
                get_apte(TT_IGDYN, TPTE_SPTR(lptes), TPTE_VAL(lptes),
                         TPTE_STRIDE(lptes) * mstride
                         );
            ++CHANGES;
          }
          break;
        } else if (ptestype == TT_GDYN) {
          break;
        } else if (ptestype == TT_ILDYN) {
          if (lptestype == TT_LDYN) {
            TPTE_APTEX(lptes) =
                get_apte(TT_ILDYN, TPTE_SPTR(lptes), TPTE_VAL(lptes),
                         TPTE_STRIDE(lptes) * mstride
                         );
            ++CHANGES;
          }
          break;
        } else if (ptestype == TT_LDYN) {
          break;
        } else {
          break;
        }
      }
    }
  }
  if (!match) {
    /* no match found, add */
    ++CHANGES;
    add_list(ptex, lhspsdx, imprecise, mstride);
  }

} /* _addtpte */

static void
addtpte(int lhspsdx, int ptex)
{
  int sl;
  _addtpte(lhspsdx, ptex, 0, 1);
  /* pointers that might target lhs must be modified as well */
  mark_apte_targets(lhspsdx);
  for (sl = 1; sl < gpsd.nslots; ++sl) {
    if (SLOT(sl) != lhspsdx && might_target(SLOT(sl))) {
      _addtpte(SLOT(sl), ptex, 1, 0);
    }
  }
} /* addtpte */

static void
inittpte(int lhspsdx, int ptex)
{
  int sl;
  _addtpte(lhspsdx, ptex, 0, 1);
} /* inittpte */

/*
 * remove the target information for the LHS
 * add the single target from the RHS
 * must modify *LHS to match *RHS
 * anything that can point to LHS must also be modified
 */
static void
replacepte(int lhspsdx, int ptex)
{
  int sl;
  free_list_slot(PSD_SLOT(lhspsdx));
  addtpte(lhspsdx, ptex);
} /* replacepte */

static void
add_tptelist(int lhspsdx, int ptelistx)
{
  int ptex, sl;
  if (ptelistx == TPTE_UNK) {
    _addtpte(lhspsdx, ptelistx, 1, 1);
    /* pointers that might target lhs must be modified as well */
    mark_apte_targets(lhspsdx);
    for (sl = 1; sl < gpsd.nslots; ++sl) {
      if (SLOT(sl) != lhspsdx && might_target(SLOT(sl))) {
        _addtpte(SLOT(sl), ptelistx, 1, 1);
      }
    }
  } else {
    for (ptex = ptelistx; ptex > 0; ptex = TPTE_NEXT(ptex)) {
      _addtpte(lhspsdx, ptex, 0, 1);
    }
    /* pointers that might target lhs must be modified as well */
    /* This is the expensive part:
     *
     *    int** p1, *p2, *p3, *p4, **p5;
     *    int a, b;
     *
     *    p1 = test1 ? &p3 : &p4;	-- here, p1 => p3|p4
     *    p2 = test2 ? &a : &b;		-- here, p2 => a|b
     *
     *    *p1 = p2;
     *
     * We know p1 might point to p3 or p4 and p2 might point to a or b,
     * so we must propagage target a|b to p3 and p4 as well as **p1
     *
     * If we add the assignment
     *    p5 = test3 ? &p3 : NULL;
     * before the *p1 assignment, then p5 might point to p3
     * we must then propagate the target a|b to *p5 as well
     *
     * So, when assigning a pointer value to *p1, any pointer target of p1
     * has its pointer targets updated by the pointer targets of the RHS.
     *
     * In fact, in any pointer assignment, any pointer that might alias
     * the LHS also has its pointer targets updated
     */
    mark_apte_targets(lhspsdx);
    for (sl = 1; sl < gpsd.nslots; ++sl) {
      if (SLOT(sl) != lhspsdx && might_target(SLOT(sl))) {
        for (ptex = ptelistx; ptex > 0; ptex = TPTE_NEXT(ptex)) {
          _addtpte(SLOT(sl), ptex, 1, 1);
        }
      }
    }
  }
} /* add_tptelist */

/*
 *  replace target information for LHS by the list
 */
static void
replace_tptelist(int lhspsdx, int ptelistx)
{
  free_list_slot(PSD_SLOT(lhspsdx));
  add_tptelist(lhspsdx, ptelistx);
} /* replace_tptelist */

/*
 * look at pointer targets of the LHS, add RHS targets to anything
 * that the LHS might point to
 */
static void
add_target_tptelist(int lhspsdx, int ptelistx)
{
  int ptex, sl, psdx;
  add_tptelist(lhspsdx, ptelistx);
  sl = PSD_SLOT(lhspsdx);
  if (LHEAD(sl) == TPTE_UNK) {
    /* everything changes */
    unk_all();
  }
} /* add_target_tptelist */

/*
 * take the RHS of the assignment, compute the effective TPTE list
 */
static int
effective_rhs(int psdx)
{
  int parentpsdx, sl, ptelistx, ptex;
  switch (PSD_TYPE(psdx)) {
  case TT_UNINIT:
    return TPTE_UNINIT;

  case TT_UNK:
    /* totally unknown */
    return TPTE_UNK;

  case TT_IND:
    /* return the list of the target */
    parentpsdx = PSD_PARENT(psdx);
    sl = PSD_SLOT(parentpsdx);
    if (sl == 0) {
      return TPTE_UNK;
    }
    return copy_list(LHEAD(sl));
  case TT_IIND:
    /* find the list of the target */
    parentpsdx = PSD_PARENT(psdx);
    sl = PSD_SLOT(parentpsdx);
    if (sl == 0) {
      return TPTE_UNK;
    }
    ptelistx = copy_list(LHEAD(sl));
    /* now account for the imprecision */
    for (ptex = ptelistx; ptex > 0; ptex = TPTE_NEXT(ptex)) {
      switch (TTMASK(TPTE_TYPE(ptex))) {
      case TT_PSYM:
        /* make imprecise */
        TPTE_APTEX(ptex) = get_apte(TT_ISYM, TPTE_SPTR(ptex), TPTE_VAL(ptex),
                                    TPTE_STRIDE(ptex)
                                        );
        break;
      case TT_ISYM:
        /* already imprecise */
        break;
      case TT_IND:
        /* make imprecise */
        TPTE_APTEX(ptex) = get_apte(TT_IIND, TPTE_SPTR(ptex), TPTE_VAL(ptex),
                                    TPTE_STRIDE(ptex)
                                        );
        break;
      case TT_IIND:
        /* already imprecise */
        break;
      case TT_UNK:
      case TT_UNINIT:
        free_list(ptelistx);
        return TPTE_UNK;
      case TT_CON:
        free_list(ptelistx);
        return TPTE_UNK;
      }
    }
    return ptelistx;
  default:
    /* real error */
    interr("pointsto: unknown RHS type in assignment", PSD_TYPE(psdx), ERR_Fatal);
    return TPTE_UNK;
  }
} /* effective_rhs */

/*
 * symbolically interpret the pointer assignments in this flow graph node
 * represent the pointer target information as a TPTE list
 */
static void
interpret(int asx)
{
  int lhspsdx, l, rhsptelistx, sl, stride;
#if DEBUG
  if (DBGBIT(TRACEFLAG, TRACEBIT)) {
    putassign(asx);
  }
#endif
  stride = ASSTRIDE(asx);
  /* interpret assignment as changes to pointer target information */
  /* pointer equals address is easy, reset pointer target */
  /* pointer equals fetch(pointer) is easy, copy pointer targets */
  /* pointer equals fetch(pointer)imprecise is easy, copy pointer targets,
   *  set imprecise */
  /* pointer equals unknown is easy, clear information */
  /* glob equals unknown is easy, clear information for all globals,
   * anything that might alias a global */
  switch (ASTYPE(asx)) {
  case AS_DIRECT:
    /* RHS must be precise or imprecise symbol. */
    lhspsdx = ASLHS(asx);
    switch (PSD_TYPE(lhspsdx)) {
    case TT_PSYM:
      /* LHS is precise symbol; this is a MUST POINTS TO relationship */
      replacepte(lhspsdx, ASRHS(asx));
      break;

    case TT_ISYM:
      /* LHS is imprecise symbol; this is a MAY POINTS TO relationship */
      addtpte(lhspsdx, ASRHS(asx));
      break;

    case TT_IND:
      /* LHS is indirect; MUST POINTS TO if all indirects are precise */
      replacepte(lhspsdx, ASRHS(asx));
      break;
    case TT_IIND:
      /* LHS is imprecise indirect; MAY POINTS TO */
      addtpte(lhspsdx, ASRHS(asx));
      break;
    case TT_GLOB:
      /* happens at calls.  Mark all globals as unknown */
      unk_globals();
      break;
    case TT_UNK:
    case TT_UNINIT: /* should not happen */
      unk_all();
      break;
    case TT_MEM:
      /* not used yet */
      interr("pointsto: unknown LHS type in assignment", PSD_TYPE(lhspsdx), ERR_Warning);
      unk_all();
      break;
    default:
      /* real error */
      interr("pointsto: unknown LHS type in assignment", PSD_TYPE(lhspsdx), ERR_Fatal);
      unk_all();
      break;
    }
#if DEBUG
    if (DBGBIT(TRACEFLAG, TRACEBIT)) {
      puttarget(PSD_SLOT(lhspsdx));
    }
#endif
    break;
  case AS_ADD_DIRECT:
    /* RHS must be precise or imprecise symbol. */
    lhspsdx = ASLHS(asx);
    switch (PSD_TYPE(lhspsdx)) {
    case TT_PSYM:
    case TT_ISYM:
    case TT_IND:
    case TT_IIND:
      /* LHS is imprecise indirect; MAY POINTS TO */
      addtpte(lhspsdx, ASRHS(asx));
      break;
    case TT_GLOB:
      /* happens at calls.  Mark all globals as unknown */
      unk_globals();
      break;
    case TT_UNK:
    case TT_UNINIT: /* should not happen */
      unk_all();
      break;
    case TT_MEM:
      /* not used yet */
      interr("pointsto: unknown LHS type in assignment", PSD_TYPE(lhspsdx), ERR_Warning);
      unk_all();
      break;
    default:
      /* real error */
      interr("pointsto: unknown LHS type in assignment", PSD_TYPE(lhspsdx), ERR_Fatal);
      unk_all();
      break;
    }
#if DEBUG
    if (DBGBIT(TRACEFLAG, TRACEBIT)) {
      puttarget(PSD_SLOT(lhspsdx));
    }
#endif
    break;
  case AS_INIT:
    /* RHS must be precise or imprecise symbol. */
    lhspsdx = ASLHS(asx);
    sl = PSD_SLOT(lhspsdx);
    if (LHEAD(sl) == TPTE_UNK) {
      free_list_slot(sl);
    }
    switch (PSD_TYPE(lhspsdx)) {
    case TT_PSYM:
      /* LHS is precise symbol; this is a MUST POINTS TO relationship */
      inittpte(lhspsdx, ASRHS(asx));
      break;

    case TT_ISYM:
      /* LHS is imprecise symbol; this is a MAY POINTS TO relationship */
      inittpte(lhspsdx, ASRHS(asx));
      break;

    case TT_IND:
      /* LHS is indirect; MUST POINTS TO if all indirects are precise */
      inittpte(lhspsdx, ASRHS(asx));
      break;
    case TT_IIND:
      /* LHS is imprecise indirect; MAY POINTS TO */
      inittpte(lhspsdx, ASRHS(asx));
      break;
    case TT_UNK:
    case TT_UNINIT: /* should not happen */
      unk_all();
      break;
    case TT_MEM:
      /* not used yet */
      interr("pointsto: unknown LHS type in init assignment", PSD_TYPE(lhspsdx),
             2);
      unk_all();
      break;
    default:
      /* real error */
      interr("pointsto: unknown LHS type in init assignment", PSD_TYPE(lhspsdx),
             4);
      break;
    }
#if DEBUG
    if (DBGBIT(TRACEFLAG, TRACEBIT)) {
      puttarget(PSD_SLOT(lhspsdx));
    }
#endif
    break;
  case AS_INDIRECT:
    /* Get the effect of the RHS */
    rhsptelistx = effective_rhs(ASRHS(asx));
#if DEBUG
    if (DBGBIT(TRACEFLAG, TRACEBIT)) {
      fprintf(gbl.dbgfil, " effective target --> ");
      putptelist(rhsptelistx);
      fprintf(gbl.dbgfil, "\n");
    }
#endif
    lhspsdx = ASLHS(asx);
    switch (PSD_TYPE(lhspsdx)) {
    case TT_PSYM:
      /* LHS is precise symbol; this is a MUST POINTS TO relationship */
      replace_tptelist(lhspsdx, rhsptelistx);
      break;

    case TT_ISYM:
      /* LHS is imprecise symbol; this is a MAY POINTS TO relationship */
      add_tptelist(lhspsdx, rhsptelistx);
      break;

    case TT_GLOB:
      /* this is used when globals might be modified */
      replace_tptelist(lhspsdx, rhsptelistx);
      /* must also modify target list for any global pointer source */
      for (sl = 1; sl < gpsd.nslots; ++sl) {
        if (is_source_global(SLOT(sl))) {
          add_tptelist(SLOT(sl), rhsptelistx);
        }
      }
      break;

    case TT_IND:
    case TT_IIND:
      /* need to handle this */
      add_target_tptelist(lhspsdx, rhsptelistx);
      Trace(("indirect LHS type in assignment"));
      break;
    case TT_UNK:
    case TT_UNINIT: /* should not happen */
      unk_all();
      break;
    case TT_MEM:
      /* ### really want to handle member LHS types */
      interr("pointsto: unknown LHS type in assignment", PSD_TYPE(lhspsdx), ERR_Warning);
      Trace(("unknown LHS type in assignment"));
      break;
    default:
      /* real error */
      interr("pointsto: unknown LHS type in assignment", PSD_TYPE(lhspsdx), ERR_Fatal);
      Trace(("unknown LHS type in assignment"));
      break;
    }
#if DEBUG
    if (DBGBIT(TRACEFLAG, TRACEBIT)) {
      puttarget(PSD_SLOT(lhspsdx));
    }
#endif
    free_list(rhsptelistx);
    break;
  case AS_ADD_INDIRECT:
    /* Get the effect of the RHS */
    rhsptelistx = effective_rhs(ASRHS(asx));
#if DEBUG
    if (DBGBIT(TRACEFLAG, TRACEBIT)) {
      fprintf(gbl.dbgfil, " effective target --> ");
      putptelist(rhsptelistx);
      fprintf(gbl.dbgfil, "\n");
    }
#endif
    lhspsdx = ASLHS(asx);
    switch (PSD_TYPE(lhspsdx)) {
    case TT_PSYM:
    case TT_ISYM:
      /* LHS is imprecise symbol; this is a MAY POINTS TO relationship */
      add_tptelist(lhspsdx, rhsptelistx);
      break;

    case TT_GLOB:
      /* this is used when globals might be modified */
      add_tptelist(lhspsdx, rhsptelistx);
      /* must also modify target list for any global pointer source */
      for (sl = 1; sl < gpsd.nslots; ++sl) {
        if (is_source_global(SLOT(sl))) {
          add_tptelist(SLOT(sl), rhsptelistx);
        }
      }
      break;

    case TT_IND:
    case TT_IIND:
      /* need to handle this */
      add_target_tptelist(lhspsdx, rhsptelistx);
      Trace(("indirect LHS type in assignment"));
      break;
    case TT_UNK:
    case TT_UNINIT: /* should not happen */
      unk_all();
      break;
    case TT_MEM:
      /* ### really want to handle member LHS types */
      interr("pointsto: unknown LHS type in assignment", PSD_TYPE(lhspsdx), ERR_Warning);
      Trace(("unknown LHS type in assignment"));
      break;
    default:
      /* real error */
      interr("pointsto: unknown LHS type in assignment", PSD_TYPE(lhspsdx), ERR_Fatal);
      Trace(("unknown LHS type in assignment"));
      break;
    }
#if DEBUG
    if (DBGBIT(TRACEFLAG, TRACEBIT)) {
      puttarget(PSD_SLOT(lhspsdx));
    }
#endif
    free_list(rhsptelistx);
    break;
  case AS_UNK:
    lhspsdx = ASLHS(asx);
    switch (PSD_TYPE(lhspsdx)) {
    case TT_GLOB:
      /* shouldn't happen.  Mark all globals as unknown */
      unk_globals();
      break;
    case TT_UNK:
    case TT_UNINIT: /* should not happen */
      unk_all();
      break;
    default:
      replace_tptelist(lhspsdx, TPTE_UNK);
      break;
    }
    break;
  case AS_CLEAR:
    break;
  default:
    break;
  }
#if DEBUG
  if (DBGBIT(TRACEFLAG, TRACEBIT)) {
    Trace(("after assignment"));
    puttargets();
  }
#endif
} /* interpret */

/*
 * compare lptex and ptex; if they have the same or comparable type,
 * compare subtypes.  If they all compare exactly, return ptex.
 * if they compare imprecisely, change ptex to be as imprecise as lptex,
 * and return -ptex if changes were made.
 */
static int
imprecise_match(int lptex, int ptex)
{
  int m;
  if (TPTE_STRIDE(lptex) != TPTE_STRIDE(ptex))
    return 0;
  if (TTMASK(TPTE_TYPE(lptex)) == TTMASK(TPTE_TYPE(ptex))) {
    switch (TTMASK(TPTE_TYPE(lptex))) {
    case TT_PSYM:
    case TT_ISYM:
      if (TPTE_SPTR(lptex) == TPTE_SPTR(ptex))
        return ptex;
      return 0;

    case TT_IND:
    case TT_IIND:
      return imprecise_match(TPTE_VAL(lptex), TPTE_VAL(ptex));

    case TT_GDYN:
    case TT_IGDYN:
    case TT_LDYN:
    case TT_ILDYN:
    case TT_ANON:
      if (TPTE_VAL(lptex) == TPTE_VAL(ptex))
        return ptex;
      return 0;

    case TT_CON:
      if (TPTE_VAL(lptex) == TPTE_VAL(ptex))
        return ptex;
      return 0;
    case TT_UNINIT:
    case TT_UNK:
    case TT_NLOC:
      return ptex;
    default:
      /* real error */
      interr("pointsto: unknown TPTE target type", TPTE_TYPE(lptex), ERR_Fatal);
      return 0;
    }
  } else {
    /* not quite an exact match */
    switch (TTMASK(TPTE_TYPE(lptex))) {
    case TT_PSYM:
      /* might match TT_ISYM, if the same symbol */
      if (TTMASK(TPTE_TYPE(ptex)) == TT_ISYM &&
          TPTE_SPTR(lptex) == TPTE_SPTR(ptex))
        return ptex;
      return 0;
    case TT_ISYM:
      /* might match TT_PSYM, if the same symbol, but change to ISYM */
      if (TTMASK(TPTE_TYPE(ptex)) == TT_PSYM &&
          TPTE_SPTR(lptex) == TPTE_SPTR(ptex)) {
        TPTE_APTEX(ptex) = get_apte(TT_ISYM, TPTE_SPTR(ptex), TPTE_VAL(ptex),
                                    TPTE_STRIDE(ptex)
                                        );
        return -ptex;
      }
      return 0;
    case TT_IND:
      /* might match TT_IIND, if the subtypes match */
      if (TTMASK(TPTE_TYPE(ptex)) == TT_IIND) {
        m = imprecise_match(TPTE_VAL(lptex), TPTE_VAL(ptex));
        if (m > 0)
          return ptex;
        if (m < 0)
          return -ptex;
      }
      return 0;
    case TT_IIND:
      /* might match TT_IND, if the subtypes match, but change to IIND */
      if (TTMASK(TPTE_TYPE(ptex)) == TT_IND) {
        m = imprecise_match(TPTE_VAL(lptex), TPTE_VAL(ptex));
        if (m != 0) {
          TPTE_APTEX(ptex) = get_apte(TT_IIND, TPTE_SPTR(ptex), TPTE_VAL(ptex),
                                      TPTE_STRIDE(ptex)
                                          );
          return -ptex;
        }
      }
      return 0;
    default:
      /* no other imprecise matches */
      return 0;
    }
  }
} /* imprecise_match */

/*
 * look along the list at ptelistx; find a match for lptex;
 * an imprecise match is good enough.  If lptex is less precise
 * than the one found, change the one found to be just as imprecise.
 * return 0 if not found, >0 if exact match found, <0 if changes were made
 */
static int
find_imprecise_match(int lptex, int ptelistx)
{
  int ptex, m;
  for (ptex = ptelistx; ptex > 0; ptex = TPTE_NEXT(ptex)) {
    m = imprecise_match(lptex, ptex);
    if (m != 0)
      return m;
  }
  return 0;
} /* find_imprecise_match */

/*
 * combine (take the 'meet') of the information at the head of
 * node v with the new local information we have.  return TRUE if it
 * changes at all
 */
static int
pte_changed(int v)
{
  int changes = 0;
  int sl;
  int lptex, hptex, newptex, newptelistx;
  Trace(("Combine information into node %d block %d", v, FG_TO_BIH(v)));
#if DEBUG
  if (DBGBIT(TRACEFLAG, TRACEBIT))
    putnodetargets("before", v);
#endif
  for (sl = 1; sl < gpsd.nslots; ++sl) {
    if (HEAD(v, sl) == TPTE_UNK) {
      /* already worst case, give up */
    } else if (LHEAD(sl) == TPTE_UNK) {
      free_list(HEAD(v, sl));
      HEAD(v, sl) = TPTE_UNK;
      ++changes;
    } else if (HEAD(v, sl) == TTE_NULL || HEAD(v, sl) == TPTE_UNINIT) {
      if (LHEAD(sl) != TTE_NULL) {
        HEAD(v, sl) = copy_list(LHEAD(sl));
        ++changes;
      }
    } else if (LHEAD(sl) == TTE_NULL) {
      /* nothing to add */
    } else {
      /* compare pointer targets one at a time */
      /* collect all new PTEs here */
      newptelistx = TTE_NULL;
      for (lptex = LHEAD(sl); lptex > 0; lptex = TPTE_NEXT(lptex)) {
        /* find a matching or almost-matching TPTE in HEAD */
        hptex = find_imprecise_match(lptex, HEAD(v, sl));
        if (hptex == 0) {
          newptex = copy_pte(lptex, 0, 1);
          TPTE_NEXT(newptex) = newptelistx;
          newptelistx = newptex;
          ++changes;
        } else if (hptex < 0) {
          /* flag that something changed */
          ++changes;
        }
      }
      /* add newptelistx to HEAD(v,sl) */
      if (newptelistx > 0) {
        for (newptex = newptelistx; TPTE_NEXT(newptex) > 0;
             newptex = TPTE_NEXT(newptex))
          ;
        TPTE_NEXT(newptex) = HEAD(v, sl);
        HEAD(v, sl) = newptelistx;
      }
    }
  }
#if DEBUG
  if (DBGBIT(TRACEFLAG, TRACEBIT) && changes)
    putnodetargets(" after", v);
#endif
  return changes;
} /* pte_changed */

#if DEBUG
static int
check_this_assignment(int asx, int v)
{
  int ptex;
  if (ASTYPE(asx) == AS_DIRECT || ASTYPE(asx) == AS_INIT ||
      ASTYPE(asx) == AS_ADD_DIRECT) {
    ptex = ASRHS(asx);
    if (ptex >= gpte.stg_avail) {
      fprintf(gbl.dbgfil, "TPTE(%d) is on list for node %d, assignment %d, but "
                          "past avail point %d\n",
              ptex, v, asx, gpte.stg_avail);
      return 1;
    } else if (TPTE_FLAG(ptex) == 0) {
      TPTE_FLAG(ptex) = -asx;
    } else if (TPTE_FLAG(ptex) == -9999999) {
      fprintf(gbl.dbgfil, "TPTE(%d) is on list for node %d, assignment %d, but "
                          "also on free list\n",
              ptex, v, asx);
      return 1;
    } else if (TPTE_FLAG(ptex) < 0) {
      fprintf(gbl.dbgfil, "TPTE(%d) is on list for node %d, assignment %d, but "
                          "also on list for assignment %d\n",
              ptex, v, asx, -TPTE_FLAG(ptex));
      return 1;
    } else if (TPTE_FLAG(ptex) > 0) {
      fprintf(gbl.dbgfil, "TPTE(%d) is on list for node %d, assignment %d, but "
                          "also on list for node %d\n",
              ptex, v, asx, TPTE_FLAG(ptex));
      return 1;
    }
  }
  return 0;
} /* check_this_assignment */

/*
 * see that all TPTE entries are on a list somewhere
 */
static void
check_pte(char *ch)
{
  int v, sl, ptex, bad, asx, stdx;
  for (ptex = 1; ptex < gpte.stg_avail; ++ptex)
    TPTE_FLAG(ptex) = 0;
  /* mark the free list */
  bad = 0;
  for (ptex = gpte.xstg_free; ptex > 0; ptex = TPTE_NEXT(ptex)) {
    if (ptex >= gpte.stg_avail) {
      fprintf(gbl.dbgfil, "TPTE(%d) is on free list but past avail point %d\n",
              ptex, gpte.stg_avail);
      bad = 1;
      break;
    } else if (TPTE_FLAG(ptex) == 0) {
      TPTE_FLAG(ptex) = -9999999;
    } else {
      fprintf(gbl.dbgfil, "TPTE(%d) is on free list twice\n", ptex);
      bad = 1;
      break;
    }
  }
  /* mark pte on target list of each slot at each node */
  for (v = 1; v <= opt.num_nodes; ++v) {
    if (nodeoffset[v] == 0)
      continue;
    for (sl = 1; sl < gpsd.nslots; ++sl) {
      if (HEAD(v, sl) != TPTE_UNINIT) {
        for (ptex = HEAD(v, sl); ptex > 0; ptex = TPTE_NEXT(ptex)) {
          if (ptex >= gpte.stg_avail) {
            fprintf(gbl.dbgfil, "TPTE(%d) is on list for node %d, slot %d, but "
                                "past avail point %d\n",
                    ptex, v, sl, gpte.stg_avail);
            bad = 1;
            break;
          } else if (TPTE_FLAG(ptex) == 0) {
            TPTE_FLAG(ptex) = v;
          } else if (TPTE_FLAG(ptex) == -9999999) {
            fprintf(gbl.dbgfil, "TPTE(%d) is on list for node %d, slot %d, but "
                                "also on free list\n",
                    ptex, v, sl);
            bad = 1;
            break;
          } else if (TPTE_FLAG(ptex) < 0) {
            fprintf(gbl.dbgfil, "TPTE(%d) is on list for node %d, slot %d, but "
                                "also on list for assignment %d\n",
                    ptex, v, sl, -TPTE_FLAG(ptex));
            bad = 1;
            break;
          } else if (TPTE_FLAG(ptex) > 0) {
            fprintf(gbl.dbgfil, "TPTE(%d) is on list for node %d, slot %d, but "
                                "also on list for node %d\n",
                    ptex, v, sl, TPTE_FLAG(ptex));
            bad = 1;
            break;
          }
        }
      }
    }
/* mark pte on direct assignments */
    for (stdx = FG_STDFIRST(v); stdx; stdx = STD_NEXT(stdx)) {
      for (asx = FIRSTAS(stdx); asx > 0; asx = ASNEXT(asx)) {
        bad += check_this_assignment(asx, stdx);
      }
      if (stdx == FG_STDLAST(v))
        break;
    }
    /* also check any unreachable statements following this node up to
     * the next node */
    stdx = FG_STDLAST(v);
    for (stdx = STD_NEXT(stdx); stdx && STD_FG(stdx) == 0;
         stdx = STD_NEXT(stdx)) {
      for (asx = FIRSTAS(stdx); asx > 0; asx = ASNEXT(asx)) {
        bad += check_this_assignment(asx, stdx);
      }
    }
  }
  for (ptex = 2; ptex < gpte.stg_avail; ++ptex) {
    if (TPTE_FLAG(ptex) == 0) {
      fprintf(gbl.dbgfil, "TPTE(%d) is not on any list\n", ptex);
      bad = 1;
    }
  }
  if (bad) {
    /* real error, consistency check failure */
    interr(ch, 0, ERR_Fatal);
  }
} /* check_pte */
#endif

/*
 * return TRUE if this node is critical, that is, has 0 or >1 predecessor,
 * or has a single predecessor that has >1 successor
 * also mark successor of entry BIH as critical,
 * and any block with XT as critical
 */
static int
critical(int v)
{
  int s;
  return TRUE;
} /* critical */

                   /*
                    * save the information as a list of aliases for each statement
                    * head of list at STD_PTA
                    */
typedef struct {
  int next; /* next pointer target */
  int type; /* pointer target type */
  int sptr; /* type-specific value */
  int val;  /* type-specific value */
  int stride;
} FPTE;

static STG_DECLARE(fpte, FPTE);

typedef struct {
  int next;    /* next pointer source */
  int type;    /* type of source */
  int sptr;    /* symbol */
  int ptelist; /* list of pointer targets */
} FPSRC;

static STG_DECLARE(fpsrc, FPSRC);

#if DEBUG
#define FPTE_NEXT(n)                                            \
  fpte.stg_base[n >= 0 && n < fpte.stg_avail                    \
                    ? n                                         \
                    : (interr("bad FPTE_NEXT index", n, 4), 0)] \
      .next
#define FPTE_TYPE(n)                                            \
  fpte.stg_base[n >= 0 && n < fpte.stg_avail                    \
                    ? n                                         \
                    : (interr("bad FPTE_TYPE index", n, 4), 0)] \
      .type
#define FPTE_SPTR(n)                                            \
  fpte.stg_base[n >= 0 && n < fpte.stg_avail                    \
                    ? n                                         \
                    : (interr("bad FPTE_SPTR index", n, 4), 0)] \
      .sptr
#define FPTE_VAL(n)                                            \
  fpte.stg_base[n >= 0 && n < fpte.stg_avail                   \
                    ? n                                        \
                    : (interr("bad FPTE_VAL index", n, 4), 0)] \
      .val
#define FPTE_STRIDE(n)                                            \
  fpte.stg_base[n >= 0 && n < fpte.stg_avail                      \
                    ? n                                           \
                    : (interr("bad FPTE_STRIDE index", n, 4), 0)] \
      .stride

#define FPSRC_NEXT(n)                                             \
  fpsrc.stg_base[n >= 0 && n < fpsrc.stg_avail                    \
                     ? n                                          \
                     : (interr("bad FPSRC_NEXT index", n, 4), 0)] \
      .next
#define FPSRC_TYPE(n)                                             \
  fpsrc.stg_base[n >= 0 && n < fpsrc.stg_avail                    \
                     ? n                                          \
                     : (interr("bad FPSRC_TYPE index", n, 4), 0)] \
      .type
#define FPSRC_SPTR(n)                                             \
  fpsrc.stg_base[n >= 0 && n < fpsrc.stg_avail                    \
                     ? n                                          \
                     : (interr("bad FPSRC_SPTR index", n, 4), 0)] \
      .sptr
#define FPSRC_PTELIST(n)                                             \
  fpsrc.stg_base[n >= 0 && n < fpsrc.stg_avail                       \
                     ? n                                             \
                     : (interr("bad FPSRC_PTELIST index", n, 4), 0)] \
      .ptelist
#else
#define FPTE_NEXT(n) fpte.stg_base[n].next
#define FPTE_TYPE(n) fpte.stg_base[n].type
#define FPTE_SPTR(n) fpte.stg_base[n].sptr
#define FPTE_VAL(n) fpte.stg_base[n].val
#define FPTE_STRIDE(n) fpte.stg_base[n].stride

#define FPSRC_NEXT(n) fpsrc.stg_base[n].next
#define FPSRC_TYPE(n) fpsrc.stg_base[n].type
#define FPSRC_SPTR(n) fpsrc.stg_base[n].sptr
#define FPSRC_PTELIST(n) fpsrc.stg_base[n].ptelist
#endif

/*
 * initialize F90 final data structures
 */
static int last_pta = 0;

static void
f90_init(void)
{
  int stdx;
  int ptr_assgns = 0;
  for (stdx = STD_NEXT(0); stdx; stdx = STD_NEXT(stdx)) {
    int astx = STD_AST(stdx);
    STD_PTA(stdx) = 0;
    if (A_TYPEG(astx) == A_ICALL && A_OPTYPEG(astx) == I_PTR2_ASSIGN)
      ptr_assgns++;
  }
  STG_ALLOC(fpte, ptr_assgns * gpsd.nslots + gpsd.nslots + 100);
  STG_ALLOC(fpsrc, ptr_assgns * gpsd.nslots + gpsd.nslots + 100);
  last_pta = 0;
} /* f90_init */

/*
 * clean up when done
 */
void
f90_fini_pointsto(void)
{
  int stdx;
  for (stdx = STD_NEXT(0); stdx; stdx = STD_NEXT(stdx)) {
    STD_PTA(stdx) = 0;
  }
  STG_DELETE(fpsrc);
  fpsrc.stg_base = NULL;
  fpsrc.stg_avail = 0;
  fpsrc.stg_size = 0;
  STG_DELETE(fpte);
  fpte.stg_base = NULL;
  fpte.stg_avail = 0;
  fpte.stg_size = 0;
} /* f90_fini_pointsto */

/*
 * add new fpsrc entry, link into a list of them for this STD
 */
static int
add_fpsrc(int psdx, int fpsrcx)
{
  int n;
  switch (PSD_TYPE(psdx)) {
  case TT_PSYM:
  case TT_ISYM:
  case TT_MEM:
  case TT_GLOB:
    n = STG_NEXT(fpsrc);
    switch (PSD_TYPE(psdx)) {
    case TT_PSYM:
    case TT_ISYM:
      FPSRC_TYPE(n) = PSD_TYPE(psdx);
      FPSRC_SPTR(n) = PSD_SYM(psdx);
      break;
    case TT_MEM:
      FPSRC_TYPE(n) = TT_ISYM;
      for (; PSD_PARENT(psdx); psdx = PSD_PARENT(psdx))
        ;
      FPSRC_SPTR(n) = PSD_SYM(psdx);
      break;
    case TT_GLOB:
      FPSRC_TYPE(n) = TT_GLOB;
      FPSRC_SPTR(n) = 0;
      break;
    }
    FPSRC_PTELIST(n) = 0;
    FPSRC_NEXT(n) = fpsrcx;
    return n;
  default:
    return fpsrcx;
  }
} /* add_fpsrc */

static void
add_fpte(int ptex, int fpsrcx)
{
  int n;
  switch (TTMASK(TPTE_TYPE(ptex))) {
  case TT_PSYM:
  case TT_ISYM:
  case TT_ANON:
  case TT_GDYN:
  case TT_IGDYN:
  case TT_LDYN:
  case TT_ILDYN:
  case TT_CON:
  case TT_NLOC:
    n = STG_NEXT(fpte);
    FPTE_TYPE(n) = TTMASK(TPTE_TYPE(ptex));
    FPTE_SPTR(n) = TPTE_SPTR(ptex);
    FPTE_VAL(n) = TPTE_VAL(ptex);
    FPTE_STRIDE(n) = TPTE_STRIDE(ptex);
    FPTE_NEXT(n) = FPSRC_PTELIST(fpsrcx);
    FPSRC_PTELIST(fpsrcx) = n;
    return;
  default:
    return;
  }
} /* add_fpte */

#if DEBUG /* { */

static FILE *dfile;

static void
putsrc(int fpsrcx)
{
  switch (FPSRC_TYPE(fpsrcx)) {
  case TT_PSYM:
    fprintf(dfile, "%d:%s", FPSRC_SPTR(fpsrcx), SYMNAME(FPSRC_SPTR(fpsrcx)));
    break;
  case TT_ISYM:
    fprintf(dfile, "%d:%s?", FPSRC_SPTR(fpsrcx), SYMNAME(FPSRC_SPTR(fpsrcx)));
    break;
  case TT_IND:
    fprintf(dfile, "?ind");
    break;
  case TT_IIND:
    fprintf(dfile, "?iind");
    break;
  case TT_MEM:
    fprintf(dfile, "%d:%s.member", FPSRC_SPTR(fpsrcx),
            SYMNAME(FPSRC_SPTR(fpsrcx)));
    break;
  case TT_GLOB:
    fprintf(dfile, ".glob.");
    break;
  case TT_NLOC:
    fprintf(dfile, ".nloc!.");
    break;
  case TT_UNINIT:
    fprintf(dfile, "Uninit!");
    break;
  case TT_UNK:
    fprintf(dfile, "Unknown!");
    break;
  default:
    fprintf(dfile, ".??%d:%d.", FPSRC_TYPE(fpsrcx), FPSRC_SPTR(fpsrcx));
    break;
  }
} /* putsrc */

static void
putfpte(int fptex)
{
  fprintf(dfile, "[%d]", fptex);
  switch (FPTE_TYPE(fptex)) {
  case TT_UNINIT:
    fprintf(dfile, "&.uninit.");
    break;
  case TT_UNK:
    fprintf(dfile, "&.unk.");
    break;
  case TT_PSYM:
    fprintf(dfile, "&%d:%s", FPTE_SPTR(fptex), SYMNAME(FPTE_SPTR(fptex)));
    break;
  case TT_ISYM:
    fprintf(dfile, "&%d:%s?", FPTE_SPTR(fptex), SYMNAME(FPTE_SPTR(fptex)));
    break;
  case TT_ANON:
    fprintf(dfile, "&anon:%d", FPTE_VAL(fptex));
    break;
  case TT_GDYN:
    fprintf(dfile, "&dyn:%d", FPTE_VAL(fptex));
    break;
  case TT_IGDYN:
    fprintf(dfile, "&dyn:%d?", FPTE_VAL(fptex));
    break;
  case TT_LDYN:
    fprintf(dfile, "&ldyn:%d", FPTE_VAL(fptex));
    break;
  case TT_ILDYN:
    fprintf(dfile, "&ldyn:%d?", FPTE_VAL(fptex));
    break;
  case TT_CON:
    fprintf(dfile, "&con:%d", FPTE_VAL(fptex));
    break;
  case TT_NLOC:
    fprintf(dfile, "&.nloc.");
    break;
  case TT_IND:
    /* should not appear */
    fprintf(dfile, "?ind");
    break;
  case TT_IIND:
    /* should not appear */
    fprintf(dfile, "?iind");
    break;
  case TT_MEM:
    /* should not appear */
    fprintf(dfile, "?mem");
    break;
  case TT_GLOB:
    /* should not appear */
    fprintf(dfile, "?glob");
    break;
  default:
    /* should not appear */
    fprintf(dfile, "???%d:%d", FPTE_TYPE(fptex), FPTE_VAL(fptex));
    break;
  }
  if (FPTE_STRIDE(fptex) > 0) {
    fprintf(gbl.dbgfil, "(::%d)", FPTE_STRIDE(fptex));
  }
} /* putfpte */

void
putstdpta(int stdx)
{
  int fpsrcx, fptex;
  dfile = gbl.dbgfil ? gbl.dbgfil : stderr;
  if (STD_PTA(stdx)) {
    fprintf(dfile, "          pta(%d @ %d) ", stdx, STD_PTA(stdx));
    for (fpsrcx = STD_PTA(stdx); fpsrcx; fpsrcx = FPSRC_NEXT(fpsrcx)) {
      fprintf(dfile, "; ");
      putsrc(fpsrcx);
      fprintf(dfile, "=>");
      for (fptex = FPSRC_PTELIST(fpsrcx); fptex; fptex = FPTE_NEXT(fptex)) {
        putfpte(fptex);
      }
    }
    fprintf(dfile, "\n");
  }
} /* putstdpta */

#endif /* } debug */

static bool
different_pta(int pta1, int pta2)
{
  int p1, p2;
  for (; pta1 && pta2; pta1 = FPSRC_NEXT(pta1), pta2 = FPSRC_NEXT(pta2)) {
    if (FPSRC_TYPE(pta1) != FPSRC_TYPE(pta2))
      return TRUE;
    if (FPSRC_SPTR(pta1) != FPSRC_SPTR(pta2))
      return TRUE;
    for (p1 = FPSRC_PTELIST(pta1), p2 = FPSRC_PTELIST(pta2); p1 && p2;
         p1 = FPTE_NEXT(p1), p2 = FPTE_NEXT(p2)) {
      if (FPTE_TYPE(p1) != FPTE_TYPE(p2))
        return TRUE;
      if (FPTE_SPTR(p1) != FPTE_SPTR(p2))
        return TRUE;
      if (FPTE_VAL(p1) != FPTE_VAL(p2))
        return TRUE;
      if (FPTE_STRIDE(p1) != FPTE_STRIDE(p2))
        return TRUE;
    }
    if (p1 || p1)
      return TRUE;
  }
  if (pta1 || pta2)
    return TRUE;
  /* identical lists */
  return FALSE;
} /* different_pta */

/*
 * Make a copy of the current list for the current statement
 * we can use the same list as for the last std if 'change' == 0
 */

static void
set_std_pta(int stdx, int change)
{
  int sl, psdx, ptex, this_pta, nthis_pta, save_fpte_avail, save_fpsrc_avail;
  if (last_pta && !change) {
    STD_PTA(stdx) = last_pta;
  } else {
    this_pta = 0;
    save_fpte_avail = fpte.stg_avail;
    save_fpsrc_avail = fpsrc.stg_avail;
    for (sl = 1; sl < gpsd.nslots; ++sl) {
      if (LHEAD(sl) != TTE_NULL && LHEAD(sl) != TPTE_UNK) {
        psdx = SLOT(sl);
        nthis_pta = add_fpsrc(psdx, this_pta);
        if (nthis_pta != this_pta) {
          this_pta = nthis_pta;
          for (ptex = LHEAD(sl); ptex > 0; ptex = TPTE_NEXT(ptex)) {
            add_fpte(ptex, this_pta);
          }
        }
      }
    }
    if (!different_pta(this_pta, last_pta)) {
      fpte.stg_avail = save_fpte_avail;
      fpsrc.stg_avail = save_fpsrc_avail;
      this_pta = last_pta;
    }
    STD_PTA(stdx) = this_pta;
    last_pta = this_pta;
  }
} /* set_std_pta */

/*
 * used externally
 *  using the previously collected pointer target information,
 *  try to determine whether the pointer at ptrsptr might point to
 *  the symbol targetsptr, or, if targetsptr is itself a pointer,
 *  might point to the same target as targetsptr
 * return TRUE if we know nothing, or we know (or believe) they might conflict
 * return FALSE if we can prove they don't conflict
 *
 * arguments are the std indices for the pointer and target references,
 * the base SPTRs of the references,
 * whether the target reference has the TARGET attribute
 * and whether the target also has the pointer attribute
 *
 * possible targets are:
 *  psym - precise symbol, with symbol sptr
 *  isym - imprecise symbol, perhaps a member of derived type, with base sptr
 *  anon - some anonymous symbol, we have no more information, but an
 *identifying tag
 *         this information comes from IPA
 *  nloc - nonlocal targets - anything but a local symbol, used for initial
 *values
 *  ldyn - locally allocated dynamic memory, with unique tag for each allocate
 *point
 *  gdyn - dynamically allocated memory from somewhere outside this routine
 *         from IPA
 *  con  - used for NULLIFY statements, DEALLOCATE statements, essentially null
 *pointer
 *  unk  - unknown
 *
 * possible conflicts for pointer and target are:
 *  ptr
 *	psym	conflict if psym sptr matches target
 *	isym	conflict if psym sptr matches target
 *	anon	no conflict - IPA only uses anon when this routine does not
 *see the symbol
 *	nloc	conflict if target is not a local (common, or host)
 *	ldyn	no conflict
 *	gdyn	no conflict
 *	con	no conflict (null doesn't conflict with anything)
 *	unk	conflict
 *	default	conflict
 *
 * possible conflicts for two pointers are:
 *
 *		psym	isym	anon	nloc	ldyn	gdyn	con
 *unk	default
 *	psym	MAY(1)	MAY(1)	no	MAY(2)	no	no
 *never	YES	YES
 *	isym	MAY(1)	MAY(1)	no	MAY(2)	no	no
 *never	YES	YES
 *	anon	no	no	MAY(3)	YES(4)	no	no	never
 *YES	YES
 *	nloc	MAY(2)	MAY(2)	YES(4)	YES	no	YES(4)
 *never	YES	YES
 *	ldyn	no	no	no	no	MAY(3)	no	never
 *YES	YES
 *	gdyn	no	no	no	YES(4)	no	MAY(3)	never
 *YES	YES
 *	con	never	never	never	never	never	never
 *never	never	never
 *	unk	YES	YES	YES	YES	YES	YES	never
 *YES	YES
 *	default	YES	YES	YES	YES	YES	YES	never
 *YES	YES
 *
 * this matrix should be symmetric
 * notes:
 * (1) two symbol targets conflict if the sptrs are the same
 * (2) symbol and nloc conflict if the symbol is not local
 * (3) two anons, ldyns, gdyns conflict if the unique value is the same
 * (4) nloc conflicts with anon and gdyn because nloc is a nonlocal target, anon
 *is
 *     an anonymous global memory location
 */

#undef TRACEFLAG
#undef TRACEBIT
#define TRACEFLAG 10
#define TRACEBIT 0x1000000

bool
pta_conflict(int ptrstdx, int ptrsptr, int targetstdx, int targetsptr,
             int targetpointer, int targettarget)
{
  int ptrsrc, targetsrc, ptrpte, targetpte;
  if (fpsrc.stg_base == NULL)
    return TRUE;
  /* see whether we have information about pointer targets for source ptrsptr at
   * statement ptrstdx */
  ptrsrc = STD_PTA(ptrstdx);
  for (; ptrsrc; ptrsrc = FPSRC_NEXT(ptrsrc)) {
    if (FPSRC_SPTR(ptrsrc) == ptrsptr)
      break;
  }
  if (ptrsrc == 0) {
#if DEBUG
    if (DBGBIT(TRACEFLAG, TRACEBIT)) {
      fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to POINTER symbol "
                          "%d:%s in std:%d\n pointer pointees are unknown\n",
              ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
              SYMNAME(targetsptr), targetstdx);
    }
#endif
    return TRUE; /* we know nothing about what this pointer targets */
  }

  if (targettarget) {
    /* 'target' has TARGET attribute. see if ptr can point to target */
    for (ptrpte = FPSRC_PTELIST(ptrsrc); ptrpte; ptrpte = FPTE_NEXT(ptrpte)) {
      switch (FPTE_TYPE(ptrpte)) {
      case TT_PSYM:
      case TT_ISYM:
        /* does the symbol match? */
        if (FPTE_SPTR(ptrpte) == targetsptr) {
#if DEBUG
          if (DBGBIT(TRACEFLAG, TRACEBIT)) {
            fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to TARGET "
                                "symbol %d:%s in std:%d\n pointer targets the "
                                "symbol directly\n",
                    ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                    SYMNAME(targetsptr), targetstdx);
          }
#endif
          return TRUE;
        }
        break;
      case TT_ANON:
      case TT_GDYN:
      case TT_IGDYN:
      case TT_LDYN:
      case TT_ILDYN:
      case TT_CON:
        /* these don't conflict with any symbol */
        break;
      case TT_NLOC:
        /* is targetsptr a nonlocal? */
        if (gbl.internal > 1 && !INTERNALG(targetsptr)) {
#if DEBUG
          if (DBGBIT(TRACEFLAG, TRACEBIT)) {
            fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to TARGET "
                                "symbol %d:%s in std:%d\n pointer targets "
                                "nonlocal memory, target is from the host\n",
                    ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                    SYMNAME(targetsptr), targetstdx);
          }
#endif
          return TRUE;
        } else {
          switch (SCG(targetsptr)) {
          case SC_CMBLK:
          case SC_EXTERN:
#if DEBUG
            if (DBGBIT(TRACEFLAG, TRACEBIT)) {
              fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to TARGET "
                                  "symbol %d:%s in std:%d\n pointer targets "
                                  "nonlocal memory, target is global\n",
                      ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                      SYMNAME(targetsptr), targetstdx);
            }
#endif
            return TRUE;
          default:;
          }
        }
        break;
      case TT_UNK:
      case TT_UNINIT:
/* might point anywhere */
#if DEBUG
        if (DBGBIT(TRACEFLAG, TRACEBIT)) {
          fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to TARGET "
                              "symbol %d:%s in std:%d pointer may point "
                              "anywhere\n",
                  ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                  SYMNAME(targetsptr), targetstdx);
        }
#endif
        return TRUE;
      case TT_IND:
      case TT_IIND:
      case TT_MEM:
      case TT_GLOB:
      default:
/* should not appear */
#if DEBUG
        if (DBGBIT(TRACEFLAG, TRACEBIT)) {
          fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to TARGET "
                              "symbol %d:%s in std:%d unexpected condition\n",
                  ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                  SYMNAME(targetsptr), targetstdx);
        }
#endif
        return TRUE;
      }
    }
  }

  if (targetpointer) {
    /* target has the pointer attribute as well */
    targetsrc = STD_PTA(targetstdx);
    for (; targetsrc; targetsrc = FPSRC_NEXT(targetsrc)) {
      if (FPSRC_SPTR(targetsrc) == targetsptr)
        break;
    }
    if (targetsrc == 0) {
#if DEBUG
      if (DBGBIT(TRACEFLAG, TRACEBIT)) {
        fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to POINTER "
                            "symbol %d:%s in std:%d\n target pointees are "
                            "unknown\n",
                ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                SYMNAME(targetsptr), targetstdx);
      }
#endif
      return TRUE; /* we know nothing about what this pointer targets */
    }

    /* compare the two pointer target lists for a match */
    for (ptrpte = FPSRC_PTELIST(ptrsrc); ptrpte; ptrpte = FPTE_NEXT(ptrpte)) {
      switch (FPTE_TYPE(ptrpte)) {
      case TT_UNK:
      case TT_UNINIT:
/* ptr might point anywhere */
#if DEBUG
        if (DBGBIT(TRACEFLAG, TRACEBIT)) {
          fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to POINTER "
                              "symbol %d:%s in std:%d\n pointer may point "
                              "anywhere\n",
                  ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                  SYMNAME(targetsptr), targetstdx);
        }
#endif
        return TRUE;
      case TT_IND:
      case TT_IIND:
      case TT_MEM:
      case TT_GLOB:
      default:
/* should not appear */
#if DEBUG
        if (DBGBIT(TRACEFLAG, TRACEBIT)) {
          fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to POINTER "
                              "symbol %d:%s in std:%d\n unexpected condition\n",
                  ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                  SYMNAME(targetsptr), targetstdx);
        }
#endif
        return TRUE;
      case TT_CON:
        if (FPTE_VAL(ptrpte) != 0) {
#if DEBUG
          if (DBGBIT(TRACEFLAG, TRACEBIT)) {
            fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to POINTER "
                                "symbol %d:%s in std:%d\n pointer may point to "
                                "nonnull constant\n",
                    ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                    SYMNAME(targetsptr), targetstdx);
          }
#endif
          return TRUE;
        }
        break;
      case TT_PSYM:
      case TT_ISYM:
      case TT_ANON:
      case TT_GDYN:
      case TT_IGDYN:
      case TT_LDYN:
      case TT_ILDYN:
      case TT_NLOC:
        break;
      }
      for (targetpte = FPSRC_PTELIST(targetsrc); targetpte;
           targetpte = FPTE_NEXT(targetpte)) {
        switch (FPTE_TYPE(targetpte)) {
        case TT_UNK:
        case TT_UNINIT:
/* target might point anywhere */
#if DEBUG
          if (DBGBIT(TRACEFLAG, TRACEBIT)) {
            fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to POINTER "
                                "symbol %d:%s in std:%d\n target may point "
                                "anywhere\n",
                    ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                    SYMNAME(targetsptr), targetstdx);
          }
#endif
          return TRUE;
        case TT_IND:
        case TT_IIND:
        case TT_MEM:
        case TT_GLOB:
        default:
/* should not appear */
#if DEBUG
          if (DBGBIT(TRACEFLAG, TRACEBIT)) {
            fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to POINTER "
                                "symbol %d:%s in std:%d\n unexpected target "
                                "condition\n",
                    ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                    SYMNAME(targetsptr), targetstdx);
          }
#endif
          return TRUE;
        case TT_CON:
          if (FPTE_VAL(targetpte) != 0) {
#if DEBUG
            if (DBGBIT(TRACEFLAG, TRACEBIT)) {
              fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to "
                                  "POINTER symbol %d:%s in std:%d\n target may "
                                  "point to nonnull constant\n",
                      ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                      SYMNAME(targetsptr), targetstdx);
            }
#endif
            return TRUE;
          }
          break;
        case TT_PSYM:
        case TT_ISYM:
        case TT_ANON:
        case TT_GDYN:
        case TT_IGDYN:
        case TT_LDYN:
        case TT_ILDYN:
        case TT_NLOC:
          break;
        }

        switch (FPTE_TYPE(ptrpte)) {
        case TT_PSYM:
        case TT_ISYM:
          switch (FPTE_TYPE(targetpte)) {
          case TT_PSYM:
          case TT_ISYM:
            /* do the symbols match? */
            if (FPTE_SPTR(ptrpte) == FPTE_SPTR(targetpte)) {
#if DEBUG
              if (DBGBIT(TRACEFLAG, TRACEBIT)) {
                fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to "
                                    "POINTER symbol %d:%s in std:%d\n both may "
                                    "point to %d:%s\n",
                        ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                        SYMNAME(targetsptr), targetstdx, FPTE_SPTR(ptrpte),
                        SYMNAME(FPTE_SPTR(ptrpte)));
              }
#endif
              return TRUE;
            }
            break;
          case TT_NLOC:
            /* is ptr symbol a nonlocal? */
            if (gbl.internal > 1 && !INTERNALG(FPTE_SPTR(ptrpte))) {
#if DEBUG
              if (DBGBIT(TRACEFLAG, TRACEBIT)) {
                fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to "
                                    "POINTER symbol %d:%s in std:%d\n pointer "
                                    "may point to %d:%s, target may point to "
                                    "nonlocal\n",
                        ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                        SYMNAME(targetsptr), targetstdx, FPTE_SPTR(ptrpte),
                        SYMNAME(FPTE_SPTR(ptrpte)));
              }
#endif
              return TRUE;
            } else {
              switch (SCG(FPTE_SPTR(ptrpte))) {
              case SC_CMBLK:
              case SC_EXTERN:
#if DEBUG
                if (DBGBIT(TRACEFLAG, TRACEBIT)) {
                  fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to "
                                      "POINTER symbol %d:%s in std:%d\n "
                                      "pointer may point to %d:%s, target may "
                                      "point to common\n",
                          ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                          SYMNAME(targetsptr), targetstdx, FPTE_SPTR(ptrpte),
                          SYMNAME(FPTE_SPTR(ptrpte)));
                }
#endif
                return TRUE;
              default:;
              }
            }
            break;
            /* symbols do not conflict with ldyn, gdyn, anon;
             *  unk and default cases already handled */
          }
          break;
        case TT_LDYN:
        case TT_ILDYN:
          /* only conflicts with the another local dynamic and value */
          if (FPTE_TYPE(targetpte) == FPTE_TYPE(ptrpte)) {
            if (FPTE_VAL(targetpte) == FPTE_VAL(ptrpte)) {
#if DEBUG
              if (DBGBIT(TRACEFLAG, TRACEBIT)) {
                fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to "
                                    "POINTER symbol %d:%s in std:%d\n both "
                                    "point to local dynamically allocated "
                                    "memory\n",
                        ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                        SYMNAME(targetsptr), targetstdx);
              }
#endif
              return TRUE;
            }
          }
          /* else no conflict from this target */
          break;
        case TT_ANON:
        case TT_GDYN:
        case TT_IGDYN:
          /* conflicts with same type and value,
           * also conflicts with NLOC */
          if (FPTE_TYPE(targetpte) == FPTE_TYPE(ptrpte)) {
            if (FPTE_VAL(targetpte) == FPTE_VAL(ptrpte)) {
#if DEBUG
              if (DBGBIT(TRACEFLAG, TRACEBIT)) {
                fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to "
                                    "POINTER symbol %d:%s in std:%d\n both may "
                                    "point to globally allocated memory\n",
                        ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                        SYMNAME(targetsptr), targetstdx);
              }
#endif
              return TRUE;
            }
          } else if (FPTE_TYPE(targetpte) == TT_NLOC) {
#if DEBUG
            if (DBGBIT(TRACEFLAG, TRACEBIT)) {
              fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to "
                                  "POINTER symbol %d:%s in std:%d\n pointer "
                                  "may point to globally allocated memory, "
                                  "target may point to nonlocal\n",
                      ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                      SYMNAME(targetsptr), targetstdx);
            }
#endif
            return TRUE;
          }
          break;
        case TT_CON:
          /* NULL pointer doesn't conflict */
          break;
        case TT_NLOC:
          /* conflicts with nonlocal, anon, gdyn, any nonlocal symbol */
          switch (FPTE_TYPE(targetpte)) {
          case TT_NLOC:
          case TT_GDYN:
          case TT_IGDYN:
          case TT_ANON:
#if DEBUG
            if (DBGBIT(TRACEFLAG, TRACEBIT)) {
              fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to "
                                  "POINTER symbol %d:%s in std:%d\n pointer "
                                  "may point to nonlocal, target may point to "
                                  "nonlocal or global dynamic or anonymous\n",
                      ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                      SYMNAME(targetsptr), targetstdx);
            }
#endif
            return TRUE;
          case TT_PSYM:
          case TT_ISYM:
            /* is targetsptr a nonlocal? */
            if (gbl.internal > 1 && !INTERNALG(FPTE_SPTR(targetpte))) {
#if DEBUG
              if (DBGBIT(TRACEFLAG, TRACEBIT)) {
                fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to "
                                    "POINTER symbol %d:%s in std:%d\n pointer "
                                    "may point to nonlocal, target may point "
                                    "to %d:%s which is from the host\n",
                        ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                        SYMNAME(targetsptr), targetstdx, FPTE_SPTR(targetpte),
                        SYMNAME(FPTE_SPTR(targetpte)));
              }
#endif
              return TRUE;
            } else {
              switch (SCG(FPTE_SPTR(targetpte))) {
              case SC_CMBLK:
              case SC_EXTERN:
#if DEBUG
                if (DBGBIT(TRACEFLAG, TRACEBIT)) {
                  fprintf(gbl.dbgfil, "pointer %d:%s in std:%d may point to "
                                      "POINTER symbol %d:%s in std:%d\n "
                                      "pointer may point to nonlocal, target "
                                      "may point to %d:%s which is external\n",
                          ptrsptr, SYMNAME(ptrsptr), ptrstdx, targetsptr,
                          SYMNAME(targetsptr), targetstdx, FPTE_SPTR(targetpte),
                          SYMNAME(FPTE_SPTR(targetpte)));
                }
#endif
                return TRUE;
              default:;
              }
            }
            break;
          }
          break;
        }
      }
    }
  }
  return FALSE;
} /* pta_conflict */

/*
 * used externally
 *  using the previously collected pointer target information,
 *  try to determine whether the pointer at ptrsptr always points to aligned
 *  data.
 * return TRUE if we know the pointer target is always quad aligned
 * return FALSE if we don't know or know otherwise
 *
 * arguments are the std indices for the pointer reference,
 * and the base SPTRs of the reference
 *
 * possible targets are:
 *  psym - precise symbol, with symbol sptr
 *         the target is aligned if the symbol is aligned and stride is one
 *  isym - imprecise symbol, perhaps a member of derived type, with base sptr
 *         unaligned
 *  anon - some anonymous symbol, we have no more information, but an
 * identifying tag
 *         this information comes from IPA
 *         unaligned, unless we enhance this information from IPA
 *  nloc - nonlocal targets - anything but a local symbol, used for initial
 * values
 *         unaligned
 *  ldyn - locally allocated dynamic memory, with unique tag for each allocate
 * point
 *         aligned or unaligned, depending on whether it is precise and stride
 * is one
 *  gdyn - dynamically allocated memory from somewhere outside this routine
 *         from IPA
 *         usually unaligned, unless we know it's precise and stride is one
 *  con  - used for NULLIFY statements, DEALLOCATE statements, essentially null
 * pointer
 *         shouldn't happen, treat as aligned
 *  unk  - unknown
 *         unaligned
 */
bool
pta_aligned(int ptrstdx, int ptrsptr)
{
  int ptrsrc, ptrpte, sptr;
  if (fpsrc.stg_base == NULL)
    return FALSE;
  /* see whether we have information about pointer targets for source ptrsptr at
   * statement ptrstdx */
  ptrsrc = STD_PTA(ptrstdx);
  for (; ptrsrc; ptrsrc = FPSRC_NEXT(ptrsrc)) {
    if (FPSRC_SPTR(ptrsrc) == ptrsptr)
      break;
  }
  if (ptrsrc == 0)
    return FALSE; /* we know nothing about what this pointer targets */

  for (ptrpte = FPSRC_PTELIST(ptrsrc); ptrpte; ptrpte = FPTE_NEXT(ptrpte)) {
    switch (FPTE_TYPE(ptrpte)) {
    case TT_PSYM:
      /* might be aligned if the symbol is */
      sptr = FPTE_SPTR(ptrpte);
      if (!QALNG(sptr))
        return FALSE;
      if (FPTE_STRIDE(ptrpte) != 1)
        return FALSE;
      break;
    case TT_GDYN:
      if (FPTE_STRIDE(ptrpte) != 1)
        return FALSE;
      break;
    case TT_LDYN:
      if (FPTE_STRIDE(ptrpte) != 1)
        return FALSE;
      break;
    case TT_CON:
      break;
    case TT_ISYM:  /* somewhere in the symbol */
    case TT_ANON:  /* don't know where */
    case TT_ILDYN: /* somewhere in the allocated space */
    case TT_IGDYN:
      return FALSE;
    case TT_NLOC:   /* some nonlocal symbol */
    case TT_UNK:    /* anywhere */
    case TT_UNINIT: /* anywhere */
      /* might point anywhere */
      return FALSE;
    case TT_IND: /* some indirect location, shouldn't happen here */
    case TT_IIND:
    case TT_MEM:
    case TT_GLOB:
    default:
      /* should not appear */
      return FALSE;
    }
  }
  /* no show stoppers found == no misaligned targets found */
  return TRUE;
} /* pta_aligned */

/*
 * used externally
 *  using previous collected pointer target information,
 *  determine whether the pointer target is always stride-1, meaning
 *  for instance that it can be passed directly to an assumed-shape argument
 *  without copying to a temp
 */
bool
pta_stride1(int ptrstdx, int ptrsptr)
{
  int ptrsrc, ptrpte;
  if (fpsrc.stg_base == NULL)
    return FALSE;
  /* see whether we have information about pointer targets for source ptrsptr at
   * statement ptrstdx */
  ptrsrc = STD_PTA(ptrstdx);
  for (; ptrsrc; ptrsrc = FPSRC_NEXT(ptrsrc)) {
    if (FPSRC_SPTR(ptrsrc) == ptrsptr)
      break;
  }
  if (ptrsrc == 0)
    return FALSE; /* we know nothing about what this pointer targets */

  for (ptrpte = FPSRC_PTELIST(ptrsrc); ptrpte; ptrpte = FPTE_NEXT(ptrpte)) {
    switch (FPTE_TYPE(ptrpte)) {
    case TT_PSYM:
    case TT_ISYM: /* somewhere in the symbol */
      if (FPTE_STRIDE(ptrpte) != 1)
        return FALSE;
      break;
    case TT_GDYN:
    case TT_IGDYN:
      if (FPTE_STRIDE(ptrpte) != 1)
        return FALSE;
      break;
    case TT_LDYN:
    case TT_ILDYN: /* somewhere in the allocated space */
      if (FPTE_STRIDE(ptrpte) != 1)
        return FALSE;
      break;
    case TT_CON:
      break;
    case TT_ANON:   /* don't know where */
    case TT_NLOC:   /* some nonlocal symbol */
    case TT_UNK:    /* anywhere */
    case TT_UNINIT: /* anywhere */
      /* might point anywhere */
      return FALSE;
    case TT_IND: /* some indirect location, shouldn't happen here */
    case TT_IIND:
    case TT_MEM:
    case TT_GLOB:
    default:
      /* should not appear */
      return FALSE;
    }
  }
  /* no show stoppers found == only stride-1 targets found */
  return TRUE;
} /* pta_stride1 */

/*
 * used externally
 *  using previous collected pointer target information,
 *  determine whether there is pointer target information for this
 * statement/sptr
 *  return a tag and id to describe it.
 *  tag may be one of:
 *   0 = no more information
 *   1 = unknown target
 *   2 = local dynamically allocated memory (tag disambiguates)
 *   3 = global dynamically allocated memory (tag disambiguates)
 *   4 = nonlocal memory (tag disambiguates)
 *   5 = precise symbol target (tag is sptr)
 *   6 = imprecise symbol target (tag is sptr)
 */
int
pta_target(int ptrstdx, int ptrsptr, int *ptag, int *pid)
{
  static int prev_func_count = 0, prevptrstdx = 0, prevptrsptr = 0, ptrsrc = 0,
             ptrpte = 0;
  int sptr;
  if (fpsrc.stg_base == NULL)
    return 0;
  if (prevptrstdx == ptrstdx && prevptrsptr == ptrsptr &&
      prev_func_count == gbl.func_count) {
    ptrpte = FPTE_NEXT(ptrpte);
  } else {
    prev_func_count = gbl.func_count;
    ptrpte = 0;
    prevptrstdx = 0;
    prevptrsptr = 0;
    /* see whether we have information about pointer targets for source ptrsptr
     * at
     * statement ptrstdx */
    ptrsrc = STD_PTA(ptrstdx);
    for (; ptrsrc; ptrsrc = FPSRC_NEXT(ptrsrc)) {
      if (FPSRC_SPTR(ptrsrc) == ptrsptr)
        break;
    }
    if (ptrsrc == 0) {
      return 0; /* we know nothing about what this pointer targets */
    }
    prevptrstdx = ptrstdx;
    prevptrsptr = ptrsptr;
    ptrpte = FPSRC_PTELIST(ptrsrc);
  }

  if (ptrpte == 0) {
    prevptrstdx = 0;
    prevptrsptr = 0;
    return 0; /* we know nothing about what this pointer targets */
  }

  switch (FPTE_TYPE(ptrpte)) {
  case TT_PSYM:
    *ptag = 5;
    *pid = FPTE_SPTR(ptrpte);
    return 1;
  case TT_ISYM: /* somewhere in the symbol */
    *ptag = 6;
    *pid = FPTE_SPTR(ptrpte);
    return 1;
  case TT_GDYN:
  case TT_IGDYN:
    *ptag = 3;
    *pid = FPTE_VAL(ptrpte);
    return 1;
  case TT_LDYN:
  case TT_ILDYN: /* somewhere in the allocated space */
    *ptag = 2;
    *pid = FPTE_VAL(ptrpte);
    return 1;
  case TT_CON:
    *ptag = 1;
    *pid = 0;
    return 1;
  case TT_ANON:   /* don't know where */
  case TT_NLOC:   /* some nonlocal symbol */
  case TT_UNK:    /* anywhere */
  case TT_UNINIT: /* anywhere */
    *ptag = 1;
    *pid = 0;
    return 1;
  case TT_IND: /* some indirect location, shouldn't happen here */
  case TT_IIND:
  case TT_MEM:
  case TT_GLOB:
  default:
    *ptag = 1;
    *pid = 0;
    return 1;
  }
} /* pta_target */

#undef TRACEFLAG
#undef TRACEBIT
#define TRACEFLAG 10
#define TRACEBIT 0x100000

/*
 * allocate storage
 *  pointer source descriptor, with hash table
 *  temporary pointer descriptors
 *  pointer assignments
 *  list of pointer assignments for stmts
 */
static void
init_points_to_anal(void)
{
  int savex6, a;
  STG_ALLOC(gpte, 100);
  gpte.xstg_free = TTE_NULL;
  gpte.stg_avail = 2;
  /* entry zero is TPTE_UNK */
  STG_CLEAR_ALL(gpte);

  STG_ALLOC(apte, 100);
  BZERO(aptehsh, int, APTEHSZ);

  a = get_apte(TT_UNK, 0, 0, 0);
  TPTE_APTEX(TPTE_UNK) = a;
  TPTE_NEXT(TPTE_UNK) = TPTE_NULL;

  a = get_apte(TT_UNINIT, 0, 0, 0);
  TPTE_APTEX(TPTE_UNINIT) = a;
  TPTE_NEXT(TPTE_UNINIT) = TPTE_NULL;

  STG_ALLOC(gpsd, nmeb.stg_avail < 2 ? 2 : nmeb.stg_avail);
  BZERO(gpsd.stg_base, PSD, 2);
  BZERO(psdhsh, int, PSDHSZ);
  gpsd.stg_avail = 2;
  PSD_TYPE(1) = TT_UNINIT;
  PSD_TYPE(0) = TT_UNK;
  gpsd.nslots = 1;
  gpsd.slot = NULL;

  STG_ALLOC(gtpd, 20);
  gtpd.stg_avail = 3;
  STG_CLEAR_ALL(gtpd);
  TTYPE(2) = TT_GLOB;
  TTYPE(1) = TT_UNINIT;
  TLINK(1) = 1;
  TTYPE(0) = TT_UNK;

  STG_ALLOC(as, 100);

  STG_ALLOC(ganon, 20);
  BZERO(ganon.stg_base, int, 2);

  STG_ALLOC(gdyn, 20);
  BZERO(gdyn.stg_base, int, 2);
  gdyn.local_dyn = 1;

  FIRSTAS(0) = 0;
} /* init_points_to_anal */

/*
 * allocate storage
 *  flow graph
 *  reverse depth-first ordering of flow graph nodes
 */
static void
init_points_to_prop(void)
{
  int savex6;

  savex6 = flg.x[6]; /* disable flow graph changes here */
  flg.x[6] |= 0x80000000;
  optshrd_init();
  flowgraph();
  flg.x[6] = savex6;
  NEW(rdfo, int, opt.num_nodes + 1);
  NEW(rdfonum, int, opt.num_nodes + 1);
  BZERO(rdfonum, int, opt.num_nodes + 1);
  rdfocount = 0;
  buildrdfo(VTX_NODE(1));
  gpte.save_stg_avail = gpte.stg_avail;
  gpte.save_stg_free = gpte.xstg_free;
} /* init_points_to_prop */

/*
 * free storage
 */
static void
fini_points_to_anal(void)
{
  STG_DELETE(gtpd);
} /* fini_points_to_anal */

/*
 * free storage
 */
static void
fini_points_to_prop(void)
{
  if (nodeoffset) {
    FREE(nodeoffset);
    nodeoffset = NULL;
  }
  STG_DELETE(head);
  if (localhead) {
    FREE(localhead);
    localhead = NULL;
  }
  if (gpsd.slot) {
    FREE(gpsd.slot);
    gpsd.slot = NULL;
  }
  FREE(rdfonum);
  rdfonum = NULL;
  FREE(rdfo);
  rdfo = NULL;

  optshrd_end();
  gpte.stg_avail = gpte.save_stg_avail;
  gpte.xstg_free = gpte.save_stg_free;
} /* fini_points_to_prop */

/*
 * free storage
 */
void
fini_points_to_all(void)
{
  STG_DELETE(gdyn);
  STG_DELETE(ganon);
  STG_DELETE(as);
  STG_DELETE(gtpd);

  STG_DELETE(gpsd);
  STG_DELETE(apte);
  STG_DELETE(gpte);
} /* fini_points_to_all */

/*
 * collect info and create the pointer pseudo assignments for later propagation
 */
void
points_to_anal(void)
{
  int stdx, a;
#if DEBUG
  if (gbl.dbgfil == NULL)
    gbl.dbgfil = stderr;
#endif
  init_points_to_anal();

  /* create a global pointer source descriptor */
  /* this is the pseudo-variable to collect any anonymous global changes */
  add_psd(0, TT_GLOB, 0, 0, 1);
  /* find the pointer assignments for each of the statements */
  for (stdx = STD_NEXT(0); stdx; stdx = STD_NEXT(stdx)) {
    find_pointer_assignments_f90(stdx);
  }
/* ### here, we should be creating initialization pseudo-assignments
 * to correspond to the initial values of globals or function arguments */
  /* clean up */
  fini_points_to_anal();
  if (as.stg_avail == 1) {
    /* nothing to learn */
    Trace(("pointer target analysis has no pointer assignments\n"));
    return;
  }
#if DEBUG
  if (DBGBIT(TRACEFLAG, TRACEBIT)) {
    if (FIRSTAS(0)) {
      fprintf(gbl.dbgfil, "\nstmt:%d pointer assignments\n", 0);
      for (a = FIRSTAS(0); a > 0; a = ASNEXT(a)) {
        putassign(a);
      }
    }
    for (stdx = STD_NEXT(0); stdx; stdx = STD_NEXT(stdx)) {
      if (FIRSTAS(stdx)) {
        fprintf(gbl.dbgfil, "\nnode:%d pointer assignments\n", stdx);
        for (a = FIRSTAS(stdx); a > 0; a = ASNEXT(a)) {
          putassign(a);
        }
      }
    }
    fprintf(gbl.dbgfil, "\n");
    fprintf(gbl.dbgfil,
            "POINTSTO - %5d NME, %5d PSD, %5d SLOTS, %5d APTE, %5d BLOCKS\n",
            nmeb.stg_avail, gpsd.stg_avail, gpsd.nslots, apte.stg_avail,
            opt.num_nodes);
  }
#endif
} /* points_to_anal */

/** \brief Do dataflow analysis to determine pointer target information
    store pointer target information at loads and stores

    - build flow graph
    - build reverse depth-first ordering
    - build pseudo-assignments to represent pointer modifications
    - use data-flow analysis to propagate pointer information around flow graph
    - modify the ILI/NME to represent the propagated information

    For F90.
 */
void
points_to(void)
{
  int r, v, rdfohigh, nextrdfohigh, rdfolow, nextrdfolow, newinfo;
  PSI_P succ;
  int sl, psdx, offset, iteration, asx;
  int stdx, cstdx, change;

  /* initialize */
  init_points_to_prop();

  /* can we afford to build the data flow equations?
   * we will need a word for each critical basic block for a
   * pointer target list head for each PSD; also a structure to
   * to store lists of actual pointer targets */
  head.stg_size = opt.num_nodes * gpsd.nslots + 1;
  if (head.stg_size > 1000000) {
    /* abort */
    Trace(("pointer target analysis is too expensive, abort\n"));
    fini_points_to_anal();
    return;
  }
  STG_ALLOC(head, head.stg_size);
  NEW(nodeoffset, int, opt.num_nodes + 1);
  BZERO(nodeoffset, int, opt.num_nodes + 1);
  NEW(localhead, int, gpsd.nslots + 1);
  NEW(gpsd.slot, int, gpsd.nslots + 1);
  BZERO(gpsd.slot, int, gpsd.nslots + 1);

  /* assign a slot number to each pointer, called a PSD or pointer source
   * descriptor.
   * For Fortran, these are pretty simple */
  for (psdx = 1; psdx < gpsd.stg_avail; ++psdx) {
    if (PSD_SLOT(psdx))
      SLOT(PSD_SLOT(psdx)) = psdx;
  }

  offset = 1;
  /* to simplify memory allocation, we allocate one big vector to hold
   * a matrix of information.  Here, we give the index into the vector
   * for the information for each flow graph node */
  /* fill in nodeoffset */
  for (r = rdfocount; r > 0; --r) {
    v = RDFO(r);
    nodeoffset[v] = offset;
    offset += gpsd.nslots;
    /* default information is 'TOP', points to nothing */
    for (sl = 1; sl < gpsd.nslots; ++sl)
      HEAD(v, sl) = TTE_NULL;
  }
  v = RDFO(rdfocount); /* entry node */
                       /*
                        * interpret the init assignments at the start node
                        * Start out by assuming the pointers are all empty
                        */
  for (sl = 0; sl < gpsd.nslots; ++sl) {
    HEAD(v, sl) = TPTE_NULL;
    LHEAD(sl) = TPTE_NULL;
  }
  for (asx = FIRSTAS(0); asx > 0 && ASTYPE(asx) == AS_INIT; asx = ASNEXT(asx)) {
    interpret(asx);
  }
  /*
   * For any nonlocal pointers that have no initial information,
   * assume they start out pointing to any nonlocal
   */
  for (sl = 1; sl < gpsd.nslots; ++sl) {
    psdx = SLOT(sl);
    if (LHEAD(sl) != TPTE_NULL) {
      HEAD(v, sl) = LHEAD(sl);
    } else if (is_source_nonlocal(psdx)) {
      HEAD(v, sl) = get_pte(TT_NLOC, 0, 0, 0);
    } else {
      HEAD(v, sl) = TPTE_UNINIT;
    }
    /* reinitialize LHEAD */
    LHEAD(sl) = TPTE_NULL;
  }

  /* repeat until no changes, first iteration must visit all nodes */
  nextrdfohigh = rdfocount;
  nextrdfolow = 1;
  iteration = 0;
  do {
    ++iteration;
    rdfohigh = nextrdfohigh;
    rdfolow = nextrdfolow;
    nextrdfohigh = 0;
    nextrdfolow = rdfocount;
    Trace(("------------------------"));
    Trace(("iteration %d, node positions %d:%d", iteration, rdfohigh, rdfolow));
#if DEBUG
    check_pte("TPTE error: before iterating");
#endif
    /* visit each basic block
     * symbolically execute each assignment, see how it
     * affects the local pointer target information */
    for (r = rdfohigh; r >= rdfolow; --r) {
      v = RDFO(r);
      Trace(("%4d=r, fg:%d, bih:%d", r, v, FG_TO_BIH(v)));
      for (sl = 1; sl < gpsd.nslots; ++sl) {
        free_list_slot(sl);
        LHEAD(sl) = copy_list(HEAD(v, sl));
      }
#if DEBUG
      if (DBGBIT(TRACEFLAG, TRACEBIT)) {
        Trace(("before node %d block %d std %d:%d", v, FG_TO_BIH(v),
               FG_STDFIRST(v), FG_STDLAST(v)));
        puttargets();
      }
#endif
      for (stdx = FG_STDFIRST(v); stdx; stdx = STD_NEXT(stdx)) {
#if DEBUG
        if (DBGBIT(TRACEFLAG, TRACEBIT)) {
          dstdp(stdx);
        }
#endif
        for (asx = FIRSTAS(stdx); asx > 0; asx = ASNEXT(asx)) {
          interpret(asx);
        }
        if (stdx == FG_STDLAST(v))
          break;
      }
#if DEBUG
      if (DBGBIT(TRACEFLAG, TRACEBIT)) {
        Trace(("after node %d block %d", v, FG_TO_BIH(v)));
        puttargets();
      }
#endif
      for (succ = FG_SUCC(v); succ != PSI_P_NULL; succ = PSI_NEXT(succ)) {
        int s, sr;
        s = PSI_NODE(succ);
        Trace(("flow edge from node %d -> %d", v, s));
        if (1 /*critical(s)*/) {
          if (pte_changed(s)) {
            sr = RDFONUM(s);
            if (sr >= r && sr > nextrdfohigh) {
              /* must iterate again at least from sr */
              nextrdfohigh = sr;
              if (sr < nextrdfolow)
                nextrdfolow = sr;
            } else if (sr < rdfolow) {
              rdfolow = sr; /* keep going to 'sr' in this iteration */
            } else if (sr < nextrdfolow) {
              nextrdfolow = sr;
            }
          }
        }
      }
    }
    for (sl = 1; sl < gpsd.nslots; ++sl) {
      free_list_slot(sl);
      LHEAD(sl) = TTE_NULL;
    }
  } while (nextrdfohigh >= nextrdfolow);
#if DEBUG
  check_pte("TPTE error: done iterating");
  Trace(("POINTSTO - %5d NME, %5d PSD, %5d SLOTS, %5d APTE, %5d BLOCKS",
         nmeb.stg_avail, gpsd.stg_avail, gpsd.nslots, apte.stg_avail,
         opt.num_nodes));
#endif

  /* now modify the STDs */
  asx = 0;
  gcount.tot = 0;
  gcount.ntot = 0;
  f90_init();
  for (r = rdfocount; r >= 1; --r) {
    v = RDFO(r);
    Trace(("------------------------"));
    Trace(("insert %4d=r, fg:%d", r, v));
    for (sl = 1; sl < gpsd.nslots; ++sl) {
      free_list_slot(sl);
      LHEAD(sl) = copy_list(HEAD(v, sl));
    }
    if (asx > 0) {
      /* real error, didn't finish assignments from previous block */
      interr("pointsto: didn't finish all symbolic assignments", asx, ERR_Fatal);
    }
#if DEBUG
    if (DBGBIT(TRACEFLAG, TRACEBIT)) {
      Trace(("before node %d stds %d:%d", v, FG_STDFIRST(v), FG_STDLAST(v)));
      puttargets();
    }
#endif
    change = 1;
    for (stdx = FG_STDFIRST(v); stdx; stdx = STD_NEXT(stdx)) {
      set_std_pta(stdx, change);
#if DEBUG
      if (DBGBIT(TRACEFLAG, TRACEBIT)) {
        if (change) {
          putstdpta(stdx);
        } else {
          if (STD_PTA(stdx)) {
            fprintf(gbl.dbgfil, "pta(std=%d) same as std %d\n", stdx,
                    STD_PREV(stdx));
          }
        }
      }
#endif
      if (stdx == FG_STDLAST(v)) {
        asx = 0;
        break;
      }
      change = 0;
      for (asx = FIRSTAS(stdx); asx > 0; asx = ASNEXT(asx)) {
        if (ASTYPE(asx) != AS_INIT) {
          change = 1;
          interpret(asx);
        }
      }
    }
  }
  fini_points_to_prop();
#if DEBUG
  if (DBGBIT(TRACEFLAG, TRACEBIT)) {
    dstdps(0, 0);
  }
#endif
} /* points_to for F90 */

