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

/**
      \file rte.c

        This file contains functions that handle Fortran descriptors including
        array descriptors and type descriptors.
*/

#include "gbldefs.h"
#include "global.h"
#include "error.h"
#include "symtab.h"
#include "symutl.h"
#include "dtypeutl.h"
#include "machar.h"
#include "ast.h"
#include "semant.h"

#include <stdio.h>

#undef RTE_C
#define RTE_C
#include "rte.h"

static int get_per_dim_member(int, int, int);
static int get_header_member(int sdsc, int info);
static int divmod(LOGICAL bIsDiv, int astNum, int astDen, int astRecip,
                  int astShift, int std);
static char* mangleUnderscores(char* str);
static int lenWithUnderscores(char* str);

static int rte_sc = SC_LOCAL;
static int rte_class = 0;
static int rte_rank = 0;
static int rte_preserve_desc = 0;
static int rte_final_desc = 0;

void
set_descriptor_class(int class)
{
  /* We set rte_class when we want to create a type descriptor in
   * sym_get_sdescr().
   */
  rte_class = class;
}

void
set_descriptor_rank(int r)
{
  /* We set rte_rank when we want to create a descriptor for a pointer or
   * allocatable with room for its dynamic type. Used in sym_get_sdescr().
   */
  rte_rank = r;
}

void
set_preserve_descriptor(int d)
{
  /* We set rte_preserve_desc when we do not want to override an
   * existing descriptor for a particular symbol in sym_get_sdescr().
   * This typically occurs with descriptors associated with polymorphic
   * objects.
   */
  rte_preserve_desc = d;
}

void
set_final_descriptor(int d)
{
  /* We set this when we want to general a final procedure descriptor */
  rte_final_desc = d;
}

void
set_descriptor_sc(int sc)
{
  rte_sc = sc;
  set_symutl_sc(sc);
}

int
get_descriptor_sc(void)
{
  return rte_sc;
}

/* \brief Returns a length of a string in which we add 1 to length for each
 * underscore in the string.
 *
 * This function is used in sym_get_sdescr() to mangle a type descriptor
 * name. See also mangleUnderscores() below.
 *
 * \param str is the string we're processing.
 *
 * \returns length of str plus number of underscores.
 */
static int
lenWithUnderscores(char* str)
{
  int len;

  if (str == NULL)
    return 0;

  for(len=0; *str != '\0'; ++len, ++str) {
    if (*str == '_') {
      ++len;
    }
  }
  return len;
} 

/* \brief If a string has underscores, then we append an equal number of $ 
 * to the string.
 * 
 * This function is called by sym_get_sdescr(). It is used in the
 * construction of type descriptor and final descriptor symbol names.
 *
 * Internally, $ is used as part of a suffix to a symbol name. Distinguishing
 * between the prefix and suffix is required later, so we need to use $ and
 * not underscores here. The $ are changed to underscores just before the
 * symbol is written out in the backend.
 *
 * Appending extra $ prevents name conflicts between type descriptor
 * objects that have an underscore in their type name, host module name,
 * and/or subprogram name. 
 *
 * \param str is the string we are processing.
 *
 * \returns str if NULL or if no underscores are present. Otherwise, returns a
 * mangled name.
 */
static char*
mangleUnderscores(char* str)
{
  char * newStr;
  int i, len, lenscores;
    
  if (str == NULL || strchr(str, '_') == 0)
    return str;
  
  lenscores = lenWithUnderscores(str);
  newStr = getitem(0, lenscores+1);
  len = strlen(str);
  strcpy(newStr, str);
  for(i=len; i < lenscores; ++i) {
    newStr[i] = '$';
  }
  newStr[i] = '\0';
  return newStr;
}  

/* \brief Generate an array section descriptor, type descriptor, or final
 * descriptor.
 *
 * \param sptr is the symbol table pointer receiving the descriptor
 * 
 * \param is the rank for an array section descriptor.
 *
 * \returns the descriptor symbol table pointer.
 */
int
sym_get_sdescr(int sptr, int rank)
{
  int dtype;
  int ub;
  int sdsc, sdsc_mem;
  LOGICAL addit = FALSE;

  if (SDSCG(sptr) > NOSYM && rte_preserve_desc) {
    /* We must preserve descriptors associated with polymorphic objects */
    return SDSCG(sptr);
  }
  if (rank < 0) {
    dtype = DTYPEG(sptr);
    if (DTY(dtype) != TY_ARRAY) {
      rank = 0;
    } else {
      rank = ADD_NUMDIM(dtype);
      if (STYPEG(sptr) == ST_MEMBER &&
          (ALIGNG(sptr) || DISTG(sptr) || POINTERG(sptr) || ADD_DEFER(dtype) ||
           ADD_ADJARR(dtype) || ADD_NOBOUNDS(dtype))) {
        /* section descriptor must be added to derived type */
        addit = TRUE;
      }
    }
  }
  if ((CLASSG(sptr) || FINALIZEDG(sptr) /*|| ALLOCDESCG(sptr)*/) &&
      STYPEG(sptr) == ST_MEMBER && rte_rank) {
    addit = TRUE;
  }
  if (rank || rte_rank) {
    ub = DESC_HDR_LEN + rank * DESC_DIM_LEN;
  } else if (rank == 0 &&
             (DTY(DTYPEG(sptr)) == TY_CHAR || DTY(DTYPEG(sptr)) == TY_NCHAR)) {
    /* Do we really need 18 of them or just F90_Desc? */
    ub = DESC_HDR_LEN + 1 * DESC_DIM_LEN;
    if (STYPEG(sptr) == ST_MEMBER)
      addit = TRUE;
  } else if (DTY(DTYPEG(sptr)) == TY_PTR || IS_PROC_DUMMYG(sptr)) {
    /* special descriptor for procedure pointer */
    ub = DESC_HDR_LEN;
    if (STYPEG(sptr) == ST_MEMBER)
      addit = TRUE;
  } else {
    ub = 1;
  }

  dtype = get_array_dtype(1, astb.bnd.dtype);
  ADD_LWBD(dtype, 0) = 0;
  ADD_LWAST(dtype, 0) = astb.bnd.one;
  ADD_NUMELM(dtype) = ADD_UPBD(dtype, 0) = ADD_UPAST(dtype, 0) =
      mk_isz_cval(ub, astb.bnd.dtype);
  if (rte_class) {
    /* create type descriptor */
    int tag;
    int sc;

    assert(DTY(DTYPEG(sptr)) == TY_DERIVED,
           "sym_get_sdescr: making type descriptor for non-derived type", sptr,
           3);
    tag = DTY(DTYPEG(sptr) + 3);

    if (SDSCG(tag) && !rte_final_desc) {
      sdsc = SDSCG(tag);
      sc = SCG(sdsc);
    } else {
      char *desc_sym;
      int len = lenWithUnderscores(SYMNAME(gbl.currmod)) + 
                lenWithUnderscores(SYMNAME(SCOPEG(tag))) +
                lenWithUnderscores(SYMNAME(SCOPEG(gbl.currsub))) +
                lenWithUnderscores(SYMNAME(tag)) + 3 /* 3 for "$$\0" */; 
      desc_sym = getitem(0, len);
      if (strcmp(SYMNAME(gbl.currmod), SYMNAME(SCOPEG(tag))) == 0) {
        sprintf(desc_sym, "%s$%s",mangleUnderscores(SYMNAME(gbl.currmod)), 
                mangleUnderscores(SYMNAME(tag)));
        sc = SC_EXTERN;
      } else {
        if (gbl.currmod) {
          sprintf(desc_sym, "%s$%s$%s", mangleUnderscores(SYMNAME(gbl.currmod)),
                  mangleUnderscores(SYMNAME(SCOPEG(tag))), 
                  mangleUnderscores(SYMNAME(tag)));
          sc = SC_EXTERN;
        } else if (gbl.currsub) {
          sprintf(desc_sym, "%s$%s", mangleUnderscores(SYMNAME(gbl.currsub)), 
                  mangleUnderscores(SYMNAME(tag)));
          sc = SC_STATIC;
        } else {
          sprintf(desc_sym, "%s$%s", mangleUnderscores(SYMNAME(SCOPEG(tag))), 
                  mangleUnderscores(SYMNAME(tag)));
          sc = SC_STATIC;
        }
      }
      if (rte_final_desc) {
        /* create a special "final" descriptor used to store
         * final procedures of a type.
         */
        assert((strlen(desc_sym)+7) <= (MAXIDLEN+1), 
               "sym_get_sdescr: final desc name buffer overflow", MAXIDLEN, 4);
        sdsc = getsymf("%s$td$ft", desc_sym);
        HCCSYMP(sdsc, 1);
        HIDDENP(sdsc, 1); /* can't see this, if in the parser */
        SCOPEP(sdsc, stb.curr_scope);
        if (gbl.internal > 1)
          INTERNALP(sdsc, 1);
        FINALP(sdsc, 1);
        PARENTP(sdsc, DTYPEG(sptr));
      } else {
        assert((strlen(desc_sym)+3) <= (MAXIDLEN+1), 
               "sym_get_sdescr: type desc name buffer overflow", MAXIDLEN, 4);
        sdsc = get_next_sym(desc_sym, "td");
        SDSCP(tag, sdsc);
        if (get_struct_initialization_tree(DTYPEG(sptr))) {
          /* Ensure existence of template object if there's initializers. */
          (void) get_dtype_init_template(DTYPEG(sptr));
        }
      }
    }

    CLASSP(sdsc, 1);

    UNLPOLYP(sdsc, UNLPOLYG(tag));
    DTYPEP(sdsc, dtype);
    STYPEP(sdsc, ST_DESCRIPTOR);
    DCLDP(sdsc, 1);

    SCP(sdsc, sc);

    NODESCP(sdsc, 1);
    DESCARRAYP(sdsc, 1); /* used in detect.c */
    if (INTERNALG(sptr))
      INTERNALP(sdsc, 1);
    return sdsc;
  }
  sdsc_mem = 0;
  if (rte_rank && SDSCG(sptr)) {
    /* This occurs when we're passing in a non-polymorphic alloc/ptr object
     * to a polymorphic dummy argument. We want to preserve the descriptor
     * of the actual since it may contain associate, etc. info but we also
     * need to enlarge it to store its type in it. See the call to
     * get_static_descriptor() in check_alloc_ptr_type().
     */
    sdsc = SDSCG(sptr);
  } else {
    if (addit && !rte_rank) {
      sdsc = get_next_sym_dt(SYMNAME(sptr), "sd", ENCLDTYPEG(sptr));
    } else {
      sdsc = get_next_sym(SYMNAME(sptr), "sd");
    }
  }
  if (addit && rte_rank) {
    /* Create a type descriptor that will be added to derived type */
    sdsc_mem = get_next_sym_dt(SYMNAME(sptr), "td", ENCLDTYPEG(sptr));
    DTYPEP(sdsc_mem, dtype);
    STYPEP(sdsc_mem, ST_DESCRIPTOR);
    DCLDP(sdsc_mem, 1);
    SCP(sdsc_mem, rte_sc);
    NODESCP(sdsc_mem, 1);
    DESCARRAYP(sdsc_mem, 1); /* used in detect.c */
    CLASSP(sdsc_mem, 1);
    if (INTERNALG(sptr))
      INTERNALP(sdsc_mem, 1);
    if (rte_sc == SC_PRIVATE && ALLOCATTRG(sptr) && MIDNUMG(sptr) &&
        !SDSCG(sptr)) {
      if (SCG(MIDNUMG(sptr)) != SC_PRIVATE) {
        SCP(sdsc_mem, SC_LOCAL);
      }
    }
  }
  DTYPEP(sdsc, dtype);
  STYPEP(sdsc, ST_DESCRIPTOR);
  DCLDP(sdsc, 1);
  SCP(sdsc, rte_sc);
  NODESCP(sdsc, 1);
  DESCARRAYP(sdsc, 1); /* used in detect.c */
  if (DTY(DTYPEG(sptr)) == TY_PTR || IS_PROC_DUMMYG(sptr)) {
    IS_PROC_DESCRP(sdsc, 1);
  }
  if (INTERNALG(sptr))
    INTERNALP(sdsc, 1);
  if (rte_sc == SC_PRIVATE && ALLOCATTRG(sptr) && MIDNUMG(sptr) &&
      !SDSCG(sptr)) {
    if (SCG(MIDNUMG(sptr)) != SC_PRIVATE) {
      SCP(sdsc, SC_LOCAL);
    }
  }
#ifdef DEVICEG
  if (CUDAG(gbl.currsub) & (CUDA_DEVICE | CUDA_GLOBAL)) {
    /* copy the device bit to the descriptor */
    if (DEVICEG(sptr))
      DEVICEP(sdsc, 1);
  }
#endif

  if (sdsc_mem || addit) {
    /* Need to add type or static descriptor to data type after sptr */
    int dtype = ENCLDTYPEG(sptr);
    assert(STYPEG(sptr) == ST_MEMBER, "sym_get_sdescr: sptr must be member",
           sptr, 3);
    assert(dtype && DTY(dtype) == TY_DERIVED,
           "sym_get_sdescr: sptr is member without enclosing dtype", sptr, 3);
    if (dtype && DTY(dtype) == TY_DERIVED) {
      int mem;
      for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
        if (mem == sptr) {
          /* add descriptor to the datatype just after 'sptr' */
          int next = SYMLKG(sptr);
          int new_mem = sdsc_mem ? sdsc_mem : sdsc;
          STYPEP(new_mem, ST_MEMBER);
          ENCLDTYPEP(new_mem, dtype);
          SYMLKP(new_mem, SYMLKG(sptr));
          if (SYMLKG(sptr) > NOSYM)
            VARIANTP(SYMLKG(sptr), sdsc_mem); /* previous link */
          SYMLKP(sptr, new_mem);
          VARIANTP(new_mem, sptr);
          SCP(new_mem, SC_NONE);
          break;
        }
      }
      assert(mem == sptr,
             "sym_get_sdescr: sptr not member of its enclosing derived type",
             sptr, 3);
    }
  }
  return sdsc;
} /* sym_get_sdescr */

int
sym_get_place_holder(char *basename, int dtype)
{
  int sptr;

  sptr = sym_get_scalar(basename, "pholder", dtype);
  return sptr;
}

void
get_static_descriptor(int sptr)
{
  int sdsc;

  sdsc = sym_get_sdescr(sptr, -1);
  SDSCP(sptr, sdsc);

  if (!is_procedure_ptr(sptr) && !IS_PROC_DUMMYG(sptr)) {
    NOMDCOMP(sdsc, 1);
    LNRZDP(sptr, 1);
  }
}

/*   sptr		   - base array
 *   MIDNUMG(sptr)	   - pointer to base array
 *   PTROFFG(sptr)	   - offset to base array  (optional)
 *   SECDSCG(DESCRG(sptr)) - base descriptor (desc)
 *   [ desc = SECDSCG(DESCRG(sptr)) ]
 *   MIDNUMG(desc)	   - pointer to descriptor
 *   PTROFFG(desc)	   - offset to descriptor
 */
void
get_all_descriptors(int sptr)
{
  int pvar;
  int ovar;
  int arrdsc;
  int desc;
  int ndim;
  int dtype, ast;
  int i;
  int s;
  ADSC *ad;

  /*
   * All associated variables created for the pointer object cannot appear
   * in the module common if the object is in the specification part of a
   * module.	A pointer common block will be created for the object.
   * If in a module, this common block is created by the module processing
   * and its member list contains these variables.  For a local object,
   * the pointer common block is created by astout by just emitting the
   * appropriate common statement.  To prevent the variables from appearing
   * in the module common, set their NOMDCOM ('not in module common') flags.
   */

  /* create pointer or use one already created if F77OUTPUT */
  pvar = MIDNUMG(sptr);
  if (pvar == 0 || pvar == NOSYM || CCSYMG(pvar)) {
    pvar = sym_get_ptr(sptr);
    MIDNUMP(sptr, pvar);
  }
  NOMDCOMP(pvar, 1);

  /* create offset */
  ovar = sym_get_offset(sptr);
  PTROFFP(sptr, ovar);
  NOMDCOMP(ovar, 1);

  ndim = rank_of_sym(sptr);

  if (STYPEG(sptr) == ST_MEMBER && SYMLKG(sptr) != pvar) {
    int dtype;
    dtype = ENCLDTYPEG(sptr);
    if (dtype) {
      int mem;
      for (mem = DTY(dtype + 1); mem > NOSYM && mem != sptr; mem = SYMLKG(mem))
        ;
      if (mem == sptr) {
        /* add 'pointer' to the derived type just after 'sptr' */
        int next = SYMLKG(sptr);
        SYMLKP(sptr, pvar);
        STYPEP(pvar, ST_MEMBER);
        ENCLDTYPEP(pvar, dtype);
        SYMLKP(pvar, next);
        VARIANTP(pvar, sptr);
        SCP(pvar, SC_NONE);
        if (next > NOSYM)
          VARIANTP(next, pvar);
        if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
          /* for arrays, put 'offset' there too */
          SYMLKP(pvar, ovar);
          STYPEP(ovar, ST_MEMBER);
          ENCLDTYPEP(ovar, dtype);
          SYMLKP(ovar, next);
          VARIANTP(ovar, pvar);
          SCP(ovar, SC_NONE);
          if (next > NOSYM)
            VARIANTP(next, ovar);
        }
      }
    }
  }
  if (DTY(DTYPEG(sptr)) != TY_ARRAY)
    return;

  /* create descriptor and pointer */
  trans_mkdescr(sptr);
  arrdsc = DESCRG(sptr);
  assert(SDSCG(sptr), "get_all_descriptors, need static descriptor", sptr, 2);
  SECDSCP(arrdsc, SDSCG(sptr));

  if (STYPEG(sptr) == ST_MEMBER) {
    /* don't change bounds of distributed member arrays unless
     * allocatable or pointer */
    if (!POINTERG(sptr) && !ALLOCG(sptr)) {
      return;
    }
  }

  /*
   * for the descriptor (whose storage class is SC_BASED), set its
   * 'not in module common' flag so that the module and interf processing
   * will ignore this 'based' symbol.  The module processing creates the
   * pointer common block early, but if pointers aren't allowed in the output,
   * the descriptor needs to be added to the beginning of the common.  The
   * descriptor cannot be added to the common by the module processing, since
   * its storage class is SC_BASED; astout will need to write the necessary
   * common statement.
   */

  /* change the bounds of the array and its descriptor */
  ad = AD_DPTR(DTYPEG(sptr));
  DESCUSEDP(sptr, 1);
  ast_visit(1, 1);
  for (i = 0; i < ndim; i++) {
    /* TBD it would be nice to zap the z_b... variables so their decls
     * do not appear in the output.
     */
    int oldast, a;

    oldast = AD_LWAST(ad, i);
    AD_LWAST(ad, i) = get_global_lower(SDSCG(sptr), i);
    if (oldast)
      ast_replace(oldast, AD_LWAST(ad, i));

    oldast = AD_UPAST(ad, i);
    a = get_extent(SDSCG(sptr), i);
    a = mk_binop(OP_SUB, a, mk_isz_cval(1, astb.bnd.dtype), astb.bnd.dtype);
    a = mk_binop(OP_ADD, AD_LWAST(ad, i), a, astb.bnd.dtype);
    AD_UPAST(ad, i) = a;
    if (oldast)
      ast_replace(oldast, AD_UPAST(ad, i));

    oldast = AD_EXTNTAST(ad, i);
    AD_EXTNTAST(ad, i) = get_extent(SDSCG(sptr), i);
    if (oldast)
      ast_replace(oldast, AD_EXTNTAST(ad, i));

    {
      AD_LWBD(ad, i) = AD_LWAST(ad, i);
      AD_UPBD(ad, i) = AD_UPAST(ad, i);
    }
  }
  for (i = 0; i < ndim; ++i) {
    AD_MLPYR(ad, i) = get_local_multiplier(SDSCG(sptr), i);
  }
  AD_NUMELM(ad) = get_desc_gsize(SDSCG(sptr));
  AD_ZBASE(ad) = get_xbase(SDSCG(sptr));
  ast = AD_ZBASE(ad);
  if (ast)
    AD_ZBASE(ad) = ast_rewrite(ast);
  ast_unvisit();
}

int
get_multiplier_index(int dim)
{
  return DESC_HDR_LEN + dim * DESC_DIM_LEN + DESC_DIM_LMULT;
}

int
get_global_lower_index(int dim)
{
  return DESC_HDR_LEN + dim * DESC_DIM_LEN + DESC_DIM_LOWER;
}

int
get_global_upper_index(int dim)
{
  return DESC_HDR_LEN + dim * DESC_DIM_LEN + DESC_DIM_UPPER;
}

int
get_global_extent_index(int dim)
{
  return DESC_HDR_LEN + dim * DESC_DIM_LEN + DESC_DIM_EXTENT;
}

int
get_section_stride_index(int dim)
{
  return DESC_HDR_LEN + dim * DESC_DIM_LEN + DESC_DIM_SSTRIDE;
}

int
get_section_offset_index(int dim)
{
  return DESC_HDR_LEN + dim * DESC_DIM_LEN + DESC_DIM_SOFFSET;
}

int
get_xbase_index(void)
{
  return DESC_HDR_LBASE;
}

int
get_xbase(int sdsc)
{
  return get_header_member(sdsc, DESC_HDR_LBASE);
}

int
get_gbase(int sdsc)
{
  return get_header_member(sdsc, DESC_HDR_GBASE);
}

int
get_gbase2(int sdsc)
{
  return get_header_member(sdsc, DESC_HDR_GBASE + 1);
}

int
get_kind(int sdsc)
{
  return get_header_member(sdsc, DESC_HDR_KIND);
}

int
get_byte_len(int sdsc)
{
  return get_header_member(sdsc, DESC_HDR_BYTE_LEN);
}

int
get_byte_len_indx(void)
{
  return DESC_HDR_BYTE_LEN;
}

int
get_local_multiplier(int sdsc, int dim)
{
  return get_per_dim_member(sdsc, dim, DESC_DIM_LMULT);
}

int
get_global_lower(int sdsc, int dim)
{
  return get_per_dim_member(sdsc, dim, DESC_DIM_LOWER);
}

int
get_global_upper(int sdsc, int dim)
{
  return get_per_dim_member(sdsc, dim, DESC_DIM_UPPER);
}

int
get_extent(int sdsc, int dim)
{
  return get_per_dim_member(sdsc, dim, DESC_DIM_EXTENT);
}

int
get_section_stride(int sym, int dim)
{
  return get_per_dim_member(sym, dim, DESC_DIM_SSTRIDE);
}

int
get_section_offset(int sym, int dim)
{
  return get_per_dim_member(sym, dim, DESC_DIM_SOFFSET);
}

int
get_local_lower(int sdsc, int dim)
{
  return get_global_lower(sdsc, dim);
}

int
get_local_upper(int sdsc, int dim)
{
  return get_global_upper(sdsc, dim);
}

int
get_owner_lower(int sdsc, int dim)
{
  return get_global_lower(sdsc, dim);
}

int
get_owner_upper(int sdsc, int dim)
{
  return get_global_upper(sdsc, dim);
}

int
get_heap_block(int sdsc)
{
  return astb.i0;
}

int
get_desc_rank(int sdsc)
{
  return get_header_member(sdsc, DESC_HDR_RANK);
}

int
get_desc_tag(int sdsc)
{
  return get_header_member(sdsc, DESC_HDR_TAG);
}

int
get_desc_flags(int sdsc)
{
  return get_header_member(sdsc, DESC_HDR_FLAGS);
}

int
get_desc_gsize_index(void)
{
  return DESC_HDR_GSIZE;
}

int
get_desc_gsize(int sdsc)
{
  return get_header_member(sdsc, DESC_HDR_GSIZE);
}

int
get_desc_lsize(int sdsc)
{
  return get_header_member(sdsc, DESC_HDR_LSIZE);
}

int
get_lsize_index(void)
{
  return DESC_HDR_LSIZE;
}

int
get_proc_base(int sdsc)
{
  return astb.i0;
}

int
get_proc_shape(int sdsc, int dim)
{
  return astb.i1;
}

int
get_proc_stride(int sdsc, int dim)
{
  return get_section_stride(sdsc, dim);
}

int
get_block_size(int sdsc, int dim)
{
  return astb.i0;
}

int
get_neg_ovlp(int sdsc, int dim)
{
  return astb.i0;
}

int
get_pos_ovlp(int sdsc, int dim)
{
  return astb.i0;
}

int
get_template_offset(int sdsc, int dim)
{
  return get_section_offset(sdsc, dim);
}

int
get_descriptor_len(int rank)
{
  return DESC_HDR_LEN + rank * DESC_DIM_LEN;
}

static int
get_header_member(int sdsc, int info)
{
  int ast;
  int subs[1];

#if DEBUG
  if (!sdsc)
    interr("get_header_member, blank static descriptor", 0, 3);
  else if (STYPEG(sdsc) != ST_ARRDSC && STYPEG(sdsc) != ST_DESCRIPTOR &&
           DTY(DTYPEG(sdsc)) != TY_ARRAY)
    interr("get_header_member, bad static descriptor", sdsc, 3);
#endif
  subs[0] = mk_isz_cval(info, astb.bnd.dtype);
  ast = mk_subscr(mk_id(sdsc), subs, 1, astb.bnd.dtype);
  return ast;
}


/** \brief Generate an AST for accessing a particular field in a descriptor
 *         header.
 *
 * Note: This is similar to get_header_member() above except it also 
 * operates on descriptors that are embedded in derived type objects.
 *
 * \param parent is the ast of the expression with the descriptor that
 *        we want to access. This is needed if the descriptor is embedded
 *        in a derived type object.
 * \param sdsc is the symbol table pointer of the descriptor we want to
 *        access.
 * \param info is the field we want to access in the descriptor.
 *
 * \return an ast expression of the descriptor access.
 */
int
get_header_member_with_parent(int parent, int sdsc, int info)
{
  int ast;
  int subs[1];

#if DEBUG
  if (!sdsc)
    interr("get_header_member, blank static descriptor", 0, 3);
  else if (STYPEG(sdsc) != ST_ARRDSC && STYPEG(sdsc) != ST_DESCRIPTOR &&
           DTY(DTYPEG(sdsc)) != TY_ARRAY)
    interr("get_header_member, bad static descriptor", sdsc, 3);
#endif
  subs[0] = mk_isz_cval(info, astb.bnd.dtype);
  ast = mk_subscr(check_member(parent, mk_id(sdsc)), subs, 1, astb.bnd.dtype);
  return ast;
}


static int
get_array_rank(int sdsc)
{
  int rank = 0;

  if (STYPEG(sdsc) == ST_ARRDSC) {
    rank = rank_of_sym(ARRAYG(sdsc));
  } else if (STYPEG(sdsc) == ST_DESCRIPTOR || STYPEG(sdsc) == ST_MEMBER) {
    int dtype = DTYPEG(sdsc);
    int ubast = AD_UPAST(AD_DPTR(dtype), 0);
    int ub;
    assert(DTY(dtype) == TY_ARRAY && A_TYPEG(ubast) == A_CNST,
           "get_array_rank: Invalid ST_DESCRIPTOR|ST_MEMBER dtype", DTY(dtype),
           0);
    ub = CONVAL2G(A_SPTRG(ubast));

    rank = (ub - (DESC_HDR_LEN + HPF_DESC_HDR_LEN)) /
           (DESC_DIM_LEN + HPF_DESC_DIM_LEN);
  } else {
    assert(0, "get_array_rank: Invalid descriptor type", STYPEG(sdsc), 0);
  }

  return rank;
}

static int
get_per_dim_member(int sdsc, int dim, int info)
{
  int ast;
  int subs[1];

#if DEBUG
  assert(sdsc && (STYPEG(sdsc) == ST_DESCRIPTOR || STYPEG(sdsc) == ST_ARRDSC ||
                  STYPEG(sdsc) == ST_MEMBER),
         "get_per_dim_member-illegal stat.desc", sdsc, 0);
#endif
  subs[0] =
      mk_isz_cval(DESC_HDR_LEN + dim * DESC_DIM_LEN + info, astb.bnd.dtype);
  ast = mk_subscr(mk_id(sdsc), subs, 1, astb.bnd.dtype);
  return ast;
}

/* If bIsDiv is TRUE, add statements to compute astNum/astDen before std.
 * If bIsDiv is FALSE, add statements to compute astNum%astDen before std.
 * astRecip is the reciprocal of astDen. If astShift is nonzero,
 * 2**astShift = astDen, and can be used to shift astNum.
 * Return an AST representing the result. */
static int
divmod(LOGICAL bIsDiv, int astNum, int astDen, int astRecip, int astShift,
       int std)
{
  int sptr;
  int astRes;
  int ast, ast1, astStmt;

  if (astDen == astb.i1)
    return astNum;
  if (astNum == astb.i0)
    return astNum;

  sptr = sym_get_scalar("r", "rte", DT_INT);
  astRes = mk_id(sptr);

  if (!XBIT(49, 0x01000000)) {
    /* ...not T3D/T3E target. */
    astStmt = mk_stmt(A_IFTHEN, 0);
    ast = mk_binop(OP_LT, astShift, astb.i0, DT_LOG);
    A_IFEXPRP(astStmt, ast);
    add_stmt_before(astStmt, std);

    ast = mk_binop(OP_DIV, astNum, astDen, DT_INT);
    if (!bIsDiv) {
      ast = mk_binop(OP_MUL, astDen, ast, DT_INT);
      ast = mk_binop(OP_SUB, astNum, ast, DT_INT);
    }
    astStmt = mk_assn_stmt(astRes, ast, DT_INT);
    add_stmt_before(astStmt, std);

    astStmt = mk_stmt(A_ELSE, 0);
    add_stmt_before(astStmt, std);

    ast1 = mk_unop(OP_SUB, astShift, DT_INT);
    ast = ast_intr(I_ISHFT, DT_INT, 2, astNum, ast1);
    if (!bIsDiv) {
      ast = ast_intr(I_ISHFT, DT_INT, 2, ast, astShift);
      ast = ast_intr(I_IEOR, DT_INT, 2, astNum, ast);
    }
    astStmt = mk_assn_stmt(astRes, ast, DT_INT);
    add_stmt_before(astStmt, std);

    astStmt = mk_stmt(A_ENDIF, 0);
    add_stmt_before(astStmt, std);
    return astRes;
  }
  astStmt = mk_stmt(A_IFTHEN, 0);
  ast = mk_binop(OP_EQ, astRecip, astb.i0, DT_LOG);
  A_IFEXPRP(astStmt, ast);
  add_stmt_before(astStmt, std);

  /* Denominator is 1. */
  if (bIsDiv)
    astStmt = mk_assn_stmt(astRes, astNum, DT_INT);
  else
    astStmt = mk_assn_stmt(astRes, astb.i0, DT_INT);
  add_stmt_before(astStmt, std);

  astStmt = mk_stmt(A_ELSE, 0);
  add_stmt_before(astStmt, std);

  sptr = sym_mkfunc_nodesc("int_mult_upper", DT_INT);
  ast = begin_call(A_FUNC, sptr, 2);
  add_arg(mk_default_int(astNum));
  add_arg(mk_default_int(astRecip));

  if (!bIsDiv) {
    ast = mk_binop(OP_MUL, astDen, ast, DT_INT);
    ast = mk_binop(OP_SUB, astNum, ast, DT_INT);
  }
  astStmt = mk_assn_stmt(astRes, ast, DT_INT);
  add_stmt_before(astStmt, std);

  astStmt = mk_stmt(A_ENDIF, 0);
  add_stmt_before(astStmt, std);

  return astRes;
}